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

-- |
-- Description : Compile the "Observe.Event.DSL" with TemplateHaskell
-- Copyright   : Copyright 2022 Shea Levy.
-- License     : Apache-2.0
-- Maintainer  : shea@shealevy.com
module Observe.Event.DSL.Compile (compile) where

import Control.Monad
import Data.Void
import GHC.Exts
import Language.Haskell.TH
import Observe.Event.DSL

#if ! MIN_VERSION_template_haskell(2,18,0)
type Quote m = m ~ Q
#endif

-- | Compile a 'SelectorSpec' into appropriate declarations.
compile :: (Quote m) => SelectorSpec -> m [Dec]
compile :: forall (m :: * -> *). Quote m => SelectorSpec -> m [Dec]
compile (SelectorSpec ExplodedName
selectorNameBase [SelectorConstructorSpec]
selectors) = do
  ([Con]
selectorCtors, [Dec]
defs) <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM forall {f :: * -> *}.
Quote f =>
([Con], [Dec]) -> SelectorConstructorSpec -> f ([Con], [Dec])
stepSelectors forall a. Monoid a => a
mempty [SelectorConstructorSpec]
selectors
  let selectorDef :: Dec
selectorDef =
        Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Kind
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
selectorName [(Name -> TyVarBndr ()
plainTV forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"f")] forall a. Maybe a
Nothing [Con]
selectorCtors []
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Dec
selectorDef forall a. a -> [a] -> [a]
: [Dec]
defs
  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 :: ([Con], [Dec]) -> SelectorConstructorSpec -> f ([Con], [Dec])
stepSelectors ([Con]
selectorCtors, [Dec]
defs) (SelectorConstructorSpec ExplodedName
nm SelectorField
NoFields) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Con
ctor forall a. a -> [a] -> [a]
: [Con]
selectorCtors, [Dec]
defs)
      where
        ctor :: Con
ctor = [Name] -> [BangType] -> Kind -> Con
GadtC [String -> Name
mkName forall a b. (a -> b) -> a -> b
$ forall a. (IsList a, Item a ~ NonEmptyString) => a -> String
upperCamel ExplodedName
nm] [] (Kind -> Kind -> Kind
AppT (Name -> Kind
ConT Name
selectorName) (Name -> Kind
ConT ''Void))
    stepSelectors ([Con]
selectorCtors, [Dec]
defs) (SelectorConstructorSpec ExplodedName
nm (Inject Name
t)) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Con
ctor forall a. a -> [a] -> [a]
: [Con]
selectorCtors, [Dec]
defs)
      where
        varX :: Name
varX = String -> Name
mkName String
"x"
        ctor :: Con
ctor =
          [Name] -> [BangType] -> Kind -> Con
GadtC
            [String -> Name
mkName forall a b. (a -> b) -> a -> b
$ forall a. (IsList a, Item a ~ NonEmptyString) => a -> String
upperCamel ExplodedName
nm]
            [(SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
SourceStrict, Kind -> Kind -> Kind
AppT (Name -> Kind
ConT Name
t) (Name -> Kind
VarT Name
varX))]
            (Kind -> Kind -> Kind
AppT (Name -> Kind
ConT Name
selectorName) (Name -> Kind
VarT Name
varX))
    stepSelectors ([Con]
selectorCtors, [Dec]
defs) (SelectorConstructorSpec ExplodedName
nm (SimpleType AnyType
mt)) = do
      Kind
t <- forall a. AnyQuote a -> forall (m :: * -> *). Quote m => m a
toQuote AnyType
mt
      let ctor :: Con
ctor = [Name] -> [BangType] -> Kind -> Con
GadtC [String -> Name
mkName forall a b. (a -> b) -> a -> b
$ forall a. (IsList a, Item a ~ NonEmptyString) => a -> String
upperCamel ExplodedName
nm] [] (Kind -> Kind -> Kind
AppT (Name -> Kind
ConT Name
selectorName) Kind
t)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (Con
ctor forall a. a -> [a] -> [a]
: [Con]
selectorCtors, [Dec]
defs)
    stepSelectors ([Con]
selectorCtors, [Dec]
defs) (SelectorConstructorSpec ExplodedName
nm (Specified FieldSpec
fieldSpec)) = do
      (Name
fieldName, Dec
fieldDef) <- forall (m :: * -> *). Quote m => FieldSpec -> m (Name, Dec)
compileFieldSpec FieldSpec
fieldSpec
      let ctor :: Con
ctor = [Name] -> [BangType] -> Kind -> Con
GadtC [String -> Name
mkName forall a b. (a -> b) -> a -> b
$ forall a. (IsList a, Item a ~ NonEmptyString) => a -> String
upperCamel ExplodedName
nm] [] (Kind -> Kind -> Kind
AppT (Name -> Kind
ConT Name
selectorName) (Name -> Kind
ConT Name
fieldName))
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (Con
ctor forall a. a -> [a] -> [a]
: [Con]
selectorCtors, Dec
fieldDef forall a. a -> [a] -> [a]
: [Dec]
defs)

compileFieldSpec :: (Quote m) => FieldSpec -> m (Name, Dec)
compileFieldSpec :: forall (m :: * -> *). Quote m => FieldSpec -> m (Name, Dec)
compileFieldSpec (FieldSpec ExplodedName
fieldNameBase [FieldConstructorSpec]
fields) = do
  [Con]
ctors <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {m :: * -> *}. Quote m => FieldConstructorSpec -> m Con
fieldCtor [FieldConstructorSpec]
fields
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( Name
fieldName,
      Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Kind
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
fieldName [] forall a. Maybe a
Nothing [Con]
ctors []
    )
  where
    makeBangType :: AnyQuote b -> m (Bang, b)
makeBangType AnyQuote b
mt = do
      b
t <- forall a. AnyQuote a -> forall (m :: * -> *). Quote m => m a
toQuote AnyQuote b
mt
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
SourceStrict, b
t)

    fieldCtor :: FieldConstructorSpec -> m Con
fieldCtor (FieldConstructorSpec ExplodedName
nm NonEmpty AnyType
ts) = do
      let margs :: AnyQuote [BangType]
margs = forall l. IsList l => l -> [Item l]
toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {m :: * -> *} {b}. Quote m => AnyQuote b -> m (Bang, b)
makeBangType NonEmpty AnyType
ts
      [BangType]
args <- forall a. AnyQuote a -> forall (m :: * -> *). Quote m => m a
toQuote AnyQuote [BangType]
margs
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Name -> [BangType] -> Con
NormalC (String -> Name
mkName forall a b. (a -> b) -> a -> b
$ forall a. (IsList a, Item a ~ NonEmptyString) => a -> String
upperCamel ExplodedName
nm) [BangType]
args

    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"