module THLego.Instances
where
import THLego.Prelude
import THLego.Helpers
import Language.Haskell.TH
import qualified TemplateHaskell.Compat.V0208 as Compat
import qualified Data.Text as Text
import qualified THLego.Lambdas as Lambdas
isLabel :: TyLit -> Type -> Exp -> Dec
isLabel label repType fromLabelExp =
InstanceD Nothing [] headType [fromLabelDec]
where
headType =
multiAppT (ConT ''IsLabel) [LitT label, repType]
fromLabelDec =
FunD 'fromLabel [Clause [] body []]
where
body =
NormalB fromLabelExp
newtypeConstructorIsLabel :: TyLit -> Type -> Name -> Type -> Dec
newtypeConstructorIsLabel label ownerType conName memberType =
isLabel label repType fromLabelExp
where
repType =
arrowChainT [memberType] ownerType
fromLabelExp =
ConE conName
sumConstructorIsLabel :: TyLit -> Type -> Name -> [Type] -> Dec
sumConstructorIsLabel label ownerType conName memberTypes =
isLabel label repType fromLabelExp
where
repType =
arrowChainT memberTypes ownerType
fromLabelExp =
ConE conName
enumConstructorIsLabel :: TyLit -> Type -> Name -> Dec
enumConstructorIsLabel label ownerType conName =
isLabel label ownerType fromLabelExp
where
fromLabelExp =
ConE conName
tupleAdtConstructorIsLabel :: TyLit -> Type -> Name -> [Type] -> Dec
tupleAdtConstructorIsLabel label ownerType conName memberTypes =
isLabel label repType fromLabelExp
where
repType =
arrowChainT [appliedTupleT memberTypes] ownerType
fromLabelExp =
Lambdas.tupleToProduct conName (length memberTypes)
productAccessorIsLabel :: TyLit -> Type -> Type -> Name -> Int -> Int -> Dec
productAccessorIsLabel label ownerType projectionType conName numMembers offset =
isLabel label repType fromLabelExp
where
repType =
multiAppT ArrowT [ownerType, projectionType]
fromLabelExp =
Lambdas.productGetter conName numMembers offset
sumAccessorIsLabel :: TyLit -> Type -> Name -> [Type] -> Dec
sumAccessorIsLabel label ownerType conName memberTypes =
isLabel label repType fromLabelExp
where
repType =
multiAppT ArrowT [ownerType, projectionType]
where
projectionType =
AppT (ConT ''Maybe) (appliedTupleT memberTypes)
fromLabelExp =
Lambdas.adtConstructorNarrower conName (length memberTypes)
enumAccessorIsLabel :: TyLit -> Type -> Name -> Dec
enumAccessorIsLabel label ownerType conName =
isLabel label repType fromLabelExp
where
repType =
multiAppT ArrowT [ownerType, projectionType]
where
projectionType =
ConT ''Bool
fromLabelExp =
Lambdas.enumConstructorToBool conName
hasField :: TyLit -> Type -> Type -> [Clause] -> Dec
hasField fieldLabel ownerType projectionType getFieldFunClauses =
InstanceD Nothing [] headType [getFieldDec]
where
headType =
multiAppT (ConT ''HasField) [LitT fieldLabel, ownerType, projectionType]
getFieldDec =
FunD 'getField getFieldFunClauses
enumHasField :: TyLit -> Type -> Name -> Dec
enumHasField fieldLabel ownerType constructorName =
hasField fieldLabel ownerType projectionType getFieldFunClauses
where
projectionType =
ConT ''Bool
getFieldFunClauses =
[matching, unmatching]
where
matching =
Clause [ConP constructorName []] (NormalB bodyExp) []
where
bodyExp =
ConE 'True
unmatching =
Clause [WildP] (NormalB bodyExp) []
where
bodyExp =
ConE 'False
sumHasField :: TyLit -> Type -> Name -> [Type] -> Dec
sumHasField fieldLabel ownerType constructorName memberTypes =
hasField fieldLabel ownerType projectionType getFieldFunClauses
where
projectionType =
AppT (ConT ''Maybe) (appliedTupleOrSingletonT memberTypes)
getFieldFunClauses =
[matching, unmatching]
where
varNames =
enumFromTo 1 (length memberTypes) &
fmap (mkName . showChar '_' . show)
matching =
Clause [ConP constructorName pats] (NormalB bodyExp) []
where
pats =
fmap VarP varNames
bodyExp =
AppE (ConE 'Just) (appliedTupleE (fmap VarE varNames))
unmatching =
Clause [WildP] (NormalB bodyExp) []
where
bodyExp =
ConE 'Nothing
productHasField :: TyLit -> Type -> Type -> Name -> Int -> Int -> Dec
productHasField fieldLabel ownerType projectionType constructorName totalMemberTypes offset =
hasField fieldLabel ownerType projectionType getFieldFunClauses
where
getFieldFunClauses =
[Clause [ConP constructorName pats] (NormalB bodyExp) []]
where
pats =
replicate offset WildP <>
bool empty [VarP aName] (totalMemberTypes > 0) <>
replicate (totalMemberTypes - offset - 1) WildP
bodyExp =
VarE aName