module TypeInfo
( module Language.Haskell.TH
, module TypeInfo
) where
import Data.List
import Data.Maybe
import Data.Function
import qualified Language.Haskell.TH as TH
import Language.Haskell.TH (Name)
import Debug.Trace
data TypeDef = TypeDef
{ tsig :: Type
, tcons :: [Con]
, prim :: Bool
} deriving Show
data Con = Con
{ cname :: Name
, cargs :: [Type]
, rec :: Bool
} deriving Show
data Type
= Base Name
| Var Name
| App Type Type
deriving (Show, Eq, Ord)
instance Eq TypeDef where
(==) = (==) `on` tsig
apply :: Name -> [Type] -> Type
apply name = foldl App (Base name)
unapply :: Type -> (Name, [Type])
unapply (Base name) = (name, [])
unapply (Var name) = (name, [])
unapply (App l r) = (name, l' ++ [r])
where (name, l') = unapply l
typeName :: TypeDef -> Name
typeName = fst . unapply . tsig
typeArgs :: TypeDef -> [Type]
typeArgs = snd . unapply . tsig
flatten :: Type -> [Name]
flatten (Base name) = [name]
flatten (Var name) = [name]
flatten (App l r) = flatten l ++ flatten r
subtype :: Type -> Type -> Bool
subtype t t' | t == t' = True
subtype t (App l r) = subtype t l || subtype t r
subtype t t' = False
occurrences :: Type -> Con -> Int
occurrences ts con = countSat (==ts) (cargs con)
countSat :: (a -> Bool) -> [a] -> Int
countSat p = length . filter p
type TypeEnv = [TypeDef]
typeSigs :: TypeEnv -> [Type]
typeSigs = map tsig
consList :: TypeEnv -> [Name]
consList env = nub (map cname (concatMap tcons env))
involvedWith :: TypeDef -> [Type]
involvedWith = nub . concatMap cargs . tcons
getCon :: Name -> TypeDef -> Con
getCon cn t = fromMaybe
(error $ "getCon: looking for " ++ show cn ++ " in " ++ show (tsig t))
(find ((cn==) . cname) (tcons t))
conType :: TypeEnv -> Name -> TypeDef
conType env cn = fromMaybe
(error $ "conType: " ++ show cn ++ " not found in " ++ show env)
(find (any ((cn==) . cname) . tcons) env)
getSiblings :: Name -> TypeEnv -> [Con]
getSiblings cn env = tcons (conType env cn)
isSibling :: TypeEnv -> Name -> Name -> Bool
isSibling env = (==) `on` conType env
splitCons :: TypeEnv -> ([Con], [Con])
splitCons = partition rec . concatMap tcons
getRecursives :: TypeEnv -> [Con]
getRecursives = fst . splitCons
getTerminals :: TypeEnv -> [Con]
getTerminals = snd . splitCons
isTerminal :: TypeEnv -> Name -> Bool
isTerminal env cn = cn `elem` map cname (getTerminals env)