module Data.Typeable.FSDTypeRepLib (
FSDType,
FSDTypeRep,
FSDTypeCon,
fsdTy,
fsdTyCon,
fsdTyConApp,
fsdTupleTyCon,
fsdTyConName,
fsdUnArrowT,
fsdTyRep,
fsdTyConOf,
fsdTypeOf,
fsdSplitTyConApp,
type2FSDTypeRep
) where
import Data.Typeable
import Data.Typeable.TypeRepLib
import Data.Typeable.Internal
import Language.Haskell.TH (Type)
import Language.Haskell.TH.TypeLib (type2TypeRep)
newtype FSDTypeRep = FSDTypeRep' TypeRep deriving (Eq, Ord, Show)
newtype FSDTypeCon = FSDTypeCon' TyCon deriving (Eq, Ord, Show)
class FSDType a where
fsdTy :: a -> FSDTypeRep
instance FSDType TypeRep where
fsdTy tr = FSDTypeRep' $ typeRepNormalize tr
fsdTyRep :: FSDTypeRep -> TypeRep
fsdTyRep (FSDTypeRep' tr) = tr
fsdTyCon :: FSDTypeRep -> FSDTypeCon
fsdTyCon (FSDTypeRep' tr) = FSDTypeCon' $ typeRepTyCon tr
fsdUnTyCon :: FSDTypeCon -> TyCon
fsdUnTyCon (FSDTypeCon' tc) = tc
fsdSplitTyConApp :: FSDTypeRep -> (FSDTypeCon, [FSDTypeRep])
fsdSplitTyConApp (FSDTypeRep' fsdtr) = (FSDTypeCon' tc, map FSDTypeRep' tr) where
(tc, tr) = splitTyConApp fsdtr
fsdTyConOf :: (Typeable a) => a -> FSDTypeCon
fsdTyConOf = fsdTyCon.fsdTy.typeOf
fsdTypeOf :: (Typeable a) => a -> FSDTypeRep
fsdTypeOf = fsdTy.typeOf
fsdTyConApp :: FSDTypeCon -> [FSDTypeRep] -> FSDTypeRep
fsdTyConApp c trs = FSDTypeRep' $ mkTyConApp tc targs where
tc = fsdUnTyCon c
targs = map fsdTyRep trs
fsdTupleTyCon :: Int -> FSDTypeCon
fsdTupleTyCon nOuts = FSDTypeCon' $ mkTyCon3 "" "GHC.Tuple" $ '(':replicate (nOuts-1) ','++")"
fsdTyConName (FSDTypeCon' tc) = tyConName tc
fsdUnArrowT :: FSDTypeRep
-> ([FSDTypeRep], FSDTypeRep)
fsdUnArrowT rep
| repCon == arrowTyCon = let (args', ret') = fsdUnArrowT arrowArg2
in (arrowArg1:args', ret')
| otherwise = ([], rep)
where (repCon,~[arrowArg1,arrowArg2]) = fsdSplitTyConApp rep
arrowTyCon :: FSDTypeCon
arrowTyCon = fsdTyConOf (undefined :: () -> ())
type2FSDTypeRep :: Type -> Maybe FSDTypeRep
type2FSDTypeRep ftr = do
tr <- type2TypeRep ftr
Just $ fsdTy tr
tyConNormalize :: TyCon -> TyCon
tyConNormalize tc = mkTyCon3 "" (tyConModule tc) (tyConName tc)
typeRepNormalize :: TypeRep -> TypeRep
typeRepNormalize tr = mkPolyTyConApp tcN kindsN argsN
where
tc = typeRepTyCon tr
kinds = typeRepKinds tr
args = typeRepArgs tr
tcN = tyConNormalize tc
kindsN = map typeRepNormalize kinds
argsN = map typeRepNormalize args