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

type Error = String

makeAdaptorAndInstanceE :: [Maybe (Either () ())]
                        -> Maybe String
                        -> Info
                        -> Either Error (Q [Dec])
makeAdaptorAndInstanceE :: [Maybe (Either () ())]
-> Maybe String -> Info -> Either String (Q [Dec])
makeAdaptorAndInstanceE [Maybe (Either () ())]
sides Maybe String
adaptorNameM Info
info = do
  DataDecStuff
dataDecStuff <- Info -> Either String 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 = [Name] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
tyVars
      numConTys :: Int
numConTys = ConTysFields -> Int
lengthCons ConTysFields
conTys
      defaultAdaptorName :: Name
defaultAdaptorName = (String -> Name
mkName (String -> Name) -> (Name -> String) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"p" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase) Name
conName
      adaptorNameN :: Name
adaptorNameN = Name -> (String -> Name) -> Maybe String -> Name
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Name
defaultAdaptorName String -> Name
mkName Maybe String
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 -> Name -> [(Name, Type)] -> Name -> Q Dec
forall name. Name -> [(Name, name)] -> Name -> Q Dec
adaptorDefinitionFields Name
conName [(Name, Type)]
fieldTys

      instanceDefinition' :: [Q Dec]
instanceDefinition' = (Maybe (Either () ()) -> Q Dec)
-> [Maybe (Either () ())] -> [Q Dec]
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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then
                           Name -> Name -> Q [Dec]
newtypeInstance Name
conName Name
tyName
                         else
                           [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []

  Q [Dec] -> Either String (Q [Dec])
forall (m :: * -> *) a. Monad m => a -> m a
return (Q [Dec] -> Either String (Q [Dec]))
-> Q [Dec] -> Either String (Q [Dec])
forall a b. (a -> b) -> a -> b
$ do
    [Dec]
as <- [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ( [ Q Dec
adaptorSig'
                     , Name -> Q Dec
adaptorDefinition' Name
adaptorNameN ]
                   [Q Dec] -> [Q Dec] -> [Q Dec]
forall a. [a] -> [a] -> [a]
++ [Q Dec]
instanceDefinition' )
    [Dec]
ns <- Q [Dec]
newtypeInstance'
    [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec]
as [Dec] -> [Dec] -> [Dec]
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 <- String -> Q Name
newName String
"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 <- CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceD ([Type] -> CxtQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
                 [t| $(conT ''N.Newtype) $(conT tyName) |]
                 ((Dec -> Q Dec) -> [Dec] -> [Q Dec]
forall a b. (a -> b) -> [a] -> [b]
map Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec]
body)
  [Dec] -> Q [Dec]
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)   = [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
l
lengthCons (FieldTys [(Name, Type)]
l) = [(Name, Type)] -> Int
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 String DataDecStuff
dataDecStuffOfInfo (TyConI (DataD [Type]
_cxt Name
tyName [TyVarBndr]
tyVars Maybe Type
_kind [Con]
constructors [DerivClause]
_deriving)) =
  do
    (Name
conName, ConTysFields
conTys) <- [Con] -> Either String (Name, ConTysFields)
extractConstructorStuff [Con]
constructors
    let tyVars' :: [Name]
tyVars' = (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Name
forall flag. TyVarBndr -> Name
varNameOfBinder [TyVarBndr]
tyVars
    DataDecStuff -> Either String DataDecStuff
forall (m :: * -> *) a. Monad m => a -> m a
return DataDecStuff :: Name -> [Name] -> Name -> ConTysFields -> DataDecStuff
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 String (Name, ConTysFields)
extractConstructorStuff [Con
constructor]
    let tyVars' :: [Name]
tyVars' = (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Name
forall flag. TyVarBndr -> Name
varNameOfBinder [TyVarBndr]
tyVars
    DataDecStuff -> Either String DataDecStuff
forall (m :: * -> *) a. Monad m => a -> m a
return DataDecStuff :: Name -> [Name] -> Name -> ConTysFields -> DataDecStuff
DataDecStuff { dTyName :: Name
dTyName  = Name
tyName
                        , dTyVars :: [Name]
dTyVars  = [Name]
tyVars'
                        , dConName :: Name
dConName = Name
conName
                        , dConTys :: ConTysFields
dConTys  = ConTysFields
conTys
                        }
dataDecStuffOfInfo Info
_ = String -> Either String DataDecStuff
forall a b. a -> Either a b
Left String
"That doesn't look like a data or newtype declaration to me"

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

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

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

extractConstructorStuff :: [Con] -> Either Error (Name, ConTysFields)
extractConstructorStuff :: [Con] -> Either String (Name, ConTysFields)
extractConstructorStuff = Con -> Either String (Name, ConTysFields)
conStuffOfConstructor (Con -> Either String (Name, ConTysFields))
-> ([Con] -> Either String Con)
-> [Con]
-> Either String (Name, ConTysFields)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< [Con] -> Either String 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 = ([Type] -> Type -> Dec) -> CxtQ -> TypeQ -> Q Dec
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 Overlap -> Maybe (Either () ()) -> Maybe Overlap
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Maybe (Either () ())
side) [Type]
i Type
j [Dec
defDefinition])
            CxtQ
instanceCxt TypeQ
instanceType
        p :: Applicative m => m Type
        p :: m Type
p = Type -> m Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> m Type) -> Type -> m Type
forall a b. (a -> b) -> a -> b
$ String -> Type
varTS String
"p"
        x :: TypeQ
x = Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> TypeQ) -> Type -> TypeQ
forall a b. (a -> b) -> a -> b
$ String -> Type
varTS String
"x"

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

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

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

        tyName0 :: TypeQ
tyName0 = String -> TypeQ
tyName String
"0"
        tyName1 :: TypeQ
tyName1 = String -> TypeQ
tyName String
"1"

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

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

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

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


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

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

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

        scope :: [TyVarBndr]
scope = [[TyVarBndr]] -> [TyVarBndr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [Name -> TyVarBndr
plainTVSpecified Name
p]
                       , (String -> TyVarBndr) -> [String] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> TyVarBndr
mkTyVarsuffix String
"0") [String]
tyVars
                       , (String -> TyVarBndr) -> [String] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> TyVarBndr
mkTyVarsuffix String
"1") [String]
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
_  -> String -> Name
forall a. HasCallStack => String -> a
error String
errorMsg
  where errorMsg :: String
errorMsg = String
"Data.Profunctor.Product.TH: "
                   String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n
                   String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" 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 = (Clause -> Dec) -> Q Clause -> Q Dec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> [Clause] -> Dec
FunD Name
x ([Clause] -> Dec) -> (Clause -> [Clause]) -> Clause -> Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Clause -> [Clause]
forall (f :: * -> *) a. Applicative f => a -> f a
pure) Q Clause
clause
  where clause :: Q Clause
clause = (Body -> Clause) -> Q Body -> Q 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 = String -> Name
mkName String
"toTuple"
        fromTupleN :: Name
fromTupleN = String -> Name
mkName String
"fromTuple"
        toTupleE :: ExpQ
toTupleE = Name -> ExpQ
varE Name
toTupleN
        fromTupleE :: ExpQ
fromTupleE = Name -> ExpQ
varE Name
fromTupleN
        theDimap :: ExpQ
theDimap = [| $(varE 'dimap) $toTupleE $fromTupleE |]
        pN :: ExpQ
pN = Name -> ExpQ
varE (Int -> Name
tupleAdaptors Int
numConVars)
        body :: Q Body
body = (Exp -> Body) -> ExpQ -> Q 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 :: Name -> [(Name, name)] -> Name -> Q Dec
adaptorDefinitionFields Name
conName [(Name, name)]
fieldsTys Name
adaptorName =
  (Clause -> Dec) -> Q Clause -> Q Dec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> [Clause] -> Dec
FunD Name
adaptorName ([Clause] -> Dec) -> (Clause -> [Clause]) -> Clause -> Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Clause -> [Clause]
forall (f :: * -> *) a. Applicative f => a -> f a
pure) Q Clause
clause
  where fields :: [Name]
fields = ((Name, name) -> Name) -> [(Name, name)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, name) -> Name
forall a b. (a, b) -> a
fst [(Name, name)]
fieldsTys
        -- TODO: vv f should be generated in Q
        fP :: PatQ
fP = Name -> PatQ
varP (String -> Name
mkName String
"f")
        fE :: ExpQ
fE = Name -> ExpQ
varE (String -> Name
mkName String
"f")
        clause :: Q Clause
clause = (Pat -> Exp -> Clause) -> PatQ -> ExpQ -> Q 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) []) PatQ
fP ExpQ
body
        body :: ExpQ
body = case [Name]
fields of
          []             -> String -> ExpQ
forall a. HasCallStack => String -> a
error String
"Can't handle no fields in constructor"
          Name
field1:[Name]
fields' ->
            let first :: ExpQ
first =
                  [| $(varE '(***$)) $(conE conName) $(theLmap field1) |]
                app :: ExpQ -> Name -> ExpQ
app ExpQ
x Name
y =
                  [| $(varE '(****)) $x $(theLmap y) |]
            in (ExpQ -> Name -> ExpQ) -> ExpQ -> [Name] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ExpQ -> Name -> ExpQ
app ExpQ
first [Name]
fields'

        theLmap :: Name -> ExpQ
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 = (String -> Pat) -> [String] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map String -> Pat
varPS (Int -> [String]
allTyVars Int
numTyVars)
        varExps :: [Exp]
varExps = (String -> Exp) -> [String] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map String -> Exp
varS (Int -> [String]
allTyVars Int
numTyVars)

classP :: Name -> [Q Type] -> Q Type
classP :: Name -> [TypeQ] -> TypeQ
classP Name
class_ = (TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
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)
           ([Maybe Exp] -> Exp) -> [Maybe Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (Exp -> Maybe Exp) -> [Exp] -> [Maybe Exp]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Maybe Exp
forall a. a -> Maybe a
Just
#endif
           [Exp]
es

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 -> String -> Int -> Type
pArg' Name
tn String
s = Type -> [Type] -> Type
appTAll (Name -> Type
ConT Name
tn) ([Type] -> Type) -> (Int -> [Type]) -> Int -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Type) -> [String] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Type
varTS (String -> Type) -> (String -> String) -> String -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
forall a. [a] -> [a] -> [a]
++String
s)) ([String] -> [Type]) -> (Int -> [String]) -> Int -> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [String]
allTyVars

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

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

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

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

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

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

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

appTAll :: Type -> [Type] -> Type
appTAll :: Type -> [Type] -> Type
appTAll = (Type -> Type -> Type) -> Type -> [Type] -> Type
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 = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
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 []