module Hoogle.DataBase.Aliases(
Aliases, createAliases, normAliases
) where
import Hoogle.Type.All
import qualified Data.Map as Map
import Hoogle.Store.All
import Data.Generics.Uniplate
import General.Base
import Safe
newtype Aliases = Aliases {fromAliases :: Map.Map String Alias}
instance Store Aliases where
put = put . fromAliases
get = get1 Aliases
instance Show Aliases where
show (Aliases mp) = unlines [ unwords $ "type" : s : vs ++ ["=", show t]
| (s,Alias vs t) <- Map.toList mp]
data Alias = Alias
{_args :: [String]
,rhs :: Type
}
deriving Typeable
instance Store Alias where
put (Alias a b) = put2 a b
get = get2 Alias
createAliases :: [Aliases] -> [Fact] -> Aliases
createAliases deps ti = mergeAliases (a:deps)
where
a = Aliases $ transitiveClosure $ Map.fromList
[ (name, Alias [v | TVar v <- args] rhs)
| FactAlias (TypeSig _ lhs) (TypeSig _ rhs) <- ti
, let (TLit name, args) = fromTApp lhs]
instance Monoid Aliases where
mempty = mergeAliases []
mappend x y = mergeAliases [x,y]
mconcat = mergeAliases
mergeAliases :: [Aliases] -> Aliases
mergeAliases [x] = x
mergeAliases xs = Aliases $ transitiveClosure $ Map.unions $ map fromAliases xs
transitiveClosure :: Map.Map String Alias -> Map.Map String Alias
transitiveClosure mp = Map.mapWithKey (\k x -> x{rhs = f [k] $ rhs x}) mp
where
f :: [String] -> Type -> Type
f seen t = case [(name,x) | (name,x) <- followAliases (Aliases mp) t, name `notElem` seen] of
[] -> t
(name,x):_ -> f (name:seen) x
followAliases :: Aliases -> Type -> [(String,Type)]
followAliases as t =
[ (s, gen x2)
| (x, gen) <- contexts t
, Just (s,x2) <- [followAlias as x]]
followAlias :: Aliases -> Type -> Maybe (String, Type)
followAlias (Aliases mp) (TApp (TLit x) xs)
| isJust m && length xs == length vs = Just (x, transform f rhs)
where m@ ~(Just (Alias vs rhs)) = Map.lookup x mp
rep = zip vs xs
f (TVar v) = lookupJustDef (TVar v) v rep
f x = x
followAlias as (TLit x) = followAlias as (TApp (TLit x) [])
followAlias _ _ = Nothing
normAliases :: Aliases -> Type -> ([String], Type)
normAliases as t = first (sort . nub) $ f t
where
f t = case followAlias as t of
Just (s,t) -> ([s],t)
Nothing -> (concat *** gen) $ unzip $ map f cs
where (cs, gen) = uniplate t