diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for eventuo11y-dsl +## 0.2.0.0 -- 2022-12-23 + +- Alias `AnyQuote` to `Q` in old `template-haskell` for direct `[t|Foo|]` syntax + ## 0.1.0.0 -- 2022-10-23 Initial release diff --git a/eventuo11y-dsl.cabal b/eventuo11y-dsl.cabal --- a/eventuo11y-dsl.cabal +++ b/eventuo11y-dsl.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: eventuo11y-dsl -version: 0.1.0.0 +version: 0.2.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. @@ -9,7 +9,7 @@ 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. + See [Example.hs](https://github.com/shlevy/eventuo11y/tree/v0.6.0.0/Example.hs) for an example. Packages providing @EventBackend@s should likely also provide extensions to the DSL and generate default renderers. @@ -34,9 +34,8 @@ Observe.Event.Syntax build-depends: - , base ^>= { 4.14, 4.16 } - , template-haskell ^>= { 2.16, 2.18 } - , th-compat ^>= 0.1.4 + , base ^>= { 4.14, 4.16, 4.17 } + , template-haskell ^>= { 2.16, 2.18, 2.19 } hs-source-dirs: src default-language: Haskell2010 diff --git a/src/Observe/Event/DSL.hs b/src/Observe/Event/DSL.hs --- a/src/Observe/Event/DSL.hs +++ b/src/Observe/Event/DSL.hs @@ -6,6 +6,9 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +-- Duplication due to compatibility for AnyQuote +{-# OPTIONS_GHC -Wno-duplicate-exports #-} -- | -- Description : DSL for generating 'Observe.Event.Event' fields and selectors @@ -17,7 +20,7 @@ -- -- Typical entrypoint is 'SelectorSpec'. -- --- See [Example.hs](https://github.com/shlevy/eventuo11y/tree/v0.5.0.0/Example.hs) for an idiomatic example. +-- See [Example.hs](https://github.com/shlevy/eventuo11y/tree/v0.6.0.0/Example.hs) for an idiomatic example. -- -- See "Observe.Event.DSL.Compile" to compile this into the relevant types. module Observe.Event.DSL @@ -35,6 +38,7 @@ -- ** Quote polymorphism AnyQuote (..), + toQuote, AnyType, -- ** Names @@ -47,14 +51,15 @@ ) where +#if MIN_VERSION_template_haskell(2,18,0) import Control.Applicative +#endif 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 @@ -155,12 +160,16 @@ 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 +#if MIN_VERSION_template_haskell(2,18,0) +-- | A concrete type for TH quotes that retains full 'Quote' polymorphism +-- +-- Prior to @template-haskell@ @2.18@, this is just an alias for 'Q' +newtype AnyQuote a = AnyQuote + { -- | Extract this value in a particular 'Quote' monad + -- + -- Prior to @template-haskell@ @2.18@, this projects into 'Q'. + toQuote :: forall m. Quote m => m a + } deriving (Functor) instance Applicative AnyQuote where pure x = AnyQuote $ pure x @@ -175,8 +184,19 @@ let AnyQuote res = f x' res -instance THC.Quote AnyQuote where - newName s = AnyQuote $ THC.newName s +instance Quote AnyQuote where + newName s = AnyQuote $ newName s + +#else +-- | A type alias for TH quotes +type AnyQuote = Q + +toQuote :: AnyQuote a -> Q a +toQuote = id +#endif + +-- | A 'Type' in any 'Quote' +type AnyType = AnyQuote Type -- | A name for some element, broken up into words. -- diff --git a/src/Observe/Event/DSL/Compile.hs b/src/Observe/Event/DSL/Compile.hs --- a/src/Observe/Event/DSL/Compile.hs +++ b/src/Observe/Event/DSL/Compile.hs @@ -1,4 +1,9 @@ +{-# 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 @@ -11,11 +16,14 @@ import Data.Void import GHC.Exts import Language.Haskell.TH -import Language.Haskell.TH.Syntax.Compat as THC 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 :: (THC.Quote m) => SelectorSpec -> m [Dec] +compile :: (Quote m) => SelectorSpec -> m [Dec] compile (SelectorSpec selectorNameBase selectors) = do (selectorCtors, defs) <- foldM stepSelectors mempty selectors let selectorDef = @@ -35,8 +43,8 @@ [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 + stepSelectors (selectorCtors, defs) (SelectorConstructorSpec nm (SimpleType mt)) = do + t <- toQuote mt let ctor = GadtC [mkName $ upperCamel nm] [] (AppT (ConT selectorName) t) pure (ctor : selectorCtors, defs) stepSelectors (selectorCtors, defs) (SelectorConstructorSpec nm (Specified fieldSpec)) = do @@ -44,7 +52,7 @@ 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 :: (Quote m) => FieldSpec -> m (Name, Dec) compileFieldSpec (FieldSpec fieldNameBase fields) = do ctors <- mapM fieldCtor fields pure @@ -52,13 +60,13 @@ DataD [] fieldName [] Nothing ctors [] ) where - makeBangType (AnyQuote mt) = do - t <- mt + makeBangType mt = do + t <- toQuote mt pure (Bang NoSourceUnpackedness SourceStrict, t) fieldCtor (FieldConstructorSpec nm ts) = do - let AnyQuote margs = toList <$> mapM makeBangType ts - args <- margs + let margs = toList <$> mapM makeBangType ts + args <- toQuote margs pure $ NormalC (mkName $ upperCamel nm) args fieldName = mkName $ upperCamel fieldNameBase <> "Field"