module THLego.Lambdas where

import Language.Haskell.TH
import THLego.Helpers
import THLego.Prelude
import qualified TemplateHaskell.Compat.V0208 as Compat

-- |
-- Van Larrhoven lens.
vlLens ::
  -- | Constructor name.
  Name ->
  -- | Total amount of members.
  Int ->
  -- | Index of the member.
  Int ->
  -- |
  --  Lambda expression of the following type:
  --
  --  > forall f. Functor f => (a -> f b) -> s -> f t
  Exp
vlLens :: Name -> Int -> Int -> Exp
vlLens Name
conName Int
numMembers Int
index =
  [Pat] -> Exp -> Exp
LamE [Pat
onMemberP, Pat
productP] Exp
exp
  where
    -- Reference implementation:
    -- \ memberMapper (Product a b) -> fmap (\ newMember -> Product newMember b) (memberMapper a)
    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))

-- |
-- Simulates lambda-case without the need for extension.
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)

-- |
-- Lambda expression, which extracts a product member by index.
productGetter ::
  -- | Constructor name.
  Name ->
  -- | Total amount of members.
  Int ->
  -- | Index of the member.
  Int ->
  -- |
  --  Lambda expression of the following form:
  --
  --  > product -> member
  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

-- |
-- Lambda expression, which sets a product member by index.
productSetter ::
  -- | Constructor name.
  Name ->
  -- | Total amount of members.
  Int ->
  -- | Index of the member.
  Int ->
  -- |
  --  Lambda expression of the following form:
  --
  --  > product -> member -> product
  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)

-- |
-- Lambda expression, which maps a product member by index.
productMapper ::
  -- | Constructor name.
  Name ->
  -- | Total amount of members.
  Int ->
  -- | Index of the member.
  Int ->
  -- |
  --  Lambda expression of the following form:
  --
  --  > (member -> member) -> product -> product
  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))

-- |
-- Lambda expression, which maps a sum member by index.
sumMapper ::
  -- | Constructor name.
  Name ->
  -- | Total amount of members.
  Int ->
  -- |
  --  Lambda expression of the following form:
  --
  --  > (membersTuple -> membersTuple) -> sum -> sum
  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)])