{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
#if ! MIN_VERSION_template_haskell(2,18,0)
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeFamilies #-}
#endif

-- |
-- Description : Compile the "Observe.Event.DSL" and generate "Observe.Event.Render.JSON" instances
-- Copyright   : Copyright 2022 Shea Levy.
-- License     : Apache-2.0
-- Maintainer  : shea@shealevy.com
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 a 'SelectorSpec' to type definitions, with a 'DefaultRenderSelectorJSON' instance.
--
-- Assumes leaf types (i.e., those in 'SimpleType' or a 'FieldConstructorSpec') are 'ToJSON', and
-- that 'Inject'ed selectors have a 'DefaultRenderSelectorJSON' instance.
compile :: (Quote m) => SelectorSpec -> m [Dec]
compile :: forall (m :: * -> *). Quote m => SelectorSpec -> m [Dec]
compile s :: SelectorSpec
s@(SelectorSpec ExplodedName
selectorNameBase [SelectorConstructorSpec]
selectors) = do
  -- Walks the selectors twice, will fix when SelectorSpec is extensible (e.g. recursion-schemes)
  [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
    -- Deduplicate this with e11y-dsl when extending language
    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)) []
            ]
    -- TODO handle case where field is not ToJSON
    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", -- Extend SimpleType with field name
                            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
    -- Deduplicate this with e11y-dsl when extending language
    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
                  )
              )