{-# LANGUAGE TemplateHaskell #-}

-- | Template Haskell derivation functions for the goblin-related typeclasses.
module Test.Goblin.TH
  ( deriveGoblin
  , deriveAddShrinks
  , deriveSeedGoblin
  ) where

import           Control.Monad (foldM, forM)
import           Data.Typeable (Typeable)
import           Language.Haskell.TH
import           TH.ReifySimple

import Test.Goblin.Core


--------------------------------------------------------------------------------
-- Goblin instance derivation
--------------------------------------------------------------------------------

-- | Derive a `Goblin` instance for datatypes which have `Goblin` and `AddShrinks`
-- instances for their enclosed fields.
-- `tinker`s recursively with fields of a datatype, then uses `<$$>` and `<**>`
-- to map the constructor over the tinkered fields.
-- `conjure`s by using `<$>` and `<*>` over recursive calls to `conjure`.
--
-- @
--   deriveGoblin ''(,)
--   ======>
--   instance (Goblin g a,
--             AddShrinks a,
--             Goblin g b,
--             AddShrinks b) =>
--            Goblin g ((,) a b) where
--     tinker gen
--       = tinkerRummagedOrConjureOrSave
--           (((\ a b -> ((,) a) b)
--              <$$> tinker ((\ ((,) a _) -> a) <$> gen))
--              <**> tinker ((\ ((,) _ b) -> b) <$> gen))
--     conjure = (saveInBagOfTricks =<< (((,) <$> conjure) <*> conjure))
-- @
deriveGoblin :: Name -> Q [Dec]
deriveGoblin :: Name -> Q [Dec]
deriveGoblin Name
name = do
  (DataType Name
_dName [Name]
dTyVars Cxt
_dCtx [DataCon]
dCons) <- Name -> Q DataType
reifyDataType Name
name
  Type
genomeVar <- Name -> Type
VarT (Name -> Type) -> Q Name -> Q Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
newName String
"genome"
  [Name]
classParamNames <- [Name] -> (Name -> Q Name) -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Name]
dTyVars (Q Name -> Name -> Q Name
forall a b. a -> b -> a
const (String -> Q Name
newName String
"arg"))
  let con :: DataCon
con = [DataCon] -> DataCon
forall p. [p] -> p
ensureSingleton [DataCon]
dCons
  Cxt
ctx <- if [Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
classParamNames
            then (Type -> Cxt -> Cxt
forall a. a -> [a] -> [a]
:[]) (Type -> Cxt) -> Q Type -> Q Cxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t| GeneOps $(pure genomeVar) |]
            else Type -> [Name] -> Q Cxt
forall (t :: * -> *). Foldable t => Type -> t Name -> Q Cxt
wrapWithGoblinConstraints Type
genomeVar [Name]
classParamNames
  Type
decTy <- Type -> [Name] -> Q Type
forall (t :: * -> *). Foldable t => Type -> t Name -> Q Type
makeInstanceType Type
genomeVar [Name]
classParamNames
  Dec
tink <- DataCon -> Q Dec
makeTinker DataCon
con
  Dec
conj <- DataCon -> Q Dec
makeConjure DataCon
con
  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing Cxt
ctx Type
decTy [Dec
tink, Dec
conj]]
 where
  ensureSingleton :: [p] -> p
ensureSingleton [p]
dCons =
    case [p]
dCons of
      []  -> String -> p
forall a. HasCallStack => String -> a
error String
"deriveGoblin: cannot derive Goblin for a void type"
      [p
x] -> p
x
      [p]
_   -> String -> p
forall a. HasCallStack => String -> a
error String
"deriveGoblin: cannot derive Goblin for a sum type"

  -- Create constraints `(Goblin g a, AddShrinks a ...) => ...` for the instance
  wrapWithGoblinConstraints :: Type -> t Name -> Q Cxt
wrapWithGoblinConstraints Type
genomeVar = [Q Type] -> Q Cxt
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Q Type] -> Q Cxt) -> (t Name -> [Q Type]) -> t Name -> Q Cxt
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (Name -> [Q Type]) -> t Name -> [Q Type]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Name
cpn -> [ [t| Goblin $(pure genomeVar) $(pure (VarT cpn)) |]
                       , [t| AddShrinks $(pure (VarT cpn)) |]
                       ])

  -- Make instance type `... => Goblin g (Foo a b ...)`
  makeInstanceType :: Type -> t Name -> Q Type
makeInstanceType Type
genomeVar t Name
classParamNames =
    [t| Goblin $(pure genomeVar)
               ( $(pure (foldl wrapTyVars (ConT name) classParamNames)) ) |]
  wrapTyVars :: Type -> Name -> Type
wrapTyVars Type
acc Name
cpn = Type -> Type -> Type
AppT Type
acc (Name -> Type
VarT Name
cpn)

  makeTinker :: DataCon -> Q Dec
makeTinker DataCon
con = do
    if [(Maybe Name, Type)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (DataCon -> [(Maybe Name, Type)]
dcFields DataCon
con) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0
       then String -> Q Dec
mkPureDec String
"tinker"
       else do
         Name
argName <- String -> Q Name
newName String
"arg"
         let pat :: Pat
pat = Name -> Pat
VarP Name
argName
         Exp
body <- Name -> Q Exp
mkBody Name
argName
         Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"tinker") [[Pat] -> Body -> [Dec] -> Clause
Clause [Pat
pat] (Exp -> Body
NormalB Exp
body) []])
   where
    mkBody :: Name -> Q Exp
mkBody Name
argName = do
      [Name]
fieldNames <- [(Maybe Name, Type)] -> ((Maybe Name, Type) -> Q Name) -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (DataCon -> [(Maybe Name, Type)]
dcFields DataCon
con) (Q Name -> (Maybe Name, Type) -> Q Name
forall a b. a -> b -> a
const (String -> Q Name
newName String
"field"))
      let accessors :: [Exp]
accessors = Name -> [Name] -> [Exp]
makeAccessors (DataCon -> Name
dcName DataCon
con) [Name]
fieldNames
      Exp
start <- [| $(pure (makeConPacker (dcName con) fieldNames))
                    <$$> (tinker ($(pure (head accessors))
                            <$> $(pure (VarE argName)))) |]
      let tinkerBody :: Q Exp
tinkerBody =
            (Exp -> Exp -> Q Exp) -> Exp -> [Exp] -> Q Exp
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\Exp
acc Exp
getter -> [| $(pure acc)
                                       <**> (tinker ($(pure getter)
                                              <$> $(pure (VarE argName)))) |])
                  Exp
start
                  ([Exp] -> [Exp]
forall a. [a] -> [a]
tail [Exp]
accessors)
      [| tinkerRummagedOrConjureOrSave $(tinkerBody) |]

  makeConjure :: DataCon -> Q Dec
makeConjure DataCon
con = do
    if [(Maybe Name, Type)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (DataCon -> [(Maybe Name, Type)]
dcFields DataCon
con) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0
       then Q Dec
mkNullaryDefn
       else do
         Exp
start <- [| $(pure (ConE (dcName con))) <$> conjure |]
         Exp
body <- (Exp -> (Maybe Name, Type) -> Q Exp)
-> Exp -> [(Maybe Name, Type)] -> Q Exp
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\Exp
acc (Maybe Name, Type)
_ -> [| $(pure acc) <*> conjure |])
                       Exp
start
                       ([(Maybe Name, Type)] -> [(Maybe Name, Type)]
forall a. [a] -> [a]
tail (DataCon -> [(Maybe Name, Type)]
dcFields DataCon
con))
         Exp
cb <- [| saveInBagOfTricks =<< $(pure body) |]
         Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"conjure") [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
cb) []])
   where
    mkNullaryDefn :: Q Dec
mkNullaryDefn = do
      Exp
body <- [| pure $(pure (ConE (dcName con))) |]
      Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"conjure") [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
body) []])


--------------------------------------------------------------------------------
-- AddShrinks instance derivation
--------------------------------------------------------------------------------

-- | Derive an `AddShrinks` instance for datatypes which have `AddShrinks`
-- instances for their enclosed fields. Simply performs structural recursion
-- on fields, then uses `<$>` and `<*>` to apply the constructor over the
-- `addShrinks` of the fields.
--
-- @
--   deriveAddShrinks ''(,)
--   ======>
--   instance (AddShrinks a, AddShrinks b) =>
--            AddShrinks ((,) a b) where
--     addShrinks ((,) x y)
--       = (((\ x y -> ((,) x) y)
--            <$> addShrinks x)
--            <*> addShrinks y)
-- @
deriveAddShrinks :: Name -> Q [Dec]
deriveAddShrinks :: Name -> Q [Dec]
deriveAddShrinks Name
name = do
  (DataType Name
_dName [Name]
dTyVars Cxt
_dCtx [DataCon]
dCons) <- Name -> Q DataType
reifyDataType Name
name
  [Name]
classParamNames <- [Name] -> (Name -> Q Name) -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Name]
dTyVars (Q Name -> Name -> Q Name
forall a b. a -> b -> a
const (String -> Q Name
newName String
"arg"))
  Cxt
ctx <- [Name] -> Q Cxt
wrapWithConstraints [Name]
classParamNames
  Type
decTy <- [Name] -> Q Type
forall (t :: * -> *). Foldable t => t Name -> Q Type
makeInstanceType [Name]
classParamNames
  Dec
addShrinkDec <- [DataCon] -> Q Dec
makeAddShrinks [DataCon]
dCons
  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing Cxt
ctx Type
decTy [Dec
addShrinkDec]]
 where

  -- Create constraints `(AddShrinks a ...) => ...` for the instance
  wrapWithConstraints :: [Name] -> Q Cxt
wrapWithConstraints = [Q Type] -> Q Cxt
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Q Type] -> Q Cxt) -> ([Name] -> [Q Type]) -> [Name] -> Q Cxt
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (Name -> Q Type) -> [Name] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
cpn -> [t| AddShrinks $(pure (VarT cpn)) |])

  -- Make instance type `... => AddShrinks (Foo a b ...)`
  makeInstanceType :: t Name -> Q Type
makeInstanceType t Name
classParamNames =
    [t| AddShrinks
          ( $(pure (foldl wrapTyVars (ConT name) classParamNames)) ) |]
  wrapTyVars :: Type -> Name -> Type
wrapTyVars Type
acc Name
cpn = Type -> Type -> Type
AppT Type
acc (Name -> Type
VarT Name
cpn)

  makeAddShrinks :: [DataCon] -> Q Dec
  makeAddShrinks :: [DataCon] -> Q Dec
makeAddShrinks [DataCon]
dcs = do
    [Clause]
clauses <- (DataCon -> Q Clause) -> [DataCon] -> Q [Clause]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM DataCon -> Q Clause
makeAddShrinksClause [DataCon]
dcs
    Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"addShrinks") [Clause]
clauses)

  makeAddShrinksClause :: DataCon -> Q Clause
  makeAddShrinksClause :: DataCon -> Q Clause
makeAddShrinksClause DataCon
con =
    if [(Maybe Name, Type)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (DataCon -> [(Maybe Name, Type)]
dcFields DataCon
con) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0

       then do
         Name
field <- String -> Q Name
newName String
"field"
         Exp
body <- [| pure $(pure (VarE field)) |]
         Clause -> Q Clause
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP Name
field] (Exp -> Body
NormalB Exp
body) [])

       else do
         [Name]
fieldNames <- [(Maybe Name, Type)] -> ((Maybe Name, Type) -> Q Name) -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (DataCon -> [(Maybe Name, Type)]
dcFields DataCon
con) (Q Name -> (Maybe Name, Type) -> Q Name
forall a b. a -> b -> a
const (String -> Q Name
newName String
"field"))
         let pat :: Pat
pat = Name -> [Pat] -> Pat
ConP (DataCon -> Name
dcName DataCon
con) ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
fieldNames)

         Exp
start <- [| $(pure (makeConPacker (dcName con) fieldNames))
                       <$> addShrinks $(pure (VarE (head fieldNames))) |]
         Exp
body <- (Exp -> Name -> Q Exp) -> Exp -> [Name] -> Q Exp
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\Exp
acc Name
v -> [| $(pure acc) <*> addShrinks $(pure (VarE v)) |])
                       Exp
start
                       ([Name] -> [Name]
forall a. [a] -> [a]
tail ([Name]
fieldNames))
         Clause -> Q Clause
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Pat] -> Body -> [Dec] -> Clause
Clause [Pat
pat] (Exp -> Body
NormalB Exp
body) [])


--------------------------------------------------------------------------------
-- SeedGoblin instance derivation
--------------------------------------------------------------------------------

-- | Derive a `SeedGoblin` instance which calls `saveInBagOfTricks` on the
-- argument then recurs structurally on fields.
--
-- @
--   deriveSeedGoblin ''(,)
--   ======>
--   instance (SeedGoblin a,
--             Typeable a,
--             SeedGoblin b,
--             Typeable b) =>
--            SeedGoblin ((,) a b) where
--     seeder p@((,) x y)
--       = do (() <$ saveInBagOfTricks p)
--            seeder x
--            seeder y
-- @
deriveSeedGoblin :: Name -> Q [Dec]
deriveSeedGoblin :: Name -> Q [Dec]
deriveSeedGoblin Name
name = do
  (DataType Name
_dName [Name]
dTyVars Cxt
_dCtx [DataCon]
dCons) <- Name -> Q DataType
reifyDataType Name
name
  [Name]
classParamNames <- [Name] -> (Name -> Q Name) -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Name]
dTyVars (Q Name -> Name -> Q Name
forall a b. a -> b -> a
const (String -> Q Name
newName String
"arg"))
  Cxt
ctx <- [Name] -> Q Cxt
wrapWithConstraints [Name]
classParamNames
  Type
decTy <- [Name] -> Q Type
forall (t :: * -> *). Foldable t => t Name -> Q Type
makeInstanceType [Name]
classParamNames
  Dec
sdr <- [DataCon] -> Q Dec
makeSeeder [DataCon]
dCons
  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing Cxt
ctx Type
decTy [Dec
sdr]]
 where

  -- Create constraints `(SeedGoblin a ...) => ...` for the instance
  wrapWithConstraints :: [Name] -> Q Cxt
wrapWithConstraints = [Q Type] -> Q Cxt
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Q Type] -> Q Cxt) -> ([Name] -> [Q Type]) -> [Name] -> Q Cxt
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (Name -> [Q Type]) -> [Name] -> [Q Type]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Name
cpn -> [ [t| SeedGoblin $(pure (VarT cpn)) |]
                       , [t| Typeable $(pure (VarT cpn)) |]
                       ])


  -- Make instance type `... => SeedGoblin (Foo a b ...)`
  makeInstanceType :: t Name -> Q Type
makeInstanceType t Name
classParamNames =
    [t| SeedGoblin
          ( $(pure (foldl wrapTyVars (ConT name) classParamNames)) ) |]
  wrapTyVars :: Type -> Name -> Type
wrapTyVars Type
acc Name
cpn = Type -> Type -> Type
AppT Type
acc (Name -> Type
VarT Name
cpn)

  makeSeeder :: [DataCon] -> Q Dec
  makeSeeder :: [DataCon] -> Q Dec
makeSeeder [DataCon]
dcs = do
    [Clause]
clauses <- (DataCon -> Q Clause) -> [DataCon] -> Q [Clause]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM DataCon -> Q Clause
makeSeederClause [DataCon]
dcs
    Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"seeder") [Clause]
clauses)

  makeSeederClause :: DataCon -> Q Clause
  makeSeederClause :: DataCon -> Q Clause
makeSeederClause DataCon
con = do
    Name
asName <- String -> Q Name
newName String
"argAs"
    [Name]
fieldNames <- [(Maybe Name, Type)] -> ((Maybe Name, Type) -> Q Name) -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (DataCon -> [(Maybe Name, Type)]
dcFields DataCon
con) (Q Name -> (Maybe Name, Type) -> Q Name
forall a b. a -> b -> a
const (String -> Q Name
newName String
"field"))
    let pat :: Pat
pat = Name -> Pat -> Pat
AsP Name
asName (Name -> [Pat] -> Pat
ConP (DataCon -> Name
dcName DataCon
con) ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
fieldNames))

    Exp
seedAs <- [| () <$ saveInBagOfTricks $(pure (VarE asName)) |]
    [Exp]
seedRest <- [Name] -> (Name -> Q Exp) -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Name]
fieldNames ((Name -> Q Exp) -> Q [Exp]) -> (Name -> Q Exp) -> Q [Exp]
forall a b. (a -> b) -> a -> b
$ \Name
vName -> do
                  [| seeder $(pure (VarE vName)) |]
    let stmts :: [Stmt]
stmts = (Exp -> Stmt) -> [Exp] -> [Stmt]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Stmt
NoBindS (Exp
seedAsExp -> [Exp] -> [Exp]
forall a. a -> [a] -> [a]
:[Exp]
seedRest)
    Clause -> Q Clause
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Pat] -> Body -> [Dec] -> Clause
Clause [Pat
pat] (Exp -> Body
NormalB ([Stmt] -> Exp
DoE [Stmt]
stmts)) [])

--------------------------------------------------------------------------------
-- Helpers
--------------------------------------------------------------------------------

-- | Take a constructor name and a list of arguments, and return a lambda
-- which receives the arguments and packs them into the constructor.
makeConPacker :: Name -> [Name] -> Exp
makeConPacker :: Name -> [Name] -> Exp
makeConPacker Name
conName [Name]
argNames =
  let body :: Exp
body = (Exp -> Name -> Exp) -> Exp -> [Name] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Exp
acc Name
v -> Exp -> Exp -> Exp
AppE Exp
acc (Name -> Exp
VarE Name
v))
                   (Name -> Exp
ConE Name
conName)
                   [Name]
argNames
   in [Pat] -> Exp -> Exp
LamE ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
argNames) Exp
body

-- | Take a constructor name and a list of arguments, and return a list
-- of lambdas which access each respective constructor field, in order.
makeAccessors :: Name -> [Name] -> [Exp]
makeAccessors :: Name -> [Name] -> [Exp]
makeAccessors Name
conName [Name]
argNames =
  [ let front :: [Pat]
front = Int -> Pat -> [Pat]
forall a. Int -> a -> [a]
replicate Int
i Pat
WildP
        back :: [Pat]
back  = Int -> Pat -> [Pat]
forall a. Int -> a -> [a]
replicate ([Name] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
argNames Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Pat
WildP
        arg :: Name
arg   = [Name]
argNames [Name] -> Int -> Name
forall a. [a] -> Int -> a
!! Int
i
        pat :: Pat
pat = Name -> [Pat] -> Pat
ConP Name
conName ([Pat]
front [Pat] -> [Pat] -> [Pat]
forall a. [a] -> [a] -> [a]
++ [Name -> Pat
VarP Name
arg] [Pat] -> [Pat] -> [Pat]
forall a. [a] -> [a] -> [a]
++ [Pat]
back)
     in [Pat] -> Exp -> Exp
LamE [Pat
pat] (Name -> Exp
VarE Name
arg)
  | Int
i <- [Int
0 .. [Name] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
argNames Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
  ]

-- | Create a decl of the form `<name> = pure`
mkPureDec :: String -> Q Dec
mkPureDec :: String -> Q Dec
mkPureDec String
name = do
  Exp
body <- [| pure |]
  Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
name) [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
body) []])