eventuo11y-dsl (empty) → 0.1.0.0

raw patch · 6 files changed

+379/−0 lines, 6 filesdep +basedep +template-haskelldep +th-compat

Dependencies added: base, template-haskell, th-compat

Files

• CHANGELOG.md +5/−0
• LICENSE +13/−0
• eventuo11y-dsl.cabal +42/−0
• src/Observe/Event/DSL.hs +233/−0
• src/Observe/Event/DSL/Compile.hs +64/−0
• src/Observe/Event/Syntax.hs +22/−0

@@ -0,0 +1,5 @@+# Revision history for eventuo11y-dsl++## 0.1.0.0 -- 2022-10-23++Initial release

@@ -0,0 +1,13 @@+Copyright 2022 Shea Levy.++Licensed under the Apache License, Version 2.0 (the "License");+you may not use this project except in compliance with the License.+You may obtain a copy of the License at++    http://www.apache.org/licenses/LICENSE-2.0++Unless required by applicable law or agreed to in writing, software+distributed under the License is distributed on an "AS IS" BASIS,+WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+See the License for the specific language governing permissions and+limitations under the License.

@@ -0,0 +1,42 @@+cabal-version:      3.0+name:               eventuo11y-dsl+version:            0.1.0.0+synopsis:           DSL for defining eventuo11y fields and selectors+description:+  Exposes a DSL for low-boilerplate definition of [eventuo11y](https://hackage.haskell.org/package/eventuo11y) fields and selectors.++  See "Observe.Event.DSL" for the core DSL.++  See "Observe.Event.DSL.Compile" for the TemplateHaskell code to generate the field and selector types.++  See [Example.hs](https://github.com/shlevy/eventuo11y/tree/v0.5.0.0/Example.hs) for an example.++  Packages providing @EventBackend@s should likely also provide extensions to the DSL and generate default renderers.++bug-reports:        https://github.com/shlevy/eventuo11y/issues+license:            Apache-2.0+license-file:       LICENSE+author:             Shea Levy+maintainer:         shea@shealevy.com+copyright:          Copyright 2022 Shea Levy.+category:           Observability+extra-source-files: CHANGELOG.md+tested-with:        GHC == { 8.10.7, 9.2.4 }++source-repository head+  type:     git+  location: https://github.com/shlevy/eventuo11y++library+  exposed-modules:+    Observe.Event.DSL+    Observe.Event.DSL.Compile+    Observe.Event.Syntax++  build-depends:+    , base              ^>= { 4.14, 4.16 }+    , template-haskell  ^>= { 2.16, 2.18 }+    , th-compat         ^>= 0.1.4++  hs-source-dirs:   src+  default-language: Haskell2010

@@ -0,0 +1,233 @@+{-# 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+  (≔) = SelectorConstructorSpec++-- | e.g. @"foo" ≔ FieldSpec ...@+instance (a ~ ExplodedName) => RecordField a FieldSpec SelectorConstructorSpec where+  k ≔ v = k ≔ Specified v++-- | e.g. @"foo" ≔ [t|Maybe Int|]@+instance (a ~ ExplodedName, m ~ AnyQuote) => RecordField a (m Type) SelectorConstructorSpec where+  k ≔ v = k ≔ SimpleType v++-- | e.g. @"foo" ≔ ''Int@+instance (a ~ ExplodedName) => RecordField a Name SelectorConstructorSpec where+  k ≔ v = k ≔ (pure $ ConT v)++-- | e.g. @"foo" ≔ [t|Int] :| [ [t|Bool], [t|Char] ]@+instance (a ~ ExplodedName, m ~ AnyQuote) => RecordField a (NonEmpty (m Type)) FieldConstructorSpec where+  (≔) = FieldConstructorSpec++-- | e.g. @"foo" ≔ [t|Maybe Int]@+instance (a ~ ExplodedName, m ~ AnyQuote) => RecordField a (m Type) FieldConstructorSpec where+  k ≔ v = k ≔ (v :| [])++-- | e.g. @"foo" ≔ [''Int, ''Char]@+instance (a ~ ExplodedName) => RecordField a [Name] FieldConstructorSpec where+  k ≔ v = k ≔ (pure . ConT <$> fromList @(NonEmpty _) v)++-- | e.g. @"foo" ≔ ''Int@+instance (a ~ ExplodedName) => RecordField a Name FieldConstructorSpec where+  k ≔ v = k ≔ ((pure $ ConT v) :| [])++-- | 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 (Functor)++-- | A 'Type' in any 'THC.Quote'+type AnyType = AnyQuote Type++instance Applicative AnyQuote where+  pure x = AnyQuote $ pure x+  (AnyQuote f) <*> (AnyQuote x) = AnyQuote $ f <*> x+  liftA2 f (AnyQuote x) (AnyQuote y) = AnyQuote $ liftA2 f x y+  (AnyQuote x) *> (AnyQuote y) = AnyQuote $ x *> y+  (AnyQuote x) <* (AnyQuote y) = AnyQuote $ x <* y++instance Monad AnyQuote where+  (AnyQuote x) >>= f = AnyQuote $ do+    x' <- x+    let AnyQuote res = f x'+    res++instance THC.Quote AnyQuote where+  newName s = AnyQuote $ THC.newName 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 = coerce . fromList @(NonEmpty _)+  toList = toList @(NonEmpty _) . coerce++-- | A singleton 'ExplodedName'.+instance IsString ExplodedName where+  fromString = fromList . (: []) . fromString++-- | Convert an 'ExplodedName' to UpperCamelCase.+upperCamel :: (IsList a, Item a ~ NonEmptyString) => a -> String+upperCamel = concat . fmap (\(hd :|: tl) -> toUpper hd : tl) . toList++-- | Convert an 'ExplodedName' to lowerCamelCase+lowerCamel :: ExplodedName -> String+lowerCamel (ExplodedName ((hd :|: tl) :| rest)) =+  (toLower hd : tl)+    <> upperCamel rest++-- | Convert an 'ExplodedName' to kebab-case+kebab :: ExplodedName -> String+kebab = intercalate "-" . fmap (\(hd :|: tl) -> toLower hd : tl) . toList++-- | Self-explanatory+newtype NonEmptyString = NonEmptyString (NonEmpty Char)++-- | Must be non-empty+instance IsList NonEmptyString where+  type Item NonEmptyString = Char+  fromList = coerce . fromList @(NonEmpty _)+  toList = toList @(NonEmpty _) . coerce++{-# COMPLETE (:|:) #-}++pattern (:|:) :: Char -> String -> NonEmptyString+pattern (:|:) hd tl <- NonEmptyString (hd :| tl)++-- | Must be non-empty+instance IsString NonEmptyString where+  fromString = fromList++-- | Self-explanatory+nonEmptyToString :: NonEmptyString -> String+nonEmptyToString = toList

@@ -0,0 +1,64 @@+{-# LANGUAGE TemplateHaskellQuotes #-}++-- |+-- 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 Language.Haskell.TH.Syntax.Compat as THC+import Observe.Event.DSL++-- | Compile a 'SelectorSpec' into appropriate declarations.+compile :: (THC.Quote m) => SelectorSpec -> m [Dec]+compile (SelectorSpec selectorNameBase selectors) = do+  (selectorCtors, defs) <- foldM stepSelectors mempty selectors+  let selectorDef =+        DataD [] selectorName [(plainTV $ mkName "f")] Nothing selectorCtors []+  pure $ selectorDef : defs+  where+    selectorName = mkName $ upperCamel selectorNameBase <> "Selector"++    stepSelectors (selectorCtors, defs) (SelectorConstructorSpec nm NoFields) = pure (ctor : selectorCtors, defs)+      where+        ctor = GadtC [mkName $ upperCamel nm] [] (AppT (ConT selectorName) (ConT ''Void))+    stepSelectors (selectorCtors, defs) (SelectorConstructorSpec nm (Inject t)) = pure (ctor : selectorCtors, defs)+      where+        varX = mkName "x"+        ctor =+          GadtC+            [mkName $ upperCamel nm]+            [(Bang NoSourceUnpackedness SourceStrict, AppT (ConT t) (VarT varX))]+            (AppT (ConT selectorName) (VarT varX))+    stepSelectors (selectorCtors, defs) (SelectorConstructorSpec nm (SimpleType (AnyQuote mt))) = do+      t <- mt+      let ctor = GadtC [mkName $ upperCamel nm] [] (AppT (ConT selectorName) t)+      pure (ctor : selectorCtors, defs)+    stepSelectors (selectorCtors, defs) (SelectorConstructorSpec nm (Specified fieldSpec)) = do+      (fieldName, fieldDef) <- compileFieldSpec fieldSpec+      let ctor = GadtC [mkName $ upperCamel nm] [] (AppT (ConT selectorName) (ConT fieldName))+      pure (ctor : selectorCtors, fieldDef : defs)++compileFieldSpec :: (THC.Quote m) => FieldSpec -> m (Name, Dec)+compileFieldSpec (FieldSpec fieldNameBase fields) = do+  ctors <- mapM fieldCtor fields+  pure+    ( fieldName,+      DataD [] fieldName [] Nothing ctors []+    )+  where+    makeBangType (AnyQuote mt) = do+      t <- mt+      pure (Bang NoSourceUnpackedness SourceStrict, t)++    fieldCtor (FieldConstructorSpec nm ts) = do+      let AnyQuote margs = toList <$> mapM makeBangType ts+      args <- margs+      pure $ NormalC (mkName $ upperCamel nm) args++    fieldName = mkName $ upperCamel fieldNameBase <> "Field"

@@ -0,0 +1,22 @@+{-# LANGUAGE MultiParamTypeClasses #-}++-- |+-- Description : Syntax helpers for eventuo11y interfaces+-- Copyright   : Copyright 2022 Shea Levy.+-- License     : Apache-2.0+-- Maintainer  : shea@shealevy.com+--+-- Syntax helpers for eventuo11y interfaces.+module Observe.Event.Syntax where++infixr 4 ≔++-- | A type class for common syntax for types that are key-value-like.+--+-- For example, the appropriate 'RecordField' instances allow for+-- @[ "bytes", "asked" ] ≔ ''ByteCount@ and @[ "bytes", "actual" ] ≔ [t|Maybe ByteCount|]@+-- to both construct 'Observe.Event.DSL.FieldConstructorSpec's, the former creating a constructor+-- @BytesAsked@ taking a 'System.Posix.Types.ByteCount' and the latter a constructor+-- @BytesActual@ taking a 'Maybe' 'System.Posix.Types.ByteCount'.+class RecordField k v a where+  (≔) :: k -> v -> a