{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BangPatterns #-}
module Reification where
import Data.List
import Control.Monad.Extra
import Language.Haskell.TH hiding (Type, Con, prim)
import qualified Language.Haskell.TH as TH
import Megadeth
import TypeInfo
unsupported :: Show value => String -> value -> a
unsupported fun input = error $ fun ++ ": unsupported input: " ++ show input
reifyNameEnv :: Name -> Q TypeEnv
reifyNameEnv = reifyName >=> reifyInvolvedTypes
reifyTypeEnv :: Type -> Q TypeEnv
reifyTypeEnv = reifyType >=> reifyInvolvedTypes
reifyName :: Name -> Q TypeDef
reifyName name = reifyType (Base name)
reifyType :: Type -> Q TypeDef
reifyType this = do
let (name, args) = unapply this
reify name >>= \case
TyConI (DataD _ _ vars _ cons _) -> do
let vars' = map extractTVar vars
binds = zip vars' args
cons' = map (extractCon binds this) cons
fields = concatMap (concatMap flatten . cargs) cons'
emptyCon = Con { cname = name, cargs = [], rec = False }
primitive <- any isPrim <$> mapM reify fields
if primitive
then return
TypeDef { tsig = apply name [], tcons = [emptyCon], prim = True }
else return
TypeDef { tsig = this, tcons = cons', prim = False }
TyConI (NewtypeD _ _ vars _ con _ ) -> do
let vars' = map extractTVar vars
binds = zip vars' args
con' = extractCon binds this con
fields = concatMap flatten (cargs con')
emptyCon = Con { cname = name, cargs = [], rec = False }
primitive <- any isPrim <$> mapM reify fields
if primitive
then return
TypeDef { tsig = apply name [], tcons = [emptyCon], prim = True }
else return
TypeDef { tsig = this, tcons = [con'], prim = False }
TyConI (TySynD _ vars ty) -> do
let vars' = map extractTVar vars
binds = zip vars' args
realT = instantiate binds (extractType ty)
realDef <- reifyType realT
return realDef { tsig = this }
PrimTyConI {} -> return
TypeDef { tsig = apply name [], tcons = [], prim = True }
x -> unsupported "reifyType" x
extractTVar :: TyVarBndr -> Name
extractTVar (PlainTV tv) = tv
extractTVar (KindedTV tv _) = tv
extractCon :: [(Name, Type)] -> Type -> TH.Con -> Con
extractCon binds this (NormalC cn cas)
= Con { cname = cn, cargs = args, rec = this `elem` args }
where args = map (instantiate binds . extractType . snd) cas
extractCon binds this (InfixC lt op rt)
= Con { cname = op, cargs = args, rec = this `elem` args }
where args = map (instantiate binds . extractType . snd) [lt,rt]
extractCon binds this (RecC cn vbts)
= Con { cname = cn, cargs = args, rec = this `elem` args }
where args = map (instantiate binds . extractType . (\(_,_,x) -> x)) vbts
extractCon _ _ x = unsupported "extractCon" x
extractType :: TH.Type -> Type
extractType (AppT t1 t2) = App (extractType t1) (extractType t2)
extractType (ConT nm) = Base nm
extractType (VarT nm) = Var nm
extractType (TupleT s) = Base (TH.tupleTypeName s)
extractType ListT = Base ''[]
extractType x = unsupported "extractType" x
instantiate :: [(Name, Type)] -> Type -> Type
instantiate binds (Base name) = Base name
instantiate binds (App l r) = App (instantiate binds l) (instantiate binds r)
instantiate binds (Var v) = maybe (Var v) id (lookup v binds)
reifyInvolvedTypes :: TypeDef -> Q TypeEnv
reifyInvolvedTypes root = addMutRecLoops <$> reifyInvolvedTypes' [root] root
where
reifyInvolvedTypes' _ this | prim this = return [this]
reifyInvolvedTypes' visited this = do
let newTypes = involvedWith this \\ map tsig visited
newTypeDefs <- mapM reifyType newTypes
newReached <- mapM (reifyInvolvedTypes' (this:visited)) newTypeDefs
return (nub (this : concat newReached))
addMutRecLoops :: TypeEnv -> TypeEnv
addMutRecLoops env = map (addMutRecLoop env) env
where
addMutRecLoop env this
= this { tcons = map (setIsRecursive env (tsig this)) (tcons this) }
setIsRecursive env this con
| rec con = con
| reachableFrom env this con = con { rec = True }
| otherwise = con
reachableFrom env this con = any (reachableFrom' env this []) (cargs con)
reachableFrom' env this visited arg
| this `subtype` arg = True
| any (this `subtype`) argImmDefs = True
| otherwise = any (reachableFrom' env this (arg:visited)) nextArgs
where
argDef = find ((==arg) . tsig) env
argImmDefs = maybe [] involvedWith argDef
nextArgs = maybe [] (\def -> involvedWith def \\ visited) argDef