{-# LANGUAGE TemplateHaskellQuotes #-}
module Instance.Runtime.TH (
allGroundInstances, allGroundInstanceTypes,
promotedList,
) where
import Instance.Runtime
import TH.Utilities
import Language.Haskell.TH
import Data.List ( uncons )
allGroundInstances :: Q Type
-> Q Exp
allGroundInstances :: Q Type -> Q Exp
allGroundInstances Q Type
q_constraint = do
Type
constraint <- Q Type
q_constraint
[Type]
ground_instance_types <- Type -> Q [Type]
allGroundInstanceTypes Type
constraint
let ty_list :: Type
ty_list = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ Type
h Type
t -> Type
PromotedConsT Type -> Type -> Type
`AppT` Type
h Type -> Type -> Type
`AppT` Type
t) Type
PromotedNilT [Type]
ground_instance_types
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Exp
VarE 'instancesForInvisible Exp -> Type -> Exp
`AppTypeE` Type
ty_list)
allGroundInstanceTypes :: Type -> Q [Type]
allGroundInstanceTypes :: Type -> Q [Type]
allGroundInstanceTypes Type
constraint = do
(Name
class_name, [Type]
ct_args) <- case Type -> Maybe (Name, [Type])
typeToNamedCon Type
constraint of
Maybe (Name, [Type])
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail (forall a. Show a => a -> String
show (forall a. Ppr a => a -> Doc
ppr Type
constraint) forall a. [a] -> [a] -> [a]
++ String
" is not headed by a class.")
Just (Name
nm, [Type]
args) -> forall (m :: * -> *) a. Monad m => a -> m a
return (Name
nm, [Type]
args)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Type -> Q ()
checkForVariables [Type]
ct_args
[InstanceDec]
instances <- Name -> [Type] -> Q [InstanceDec]
reifyInstances Name
class_name ([Type]
ct_args forall a. [a] -> [a] -> [a]
++ [Name -> Type
VarT (String -> Name
mkName String
"a")])
forall (m :: * -> *) a. Monad m => a -> m a
return [ Type
ty
| InstanceD Maybe Overlap
_ [Type]
_ Type
instance_ty [InstanceDec]
_ <- [InstanceDec]
instances
, Just (Name
_, [Type]
args) <- forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Maybe (Name, [Type])
typeToNamedCon Type
instance_ty)
, Just (Type
ty, [Type]
_) <- forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. [a] -> Maybe (a, [a])
uncons (forall a. [a] -> [a]
reverse [Type]
args))
, Type -> Bool
hasNoVariables Type
ty
]
checkForVariables :: Type -> Q ()
checkForVariables :: Type -> Q ()
checkForVariables Type
ty
| Type -> Bool
hasNoVariables Type
ty = forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = String -> Q ()
reportError (String
"`" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Ppr a => a -> Doc
ppr Type
ty) forall a. [a] -> [a] -> [a]
++ String
"' has variables; this is not allowed.")
hasNoVariables :: Type -> Bool
hasNoVariables :: Type -> Bool
hasNoVariables (ForallT {}) = Bool
False
hasNoVariables (ForallVisT {}) = Bool
False
hasNoVariables (AppT Type
ty1 Type
ty2) = Type -> Bool
hasNoVariables Type
ty1 Bool -> Bool -> Bool
&& Type -> Bool
hasNoVariables Type
ty2
hasNoVariables (AppKindT Type
ty1 Type
ki2) = Type -> Bool
hasNoVariables Type
ty1 Bool -> Bool -> Bool
&& Type -> Bool
hasNoVariables Type
ki2
hasNoVariables (SigT Type
ty Type
ki) = Type -> Bool
hasNoVariables Type
ty Bool -> Bool -> Bool
&& Type -> Bool
hasNoVariables Type
ki
hasNoVariables (VarT {}) = Bool
False
hasNoVariables (ConT {}) = Bool
True
hasNoVariables (PromotedT {}) = Bool
True
hasNoVariables (InfixT Type
ty1 Name
_ Type
ty2) = Type -> Bool
hasNoVariables Type
ty1 Bool -> Bool -> Bool
&& Type -> Bool
hasNoVariables Type
ty2
hasNoVariables (UInfixT Type
ty1 Name
_ Type
ty2) = Type -> Bool
hasNoVariables Type
ty1 Bool -> Bool -> Bool
&& Type -> Bool
hasNoVariables Type
ty2
hasNoVariables (ParensT Type
ty) = Type -> Bool
hasNoVariables Type
ty
hasNoVariables (TupleT {}) = Bool
True
hasNoVariables (UnboxedTupleT {}) = Bool
True
hasNoVariables (UnboxedSumT {}) = Bool
True
hasNoVariables Type
ArrowT = Bool
True
hasNoVariables Type
MulArrowT = Bool
True
hasNoVariables Type
EqualityT = Bool
True
hasNoVariables Type
ListT = Bool
True
hasNoVariables (PromotedTupleT {}) = Bool
True
hasNoVariables Type
PromotedConsT = Bool
True
hasNoVariables Type
PromotedNilT = Bool
True
hasNoVariables Type
StarT = Bool
True
hasNoVariables Type
ConstraintT = Bool
True
hasNoVariables (LitT {}) = Bool
True
hasNoVariables Type
WildCardT = Bool
True
hasNoVariables (ImplicitParamT String
_ Type
ty) = Type -> Bool
hasNoVariables Type
ty
promotedList :: [Type] -> Type
promotedList :: [Type] -> Type
promotedList = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Type
h Type
t -> Type
PromotedConsT Type -> Type -> Type
`AppT` Type
h Type -> Type -> Type
`AppT` Type
t) Type
PromotedNilT