module Data.Type.Typeable
( deriveTypeableFromMeta
, declareTypeableFromMeta
, convertTypeIDToTypeRep
) where
import Data.Type.Kind
import Data.Type.Internal.Framework
import Data.Type.Internal.Body as Data.Type
import Data.Type.Internal.TH
import Data.Typeable
import Control.Monad
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
deriveTypeableFromMeta
:: Name
-> Q [Dec]
deriveTypeableFromMeta name = do
info <- qReify name
let
f :: TyVarBndr -> Kind
f (PlainTV _) = StarK
f (KindedTV _ k) = k
case info of
TyConI (DataD _ _ tyvars _ _) -> do
let kind = fromParameters $ map f tyvars
declareTypeableFromMeta kind name
TyConI (NewtypeD _ _ tyvars _ _) -> do
let kind = fromParameters $ map f tyvars
declareTypeableFromMeta kind name
_ -> do
qReport True $ "Cannot derive Typeable from Meta for " ++ nameBase name ++ " (qReify not matched)."
return []
declareTypeableFromMeta
:: Kind
-> Name
-> Q [Dec]
declareTypeableFromMeta kind name@(Name (occString->occ) (NameG _ (pkgString->pkg) (modString->mod))) = do
let typeables = [''Typeable,''Typeable1,''Typeable2,''Typeable3,''Typeable4,''Typeable5,''Typeable6,''Typeable7]
let typeOfs = ['typeOf,'typeOf1,'typeOf2,'typeOf3,'typeOf4,'typeOf5,'typeOf6,'typeOf7]
let params = toParameters kind
let (length -> r1c, reverse -> rNs) = span (==StarK) $ reverse params
when (length rNs == 0) . fail $ "Cannot declare Typeable from Meta for " ++ occ ++ " (the type constructor is not at least rank 2)."
when (r1c > 7) . fail $ "Cannot declare Typeable from Meta for " ++ occ ++ " (the type constructor has more than 7 rank 1 parameters at the end)."
when (maximum (map kindStars rNs) > kindStarLimit) . fail $ "Cannot declare Typeable from Meta for " ++ occ ++ " (the type constructor has parameters that exceed kind star limit)."
let tid k = mkName $ "Data.Type.typeID" ++ kindName k
let wrap k = mkName $ "Data.Type.Type" ++ kindName k
let meta k = mkName $ "Data.Type.Meta" ++ kindName k
rNvs <- replicateM (length rNs) . fmap varT $ newName "rN"
let cxts = cxt [ classP (meta k) [v] | k <- rNs | v <- rNvs ]
let hd = conT (typeables!!r1c) `appT` (foldl1 appT (conT name : rNvs))
let rNtr k v = foldr1 appE
[ varE 'convertTypeIDToTypeRep
, varE (tid k)
, sigE (conE $ wrap k) (appT (conT $ wrap k) v)
]
let body = foldl1 appE
[ varE 'mkTyConApp
, varE 'mkTyCon `appE` stringE occ
, listE [ rNtr k v | k <- rNs | v <- rNvs ]
]
let funs = [ funD (typeOfs!!r1c) [clause [wildP] (normalB body) []] ]
instanceD cxts hd funs >>= return . \x -> [x]
declareMeta _ name = do
qReport True $ "Cannot declare Typeable from Meta for " ++ nameBase name ++ " (name not matched)."
return []
convertTypeIDToTypeRep :: TypeID -> TypeRep
convertTypeIDToTypeRep = mapTypeID (\_ _ occ -> mkTyConApp (mkTyCon occ) []) (\f p -> f `mkAppTy` p)