diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +# 1.2.0.0 (October 23rd, 2018) + +- Added `Control.Monad.Freer.TH`, which provides a `makeEffect` function that automatically generates boilerplate operations using `send` for an effect ([#15](https://github.com/lexi-lambda/freer-simple/pull/15)). + # 1.1.0.0 (February 20th, 2018) - Changed the implementation of `LastMember` to avoid an issue similar to the one with `Member` fixed in 1.0.1.1 that could cause the constraint to unnecessarily fail to solve ([#6](https://github.com/lexi-lambda/freer-simple/issues/6)). diff --git a/bench/Core.hs b/bench/Core.hs --- a/bench/Core.hs +++ b/bench/Core.hs @@ -55,8 +55,8 @@ where go = MTL.get >>= (\n -> if n <= (0 :: Int) then MTL.throwError "wat" else MTL.put (n-1) >> go) countDownExcEE :: Int -> Either String (Int,Int) -countDownExcEE start = EE.run $ EE.runExc (EE.runState start go) - where go = EE.get >>= (\n -> if n <= (0 :: Int) then EE.throwExc "wat" else EE.put (n-1) >> go) +countDownExcEE start = EE.run $ EE.runError (EE.runState start go) + where go = EE.get >>= (\n -> if n <= (0 :: Int) then EE.throwError "wat" else EE.put (n-1) >> go) -------------------------------------------------------------------------------- -- Freer: Interpreter -- diff --git a/freer-simple.cabal b/freer-simple.cabal --- a/freer-simple.cabal +++ b/freer-simple.cabal @@ -1,11 +1,11 @@ --- This file has been generated from package.yaml by hpack version 0.20.0. +-- This file has been generated from package.yaml by hpack version 0.28.2. -- -- see: https://github.com/sol/hpack -- --- hash: f02232dd03e2c26a1697a9b46bb32db8b1f332d4d81f5bb5c309a480589ea5d1 +-- hash: 4f06465ab3fa36c72dff4e9197bc984c95dc787f823d64bf28f26b1a73a33a54 name: freer-simple -version: 1.1.0.0 +version: 1.2.0.0 synopsis: Implementation of a friendly effect system for Haskell. description: An implementation of an effect system for Haskell (a fork of ), which is @@ -30,7 +30,6 @@ license-file: LICENSE build-type: Simple cabal-version: >= 1.10 - extra-source-files: CHANGELOG.md README.md @@ -40,14 +39,6 @@ location: https://github.com/lexi-lambda/freer-simple library - hs-source-dirs: - src - default-extensions: ConstraintKinds DataKinds DeriveFunctor FlexibleContexts FlexibleInstances FunctionalDependencies GADTs LambdaCase MultiParamTypeClasses RankNTypes ScopedTypeVariables TypeApplications TypeOperators - ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints - build-depends: - base >=4.9 && <5 - , natural-transformation >=0.2 - , transformers-base exposed-modules: Control.Monad.Freer Control.Monad.Freer.Coroutine @@ -57,6 +48,7 @@ Control.Monad.Freer.NonDet Control.Monad.Freer.Reader Control.Monad.Freer.State + Control.Monad.Freer.TH Control.Monad.Freer.Trace Control.Monad.Freer.Writer Data.FTCQueue @@ -64,17 +56,19 @@ Data.OpenUnion.Internal other-modules: Paths_freer_simple - default-language: Haskell2010 - -executable freer-examples - main-is: Main.hs hs-source-dirs: - examples/src + src default-extensions: ConstraintKinds DataKinds DeriveFunctor FlexibleContexts FlexibleInstances FunctionalDependencies GADTs LambdaCase MultiParamTypeClasses RankNTypes ScopedTypeVariables TypeApplications TypeOperators ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints build-depends: base >=4.9 && <5 - , freer-simple + , natural-transformation >=0.2 + , template-haskell >=2.11 && <2.15 + , transformers-base + default-language: Haskell2010 + +executable freer-examples + main-is: Main.hs other-modules: Capitalize Console @@ -82,11 +76,28 @@ Fresh Trace Paths_freer_simple + hs-source-dirs: + examples/src + default-extensions: ConstraintKinds DataKinds DeriveFunctor FlexibleContexts FlexibleInstances FunctionalDependencies GADTs LambdaCase MultiParamTypeClasses RankNTypes ScopedTypeVariables TypeApplications TypeOperators + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints + build-depends: + base >=4.9 && <5 + , freer-simple default-language: Haskell2010 test-suite unit type: exitcode-stdio-1.0 main-is: Tests.hs + other-modules: + Tests.Coroutine + Tests.Exception + Tests.Fresh + Tests.Loop + Tests.NonDet + Tests.Reader + Tests.State + Tests.TH + Paths_freer_simple hs-source-dirs: tests default-extensions: ConstraintKinds DataKinds DeriveFunctor FlexibleContexts FlexibleInstances FunctionalDependencies GADTs LambdaCase MultiParamTypeClasses RankNTypes ScopedTypeVariables TypeApplications TypeOperators @@ -98,20 +109,13 @@ , tasty , tasty-hunit , tasty-quickcheck - other-modules: - Tests.Coroutine - Tests.Exception - Tests.Fresh - Tests.Loop - Tests.NonDet - Tests.Reader - Tests.State - Paths_freer_simple default-language: Haskell2010 benchmark core type: exitcode-stdio-1.0 main-is: Core.hs + other-modules: + Paths_freer_simple hs-source-dirs: bench default-extensions: ConstraintKinds DataKinds DeriveFunctor FlexibleContexts FlexibleInstances FunctionalDependencies GADTs LambdaCase MultiParamTypeClasses RankNTypes ScopedTypeVariables TypeApplications TypeOperators @@ -119,10 +123,8 @@ build-depends: base >=4.9 && <5 , criterion - , extensible-effects <2 + , extensible-effects , free , freer-simple , mtl - other-modules: - Paths_freer_simple default-language: Haskell2010 diff --git a/src/Control/Monad/Freer.hs b/src/Control/Monad/Freer.hs --- a/src/Control/Monad/Freer.hs +++ b/src/Control/Monad/Freer.hs @@ -91,7 +91,7 @@ 'Just' contents -> 'pure' contents 'Nothing' -> 'error' ("readFile: no such file " ++ path) WriteFile path contents -> 'Control.Monad.Freer.State.modify' $ \\vfs -> - (path, contents) : 'Data.List.delete' (path, contents) vfs + (path, contents) : 'Data.List.deleteBy' (('==') ``Data.Function.on`` 'fst') (path, contents) vfs @ This handler is easy to write, doesn’t require any knowledge of how @@ -161,6 +161,10 @@ …then 'readFile' would /only/ be usable with an 'Eff' computation that /only/ performed @FileSystem@ effects, which isn’t especially useful. + +Since writing these functions is entirely mechanical, they can be generated +automatically using Template Haskell; see "Control.Monad.Freer.TH" for more +details. -} module Control.Monad.Freer ( -- * Effect Monad diff --git a/src/Control/Monad/Freer/TH.hs b/src/Control/Monad/Freer/TH.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Freer/TH.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- Originally ported from code written by Sandy Maguire (@isovector), available +-- at https://github.com/IxpertaSolutions/freer-effects/pull/28. + +{-| +This module provides Template Haskell functions for automatically generating +effect operation functions (that is, functions that use 'send') from a given +effect algebra. For example, using the @FileSystem@ effect from the example in +the module documentation for "Control.Monad.Freer", we can write the following: + +@ +data FileSystem r where + ReadFile :: 'FilePath' -> FileSystem 'String' + WriteFile :: 'FilePath' -> 'String' -> FileSystem () +'makeEffect' ''FileSystem +@ + +This will automatically generate the following functions: + +@ +readFile :: 'Member' FileSystem effs => 'FilePath' -> 'Eff' effs 'String' +readFile a = 'send' (ReadFile a) + +writeFile :: 'Member' FileSystem effs => 'FilePath' -> 'String' -> 'Eff' effs () +writeFile a b = 'send' (WriteFile a b) +@ +-} +module Control.Monad.Freer.TH + ( makeEffect + , makeEffect_ + ) +where + +import Control.Monad (forM, unless) +import Control.Monad.Freer (send, Member, Eff) +import Data.Char (toLower) +import Data.List (nub) +import Data.Maybe (mapMaybe) +import Language.Haskell.TH +import Prelude + + +-- | If @T@ is a GADT representing an effect algebra, as described in the module +-- documentation for "Control.Monad.Freer", @$('makeEffect' ''T)@ automatically +-- generates a function that uses 'send' with each operation. For more +-- information, see the module documentation for "Control.Monad.Freer.TH". +makeEffect :: Name -> Q [Dec] +makeEffect = genFreer True + +-- | Like 'makeEffect', but does not provide type signatures. This can be used +-- to attach Haddock comments to individual arguments for each generated +-- function. +-- +-- @ +-- data Lang x where +-- Output :: String -> Lang () +-- +-- makeEffect_ ''Lang +-- +-- -- | Output a string. +-- output :: Member Lang effs +-- => String -- ^ String to output. +-- -> Eff effs () -- ^ No result. +-- @ +-- +-- Note that 'makeEffect_' must be used /before/ the explicit type signatures. +makeEffect_ :: Name -> Q [Dec] +makeEffect_ = genFreer False + +-- | Generates declarations and possibly signatures for functions to lift GADT +-- constructors into 'Eff' actions. +genFreer :: Bool -> Name -> Q [Dec] +genFreer makeSigs tcName = do + -- The signatures for the generated definitions require FlexibleContexts. + isExtEnabled FlexibleContexts + >>= flip unless (fail "makeEffect requires FlexibleContexts to be enabled") + + reify tcName >>= \case + TyConI (DataD _ _ _ _ cons _) -> do + sigs <- filter (const makeSigs) <$> mapM genSig cons + decs <- mapM genDecl cons + return $ sigs ++ decs + + _ -> fail "makeEffect expects a type constructor" + +-- | Given the name of a GADT constructor, return the name of the corresponding +-- lifted function. +getDeclName :: Name -> Name +getDeclName = mkName . overFirst toLower . nameBase + where + overFirst f (a : as) = f a : as + overFirst _ as = as + +-- | Builds a function definition of the form @x a b c = send $ X a b c@. +genDecl :: Con -> Q Dec +genDecl (ForallC _ _ con) = genDecl con +genDecl (GadtC [cName] tArgs _ ) = do + let fnName = getDeclName cName + let arity = length tArgs - 1 + dTypeVars <- forM [0 .. arity] $ const $ newName "a" + return $ FunD fnName . pure $ Clause + (VarP <$> dTypeVars) + (NormalB . AppE (VarE 'send) $ foldl + (\b -> AppE b . VarE) + (ConE cName) + dTypeVars + ) + [] +genDecl _ = fail "genDecl expects a GADT constructor" + +-- | Generates a type signature of the form +-- @x :: Member (Effect e) effs => a -> b -> c -> Eff effs r@. +genSig :: Con -> Q Dec +genSig (ForallC _ _ con ) = genSig con +genSig (GadtC [cName] tArgs' ctrType@(AppT eff tRet)) = do + effs <- newName "effs" + let + fnName = getDeclName cName + tArgs = fmap snd tArgs' + otherVars = unapply ctrType + quantifiedVars = + fmap PlainTV . nub $ effs : mapMaybe freeVarName (tArgs ++ otherVars) + memberConstraint = ConT ''Member `AppT` eff `AppT` VarT effs + resultType = ConT ''Eff `AppT` VarT effs `AppT` tRet + + return + . SigD fnName + . ForallT quantifiedVars [memberConstraint] + . foldArrows + $ tArgs + ++ [resultType] +-- TODO: Although this should never happen, we obviously need a better error message below. +genSig GadtC{} = fail "genSig can only look at applications (AppT)" +genSig _ = fail "genSig expects a GADT constructor" + +-- | Gets the name of the free variable in the 'Type', if it exists. +freeVarName :: Type -> Maybe Name +freeVarName (VarT n) = Just n +freeVarName _ = Nothing + +-- | Folds a list of 'Type's into a right-associative arrow 'Type'. +foldArrows :: [Type] -> Type +foldArrows = foldr1 (AppT . AppT ArrowT) + +-- | Unfolds a type into any types which were applied together. +unapply :: Type -> [Type] +unapply (AppT a b) = unapply a ++ unapply b +unapply a = [a] diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -12,6 +12,7 @@ import qualified Tests.Reader (tests) import qualified Tests.State (tests) import qualified Tests.Loop (tests) +import qualified Tests.TH (tests) -------------------------------------------------------------------------------- -- Pure Tests -- @@ -38,4 +39,5 @@ , Tests.Reader.tests , Tests.State.tests , Tests.Loop.tests + , Tests.TH.tests ] diff --git a/tests/Tests/TH.hs b/tests/Tests/TH.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/TH.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE TemplateHaskell #-} +module Tests.TH where + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + +import Control.Monad.Freer (Eff, run, interpret, type(~>)) +import Control.Monad.Freer.TH (makeEffect) + +-- Create a test GADT for our effects. +data Prepender next where + PrependSomething :: String -> Prepender String + +-- Make TH generate our effect functions. +makeEffect ''Prepender + +tests :: TestTree +tests = testGroup + "TH tests" + [ testProperty "Prepender uses generated effects" + $ \s -> testGeneratedFunction s == ("prepended: " ++ s) + ] + +-------------------------------------------------------------------------------- + -- Examples -- +-------------------------------------------------------------------------------- +runPrepender :: Eff (Prepender ': effs) ~> Eff effs +runPrepender = interpret + (\case + PrependSomething s -> pure $ "prepended: " ++ s + ) + +testGeneratedFunction :: String -> String +testGeneratedFunction s = run . runPrepender $ prependSomething s