From 52c82783781250d91a0ec22287335d14fed109d0 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Thu, 3 Feb 2022 18:01:29 +0100 Subject: [PATCH 01/11] Added effectful-th package --- cabal.project | 1 + effectful-th/CHANGELOG.md | 2 + effectful-th/LICENSE | 30 ++++++ effectful-th/effectful-th.cabal | 89 +++++++++++++++++ effectful-th/examples/MyReader.hs | 21 ++++ effectful-th/src/Effectful/TH.hs | 157 ++++++++++++++++++++++++++++++ effectful-th/tests/Error.hs | 7 ++ effectful-th/tests/Fail.hs | 7 ++ effectful-th/tests/Main.hs | 4 + effectful-th/tests/Reader.hs | 7 ++ effectful-th/tests/State.hs | 7 ++ effectful-th/tests/Writer.hs | 7 ++ 12 files changed, 339 insertions(+) create mode 100644 effectful-th/CHANGELOG.md create mode 100644 effectful-th/LICENSE create mode 100644 effectful-th/effectful-th.cabal create mode 100644 effectful-th/examples/MyReader.hs create mode 100644 effectful-th/src/Effectful/TH.hs create mode 100644 effectful-th/tests/Error.hs create mode 100644 effectful-th/tests/Fail.hs create mode 100644 effectful-th/tests/Main.hs create mode 100644 effectful-th/tests/Reader.hs create mode 100644 effectful-th/tests/State.hs create mode 100644 effectful-th/tests/Writer.hs diff --git a/cabal.project b/cabal.project index 8d38526c..b8973f82 100644 --- a/cabal.project +++ b/cabal.project @@ -1,3 +1,4 @@ packages: effectful/effectful.cabal effectful-core/effectful-core.cabal + effectful-th/effectful-th.cabal diff --git a/effectful-th/CHANGELOG.md b/effectful-th/CHANGELOG.md new file mode 100644 index 00000000..6c55ef81 --- /dev/null +++ b/effectful-th/CHANGELOG.md @@ -0,0 +1,2 @@ +# effectful-th-0.0.0.0 (2022-02-03) +* Initial alpha release. diff --git a/effectful-th/LICENSE b/effectful-th/LICENSE new file mode 100644 index 00000000..edecc3de --- /dev/null +++ b/effectful-th/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2021-2022, Andrzej Rybczak + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Andrzej Rybczak nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/effectful-th/effectful-th.cabal b/effectful-th/effectful-th.cabal new file mode 100644 index 00000000..cc657cc2 --- /dev/null +++ b/effectful-th/effectful-th.cabal @@ -0,0 +1,89 @@ +cabal-version: 2.4 +build-type: Simple +name: effectful-th +version: 0.1 +license: BSD-3-Clause +license-file: LICENSE +category: Control +maintainer: andrzej@rybczak.net +author: Andrzej Rybczak +synopsis: Template Haskell utilities for the effectful library. + +description: This package provides several Template Haskell helper functions to + aid the development of effects for the + @@ + library. + +extra-source-files: CHANGELOG.md + +tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.1 + +bug-reports: https://github.com/arybczak/effectful/issues +source-repository head + type: git + location: https://github.com/arybczak/effectful.git + +common language + ghc-options: -Wall -Wcompat + + default-language: Haskell2010 + + default-extensions: BangPatterns + ConstraintKinds + DataKinds + DeriveFunctor + DeriveGeneric + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + LambdaCase + MultiParamTypeClasses + NoStarIsType + RankNTypes + RecordWildCards + RoleAnnotations + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeFamilies + TypeOperators + +library + import: language + + ghc-options: -O2 + + build-depends: base >= 4.13 && < 5 + , effectful-core + , syb + , template-haskell + , th-abstraction + + hs-source-dirs: src + + exposed-modules: Effectful.TH + +test-suite effectful-th-test + import: language + + ghc-options: -threaded -rtsopts -with-rtsopts=-N4 + + build-depends: base + , effectful-core + , effectful-th + + hs-source-dirs: tests examples + + type: exitcode-stdio-1.0 + main-is: Main.hs + + other-modules: Error + Fail + Reader + State + Writer + -- These are examples; We do not actually run them but list + -- them here in order to check if they compile. + MyReader diff --git a/effectful-th/examples/MyReader.hs b/effectful-th/examples/MyReader.hs new file mode 100644 index 00000000..3b7610f2 --- /dev/null +++ b/effectful-th/examples/MyReader.hs @@ -0,0 +1,21 @@ +-- These extensions are needed for the definition of the effect. +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +-- These extensions are needed for the generation of the functions. +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +module MyReader where + +import Effectful (Dispatch(Dynamic), DispatchOf) +import Effectful.TH + +data Reader r :: Effect where + Ask :: Reader r m r + Local :: (r -> r) -> m a -> Reader r m a + +type instance DispatchOf (Reader r) = 'Dynamic + +makeSendFunctions ''Reader diff --git a/effectful-th/src/Effectful/TH.hs b/effectful-th/src/Effectful/TH.hs new file mode 100644 index 00000000..c66b0cd6 --- /dev/null +++ b/effectful-th/src/Effectful/TH.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +-- | Template Haskell utilities. +module Effectful.TH + ( -- * Generate functions for dynamic effects + makeSendFunctions + + -- * Re-exports + , Effect + , send + ) where + +import Effectful (Eff, Effect, (:>)) +import Effectful.Dispatch.Dynamic (send) +import Data.Char +import Data.Generics +import qualified Data.List +import Language.Haskell.TH +import Language.Haskell.TH.Datatype +import Language.Haskell.TH.Datatype.TyVarBndr + +-- | Generate functions for sending a dynamic effect to the effect handler. +-- +-- For example, +-- +-- > -- These extensions are needed for the definition of the effect. +-- > {-# LANGUAGE DataKinds #-} +-- > {-# LANGUAGE GADTs #-} +-- > {-# LANGUAGE TypeFamilies #-} +-- > -- These extensions are needed for the generation of the functions. +-- > {-# LANGUAGE FlexibleContexts #-} +-- > {-# LANGUAGE ScopedTypeVariables #-} +-- > {-# LANGUAGE TemplateHaskell #-} +-- > {-# LANGUAGE TypeApplications #-} +-- > module MyReader where +-- > +-- > import Effectful (Dispatch(Dynamic), DispatchOf) +-- > import Effectful.TH +-- > +-- > data Reader r :: Effect where +-- > Ask :: Reader r m r +-- > Local :: (r -> r) -> m a -> Reader r m a +-- > +-- > type instance DispatchOf (Reader r) = 'Dynamic +-- > +-- > makeSendFunctions ''Reader +-- +-- will generate the following functions: +-- +-- > ask :: forall (r :: Type) (es :: [Effect]) (b :: Type). +-- > (Reader r :> es, r ~ b) => Eff es b +-- > ask = send Ask +-- > +-- > local :: forall (r :: Type) (es :: [Effect]) (b :: Type). +-- > Reader r :> es => (r -> r) -> Eff es b -> Eff es b +-- > local arg1 arg2 = send (Local @r @(Eff es) @b arg1 arg2) +makeSendFunctions :: Name -> Q [Dec] +makeSendFunctions tname = do + tinfo <- reifyDatatype tname + fmap mconcat $ mapM (makeSendFunctionFor tinfo) $ datatypeCons tinfo + +-- | Generates the function for a particular data constructor. +makeSendFunctionFor :: DatatypeInfo -> ConstructorInfo -> Q [Dec] +makeSendFunctionFor tinfo cinfo = do + let fname = toFunctionName $ constructorName cinfo + + let (effectVarBndrs, mBndr, rBndr) = effVars $ datatypeVars tinfo + effectVars = map tvName effectVarBndrs + m = tvName mBndr + r = tvName rBndr + + es <- newName "es" + esBndr <- kindedTV es <$> [t| [Effect] |] + effMonad <- [t| Eff $(varT es) |] + let replaceEff = map (pure . replaceTV m effMonad) + + -- Create the function's type signature. + let bndrs = effectVarBndrs <> constructorVars cinfo <> [esBndr, rBndr] + + let effect = appsT $ conT (datatypeName tinfo) : map varT effectVars + effectConstraint = [t| $(effect) :> $(varT es) |] + constructorConstraints = replaceEff $ constructorContext cinfo + ctx = sequence $ effectConstraint : constructorConstraints + + let args = replaceEff $ constructorFields cinfo + eff = [t| Eff $(varT es) $(varT r) |] + funSig = arrowsT args eff + + sig <- sigD fname $ forallT bndrs ctx funSig + + -- Create the function's definition. + ns <- let + fieldsN = length $ constructorFields cinfo + in mapM (\i -> newName ("arg" <> show i)) [1 .. fieldsN] + + let pats = map varP ns + con = conE $ constructorName cinfo + tyApps = replaceEff $ listTyVars $ constructorFields cinfo + fields = map varE ns + body = normalB $ [|send|] `appE` appsE (appTypesE con tyApps : fields) + + defn <- funD fname [clause pats body []] + +#if MIN_VERSION_template_haskell(2,18,0) + let doc :: String + doc = "-- | Send the '" + <> show (constructorName cinfo) + <> "' effect to the effect handler." + pure [withDecDoc doc sig, defn] +#else + pure [sig, defn] +#endif + +toFunctionName :: Name -> Name +toFunctionName cname = let + x : xs = nameBase cname + in mkName $ toLower x : xs + +effVars :: [TyVarBndrUnit] -> ([TyVarBndr], TyVarBndr, TyVarBndr) +effVars = go mempty + where + go _ [] = error "Type is no Effect !" + go _ [_] = error "Type is no Effect !" + go acc [m, r] = (reverse acc, m, r) + go acc (tv : tvs) = go (tv : acc) tvs + +listTyVars :: [Type] -> [Type] +listTyVars = foldl f mempty + where + f memo t = let + tvs = listify isTyVar t + in memo <> (Data.List.nub tvs Data.List.\\ memo) + + isTyVar VarT{} = True + isTyVar _ = False + +replaceTV :: Name -> Type -> Type -> Type +replaceTV n r = everywhere (mkT f) + where + f :: Type -> Type + f (VarT tv) | tv == n = r + f t = t + +---------------------------------------- +-- Helper functions +---------------------------------------- + +appsT :: [Q Type] -> Q Type +appsT [] = error "appsT []" +appsT [x] = x +appsT (x:y:zs) = appsT ( (appT x y) : zs ) + +appTypesE :: Q Exp -> [Q Type] -> Q Exp +appTypesE = foldl appTypeE + +arrowsT :: [Q Type] -> Q Type -> Q Type +arrowsT = flip (foldr (\arg -> appT (appT arrowT arg))) diff --git a/effectful-th/tests/Error.hs b/effectful-th/tests/Error.hs new file mode 100644 index 00000000..388dc315 --- /dev/null +++ b/effectful-th/tests/Error.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} +module Error where + +import Effectful.Error.Dynamic (Error) +import Effectful.TH + +makeSendFunctions ''Error diff --git a/effectful-th/tests/Fail.hs b/effectful-th/tests/Fail.hs new file mode 100644 index 00000000..6f0b3151 --- /dev/null +++ b/effectful-th/tests/Fail.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} +module Fail where + +import Effectful.Fail (Fail) +import Effectful.TH + +makeSendFunctions ''Fail diff --git a/effectful-th/tests/Main.hs b/effectful-th/tests/Main.hs new file mode 100644 index 00000000..a31c5a02 --- /dev/null +++ b/effectful-th/tests/Main.hs @@ -0,0 +1,4 @@ +module Main (main) where + +main :: IO () +main = pure () diff --git a/effectful-th/tests/Reader.hs b/effectful-th/tests/Reader.hs new file mode 100644 index 00000000..edda4547 --- /dev/null +++ b/effectful-th/tests/Reader.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} +module Reader where + +import Effectful.Reader.Dynamic (Reader) +import Effectful.TH + +makeSendFunctions ''Reader diff --git a/effectful-th/tests/State.hs b/effectful-th/tests/State.hs new file mode 100644 index 00000000..6c6f5b3b --- /dev/null +++ b/effectful-th/tests/State.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} +module State where + +import Effectful.State.Dynamic (State) +import Effectful.TH + +makeSendFunctions ''State diff --git a/effectful-th/tests/Writer.hs b/effectful-th/tests/Writer.hs new file mode 100644 index 00000000..de2d2fe8 --- /dev/null +++ b/effectful-th/tests/Writer.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} +module Writer where + +import Effectful.Writer.Dynamic (Writer) +import Effectful.TH + +makeSendFunctions ''Writer From 6c3e716ebb1cba9f8d7bcac0a4978660286b4140 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Thu, 3 Feb 2022 20:31:28 +0100 Subject: [PATCH 02/11] Updated CI --- .github/workflows/haskell-ci.yml | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 3a654520..5a039b44 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -171,6 +171,7 @@ jobs: touch cabal.project echo "packages: $GITHUB_WORKSPACE/source/effectful" >> cabal.project echo "packages: $GITHUB_WORKSPACE/source/effectful-core" >> cabal.project + echo "packages: $GITHUB_WORKSPACE/source/effectful-th" >> cabal.project cat cabal.project - name: sdist run: | @@ -186,20 +187,25 @@ jobs: echo "PKGDIR_effectful=${PKGDIR_effectful}" >> "$GITHUB_ENV" PKGDIR_effectful_core="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/effectful-core-[0-9.]*')" echo "PKGDIR_effectful_core=${PKGDIR_effectful_core}" >> "$GITHUB_ENV" + PKGDIR_effectful_th="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/effectful-th-[0-9.]*')" + echo "PKGDIR_effectful_th=${PKGDIR_effectful_th}" >> "$GITHUB_ENV" rm -f cabal.project cabal.project.local touch cabal.project touch cabal.project.local echo "packages: ${PKGDIR_effectful}" >> cabal.project echo "packages: ${PKGDIR_effectful_core}" >> cabal.project + echo "packages: ${PKGDIR_effectful_th}" >> cabal.project echo "package effectful" >> cabal.project echo " ghc-options: -Werror=missing-methods" >> cabal.project echo "package effectful-core" >> cabal.project echo " ghc-options: -Werror=missing-methods" >> cabal.project + echo "package effectful-th" >> cabal.project + echo " ghc-options: -Werror=missing-methods" >> cabal.project cat >> cabal.project <> cabal.project.local + $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: $_ installed\n" unless /^(effectful|effectful-core|effectful-th)$/; }' >> cabal.project.local cat cabal.project cat cabal.project.local - name: dump install plan @@ -239,6 +245,8 @@ jobs: ${CABAL} -vnormal check cd ${PKGDIR_effectful_core} || false ${CABAL} -vnormal check + cd ${PKGDIR_effectful_th} || false + ${CABAL} -vnormal check - name: haddock run: | $CABAL v2-haddock $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all From 79d16be556343b9ce73d1d7e57844078ec6c110e Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Thu, 3 Feb 2022 21:00:39 +0100 Subject: [PATCH 03/11] Fixed: TyVarBndr -> TyVarBndrUnit --- effectful-th/src/Effectful/TH.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/effectful-th/src/Effectful/TH.hs b/effectful-th/src/Effectful/TH.hs index c66b0cd6..31d29452 100644 --- a/effectful-th/src/Effectful/TH.hs +++ b/effectful-th/src/Effectful/TH.hs @@ -116,7 +116,7 @@ toFunctionName cname = let x : xs = nameBase cname in mkName $ toLower x : xs -effVars :: [TyVarBndrUnit] -> ([TyVarBndr], TyVarBndr, TyVarBndr) +effVars :: [TyVarBndrUnit] -> ([TyVarBndrUnit], TyVarBndrUnit, TyVarBndrUnit) effVars = go mempty where go _ [] = error "Type is no Effect !" From 7f16a3fd68a22ff34d938973f4d2bc793490c3d7 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Thu, 3 Feb 2022 22:26:16 +0100 Subject: [PATCH 04/11] Fixed compilation with GHC 9.2 --- effectful-th/src/Effectful/TH.hs | 19 +++++++++++-------- effectful-th/tests/Fail.hs | 2 ++ 2 files changed, 13 insertions(+), 8 deletions(-) diff --git a/effectful-th/src/Effectful/TH.hs b/effectful-th/src/Effectful/TH.hs index 31d29452..a5d97d60 100644 --- a/effectful-th/src/Effectful/TH.hs +++ b/effectful-th/src/Effectful/TH.hs @@ -75,7 +75,8 @@ makeSendFunctionFor tinfo cinfo = do let replaceEff = map (pure . replaceTV m effMonad) -- Create the function's type signature. - let bndrs = effectVarBndrs <> constructorVars cinfo <> [esBndr, rBndr] + let bndrs = map (mapTVFlag (const inferredSpec)) $ + effectVarBndrs <> constructorVars cinfo <> [esBndr, rBndr] let effect = appsT $ conT (datatypeName tinfo) : map varT effectVars effectConstraint = [t| $(effect) :> $(varT es) |] @@ -86,7 +87,7 @@ makeSendFunctionFor tinfo cinfo = do eff = [t| Eff $(varT es) $(varT r) |] funSig = arrowsT args eff - sig <- sigD fname $ forallT bndrs ctx funSig + sig <- withDoc $ sigD fname $ forallT bndrs ctx funSig -- Create the function's definition. ns <- let @@ -101,14 +102,16 @@ makeSendFunctionFor tinfo cinfo = do defn <- funD fname [clause pats body []] + pure [sig, defn] + where + withDoc :: Q Dec -> Q Dec #if MIN_VERSION_template_haskell(2,18,0) - let doc :: String - doc = "-- | Send the '" - <> show (constructorName cinfo) - <> "' effect to the effect handler." - pure [withDecDoc doc sig, defn] + withDoc = withDecDoc + $ "-- | Send the '" + <> show (constructorName cinfo) + <> "' effect to the effect handler." #else - pure [sig, defn] + withDoc = id #endif toFunctionName :: Name -> Name diff --git a/effectful-th/tests/Fail.hs b/effectful-th/tests/Fail.hs index 6f0b3151..e2b6b3a5 100644 --- a/effectful-th/tests/Fail.hs +++ b/effectful-th/tests/Fail.hs @@ -1,6 +1,8 @@ {-# LANGUAGE TemplateHaskell #-} module Fail where +import Prelude hiding (fail) + import Effectful.Fail (Fail) import Effectful.TH From 7f15f5d58e3d8d9c1d0ff2fcb8e17ec8f84c3099 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Fri, 4 Feb 2022 01:29:35 +0100 Subject: [PATCH 05/11] Added Options type to customize function generation --- effectful-th/src/Effectful/TH.hs | 94 ++++++++++++++++++++++++++------ 1 file changed, 77 insertions(+), 17 deletions(-) diff --git a/effectful-th/src/Effectful/TH.hs b/effectful-th/src/Effectful/TH.hs index a5d97d60..0eb7a9d4 100644 --- a/effectful-th/src/Effectful/TH.hs +++ b/effectful-th/src/Effectful/TH.hs @@ -4,21 +4,65 @@ module Effectful.TH ( -- * Generate functions for dynamic effects makeSendFunctions + , makeSendFunctionsWithOptions + , makeSendFunctionFor + , Options + , defaultOptions + , setMakeFunction + , setMakeFunctionFor + , setToFunctionName -- * Re-exports , Effect , send ) where +import Control.Monad (forM) import Effectful (Eff, Effect, (:>)) import Effectful.Dispatch.Dynamic (send) -import Data.Char -import Data.Generics +import Data.Char (toLower) +import Data.Generics (everywhere, listify, mkT) import qualified Data.List import Language.Haskell.TH import Language.Haskell.TH.Datatype import Language.Haskell.TH.Datatype.TyVarBndr +-- | Options for the generation of send functions. +data Options = Options + { optionsMakeFunction :: Name -> Bool + , optionsToFunctionName :: String -> String + } + +-- | Default options used by 'makeSendFunctions'. Those are: +-- +-- * Generate functions for all data constructors of the effect type. +-- * The function's name is the one of the data constructor with the first +-- letter converted to lower case. +defaultOptions :: Options +defaultOptions = Options + { optionsMakeFunction = const True + , optionsToFunctionName = \case + x : xs -> toLower x : xs + _ -> error "Empty constructor name" + } + +-- | Control which data constructor to generate functions for. +-- +-- The function passed as a first argument is a predicate used to decide for +-- each constructor name whether a function is generated or not. +setMakeFunction :: (Name -> Bool) -> Options -> Options +setMakeFunction f options = options { optionsMakeFunction = f } + +-- | A version of 'setMakeFunction' expecting a list of names for which +-- functions are generated. +setMakeFunctionFor :: [Name] -> Options -> Options +setMakeFunctionFor ns = setMakeFunction (`elem` ns) + +-- | Controls how to map constructor names to the names of the functions that +-- are generated. +setToFunctionName :: (String -> String) -> Options -> Options +setToFunctionName f options = options { optionsToFunctionName = f } + -- | Generate functions for sending a dynamic effect to the effect handler. -- -- For example, @@ -55,14 +99,35 @@ import Language.Haskell.TH.Datatype.TyVarBndr -- > Reader r :> es => (r -> r) -> Eff es b -> Eff es b -- > local arg1 arg2 = send (Local @r @(Eff es) @b arg1 arg2) makeSendFunctions :: Name -> Q [Dec] -makeSendFunctions tname = do +makeSendFunctions = makeSendFunctionsWithOptions defaultOptions + +-- | A version of 'makeSendFunctions' that takes 'Options' to customize the +-- generated functions. +makeSendFunctionsWithOptions :: Options -> Name -> Q [Dec] +makeSendFunctionsWithOptions options tname = do tinfo <- reifyDatatype tname - fmap mconcat $ mapM (makeSendFunctionFor tinfo) $ datatypeCons tinfo + fmap mconcat $ forM (datatypeCons tinfo) $ \cinfo -> do + if optionsMakeFunction options $ constructorName cinfo + then makeSendFunctionForInfo options tinfo cinfo + else pure [] -- | Generates the function for a particular data constructor. -makeSendFunctionFor :: DatatypeInfo -> ConstructorInfo -> Q [Dec] -makeSendFunctionFor tinfo cinfo = do - let fname = toFunctionName $ constructorName cinfo +-- +-- > makeSendFunctionFor options tname cname +-- generates a send function for the data constructor @cname@ of the type +-- @tname@. +-- This function ignores the @makeFunction@ selector of the 'Options' passed. +makeSendFunctionFor :: Options -> Name -> Name -> Q [Dec] +makeSendFunctionFor options tname cname = do + tinfo <- reifyDatatype tname + let cinfo = lookupByConstructorName cname tinfo + makeSendFunctionForInfo options tinfo cinfo + +-- | A version of 'makeSendFunctionFor' that takes the already reified +-- 'DatatypeInfo' and 'ConstructorInfo' as arguments. +makeSendFunctionForInfo :: Options -> DatatypeInfo -> ConstructorInfo -> Q [Dec] +makeSendFunctionForInfo options tinfo cinfo = do + let fname = mkName $ optionsToFunctionName options $ nameBase cname let (effectVarBndrs, mBndr, rBndr) = effVars $ datatypeVars tinfo effectVars = map tvName effectVarBndrs @@ -95,7 +160,7 @@ makeSendFunctionFor tinfo cinfo = do in mapM (\i -> newName ("arg" <> show i)) [1 .. fieldsN] let pats = map varP ns - con = conE $ constructorName cinfo + con = conE cname tyApps = replaceEff $ listTyVars $ constructorFields cinfo fields = map varE ns body = normalB $ [|send|] `appE` appsE (appTypesE con tyApps : fields) @@ -104,21 +169,16 @@ makeSendFunctionFor tinfo cinfo = do pure [sig, defn] where + cname = constructorName cinfo + withDoc :: Q Dec -> Q Dec #if MIN_VERSION_template_haskell(2,18,0) - withDoc = withDecDoc - $ "-- | Send the '" - <> show (constructorName cinfo) - <> "' effect to the effect handler." + withDoc = withDecDoc $ + "-- | Send the '" <> show cname <> "' effect to the effect handler." #else withDoc = id #endif -toFunctionName :: Name -> Name -toFunctionName cname = let - x : xs = nameBase cname - in mkName $ toLower x : xs - effVars :: [TyVarBndrUnit] -> ([TyVarBndrUnit], TyVarBndrUnit, TyVarBndrUnit) effVars = go mempty where From 5951a5cfdc82dabe5b4994327485f155d5097d9e Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Fri, 4 Feb 2022 01:49:44 +0100 Subject: [PATCH 06/11] No more SYB --- effectful-th/effectful-th.cabal | 2 +- effectful-th/src/Effectful/TH.hs | 30 ++++++++---------------------- 2 files changed, 9 insertions(+), 23 deletions(-) diff --git a/effectful-th/effectful-th.cabal b/effectful-th/effectful-th.cabal index cc657cc2..afed2280 100644 --- a/effectful-th/effectful-th.cabal +++ b/effectful-th/effectful-th.cabal @@ -56,8 +56,8 @@ library ghc-options: -O2 build-depends: base >= 4.13 && < 5 + , containers , effectful-core - , syb , template-haskell , th-abstraction diff --git a/effectful-th/src/Effectful/TH.hs b/effectful-th/src/Effectful/TH.hs index 0eb7a9d4..b45967aa 100644 --- a/effectful-th/src/Effectful/TH.hs +++ b/effectful-th/src/Effectful/TH.hs @@ -21,8 +21,7 @@ import Control.Monad (forM) import Effectful (Eff, Effect, (:>)) import Effectful.Dispatch.Dynamic (send) import Data.Char (toLower) -import Data.Generics (everywhere, listify, mkT) -import qualified Data.List +import qualified Data.Map as Map import Language.Haskell.TH import Language.Haskell.TH.Datatype import Language.Haskell.TH.Datatype.TyVarBndr @@ -137,7 +136,7 @@ makeSendFunctionForInfo options tinfo cinfo = do es <- newName "es" esBndr <- kindedTV es <$> [t| [Effect] |] effMonad <- [t| Eff $(varT es) |] - let replaceEff = map (pure . replaceTV m effMonad) + let replaceEff = map pure . applySubstitution (Map.singleton m effMonad) -- Create the function's type signature. let bndrs = map (mapTVFlag (const inferredSpec)) $ @@ -149,7 +148,7 @@ makeSendFunctionForInfo options tinfo cinfo = do ctx = sequence $ effectConstraint : constructorConstraints let args = replaceEff $ constructorFields cinfo - eff = [t| Eff $(varT es) $(varT r) |] + eff = [t| $(pure effMonad) $(varT r) |] funSig = arrowsT args eff sig <- withDoc $ sigD fname $ forallT bndrs ctx funSig @@ -161,7 +160,7 @@ makeSendFunctionForInfo options tinfo cinfo = do let pats = map varP ns con = conE cname - tyApps = replaceEff $ listTyVars $ constructorFields cinfo + tyApps = replaceEff $ listTVs $ constructorFields cinfo fields = map varE ns body = normalB $ [|send|] `appE` appsE (appTypesE con tyApps : fields) @@ -184,25 +183,12 @@ effVars = go mempty where go _ [] = error "Type is no Effect !" go _ [_] = error "Type is no Effect !" - go acc [m, r] = (reverse acc, m, r) - go acc (tv : tvs) = go (tv : acc) tvs + go !acc [m, r] = (reverse acc, m, r) + go !acc (tv : tvs) = go (tv : acc) tvs -listTyVars :: [Type] -> [Type] -listTyVars = foldl f mempty - where - f memo t = let - tvs = listify isTyVar t - in memo <> (Data.List.nub tvs Data.List.\\ memo) - - isTyVar VarT{} = True - isTyVar _ = False +listTVs :: [Type] -> [Type] +listTVs = map (VarT . tvName) . freeVariablesWellScoped -replaceTV :: Name -> Type -> Type -> Type -replaceTV n r = everywhere (mkT f) - where - f :: Type -> Type - f (VarT tv) | tv == n = r - f t = t ---------------------------------------- -- Helper functions From de71ea480ce62763785ccd92b39dbae7072cc2e1 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Fri, 4 Feb 2022 02:25:05 +0100 Subject: [PATCH 07/11] Improved documentation --- effectful-th/src/Effectful/TH.hs | 34 +++++++++++++++++++++++++++++++- 1 file changed, 33 insertions(+), 1 deletion(-) diff --git a/effectful-th/src/Effectful/TH.hs b/effectful-th/src/Effectful/TH.hs index b45967aa..daf1464b 100644 --- a/effectful-th/src/Effectful/TH.hs +++ b/effectful-th/src/Effectful/TH.hs @@ -27,6 +27,13 @@ import Language.Haskell.TH.Datatype import Language.Haskell.TH.Datatype.TyVarBndr -- | Options for the generation of send functions. +-- +-- The available options are documented in their respective setters: +-- +-- * 'setMakeFunction': Select for which data constructors functions are +-- generated. +-- * 'setToFunctionName': How data constructor names are mapped to function +-- names. data Options = Options { optionsMakeFunction :: Name -> Bool , optionsToFunctionName :: String -> String @@ -62,7 +69,7 @@ setMakeFunctionFor ns = setMakeFunction (`elem` ns) setToFunctionName :: (String -> String) -> Options -> Options setToFunctionName f options = options { optionsToFunctionName = f } --- | Generate functions for sending a dynamic effect to the effect handler. +-- | Generate functions for sending an effect operation to its handler. -- -- For example, -- @@ -139,31 +146,40 @@ makeSendFunctionForInfo options tinfo cinfo = do let replaceEff = map pure . applySubstitution (Map.singleton m effMonad) -- Create the function's type signature. + + -- The bindings of the type variables in the scope of the signature. let bndrs = map (mapTVFlag (const inferredSpec)) $ effectVarBndrs <> constructorVars cinfo <> [esBndr, rBndr] + -- The signature's context. let effect = appsT $ conT (datatypeName tinfo) : map varT effectVars effectConstraint = [t| $(effect) :> $(varT es) |] constructorConstraints = replaceEff $ constructorContext cinfo ctx = sequence $ effectConstraint : constructorConstraints + -- The type of the function. let args = replaceEff $ constructorFields cinfo eff = [t| $(pure effMonad) $(varT r) |] funSig = arrowsT args eff + -- The whole function signature. sig <- withDoc $ sigD fname $ forallT bndrs ctx funSig -- Create the function's definition. + + -- The names of the patterns / constructor arguments. ns <- let fieldsN = length $ constructorFields cinfo in mapM (\i -> newName ("arg" <> show i)) [1 .. fieldsN] + -- The patterns and the function body. let pats = map varP ns con = conE cname tyApps = replaceEff $ listTVs $ constructorFields cinfo fields = map varE ns body = normalB $ [|send|] `appE` appsE (appTypesE con tyApps : fields) + -- The whole function definition. defn <- funD fname [clause pats body []] pure [sig, defn] @@ -178,6 +194,14 @@ makeSendFunctionForInfo options tinfo cinfo = do withDoc = id #endif +-- | Split the type variables of the effect in +-- +-- * the ones specific to the effect. +-- * the monad of the effect (i.e. the one that will be instantiated with +-- 'Eff es') +-- * the return type of the operation. +-- +-- For example, the effect `Reader r m a` will be split into `([r], m, a)`. effVars :: [TyVarBndrUnit] -> ([TyVarBndrUnit], TyVarBndrUnit, TyVarBndrUnit) effVars = go mempty where @@ -186,6 +210,9 @@ effVars = go mempty go !acc [m, r] = (reverse acc, m, r) go !acc (tv : tvs) = go (tv : acc) tvs +-- | Extract a list of type variables in a well-scoped fashion. +-- +-- See 'freeVariablesWellScoped' for further information. listTVs :: [Type] -> [Type] listTVs = map (VarT . tvName) . freeVariablesWellScoped @@ -194,13 +221,18 @@ listTVs = map (VarT . tvName) . freeVariablesWellScoped -- Helper functions ---------------------------------------- +-- | `appsE` for `Type`. appsT :: [Q Type] -> Q Type appsT [] = error "appsT []" appsT [x] = x appsT (x:y:zs) = appsT ( (appT x y) : zs ) +-- | `appsE` for type applications. appTypesE :: Q Exp -> [Q Type] -> Q Exp appTypesE = foldl appTypeE +-- | `appsE` for arrows. +-- +-- For example, `arrows [a, b] c` will result in `a -> (b -> c)`. arrowsT :: [Q Type] -> Q Type -> Q Type arrowsT = flip (foldr (\arg -> appT (appT arrowT arg))) From 5266304181779e0ccaa3a10ed3b34ad2099760c9 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Mon, 14 Feb 2022 23:14:02 +0100 Subject: [PATCH 08/11] Better naming --- effectful-th/examples/MyReader.hs | 2 +- effectful-th/src/Effectful/TH.hs | 36 +++++++++++++++---------------- effectful-th/tests/Error.hs | 2 +- effectful-th/tests/Fail.hs | 2 +- effectful-th/tests/Reader.hs | 2 +- effectful-th/tests/State.hs | 2 +- effectful-th/tests/Writer.hs | 2 +- 7 files changed, 24 insertions(+), 24 deletions(-) diff --git a/effectful-th/examples/MyReader.hs b/effectful-th/examples/MyReader.hs index 3b7610f2..272b608f 100644 --- a/effectful-th/examples/MyReader.hs +++ b/effectful-th/examples/MyReader.hs @@ -18,4 +18,4 @@ data Reader r :: Effect where type instance DispatchOf (Reader r) = 'Dynamic -makeSendFunctions ''Reader +makeEffect ''Reader diff --git a/effectful-th/src/Effectful/TH.hs b/effectful-th/src/Effectful/TH.hs index daf1464b..710cdc0a 100644 --- a/effectful-th/src/Effectful/TH.hs +++ b/effectful-th/src/Effectful/TH.hs @@ -3,9 +3,9 @@ -- | Template Haskell utilities. module Effectful.TH ( -- * Generate functions for dynamic effects - makeSendFunctions - , makeSendFunctionsWithOptions - , makeSendFunctionFor + makeEffect + , makeEffectWithOptions + , makePartialEffect , Options , defaultOptions , setMakeFunction @@ -39,7 +39,7 @@ data Options = Options , optionsToFunctionName :: String -> String } --- | Default options used by 'makeSendFunctions'. Those are: +-- | Default options used by 'makeEffect'. Those are: -- -- * Generate functions for all data constructors of the effect type. -- * The function's name is the one of the data constructor with the first @@ -93,7 +93,7 @@ setToFunctionName f options = options { optionsToFunctionName = f } -- > -- > type instance DispatchOf (Reader r) = 'Dynamic -- > --- > makeSendFunctions ''Reader +-- > makeEffect ''Reader -- -- will generate the following functions: -- @@ -104,35 +104,35 @@ setToFunctionName f options = options { optionsToFunctionName = f } -- > local :: forall (r :: Type) (es :: [Effect]) (b :: Type). -- > Reader r :> es => (r -> r) -> Eff es b -> Eff es b -- > local arg1 arg2 = send (Local @r @(Eff es) @b arg1 arg2) -makeSendFunctions :: Name -> Q [Dec] -makeSendFunctions = makeSendFunctionsWithOptions defaultOptions +makeEffect :: Name -> Q [Dec] +makeEffect = makeEffectWithOptions defaultOptions --- | A version of 'makeSendFunctions' that takes 'Options' to customize the +-- | A version of 'makeEffect' that takes 'Options' to customize the -- generated functions. -makeSendFunctionsWithOptions :: Options -> Name -> Q [Dec] -makeSendFunctionsWithOptions options tname = do +makeEffectWithOptions :: Options -> Name -> Q [Dec] +makeEffectWithOptions options tname = do tinfo <- reifyDatatype tname fmap mconcat $ forM (datatypeCons tinfo) $ \cinfo -> do if optionsMakeFunction options $ constructorName cinfo - then makeSendFunctionForInfo options tinfo cinfo + then makePartialEffectInfo options tinfo cinfo else pure [] -- | Generates the function for a particular data constructor. -- --- > makeSendFunctionFor options tname cname +-- > makeEffect options tname cname -- generates a send function for the data constructor @cname@ of the type -- @tname@. -- This function ignores the @makeFunction@ selector of the 'Options' passed. -makeSendFunctionFor :: Options -> Name -> Name -> Q [Dec] -makeSendFunctionFor options tname cname = do +makePartialEffect :: Options -> Name -> Name -> Q [Dec] +makePartialEffect options tname cname = do tinfo <- reifyDatatype tname let cinfo = lookupByConstructorName cname tinfo - makeSendFunctionForInfo options tinfo cinfo + makePartialEffectInfo options tinfo cinfo --- | A version of 'makeSendFunctionFor' that takes the already reified +-- | A version of 'makeEffect' that takes the already reified -- 'DatatypeInfo' and 'ConstructorInfo' as arguments. -makeSendFunctionForInfo :: Options -> DatatypeInfo -> ConstructorInfo -> Q [Dec] -makeSendFunctionForInfo options tinfo cinfo = do +makePartialEffectInfo :: Options -> DatatypeInfo -> ConstructorInfo -> Q [Dec] +makePartialEffectInfo options tinfo cinfo = do let fname = mkName $ optionsToFunctionName options $ nameBase cname let (effectVarBndrs, mBndr, rBndr) = effVars $ datatypeVars tinfo diff --git a/effectful-th/tests/Error.hs b/effectful-th/tests/Error.hs index 388dc315..f2f2caa2 100644 --- a/effectful-th/tests/Error.hs +++ b/effectful-th/tests/Error.hs @@ -4,4 +4,4 @@ module Error where import Effectful.Error.Dynamic (Error) import Effectful.TH -makeSendFunctions ''Error +makeEffect ''Error diff --git a/effectful-th/tests/Fail.hs b/effectful-th/tests/Fail.hs index e2b6b3a5..bafd7244 100644 --- a/effectful-th/tests/Fail.hs +++ b/effectful-th/tests/Fail.hs @@ -6,4 +6,4 @@ import Prelude hiding (fail) import Effectful.Fail (Fail) import Effectful.TH -makeSendFunctions ''Fail +makeEffect ''Fail diff --git a/effectful-th/tests/Reader.hs b/effectful-th/tests/Reader.hs index edda4547..c7a61902 100644 --- a/effectful-th/tests/Reader.hs +++ b/effectful-th/tests/Reader.hs @@ -4,4 +4,4 @@ module Reader where import Effectful.Reader.Dynamic (Reader) import Effectful.TH -makeSendFunctions ''Reader +makeEffect ''Reader diff --git a/effectful-th/tests/State.hs b/effectful-th/tests/State.hs index 6c6f5b3b..7c29a90a 100644 --- a/effectful-th/tests/State.hs +++ b/effectful-th/tests/State.hs @@ -4,4 +4,4 @@ module State where import Effectful.State.Dynamic (State) import Effectful.TH -makeSendFunctions ''State +makeEffect ''State diff --git a/effectful-th/tests/Writer.hs b/effectful-th/tests/Writer.hs index de2d2fe8..7b83c19b 100644 --- a/effectful-th/tests/Writer.hs +++ b/effectful-th/tests/Writer.hs @@ -4,4 +4,4 @@ module Writer where import Effectful.Writer.Dynamic (Writer) import Effectful.TH -makeSendFunctions ''Writer +makeEffect ''Writer From 0f300d8b64f70cfa01493dcff46a20ab31071ea2 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Mon, 14 Feb 2022 23:39:34 +0100 Subject: [PATCH 09/11] Applied additional suggestions --- effectful-th/effectful-th.cabal | 4 +--- effectful-th/src/Effectful/TH.hs | 18 +++++++++++++++++- 2 files changed, 18 insertions(+), 4 deletions(-) diff --git a/effectful-th/effectful-th.cabal b/effectful-th/effectful-th.cabal index afed2280..178529c3 100644 --- a/effectful-th/effectful-th.cabal +++ b/effectful-th/effectful-th.cabal @@ -53,12 +53,10 @@ common language library import: language - ghc-options: -O2 - build-depends: base >= 4.13 && < 5 , containers , effectful-core - , template-haskell + , template-haskell >= 2.16 && < 2.19 , th-abstraction hs-source-dirs: src diff --git a/effectful-th/src/Effectful/TH.hs b/effectful-th/src/Effectful/TH.hs index 710cdc0a..2c281388 100644 --- a/effectful-th/src/Effectful/TH.hs +++ b/effectful-th/src/Effectful/TH.hs @@ -17,7 +17,7 @@ module Effectful.TH , send ) where -import Control.Monad (forM) +import Control.Monad (filterM, forM, unless) import Effectful (Eff, Effect, (:>)) import Effectful.Dispatch.Dynamic (send) import Data.Char (toLower) @@ -135,6 +135,13 @@ makePartialEffectInfo :: Options -> DatatypeInfo -> ConstructorInfo -> Q [Dec] makePartialEffectInfo options tinfo cinfo = do let fname = mkName $ optionsToFunctionName options $ nameBase cname + -- Check if required extensions are enabled. + requiredExtensions (nameBase fname) + [ FlexibleContexts + , ScopedTypeVariables + , TypeApplications + ] + let (effectVarBndrs, mBndr, rBndr) = effVars $ datatypeVars tinfo effectVars = map tvName effectVarBndrs m = tvName mBndr @@ -216,6 +223,15 @@ effVars = go mempty listTVs :: [Type] -> [Type] listTVs = map (VarT . tvName) . freeVariablesWellScoped +requiredExtensions :: String -> [Extension] -> Q () +requiredExtensions what exts = do + missing <- filterM (fmap not . isExtEnabled) exts + let ppMissing = map (\ext -> "{-# LANGUAGE " <> show ext <> " #-}") missing + unless (null missing) $ do + fail $ unlines $ + [ "Generating " <> what <> " requires additional language extensions." + , "You can enable them by adding the following pragmas to the beginning of the source file:" + ] <> ppMissing ---------------------------------------- -- Helper functions From 0a5a87ad4225837649228d9d57018f1cd84c5fc8 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Mon, 14 Feb 2022 23:51:58 +0100 Subject: [PATCH 10/11] Added some documentation on known limitations --- effectful-th/src/Effectful/TH.hs | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/effectful-th/src/Effectful/TH.hs b/effectful-th/src/Effectful/TH.hs index 2c281388..b5675c97 100644 --- a/effectful-th/src/Effectful/TH.hs +++ b/effectful-th/src/Effectful/TH.hs @@ -104,11 +104,24 @@ setToFunctionName f options = options { optionsToFunctionName = f } -- > local :: forall (r :: Type) (es :: [Effect]) (b :: Type). -- > Reader r :> es => (r -> r) -> Eff es b -> Eff es b -- > local arg1 arg2 = send (Local @r @(Eff es) @b arg1 arg2) +-- +-- __Known limitations__ +-- +-- This function works for "basic" effect types but may fail more advanced ones. +-- In particular the following does not work: +-- +-- - Constructors that only work with an explicit type application. +-- See for an +-- example. +-- - Explicit foralls in constructor binding type variables in a different +-- order than the one GHC would infer. makeEffect :: Name -> Q [Dec] makeEffect = makeEffectWithOptions defaultOptions -- | A version of 'makeEffect' that takes 'Options' to customize the -- generated functions. +-- +-- See 'makeEffect' for known limitations. makeEffectWithOptions :: Options -> Name -> Q [Dec] makeEffectWithOptions options tname = do tinfo <- reifyDatatype tname @@ -123,6 +136,8 @@ makeEffectWithOptions options tname = do -- generates a send function for the data constructor @cname@ of the type -- @tname@. -- This function ignores the @makeFunction@ selector of the 'Options' passed. +-- +-- See 'makeEffect' for known limitations. makePartialEffect :: Options -> Name -> Name -> Q [Dec] makePartialEffect options tname cname = do tinfo <- reifyDatatype tname @@ -131,6 +146,8 @@ makePartialEffect options tname cname = do -- | A version of 'makeEffect' that takes the already reified -- 'DatatypeInfo' and 'ConstructorInfo' as arguments. +-- +-- See 'makeEffect' for known limitations. makePartialEffectInfo :: Options -> DatatypeInfo -> ConstructorInfo -> Q [Dec] makePartialEffectInfo options tinfo cinfo = do let fname = mkName $ optionsToFunctionName options $ nameBase cname From 90213b739016835bbf5089d8fe197b7789d6d44f Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Mon, 14 Feb 2022 23:53:22 +0100 Subject: [PATCH 11/11] Relaxed lower version bound of template-haskell --- effectful-th/effectful-th.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/effectful-th/effectful-th.cabal b/effectful-th/effectful-th.cabal index 178529c3..43ffce1a 100644 --- a/effectful-th/effectful-th.cabal +++ b/effectful-th/effectful-th.cabal @@ -56,7 +56,7 @@ library build-depends: base >= 4.13 && < 5 , containers , effectful-core - , template-haskell >= 2.16 && < 2.19 + , template-haskell >= 2.15 && < 2.19 , th-abstraction hs-source-dirs: src