{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

-- |
-- Description : DSL for generating 'Observe.Event.Event' fields and selectors
-- Copyright   : Copyright 2022 Shea Levy.
-- License     : Apache-2.0
-- Maintainer  : shea@shealevy.com
--
-- DSL for generating 'Observe.Event.Event' fields and selectors.
--
-- Typical entrypoint is 'SelectorSpec'.
--
-- See [Example.hs](https://github.com/shlevy/eventuo11y/tree/v0.5.0.0/Example.hs) for an idiomatic example.
--
-- See "Observe.Event.DSL.Compile" to compile this into the relevant types.
module Observe.Event.DSL
  ( -- * The core AST
    SelectorSpec (..),
    SelectorConstructorSpec (..),
    SelectorField (..),
    FieldSpec (..),
    FieldConstructorSpec (..),

    -- * Syntax
    RecordField (..),

    -- * Miscellaneous helpers

    -- ** Quote polymorphism
    AnyQuote (..),
    AnyType,

    -- ** Names
    ExplodedName,
    upperCamel,
    lowerCamel,
    kebab,
    NonEmptyString ((:|:)),
    nonEmptyToString,
  )
where

import Control.Applicative
import Data.Char
import Data.List
import Data.List.NonEmpty hiding (fromList, toList)
import Data.String
import GHC.Exts
import Language.Haskell.TH
import Language.Haskell.TH.Syntax.Compat as THC
import Observe.Event.Syntax

-- | A specification for an 'Observe.Event.Event' selector type
data SelectorSpec
  = SelectorSpec
      !ExplodedName
      -- ^ The base name of the generated type. @Selector@ will be appended.
      ![SelectorConstructorSpec]
      -- ^ Constructors for the selector type.

-- | A specification for a single constructor for a selector
--
-- End users probably want to use 'RecordField' to create
-- 'SelectorConstructorSpec's.
data SelectorConstructorSpec
  = SelectorConstructorSpec
      !ExplodedName
      -- ^ The name of the constructor
      !SelectorField
      -- ^ The type of fields associated with this selector

-- | Ways to specify the field for a selector.
data SelectorField
  = -- | The field is itself specified with the DSL.
    --
    -- The field type will be generated alongside the selector type.
    --
    -- End users probably want to use the 'RecordField' 'ExplodedName'
    -- 'FieldSpec' 'SelectorConstructorSpec' instance for 'Specified'
    -- 'SelectorField's.
    Specified !FieldSpec
  | -- | The field type is simply a preexisting type, typically not eventuo11y-aware.
    --
    -- End users probably want to use the 'RecordField' 'ExplodedName'
    -- 'Name' 'SelectorConstructorSpec' or 'RecordField' 'ExplodedName'
    -- 'AnyType' 'SelectorConstructorSpec' instances for 'SimpleType'
    -- 'SelectorField's
    SimpleType !AnyType
  | -- | This selector is a natural injection from a different selector type.
    --
    -- This is typically used to call library code with its own selector types.
    Inject !Name
  | -- | Events selected by this selector have no fields.
    --
    -- This may be useful purely to add timing to some event, or
    -- to create an event that is parent and/or proximate to other
    -- events.
    NoFields

-- | A specification for an 'Observe.Event.Event' field type.
data FieldSpec
  = FieldSpec
      !ExplodedName
      -- ^ The base name of the field. @Field@ will be appended.
      ![FieldConstructorSpec]
      -- ^ Constructors of this field type.

-- | A specification for a single constructor for a field
--
-- End users probably want to use 'RecordField' to create
-- 'FieldConstructorSpec's.
data FieldConstructorSpec
  = FieldConstructorSpec
      !ExplodedName
      -- ^ The name of the constructor
      !(NonEmpty AnyType)
      -- ^ The types of the arguments to the constructor.

-- | e.g. @"foo" ≔ NoFields@
instance (a ~ ExplodedName) => RecordField a SelectorField SelectorConstructorSpec where
  ≔ :: a -> SelectorField -> SelectorConstructorSpec
(≔) = ExplodedName -> SelectorField -> SelectorConstructorSpec
SelectorConstructorSpec

-- | e.g. @"foo" ≔ FieldSpec ...@
instance (a ~ ExplodedName) => RecordField a FieldSpec SelectorConstructorSpec where
  a
k ≔ :: a -> FieldSpec -> SelectorConstructorSpec
≔ FieldSpec
v = a
k forall k v a. RecordField k v a => k -> v -> a
≔ FieldSpec -> SelectorField
Specified FieldSpec
v

-- | e.g. @"foo" ≔ [t|Maybe Int|]@
instance (a ~ ExplodedName, m ~ AnyQuote) => RecordField a (m Type) SelectorConstructorSpec where
  a
k ≔ :: a -> m Type -> SelectorConstructorSpec
≔ m Type
v = a
k forall k v a. RecordField k v a => k -> v -> a
≔ AnyType -> SelectorField
SimpleType m Type
v

-- | e.g. @"foo" ≔ ''Int@
instance (a ~ ExplodedName) => RecordField a Name SelectorConstructorSpec where
  a
k ≔ :: a -> Name -> SelectorConstructorSpec
≔ Name
v = a
k forall k v a. RecordField k v a => k -> v -> a
≔ (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT Name
v)

-- | e.g. @"foo" ≔ [t|Int] :| [ [t|Bool], [t|Char] ]@
instance (a ~ ExplodedName, m ~ AnyQuote) => RecordField a (NonEmpty (m Type)) FieldConstructorSpec where
  ≔ :: a -> NonEmpty (m Type) -> FieldConstructorSpec
(≔) = ExplodedName -> NonEmpty AnyType -> FieldConstructorSpec
FieldConstructorSpec

-- | e.g. @"foo" ≔ [t|Maybe Int]@
instance (a ~ ExplodedName, m ~ AnyQuote) => RecordField a (m Type) FieldConstructorSpec where
  a
k ≔ :: a -> m Type -> FieldConstructorSpec
≔ m Type
v = a
k forall k v a. RecordField k v a => k -> v -> a
≔ (m Type
v forall a. a -> [a] -> NonEmpty a
:| [])

-- | e.g. @"foo" ≔ [''Int, ''Char]@
instance (a ~ ExplodedName) => RecordField a [Name] FieldConstructorSpec where
  a
k ≔ :: a -> [Name] -> FieldConstructorSpec
≔ [Name]
v = a
k forall k v a. RecordField k v a => k -> v -> a
≔ (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Type
ConT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall l. IsList l => [Item l] -> l
fromList @(NonEmpty _) [Name]
v)

-- | e.g. @"foo" ≔ ''Int@
instance (a ~ ExplodedName) => RecordField a Name FieldConstructorSpec where
  a
k ≔ :: a -> Name -> FieldConstructorSpec
≔ Name
v = a
k forall k v a. RecordField k v a => k -> v -> a
≔ ((forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT Name
v) forall a. a -> [a] -> NonEmpty a
:| [])

-- | A concrete type capturing values that can be instantiated in any
-- 'THC.Quote'.
newtype AnyQuote a = AnyQuote (forall m. THC.Quote m => m a) deriving (forall a b. a -> AnyQuote b -> AnyQuote a
forall a b. (a -> b) -> AnyQuote a -> AnyQuote b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> AnyQuote b -> AnyQuote a
$c<$ :: forall a b. a -> AnyQuote b -> AnyQuote a
fmap :: forall a b. (a -> b) -> AnyQuote a -> AnyQuote b
$cfmap :: forall a b. (a -> b) -> AnyQuote a -> AnyQuote b
Functor)

-- | A 'Type' in any 'THC.Quote'
type AnyType = AnyQuote Type

instance Applicative AnyQuote where
  pure :: forall a. a -> AnyQuote a
pure a
x = forall a. (forall (m :: * -> *). Quote m => m a) -> AnyQuote a
AnyQuote forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
  (AnyQuote forall (m :: * -> *). Quote m => m (a -> b)
f) <*> :: forall a b. AnyQuote (a -> b) -> AnyQuote a -> AnyQuote b
<*> (AnyQuote forall (m :: * -> *). Quote m => m a
x) = forall a. (forall (m :: * -> *). Quote m => m a) -> AnyQuote a
AnyQuote forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => m (a -> b)
f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *). Quote m => m a
x
  liftA2 :: forall a b c.
(a -> b -> c) -> AnyQuote a -> AnyQuote b -> AnyQuote c
liftA2 a -> b -> c
f (AnyQuote forall (m :: * -> *). Quote m => m a
x) (AnyQuote forall (m :: * -> *). Quote m => m b
y) = forall a. (forall (m :: * -> *). Quote m => m a) -> AnyQuote a
AnyQuote forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> b -> c
f forall (m :: * -> *). Quote m => m a
x forall (m :: * -> *). Quote m => m b
y
  (AnyQuote forall (m :: * -> *). Quote m => m a
x) *> :: forall a b. AnyQuote a -> AnyQuote b -> AnyQuote b
*> (AnyQuote forall (m :: * -> *). Quote m => m b
y) = forall a. (forall (m :: * -> *). Quote m => m a) -> AnyQuote a
AnyQuote forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => m a
x forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *). Quote m => m b
y
  (AnyQuote forall (m :: * -> *). Quote m => m a
x) <* :: forall a b. AnyQuote a -> AnyQuote b -> AnyQuote a
<* (AnyQuote forall (m :: * -> *). Quote m => m b
y) = forall a. (forall (m :: * -> *). Quote m => m a) -> AnyQuote a
AnyQuote forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => m a
x forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *). Quote m => m b
y

instance Monad AnyQuote where
  (AnyQuote forall (m :: * -> *). Quote m => m a
x) >>= :: forall a b. AnyQuote a -> (a -> AnyQuote b) -> AnyQuote b
>>= a -> AnyQuote b
f = forall a. (forall (m :: * -> *). Quote m => m a) -> AnyQuote a
AnyQuote forall a b. (a -> b) -> a -> b
$ do
    a
x' <- forall (m :: * -> *). Quote m => m a
x
    let AnyQuote forall (m :: * -> *). Quote m => m b
res = a -> AnyQuote b
f a
x'
    forall (m :: * -> *). Quote m => m b
res

instance THC.Quote AnyQuote where
  newName :: String -> AnyQuote Name
newName String
s = forall a. (forall (m :: * -> *). Quote m => m a) -> AnyQuote a
AnyQuote forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => String -> m Name
THC.newName String
s

-- | A name for some element, broken up into words.
--
-- Different elements will use this differently. For example, using
-- @[ "foo", "bar" ]@ in a 'SelectorSpec' would result in a type named
-- @FooBarSelector@, while using it in a 'FieldSpec' might cause a
-- renderer generator to give the field the key @foo-bar@.
newtype ExplodedName = ExplodedName (NonEmpty NonEmptyString)

-- | Must be non-empty.
instance IsList ExplodedName where
  type Item ExplodedName = NonEmptyString
  fromList :: [Item ExplodedName] -> ExplodedName
fromList = coerce :: forall a b. Coercible a b => a -> b
coerce forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. IsList l => [Item l] -> l
fromList @(NonEmpty _)
  toList :: ExplodedName -> [Item ExplodedName]
toList = forall l. IsList l => l -> [Item l]
toList @(NonEmpty _) forall b c a. (b -> c) -> (a -> b) -> a -> c
. coerce :: forall a b. Coercible a b => a -> b
coerce

-- | A singleton 'ExplodedName'.
instance IsString ExplodedName where
  fromString :: String -> ExplodedName
fromString = forall l. IsList l => [Item l] -> l
fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
: []) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString

-- | Convert an 'ExplodedName' to UpperCamelCase.
upperCamel :: (IsList a, Item a ~ NonEmptyString) => a -> String
upperCamel :: forall a. (IsList a, Item a ~ NonEmptyString) => a -> String
upperCamel = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Char
hd :|: String
tl) -> Char -> Char
toUpper Char
hd forall a. a -> [a] -> [a]
: String
tl) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. IsList l => l -> [Item l]
toList

-- | Convert an 'ExplodedName' to lowerCamelCase
lowerCamel :: ExplodedName -> String
lowerCamel :: ExplodedName -> String
lowerCamel (ExplodedName ((Char
hd :|: String
tl) :| [NonEmptyString]
rest)) =
  (Char -> Char
toLower Char
hd forall a. a -> [a] -> [a]
: String
tl)
    forall a. Semigroup a => a -> a -> a
<> forall a. (IsList a, Item a ~ NonEmptyString) => a -> String
upperCamel [NonEmptyString]
rest

-- | Convert an 'ExplodedName' to kebab-case
kebab :: ExplodedName -> String
kebab :: ExplodedName -> String
kebab = forall a. [a] -> [[a]] -> [a]
intercalate String
"-" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Char
hd :|: String
tl) -> Char -> Char
toLower Char
hd forall a. a -> [a] -> [a]
: String
tl) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. IsList l => l -> [Item l]
toList

-- | Self-explanatory
newtype NonEmptyString = NonEmptyString (NonEmpty Char)

-- | Must be non-empty
instance IsList NonEmptyString where
  type Item NonEmptyString = Char
  fromList :: [Item NonEmptyString] -> NonEmptyString
fromList = coerce :: forall a b. Coercible a b => a -> b
coerce forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. IsList l => [Item l] -> l
fromList @(NonEmpty _)
  toList :: NonEmptyString -> [Item NonEmptyString]
toList = forall l. IsList l => l -> [Item l]
toList @(NonEmpty _) forall b c a. (b -> c) -> (a -> b) -> a -> c
. coerce :: forall a b. Coercible a b => a -> b
coerce

{-# COMPLETE (:|:) #-}

pattern (:|:) :: Char -> String -> NonEmptyString
pattern $m:|: :: forall {r}.
NonEmptyString -> (Char -> String -> r) -> ((# #) -> r) -> r
(:|:) hd tl <- NonEmptyString (hd :| tl)

-- | Must be non-empty
instance IsString NonEmptyString where
  fromString :: String -> NonEmptyString
fromString = forall l. IsList l => [Item l] -> l
fromList

-- | Self-explanatory
nonEmptyToString :: NonEmptyString -> String
nonEmptyToString :: NonEmptyString -> String
nonEmptyToString = forall l. IsList l => l -> [Item l]
toList