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
import qualified THLego.Helpers as Helpers
isLabel :: TyLit -> Type -> Exp -> Dec
isLabel :: TyLit -> Type -> Exp -> Dec
isLabel TyLit
label Type
repType Exp
fromLabelExp =
Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [] Type
headType [Dec
fromLabelDec]
where
headType :: Type
headType =
Type -> Cxt -> Type
multiAppT (Name -> Type
ConT ''IsLabel) [TyLit -> Type
LitT TyLit
label, Type
repType]
fromLabelDec :: Dec
fromLabelDec =
Name -> [Clause] -> Dec
FunD 'fromLabel [[Pat] -> Body -> [Dec] -> Clause
Clause [] Body
body []]
where
body :: Body
body =
Exp -> Body
NormalB Exp
fromLabelExp
constructorIsLabel :: TyLit -> Type -> [Type] -> Exp -> Dec
constructorIsLabel :: TyLit -> Type -> Cxt -> Exp -> Dec
constructorIsLabel TyLit
label Type
ownerType Cxt
memberTypes Exp
fromLabelExp =
Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing Cxt
paramPreds Type
headType [Dec
fromLabelDec]
where
paramPreds :: Cxt
paramPreds =
Cxt
memberTypes
Cxt -> (Cxt -> Cxt) -> Cxt
forall a b. a -> (a -> b) -> b
& (Name -> Type -> Type) -> Cxt -> Cxt
forall a b. (Name -> a -> b) -> [a] -> [b]
Helpers.mapWithAlphabeticName (\ Name
n Type
t -> Type -> Cxt -> Type
multiAppT Type
EqualityT [Name -> Type
VarT Name
n, Type
t])
headType :: Type
headType =
Type -> Cxt -> Type
multiAppT (Name -> Type
ConT ''IsLabel) [TyLit -> Type
LitT TyLit
label, Type
repType]
where
repType :: Type
repType =
Cxt -> Type -> Type
arrowChainT Cxt
memberVarTypes Type
ownerType
where
memberVarTypes :: Cxt
memberVarTypes =
(Name -> Type -> Type) -> Cxt -> Cxt
forall a b. (Name -> a -> b) -> [a] -> [b]
Helpers.mapWithAlphabeticName (Type -> Type -> Type
forall a b. a -> b -> a
const (Type -> Type -> Type) -> (Name -> Type) -> Name -> Type -> Type
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Name -> Type
VarT) Cxt
paramPreds
fromLabelDec :: Dec
fromLabelDec =
Name -> [Clause] -> Dec
FunD 'fromLabel [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
fromLabelExp) []]
newtypeConstructorIsLabel :: TyLit -> Type -> Name -> Type -> Dec
newtypeConstructorIsLabel :: TyLit -> Type -> Name -> Type -> Dec
newtypeConstructorIsLabel TyLit
label Type
ownerType Name
conName Type
memberType =
TyLit -> Type -> Name -> Cxt -> Dec
sumConstructorIsLabel TyLit
label Type
ownerType Name
conName [Type
memberType]
sumConstructorIsLabel :: TyLit -> Type -> Name -> [Type] -> Dec
sumConstructorIsLabel :: TyLit -> Type -> Name -> Cxt -> Dec
sumConstructorIsLabel TyLit
label Type
ownerType Name
conName Cxt
memberTypes =
TyLit -> Type -> Cxt -> Exp -> Dec
constructorIsLabel TyLit
label Type
ownerType Cxt
memberTypes (Name -> Exp
ConE Name
conName)
enumConstructorIsLabel :: TyLit -> Type -> Name -> Dec
enumConstructorIsLabel :: TyLit -> Type -> Name -> Dec
enumConstructorIsLabel TyLit
label Type
ownerType Name
conName =
TyLit -> Type -> Name -> Cxt -> Dec
sumConstructorIsLabel TyLit
label Type
ownerType Name
conName []
tupleAdtConstructorIsLabel :: TyLit -> Type -> Name -> [Type] -> Dec
tupleAdtConstructorIsLabel :: TyLit -> Type -> Name -> Cxt -> Dec
tupleAdtConstructorIsLabel TyLit
label Type
ownerType Name
conName Cxt
memberTypes =
TyLit -> Type -> Cxt -> Exp -> Dec
constructorIsLabel TyLit
label Type
ownerType [Type
memberType] Exp
fromLabelExp
where
memberType :: Type
memberType =
Cxt -> Type
appliedTupleOrSingletonT Cxt
memberTypes
fromLabelExp :: Exp
fromLabelExp =
Name -> Int -> Exp
Lambdas.tupleToProduct Name
conName (Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
memberTypes)
mapperIsLabel ::
TyLit ->
Type ->
Type ->
Exp ->
Dec
mapperIsLabel :: TyLit -> Type -> Type -> Exp -> Dec
mapperIsLabel TyLit
label Type
ownerType Type
projectionType Exp
fromLabelExp =
Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [Type
memberPred] Type
headType [Dec
fromLabelDec]
where
projVarType :: Type
projVarType =
Name -> Type
VarT (String -> Name
mkName String
"mapper")
memberPred :: Type
memberPred =
Type -> Cxt -> Type
multiAppT Type
EqualityT [Type
projVarType, Type
projectionType]
headType :: Type
headType =
Type -> Cxt -> Type
multiAppT (Name -> Type
ConT ''IsLabel) [TyLit -> Type
LitT TyLit
label, Type
instanceType]
where
instanceType :: Type
instanceType =
Cxt -> Type -> Type
arrowChainT [Type
projVarType, Type
ownerType] Type
ownerType
fromLabelDec :: Dec
fromLabelDec =
Name -> [Clause] -> Dec
FunD 'fromLabel [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
fromLabelExp) []]
productMapperIsLabel ::
TyLit ->
Type ->
Type ->
Name ->
Int ->
Int ->
Dec
productMapperIsLabel :: TyLit -> Type -> Type -> Name -> Int -> Int -> Dec
productMapperIsLabel TyLit
label Type
ownerType Type
memberType Name
conName Int
totalMemberTypes Int
offset =
TyLit -> Type -> Type -> Exp -> Dec
mapperIsLabel TyLit
label Type
ownerType
(Type -> Cxt -> Type
multiAppT Type
ArrowT [Type
memberType, Type
memberType])
(Name -> Int -> Int -> Exp
Lambdas.productMapper Name
conName Int
totalMemberTypes Int
offset)
sumMapperIsLabel ::
TyLit ->
Type ->
Name ->
[Type] ->
Dec
sumMapperIsLabel :: TyLit -> Type -> Name -> Cxt -> Dec
sumMapperIsLabel TyLit
label Type
ownerType Name
conName Cxt
memberTypes =
TyLit -> Type -> Type -> Exp -> Dec
mapperIsLabel TyLit
label Type
ownerType
(Cxt -> Type -> Type
arrowChainT Cxt
memberTypes (Cxt -> Type
appliedTupleOrSingletonT Cxt
memberTypes))
(Name -> Int -> Exp
Lambdas.sumMapper Name
conName (Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
memberTypes))
accessorIsLabel :: TyLit -> Type -> Type -> Exp -> Dec
accessorIsLabel :: TyLit -> Type -> Type -> Exp -> Dec
accessorIsLabel TyLit
label Type
ownerType Type
projectionType Exp
fromLabelExp =
Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [Type
memberPred] Type
headType [Dec
fromLabelDec]
where
projVarType :: Type
projVarType =
Name -> Type
VarT Name
aName
memberPred :: Type
memberPred =
Type -> Cxt -> Type
multiAppT Type
EqualityT [Type
projVarType, Type
projectionType]
headType :: Type
headType =
Type -> Cxt -> Type
multiAppT (Name -> Type
ConT ''IsLabel) [TyLit -> Type
LitT TyLit
label, Type
instanceType]
where
instanceType :: Type
instanceType =
Type -> Cxt -> Type
multiAppT Type
ArrowT [Type
ownerType, Type
projVarType]
fromLabelDec :: Dec
fromLabelDec =
Name -> [Clause] -> Dec
FunD 'fromLabel [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
fromLabelExp) []]
productAccessorIsLabel ::
TyLit ->
Type ->
Type ->
Name ->
Int ->
Int ->
Dec
productAccessorIsLabel :: TyLit -> Type -> Type -> Name -> Int -> Int -> Dec
productAccessorIsLabel TyLit
label Type
ownerType Type
projectionType Name
conName Int
numMembers Int
offset =
TyLit -> Type -> Type -> Exp -> Dec
accessorIsLabel TyLit
label Type
ownerType Type
projectionType Exp
fromLabelExp
where
fromLabelExp :: Exp
fromLabelExp =
Name -> Int -> Int -> Exp
Lambdas.productGetter Name
conName Int
numMembers Int
offset
sumAccessorIsLabel :: TyLit -> Type -> Name -> [Type] -> Dec
sumAccessorIsLabel :: TyLit -> Type -> Name -> Cxt -> Dec
sumAccessorIsLabel TyLit
label Type
ownerType Name
conName Cxt
memberTypes =
TyLit -> Type -> Type -> Exp -> Dec
accessorIsLabel TyLit
label Type
ownerType Type
projectionType Exp
fromLabelExp
where
projectionType :: Type
projectionType =
Type -> Type -> Type
AppT (Name -> Type
ConT ''Maybe) (Cxt -> Type
appliedTupleOrSingletonT Cxt
memberTypes)
fromLabelExp :: Exp
fromLabelExp =
Name -> Int -> Exp
Lambdas.adtConstructorNarrower Name
conName (Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
memberTypes)
enumAccessorIsLabel :: TyLit -> Type -> Name -> Dec
enumAccessorIsLabel :: TyLit -> Type -> Name -> Dec
enumAccessorIsLabel TyLit
label Type
ownerType Name
conName =
TyLit -> Type -> Type -> Exp -> Dec
accessorIsLabel TyLit
label Type
ownerType Type
projectionType Exp
fromLabelExp
where
projectionType :: Type
projectionType =
Name -> Type
ConT ''Bool
fromLabelExp :: Exp
fromLabelExp =
Name -> Exp
Lambdas.enumConstructorToBool Name
conName
hasField :: TyLit -> Type -> Type -> [Clause] -> Dec
hasField :: TyLit -> Type -> Type -> [Clause] -> Dec
hasField TyLit
fieldLabel Type
ownerType Type
projectionType [Clause]
getFieldFunClauses =
Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [] Type
headType [Dec
getFieldDec]
where
headType :: Type
headType =
Type -> Cxt -> Type
multiAppT (Name -> Type
ConT ''HasField) [TyLit -> Type
LitT TyLit
fieldLabel, Type
ownerType, Type
projectionType]
getFieldDec :: Dec
getFieldDec =
Name -> [Clause] -> Dec
FunD 'getField [Clause]
getFieldFunClauses
enumHasField ::
TyLit ->
Type ->
Name ->
Dec
enumHasField :: TyLit -> Type -> Name -> Dec
enumHasField TyLit
fieldLabel Type
ownerType Name
constructorName =
TyLit -> Type -> Type -> [Clause] -> Dec
hasField TyLit
fieldLabel Type
ownerType Type
projectionType [Clause]
getFieldFunClauses
where
projectionType :: Type
projectionType =
Name -> Type
ConT ''Bool
getFieldFunClauses :: [Clause]
getFieldFunClauses =
[Clause
matching, Clause
unmatching]
where
matching :: Clause
matching =
[Pat] -> Body -> [Dec] -> Clause
Clause [Name -> [Pat] -> Pat
ConP Name
constructorName []] (Exp -> Body
NormalB Exp
bodyExp) []
where
bodyExp :: Exp
bodyExp =
Name -> Exp
ConE 'True
unmatching :: Clause
unmatching =
[Pat] -> Body -> [Dec] -> Clause
Clause [Pat
WildP] (Exp -> Body
NormalB Exp
bodyExp) []
where
bodyExp :: Exp
bodyExp =
Name -> Exp
ConE 'False
sumHasField ::
TyLit ->
Type ->
Name ->
[Type] ->
Dec
sumHasField :: TyLit -> Type -> Name -> Cxt -> Dec
sumHasField TyLit
fieldLabel Type
ownerType Name
constructorName Cxt
memberTypes =
TyLit -> Type -> Type -> [Clause] -> Dec
hasField TyLit
fieldLabel Type
ownerType Type
projectionType [Clause]
getFieldFunClauses
where
projectionType :: Type
projectionType =
Type -> Type -> Type
AppT (Name -> Type
ConT ''Maybe) (Cxt -> Type
appliedTupleOrSingletonT Cxt
memberTypes)
getFieldFunClauses :: [Clause]
getFieldFunClauses =
[Clause
matching, Clause
unmatching]
where
varNames :: [Name]
varNames =
Cxt
memberTypes Cxt -> (Cxt -> [Name]) -> [Name]
forall a b. a -> (a -> b) -> b
&
(Name -> Type -> Name) -> Cxt -> [Name]
forall a b. (Name -> a -> b) -> [a] -> [b]
mapWithAlphabeticName (Name -> Type -> Name
forall a b. a -> b -> a
const (Name -> Type -> Name) -> (Name -> Name) -> Name -> Type -> Name
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Name -> Name
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id)
matching :: Clause
matching =
[Pat] -> Body -> [Dec] -> Clause
Clause [Name -> [Pat] -> Pat
ConP Name
constructorName [Pat]
pats] (Exp -> Body
NormalB Exp
bodyExp) []
where
pats :: [Pat]
pats =
(Name -> Pat) -> [Name] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Pat
VarP [Name]
varNames
bodyExp :: Exp
bodyExp =
Exp -> Exp -> Exp
AppE (Name -> Exp
ConE 'Just) ([Exp] -> Exp
appliedTupleE ((Name -> Exp) -> [Name] -> [Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Exp
VarE [Name]
varNames))
unmatching :: Clause
unmatching =
[Pat] -> Body -> [Dec] -> Clause
Clause [Pat
WildP] (Exp -> Body
NormalB Exp
bodyExp) []
where
bodyExp :: Exp
bodyExp =
Name -> Exp
ConE 'Nothing
productHasField ::
TyLit ->
Type ->
Type ->
Name ->
Int ->
Int ->
Dec
productHasField :: TyLit -> Type -> Type -> Name -> Int -> Int -> Dec
productHasField TyLit
fieldLabel Type
ownerType Type
projectionType Name
constructorName Int
totalMemberTypes Int
offset =
TyLit -> Type -> Type -> [Clause] -> Dec
hasField TyLit
fieldLabel Type
ownerType Type
projectionType [Clause]
getFieldFunClauses
where
getFieldFunClauses :: [Clause]
getFieldFunClauses =
[[Pat] -> Body -> [Dec] -> Clause
Clause [Name -> [Pat] -> Pat
ConP Name
constructorName [Pat]
pats] (Exp -> Body
NormalB Exp
bodyExp) []]
where
pats :: [Pat]
pats =
Int -> Pat -> [Pat]
forall a. Int -> a -> [a]
replicate Int
offset Pat
WildP [Pat] -> [Pat] -> [Pat]
forall a. Semigroup a => a -> a -> a
<>
[Pat] -> [Pat] -> Bool -> [Pat]
forall a. a -> a -> Bool -> a
bool [Pat]
forall (f :: * -> *) a. Alternative f => f a
empty [Name -> Pat
VarP Name
aName] (Int
totalMemberTypes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) [Pat] -> [Pat] -> [Pat]
forall a. Semigroup a => a -> a -> a
<>
Int -> Pat -> [Pat]
forall a. Int -> a -> [a]
replicate (Int
totalMemberTypes Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Pat
WildP
bodyExp :: Exp
bodyExp =
Name -> Exp
VarE Name
aName