{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
#if ! MIN_VERSION_template_haskell(2,18,0)
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeFamilies #-}
#endif
module Observe.Event.Render.JSON.DSL.Compile (compile) where
import Data.Aeson
import GHC.Exts
import Language.Haskell.TH
import Observe.Event.DSL
import qualified Observe.Event.DSL.Compile as DSL
import Observe.Event.Render.JSON
#if ! MIN_VERSION_template_haskell(2,18,0)
type Quote m = m ~ Q
#endif
conPCompat :: Name -> [Pat] -> Pat
#if MIN_VERSION_template_haskell(2,18,0)
conPCompat :: Name -> [Pat] -> Pat
conPCompat Name
n [Pat]
ps = Name -> [Type] -> [Pat] -> Pat
ConP Name
n [] [Pat]
ps
#else
conPCompat = ConP
#endif
compile :: (Quote m) => SelectorSpec -> m [Dec]
compile :: forall (m :: * -> *). Quote m => SelectorSpec -> m [Dec]
compile s :: SelectorSpec
s@(SelectorSpec ExplodedName
selectorNameBase [SelectorConstructorSpec]
selectors) = do
[Dec]
baseDecs <- forall (m :: * -> *). Quote m => SelectorSpec -> m [Dec]
DSL.compile SelectorSpec
s
let ([Clause]
renderSelectorClauses, [Dec]
decs) = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr SelectorConstructorSpec -> ([Clause], [Dec]) -> ([Clause], [Dec])
stepSelectors (forall a. Monoid a => a
mempty, [Dec]
baseDecs) [SelectorConstructorSpec]
selectors
selectorInstance :: Dec
selectorInstance =
Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD
forall a. Maybe a
Nothing
[]
(Type -> Type -> Type
AppT (Name -> Type
ConT ''DefaultRenderSelectorJSON) (Name -> Type
ConT Name
selectorName))
[Name -> [Clause] -> Dec
FunD 'defaultRenderSelectorJSON [Clause]
renderSelectorClauses]
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Dec
selectorInstance forall a. a -> [a] -> [a]
: [Dec]
decs
where
selectorName :: Name
selectorName = String -> Name
mkName forall a b. (a -> b) -> a -> b
$ forall a. (IsList a, Item a ~ NonEmptyString) => a -> String
upperCamel ExplodedName
selectorNameBase forall a. Semigroup a => a -> a -> a
<> String
"Selector"
stepSelectors :: SelectorConstructorSpec -> ([Clause], [Dec]) -> ([Clause], [Dec])
stepSelectors (SelectorConstructorSpec ExplodedName
nm SelectorField
NoFields) ([Clause]
renderSelectorClauses, [Dec]
decs) = (Clause
c forall a. a -> [a] -> [a]
: [Clause]
renderSelectorClauses, [Dec]
decs)
where
c :: Clause
c =
[Pat] -> Body -> [Dec] -> Clause
Clause
[Name -> [Pat] -> Pat
conPCompat (String -> Name
mkName forall a b. (a -> b) -> a -> b
$ forall a. (IsList a, Item a ~ NonEmptyString) => a -> String
upperCamel ExplodedName
nm) []]
( Exp -> Body
NormalB
( [Maybe Exp] -> Exp
TupE
[ forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lit -> Exp
LitE forall a b. (a -> b) -> a -> b
$ String -> Lit
StringL (ExplodedName -> String
kebab ExplodedName
nm),
forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'defaultRenderFieldJSON
]
)
)
[]
stepSelectors (SelectorConstructorSpec ExplodedName
nm (Inject Name
_)) ([Clause]
renderSelectorClauses, [Dec]
decs) = (Clause
c forall a. a -> [a] -> [a]
: [Clause]
renderSelectorClauses, [Dec]
decs)
where
keyNm :: Name
keyNm = String -> Name
mkName String
"key"
renderNm :: Name
renderNm = String -> Name
mkName String
"render"
selNm :: Name
selNm = String -> Name
mkName String
"sel"
c :: Clause
c =
[Pat] -> Body -> [Dec] -> Clause
Clause
[Name -> [Pat] -> Pat
conPCompat (String -> Name
mkName forall a b. (a -> b) -> a -> b
$ forall a. (IsList a, Item a ~ NonEmptyString) => a -> String
upperCamel ExplodedName
nm) [Name -> Pat
VarP Name
selNm]]
( Exp -> Body
NormalB
( [Maybe Exp] -> Exp
TupE
[ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lit -> Exp
LitE forall a b. (a -> b) -> a -> b
$ String -> Lit
StringL (ExplodedName -> String
kebab ExplodedName
nm forall a. Semigroup a => a -> a -> a
<> String
":")) (Name -> Exp
VarE '(<>)) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
keyNm),
forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
renderNm
]
)
)
[ Pat -> Body -> [Dec] -> Dec
ValD ([Pat] -> Pat
TupP [Name -> Pat
VarP Name
keyNm, Name -> Pat
VarP Name
renderNm]) (Exp -> Body
NormalB forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'defaultRenderSelectorJSON) (Name -> Exp
VarE Name
selNm)) []
]
stepSelectors (SelectorConstructorSpec ExplodedName
nm (SimpleType AnyType
_)) ([Clause]
renderSelectorClauses, [Dec]
decs) = (Clause
c forall a. a -> [a] -> [a]
: [Clause]
renderSelectorClauses, [Dec]
decs)
where
xNm :: Name
xNm = String -> Name
mkName String
"x"
c :: Clause
c =
[Pat] -> Body -> [Dec] -> Clause
Clause
[Name -> [Pat] -> Pat
conPCompat (String -> Name
mkName forall a b. (a -> b) -> a -> b
$ forall a. (IsList a, Item a ~ NonEmptyString) => a -> String
upperCamel ExplodedName
nm) []]
( Exp -> Body
NormalB
( [Maybe Exp] -> Exp
TupE
[ forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lit -> Exp
LitE forall a b. (a -> b) -> a -> b
$ String -> Lit
StringL (ExplodedName -> String
kebab ExplodedName
nm),
forall a. a -> Maybe a
Just
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pat] -> Exp -> Exp
LamE
[ Name -> Pat
VarP Name
xNm
]
forall a b. (a -> b) -> a -> b
$ [Maybe Exp] -> Exp
TupE
[ forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lit -> Exp
LitE forall a b. (a -> b) -> a -> b
$ String -> Lit
StringL String
"val",
forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'toJSON) (Name -> Exp
VarE Name
xNm)
]
]
)
)
[]
stepSelectors (SelectorConstructorSpec ExplodedName
nm (Specified FieldSpec
fieldSpec)) ([Clause]
renderSelectorClauses, [Dec]
decs) = (Clause
c forall a. a -> [a] -> [a]
: [Clause]
renderSelectorClauses, Dec
fieldDec forall a. a -> [a] -> [a]
: [Dec]
decs)
where
c :: Clause
c =
[Pat] -> Body -> [Dec] -> Clause
Clause
[Name -> [Pat] -> Pat
conPCompat (String -> Name
mkName forall a b. (a -> b) -> a -> b
$ forall a. (IsList a, Item a ~ NonEmptyString) => a -> String
upperCamel ExplodedName
nm) []]
( Exp -> Body
NormalB
( [Maybe Exp] -> Exp
TupE
[ forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lit -> Exp
LitE forall a b. (a -> b) -> a -> b
$ String -> Lit
StringL (ExplodedName -> String
kebab ExplodedName
nm),
forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'defaultRenderFieldJSON
]
)
)
[]
fieldDec :: Dec
fieldDec = FieldSpec -> Dec
compileFieldSpec FieldSpec
fieldSpec
compileFieldSpec :: FieldSpec -> Dec
compileFieldSpec :: FieldSpec -> Dec
compileFieldSpec (FieldSpec ExplodedName
fieldNameBase [FieldConstructorSpec]
fields) =
Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD
forall a. Maybe a
Nothing
[]
(Type -> Type -> Type
AppT (Name -> Type
ConT ''DefaultRenderFieldJSON) (Name -> Type
ConT Name
fieldName))
[Name -> [Clause] -> Dec
FunD 'defaultRenderFieldJSON (FieldConstructorSpec -> Clause
renderFieldClause forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FieldConstructorSpec]
fields)]
where
fieldName :: Name
fieldName = String -> Name
mkName forall a b. (a -> b) -> a -> b
$ forall a. (IsList a, Item a ~ NonEmptyString) => a -> String
upperCamel ExplodedName
fieldNameBase forall a. Semigroup a => a -> a -> a
<> String
"Field"
renderFieldClause :: FieldConstructorSpec -> Clause
renderFieldClause (FieldConstructorSpec ExplodedName
ctorNm NonEmpty AnyType
ts) =
[Pat] -> Body -> [Dec] -> Clause
Clause
[Name -> [Pat] -> Pat
conPCompat (String -> Name
mkName forall a b. (a -> b) -> a -> b
$ forall a. (IsList a, Item a ~ NonEmptyString) => a -> String
upperCamel ExplodedName
ctorNm) (forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
argNms)]
( Exp -> Body
NormalB
( [Maybe Exp] -> Exp
TupE
[ forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lit -> Exp
LitE forall a b. (a -> b) -> a -> b
$ String -> Lit
StringL (ExplodedName -> String
kebab ExplodedName
ctorNm),
forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Exp
valE
]
)
)
[]
where
len :: Int
len = forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty AnyType
ts
argNms :: [Name]
argNms = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Int
idx -> String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
"x" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
idx) [Int
1 .. Int
len]
valE :: Exp
valE = case [Name]
argNms of
[] -> Name -> Exp
ConE 'Null
[Name
argNm] -> Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'toJSON) (Name -> Exp
VarE Name
argNm)
[Name]
_ ->
Exp -> Exp -> Exp
AppE
(Name -> Exp
ConE 'Object)
( Exp -> Exp -> Exp
AppE
(Name -> Exp
VarE 'fromList)
( [Exp] -> Exp
ListE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
( \Name
argNm ([Exp]
jsonEs, Int
idx) ->
( [Maybe Exp] -> Exp
TupE
[ forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lit -> Exp
LitE forall a b. (a -> b) -> a -> b
$ String -> Lit
StringL (forall a. Show a => a -> String
show Int
idx),
forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'toJSON) (Name -> Exp
VarE Name
argNm)
] forall a. a -> [a] -> [a]
:
[Exp]
jsonEs,
Int
idx forall a. Num a => a -> a -> a
- Int
1
)
)
([], Int
len)
[Name]
argNms
)
)