module THInstanceReification
(
reifyProperInstances,
isProperInstance,
typesSatisfyDecConstraints,
)
where
import THInstanceReification.Prelude.Basic
import THInstanceReification.Prelude.TH
import qualified Data.Map as Map
reifyProperInstances :: Name -> [Type] -> Q [InstanceDec]
reifyProperInstances n tl =
reifyInstances n tl >>= filterM (typesSatisfyDecConstraints tl)
isProperInstance :: Name -> [Type] -> Q Bool
isProperInstance n tl =
not . null <$> reifyProperInstances n tl
typesSatisfyDecConstraints :: [Type] -> InstanceDec -> Q Bool
typesSatisfyDecConstraints tl = \case
InstanceD _ context instanceType _ -> do
let ([ConT n], htl) = splitAt 1 $ reverse $ unapplyType instanceType
expandedTypes <- mapM expandSyns tl
expandedInstanceTypes <- mapM expandSyns htl
maybe
(fail $ "Unmatching amounts of types: " <> show expandedTypes <> ", " <>
show expandedInstanceTypes)
(analyze context)
(pair expandedTypes expandedInstanceTypes)
d -> fail $ "Not an instance dec: " <> show d
where
analyze :: Cxt -> [(Type, Type)] -> Q Bool
analyze context typeAssocs = and <$> mapM analyzePredicate context
where
actualTypeByVarName :: Name -> Maybe Type
actualTypeByVarName = \n -> Map.lookup n m
where
m = Map.fromList $ concat $ map accRecords $ typeAssocs
where
accRecords = \case
(AppT al ar, AppT hl hr) -> accRecords (al, hl) ++ accRecords (ar, hr)
(a, VarT n) -> [(n, a)]
_ -> []
analyzePredicate :: Pred -> Q Bool
analyzePredicate = \case
AppT (AppT EqualityT _) _ -> return True
AppT (ConT n) t ->
case replaceTypeVars actualTypeByVarName t of
Just t' -> isProperInstance n [t']
_ -> return False
_ -> return True
unapplyType :: Type -> [Type]
unapplyType = \case
AppT l r -> r : unapplyType l
t -> [t]
replaceTypeVars :: (Name -> Maybe Type) -> Type -> Maybe Type
replaceTypeVars f = \case
AppT l r -> AppT <$> replaceTypeVars f l <*> replaceTypeVars f r
VarT n -> f n
t -> Just t