module THLego.Lambdas where
import Language.Haskell.TH
import THLego.Helpers
import THLego.Prelude
import qualified TemplateHaskell.Compat.V0208 as Compat
vlLens ::
Name ->
Int ->
Int ->
Exp
vlLens :: Name -> Int -> Int -> Exp
vlLens Name
conName Int
numMembers Int
index =
[Pat] -> Exp -> Exp
LamE [Pat
onMemberP, Pat
productP] Exp
exp
where
onMemberName :: Name
onMemberName =
String -> Name
mkName String
"memberMapper"
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))
onMemberP :: Pat
onMemberP =
Name -> Pat
VarP Name
onMemberName
productP :: Pat
productP =
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
multiAppE (Name -> Exp
VarE 'fmap) [Exp
setterE, Exp
onMemberE]
where
setterE :: Exp
setterE =
[Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
valueName] Exp
exp
where
valueName :: Name
valueName =
String -> Name
mkName String
"newMember"
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]
argNames)
where
argNames :: [Name]
argNames =
Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
index [Name]
memberNames
[Name] -> [Name] -> [Name]
forall a. Semigroup a => a -> a -> a
<> [Name
valueName]
[Name] -> [Name] -> [Name]
forall a. Semigroup a => a -> a -> a
<> Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
drop (Int -> Int
forall a. Enum a => a -> a
succ Int
index) [Name]
memberNames
onMemberE :: Exp
onMemberE =
Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
onMemberName) (Name -> Exp
VarE (Int -> Name
alphabeticIndexName Int
index))
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
tupleOrSingletonToProduct 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)
tupleOrSingletonToProduct :: Name -> Int -> Exp
tupleOrSingletonToProduct :: Name -> Int -> Exp
tupleOrSingletonToProduct Name
conName Int
numMembers =
if Int
numMembers Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
then Name -> Exp
ConE Name
conName
else Name -> Int -> Exp
tupleToProduct Name
conName Int
numMembers
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)])