{-# 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]
| FieldTys [(Name, Type)]
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)
= 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 ]
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
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
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 []