module THLego.Lambdas
where
import THLego.Prelude
import THLego.Helpers
import Language.Haskell.TH
import qualified TemplateHaskell.Compat.V0208 as Compat
matcher :: [Match] -> Exp
matcher :: [Match] -> Exp
matcher [Match]
matches =
[Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
aName] (Exp -> [Match] -> Exp
CaseE (Name -> Exp
VarE Name
aName) [Match]
matches)
productGetter ::
Name ->
Int ->
Int ->
Exp
productGetter :: Name -> Int -> Int -> Exp
productGetter Name
conName Int
numMembers Int
index =
[Pat] -> Exp -> Exp
LamE [Pat
pat] Exp
exp
where
varName :: Name
varName =
Int -> Name
alphabeticIndexName Int
index
pat :: Pat
pat =
Name -> [Pat] -> Pat
ConP Name
conName [Pat]
pats
where
pats :: [Pat]
pats =
Int -> Pat -> [Pat]
forall a. Int -> a -> [a]
replicate Int
index Pat
WildP [Pat] -> [Pat] -> [Pat]
forall a. Semigroup a => a -> a -> a
<>
Pat -> [Pat]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Pat
VarP Name
varName) [Pat] -> [Pat] -> [Pat]
forall a. Semigroup a => a -> a -> a
<>
Int -> Pat -> [Pat]
forall a. Int -> a -> [a]
replicate (Int
numMembers Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
index Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Pat
WildP
exp :: Exp
exp =
Name -> Exp
VarE Name
varName
productSetter ::
Name ->
Int ->
Int ->
Exp
productSetter :: Name -> Int -> Int -> Exp
productSetter Name
conName Int
numMembers Int
index =
[Pat] -> Exp -> Exp
LamE [Pat
stateP, Pat
valP] Exp
exp
where
memberName :: Name
memberName =
Int -> Name
alphabeticIndexName Int
index
memberNames :: [Name]
memberNames =
(Int -> Name) -> [Int] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Name
alphabeticIndexName (Int -> Int -> [Int]
forall a. Enum a => a -> a -> [a]
enumFromTo Int
0 (Int -> Int
forall a. Enum a => a -> a
pred Int
numMembers))
stateP :: Pat
stateP =
Name -> [Pat] -> Pat
ConP Name
conName [Pat]
pats
where
pats :: [Pat]
pats =
([Name]
memberNames [Name] -> ([Name] -> [Name]) -> [Name]
forall a b. a -> (a -> b) -> b
& Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
index [Name] -> ([Name] -> [Pat]) -> [Pat]
forall a b. a -> (a -> b) -> b
& (Name -> Pat) -> [Name] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Pat
VarP) [Pat] -> [Pat] -> [Pat]
forall a. Semigroup a => a -> a -> a
<>
[Pat
WildP] [Pat] -> [Pat] -> [Pat]
forall a. Semigroup a => a -> a -> a
<>
([Name]
memberNames [Name] -> ([Name] -> [Name]) -> [Name]
forall a b. a -> (a -> b) -> b
& Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
drop (Int -> Int
forall a. Enum a => a -> a
succ Int
index) [Name] -> ([Name] -> [Pat]) -> [Pat]
forall a b. a -> (a -> b) -> b
& (Name -> Pat) -> [Name] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Pat
VarP)
valP :: Pat
valP =
Name -> Pat
VarP Name
memberName
exp :: Exp
exp =
(Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Exp -> Exp -> Exp
AppE (Name -> Exp
ConE Name
conName) ((Name -> Exp) -> [Name] -> [Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Exp
VarE [Name]
memberNames)
productMapper ::
Name ->
Int ->
Int ->
Exp
productMapper :: Name -> Int -> Int -> Exp
productMapper Name
conName Int
numMembers Int
index =
[Pat] -> Exp -> Exp
LamE [Pat
mapperP, Pat
stateP] Exp
exp
where
memberName :: Name
memberName =
Int -> Name
alphabeticIndexName Int
index
memberNames :: [Name]
memberNames =
(Int -> Name) -> [Int] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Name
alphabeticIndexName (Int -> Int -> [Int]
forall a. Enum a => a -> a -> [a]
enumFromTo Int
0 (Int -> Int
forall a. Enum a => a -> a
pred Int
numMembers))
valName :: Name
valName =
Int -> Name
alphabeticIndexName Int
index
fnName :: Name
fnName =
String -> Name
mkName String
"fn"
mapperP :: Pat
mapperP =
Name -> Pat
VarP Name
fnName
stateP :: Pat
stateP =
Name -> [Pat] -> Pat
ConP Name
conName [Pat]
pats
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]
memberNames
exp :: Exp
exp =
(Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Exp -> Exp -> Exp
AppE (Name -> Exp
ConE Name
conName) ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$
(Int -> Exp) -> [Int] -> [Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> Exp
VarE (Name -> Exp) -> (Int -> Name) -> Int -> Exp
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int -> Name
alphabeticIndexName) (Int -> Int -> [Int]
forall a. Enum a => a -> a -> [a]
enumFromTo Int
0 (Int -> Int
forall a. Enum a => a -> a
pred Int
index)) [Exp] -> [Exp] -> [Exp]
forall a. Semigroup a => a -> a -> a
<>
Exp -> [Exp]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
fnName) (Name -> Exp
VarE Name
valName)) [Exp] -> [Exp] -> [Exp]
forall a. Semigroup a => a -> a -> a
<>
(Int -> Exp) -> [Int] -> [Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> Exp
VarE (Name -> Exp) -> (Int -> Name) -> Int -> Exp
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int -> Name
alphabeticIndexName) (Int -> Int -> [Int]
forall a. Enum a => a -> a -> [a]
enumFromTo (Int -> Int
forall a. Enum a => a -> a
succ Int
index) (Int -> Int
forall a. Enum a => a -> a
pred Int
numMembers))
sumMapper ::
Name ->
Int ->
Exp
sumMapper :: Name -> Int -> Exp
sumMapper Name
conName Int
numMembers =
[Pat] -> Exp -> Exp
LamE [Pat
mapperP] ([Match] -> Exp
matcher [Match]
matches)
where
fnName :: Name
fnName =
String -> Name
mkName String
"fn"
mapperP :: Pat
mapperP =
Name -> Pat
VarP Name
fnName
matches :: [Match]
matches =
[Match
pos, Match
neg]
where
pos :: Match
pos =
Pat -> Body -> [Dec] -> Match
Match (Name -> [Pat] -> Pat
ConP Name
conName [Pat]
memberPats) (Exp -> Body
NormalB Exp
bodyExp) []
where
memberVarNames :: [Name]
memberVarNames =
(Int -> Name) -> [Int] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Name
alphabeticIndexName (Int -> Int -> [Int]
forall a. Enum a => a -> a -> [a]
enumFromTo Int
0 (Int -> Int
forall a. Enum a => a -> a
pred Int
numMembers))
memberPats :: [Pat]
memberPats =
(Name -> Pat) -> [Name] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Pat
VarP [Name]
memberVarNames
bodyExp :: Exp
bodyExp =
Exp -> Exp -> Exp
AppE (Name -> Int -> Exp
tupleToProduct Name
conName Int
numMembers)
(Exp -> [Exp] -> Exp
multiAppE (Name -> Exp
VarE Name
fnName) ((Name -> Exp) -> [Name] -> [Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Exp
VarE [Name]
memberVarNames))
neg :: Match
neg =
Pat -> Body -> [Dec] -> Match
Match (Name -> Pat
VarP Name
aName) (Exp -> Body
NormalB (Name -> Exp
VarE Name
aName)) []
adtConstructorNarrower :: Name -> Int -> Exp
adtConstructorNarrower :: Name -> Int -> Exp
adtConstructorNarrower Name
conName Int
numMembers =
[Match] -> Exp
matcher [Match
positive, Match
negative]
where
positive :: Match
positive =
Pat -> Body -> [Dec] -> Match
Match (Name -> [Pat] -> Pat
ConP Name
conName ((Name -> Pat) -> [Name] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Pat
VarP [Name]
varNames)) (Exp -> Body
NormalB Exp
exp) []
where
varNames :: [Name]
varNames =
(Int -> Name) -> [Int] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Name
alphabeticIndexName (Int -> Int -> [Int]
forall a. Enum a => a -> a -> [a]
enumFromTo Int
0 (Int -> Int
forall a. Enum a => a -> a
pred Int
numMembers))
exp :: Exp
exp =
Exp -> Exp -> Exp
AppE (Name -> Exp
ConE 'Just) ([Exp] -> Exp
Compat.tupE ((Name -> Exp) -> [Name] -> [Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Exp
VarE [Name]
varNames))
negative :: Match
negative =
Pat -> Body -> [Dec] -> Match
Match Pat
WildP (Exp -> Body
NormalB (Name -> Exp
ConE 'Nothing)) []
enumConstructorToBool :: Name -> Exp
enumConstructorToBool :: Name -> Exp
enumConstructorToBool Name
constructorName =
[Match] -> Exp
matcher [Match
positive, Match
negative]
where
positive :: Match
positive =
Pat -> Body -> [Dec] -> Match
Match (Name -> [Pat] -> Pat
ConP Name
constructorName []) (Exp -> Body
NormalB Exp
bodyExp) []
where
bodyExp :: Exp
bodyExp =
Name -> Exp
ConE 'True
negative :: Match
negative =
Pat -> Body -> [Dec] -> Match
Match Pat
WildP (Exp -> Body
NormalB Exp
bodyExp) []
where
bodyExp :: Exp
bodyExp =
Name -> Exp
ConE 'False
singleConstructorAdtToTuple :: Name -> Int -> Exp
singleConstructorAdtToTuple :: Name -> Int -> Exp
singleConstructorAdtToTuple Name
conName Int
numMembers =
[Pat] -> Exp -> Exp
LamE [Pat
pat] Exp
exp
where
varNames :: [Name]
varNames =
(Int -> Name) -> [Int] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Name
alphabeticIndexName (Int -> Int -> [Int]
forall a. Enum a => a -> a -> [a]
enumFromTo Int
0 (Int -> Int
forall a. Enum a => a -> a
pred Int
numMembers))
pat :: Pat
pat =
Name -> [Pat] -> Pat
ConP Name
conName ((Name -> Pat) -> [Name] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Pat
VarP [Name]
varNames)
exp :: Exp
exp =
[Exp] -> Exp
Compat.tupE ((Name -> Exp) -> [Name] -> [Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Exp
VarE [Name]
varNames)
tupleToProduct :: Name -> Int -> Exp
tupleToProduct :: Name -> Int -> Exp
tupleToProduct Name
conName Int
numMembers =
[Pat] -> Exp -> Exp
LamE [Pat
pat] Exp
exp
where
varNames :: [Name]
varNames =
(Int -> Name) -> [Int] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Name
alphabeticIndexName (Int -> Int -> [Int]
forall a. Enum a => a -> a -> [a]
enumFromTo Int
0 (Int -> Int
forall a. Enum a => a -> a
pred Int
numMembers))
pat :: Pat
pat =
[Pat] -> Pat
TupP ((Name -> Pat) -> [Name] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Pat
VarP [Name]
varNames)
exp :: Exp
exp =
Exp -> [Exp] -> Exp
multiAppE (Name -> Exp
ConE Name
conName) ((Name -> Exp) -> [Name] -> [Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Exp
VarE [Name]
varNames)
namedFieldSetter :: Name -> Exp
namedFieldSetter :: Name -> Exp
namedFieldSetter Name
fieldName =
[Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
aName, Name -> Pat
VarP Name
bName] (Exp -> [FieldExp] -> Exp
RecUpdE (Name -> Exp
VarE Name
aName) [(Name
fieldName, Name -> Exp
VarE Name
bName)])