{-# LANGUAGE CPP #-}
module Composite.Aeson.Formats.InternalTH
( makeTupleDefaults, makeTupleFormats, makeNamedTupleFormats
) where
import Composite.Aeson.Base (JsonFormat(JsonFormat), JsonProfunctor(JsonProfunctor))
import Control.Monad.Except (throwError)
import qualified Data.Aeson as Aeson
#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.Key as Aeson.Key
import qualified Data.Aeson.KeyMap as Aeson.KeyMap
#else
import qualified Data.HashMap.Lazy as HM
#endif
import qualified Data.Aeson.BetterErrors as ABE
import Data.List (foldl')
import Data.Text (Text)
import qualified Data.Vector as V
import Language.Haskell.TH
( Name, mkName, newName, tupleDataName
, Q
, cxt, clause, normalB
, Dec, funD, instanceD, sigD, valD
, Exp(AppE, ConE, VarE), appE, doE, lamE, listE, varE
, conP, varP, wildP
, bindS, noBindS
, Type(AppT, ArrowT, ConT, ForallT, TupleT, VarT), appT, conT, varT
, TyVarBndr(PlainTV)
#if MIN_VERSION_template_haskell(2,17,0)
, Specificity(SpecifiedSpec)
#endif
)
import Language.Haskell.TH.Syntax (lift)
djfClassName :: Name
djfClassName :: Name
djfClassName = String -> Name
mkName String
"Composite.Aeson.Formats.Default.DefaultJsonFormat"
djfFunName :: Name
djfFunName :: Name
djfFunName = String -> Name
mkName String
"Composite.Aeson.Formats.Default.defaultJsonFormat"
makeTupleDefaults :: Q [Dec]
makeTupleDefaults :: Q [Dec]
makeTupleDefaults = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {m :: * -> *}. Quote m => Int -> m Dec
makeTupleDefault [Int
2..Int
59]
where
makeTupleDefault :: Int -> m Dec
makeTupleDefault Int
arity = do
[Name]
names <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (m :: * -> *). Quote m => String -> m Name
newName forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"a" forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) [Int
1..Int
arity]
let constraints :: [m Type]
constraints = forall a b. (a -> b) -> [a] -> [b]
map (\ Name
n -> forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Name -> m Type
conT Name
djfClassName) (forall (m :: * -> *). Quote m => Name -> m Type
varT Name
n)) [Name]
names
instanceHead :: m Type
instanceHead = forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Name -> m Type
conT Name
djfClassName) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Type -> Type -> Type
AppT (Int -> Type
TupleT Int
arity) (forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT [Name]
names))
implName :: Name
implName = String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
"Composite.Aeson.Formats.Provided.tuple" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
arity forall a. Semigroup a => a -> a -> a
<> String
"JsonFormat"
forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt [m Type]
constraints) m Type
instanceHead
[ forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD (String -> Name
mkName String
"defaultJsonFormat")
[ forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
[]
(forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\ Exp
lhs Int
_ -> Exp -> Exp -> Exp
AppE Exp
lhs (Name -> Exp
VarE Name
djfFunName)) (Name -> Exp
VarE Name
implName) [Int
1..Int
arity]))
[]
]
]
makeTupleFormats :: Q [Dec]
makeTupleFormats :: Q [Dec]
makeTupleFormats = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {m :: * -> *}. Quote m => Int -> m [Dec]
makeTupleFormat [Int
2..Int
59]
where
makeTupleFormat :: Int -> m [Dec]
makeTupleFormat Int
arity = do
[Name]
tyNames <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (m :: * -> *). Quote m => String -> m Name
newName forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"t" forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) [Int
1..Int
arity]
[Name]
oNames <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (m :: * -> *). Quote m => String -> m Name
newName forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"o" forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) [Int
1..Int
arity]
[Name]
iNames <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (m :: * -> *). Quote m => String -> m Name
newName forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"i" forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) [Int
1..Int
arity]
Name
oTupName <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"oTup"
Name
iTupName <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"iTup"
[Name]
valNames <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (m :: * -> *). Quote m => String -> m Name
newName forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"v" forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) [Int
1..Int
arity]
Name
tyErrName <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"e"
let name :: Name
name = String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
"tuple" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
arity forall a. Semigroup a => a -> a -> a
<> String
"JsonFormat"
tupleType :: Type
tupleType = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Type -> Type -> Type
AppT (Int -> Type
TupleT Int
arity) (forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT [Name]
tyNames)
funType :: Type
funType =
[TyVarBndr Specificity] -> Cxt -> Type -> Type
ForallT
#if MIN_VERSION_template_haskell(2,17,0)
(forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
tyErrName Specificity
SpecifiedSpec forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall flag. Name -> flag -> TyVarBndr flag
PlainTV Specificity
SpecifiedSpec) [Name]
tyNames)
#else
(PlainTV tyErrName : map PlainTV tyNames)
#endif
[]
(forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ Type
tyName Type
rest -> Type
ArrowT Type -> Type -> Type
`AppT` (Name -> Type
ConT ''JsonFormat Type -> Type -> Type
`AppT` Name -> Type
VarT Name
tyErrName Type -> Type -> Type
`AppT` Type
tyName) Type -> Type -> Type
`AppT` Type
rest)
(Name -> Type
ConT ''JsonFormat Type -> Type -> Type
`AppT` Name -> Type
VarT Name
tyErrName Type -> Type -> Type
`AppT` Type
tupleType)
(forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT [Name]
tyNames))
oTupImpl :: m Exp
oTupImpl =
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE
[forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (Int -> Name
tupleDataName Int
arity) (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
valNames)]
[| (Aeson.Array . V.fromList) $(listE $ map (\ (varName, oName) -> appE (varE oName) (varE varName)) (zip valNames oNames)) |]
iTupImpl :: m Exp
iTupImpl =
forall (m :: * -> *). Quote m => [m Stmt] -> m Exp
doE
forall a b. (a -> b) -> a -> b
$ [ forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Stmt
bindS forall (m :: * -> *). Quote m => m Pat
wildP [|
ABE.withArray Right >>= \ a ->
if V.length a == $(lift arity)
then pure ()
else throwError $ ABE.InvalidJSON $ $(lift $ "expected an array of exactly " <> show arity <> " elements")
|]
]
forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map ( \ (Int
n, Name
valName, Name
iName) ->
forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Stmt
bindS (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
valName) [| ABE.nth $(lift (n :: Int)) $(varE iName) |] )
(forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Int
0..] [Name]
valNames [Name]
iNames)
forall a. [a] -> [a] -> [a]
++ [ forall (m :: * -> *). Quote m => m Exp -> m Stmt
noBindS (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE 'pure) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Exp -> Exp -> Exp
AppE (Name -> Exp
ConE (Int -> Name
tupleDataName Int
arity)) (forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE [Name]
valNames))) ]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
[ forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
name (forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
funType)
, forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
name
[ forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
(forall a b. (a -> b) -> [a] -> [b]
map (\ (Name
oName, Name
iName) -> forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'JsonFormat [forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'JsonProfunctor [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
oName, forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
iName]]) (forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
oNames [Name]
iNames))
(forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| JsonFormat (JsonProfunctor $(varE oTupName) $(varE iTupName)) |])
[ forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
oTupName) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB m Exp
oTupImpl) []
, forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
iTupName) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB m Exp
iTupImpl) []
]
]
]
makeNamedTupleFormats :: Q [Dec]
makeNamedTupleFormats :: Q [Dec]
makeNamedTupleFormats = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {m :: * -> *}. Quote m => Int -> m [Dec]
makeNamedTupleFormat [Int
2..Int
59]
where
makeNamedTupleFormat :: Int -> m [Dec]
makeNamedTupleFormat Int
arity = do
[Name]
tyNames <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (m :: * -> *). Quote m => String -> m Name
newName forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"t" forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) [Int
1..Int
arity]
[Name]
fNames <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (m :: * -> *). Quote m => String -> m Name
newName forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"f" forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) [Int
1..Int
arity]
[Name]
oNames <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (m :: * -> *). Quote m => String -> m Name
newName forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"o" forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) [Int
1..Int
arity]
[Name]
iNames <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (m :: * -> *). Quote m => String -> m Name
newName forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"i" forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) [Int
1..Int
arity]
Name
oTupName <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"oTup"
Name
iTupName <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"iTup"
[Name]
valNames <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (m :: * -> *). Quote m => String -> m Name
newName forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"v" forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) [Int
1..Int
arity]
Name
tyErrName <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"e"
let name :: Name
name = String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
"namedTuple" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
arity forall a. Semigroup a => a -> a -> a
<> String
"JsonFormat"
tupleType :: Type
tupleType = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Type -> Type -> Type
AppT (Int -> Type
TupleT Int
arity) (forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT [Name]
tyNames)
funType :: Type
funType =
[TyVarBndr Specificity] -> Cxt -> Type -> Type
ForallT
#if MIN_VERSION_template_haskell(2,17,0)
(forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
tyErrName Specificity
SpecifiedSpec forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall flag. Name -> flag -> TyVarBndr flag
PlainTV Specificity
SpecifiedSpec) [Name]
tyNames)
#else
(PlainTV tyErrName : map PlainTV tyNames)
#endif
[]
(forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ Type
tyName Type
rest -> Type
ArrowT Type -> Type -> Type
`AppT` Name -> Type
ConT ''Text Type -> Type -> Type
`AppT` (Type
ArrowT Type -> Type -> Type
`AppT` (Name -> Type
ConT ''JsonFormat Type -> Type -> Type
`AppT` Name -> Type
VarT Name
tyErrName Type -> Type -> Type
`AppT` Type
tyName) Type -> Type -> Type
`AppT` Type
rest))
(Name -> Type
ConT ''JsonFormat Type -> Type -> Type
`AppT` Name -> Type
VarT Name
tyErrName Type -> Type -> Type
`AppT` Type
tupleType)
(forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT [Name]
tyNames))
oTupImpl :: m Exp
oTupImpl =
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE
[forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (Int -> Name
tupleDataName Int
arity) (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
valNames)]
#if MIN_VERSION_aeson(2,0,0)
[| (Aeson.Object . Aeson.KeyMap.fromList)
$(listE $ map (\ (fName, varName, oName) -> [| (Aeson.Key.fromText $(varE fName), $(varE oName) $(varE varName)) |])
#else
[| (Aeson.Object . HM.fromList)
$(listE $ map (\ (fName, varName, oName) -> [| ($(varE fName), $(varE oName) $(varE varName)) |])
#endif
(zip3 fNames valNames oNames)) |]
iTupImpl :: m Exp
iTupImpl =
forall (m :: * -> *). Quote m => [m Stmt] -> m Exp
doE
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ( \ (Name
fName, Name
valName, Name
iName) ->
forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Stmt
bindS (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
valName) [| ABE.key $(varE fName) $(varE iName) |] )
(forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Name]
fNames [Name]
valNames [Name]
iNames)
forall a. [a] -> [a] -> [a]
++ [ forall (m :: * -> *). Quote m => m Exp -> m Stmt
noBindS (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE 'pure) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Exp -> Exp -> Exp
AppE (Name -> Exp
ConE (Int -> Name
tupleDataName Int
arity)) (forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE [Name]
valNames))) ]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
[ forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
name (forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
funType)
, forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
name
[ forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
(forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ (Name
fName, Name
oName, Name
iName) [m Pat]
rest -> forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
fName forall a. a -> [a] -> [a]
: forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'JsonFormat [forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'JsonProfunctor [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
oName, forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
iName]] forall a. a -> [a] -> [a]
: [m Pat]
rest)
[]
(forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Name]
fNames [Name]
oNames [Name]
iNames))
(forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| JsonFormat (JsonProfunctor $(varE oTupName) $(varE iTupName)) |])
[ forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
oTupName) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB m Exp
oTupImpl) []
, forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
iTupName) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB m Exp
iTupImpl) []
]
]
]