module Data.Express.Utils.Typeable
( tyArity
, unFunTy
, isFunTy
, argumentTy
, resultTy
, finalResultTy
, boolTy
, intTy
, orderingTy
, mkComparisonTy
, mkCompareTy
, funTyCon
, compareTy
, elementTy
, typesIn
, typesInList
, (->::)
, module Data.Typeable
)
where
import Data.Typeable
import Data.Monoid ((<>))
import Data.Express.Utils.List
compareTy :: TypeRep -> TypeRep -> Ordering
compareTy t1 t2 | t1 == t2 = EQ
compareTy t1 t2 = tyArity t1 `compare` tyArity t2
<> length ts1 `compare` length ts2
<> show c1 `compare` show c2
<> foldr (<>) EQ (zipWith compareTy ts1 ts2)
where
(c1,ts1) = splitTyConApp t1
(c2,ts2) = splitTyConApp t2
tyArity :: TypeRep -> Int
tyArity t
| isFunTy t = 1 + tyArity (resultTy t)
| otherwise = 0
finalResultTy :: TypeRep -> TypeRep
finalResultTy t
| isFunTy t = finalResultTy (resultTy t)
| otherwise = t
unFunTy :: TypeRep -> (TypeRep,TypeRep)
unFunTy t
| isFunTy t = let (f,[a,b]) = splitTyConApp t in (a,b)
| otherwise = error $ "error (unFunTy): `" ++ show t ++ "` is not a function type"
argumentTy :: TypeRep -> TypeRep
argumentTy = fst . unFunTy
resultTy :: TypeRep -> TypeRep
resultTy = snd . unFunTy
elementTy :: TypeRep -> TypeRep
elementTy t
| isListTy t = let (_,[a]) = splitTyConApp t in a
| otherwise = error $ "error (elementTy): `" ++ show t ++ "' is not a list type"
boolTy :: TypeRep
boolTy = typeOf (undefined :: Bool)
intTy :: TypeRep
intTy = typeOf (undefined :: Int)
orderingTy :: TypeRep
orderingTy = typeOf (undefined :: Ordering)
funTyCon :: TyCon
funTyCon = typeRepTyCon $ typeOf (undefined :: () -> ())
listTyCon :: TyCon
listTyCon = typeRepTyCon $ typeOf (undefined :: [()])
isFunTy :: TypeRep -> Bool
isFunTy t =
case splitTyConApp t of
(con,[_,_]) | con == funTyCon -> True
_ -> False
isListTy :: TypeRep -> Bool
isListTy t = case splitTyConApp t of
(con,[_]) | con == listTyCon -> True
_ -> False
mkComparisonTy :: TypeRep -> TypeRep
mkComparisonTy a = a ->:: a ->:: boolTy
mkCompareTy :: TypeRep -> TypeRep
mkCompareTy a = a ->:: a ->:: orderingTy
typesIn :: TypeRep -> [TypeRep]
typesIn t = typesInList [t]
typesInList :: [TypeRep] -> [TypeRep]
typesInList ts = nubSortBy compareTy $ tins ts []
where
tin t = (t:) . tins (typeRepArgs t)
tins ts = foldr (.) id (map tin ts)
(->::) :: TypeRep -> TypeRep -> TypeRep
(->::) = mkFunTy
infixr 9 ->::