module Data.Type.Internal.Derive
( deriveMeta
, declareMeta
)
where
import Data.Type.Kind
import Data.Type.Internal.Framework
import Control.Monad
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
deriveMeta
:: Name
-> Q [Dec]
deriveMeta 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
declareMeta kind name
TyConI (NewtypeD _ _ tyvars _ _) -> do
let kind = fromParameters $ map f tyvars
declareMeta kind name
_ -> do
qReport True $ "Cannot derive Meta for " ++ nameBase name ++ " (qReify not matched)."
return []
declareMeta
:: Kind
-> Name
-> Q [Dec]
declareMeta k name@(Name (occString->occ) (NameG _ (pkgString->pkg) (modString->mod))) = do
when (kindStars k > kindStarLimit) . fail $ "Cannot declare Meta for " ++ nameBase name ++ " (kind star limit exceeded)."
let tid = mkName $ "typeID" ++ kindName k
let wrap = mkName $ "Data.Type.Type" ++ kindName k
let meta = mkName $ "Data.Type.Meta" ++ kindName k
let cxts = cxt []
let hd = conT meta `appT` (conT name)
let body = foldl1 appE
[ varE 'makeTypeID
, stringE pkg
, stringE mod
, stringE occ
]
let funs = [ funD tid [clause [wildP] (normalB body) []] ]
instanceD cxts hd funs >>= return . \x -> [x]
declareMeta _ name = do
qReport True $ "Cannot declare Meta for " ++ nameBase name ++ " (name not matched)."
return []