freer-simple 1.1.0.0 → 1.2.0.0

raw patch · 7 files changed

+229/−33 lines, 7 filesdep +template-haskelldep ~extensible-effectsPVP ok

version bump matches the API change (PVP)

Dependencies added: template-haskell

Dependency ranges changed: extensible-effects

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• bench/Core.hs +2/−2
• freer-simple.cabal +32/−30
• src/Control/Monad/Freer.hs +5/−1
• src/Control/Monad/Freer/TH.hs +150/−0
• tests/Tests.hs +2/−0
• tests/Tests/TH.hs +34/−0

@@ -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)).

@@ -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 --

@@ -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                 <http://hackage.haskell.org/package/freer-effects freer-effects>), 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

@@ -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

@@ -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]

@@ -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   ]

@@ -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