{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE CPP             #-}

-- | The shared functionality behind Lens.Family.TH and Lens.Family2.TH.
module Lens.Family.THCore (
   defaultNameTransform
  , LensTypeInfo
  , ConstructorFieldInfo
  , deriveLenses
  , makeTraversals
  ) where

import Language.Haskell.TH
import Control.Applicative (pure)
import Data.Char (toLower)

-- | By default, if the field name begins with an underscore,
-- then the underscore will simply be removed (and the new first character
-- lowercased if necessary).
defaultNameTransform :: String -> Maybe String
defaultNameTransform :: String -> Maybe String
defaultNameTransform (Char
'_':Char
c:String
rest) = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Char -> Char
toLower Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
rest
defaultNameTransform String
_ = Maybe String
forall a. Maybe a
Nothing


-- | Information about the larger type the lens will operate on.
type LensTypeInfo =
#if MIN_VERSION_template_haskell(2,21,0)
  (Name, [TyVarBndr BndrVis])
#elif MIN_VERSION_template_haskell(2,17,0)
  (Name, [TyVarBndr ()])
#else
  (Name, [TyVarBndr])
#endif

-- | Information about the smaller type the lens will operate on.
type ConstructorFieldInfo = (Name, Strict, Type)


-- | The true workhorse of lens derivation. This macro is parameterized
-- by a macro that derives signatures, as well as a function that
-- filters and transforms names. Producing Nothing means that
-- a lens should not be generated for the provided name.
deriveLenses ::
     (Name -> LensTypeInfo -> ConstructorFieldInfo -> Q [Dec])
     -- ^ the signature deriver
  -> (String -> Maybe String)
     -- ^ the name transformer
  -> Name -> Q [Dec]
deriveLenses :: (Name -> LensTypeInfo -> ConstructorFieldInfo -> Q [Dec])
-> (String -> Maybe String) -> Name -> Q [Dec]
deriveLenses Name -> LensTypeInfo -> ConstructorFieldInfo -> Q [Dec]
sigDeriver String -> Maybe String
nameTransform Name
datatype = do
  LensTypeInfo
typeInfo          <- Name -> Q LensTypeInfo
extractLensTypeInfo Name
datatype
  let derive1 :: ConstructorFieldInfo -> Q [Dec]
derive1 = (Name -> LensTypeInfo -> ConstructorFieldInfo -> Q [Dec])
-> (String -> Maybe String)
-> LensTypeInfo
-> ConstructorFieldInfo
-> Q [Dec]
deriveLens Name -> LensTypeInfo -> ConstructorFieldInfo -> Q [Dec]
sigDeriver String -> Maybe String
nameTransform LensTypeInfo
typeInfo
  [ConstructorFieldInfo]
constructorFields <- Name -> Q [ConstructorFieldInfo]
extractConstructorFields Name
datatype
  [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (ConstructorFieldInfo -> Q [Dec])
-> [ConstructorFieldInfo] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ConstructorFieldInfo -> Q [Dec]
derive1 [ConstructorFieldInfo]
constructorFields


extractLensTypeInfo :: Name -> Q LensTypeInfo
extractLensTypeInfo :: Name -> Q LensTypeInfo
extractLensTypeInfo Name
datatype = do
  let datatypeStr :: String
datatypeStr = Name -> String
nameBase Name
datatype
  Info
i <- Name -> Q Info
reify Name
datatype
  LensTypeInfo -> Q LensTypeInfo
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (LensTypeInfo -> Q LensTypeInfo) -> LensTypeInfo -> Q LensTypeInfo
forall a b. (a -> b) -> a -> b
$ case Info
i of
    TyConI (DataD    Cxt
_ Name
n [TyVarBndr ()]
ts Maybe Kind
_ [Con]
_ [DerivClause]
_) -> (Name
n, [TyVarBndr ()]
ts)
    TyConI (NewtypeD Cxt
_ Name
n [TyVarBndr ()]
ts Maybe Kind
_ Con
_ [DerivClause]
_) -> (Name
n, [TyVarBndr ()]
ts)
    Info
_ -> String -> LensTypeInfo
forall a. HasCallStack => String -> a
error (String -> LensTypeInfo) -> String -> LensTypeInfo
forall a b. (a -> b) -> a -> b
$ String
"Can't derive Lens for: "  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
datatypeStr
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", type name required."


extractConstructorFields :: Name -> Q [ConstructorFieldInfo]
extractConstructorFields :: Name -> Q [ConstructorFieldInfo]
extractConstructorFields Name
datatype = do
  let datatypeStr :: String
datatypeStr = Name -> String
nameBase Name
datatype
  Info
i <- Name -> Q Info
reify Name
datatype
  [ConstructorFieldInfo] -> Q [ConstructorFieldInfo]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([ConstructorFieldInfo] -> Q [ConstructorFieldInfo])
-> [ConstructorFieldInfo] -> Q [ConstructorFieldInfo]
forall a b. (a -> b) -> a -> b
$ case Info
i of
    TyConI (DataD    Cxt
_ Name
_ [TyVarBndr ()]
_ Maybe Kind
_ [RecC Name
_ [ConstructorFieldInfo]
fs] [DerivClause]
_) -> [ConstructorFieldInfo]
fs
    TyConI (NewtypeD Cxt
_ Name
_ [TyVarBndr ()]
_ Maybe Kind
_ (RecC Name
_ [ConstructorFieldInfo]
fs) [DerivClause]
_) -> [ConstructorFieldInfo]
fs
    TyConI (DataD    Cxt
_ Name
_ [TyVarBndr ()]
_ Maybe Kind
_ [Con
_]         [DerivClause]
_) ->
      String -> [ConstructorFieldInfo]
forall a. HasCallStack => String -> a
error (String -> [ConstructorFieldInfo])
-> String -> [ConstructorFieldInfo]
forall a b. (a -> b) -> a -> b
$ String
"Can't derive Lens without record selectors: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
datatypeStr
    TyConI NewtypeD{} ->
      String -> [ConstructorFieldInfo]
forall a. HasCallStack => String -> a
error (String -> [ConstructorFieldInfo])
-> String -> [ConstructorFieldInfo]
forall a b. (a -> b) -> a -> b
$ String
"Can't derive Lens without record selectors: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
datatypeStr
    TyConI TySynD{} ->
      String -> [ConstructorFieldInfo]
forall a. HasCallStack => String -> a
error (String -> [ConstructorFieldInfo])
-> String -> [ConstructorFieldInfo]
forall a b. (a -> b) -> a -> b
$ String
"Can't derive Lens for type synonym: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
datatypeStr
    TyConI DataD{} ->
      String -> [ConstructorFieldInfo]
forall a. HasCallStack => String -> a
error (String -> [ConstructorFieldInfo])
-> String -> [ConstructorFieldInfo]
forall a b. (a -> b) -> a -> b
$ String
"Can't derive Lens for tagged union: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
datatypeStr
    Info
_ ->
      String -> [ConstructorFieldInfo]
forall a. HasCallStack => String -> a
error (String -> [ConstructorFieldInfo])
-> String -> [ConstructorFieldInfo]
forall a b. (a -> b) -> a -> b
$ String
"Can't derive Lens for: "  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
datatypeStr
           String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", type name required."


-- Derive a lens for the given record selector
-- using the given name transformation function.
deriveLens :: (Name -> LensTypeInfo -> ConstructorFieldInfo -> Q [Dec])
           -> (String -> Maybe String)
           -> LensTypeInfo -> ConstructorFieldInfo -> Q [Dec]
deriveLens :: (Name -> LensTypeInfo -> ConstructorFieldInfo -> Q [Dec])
-> (String -> Maybe String)
-> LensTypeInfo
-> ConstructorFieldInfo
-> Q [Dec]
deriveLens Name -> LensTypeInfo -> ConstructorFieldInfo -> Q [Dec]
sigDeriver String -> Maybe String
nameTransform LensTypeInfo
ty ConstructorFieldInfo
field = do
  let (Name
fieldName, Strict
_fieldStrict, Kind
_fieldType) = ConstructorFieldInfo
field
      (Name
_tyName, [TyVarBndr ()]
_tyVars) = LensTypeInfo
ty  -- just to clarify what's here
  case String -> Maybe String
nameTransform (Name -> String
nameBase Name
fieldName) of
    Maybe String
Nothing       -> [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    Just String
lensNameStr -> do
      let lensName :: Name
lensName = String -> Name
mkName String
lensNameStr
      [Dec]
sig  <- Name -> LensTypeInfo -> ConstructorFieldInfo -> Q [Dec]
sigDeriver Name
lensName LensTypeInfo
ty ConstructorFieldInfo
field
      Dec
body <- Name -> Name -> Q Dec
deriveLensBody Name
lensName Name
fieldName
      [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Dec]
sig [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec
body]


-- Given a record field name,
-- produces a single function declaration:
-- lensName f a = (\x -> a { field = x }) `fmap` f (field a)
deriveLensBody :: Name -> Name -> Q Dec
deriveLensBody :: Name -> Name -> Q Dec
deriveLensBody Name
lensName Name
fieldName = Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
lensName [Q Clause
defLine]
  where
    a :: Name
a = String -> Name
mkName String
"a"
    f :: Name
f = String -> Name
mkName String
"f"
    defLine :: Q Clause
defLine = [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Q Pat]
pats (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body) []
    pats :: [Q Pat]
pats = [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
a]
    body :: Q Exp
body = [| (\x -> $(Name -> Name -> Q Exp -> Q Exp
forall {m :: * -> *}. Quote m => Name -> Name -> m Exp -> m Exp
record Name
a Name
fieldName [|x|]))
              `fmap` $(Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f) (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
fieldName) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
a)))
            |]
    record :: Name -> Name -> m Exp -> m Exp
record Name
rec Name
fld m Exp
val = m Exp
val m Exp -> (Exp -> m Exp) -> m Exp
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Exp
v -> m Exp -> [m (Name, Exp)] -> m Exp
forall (m :: * -> *). Quote m => m Exp -> [m (Name, Exp)] -> m Exp
recUpdE (Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
rec) [(Name, Exp) -> m (Name, Exp)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
fld, Exp
v)]

-- | Derive traversals for each constructor in
-- a data or newtype declaration,
-- Traversals will be named by prefixing the
-- constructor name with an underscore.
--
-- Example usage:
--
-- > $(makeTraversals ''Foo)
makeTraversals :: Name -> Q [Dec]
makeTraversals :: Name -> Q [Dec]
makeTraversals = (String -> Maybe String) -> Name -> Q [Dec]
deriveTraversals (\String
s -> String -> Maybe String
forall a. a -> Maybe a
Just (Char
'_'Char -> String -> String
forall a. a -> [a] -> [a]
:String
s))

deriveTraversals :: (String -> Maybe String) -> Name -> Q [Dec]
deriveTraversals :: (String -> Maybe String) -> Name -> Q [Dec]
deriveTraversals String -> Maybe String
nameTransform Name
name = do
  LensTypeInfo
typeInfo <- Name -> Q LensTypeInfo
extractLensTypeInfo Name
name
  [Con]
constructors <- Name -> Q [Con]
extractConstructorInfo Name
name
  let derive1 :: Con -> Q [Dec]
derive1 = (String -> Maybe String) -> LensTypeInfo -> [Con] -> Con -> Q [Dec]
deriveTraversal String -> Maybe String
nameTransform LensTypeInfo
typeInfo [Con]
constructors
  [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (Con -> Q [Dec]) -> [Con] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Con -> Q [Dec]
derive1 [Con]
constructors


extractConstructorInfo :: Name -> Q [Con]
extractConstructorInfo :: Name -> Q [Con]
extractConstructorInfo Name
datatype = do
  let datatypeStr :: String
datatypeStr = Name -> String
nameBase Name
datatype
  Info
i <- Name -> Q Info
reify Name
datatype
  [Con] -> Q [Con]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Con] -> Q [Con]) -> [Con] -> Q [Con]
forall a b. (a -> b) -> a -> b
$ case Info
i of
    TyConI (DataD    Cxt
_ Name
_ [TyVarBndr ()]
_ Maybe Kind
_ [Con]
fs [DerivClause]
_) -> [Con]
fs
    TyConI (NewtypeD Cxt
_ Name
_ [TyVarBndr ()]
_ Maybe Kind
_ Con
f  [DerivClause]
_) -> [Con
f]
    Info
_ -> String -> [Con]
forall a. HasCallStack => String -> a
error (String -> [Con]) -> String -> [Con]
forall a b. (a -> b) -> a -> b
$ String
"Can't derive traversal for: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
datatypeStr


deriveTraversal :: (String -> Maybe String) -> LensTypeInfo -> [Con] -> Con -> Q [Dec]
deriveTraversal :: (String -> Maybe String) -> LensTypeInfo -> [Con] -> Con -> Q [Dec]
deriveTraversal String -> Maybe String
nameTransform LensTypeInfo
ty [Con]
cs Con
con = do
  let (Name
tyName, [TyVarBndr ()]
_tyVars) = LensTypeInfo
ty
      (Name
conN, Int
nArgs) = Con -> (Name, Int)
getConInfo Con
con
  case String -> Maybe String
nameTransform (Name -> String
nameBase Name
conN) of
    Maybe String
Nothing       -> [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    Just String
lensNameStr -> do
      let lensName :: Name
lensName = String -> Name
mkName String
lensNameStr
      [Dec]
sig  <- [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [] -- TODO
      Dec
body <- Name -> Name -> Int -> [Con] -> Q Dec
deriveTraversalBody Name
lensName Name
conN Int
nArgs [Con]
cs
      [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Dec]
sig [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec
body]


deconstructReconstruct :: Con -> String -> (Pat, Exp)
deconstructReconstruct :: Con -> String -> (Pat, Exp)
deconstructReconstruct Con
c String
nameBase = (Pat
pat, Exp
expr) where
#if MIN_VERSION_template_haskell(2,18,0)
  -- ConP Name [Type] [Pat]
  pat :: Pat
pat = Name -> Cxt -> [Pat] -> Pat
ConP Name
conN Cxt
forall a. Monoid a => a
mempty ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
argNames)
#else
  pat = ConP conN        (map VarP argNames)
#endif
  expr :: Exp
expr = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
AppE (Name -> Exp
ConE Name
conN) ((Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE [Name]
argNames)
  (Name
conN, Int
nArgs) = Con -> (Name, Int)
getConInfo Con
c
  argNames :: [Name]
argNames = Int -> String -> [Name]
mkArgNames Int
nArgs String
nameBase

getConInfo :: Con -> (Name, Int)
getConInfo :: Con -> (Name, Int)
getConInfo Con
con = case Con
con of
  NormalC Name
n [BangType]
tys -> (Name
n, [BangType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
tys)
  RecC Name
n [ConstructorFieldInfo]
tys -> (Name
n, [ConstructorFieldInfo] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorFieldInfo]
tys)
  InfixC BangType
t1 Name
n BangType
t2 -> (Name
n, Int
2)
  ForallC [TyVarBndr Specificity]
_ Cxt
_ Con
c
    -> String -> (Name, Int)
forall a. HasCallStack => String -> a
error (String -> (Name, Int)) -> String -> (Name, Int)
forall a b. (a -> b) -> a -> b
$ String
"Traversal derivation not supported: "
       String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"forall'd constructor: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase ((Name, Int) -> Name
forall a b. (a, b) -> a
fst ((Name, Int) -> Name) -> (Name, Int) -> Name
forall a b. (a -> b) -> a -> b
$ Con -> (Name, Int)
getConInfo Con
c)

deriveTraversalBody :: Name -> Name -> Int -> [Con] -> Q Dec
deriveTraversalBody :: Name -> Name -> Int -> [Con] -> Q Dec
deriveTraversalBody Name
lensName Name
constructorName Int
nArgs [Con]
cs =
  Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
lensName (Q Clause
defLineQ Clause -> [Q Clause] -> [Q Clause]
forall a. a -> [a] -> [a]
:[Q Clause]
fallbacks) where
    argNames :: [Name]
argNames = Int -> String -> [Name]
mkArgNames Int
nArgs String
"x"
    newArgNames :: [Name]
newArgNames = Int -> String -> [Name]
mkArgNames Int
nArgs String
"x'"
    argTup :: Exp
argTup = [Name] -> Exp
argTupFrom [Name]
argNames
    newArgPat :: Pat
newArgPat = Pat -> Pat
TildeP (Pat -> Pat) -> Pat -> Pat
forall a b. (a -> b) -> a -> b
$ [Name] -> Pat
argPatFrom [Name]
newArgNames
    newArgVars :: [Exp]
newArgVars = [Name] -> [Exp]
argVarsFrom [Name]
newArgNames
    t :: Name
t = String -> Name
mkName String
"t"
    k :: Name
k = String -> Name
mkName String
"k"
    constructorUncurried :: Exp
constructorUncurried =
      Name -> Pat -> [Exp] -> Exp
constructorUncurriedFrom Name
constructorName Pat
newArgPat [Exp]
newArgVars
    kApplied :: Exp
kApplied = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
k) Exp
argTup
    defLine :: Q Clause
defLine = [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Q Pat]
defPats (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
defBody) []
    defPats :: [Q Pat]
defPats = [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
k, Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
constructorName ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
argNames)]
    defBody :: Q Exp
defBody = [| $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
constructorUncurried)
                 `fmap` $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
kApplied)
               |]
    fallbacks :: [Q Clause]
fallbacks = (Con -> Q Clause) -> [Con] -> [Q Clause]
forall a b. (a -> b) -> [a] -> [b]
map Con -> Q Clause
forall {m :: * -> *}. Quote m => Con -> m Clause
fallbackFor ([Con] -> [Q Clause]) -> [Con] -> [Q Clause]
forall a b. (a -> b) -> a -> b
$ (Con -> Bool) -> [Con] -> [Con]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Con
c -> (Name, Int) -> Name
forall a b. (a, b) -> a
fst (Con -> (Name, Int)
getConInfo Con
c) Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
constructorName) [Con]
cs
    fallbackFor :: Con -> m Clause
fallbackFor Con
con = [m Pat] -> m Body -> [m Dec] -> m Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [m Pat]
fallbackPats (m Exp -> m Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB m Exp
fallbackBody) [] where
      (Pat
conPat, Exp
conApp) = Con -> String -> (Pat, Exp)
deconstructReconstruct Con
con String
"a"
      fallbackPats :: [m Pat]
fallbackPats = [m Pat
forall (m :: * -> *). Quote m => m Pat
wildP, Pat -> m Pat
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pat
conPat]
      fallbackBody :: m Exp
fallbackBody = [| pure $(Exp -> m Exp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
conApp) |]

constructorUncurriedFrom :: Name -> Pat -> [Exp] -> Exp
constructorUncurriedFrom :: Name -> Pat -> [Exp] -> Exp
constructorUncurriedFrom Name
conN Pat
pat = [Pat] -> Exp -> Exp
LamE [Pat
pat] (Exp -> Exp) -> ([Exp] -> Exp) -> [Exp] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Exp] -> Exp
mkBody where
  mkBody :: [Exp] -> Exp
mkBody = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
AppE (Name -> Exp
ConE Name
conN)

unitPat :: Pat
unitPat :: Pat
unitPat = [Pat] -> Pat
TupP []

unitExp :: Exp
unitExp :: Exp
unitExp = [Maybe Exp] -> Exp
TupE []

argPatFrom :: [Name] -> Pat
argPatFrom :: [Name] -> Pat
argPatFrom [] = Pat
unitPat
argPatFrom [Name
x] = Name -> Pat
VarP Name
x
argPatFrom [Name]
xs = [Pat] -> Pat
TupP ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
xs)

argTupFrom :: [Name] -> Exp
argTupFrom :: [Name] -> Exp
argTupFrom [] = Exp
unitExp
argTupFrom [Name
x] = Name -> Exp
VarE Name
x
argTupFrom [Name]
xs =
#if MIN_VERSION_template_haskell(2,16,0)
  [Maybe Exp] -> Exp
TupE ([Maybe Exp] -> Exp) -> [Maybe Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (Name -> Maybe Exp) -> [Name] -> [Maybe Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> (Name -> Exp) -> Name -> Maybe Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Exp
VarE) [Name]
xs
#else
  TupE $ map VarE xs
#endif

argVarsFrom :: [Name] -> [Exp]
argVarsFrom :: [Name] -> [Exp]
argVarsFrom = (Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE

mkArgNames :: Int -> String -> [Name]
mkArgNames :: Int -> String -> [Name]
mkArgNames Int
nArgs String
base = Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
nArgs ([Name] -> [Name]) -> ([Int] -> [Name]) -> [Int] -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Name) -> [Int] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Name
forall {a}. (Eq a, Num a, Show a) => a -> Name
toName ([Int] -> [Name]) -> [Int] -> [Name]
forall a b. (a -> b) -> a -> b
$ [Int
1 :: Int ..] where
  toName :: a -> Name
toName a
1 = String -> Name
mkName String
base
  toName a
n = String -> Name
mkName (String
base String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
n)