freer 0.2.3.0 → 0.2.4.0

raw patch · 25 files changed

+212/−129 lines, 25 filesdep ~basenew-component:exe:freer-examplesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• LICENSE +2/−2
• README.md +15/−14
• bench/Core.hs +8/−1
• changelog.md +6/−0
• examples/src/Main.hs +8/−4
• examples/src/Teletype.hs +19/−17
• freer.cabal +3/−2
• src/Control/Monad/Freer.hs +16/−2
• src/Control/Monad/Freer/Coroutine.hs +2/−2
• src/Control/Monad/Freer/Cut.hs +2/−2
• src/Control/Monad/Freer/Exception.hs +2/−2
• src/Control/Monad/Freer/Fresh.hs +2/−2
• src/Control/Monad/Freer/Internal.hs +5/−5
• src/Control/Monad/Freer/Reader.hs +2/−2
• src/Control/Monad/Freer/State.hs +2/−2
• src/Control/Monad/Freer/StateRW.hs +2/−2
• src/Control/Monad/Freer/Trace.hs +4/−5
• src/Control/Monad/Freer/Writer.hs +7/−3
• src/Data/FTCQueue.hs +2/−2
• src/Data/Open/Union.hs +7/−57
• src/Data/Open/Union/Internal.hs +77/−0
• tests/Tests.hs +5/−0
• tests/Tests/Coroutine.hs +6/−1
• tests/Tests/Exception.hs +2/−0
• tests/Tests/Reader.hs +6/−0

@@ -1,4 +1,4 @@-Copyright (c) 2015, Alej Cabrera+Copyright (c) 2016, Allele Dev  All rights reserved. @@ -13,7 +13,7 @@       disclaimer in the documentation and/or other materials provided       with the distribution. -    * Neither the name of Alej Cabrera nor the names of other+    * Neither the name of Allele Dev nor the names of other       contributors may be used to endorse or promote products derived       from this software without specific prior written permission. 

@@ -57,25 +57,26 @@ -------------------------------------------------------------------------------- runTeletype :: Eff '[Teletype] w -> IO w runTeletype (Val x) = return x-runTeletype (E u q) = case decomp u of-              Right (PutStrLn msg) -> putStrLn msg  >> runTeletype (qApp q ())-              Right GetLine        -> getLine      >>= \s -> runTeletype (qApp q s)-              Right ExitSuccess    -> exitSuccess-              Left  _              -> error "This cannot happen"+runTeletype (E u q) = case extract u of+              (PutStrLn msg) -> putStrLn msg  >> runTeletype (qApp q ())+              GetLine        -> getLine      >>= \s -> runTeletype (qApp q s)+              ExitSuccess    -> exitSuccess  --------------------------------------------------------------------------------                         -- Pure Interpreter -- -------------------------------------------------------------------------------- runTeletypePure :: [String] -> Eff '[Teletype] w -> [String]-runTeletypePure inputs req = reverse (go inputs req [])-  where go :: [String] -> Eff '[Teletype] w -> [String] -> [String]-        go _      (Val _) acc = acc-        go []     _       acc = acc-        go (x:xs) (E u q) acc = case decomp u of-          Right (PutStrLn msg) -> go (x:xs) (qApp q ()) (msg:acc)-          Right GetLine        -> go xs     (qApp q x) acc-          Right ExitSuccess    -> go xs     (Val ())   acc-          Left _               -> go xs     (Val ())   acc+runTeletypePure inputs req =+  reverse . snd $ run (handleRelayS (inputs, []) (\s _ -> pure s) go req)+  where+    go :: ([String], [String])+       -> Teletype v+       -> (([String], [String]) -> Arr '[] v ([String], [String]))+       -> Eff '[] ([String], [String])+    go (is, os) (PutStrLn msg) q = q (is, msg : os) ()+    go (i:is, os) GetLine q = q (is, os) i+    go ([], _) GetLine _ = error "Not enough lines"+    go (_, os) ExitSuccess _ = pure ([], os) ```  # Contributing

@@ -5,8 +5,16 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE CPP #-} module Main where +#if __GLASGOW_HASKELL__ <= 708+import Control.Applicative+import qualified Control.Monad.Error as MTL+#else+import qualified Control.Monad.Except as MTL+#endif+ import Control.Monad import Control.Monad.Freer import Control.Monad.Freer.Internal@@ -17,7 +25,6 @@ import Criterion import Criterion.Main import qualified Control.Monad.State as MTL-import qualified Control.Monad.Except as MTL import qualified Control.Monad.Free as Free  --------------------------------------------------------------------------------

@@ -1,3 +1,9 @@+# 0.2.4.0 (November 25, 2016)++* Internal reorg+  * In particular, hide implementation details in Union.Internal+  * Rewrite interpreters in terms of `extract` instead of `decomp`+ # 0.2.3.0 (June 25, 2016)  * Add GHC 8 support

@@ -1,18 +1,22 @@ {-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-} module Main where  import Control.Monad.Freer import Teletype -runner :: Eff '[Teletype] ()+runner :: (Member Teletype r) => Eff r () runner = do   x <- getLine'+  _ <- getLine'   putStrLn' x-  y <- getLine'-  putStrLn' y+  z <- getLine'+  putStrLn' z+  putStrLn' x+  putStrLn' x  main :: IO () main = do-  let xs = runTeletypePure ["cat", "fish"] runner+  let xs = runTeletypePure ["cat", "fish", "dog", "bird"] runner   print xs   runTeletype runner

@@ -5,7 +5,6 @@ module Teletype where  import Control.Monad.Freer-import Control.Monad.Freer.Internal import System.Exit hiding (ExitSuccess)  --------------------------------------------------------------------------------@@ -28,24 +27,27 @@ --------------------------------------------------------------------------------                      -- Effectful Interpreter -- ---------------------------------------------------------------------------------runTeletype :: Eff '[Teletype] w -> IO w-runTeletype (Val x) = return x-runTeletype (E u q) = case decomp u of-              Right (PutStrLn msg) -> putStrLn msg  >> runTeletype (qApp q ())-              Right GetLine        -> getLine      >>= \s -> runTeletype (qApp q s)-              Right ExitSuccess    -> exitSuccess-              Left  _              -> error "This cannot happen"+runTeletype :: Eff '[Teletype, IO] w -> IO w+runTeletype req = runM (handleRelay pure go req)+  where+   go :: Teletype v -> Arr '[IO] v w -> Eff '[IO] w+   go (PutStrLn msg) q = send (putStrLn msg) >>= q+   go GetLine q = send getLine >>= q+   go ExitSuccess q = send exitSuccess >>= q  --------------------------------------------------------------------------------                         -- Pure Interpreter -- -------------------------------------------------------------------------------- runTeletypePure :: [String] -> Eff '[Teletype] w -> [String]-runTeletypePure inputs req = reverse (go inputs req [])-  where go :: [String] -> Eff '[Teletype] w -> [String] -> [String]-        go _      (Val _) acc = acc-        go []     _       acc = acc-        go (x:xs) (E u q) acc = case decomp u of-          Right (PutStrLn msg) -> go (x:xs) (qApp q ()) (msg:acc)-          Right GetLine        -> go xs     (qApp q x) acc-          Right ExitSuccess    -> go xs     (Val ())   acc-          Left _               -> go xs     (Val ())   acc+runTeletypePure inputs req =+  reverse . snd $ run (handleRelayS (inputs, []) (\s _ -> pure s) go req)+  where+    go+      :: ([String], [String])+      -> Teletype v+      -> (([String], [String]) -> Arr '[] v ([String], [String]))+      -> Eff '[] ([String], [String])+    go (is, os) (PutStrLn msg) q = q (is, msg : os) ()+    go (i:is, os) GetLine q = q (is, os) i+    go ([], _) GetLine _ = error "Not enough lines"+    go (_, os) ExitSuccess _ = pure ([], os)

@@ -1,5 +1,5 @@ name:                freer-version:             0.2.3.0+version:             0.2.4.0 synopsis:            Implementation of the Freer Monad license:             BSD3 license-file:        LICENSE@@ -48,13 +48,14 @@                      , Control.Monad.Freer.Writer                      , Data.FTCQueue                      , Data.Open.Union+                     , Data.Open.Union.Internal    build-depends:       base >=4.7 && <5   hs-source-dirs:      src   ghc-options:         -Wall   default-language:    Haskell2010 -executable examples+executable freer-examples   main-is:             Main.hs   other-modules:       Common                      , Coroutine

@@ -1,9 +1,12 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE RankNTypes #-} {-| Module      : Control.Monad.Freer Description : Freer - an extensible effects library-Copyright   : Alej Cabrera 2015+Copyright   : Allele Dev 2016 License     : BSD-3-Maintainer  : cpp.cabrera@gmail.com+Maintainer  : allele.dev@gmail.com Stability   : experimental Portability : POSIX @@ -13,7 +16,12 @@   Members,   Eff,   run,+  runM,+  runNat,+  handleRelay,+  handleRelayS,   send,+  Arr,    NonDetEff(..),   makeChoiceA,@@ -21,3 +29,9 @@ ) where  import Control.Monad.Freer.Internal++runNat+  :: forall m r e w.+     (Member m r)+  => (forall a. e a -> m a) -> Eff (e ': r) w -> Eff r w+runNat f = handleRelay pure (\v -> (send (f v) >>=))

@@ -6,9 +6,9 @@ {-| Module      : Control.Monad.Freer.Coroutine Description : Composable coroutine effects layer.-Copyright   : Alej Cabrera 2015+Copyright   : Allele Dev 2016 License     : BSD-3-Maintainer  : cpp.cabrera@gmail.com+Maintainer  : allele.dev@gmail.com Stability   : broken Portability : POSIX 

@@ -5,9 +5,9 @@ {-| Module      : Control.Monad.Freer.Cut Description : An implementation of logical Cut-Copyright   : Alej Cabrera 2015+Copyright   : Allele Dev 2016 License     : BSD-3-Maintainer  : cpp.cabrera@gmail.com+Maintainer  : allele.dev@gmail.com Stability   : broken Portability : POSIX 

@@ -5,9 +5,9 @@ {-| Module      : Control.Monad.Freer.Exception Description : An Exception effect and handler.-Copyright   : Alej Cabrera 2015+Copyright   : Allele Dev 2016 License     : BSD-3-Maintainer  : cpp.cabrera@gmail.com+Maintainer  : allele.dev@gmail.com Stability   : experimental Portability : POSIX 

@@ -6,9 +6,9 @@ {-| Module      : Control.Monad.Freer.Fresh Description : Generation of fresh integers as an effect.-Copyright   : Alej Cabrera 2015+Copyright   : Allele Dev 2016 License     : BSD-3-Maintainer  : cpp.cabrera@gmail.com+Maintainer  : allele.dev@gmail.com Stability   : broken Portability : POSIX 

@@ -14,9 +14,9 @@ {-| Module      : Control.Monad.Freer.Internal Description : Mechanisms to make effects work-Copyright   : Alej Cabrera 2015+Copyright   : Allele Dev 2016 License     : BSD-3-Maintainer  : cpp.cabrera@gmail.com+Maintainer  : allele.dev@gmail.com Stability   : experimental Portability : POSIX @@ -44,6 +44,7 @@    decomp,   tsingleton,+  extract,    qApp,   qComp,@@ -137,9 +138,8 @@ -- This is useful for plugging in traditional transformer stacks. runM :: Monad m => Eff '[m] w -> m w runM (Val x) = return x-runM (E u q) = case decomp u of-  Right mb -> mb >>= runM . qApp q-  Left _   -> error "Internal:runM - This (Left) should never happen"+runM (E u q) = case extract u of+  mb -> mb >>= runM . qApp q  -- the other case is unreachable since Union [] a cannot be -- constructed. Therefore, run is a total function if its argument

@@ -7,9 +7,9 @@ {-| Module      : Control.Monad.Freer.Reader Description : Reader effects, for encapsulating an environment-Copyright   : Alej Cabrera 2015+Copyright   : Allele Dev 2016 License     : BSD-3-Maintainer  : cpp.cabrera@gmail.com+Maintainer  : allele.dev@gmail.com Stability   : experimental Portability : POSIX 

@@ -7,9 +7,9 @@ {-| Module      : Control.Monad.Freer.State Description : State effects, for state-carrying computations.-Copyright   : Alej Cabrera 2015+Copyright   : Allele Dev 2016 License     : BSD-3-Maintainer  : cpp.cabrera@gmail.com+Maintainer  : allele.dev@gmail.com Stability   : experimental Portability : POSIX 

@@ -6,9 +6,9 @@ {-| Module      : Control.Monad.Freer.StateRW Description : State effects in terms of Reader/Writer-Copyright   : Alej Cabrera 2015+Copyright   : Allele Dev 2016 License     : BSD-3-Maintainer  : cpp.cabrera@gmail.com+Maintainer  : allele.dev@gmail.com Stability   : experimental Portability : POSIX 

@@ -6,9 +6,9 @@ {-| Module      : Control.Monad.Freer.Trace Description : Composable Trace effects-Copyright   : Alej Cabrera 2015+Copyright   : Allele Dev 2016 License     : BSD-3-Maintainer  : cpp.cabrera@gmail.com+Maintainer  : allele.dev@gmail.com Stability   : experimental Portability : POSIX @@ -38,6 +38,5 @@ -- | An IO handler for Trace effects runTrace :: Eff '[Trace] w -> IO w runTrace (Val x) = return x-runTrace (E u q) = case decomp u of-     Right (Trace s) -> putStrLn s >> runTrace (qApp q ())-     Left _          -> error "runTrace:Left - This should never happen"+runTrace (E u q) = case extract u of+     Trace s -> putStrLn s >> runTrace (qApp q ())

@@ -2,13 +2,13 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DataKinds #-}-+{-# LANGUAGE CPP #-} {-| Module      : Control.Monad.Freer.Writer Description : Composable Writer effects --Copyright   : Alej Cabrera 2015+Copyright   : Allele Dev 2016 License     : BSD-3-Maintainer  : cpp.cabrera@gmail.com+Maintainer  : allele.dev@gmail.com Stability   : experimental Portability : POSIX @@ -23,6 +23,10 @@   tell,   runWriter ) where++#if __GLASGOW_HASKELL__ <= 708+import Data.Monoid+#endif  import Control.Monad.Freer.Internal 

@@ -3,9 +3,9 @@ {-| Module      : Data.FTCQueue Description : Fast type-aligned queue optimized to effectful functions.-Copyright   : Alej Cabrera 2015+Copyright   : Allele Dev 2016 License     : BSD-3-Maintainer  : cpp.cabrera@gmail.com+Maintainer  : allele.dev@gmail.com Stability   : experimental Portability : POSIX 

@@ -10,9 +10,9 @@ {-| Module      : Data.Open.Union Description : Open unions (type-indexed co-products) for extensible effects.-Copyright   : Alej Cabrera 2015+Copyright   : Allele Dev 2016 License     : BSD-3-Maintainer  : cpp.cabrera@gmail.com+Maintainer  : allele.dev@gmail.com Stability   : experimental Portability : POSIX @@ -31,72 +31,22 @@ -}  module Data.Open.Union (+  module Data.Open.Union,   Union,+  Member(..),   decomp,   weaken,-  Member(..),-  Members+  extract,+  Functor(..) ) where  import GHC.Exts+import Data.Open.Union.Internal  --------------------------------------------------------------------------------                            -- Interface -- ---------------------------------------------------------------------------------data Union (r :: [ * -> * ]) v where-  UNow  :: t v -> Union (t ': r) v-  UNext :: Union r v -> Union (any ': r) v--{-# INLINE decomp #-}-decomp :: Union (t ': r) v -> Either (Union r v) (t v)-decomp (UNow x)  = Right x-decomp (UNext v) = Left v--{-# INLINE weaken #-}-weaken :: Union r w -> Union (any ': r) w-weaken = UNext--class (Member' t r (FindElem t r)) => Member t r where-  inj :: t v -> Union r v-  prj :: Union r v -> Maybe (t v)--instance (Member' t r (FindElem t r)) => Member t r where-  inj = inj' (P :: P (FindElem t r))-  prj = prj' (P :: P (FindElem t r))- type family Members m r :: Constraint where   Members (t ': c) r = (Member t r, Members c r)   Members '[] r = () ----------------------------------------------------------------------------------                         -- Implementation ------------------------------------------------------------------------------------data Nat = S Nat | Z-data P (n :: Nat) = P---- injecting/projecting at a specified position P n-class Member' t r (n :: Nat) where-  inj' :: P n -> t v -> Union r v-  prj' :: P n -> Union r v -> Maybe (t v)--instance (r ~ (t ': r')) => Member' t r 'Z where-  inj' _ = UNow-  prj' _ (UNow x) = Just x-  prj' _ _        = Nothing--instance (r ~ (t' ': r'), Member' t r' n) => Member' t r ('S n) where-  inj' _ = UNext . inj' (P::P n)-  prj' _ (UNow _)  = Nothing-  prj' _ (UNext x) = prj' (P::P n) x---- Find an index of an element in a `list'--- The element must exist--- This closed type family disambiguates otherwise overlapping--- instances-type family FindElem (t :: * -> *) r :: Nat where-  FindElem t (t ': r)    = 'Z-  FindElem t (any ': r)  = 'S (FindElem t r)--type family EQU (a :: k) (b :: k) :: Bool where-  EQU a a = 'True-  EQU a b = 'False

@@ -0,0 +1,77 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds, PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Open.Union.Internal where++data Union (r :: [ * -> * ]) v where+  UNow  :: t v -> Union (t ': r) v+  UNext :: Union (t ': r) v -> Union (any ': t ': r) v++data Nat = S Nat | Z+data P (n :: Nat) = P++-- injecting/projecting at a specified position P n+class Member' t r (n :: Nat) where+  inj' :: P n -> t v -> Union r v+  prj' :: P n -> Union r v -> Maybe (t v)++instance (r ~ (t ': r')) => Member' t r 'Z where+  inj' _ = UNow+  prj' _ (UNow x) = Just x+  prj' _ _        = Nothing++instance (r ~ (t' ': r' : rs'), Member' t (r' : rs') n) => Member' t r ('S n) where+  inj' _ = UNext . inj' (P::P n)+  prj' _ (UNow _)  = Nothing+  prj' _ (UNext x) = prj' (P::P n) x++-- Find an index of an element in a `list'+-- The element must exist+-- This closed type family disambiguates otherwise overlapping+-- instances+type family FindElem (t :: * -> *) r :: Nat where+  FindElem t (t ': r)    = 'Z+  FindElem t (any ': r)  = 'S (FindElem t r)++type family EQU (a :: k) (b :: k) :: Bool where+  EQU a a = 'True+  EQU a b = 'False++--------------------------------------------------------------------------------+                           -- Interface --+--------------------------------------------------------------------------------++{-# INLINE decomp #-}+decomp :: Union (t ': r) v -> Either (Union r v) (t v)+decomp (UNow x)  = Right x+decomp (UNext v) = Left v++{-# INLINE weaken #-}+weaken :: Union (t ': r) w -> Union (any ': t ': r) w+weaken = UNext++{-# INLINE extract #-}+extract :: Union '[t] v -> t v+extract (UNow x)  = x+++class (Member' t r (FindElem t r)) => Member t r where+  inj :: t v -> Union r v+  prj :: Union r v -> Maybe (t v)++instance (Member' t r (FindElem t r)) => Member t r where+  inj = inj' (P :: P (FindElem t r))+  prj = prj' (P :: P (FindElem t r))++instance (Functor f) => Functor (Union '[f]) where+  fmap f = inj . fmap f . extract+instance (Functor f1, Functor (Union (f2 ': fs))) =>+         Functor (Union (f1 ': f2 ': fs)) where+  fmap f = either (weaken . fmap f) (inj . fmap f) . decomp++

@@ -1,4 +1,9 @@+{-# LANGUAGE CPP #-} module Main where++#if __GLASGOW_HASKELL__ <= 708+import Control.Applicative+#endif  import Control.Monad.Freer 

@@ -1,9 +1,14 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DataKinds #-}-+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-} module Tests.Coroutine (   runTestCoroutine ) where++#if __GLASGOW_HASKELL__ <= 708+import Control.Applicative+#endif  import Control.Monad import Control.Monad.Freer

@@ -1,6 +1,8 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+ module Tests.Exception (   TooBig(..), 

@@ -1,9 +1,15 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-} module Tests.Reader (   testReader,   testMultiReader,   testLocal ) where++#if __GLASGOW_HASKELL__ <= 708+import Control.Applicative+#endif  import Control.Monad.Freer import Control.Monad.Freer.Reader