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

module Data.Profunctor.Product.Internal.TH where

import Data.Profunctor (dimap, lmap)
import Data.Profunctor.Product hiding (constructor, field)
import Data.Profunctor.Product.Default (Default, def)
import qualified Data.Profunctor.Product.Newtype as N
import Language.Haskell.TH (Dec(DataD, SigD, FunD, InstanceD, NewtypeD),
                            mkName, newName, nameBase,
                            Con(RecC, NormalC),
                            Clause(Clause),
                            Type(VarT, ForallT, AppT, ConT),
                            Body(NormalB), Q,
                            Exp(ConE, VarE, AppE, TupE, LamE),
                            Pat(TupP, VarP, ConP), Name,
                            Info(TyConI), reify, conE, appT, conT, varE, varP,
                            instanceD, Overlap(Incoherent), Pred)
import Language.Haskell.TH.Datatype.TyVarBndr (TyVarBndr_, TyVarBndrSpec,
                                               plainTVSpecified, tvName)
import Control.Monad ((<=<))
import Control.Applicative (pure, liftA2, (<$>), (<*>))

makeAdaptorAndInstanceI :: Bool -> Maybe String -> Name -> Q [Dec]
makeAdaptorAndInstanceI :: Bool -> Maybe Error -> Name -> Q [Dec]
makeAdaptorAndInstanceI Bool
inferrable Maybe Error
adaptorNameM =
  forall {m :: * -> *} {a}. MonadFail m => Either Error (m a) -> m a
returnOrFail forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall {a} {b}. (a -> b) -> a -> Q b
r Info -> Either Error (Q [Dec])
makeAandIE forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Name -> Q Info
reify
  where r :: (a -> b) -> a -> Q b
r = (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
.)
        returnOrFail :: Either Error (m a) -> m a
returnOrFail (Right m a
decs) = m a
decs
        returnOrFail (Left Error
errMsg) = forall (m :: * -> *) a. MonadFail m => Error -> m a
fail Error
errMsg
        makeAandIE :: Info -> Either Error (Q [Dec])
makeAandIE = [Maybe (Either () ())]
-> Maybe Error -> Info -> Either Error (Q [Dec])
makeAdaptorAndInstanceE [Maybe (Either () ())]
sides Maybe Error
adaptorNameM
        sides :: [Maybe (Either () ())]
sides = case Bool
inferrable of
          Bool
True  -> [forall a. a -> Maybe a
Just (forall a b. a -> Either a b
Left ()), forall a. a -> Maybe a
Just (forall a b. b -> Either a b
Right ())]
          Bool
False -> [forall a. Maybe a
Nothing]

type Error = String

makeAdaptorAndInstanceE :: [Maybe (Either () ())]
                        -> Maybe String
                        -> Info
                        -> Either Error (Q [Dec])
makeAdaptorAndInstanceE :: [Maybe (Either () ())]
-> Maybe Error -> Info -> Either Error (Q [Dec])
makeAdaptorAndInstanceE [Maybe (Either () ())]
sides Maybe Error
adaptorNameM Info
info = do
  DataDecStuff
dataDecStuff <- Info -> Either Error DataDecStuff
dataDecStuffOfInfo Info
info
  let tyName :: Name
tyName  = DataDecStuff -> Name
dTyName  DataDecStuff
dataDecStuff
      tyVars :: [Name]
tyVars  = DataDecStuff -> [Name]
dTyVars  DataDecStuff
dataDecStuff
      conName :: Name
conName = DataDecStuff -> Name
dConName DataDecStuff
dataDecStuff
      conTys :: ConTysFields
conTys  = DataDecStuff -> ConTysFields
dConTys  DataDecStuff
dataDecStuff

      numTyVars :: Int
numTyVars = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
tyVars
      numConTys :: Int
numConTys = ConTysFields -> Int
lengthCons ConTysFields
conTys
      defaultAdaptorName :: Name
defaultAdaptorName = (Error -> Name
mkName forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Error
"p" forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Error
nameBase) Name
conName
      adaptorNameN :: Name
adaptorNameN = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Name
defaultAdaptorName Error -> Name
mkName Maybe Error
adaptorNameM
      adaptorSig' :: Q Dec
adaptorSig' = Name -> Int -> Name -> Q Dec
adaptorSig Name
tyName Int
numTyVars Name
adaptorNameN
      adaptorDefinition' :: Name -> Q Dec
adaptorDefinition' = case ConTysFields
conTys of
        ConTys   [Type]
_        -> Int -> Name -> Name -> Q Dec
adaptorDefinition Int
numTyVars Name
conName
        FieldTys [(Name, Type)]
fieldTys -> forall name. Name -> [(Name, name)] -> Name -> Q Dec
adaptorDefinitionFields Name
conName [(Name, Type)]
fieldTys

      instanceDefinition' :: [Q Dec]
instanceDefinition' = forall a b. (a -> b) -> [a] -> [b]
map (\Maybe (Either () ())
side ->
        Maybe (Either () ()) -> Name -> Int -> Int -> Name -> Name -> Q Dec
instanceDefinition Maybe (Either () ())
side Name
tyName Int
numTyVars Int
numConTys Name
adaptorNameN Name
conName)
        [Maybe (Either () ())]
sides

      newtypeInstance' :: Q [Dec]
newtypeInstance' = if Int
numConTys forall a. Eq a => a -> a -> Bool
== Int
1 then
                           Name -> Name -> Q [Dec]
newtypeInstance Name
conName Name
tyName
                         else
                           forall (m :: * -> *) a. Monad m => a -> m a
return []

  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
    [Dec]
as <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ( [ Q Dec
adaptorSig'
                     , Name -> Q Dec
adaptorDefinition' Name
adaptorNameN ]
                   forall a. [a] -> [a] -> [a]
++ [Q Dec]
instanceDefinition' )
    [Dec]
ns <- Q [Dec]
newtypeInstance'
    forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec]
as forall a. [a] -> [a] -> [a]
++ [Dec]
ns)

newtypeInstance :: Name -> Name -> Q [Dec]
newtypeInstance :: Name -> Name -> Q [Dec]
newtypeInstance Name
conName Name
tyName = do
  Name
x <- forall (m :: * -> *). Quote m => Error -> m Name
newName Error
"x"

  let body :: [Dec]
body = [ Name -> [Clause] -> Dec
FunD 'N.constructor [Body -> Clause
simpleClause (Exp -> Body
NormalB (Name -> Exp
ConE Name
conName))]
             , Name -> [Clause] -> Dec
FunD 'N.field [Body -> Clause
simpleClause (Exp -> Body
NormalB ([Pat] -> Exp -> Exp
LamE [Name -> [Pat] -> Pat
conP Name
conName [Name -> Pat
VarP Name
x]] (Name -> Exp
VarE Name
x)))] ]
  Dec
i <- forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD (forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
                 [t| $(conT ''N.Newtype) $(conT tyName) |]
                 (forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec]
body)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
i]

data ConTysFields = ConTys   [Type]
                  -- ^^ The type of each constructor field
                  | FieldTys [(Name, Type)]
                  -- ^^ The fieldname and type of each constructor field

lengthCons :: ConTysFields -> Int
lengthCons :: ConTysFields -> Int
lengthCons (ConTys [Type]
l)   = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
l
lengthCons (FieldTys [(Name, Type)]
l) = forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Name, Type)]
l

data DataDecStuff = DataDecStuff {
    DataDecStuff -> Name
dTyName  :: Name
  , DataDecStuff -> [Name]
dTyVars  :: [Name]
  , DataDecStuff -> Name
dConName :: Name
  , DataDecStuff -> ConTysFields
dConTys  :: ConTysFields
  }

dataDecStuffOfInfo :: Info -> Either Error DataDecStuff
dataDecStuffOfInfo :: Info -> Either Error DataDecStuff
dataDecStuffOfInfo (TyConI (DataD [Type]
_cxt Name
tyName [TyVarBndr ()]
tyVars Maybe Type
_kind [Con]
constructors [DerivClause]
_deriving)) =
  do
    (Name
conName, ConTysFields
conTys) <- [Con] -> Either Error (Name, ConTysFields)
extractConstructorStuff [Con]
constructors
    let tyVars' :: [Name]
tyVars' = forall a b. (a -> b) -> [a] -> [b]
map forall flag. TyVarBndr_ flag -> Name
varNameOfBinder [TyVarBndr ()]
tyVars
    forall (m :: * -> *) a. Monad m => a -> m a
return DataDecStuff { dTyName :: Name
dTyName  = Name
tyName
                        , dTyVars :: [Name]
dTyVars  = [Name]
tyVars'
                        , dConName :: Name
dConName = Name
conName
                        , dConTys :: ConTysFields
dConTys  = ConTysFields
conTys
                        }

dataDecStuffOfInfo (TyConI (NewtypeD [Type]
_cxt Name
tyName [TyVarBndr ()]
tyVars Maybe Type
_kind Con
constructor [DerivClause]
_deriving)) =
  do
    (Name
conName, ConTysFields
conTys) <- [Con] -> Either Error (Name, ConTysFields)
extractConstructorStuff [Con
constructor]
    let tyVars' :: [Name]
tyVars' = forall a b. (a -> b) -> [a] -> [b]
map forall flag. TyVarBndr_ flag -> Name
varNameOfBinder [TyVarBndr ()]
tyVars
    forall (m :: * -> *) a. Monad m => a -> m a
return DataDecStuff { dTyName :: Name
dTyName  = Name
tyName
                        , dTyVars :: [Name]
dTyVars  = [Name]
tyVars'
                        , dConName :: Name
dConName = Name
conName
                        , dConTys :: ConTysFields
dConTys  = ConTysFields
conTys
                        }
dataDecStuffOfInfo Info
_ = forall a b. a -> Either a b
Left Error
"That doesn't look like a data or newtype declaration to me"

varNameOfBinder :: TyVarBndr_ flag -> Name
varNameOfBinder :: forall flag. TyVarBndr_ flag -> Name
varNameOfBinder = forall flag. TyVarBndr_ flag -> Name
tvName

conStuffOfConstructor :: Con -> Either Error (Name, ConTysFields)
conStuffOfConstructor :: Con -> Either Error (Name, ConTysFields)
conStuffOfConstructor = \case
  NormalC Name
conName [BangType]
st -> forall (m :: * -> *) a. Monad m => a -> m a
return (Name
conName, [Type] -> ConTysFields
ConTys (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [BangType]
st))
  RecC Name
conName [VarBangType]
vst -> forall (m :: * -> *) a. Monad m => a -> m a
return (Name
conName, [(Name, Type)] -> ConTysFields
FieldTys (forall a b. (a -> b) -> [a] -> [b]
map (\(Name
n, Bang
_, Type
t) -> (Name
n, Type
t)) [VarBangType]
vst))
  Con
_ -> forall a b. a -> Either a b
Left Error
"I can't deal with your constructor type"

constructorOfConstructors :: [Con] -> Either Error Con
constructorOfConstructors :: [Con] -> Either Error Con
constructorOfConstructors = \case
  [Con
single] -> forall (m :: * -> *) a. Monad m => a -> m a
return Con
single
  []       -> forall a b. a -> Either a b
Left Error
"I need at least one constructor"
  [Con]
_many    -> forall a b. a -> Either a b
Left Error
"I can't deal with more than one constructor"

extractConstructorStuff :: [Con] -> Either Error (Name, ConTysFields)
extractConstructorStuff :: [Con] -> Either Error (Name, ConTysFields)
extractConstructorStuff = Con -> Either Error (Name, ConTysFields)
conStuffOfConstructor forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< [Con] -> Either Error Con
constructorOfConstructors

instanceDefinition :: Maybe (Either () ())
                   -> Name
                   -> Int
                   -> Int
                   -> Name
                   -> Name
                   -> Q Dec
instanceDefinition :: Maybe (Either () ()) -> Name -> Int -> Int -> Name -> Name -> Q Dec
instanceDefinition Maybe (Either () ())
side Name
tyName' Int
numTyVars Int
numConVars Name
adaptorName' Name
conName =
  Q Dec
instanceDec
  where instanceDec :: Q Dec
instanceDec = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2
            (\[Type]
i Type
j -> Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD (Overlap
Incoherent forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Maybe (Either () ())
side) [Type]
i Type
j [Dec
defDefinition])
            Q [Type]
instanceCxt Q Type
instanceType
        p :: Applicative m => m Type
        p :: forall (m :: * -> *). Applicative m => m Type
p = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Error -> Type
varTS Error
"p"
        x :: Q Type
x = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Error -> Type
varTS Error
"x"

        instanceCxt :: Q [Type]
instanceCxt = do
            [Type]
typeMatch' <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q Type]
typeMatch
            Type
productProfunctor_p' <- Q Type
productProfunctor_p
            [Type]
default_p_as0_as1 <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Error -> Q Type
default_p_a0_a1 (Int -> [Error]
allTyVars Int
numTyVars)
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type
productProfunctor_p' forall a. a -> [a] -> [a]
: [Type]
typeMatch' forall a. [a] -> [a] -> [a]
++ [Type]
default_p_as0_as1)

        productProfunctor_p :: Q Pred
        productProfunctor_p :: Q Type
productProfunctor_p = Name -> [Q Type] -> Q Type
classP ''ProductProfunctor [forall (m :: * -> *). Applicative m => m Type
p]

        ([Q Type]
typeMatch, Q Type
pArg0, Q Type
pArg1) = case Maybe (Either () ())
side of
            Maybe (Either () ())
Nothing ->         ([],                       Q Type
tyName0, Q Type
tyName1)
            Just (Left ())  -> ([ [t| $x ~ $tyName0 |] ], Q Type
x,       Q Type
tyName1)
            Just (Right ()) -> ([ [t| $x ~ $tyName1 |] ], Q Type
tyName0, Q Type
x)

        tyName0 :: Q Type
tyName0 = Error -> Q Type
tyName Error
"0"
        tyName1 :: Q Type
tyName1 = Error -> Q Type
tyName Error
"1"

        default_p_a0_a1 :: String -> Q Pred
        default_p_a0_a1 :: Error -> Q Type
default_p_a0_a1 Error
a  = Name -> [Q Type] -> Q Type
classP ''Default [forall (m :: * -> *). Applicative m => m Type
p, forall {f :: * -> *}. Applicative f => Error -> Error -> f Type
tvar Error
a Error
"0", forall {f :: * -> *}. Applicative f => Error -> Error -> f Type
tvar Error
a Error
"1"]

        tvar :: Error -> Error -> f Type
tvar Error
a Error
i = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Error -> Error -> Type
mkTySuffix Error
i Error
a)

        tyName :: String -> Q Type
        tyName :: Error -> Q Type
tyName Error
suffix = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Name -> Error -> Int -> Type
pArg' Name
tyName' Error
suffix Int
numTyVars

        instanceType :: Q Type
instanceType = [t| $(conT ''Default) $p $pArg0 $pArg1 |]

        defDefinition :: Dec
defDefinition = Name -> [Clause] -> Dec
FunD 'def [Body -> Clause
simpleClause Body
defBody]
        defBody :: Body
defBody = Exp -> Body
NormalB(Name -> Exp
VarE Name
adaptorName' Exp -> Exp -> Exp
`AppE` Exp -> [Exp] -> Exp
appEAll (Name -> Exp
ConE Name
conName) [Exp]
defsN)
        defsN :: [Exp]
defsN = forall a. Int -> a -> [a]
replicate Int
numConVars (Name -> Exp
VarE 'def)

adaptorSig :: Name -> Int -> Name -> Q Dec
adaptorSig :: Name -> Int -> Name -> Q Dec
adaptorSig Name
tyName' Int
numTyVars Name
n = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> Type -> Dec
SigD Name
n) Q Type
adaptorType
  where p :: Name
p = Error -> Name
mkName Error
"p"
        adaptorType :: Q Type
adaptorType = [TyVarBndr Specificity] -> [Type] -> Type -> Type
ForallT [TyVarBndr Specificity]
scope forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q [Type]
adaptorCxt forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Q Type
adaptorAfterCxt
        adaptorAfterCxt :: Q Type
adaptorAfterCxt = [t| $before -> $after |]
        adaptorCxt :: Q [Type]
adaptorCxt = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> [a] -> [a]
:[]) (Name -> [Q Type] -> Q Type
classP ''ProductProfunctor [Q Type
pType])
        before :: Q Type
before = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Type -> Type -> Type
AppT) (forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Type
ConT Name
tyName')) [Q Type]
pArgs
        pType :: Q Type
pType = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Name -> Type
VarT Name
p
        pArgs :: [Q Type]
pArgs = forall a b. (a -> b) -> [a] -> [b]
map Error -> Q Type
pApp [Error]
tyVars
        pApp :: String  -> Q Type
        pApp :: Error -> Q Type
pApp Error
v = [t| $pType $(mkVarTsuffix "0" v) $(mkVarTsuffix "1" v) |]


        tyVars :: [Error]
tyVars = Int -> [Error]
allTyVars Int
numTyVars

        pArg :: String -> Q Type
        pArg :: Error -> Q Type
pArg Error
s = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Name -> Error -> Int -> Type
pArg' Name
tyName' Error
s Int
numTyVars

        after :: Q Type
after = [t| $pType $(pArg "0") $(pArg "1") |]

        scope :: [TyVarBndr Specificity]
scope = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [Name -> TyVarBndr Specificity
plainTVSpecified Name
p]
                       , forall a b. (a -> b) -> [a] -> [b]
map (Error -> Error -> TyVarBndr Specificity
mkTyVarsuffix Error
"0") [Error]
tyVars
                       , forall a b. (a -> b) -> [a] -> [b]
map (Error -> Error -> TyVarBndr Specificity
mkTyVarsuffix Error
"1") [Error]
tyVars ]

-- This should probably fail in a more graceful way than an error. I
-- guess via Either or Q.
tupleAdaptors :: Int -> Name
tupleAdaptors :: Int -> Name
tupleAdaptors Int
n = case Int
n of Int
1  -> 'p1
                            Int
2  -> 'p2
                            Int
3  -> 'p3
                            Int
4  -> 'p4
                            Int
5  -> 'p5
                            Int
6  -> 'p6
                            Int
7  -> 'p7
                            Int
8  -> 'p8
                            Int
9  -> 'p9
                            Int
10 -> 'p10
                            Int
11 -> 'p11
                            Int
12 -> 'p12
                            Int
13 -> 'p13
                            Int
14 -> 'p14
                            Int
15 -> 'p15
                            Int
16 -> 'p16
                            Int
17 -> 'p17
                            Int
18 -> 'p18
                            Int
19 -> 'p19
                            Int
20 -> 'p20
                            Int
21 -> 'p21
                            Int
22 -> 'p22
                            Int
23 -> 'p23
                            Int
24 -> 'p24
                            Int
25 -> 'p25
                            Int
26 -> 'p26
                            Int
27 -> 'p27
                            Int
28 -> 'p28
                            Int
29 -> 'p29
                            Int
30 -> 'p30
                            Int
31 -> 'p31
                            Int
32 -> 'p32
                            Int
33 -> 'p33
                            Int
34 -> 'p34
                            Int
35 -> 'p35
                            Int
36 -> 'p36
                            Int
37 -> 'p37
                            Int
38 -> 'p38
                            Int
39 -> 'p39
                            Int
40 -> 'p40
                            Int
41 -> 'p41
                            Int
42 -> 'p42
                            Int
43 -> 'p43
                            Int
44 -> 'p44
                            Int
45 -> 'p45
                            Int
46 -> 'p46
                            Int
47 -> 'p47
                            Int
48 -> 'p48
                            Int
49 -> 'p49
                            Int
50 -> 'p50
                            Int
51 -> 'p51
                            Int
52 -> 'p52
                            Int
53 -> 'p53
                            Int
54 -> 'p54
                            Int
55 -> 'p55
                            Int
56 -> 'p56
                            Int
57 -> 'p57
                            Int
58 -> 'p58
                            Int
59 -> 'p59
                            Int
60 -> 'p60
                            Int
61 -> 'p61
                            Int
62 -> 'p62
                            Int
_  -> forall a. HasCallStack => Error -> a
error Error
errorMsg
  where errorMsg :: Error
errorMsg = Error
"Data.Profunctor.Product.TH: "
                   forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> Error
show Int
n
                   forall a. [a] -> [a] -> [a]
++ Error
" is too many type variables for me!"

adaptorDefinition :: Int -> Name -> Name -> Q Dec
adaptorDefinition :: Int -> Name -> Name -> Q Dec
adaptorDefinition Int
numConVars Name
conName Name
x = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> [Clause] -> Dec
FunD Name
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure) Q Clause
clause
  where clause :: Q Clause
clause = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Body
b -> [Pat] -> Body -> [Dec] -> Clause
Clause [] Body
b [Dec]
wheres) Q Body
body
        toTupleN :: Name
toTupleN = Error -> Name
mkName Error
"toTuple"
        fromTupleN :: Name
fromTupleN = Error -> Name
mkName Error
"fromTuple"
        toTupleE :: Q Exp
toTupleE = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
toTupleN
        fromTupleE :: Q Exp
fromTupleE = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
fromTupleN
        theDimap :: Q Exp
theDimap = [| $(varE 'dimap) $toTupleE $fromTupleE |]
        pN :: Q Exp
pN = forall (m :: * -> *). Quote m => Name -> m Exp
varE (Int -> Name
tupleAdaptors Int
numConVars)
        body :: Q Body
body = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> Body
NormalB [| $theDimap . $pN . $toTupleE |]
        wheres :: [Dec]
wheres = [Name -> (Name, Int) -> Dec
toTuple Name
conName (Name
toTupleN, Int
numConVars),
                  Name -> (Name, Int) -> Dec
fromTuple Name
conName (Name
fromTupleN, Int
numConVars)]

adaptorDefinitionFields :: Name -> [(Name, name)] -> Name -> Q Dec
adaptorDefinitionFields :: forall name. Name -> [(Name, name)] -> Name -> Q Dec
adaptorDefinitionFields Name
conName [(Name, name)]
fieldsTys Name
adaptorName =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> [Clause] -> Dec
FunD Name
adaptorName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure) Q Clause
clause
  where fields :: [Name]
fields = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Name, name)]
fieldsTys
        -- TODO: vv f should be generated in Q
        fP :: Q Pat
fP = forall (m :: * -> *). Quote m => Name -> m Pat
varP (Error -> Name
mkName Error
"f")
        fE :: Q Exp
fE = forall (m :: * -> *). Quote m => Name -> m Exp
varE (Error -> Name
mkName Error
"f")
        clause :: Q Clause
clause = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (\Pat
fP' Exp
b -> [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
fP'] (Exp -> Body
NormalB Exp
b) []) Q Pat
fP Q Exp
body
        body :: Q Exp
body = case [Name]
fields of
          []             -> forall a. HasCallStack => Error -> a
error Error
"Can't handle no fields in constructor"
          Name
field1:[Name]
fields' ->
            let first :: Q Exp
first =
                  [| $(varE '(***$)) $(conE conName) $(theLmap field1) |]
                app :: Q Exp -> Name -> Q Exp
app Q Exp
x Name
y =
                  [| $(varE '(****)) $x $(theLmap y) |]
            in forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Exp -> Name -> Q Exp
app Q Exp
first [Name]
fields'

        theLmap :: Name -> Q Exp
theLmap Name
field =
          [| $(varE 'lmap) $(varE field) ($(varE field) $fE) |]

xTuple :: ([Pat] -> Pat) -> ([Exp] -> Exp) -> (Name, Int) -> Dec
xTuple :: ([Pat] -> Pat) -> ([Exp] -> Exp) -> (Name, Int) -> Dec
xTuple [Pat] -> Pat
patCon [Exp] -> Exp
retCon (Name
funN, Int
numTyVars) = Name -> [Clause] -> Dec
FunD Name
funN [Clause
clause]
  where clause :: Clause
clause = [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
pat] Body
body []
        pat :: Pat
pat = [Pat] -> Pat
patCon [Pat]
varPats
        body :: Body
body = Exp -> Body
NormalB ([Exp] -> Exp
retCon [Exp]
varExps)
        varPats :: [Pat]
varPats = forall a b. (a -> b) -> [a] -> [b]
map Error -> Pat
varPS (Int -> [Error]
allTyVars Int
numTyVars)
        varExps :: [Exp]
varExps = forall a b. (a -> b) -> [a] -> [b]
map Error -> Exp
varS (Int -> [Error]
allTyVars Int
numTyVars)

classP :: Name -> [Q Type] -> Q Type
classP :: Name -> [Q Type] -> Q Type
classP Name
class_ = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Name -> m Type
conT Name
class_)

tupP :: [Pat] -> Pat
tupP :: [Pat] -> Pat
tupP [Pat
p] = Pat
p
tupP [Pat]
ps  = [Pat] -> Pat
TupP [Pat]
ps

tupE :: [Exp] -> Exp
tupE :: [Exp] -> Exp
tupE [Exp
e] = Exp
e
tupE [Exp]
es  = [Maybe Exp] -> Exp
TupE
#if MIN_VERSION_template_haskell(2,16,0)
           forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> Maybe a
Just
#endif
           [Exp]
es

conP :: Name -> [Pat] -> Pat
conP :: Name -> [Pat] -> Pat
conP Name
conname = Name -> [Type] -> [Pat] -> Pat
ConP Name
conname
#if MIN_VERSION_template_haskell(2,18,0)
               []
#endif

fromTuple :: Name -> (Name, Int) -> Dec
fromTuple :: Name -> (Name, Int) -> Dec
fromTuple Name
conName = ([Pat] -> Pat) -> ([Exp] -> Exp) -> (Name, Int) -> Dec
xTuple [Pat] -> Pat
patCon [Exp] -> Exp
retCon
  where patCon :: [Pat] -> Pat
patCon = [Pat] -> Pat
tupP
        retCon :: [Exp] -> Exp
retCon = Exp -> [Exp] -> Exp
appEAll (Name -> Exp
ConE Name
conName)

toTuple :: Name -> (Name, Int) -> Dec
toTuple :: Name -> (Name, Int) -> Dec
toTuple Name
conName = ([Pat] -> Pat) -> ([Exp] -> Exp) -> (Name, Int) -> Dec
xTuple [Pat] -> Pat
patCon [Exp] -> Exp
retCon
  where patCon :: [Pat] -> Pat
patCon = Name -> [Pat] -> Pat
conP Name
conName
        retCon :: [Exp] -> Exp
retCon = [Exp] -> Exp
tupE

{-
Note that we can also do the instance definition like this, but it would
require pulling the to/fromTuples to the top level

instance (ProductProfunctor p, Default p a a', Default p b b',
          Default p c c', Default p d d', Default p e e',
          Default p f f', Default p g g', Default p h h')
         => Default p (LedgerRow' a b c d e f g h)
                      (LedgerRow' a' b' c' d' e' f' g' h') where
  def = dimap tupleOfLedgerRow lRowOfTuple def
-}

pArg' :: Name -> String -> Int -> Type
pArg' :: Name -> Error -> Int -> Type
pArg' Name
tn Error
s = Type -> [Type] -> Type
appTAll (Name -> Type
ConT Name
tn) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Error -> Type
varTS forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. [a] -> [a] -> [a]
++Error
s)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Error]
allTyVars

allTyVars :: Int -> [String]
allTyVars :: Int -> [Error]
allTyVars Int
numTyVars = forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> Error
varA [Int]
tyNums
  where varA :: a -> Error
varA a
i = Error
"a" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> Error
show a
i forall a. [a] -> [a] -> [a]
++ Error
"_"
        tyNums :: [Int]
        tyNums :: [Int]
tyNums = [Int
1..Int
numTyVars]

varS :: String -> Exp
varS :: Error -> Exp
varS = Name -> Exp
VarE forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> Name
mkName

varPS :: String -> Pat
varPS :: Error -> Pat
varPS = Name -> Pat
VarP forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> Name
mkName

mkTyVarsuffix :: String -> String -> TyVarBndrSpec
mkTyVarsuffix :: Error -> Error -> TyVarBndr Specificity
mkTyVarsuffix Error
s = Name -> TyVarBndr Specificity
plainTVSpecified forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> Name
mkName forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. [a] -> [a] -> [a]
++Error
s)

mkTySuffix :: String -> String -> Type
mkTySuffix :: Error -> Error -> Type
mkTySuffix Error
s = Error -> Type
varTS forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. [a] -> [a] -> [a]
++Error
s)

mkVarTsuffix :: String -> String -> Q Type
mkVarTsuffix :: Error -> Error -> Q Type
mkVarTsuffix Error
s = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Type
VarT forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> Name
mkName forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. [a] -> [a] -> [a]
++Error
s)

varTS :: String -> Type
varTS :: Error -> Type
varTS = Name -> Type
VarT forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> Name
mkName

appTAll :: Type -> [Type] -> Type
appTAll :: Type -> [Type] -> Type
appTAll = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT

appEAll :: Exp -> [Exp] -> Exp
appEAll :: Exp -> [Exp] -> Exp
appEAll = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
AppE

simpleClause :: Body -> Clause
simpleClause :: Body -> Clause
simpleClause Body
x = [Pat] -> Body -> [Dec] -> Clause
Clause [] Body
x []