free 4.11 → 5.2
raw patch · 38 files changed
Files
- .ghci +0/−1
- .gitignore +17/−0
- .hlint.yaml +15/−0
- .travis.yml +0/−8
- CHANGELOG.markdown +134/−0
- HLint.hs +0/−15
- README.markdown +1/−1
- doc/proof/Control/Comonad/Trans/Cofree/instance-Applicative-CofreeT.md +2/−2
- doc/proof/Control/Comonad/Trans/Cofree/instance-Monad-CofreeT.md +1/−1
- examples/Cabbage.lhs +16/−17
- examples/LICENSE +30/−0
- examples/MandelbrotIter.lhs +11/−12
- examples/NewtonCoiter.lhs +6/−5
- examples/PerfTH.hs +122/−0
- examples/RetryTH.hs +7/−5
- examples/Teletype.lhs +3/−3
- examples/ValidationForm.hs +5/−4
- examples/free-examples.cabal +109/−0
- free.cabal +50/−21
- src/Control/Alternative/Free.hs +24/−47
- src/Control/Alternative/Free/Final.hs +73/−0
- src/Control/Applicative/Free.hs +235/−26
- src/Control/Applicative/Free/Fast.hs +121/−0
- src/Control/Applicative/Free/Final.hs +85/−0
- src/Control/Applicative/Trans/Free.hs +17/−45
- src/Control/Comonad/Cofree.hs +153/−91
- src/Control/Comonad/Cofree/Class.hs +8/−3
- src/Control/Comonad/Trans/Cofree.hs +69/−78
- src/Control/Comonad/Trans/Coiter.hs +40/−70
- src/Control/Monad/Free.hs +104/−121
- src/Control/Monad/Free/Ap.hs +349/−0
- src/Control/Monad/Free/Church.hs +51/−18
- src/Control/Monad/Free/Class.hs +23/−15
- src/Control/Monad/Free/TH.hs +134/−50
- src/Control/Monad/Trans/Free.hs +105/−138
- src/Control/Monad/Trans/Free/Ap.hs +443/−0
- src/Control/Monad/Trans/Free/Church.hs +68/−46
- src/Control/Monad/Trans/Iter.hs +71/−86
− .ghci
@@ -1,1 +0,0 @@-:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h
.gitignore view
@@ -1,4 +1,5 @@ dist+dist-newstyle docs wiki TAGS@@ -13,3 +14,19 @@ *# .cabal-sandbox/ cabal.sandbox.config+.stack-work/+cabal-dev+*.chi+*.chs.h+*.dyn_o+*.dyn_hi+.hpc+.hsenv+*.prof+*.aux+*.hp+*.eventlog+cabal.project.local+cabal.project.local~+.HTF/+.ghc.environment.*
+ .hlint.yaml view
@@ -0,0 +1,15 @@+- arguments: [--cpp-define=HLINT, --cpp-ansi, --cpp-include=include]++- fixity: "infixr 5 :<"++# This affects performance+- ignore: {name: Redundant lambda}++# This is not valid for improve+- ignore: {name: Eta reduce}++# DeriveDataTypable noise+- ignore: {name: Unused LANGUAGE pragma}++# They are clearer in places+- ignore: {name: Avoid lambda}
− .travis.yml
@@ -1,8 +0,0 @@-language: haskell-notifications:- irc:- channels:- - "irc.freenode.org#haskell-lens"- skip_join: true- template:- - "\x0313free\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}"
CHANGELOG.markdown view
@@ -1,3 +1,137 @@+5.2 [2023.03.12]+----------------+* Drop support for GHC 7.10 and earlier.+* Drop redundant `Monad` constraints on many functions and instances. These+ constraints were only present for compatibility with pre-7.10 versions of+ GHC, which `free` no longer supports.+* Add `Eq`, `Eq1`, `Ord`, `Ord1`, and `Foldable` instances for `Ap` in+ `Control.Applicative.Free`.+* Switch out `bifunctors` dependency for `bifunctor-classes-compat`.++5.1.10 [2022.11.30]+-------------------+* Add a `MonadFail` instance for `FT`.++5.1.9 [2022.06.26]+------------------+* Simplify the `Eq` and `Ord` instances for `FT` to avoid the use of+ overlapping instances.++5.1.8 [2022.05.07]+------------------+* Generalize the `Monad` constraint in the type signatures for+ `hoistFreeT` in `Control.Monad.Trans.Free` and `Control.Monad.Trans.Free.Ap`+ to a `Functor` constraint.+* Allow building with `transformers-0.6.*` and `mtl-2.3.*`.++5.1.7 [2021.04.30]+------------------+* Enable `FlexibleContexts` in `Control.Monad.Trans.Free.Church` to allow+ building with GHC 9.2.++5.1.6 [2020.12.31]+------------------+* Explicitly mark modules as `Safe`.++5.1.5 [2020.12.16]+------------------+* Move `indexed-traversable` (`FunctorWithIndex` etc) instances from `lens`.++5.1.4 [2020.10.01]+------------------+* Allow building with `template-haskell-2.17.0.0` (GHC 9.0).++5.1.3 [2019.11.26]+------------------+* Allow building with `template-haskell-2.16` (GHC 8.10).+* Add `Eq{1,2}`, `Ord{1,2}`, `Read{1,2}`, and `Show{1,2}` instances for+ `CofreeF`.++5.1.2 [2019.08.27]+------------------+* Implement more performant versions of `some` and `many` in the `Alternative`+ instance for the final `Alt` encoding.++5.1.1 [2019.05.02]+------------------+* Allow building with `base-4.13` (GHC 8.8).++5.1 [2018.07.03]+----------------+* Generalize the type of `_Free`.+* Allow building with `containers-0.6`.+* Avoid incurring some dependencies when using recent GHCs.++5.0.2 [2018.04.25]+------------------+* Add `Generic` and `Generic1` instances where possible.++5.0.1 [2018.03.07]+------------------+* Fix the build on old GHCs with `transformers-0.4`.++5 [2018.01.28]+--------------+* Add a `Semigroup` instance for `IterT`.+* Add `MonadFail` instances for `IterT` and `FreeT`.+* Add a `Comonad` instance for the free `Applicative`, `Ap`.+* Add `Control.Monad.Free.Ap` and `Control.Monad.Trans.Free.Ap` modules, based+ on the "Applicative Effects in Free Monads" series of articles by Will+ Fancher.+* Derive `Data` instances for `Free` and `Cofree`.+* `Control.Monad.Free.TH` now properly supports `template-haskell-2.11.0.0`. In+ particular, it now supports `GadtC` and `RecGadtC`, which are new+ `template-haskell` forms for representing GADTs.+* Add `telescoped_`, `shoots`, and `leaves` to `Control.Comonad.Cofree`+* Add the `Control.Applicative.Free.Fast` module, based on Dave Menendez's+ article "Free Applicative Functors in Haskell"+* Add `foldFreeT` to `Control.Monad.Trans.Free`+* Improve the `foldMap` and `cutoff` functions for+ `Control.Monad.Free.Church.F`, and add a `Traversable`+* Add a `MonadBase` instance for `FreeT`+* Add a performance test comparing Free and Church interpreters+* The use of `prelude-extras` has been removed. `free` now uses the+ `Data.Functor.Classes` module to give `free`'s datatypes instances of `Eq1`,+ `Ord1`, `Read1`, and `Show1`. Their `Eq`, `Ord`, `Read`, and `Show` instances+ have also been modified to incorporate these classes. For example, what+ previously existed as:++ ```haskell+ instance (Eq (f (Free f a)), Eq a) => Eq (Free f a) where+ ```++ has now been changed to:++ ```haskell+ instance (Eq1 f, Eq a) => Eq (Free f a) where+ ```+* Remove redundant `Functor` constraints from `Control.Alternative.Free`++4.12.4+------+* Removed a number of spurious class constraints.+* Support GHC 8++4.12.3+------+* Support `comonad` 5++4.12.2+------+* Add instances for `ExceptT`: like `ErrorT`, but without an `Error` constraint.+* Support `containers`+* Support `transformers` 0.5+++4.12.1+------+* Support GHC 7.4++4.12+----+* Add instances of `MonadCatch` and `MonadThrow` from `exceptions` to `FT`, `FreeT` and `IterT`.+* `semigroupoids` 5, `profunctors` 5, and `bifunctors` 5 support.+ 4.11 ----- * Pass Monad[FreeT].fail into underlying monad
− HLint.hs
@@ -1,15 +0,0 @@-import "hint" HLint.HLint--infixr 5 :<---- This affects performance-ignore "Redundant lambda"---- This is not valid for improve-ignore "Eta reduce"---- DeriveDataTypable noise-ignore "Unused LANGUAGE pragma"---- They are clearer in places-ignore "Avoid lambda"
README.markdown view
@@ -1,7 +1,7 @@ free ==== -[](http://travis-ci.org/ekmett/free)+[](https://hackage.haskell.org/package/free) [](https://github.com/ekmett/free/actions?query=workflow%3AHaskell-CI) This package provides a common definitions for working with free monads, free applicatives, and cofree comonads in Haskell.
doc/proof/Control/Comonad/Trans/Cofree/instance-Applicative-CofreeT.md view
@@ -200,7 +200,7 @@ . ≡ (.) ``` -By repeteadly applying the Applicative laws for the underlying functor, we+By repeatedly applying the Applicative laws for the underlying functor, we get: ```haskell@@ -288,7 +288,7 @@ $W ≡ ($ star(C w)) ``` -By repeteadly applying composition law for w, we get:+By repeatedly applying composition law for w, we get: ```haskell
doc/proof/Control/Comonad/Trans/Cofree/instance-Monad-CofreeT.md view
@@ -20,7 +20,7 @@ This definition is equivalent to that of the Cofree module if 'w' is identity. -The tokens `CofreeT` and `runCofreeT` are abreviated as `C` and `unC`, +The tokens `CofreeT` and `runCofreeT` are abbreviated as `C` and `unC`, respectively, for readability. ## Left identity
examples/Cabbage.lhs view
@@ -1,7 +1,6 @@ > {-# LANGUAGE ViewPatterns #-} > module Cabbage where- -> import Control.Applicative+ > import Control.Monad > import Control.Monad.State > import Control.Monad.Trans.Iter@@ -9,23 +8,23 @@ > import Data.Functor.Identity > import Data.Maybe > import Data.Tuple-> import Data.List+> import Data.List (inits, tails) Consider the following problem: -A farmer must cross a river with a wolf, a sheep and a cabbage. -He owns a boat, which can only carry himself and one other item. +A farmer must cross a river with a wolf, a sheep and a cabbage.+He owns a boat, which can only carry himself and one other item. The sheep must not be left alone with the wolf, or with the cabbage:-if that happened, one of them would eat the other. +if that happened, one of them would eat the other. > data Item = Wolf | Sheep | Cabbage | Farmer deriving (Ord, Show, Eq)-> +> > eats :: Item -> Item -> Bool > Sheep `eats` Cabbage = True > Wolf `eats` Sheep = True > _ `eats` _ = False -The problem can be represented as the set of items on each side of the river. +The problem can be represented as the set of items on each side of the river. > type Situation = ([Item],[Item]) @@ -35,7 +34,7 @@ First, some helper functions to extract single elements from lists, leaving the rest intact: -> plusTailOf :: [a] -> [a] -> (Maybe a, [a]) +> plusTailOf :: [a] -> [a] -> (Maybe a, [a]) > a `plusTailOf` b = (listToMaybe b, a ++ drop 1 b) > singleOut1 :: (a -> Bool) -> [a] -> (Maybe a,[a])@@ -43,7 +42,7 @@ @ *Cabbage> singleOut1 (== Sheep) [Wolf, Sheep, Cabbage]-[(Just Wolf,[Sheep,Cabbage]),(Just Sheep,[Wolf,Cabbage]),(Just Cabbage,[Wolf,Sheep]),(Nothing,[Wolf,Sheep,Cabbage])]+(Just Sheep,[Wolf,Cabbage]) @ > singleOutAll :: [a] -> [(Maybe a,[a])]@@ -61,11 +60,11 @@ > move :: Situation -> [Situation] > move = move2-> where +> where > move2 (singleOut1 (== Farmer) -> (Just Farmer,as), bs) = move1 as bs > move2 (bs, singleOut1 (== Farmer) -> (Just Farmer,as)) = map swap $ move1 as bs > move2 _ = []-> +> > move1 as bs = [(as', [Farmer] ++ maybeToList b ++ bs) | > (b, as') <- singleOutAll as, > and [not $ x `eats` y | x <- as', y <- as']]@@ -74,15 +73,15 @@ *Cabbage> move initial [([Wolf,Cabbage],[Farmer,Sheep])] @- + When the starting side becomes empty, the farmer succeeds. > success :: Situation -> Bool > success ([],_) = True > success _ = False -A straightforward implementation to solve the problem could use the -list monad, trying all possible solutions and +A straightforward implementation to solve the problem could use the+list monad, trying all possible solutions and > solution1 :: Situation > solution1 = head $ solutions' initial@@ -96,8 +95,8 @@ To guarantee termination, we can use the 'Iter' monad with its MonadPlus instance. As long as one of the possible execution paths finds a solution, the program-will terminate: the solution is looked for _in breadth_. - +will terminate: the solution is looked for _in breadth_.+ > solution2 :: Iter Situation > solution2 = solution' initial > where
+ examples/LICENSE view
@@ -0,0 +1,30 @@+Copyright 2008-2013 Edward Kmett++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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.
examples/MandelbrotIter.lhs view
@@ -1,18 +1,17 @@-Compiling to an executable file with the @-O2@ optimization level is recomended.+Compiling to an executable file with the @-O2@ optimization level is recommended. For example: @ghc -o 'mandelbrot_iter' -O2 MandelbrotIter.lhs ; ./mandelbrot_iter@ > {-# LANGUAGE PackageImports #-}+> module Main where -> import Control.Arrow+> import Control.Arrow hiding (loop)+> import Control.Monad.IO.Class (MonadIO(..)) > import Control.Monad.Trans.Iter-> import "mtl" Control.Monad.Reader-> import "mtl" Control.Monad.List-> import "mtl" Control.Monad.Identity-> import Control.Monad.IO.Class+> import "mtl" Control.Monad.Reader (ReaderT, runReaderT, asks) > import Data.Complex > import Graphics.HGL (runGraphics, Window, withPen,-> line, RGB (RGB), RedrawMode (Unbuffered, DoubleBuffered), openWindowEx,+> line, RGB (RGB), RedrawMode (DoubleBuffered), openWindowEx, > drawInWindow, mkPen, Style (Solid)) Some fractals can be defined by infinite sequences of complex numbers. For example,@@ -20,11 +19,11 @@ the following sequence is generated for each point @c@ in the complex plane: @-z₀ = c +z₀ = c -z₁ = z₀² + c +z₁ = z₀² + c -z₂ = z₁² + c +z₂ = z₁² + c … @@@ -96,7 +95,7 @@ Drawing a point is equivalent to drawing a line of length one. > drawPoint :: RGB -> (Int,Int) -> FractalM ()-> drawPoint color p@(x,y) = do+> drawPoint color (x,y) = do > w <- asks window > let point = line (x,y) (x+1, y+1) > liftIO $ drawInWindow w $ mkPen Solid 1 color (flip withPen point)@@ -133,6 +132,6 @@ > runGraphics $ do > w <- openWindowEx "Mandelbrot" Nothing (windowWidth, windowHeight) DoubleBuffered (Just 1) > let canvas = Canvas windowWidth windowHeight w-> runFractalM' 100 canvas drawMandelbrot+> _ <- runFractalM' 100 canvas drawMandelbrot > putStrLn $ "Fin"
examples/NewtonCoiter.lhs view
@@ -5,10 +5,10 @@ to find zeroes of a function is one such algorithm. > {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}+> module Main where > import Control.Comonad.Trans.Coiter > import Control.Comonad.Env-> import Control.Applicative > import Data.Foldable (toList, find) > data Function = Function {@@ -62,7 +62,8 @@ > estimateError :: Solution Double -> Result > estimateError s =-> let a:a':_ = toList s in+> let (a, s') = extract $ runCoiterT s in+> let a' = extract s' in > let f = asks function s in > Result { value = a, > xerror = abs $ a - a',@@ -75,9 +76,9 @@ > estimateOutlook :: Int -> Solution Result -> Outlook > estimateOutlook sampleSize solution = > let sample = map ferror $ take sampleSize $ tail $ toList solution in-> let result = extract solution in-> Outlook { result = result,-> progress = ferror result > minimum sample }+> let result' = extract solution in+> Outlook { result = result',+> progress = ferror result' > minimum sample } To compute the square root of @c@, we solve the equation @x*x - c = 0@. We will stop whenever the accuracy of the result doesn't improve in the next 5 steps.
+ examples/PerfTH.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Main where++import System.CPUTime.Rdtsc+import System.IO.Unsafe+import Data.IORef+import Data.Word+import Control.Monad+import Control.Monad.IO.Class (MonadIO(..))+import qualified Control.Monad.Fail as Fail (MonadFail)+import Control.Monad.Free+import Control.Monad.Free.TH+import qualified Control.Monad.Free.Church as Church+import Control.Monad.Trans.State.Strict+import Text.Printf++-- | A data type representing basic commands for our performance-testing eDSL.+data PerfF next where+ Output :: String -> next -> PerfF next+ Input :: (Show a, Read a) => (a -> next) -> PerfF next++-- | Unfortunately this Functor instance cannot yet be derived+-- automatically by GHC.+instance Functor PerfF where+ fmap f (Output s x) = Output s (f x)+ fmap f (Input g) = Input (f . g)++makeFreeCon 'Output+makeFreeCon 'Input++type PerfCnt = Word64++-- | Unsafe state variable: base CPU cycles+{-# NOINLINE g_base_counter #-}+g_base_counter :: IORef PerfCnt+g_base_counter = unsafePerformIO $ do+ rdtsc >>= newIORef++-- | Prints number of CPU cycles since last call+g_print_time_since_prev_call :: (MonadIO m) => m ()+g_print_time_since_prev_call = liftIO $ do+ cb <- readIORef g_base_counter+ c <- rdtsc+ writeIORef g_base_counter c+ putStr $ printf "\r%-10s" (show $ c - cb)++-- | Free-based interpreter+runPerfFree :: (MonadIO m) => [String] -> Free PerfF () -> m ()+runPerfFree [] _ = return ()+runPerfFree (s:ss) x = case x of+ Free (Output _o next) -> do+ runPerfFree (s:ss) next+ Free (Input next) -> do+ g_print_time_since_prev_call+ runPerfFree ss (next (read s))+ Pure a -> do+ return a++-- | Church-based interpreter+runPerfF :: (Fail.MonadFail m, MonadIO m) => [String] -> Church.F PerfF () -> m ()+runPerfF [] _ = return ()+runPerfF ss0 f =+ fst `liftM` do+ flip runStateT ss0 $ Church.iterM go f where+ go (Output _o next) = do+ next+ go (Input next) = do+ g_print_time_since_prev_call+ (s:ss) <- get+ put ss+ next (read s)++-- | Test input is the same for all cases+test_input :: [String]+test_input = [show i | i<-([1..9999] ++ [0 :: Int])]++-- | Tail-recursive program+test_tail :: (MonadFree PerfF m) => m ()+test_tail = do+ output "Enter something"+ (n :: Int) <- input+ output $ "Just entered: " ++ (show n)+ when (n > 0) $ do+ test_tail++run_tail_free,run_tail_f :: IO ()+run_tail_free = runPerfFree test_input test_tail+run_tail_f = runPerfF test_input test_tail+++-- | Deep-recursive program+test_loop :: (MonadFree PerfF m) => m ()+test_loop = do+ output "Enter something"+ (n :: Int) <- input+ when (n > 0) $ do+ test_loop+ output $ "Just entered: " ++ (show n)++run_loop_free,run_loop_f :: IO ()+run_loop_free = runPerfFree test_input test_loop+run_loop_f = runPerfF test_input test_loop++main :: IO ()+main = do+ putStr $ unlines [+ "Running two kinds of FreeMonad programs against two kinds of interpreters.",+ "Counters represent approx. number of CPU ticks per program iteration" ]+ putStrLn ">> (1/4) Tail-recursive program/Free interpreter"+ run_tail_free+ putStrLn "\n>> (2/4) Tail-recursive program/Church interpreter"+ run_tail_f+ putStrLn "\n>> (3/4) Deep-recursive program/Free interpreter (a slower one)"+ run_loop_free+ putStrLn "\n>> (4/4) Deep-recursive program/Church interpreter"+ run_loop_f+ putStrLn "\n"+
examples/RetryTH.hs view
@@ -1,12 +1,15 @@ {-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} module Main where import Control.Monad+import Control.Monad.Fail as Fail import Control.Monad.Free import Control.Monad.Free.TH import Control.Monad.IO.Class+import Control.Monad.Trans.Instances () import Control.Monad.Trans.Maybe import qualified Data.Foldable as F import Text.Read (readMaybe)@@ -52,10 +55,10 @@ -- retry :: MonadFree RetryF m => m a -- | We can run a retriable program in any MonadIO.-runRetry :: MonadIO m => Retry a -> m a+runRetry :: (MonadFail m, MonadIO m) => Retry a -> m a runRetry = iterM run where- run :: MonadIO m => RetryF (m a) -> m a+ run :: (MonadFail m, MonadIO m) => RetryF (m a) -> m a run (Output s next) = do liftIO $ putStrLn s@@ -65,7 +68,7 @@ s <- liftIO getLine case readMaybe s of Just x -> next x- Nothing -> fail "invalid input"+ Nothing -> Fail.fail "invalid input" run (WithRetry block next) = do -- Here we use@@ -75,7 +78,7 @@ Just x <- runMaybeT . F.msum $ repeat (runRetry block) next x - run Retry = fail "forced retry"+ run Retry = Fail.fail "forced retry" -- | Sample program. test :: Retry ()@@ -91,4 +94,3 @@ main :: IO () main = runRetry test-
examples/Teletype.lhs view
@@ -1,12 +1,12 @@ > {-# LANGUAGE DeriveFunctor, TemplateHaskell, FlexibleContexts #-} --+> module Main where +> import qualified Control.Exception as E (catch) > import Control.Monad (mfilter) > import Control.Monad.Loops (unfoldM) > import Control.Monad.Free (liftF, Free, iterM, MonadFree) > import Control.Monad.Free.TH (makeFree)-> import Control.Applicative ((<$>)) > import System.IO (isEOF)-> import Control.Exception (catch) > import System.IO.Error (ioeGetErrorString) > import System.Exit (exitSuccess) @@ -61,7 +61,7 @@ > run (ReadOrEOF eof f) = isEOF >>= \b -> if b then eof > else getChar >>= f >-> run (ReadOrError ferror f) = catch (getChar >>= f) (ferror . ioeGetErrorString)+> run (ReadOrError ferror f) = E.catch (getChar >>= f) (ferror . ioeGetErrorString) > run (NL rest) = putChar '\n' >> rest > run (rest :\^^ str) = putStr str >> rest > run ((:%) rest format tokens) = ttFormat format tokens >> rest
examples/ValidationForm.hs view
@@ -1,10 +1,10 @@ module Main where -import Control.Applicative import Control.Applicative.Free-import Control.Monad.State+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Trans.State -import Data.Monoid+import Data.Monoid (Sum(..)) import Text.Read (readEither) import Text.Printf@@ -66,8 +66,9 @@ -- Repeats field input until it passes validation. -- Show help message on empty input. input :: Form a -> IO a-input m = evalStateT (runAp inputField m) (1 :: Integer)+input m = evalStateT (runAp inputField m) 1 where+ inputField :: Field a -> StateT Int IO a inputField f@(Field n g h) = do i <- get -- get field input with prompt
+ examples/free-examples.cabal view
@@ -0,0 +1,109 @@+name: free-examples+category: Control, Monads+version: 0.1+license: BSD3+cabal-version: 1.18+license-file: LICENSE+author: Edward A. Kmett+maintainer: Edward A. Kmett <ekmett@gmail.com>+stability: provisional+homepage: http://github.com/ekmett/free/+bug-reports: http://github.com/ekmett/free/issues+copyright: Copyright (C) 2008-2015 Edward A. Kmett+tested-with: GHC == 8.0.2+ , GHC == 8.2.2+ , GHC == 8.4.4+ , GHC == 8.6.5+ , GHC == 8.8.4+ , GHC == 8.10.7+ , GHC == 9.0.2+ , GHC == 9.2.6+ , GHC == 9.4.4+ , GHC == 9.6.1+synopsis: Monads for free+description: Examples projects using @free@+build-type: Simple++source-repository head+ type: git+ location: git://github.com/ekmett/free.git++flag mandelbrot-iter+ default: True++library+ hs-source-dirs: .+ default-language: Haskell2010+ exposed-modules: Cabbage+ ghc-options: -Wall+ build-depends:+ base >= 4.9 && < 5,+ free,+ mtl >= 2.0.1 && < 2.4,+ transformers >= 0.2 && < 0.7++executable free-mandelbrot-iter+ if !flag(mandelbrot-iter)+ buildable: False+ hs-source-dirs: .+ default-language: Haskell2010+ main-is: MandelbrotIter.lhs+ ghc-options: -Wall+ build-depends:+ base >= 4.9 && < 5,+ free,+ HGL >= 3.2.3.2,+ mtl >= 2.0.1 && < 2.4,+ transformers >= 0.2 && < 0.7++executable free-newton-coiter+ hs-source-dirs: .+ default-language: Haskell2010+ main-is: NewtonCoiter.lhs+ ghc-options: -Wall+ build-depends:+ base >= 4.9 && < 5,+ comonad >= 4 && < 6,+ free++executable free-perf-th+ hs-source-dirs: .+ default-language: Haskell2010+ main-is: PerfTH.hs+ ghc-options: -Wall+ build-depends:+ base >= 4.9 && < 5,+ free,+ rdtsc,+ transformers >= 0.2 && < 0.7++executable free-retry-th+ hs-source-dirs: .+ default-language: Haskell2010+ main-is: RetryTH.hs+ ghc-options: -Wall -fno-warn-orphans+ build-depends:+ base >= 4.9 && < 5,+ free,+ transformers >= 0.2 && < 0.7,+ transformers-compat >= 0.6.4 && < 0.8++executable free-teletype+ hs-source-dirs: .+ default-language: Haskell2010+ main-is: Teletype.lhs+ ghc-options: -Wall+ build-depends:+ base >= 4.9 && < 5,+ free,+ monad-loops++executable free-validation-form+ hs-source-dirs: .+ default-language: Haskell2010+ main-is: ValidationForm.hs+ ghc-options: -Wall+ build-depends:+ base >= 4.9 && < 5,+ free,+ transformers >= 0.2 && < 0.7
free.cabal view
@@ -1,15 +1,25 @@ name: free category: Control, Monads-version: 4.11+version: 5.2 license: BSD3-cabal-version: >= 1.10+cabal-version: 1.18 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett <ekmett@gmail.com> stability: provisional homepage: http://github.com/ekmett/free/ bug-reports: http://github.com/ekmett/free/issues-copyright: Copyright (C) 2008-2013 Edward A. Kmett+copyright: Copyright (C) 2008-2015 Edward A. Kmett+tested-with: GHC == 8.0.2+ , GHC == 8.2.2+ , GHC == 8.4.4+ , GHC == 8.6.5+ , GHC == 8.8.4+ , GHC == 8.10.7+ , GHC == 9.0.2+ , GHC == 9.2.6+ , GHC == 9.4.4+ , GHC == 9.6.1 synopsis: Monads for free description: Free monads are useful for many tree-like structures and domain specific languages.@@ -28,20 +38,20 @@ . More information on free monads, including examples, can be found in the following blog posts:- <http://comonad.com/reader/2008/monads-for-free/>- <http://comonad.com/reader/2011/free-monads-for-less/>+ <https://ekmett.github.io/reader/2008/monads-for-free/>+ <https://ekmett.github.io/reader/2011/free-monads-for-less/> build-type: Simple extra-source-files:- .ghci .gitignore- .travis.yml+ .hlint.yaml .vim.custom README.markdown CHANGELOG.markdown- HLint.hs doc/proof/Control/Comonad/Cofree/*.md doc/proof/Control/Comonad/Trans/Cofree/*.md+ examples/free-examples.cabal+ examples/LICENSE examples/*.hs examples/*.lhs extra-doc-files:@@ -56,7 +66,6 @@ hs-source-dirs: src default-language: Haskell2010- default-extensions: CPP other-extensions: MultiParamTypeClasses FunctionalDependencies@@ -66,32 +75,52 @@ GADTs build-depends:- base == 4.*,- bifunctors == 4.*,- comonad == 4.*,- distributive >= 0.2.1,- mtl >= 2.0.1.0 && < 2.3,- prelude-extras >= 0.4 && < 1,- profunctors == 4.*,- semigroupoids == 4.*,- semigroups >= 0.8.3.1 && < 1,- transformers >= 0.2.0 && < 0.5,- template-haskell >= 2.7.0.0 && < 3+ base >= 4.9 && < 5,+ comonad >= 5.0.8 && < 6,+ containers >= 0.5.7.1 && < 0.7,+ distributive >= 0.5.2 && < 1,+ exceptions >= 0.10.4 && < 0.11,+ indexed-traversable >= 0.1.1 && < 0.2,+ mtl >= 2.2.2 && < 2.4,+ profunctors >= 5.6.1 && < 6,+ semigroupoids >= 5.3.5 && < 6,+ th-abstraction >= 0.4.2.0 && < 0.6,+ transformers >= 0.5 && < 0.7,+ transformers-base >= 0.4.5.2 && < 0.5,+ template-haskell >= 2.11 && < 2.21 + if !impl(ghc >= 8.2)+ build-depends: bifunctor-classes-compat >= 0.1 && < 0.2+ exposed-modules: Control.Applicative.Free+ Control.Applicative.Free.Fast+ Control.Applicative.Free.Final Control.Applicative.Trans.Free Control.Alternative.Free+ Control.Alternative.Free.Final Control.Comonad.Cofree Control.Comonad.Cofree.Class Control.Comonad.Trans.Cofree Control.Comonad.Trans.Coiter Control.Monad.Free+ Control.Monad.Free.Ap Control.Monad.Free.Church Control.Monad.Free.Class Control.Monad.Free.TH Control.Monad.Trans.Free+ Control.Monad.Trans.Free.Ap Control.Monad.Trans.Free.Church Control.Monad.Trans.Iter - ghc-options: -Wall+ ghc-options: -Wall -Wcompat -Wnoncanonical-monad-instances++ if !impl(ghc >= 8.8)+ ghc-options: -Wnoncanonical-monadfail-instances++ if impl(ghc >= 9.0)+ -- these flags may abort compilation with GHC-8.10+ -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/3295+ ghc-options: -Winferred-safe-imports -Wmissing-safe-haskell-mode++ x-docspec-extra-packages: tagged
src/Control/Alternative/Free.hs view
@@ -2,10 +2,8 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-}-#if __GLASGOW_HASKELL__ >= 707-{-# LANGUAGE DeriveDataTypeable #-}-#endif-{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE Safe #-}+ ----------------------------------------------------------------------------- -- | -- Module : Control.Alternative.Free@@ -29,31 +27,29 @@ import Control.Applicative import Data.Functor.Apply+import Data.Functor.Alt ((<!>))+import qualified Data.Functor.Alt as Alt++#if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup-import Data.Typeable+#endif infixl 3 `Ap` data AltF f a where Ap :: f a -> Alt f (a -> b) -> AltF f b Pure :: a -> AltF f a-#if __GLASGOW_HASKELL__ >= 707- deriving Typeable-#endif newtype Alt f a = Alt { alternatives :: [AltF f a] }-#if __GLASGOW_HASKELL__ >= 707- deriving Typeable-#endif -instance Functor f => Functor (AltF f) where+instance Functor (AltF f) where fmap f (Pure a) = Pure $ f a fmap f (Ap x g) = x `Ap` fmap (f .) g -instance Functor f => Functor (Alt f) where+instance Functor (Alt f) where fmap f (Alt xs) = Alt $ map (fmap f) xs -instance Functor f => Applicative (AltF f) where+instance Applicative (AltF f) where pure = Pure {-# INLINE pure #-} (Pure f) <*> y = fmap f y -- fmap@@ -61,24 +57,24 @@ (Ap a f) <*> b = a `Ap` (flip <$> f <*> (Alt [b])) {-# INLINE (<*>) #-} -instance Functor f => Applicative (Alt f) where+instance Applicative (Alt f) where pure a = Alt [pure a] {-# INLINE pure #-} (Alt xs) <*> ys = Alt (xs >>= alternatives . (`ap'` ys)) where- ap' :: (Functor f) => AltF f (a -> b) -> Alt f a -> Alt f b+ ap' :: AltF f (a -> b) -> Alt f a -> Alt f b Pure f `ap'` u = fmap f u (u `Ap` f) `ap'` v = Alt [u `Ap` (flip <$> f) <*> v] {-# INLINE (<*>) #-} -liftAltF :: (Functor f) => f a -> AltF f a+liftAltF :: f a -> AltF f a liftAltF x = x `Ap` pure id {-# INLINE liftAltF #-} --- | A version of 'lift' that can be used with just a 'Functor' for @f@.-liftAlt :: (Functor f) => f a -> Alt f a+-- | A version of 'lift' that can be used with any @f@.+liftAlt :: f a -> Alt f a liftAlt = Alt . (:[]) . liftAltF {-# INLINE liftAlt #-} @@ -94,24 +90,28 @@ go2 (Ap x f) = flip id <$> u x <*> go f {-# INLINABLE runAlt #-} -instance (Functor f) => Apply (Alt f) where+instance Apply (Alt f) where (<.>) = (<*>) {-# INLINE (<.>) #-} -instance (Functor f) => Alternative (Alt f) where+instance Alt.Alt (Alt f) where+ (<!>) = (<|>)+ {-# INLINE (<!>) #-}++instance Alternative (Alt f) where empty = Alt [] {-# INLINE empty #-} Alt as <|> Alt bs = Alt (as ++ bs) {-# INLINE (<|>) #-} -instance (Functor f) => Semigroup (Alt f a) where+instance Semigroup (Alt f a) where (<>) = (<|>) {-# INLINE (<>) #-} -instance (Functor f) => Monoid (Alt f a) where+instance Monoid (Alt f a) where mempty = empty {-# INLINE mempty #-}- mappend = (<|>)+ mappend = (<>) {-# INLINE mappend #-} mconcat as = Alt (as >>= alternatives) {-# INLINE mconcat #-}@@ -125,26 +125,3 @@ hoistAlt :: (forall a. f a -> g a) -> Alt f b -> Alt g b hoistAlt f (Alt as) = Alt (map (hoistAltF f) as) {-# INLINE hoistAlt #-}--#if __GLASGOW_HASKELL__ < 707-instance Typeable1 f => Typeable1 (Alt f) where- typeOf1 t = mkTyConApp altTyCon [typeOf1 (f t)] where- f :: Alt f a -> f a- f = undefined--instance Typeable1 f => Typeable1 (AltF f) where- typeOf1 t = mkTyConApp altFTyCon [typeOf1 (f t)] where- f :: AltF f a -> f a- f = undefined--altTyCon, altFTyCon :: TyCon-#if __GLASGOW_HASKELL__ < 704-altTyCon = mkTyCon "Control.Alternative.Free.Alt"-altFTyCon = mkTyCon "Control.Alternative.Free.AltF"-#else-altTyCon = mkTyCon3 "free" "Control.Alternative.Free" "Alt"-altFTyCon = mkTyCon3 "free" "Control.Alternative.Free" "AltF"-#endif-{-# NOINLINE altTyCon #-}-{-# NOINLINE altFTyCon #-}-#endif
+ src/Control/Alternative/Free/Final.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE Safe #-}++-----------------------------------------------------------------------------+-- |+-- Module : Control.Alternative.Free.Final+-- Copyright : (C) 2012 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : GADTs, Rank2Types+--+-- Final encoding of free 'Alternative' functors.+----------------------------------------------------------------------------+module Control.Alternative.Free.Final+ ( Alt(..)+ , runAlt+ , liftAlt+ , hoistAlt+ ) where++import Control.Applicative+import Data.Functor.Apply+import Data.Functor.Alt ((<!>))+import qualified Data.Functor.Alt as Alt++#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup+#endif++-- | The free 'Alternative' for any @f@.+newtype Alt f a = Alt { _runAlt :: forall g. Alternative g => (forall x. f x -> g x) -> g a }++instance Functor (Alt f) where+ fmap f (Alt g) = Alt (\k -> fmap f (g k))++instance Apply (Alt f) where+ Alt f <.> Alt x = Alt (\k -> f k <*> x k)++instance Applicative (Alt f) where+ pure x = Alt (\_ -> pure x)+ Alt f <*> Alt x = Alt (\k -> f k <*> x k)++instance Alt.Alt (Alt f) where+ Alt x <!> Alt y = Alt (\k -> x k <|> y k)++instance Alternative (Alt f) where+ empty = Alt (\_ -> empty)+ Alt x <|> Alt y = Alt (\k -> x k <|> y k)+ some (Alt x) = Alt $ \k -> some (x k)+ many (Alt x) = Alt $ \k -> many (x k)++instance Semigroup (Alt f a) where+ (<>) = (<|>)++instance Monoid (Alt f a) where+ mempty = empty+ mappend = (<>)++-- | A version of 'lift' that can be used with @f@.+liftAlt :: f a -> Alt f a+liftAlt f = Alt (\k -> k f)++-- | Given a natural transformation from @f@ to @g@, this gives a canonical monoidal natural transformation from @'Alt' f@ to @g@.+runAlt :: forall f g a. Alternative g => (forall x. f x -> g x) -> Alt f a -> g a+runAlt phi g = _runAlt g phi++-- | Given a natural transformation from @f@ to @g@ this gives a monoidal natural transformation from @Alt f@ to @Alt g@.+hoistAlt :: (forall a. f a -> g a) -> Alt f b -> Alt g b+hoistAlt phi (Alt g) = Alt (\k -> g (k . phi))+
src/Control/Applicative/Free.hs view
@@ -1,10 +1,7 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE GADTs #-}-#if __GLASGOW_HASKELL__ >= 707-{-# LANGUAGE DeriveDataTypeable #-}-#endif-{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE Safe #-}+ ----------------------------------------------------------------------------- -- | -- Module : Control.Applicative.Free@@ -30,6 +27,7 @@ , runAp , runAp_ , liftAp+ , iterAp , hoistAp , retractAp @@ -38,17 +36,18 @@ ) where import Control.Applicative+import Control.Comonad (Comonad(..)) import Data.Functor.Apply-import Data.Typeable-import Data.Monoid+import Data.Foldable+import Data.Semigroup.Foldable+import Data.Functor.Classes +import Prelude hiding (null)+ -- | The free 'Applicative' for a 'Functor' @f@. data Ap f a where Pure :: a -> Ap f a Ap :: f a -> Ap f (a -> b) -> Ap f b-#if __GLASGOW_HASKELL__ >= 707- deriving Typeable-#endif -- | Given a natural transformation from @f@ to @g@, this gives a canonical monoidal natural transformation from @'Ap' f@ to @g@. --@@ -81,11 +80,237 @@ Pure f <*> y = fmap f y Ap x y <*> z = Ap x (flip <$> y <*> z) +instance Comonad f => Comonad (Ap f) where+ extract (Pure a) = a+ extract (Ap x y) = extract y (extract x)+ duplicate (Pure a) = Pure (Pure a)+ duplicate (Ap x y) = Ap (duplicate x) (extend (flip Ap) y)++-- | @foldMap f == foldMap f . 'runAp' 'Data.Foldable.toList'@+instance Foldable f => Foldable (Ap f) where+ foldMap f (Pure a) = f a+ foldMap f (Ap x y) = foldMap (\a -> foldMap (\g -> f (g a)) y) x++ null (Pure _) = False+ null (Ap x y) = null x || null y++ length = go 1+ where+ -- This type annotation is required to do polymorphic recursion+ go :: Foldable t => Int -> Ap t a -> Int+ go n (Pure _) = n+ go n (Ap x y) = case n * length x of+ 0 -> 0+ n' -> go n' y++-- | @foldMap f == foldMap f . 'runAp' 'toNonEmpty'@+instance Foldable1 f => Foldable1 (Ap f) where+ foldMap1 f (Pure a) = f a+ foldMap1 f (Ap x y) = foldMap1 (\a -> foldMap1 (\g -> f (g a)) y) x+++{- $note_eq1++This comment section is an internal documentation, but written in proper+Haddock markup. It is to allow rendering them to ease reading this rather long document.++=== About the definition of @Eq1 (Ap f)@ instance++The @Eq1 (Ap f)@ instance below has a complex definition. This comment+explains why it is defined like that.++The discussion given here also applies to @Ord1 (Ap f)@ instance with a little change.++==== General discussion about @Eq1@ type class++Currently, there isn't a law on the @Eq1@ type class, but the following+properties can be expected.++* If @Eq (f ())@, and @Functor f@ holds, @Eq1 f@ satisfies++ > liftEq (\_ _ -> True) x y == (() <$ x) == (() <$ y)++* If @Foldable f@ holds, @Eq1 f@ satisfies:++ * @boringEq x y@ implies @length (toList x) == length (toList y)@++ * @liftEq eq x y == liftEq (\_ _ -> True) && all (\(a,b) -> eq a b)) (zip (toList x) (toList y))@++Let's define the commonly used function @liftEq (\\_ _ -> True)@ as @boringEq@.++> boringEq :: Eq1 f => f a -> f b -> Bool+> boringEq = liftEq (\_ _ -> True)++Changing the constant @True@ to the constant @False@ in the definition of+@boringEq@, let @emptyEq@ function be defined as:++> emptyEq :: Eq1 f => f a -> f b -> Bool+> emptyEq = liftEq (\_ _ -> False)++From the above properties expectated on a @Eq1@ instance, @emptyEq@ satisfies the following.++> emptyEq x y = boringEq x y && null (zip (toList x) (toList y))++==== About @instance (Eq1 (Ap f))@++If we're to define @Eq1 (Ap f)@ satisfying these properties as expected, @Eq (Ap f ())@ will determine+how @liftEq@ should behave. It's not unreasonable to define equality between @Ap f ()@ as below.++> boringEqAp (Pure _) (Pure _) = True+> boringEqAp (Ap x1 y1) (Ap x2 y2) = boringEq x1 x2 && boringEqAp y1 y2+> {- = ((() <$ x1) == (() <$ x2)) && (y1 == y2) -}+> boringEqAp _ _ = False++Its type can be more general than equality between @Ap f ()@:++> boringEqAp :: Eq1 f => Ap f a -> Ap f b -> Bool++Using @boringEqAp@, the specification of @liftEq@ will be:++> liftEq eq x y = boringEqAp x y && and (zipWith eq (toList x) (toList y))++Then unfold @toList@ to remove the dependency to @Foldable@.++> liftEq eq (Pure a1) (Pure a2)+> = boringEqAp (Pure a1) (Pure a2) && all (\(a,b) -> eq a b)) (zip (toList (Pure x)) (toList Pure y))+> = True && all (\(a,b) -> eq a b) (zip [a1] [a2])+> = eq a1 a2+> liftEq eq (Ap x1 y1) (Ap x2 y2)+> = boringEqAp (Ap x1 y1) (Ap x2 y2) && all (\(b1, b2) -> eq b1 b2) (zip (toList (Ap x1 y1)) (toList (Ap x2 y2)))+> = boringEq x1 y1 && boringEqAp y1 y2 && all (\(b1, b2) -> eq b1 b2) (zip (toList x1 <**> toList y1) (toList x2 <**> toList y2))+> = boringEq x1 y1 && boringEqAp y1 y2 && all (\(b1, b2) -> eq b1 b2) (zip (as1 <**> gs1) (as2 <**> gs2))+> where as1 = toList x1+> as2 = toList x2+> gs1 = toList y1+> gs2 = toList y2+> = boringEq x1 y1 && boringEqAp y1 y2 && all (\(a1, a2) -> all (\(g1, g2) -> eq (g1 a1) (g2 a2)) (zip gs1 gs2)) (zip as1 as2)++If @zip as1 as2@ is /not/ empty, the following transformation is valid.++> (...) | not (null (zip as1 as2))+> = boringEq x1 x2 && boringEqAp y1 y2 && all (\(a1, a2) -> all (\(g1, g2) -> eq (g1 a1) (g2 a2)) (zip gs1 gs2)) (zip as1 as2)+> = boringEq x1 x2 && all (\(a1, a2) -> boringEqAp y1 y2 && all (\(g1, g2) -> eq (g1 a1) (g2 a2)) (zip gs1 gs2)) (zip as1 as2)+> -- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^+> = boringEq x1 x2 && all (\(a1, a2) -> liftEq (\g1 g2 -> eq (g1 a1) (g2 a2)) y1 y2) (zip as1 as2)+> = liftEq (\a1 a2 -> liftEq (\g1 g2 -> eq (g1 a1) (g2 a2)) y1 y2)) x1 x2++Because, generally, the following transformation is valid if @xs@ is a nonempty list.++> cond && all p xs = all (\x -> cond && p x) xs -- Only when xs is not empty!++If @zip as1 as2@ is empty, @all (...) (zip as1 as2)@ is vacuously true, so the following transformation is valid.++> (...) | null (zip as1 as2)+> = boringEq x1 x2 && boringEqAp y1 y2 && all (\(a1, a2) -> all (\(g1, g2) -> eq (g1 a1) (g2 a2)) (zip gs1 gs2)) (zip as1 as2)+> = boringEq x1 x2 && boringEqAp y1 y2++Combining two cases:++> liftEq eq (Ap x1 y1) (Ap x2 y2)+> = null (zip as1 as2) && boringEq x1 x2 && boringEqAp y1 y2+> || not (null (zip as1 as2)) && liftEq (\a1 a2 -> liftEq (\g1 g2 -> eq (g1 a1) (g2 a2)) y1 y2)) x1 x2+> = null (zip as1 as2) && boringEq x1 x2 && boringEqAp y1 y2+> || liftEq (\a1 a2 -> liftEq (\g1 g2 -> eq (g1 a1) (g2 a2)) y1 y2)) x1 x2+> = emptyEq x1 x2 && boringEqAp y1 y2+> || liftEq (\a1 a2 -> liftEq (\g1 g2 -> eq (g1 a1) (g2 a2)) y1 y2)) x1 x2++The property about @emptyEq@ is used in the last equation.++Hence it's defined as this source code.++-}++-- | Specialized 'boringEq' for @Ap f@.+boringEqAp :: Eq1 f => Ap f a -> Ap f b -> Bool+boringEqAp (Pure _) (Pure _) = True+boringEqAp (Ap x1 y1) (Ap x2 y2) = boringEq x1 x2 && boringEqAp y1 y2+boringEqAp _ _ = False++-- | Implementaion of 'liftEq' for @Ap f@.+liftEqAp :: Eq1 f => (a -> b -> Bool) -> Ap f a -> Ap f b -> Bool+liftEqAp eq (Pure a1) (Pure a2) = eq a1 a2+liftEqAp eq (Ap x1 y1) (Ap x2 y2)+ -- This branching is necessary and not just an optimization.+ -- See the above comment for more+ | emptyEq x1 x2 = boringEqAp y1 y2+ | otherwise =+ liftEq (\a1 a2 -> liftEqAp (\g1 g2 -> eq (g1 a1) (g2 a2)) y1 y2) x1 x2+liftEqAp _ _ _ = False++-- | @boringEq fa fb@ tests if @fa@ and @fb@ are equal ignoring any difference between+-- their content (the values of their last parameters @a@ and @b@.)+--+-- It is named \'boring\' because the type parameters @a@ and @b@ are+-- treated as if they are the most boring type @()@.+boringEq :: Eq1 f => f a -> f b -> Bool+boringEq = liftEq (\_ _ -> True)++-- | @emptyEq fa fb@ tests if @fa@ and @fb@ are equal /and/ they don't have any content+-- (the values of their last parameters @a@ and @b@.)+--+-- It is named \'empty\' because it only tests for values without any content,+-- like an empty list or @Nothing@.+--+-- If @f@ is also @Foldable@, @emptyEq fa fb@ would be equivalent to+-- @null fa && null fb && liftEq eq@ for any @eq :: a -> b -> Bool@.+--+-- (It depends on each instance of @Eq1@. Since @Eq1@ does not have+-- any laws currently, this is not a hard guarantee. But all instances in "base", "transformers",+-- "containers", "array", and "free" satisfy it.)+--+-- Note that @emptyEq@ is not a equivalence relation, since it's possible @emptyEq x x == False@.+emptyEq :: Eq1 f => f a -> f b -> Bool+emptyEq = liftEq (\_ _ -> False)++instance Eq1 f => Eq1 (Ap f) where+ liftEq = liftEqAp++instance (Eq1 f, Eq a) => Eq (Ap f a) where+ (==) = eq1++-- | Specialized 'boringCompare' for @Ap f@.+boringCompareAp :: Ord1 f => Ap f a -> Ap f b -> Ordering+boringCompareAp (Pure _) (Pure _) = EQ+boringCompareAp (Pure _) (Ap _ _) = LT+boringCompareAp (Ap x1 y1) (Ap x2 y2) = boringCompare x1 x2 `mappend` boringCompareAp y1 y2+boringCompareAp (Ap _ _) (Pure _) = GT++-- | Implementation of 'liftCompare' for @Ap f@+liftCompareAp :: Ord1 f => (a -> b -> Ordering) -> Ap f a -> Ap f b -> Ordering+liftCompareAp cmp (Pure a1) (Pure a2) = cmp a1 a2+liftCompareAp _ (Pure _) (Ap _ _) = LT+liftCompareAp cmp (Ap x1 y1) (Ap x2 y2)+ -- This branching is necessary and not just an optimization.+ -- See the above comment for more+ | emptyEq x1 x2 = boringCompareAp y1 y2+ | otherwise = liftCompare (\a1 a2 -> liftCompareAp (\g1 g2 -> cmp (g1 a1) (g2 a2)) y1 y2) x1 x2+liftCompareAp _ (Ap _ _) (Pure _) = GT++-- | @boringCompare fa fb@ compares @fa@ and @fb@ ignoring any difference between+-- their content (the values of their last parameters @a@ and @b@.)+--+-- It is named \'boring\' because the type parameters @a@ and @b@ are+-- treated as if they are the most boring type @()@.+boringCompare :: Ord1 f => f a -> f b -> Ordering+boringCompare = liftCompare (\_ _ -> EQ)++instance Ord1 f => Ord1 (Ap f) where+ liftCompare = liftCompareAp++instance (Ord1 f, Ord a) => Ord (Ap f a) where+ compare = compare1+ -- | A version of 'lift' that can be used with just a 'Functor' for @f@. liftAp :: f a -> Ap f a liftAp x = Ap x (Pure id) {-# INLINE liftAp #-} +-- | Tear down a free 'Applicative' using iteration.+iterAp :: Functor g => (g a -> a) -> Ap g a -> a+iterAp algebra = go+ where go (Pure a) = a+ go (Ap underlying apply) = algebra (go . (apply <*>) . pure <$> underlying)+ -- | Given a natural transformation from @f@ to @g@ this gives a monoidal natural transformation from @Ap f@ to @Ap g@. hoistAp :: (forall a. f a -> g a) -> Ap f b -> Ap g b hoistAp _ (Pure a) = Pure a@@ -98,22 +323,6 @@ retractAp :: Applicative f => Ap f a -> f a retractAp (Pure a) = pure a retractAp (Ap x y) = x <**> retractAp y--#if __GLASGOW_HASKELL__ < 707-instance Typeable1 f => Typeable1 (Ap f) where- typeOf1 t = mkTyConApp apTyCon [typeOf1 (f t)] where- f :: Ap f a -> f a- f = undefined--apTyCon :: TyCon-#if __GLASGOW_HASKELL__ < 704-apTyCon = mkTyCon "Control.Applicative.Free.Ap"-#else-apTyCon = mkTyCon3 "free" "Control.Applicative.Free" "Ap"-#endif-{-# NOINLINE apTyCon #-}--#endif {- $examples
+ src/Control/Applicative/Free/Fast.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE Safe #-}++--------------------------------------------------------------------------------+-- |+-- A faster free applicative.+-- Based on <https://www.eyrie.org/~zednenem/2013/05/27/freeapp Dave Menendez's work>.+--------------------------------------------------------------------------------+module Control.Applicative.Free.Fast+ (+ -- * The Sequence of Effects+ ASeq(..)+ , reduceASeq+ , hoistASeq+ , traverseASeq+ , rebaseASeq+ -- * The Faster Free Applicative+ , Ap(..)+ , liftAp+ , retractAp+ , runAp+ , runAp_+ , hoistAp+ ) where++import Control.Applicative+import Data.Functor.Apply++-- | The free applicative is composed of a sequence of effects,+-- and a pure function to apply that sequence to.+-- The fast free applicative separates these from each other,+-- so that the sequence may be built up independently,+-- and so that 'fmap' can run in constant time by having immediate access to the pure function.+data ASeq f a where+ ANil :: ASeq f ()+ ACons :: f a -> ASeq f u -> ASeq f (a,u)++-- | Interprets the sequence of effects using the semantics for+-- `pure` and `<*>` given by the Applicative instance for 'f'.+reduceASeq :: Applicative f => ASeq f u -> f u+reduceASeq ANil = pure ()+reduceASeq (ACons x xs) = (,) <$> x <*> reduceASeq xs++-- | Given a natural transformation from @f@ to @g@ this gives a natural transformation from @ASeq f@ to @ASeq g@.+hoistASeq :: (forall x. f x -> g x) -> ASeq f a -> ASeq g a+hoistASeq _ ANil = ANil+hoistASeq u (ACons x xs) = ACons (u x) (u `hoistASeq` xs)++-- | Traverse a sequence with resepect to its interpretation type 'f'.+traverseASeq :: Applicative h => (forall x. f x -> h (g x)) -> ASeq f a -> h (ASeq g a)+traverseASeq _ ANil = pure ANil+traverseASeq f (ACons x xs) = ACons <$> f x <*> traverseASeq f xs++-- | It may not be obvious, but this essentially acts like ++,+-- traversing the first sequence and creating a new one by appending the second sequence.+-- The difference is that this also has to modify the return functions and that the return type depends on the input types.+--+-- See the source of 'hoistAp' as an example usage.+rebaseASeq :: ASeq f u -> (forall x. (x -> y) -> ASeq f x -> z) ->+ (v -> u -> y) -> ASeq f v -> z+rebaseASeq ANil k f = k (\v -> f v ())+rebaseASeq (ACons x xs) k f =+ rebaseASeq xs (\g s -> k (\(a,u) -> g u a) (ACons x s))+ (\v u a -> f v (a,u))+++-- | The faster free 'Applicative'.+newtype Ap f a = Ap+ { unAp :: forall u y z.+ (forall x. (x -> y) -> ASeq f x -> z) ->+ (u -> a -> y) -> ASeq f u -> z }++-- | Given a natural transformation from @f@ to @g@, this gives a canonical monoidal natural transformation from @'Ap' f@ to @g@.+--+-- prop> runAp t == retractApp . hoistApp t+runAp :: Applicative g => (forall x. f x -> g x) -> Ap f a -> g a+runAp u = retractAp . hoistAp u++-- | Perform a monoidal analysis over free applicative value.+--+-- Example:+--+-- @+-- count :: Ap f a -> Int+-- count = getSum . runAp_ (\\_ -> Sum 1)+-- @+runAp_ :: Monoid m => (forall a. f a -> m) -> Ap f b -> m+runAp_ f = getConst . runAp (Const . f)++instance Functor (Ap f) where+ fmap g x = Ap (\k f -> unAp x k (\s -> f s . g))++instance Apply (Ap f) where+ (<.>) = (<*>)++instance Applicative (Ap f) where+ pure a = Ap (\k f -> k (`f` a))+ x <*> y = Ap (\k f -> unAp y (unAp x k) (\s a g -> f s (g a)))++-- | A version of 'lift' that can be used with just a 'Functor' for @f@.+liftAp :: f a -> Ap f a+liftAp a = Ap (\k f s -> k (\(a',s') -> f s' a') (ACons a s))+{-# INLINE liftAp #-}++-- | Given a natural transformation from @f@ to @g@ this gives a monoidal natural transformation from @Ap f@ to @Ap g@.+hoistAp :: (forall x. f x -> g x) -> Ap f a -> Ap g a+hoistAp g x = Ap (\k f s ->+ unAp x+ (\f' s' ->+ rebaseASeq (hoistASeq g s') k+ (\v u -> f v (f' u)) s)+ (const id)+ ANil)++-- | Interprets the free applicative functor over f using the semantics for+-- `pure` and `<*>` given by the Applicative instance for f.+--+-- prop> retractApp == runAp id+retractAp :: Applicative f => Ap f a -> f a+retractAp x = unAp x (\f s -> f <$> reduceASeq s) (\() -> id) ANil
+ src/Control/Applicative/Free/Final.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE Safe #-}++-----------------------------------------------------------------------------+-- |+-- Module : Control.Applicative.Free.Final+-- Copyright : (C) 2012-2013 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : GADTs, Rank2Types+--+-- Final encoding of free 'Applicative' functors.+----------------------------------------------------------------------------+module Control.Applicative.Free.Final+ (+ -- | Compared to the free monad, they are less expressive. However, they are also more+ -- flexible to inspect and interpret, as the number of ways in which+ -- the values can be nested is more limited.++ Ap(..)+ , runAp+ , runAp_+ , liftAp+ , hoistAp+ , retractAp++ -- * Examples+ -- $examples+ ) where++import Control.Applicative+import Data.Functor.Apply++-- | The free 'Applicative' for a 'Functor' @f@.+newtype Ap f a = Ap { _runAp :: forall g. Applicative g => (forall x. f x -> g x) -> g a }++-- | Given a natural transformation from @f@ to @g@, this gives a canonical monoidal natural transformation from @'Ap' f@ to @g@.+--+-- prop> runAp t == retractApp . hoistApp t+runAp :: Applicative g => (forall x. f x -> g x) -> Ap f a -> g a+runAp phi m = _runAp m phi++-- | Perform a monoidal analysis over free applicative value.+--+-- Example:+--+-- @+-- count :: Ap f a -> Int+-- count = getSum . runAp_ (\\_ -> Sum 1)+-- @+runAp_ :: Monoid m => (forall a. f a -> m) -> Ap f b -> m+runAp_ f = getConst . runAp (Const . f)++instance Functor (Ap f) where+ fmap f (Ap g) = Ap (\k -> fmap f (g k))++instance Apply (Ap f) where+ Ap f <.> Ap x = Ap (\k -> f k <*> x k)++instance Applicative (Ap f) where+ pure x = Ap (\_ -> pure x)+ Ap f <*> Ap x = Ap (\k -> f k <*> x k)++-- | A version of 'lift' that can be used with just a 'Functor' for @f@.+liftAp :: f a -> Ap f a+liftAp x = Ap (\k -> k x)++-- | Given a natural transformation from @f@ to @g@ this gives a monoidal natural transformation from @Ap f@ to @Ap g@.+hoistAp :: (forall a. f a -> g a) -> Ap f b -> Ap g b+hoistAp f (Ap g) = Ap (\k -> g (k . f))++-- | Interprets the free applicative functor over f using the semantics for+-- `pure` and `<*>` given by the Applicative instance for f.+--+-- prop> retractApp == runAp id+retractAp :: Applicative f => Ap f a -> f a+retractAp (Ap g) = g id++{- $examples++<examples/ValidationForm.hs Validation form>++-}
src/Control/Applicative/Trans/Free.hs view
@@ -1,10 +1,7 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE GADTs #-}-#if __GLASGOW_HASKELL__ >= 707-{-# LANGUAGE DeriveDataTypeable #-}-#endif-{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE Safe #-}+ ----------------------------------------------------------------------------- -- | -- Module : Control.Applicative.Trans.Free@@ -36,6 +33,7 @@ , hoistApF , transApT , transApF+ , joinApT -- * Free Applicative , Ap , runAp@@ -47,28 +45,18 @@ ) where import Control.Applicative+import Control.Monad (liftM) import Data.Functor.Apply import Data.Functor.Identity-import Data.Typeable-#if !(MIN_VERSION_base(4,8,0))-import Data.Monoid (Monoid)-#endif-import qualified Data.Foldable as F -- | The free 'Applicative' for a 'Functor' @f@. data ApF f g a where Pure :: a -> ApF f g a Ap :: f a -> ApT f g (a -> b) -> ApF f g b-#if __GLASGOW_HASKELL__ >= 707- deriving Typeable-#endif -- | The free 'Applicative' transformer for a 'Functor' @f@ over -- 'Applicative' @g@. newtype ApT f g a = ApT { getApT :: g (ApF f g a) }-#if __GLASGOW_HASKELL__ >= 707- deriving Typeable-#endif instance Functor g => Functor (ApF f g) where fmap f (Pure a) = Pure (f a)@@ -129,13 +117,13 @@ -- Examples: -- -- @--- height :: ('Functor' g, 'F.Foldable' g) => 'ApT' f g a -> 'Int'--- height = 'getSum' . runApT_ (\_ -> 'Sum' 1) 'F.maximum'+-- height :: ('Functor' g, 'Foldable' g) => 'ApT' f g a -> 'Int'+-- height = 'getSum' . runApT_ (\_ -> 'Sum' 1) 'maximum' -- @ -- -- @--- size :: ('Functor' g, 'F.Foldable' g) => 'ApT' f g a -> 'Int'--- size = 'getSum' . runApT_ (\_ -> 'Sum' 1) 'F.fold'+-- size :: ('Functor' g, 'Foldable' g) => 'ApT' f g a -> 'Int'+-- size = 'getSum' . runApT_ (\_ -> 'Sum' 1) 'fold' -- @ runApT_ :: (Functor g, Monoid m) => (forall a. f a -> m) -> (g m -> m) -> ApT f g b -> m runApT_ f g = getConst . runApT (Const . f) (Const . g . fmap getConst)@@ -158,6 +146,13 @@ transApT :: Functor g => (forall a. g a -> g' a) -> ApT f g b -> ApT f g' b transApT f (ApT g) = ApT $ f (transApF f <$> g) +-- | Pull out and join @m@ layers of @'ApT' f m a@.+joinApT :: Monad m => ApT f m a -> m (Ap f a)+joinApT (ApT m) = m >>= joinApF+ where+ joinApF (Pure x) = return (pure x)+ joinApF (Ap x y) = (liftApT x <**>) `liftM` joinApT y+ -- | The free 'Applicative' for a 'Functor' @f@. type Ap f = ApT f Identity @@ -189,31 +184,8 @@ type Alt f = ApT f [] -- | Given a natural transformation from @f@ to @g@, this gives a canonical monoidal natural transformation from @'Alt' f@ to @g@.-runAlt :: (Alternative g, F.Foldable t) => (forall x. f x -> g x) -> ApT f t a -> g a-runAlt f (ApT xs) = F.foldr (\x acc -> h x <|> acc) empty xs+runAlt :: (Alternative g, Foldable t) => (forall x. f x -> g x) -> ApT f t a -> g a+runAlt f (ApT xs) = foldr (\x acc -> h x <|> acc) empty xs where h (Pure x) = pure x h (Ap x g) = f x <**> runAlt f g--#if __GLASGOW_HASKELL__ < 707-instance (Typeable1 f, Typeable1 g) => Typeable1 (ApT f g) where- typeOf1 t = mkTyConApp apTTyCon [typeOf1 (f t)] where- f :: ApT f g a -> g (f a)- f = undefined--instance (Typeable1 f, Typeable1 g) => Typeable1 (ApF f g) where- typeOf1 t = mkTyConApp apFTyCon [typeOf1 (f t)] where- f :: ApF f g a -> g (f a)- f = undefined--apTTyCon, apFTyCon :: TyCon-#if __GLASGOW_HASKELL__ < 704-apTTyCon = mkTyCon "Control.Applicative.Trans.Free.ApT"-apFTyCon = mkTyCon "Control.Applicative.Trans.Free.ApF"-#else-apTTyCon = mkTyCon3 "free" "Control.Applicative.Trans.Free" "ApT"-apFTyCon = mkTyCon3 "free" "Control.Applicative.Trans.Free" "ApF"-#endif-{-# NOINLINE apTTyCon #-}-{-# NOINLINE apFTyCon #-}-#endif
src/Control/Comonad/Cofree.hs view
@@ -1,12 +1,12 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE Rank2Types #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-#if __GLASGOW_HASKELL__ >= 707-{-# LANGUAGE DeriveDataTypeable #-}-#endif+{-# LANGUAGE Safe #-}+{-# LANGUAGE StandaloneDeriving #-}+ ----------------------------------------------------------------------------- -- | -- Module : Control.Comonad.Cofree@@ -25,12 +25,17 @@ , ComonadCofree(..) , section , coiter+ , coiterW , unfold+ , unfoldM , hoistCofree -- * Lenses into cofree comonads , _extract , _unwrap , telescoped+ , telescoped_+ , shoots+ , leaves ) where import Control.Applicative@@ -40,20 +45,25 @@ import Control.Comonad.Env.Class import Control.Comonad.Store.Class as Class import Control.Comonad.Traced.Class+import Control.Comonad.Hoist.Class import Control.Category-import Control.Monad(ap)+import Control.Monad(ap, (>=>), liftM) import Control.Monad.Zip import Data.Functor.Bind+import Data.Functor.Classes import Data.Functor.Extend+import Data.Functor.WithIndex import Data.Data import Data.Distributive import Data.Foldable+import Data.Foldable.WithIndex import Data.Semigroup import Data.Traversable+import Data.Traversable.WithIndex import Data.Semigroup.Foldable import Data.Semigroup.Traversable+import GHC.Generics hiding (Infix, Prefix) import Prelude hiding (id,(.))-import Prelude.Extras infixr 5 :<@@ -63,7 +73,7 @@ -- /Formally/ -- -- A 'Comonad' @v@ is a cofree 'Comonad' for @f@ if every comonad homomorphism--- another comonad @w@ to @v@ is equivalent to a natural transformation+-- from another comonad @w@ to @v@ is equivalent to a natural transformation -- from @w@ to @f@. -- -- A 'cofree' functor is right adjoint to a forgetful functor.@@ -80,7 +90,7 @@ -- -- For instance, ----- * @'Cofree' 'Maybe'@ forms the a comonad for a non-empty list.+-- * @'Cofree' 'Maybe'@ forms the comonad for a non-empty list. -- -- * @'Cofree' ('Const' b)@ is a product. --@@ -96,24 +106,32 @@ -- -- In particular, if @f a ≡ [a]@, the -- resulting data structure is a <https://en.wikipedia.org/wiki/Rose_tree Rose tree>.--- For a practical application, check --- <https://personal.cis.strath.ac.uk/neil.ghani/papers/ghani-calco07 Higher Dimensional Trees, Algebraically> by Neil Ghani et al.+-- For a practical application, check+-- <https://web.archive.org/web/20161208002902/http://www.cs.le.ac.uk/people/ak155/Papers/CALCO-07/GK07.pdf Higher Dimensional Trees, Algebraically> by Neil Ghani et al. data Cofree f a = a :< f (Cofree f a)-#if __GLASGOW_HASKELL__ >= 707- deriving (Typeable)-#endif+ deriving (Generic, Generic1) +deriving instance (Typeable f, Data (f (Cofree f a)), Data a) => Data (Cofree f a)+ -- | Use coiteration to generate a cofree comonad from a seed. -- -- @'coiter' f = 'unfold' ('id' 'Control.Arrow.&&&' f)@ coiter :: Functor f => (a -> f a) -> a -> Cofree f a coiter psi a = a :< (coiter psi <$> psi a) +-- | Like coiter for comonadic values.+coiterW :: (Comonad w, Functor f) => (w a -> f (w a)) -> w a -> Cofree f a+coiterW psi a = extract a :< (coiterW psi <$> psi a)+ -- | Unfold a cofree comonad from a seed. unfold :: Functor f => (b -> (a, f b)) -> b -> Cofree f a unfold f c = case f c of (x, d) -> x :< fmap (unfold f) d +-- | Unfold a cofree comonad from a seed, monadically.+unfoldM :: (Traversable f, Monad m) => (b -> m (a, f b)) -> b -> m (Cofree f a)+unfoldM f = f >=> \ (x, t) -> (x :<) `liftM` Data.Traversable.mapM (unfoldM f) t+ hoistCofree :: Functor f => (forall x . f x -> g x) -> Cofree f a -> Cofree g a hoistCofree f (x :< y) = x :< f (hoistCofree f <$> y) @@ -146,7 +164,7 @@ {-# INLINE lower #-} instance Alternative f => Monad (Cofree f) where- return x = x :< empty+ return = pure {-# INLINE return #-} (a :< m) >>= k = case k a of b :< n -> b :< (n <|> fmap (>>= k) m)@@ -177,59 +195,56 @@ {-# INLINE (@>) #-} instance Alternative f => Applicative (Cofree f) where- pure = return+ pure x = x :< empty {-# INLINE pure #-} (<*>) = ap {-# INLINE (<*>) #-} -instance (Functor f, Show1 f) => Show1 (Cofree f) where- showsPrec1 d (a :< as) = showParen (d > 5) $- showsPrec 6 a . showString " :< " . showsPrec1 5 (fmap Lift1 as)+instance (Show1 f) => Show1 (Cofree f) where+ liftShowsPrec sp sl = go+ where+ goList = liftShowList sp sl+ go d (a :< as) = showParen (d > 5) $+ sp 6 a . showString " :< " . liftShowsPrec go goList 5 as -instance (Show (f (Cofree f a)), Show a) => Show (Cofree f a) where- showsPrec d (a :< as) = showParen (d > 5) $- showsPrec 6 a . showString " :< " . showsPrec 5 as+instance (Show1 f, Show a) => Show (Cofree f a) where+ showsPrec = showsPrec1 -instance (Functor f, Read1 f) => Read1 (Cofree f) where- readsPrec1 d r = readParen (d > 5)- (\r' -> [(u :< fmap lower1 v,w) |- (u, s) <- readsPrec 6 r',- (":<", t) <- lex s,- (v, w) <- readsPrec1 5 t]) r+instance (Read1 f) => Read1 (Cofree f) where+ liftReadsPrec rp rl = go+ where+ goList = liftReadList rp rl+ go d r = readParen (d > 5)+ (\r' -> [(u :< v, w) |+ (u, s) <- rp 6 r',+ (":<", t) <- lex s,+ (v, w) <- liftReadsPrec go goList 5 t]) r -instance (Read (f (Cofree f a)), Read a) => Read (Cofree f a) where- readsPrec d r = readParen (d > 5)- (\r' -> [(u :< v,w) |- (u, s) <- readsPrec 6 r',- (":<", t) <- lex s,- (v, w) <- readsPrec 5 t]) r+instance (Read1 f, Read a) => Read (Cofree f a) where+ readsPrec = readsPrec1 -instance (Eq (f (Cofree f a)), Eq a) => Eq (Cofree f a) where-#ifndef HLINT- a :< as == b :< bs = a == b && as == bs-#endif+instance (Eq1 f, Eq a) => Eq (Cofree f a) where+ (==) = eq1 -instance (Functor f, Eq1 f) => Eq1 (Cofree f) where-#ifndef HLINT- a :< as ==# b :< bs = a == b && fmap Lift1 as ==# fmap Lift1 bs-#endif+instance (Eq1 f) => Eq1 (Cofree f) where+ liftEq eq = go+ where+ go (a :< as) (b :< bs) = eq a b && liftEq go as bs -instance (Ord (f (Cofree f a)), Ord a) => Ord (Cofree f a) where- compare (a :< as) (b :< bs) = case compare a b of- LT -> LT- EQ -> compare as bs- GT -> GT+instance (Ord1 f, Ord a) => Ord (Cofree f a) where+ compare = compare1 -instance (Functor f, Ord1 f) => Ord1 (Cofree f) where- compare1 (a :< as) (b :< bs) = case compare a b of- LT -> LT- EQ -> compare1 (fmap Lift1 as) (fmap Lift1 bs)- GT -> GT+instance (Ord1 f) => Ord1 (Cofree f) where+ liftCompare cmp = go+ where+ go (a :< as) (b :< bs) = cmp a b `mappend` liftCompare go as bs instance Foldable f => Foldable (Cofree f) where foldMap f = go where go (a :< as) = f a `mappend` foldMap go as {-# INLINE foldMap #-}+ length = go 0 where+ go s (_ :< as) = foldl' go (s + 1) as instance Foldable1 f => Foldable1 (Cofree f) where foldMap1 f = go where@@ -246,45 +261,20 @@ go (a :< as) = (:<) <$> f a <.> traverse1 go as {-# INLINE traverse1 #-} -#if __GLASGOW_HASKELL__ < 707-instance (Typeable1 f) => Typeable1 (Cofree f) where- typeOf1 dfa = mkTyConApp cofreeTyCon [typeOf1 (f dfa)]- where- f :: Cofree f a -> f a- f = undefined--instance (Typeable1 f, Typeable a) => Typeable (Cofree f a) where- typeOf = typeOfDefault--cofreeTyCon :: TyCon-#if __GLASGOW_HASKELL__ < 704-cofreeTyCon = mkTyCon "Control.Comonad.Cofree.Cofree"-#else-cofreeTyCon = mkTyCon3 "free" "Control.Comonad.Cofree" "Cofree"-#endif-{-# NOINLINE cofreeTyCon #-}+instance FunctorWithIndex i f => FunctorWithIndex [i] (Cofree f) where+ imap f (a :< as) = f [] a :< imap (\i -> imap (f . (:) i)) as+ {-# INLINE imap #-} -instance- ( Typeable1 f- , Data (f (Cofree f a))- , Data a- ) => Data (Cofree f a) where- gfoldl f z (a :< as) = z (:<) `f` a `f` as- toConstr _ = cofreeConstr- gunfold k z c = case constrIndex c of- 1 -> k (k (z (:<)))- _ -> error "gunfold"- dataTypeOf _ = cofreeDataType- dataCast1 f = gcast1 f+instance FoldableWithIndex i f => FoldableWithIndex [i] (Cofree f) where+ ifoldMap f (a :< as) = f [] a `mappend` ifoldMap (\i -> ifoldMap (f . (:) i)) as+ {-# INLINE ifoldMap #-} -cofreeConstr :: Constr-cofreeConstr = mkConstr cofreeDataType ":<" [] Infix-{-# NOINLINE cofreeConstr #-}+instance TraversableWithIndex i f => TraversableWithIndex [i] (Cofree f) where+ itraverse f (a :< as) = (:<) <$> f [] a <*> itraverse (\i -> itraverse (f . (:) i)) as+ {-# INLINE itraverse #-} -cofreeDataType :: DataType-cofreeDataType = mkDataType "Control.Comonad.Cofree.Cofree" [cofreeConstr]-{-# NOINLINE cofreeDataType #-}-#endif+instance ComonadHoist Cofree where+ cohoist = hoistCofree instance ComonadEnv e w => ComonadEnv e (Cofree w) where ask = ask . lower@@ -326,13 +316,85 @@ _unwrap f (a :< as) = (a :<) <$> f as {-# INLINE _unwrap #-} --- | Construct a @Lens@ into a @'Cofree' f@ given a list of lenses into the base functor.+-- | Construct an @Lens@ into a @'Cofree' g@ given a list of lenses into the base functor.+-- When the input list is empty, this is equivalent to '_extract'.+-- When the input list is non-empty, this composes the input lenses+-- with '_unwrap' to walk through the @'Cofree' g@ before using+-- '_extract' to get the element at the final location. -- -- For more on lenses see the 'lens' package on hackage. ----- @telescoped :: 'Functor' g => [Lens' ('Cofree' g a) (g ('Cofree' g a))] -> Lens' ('Cofree' g a) a@-telescoped :: (Functor f, Functor g) =>+-- @telescoped :: [Lens' (g ('Cofree' g a)) ('Cofree' g a)] -> Lens' ('Cofree' g a) a@+--+-- @telescoped :: [Traversal' (g ('Cofree' g a)) ('Cofree' g a)] -> Traversal' ('Cofree' g a) a@+--+-- @telescoped :: [Getter (g ('Cofree' g a)) ('Cofree' g a)] -> Getter ('Cofree' g a) a@+--+-- @telescoped :: [Fold (g ('Cofree' g a)) ('Cofree' g a)] -> Fold ('Cofree' g a) a@+--+-- @telescoped :: [Setter' (g ('Cofree' g a)) ('Cofree' g a)] -> Setter' ('Cofree' g a) a@+telescoped :: Functor f => [(Cofree g a -> f (Cofree g a)) -> g (Cofree g a) -> f (g (Cofree g a))] -> (a -> f a) -> Cofree g a -> f (Cofree g a) telescoped = Prelude.foldr (\l r -> _unwrap . l . r) _extract {-# INLINE telescoped #-}++-- not actually named 'eats'+-- | Construct an @Lens@ into a @'Cofree' g@ given a list of lenses into the base functor.+-- The only difference between this and 'telescoped' is that 'telescoped' focuses on a single value, but this focuses on the entire remaining subtree.+-- When the input list is empty, this is equivalent to 'id'.+-- When the input list is non-empty, this composes the input lenses+-- with '_unwrap' to walk through the @'Cofree' g@.+--+-- For more on lenses see the 'lens' package on hackage.+--+-- @telescoped :: [Lens' (g ('Cofree' g a)) ('Cofree' g a)] -> Lens' ('Cofree' g a) ('Cofree' g a)@+--+-- @telescoped :: [Traversal' (g ('Cofree' g a)) ('Cofree' g a)] -> Traversal' ('Cofree' g a) ('Cofree' g a)@+--+-- @telescoped :: [Getter (g ('Cofree' g a)) ('Cofree' g a)] -> Getter ('Cofree' g a) ('Cofree' g a)@+--+-- @telescoped :: [Fold (g ('Cofree' g a)) ('Cofree' g a)] -> Fold ('Cofree' g a) ('Cofree' g a)@+--+-- @telescoped :: [Setter' (g ('Cofree' g a)) ('Cofree' g a)] -> Setter' ('Cofree' g a) ('Cofree' g a)@+telescoped_ :: Functor f =>+ [(Cofree g a -> f (Cofree g a)) -> g (Cofree g a) -> f (g (Cofree g a))] ->+ (Cofree g a -> f (Cofree g a)) -> Cofree g a -> f (Cofree g a)+telescoped_ = Prelude.foldr (\l r -> _unwrap . l . r) id+{-# INLINE telescoped_ #-}++-- | A @Traversal'@ that gives access to all non-leaf @a@ elements of a+-- @'Cofree' g@ a, where non-leaf is defined as @x@ from @(x :< xs)@ where+-- @null xs@ is @False@.+--+-- Because this doesn't give access to all values in the @'Cofree' g@,+-- it cannot be used to change types.+--+-- @shoots :: Traversable g => Traversal' (Cofree g a) a@+--+-- N.B. On GHC < 7.9, this is slightly less flexible, as it has to+-- use @null (toList xs)@ instead.+shoots :: (Applicative f, Traversable g) => (a -> f a) -> Cofree g a -> f (Cofree g a)+shoots f = go+ where+ go xxs@(x :< xs) | null xs = pure xxs+ | otherwise = (:<) <$> f x <*> traverse go xs+{-# INLINE shoots #-}++-- | A @Traversal'@ that gives access to all leaf @a@ elements of a+-- @'Cofree' g@ a, where leaf is defined as @x@ from @(x :< xs)@ where+-- @null xs@ is @True@.+--+-- Because this doesn't give access to all values in the @'Cofree' g@,+-- it cannot be used to change types.+--+-- @shoots :: Traversable g => Traversal' (Cofree g a) a@+--+-- N.B. On GHC < 7.9, this is slightly less flexible, as it has to+-- use @null (toList xs)@ instead.+leaves :: (Applicative f, Traversable g) => (a -> f a) -> Cofree g a -> f (Cofree g a)+leaves f = go+ where+ go (x :< xs) | null xs = (:< xs) <$> f x+ | otherwise = (x :<) <$> traverse go xs+{-# INLINE leaves #-}
src/Control/Comonad/Cofree/Class.hs view
@@ -1,7 +1,9 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE Safe #-} {-# LANGUAGE UndecidableInstances #-}+ ----------------------------------------------------------------------------- -- | -- Module : Control.Comonad.Cofree.Class@@ -22,8 +24,8 @@ import Control.Comonad.Trans.Store import Control.Comonad.Trans.Traced import Control.Comonad.Trans.Identity-import Data.List.NonEmpty-import Data.Semigroup+import Data.List.NonEmpty (NonEmpty(..))+import Data.Tree -- | Allows you to peel a layer off a cofree comonad. class (Functor f, Comonad w) => ComonadCofree f w | w -> f where@@ -34,6 +36,9 @@ unwrap (_ :| []) = Nothing unwrap (_ :| (a : as)) = Just (a :| as) +instance ComonadCofree [] Tree where+ unwrap = subForest+ instance ComonadCofree (Const b) ((,) b) where unwrap = Const . fst @@ -46,5 +51,5 @@ instance ComonadCofree f w => ComonadCofree f (StoreT s w) where unwrap (StoreT wsa s) = flip StoreT s <$> unwrap wsa -instance (ComonadCofree f w, Semigroup m, Monoid m) => ComonadCofree f (TracedT m w) where+instance (ComonadCofree f w, Monoid m) => ComonadCofree f (TracedT m w) where unwrap (TracedT wma) = TracedT <$> unwrap wma
src/Control/Comonad/Trans/Cofree.hs view
@@ -1,11 +1,11 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-#if __GLASGOW_HASKELL__ >= 707-{-# LANGUAGE DeriveDataTypeable #-}-#endif+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE StandaloneDeriving #-} ----------------------------------------------------------------------------- -- |@@ -26,6 +26,7 @@ , ComonadCofree(..) , headF , tailF+ , transCofreeT , coiterT ) where @@ -33,30 +34,65 @@ import Control.Comonad import Control.Comonad.Trans.Class import Control.Comonad.Cofree.Class+import Control.Comonad.Env.Class+import Control.Comonad.Hoist.Class import Control.Category import Data.Bifunctor import Data.Bifoldable import Data.Bitraversable import Data.Foldable+import Data.Functor.Classes import Data.Functor.Identity-import Data.Semigroup import Data.Traversable import Control.Monad (liftM) import Control.Monad.Trans import Control.Monad.Zip import Prelude hiding (id,(.)) import Data.Data+import GHC.Generics hiding (Infix, Prefix) infixr 5 :< -- | This is the base functor of the cofree comonad transformer. data CofreeF f a b = a :< f b- deriving (Eq,Ord,Show,Read-#if __GLASGOW_HASKELL__ >= 707- ,Typeable-#endif- )+ deriving (Eq,Ord,Show,Read,Generic,Generic1) +instance Show1 f => Show2 (CofreeF f) where+ liftShowsPrec2 spa _sla spb slb d (a :< fb) =+ showParen (d > 5) $+ spa 6 a . showString " :< " . liftShowsPrec spb slb 6 fb++instance (Show1 f, Show a) => Show1 (CofreeF f a) where+ liftShowsPrec = liftShowsPrec2 showsPrec showList++instance Read1 f => Read2 (CofreeF f) where+ liftReadsPrec2 rpa _rla rpb rlb d =+ readParen (d > 5) $+ (\r' -> [ (u :< v, w)+ | (u, s) <- rpa 6 r'+ , (":<", t) <- lex s+ , (v, w) <- liftReadsPrec rpb rlb 6 t+ ])++instance (Read1 f, Read a) => Read1 (CofreeF f a) where+ liftReadsPrec = liftReadsPrec2 readsPrec readList++instance Eq1 f => Eq2 (CofreeF f) where+ liftEq2 eqa eqfb (a :< fb) (a' :< fb') = eqa a a' && liftEq eqfb fb fb'++instance (Eq1 f, Eq a) => Eq1 (CofreeF f a) where+ liftEq = liftEq2 (==)++instance Ord1 f => Ord2 (CofreeF f) where+ liftCompare2 cmpa cmpfb (a :< fb) (a' :< fb') =+ case cmpa a a' of+ LT -> LT+ EQ -> liftCompare cmpfb fb fb'+ GT -> GT++instance (Ord1 f, Ord a) => Ord1 (CofreeF f a) where+ liftCompare = liftCompare2 compare+ -- | Extract the head of the base functor headF :: CofreeF f a b -> a headF (a :< _) = a@@ -83,11 +119,12 @@ instance Traversable f => Bitraversable (CofreeF f) where bitraverse f g (a :< as) = (:<) <$> f a <*> traverse g as +transCofreeF :: (forall x. f x -> g x) -> CofreeF f a b -> CofreeF g a b+transCofreeF t (a :< fb) = a :< t fb+{-# INLINE transCofreeF #-}+ -- | This is a cofree comonad of some functor @f@, with a comonad @w@ threaded through it at each level. newtype CofreeT f w a = CofreeT { runCofreeT :: w (CofreeF f a (CofreeT f w a)) }-#if __GLASGOW_HASKELL__ >= 707- deriving Typeable-#endif -- | The cofree `Comonad` of a functor @f@. type Cofree f = CofreeT f Identity@@ -132,12 +169,19 @@ instance (Traversable f, Traversable w) => Traversable (CofreeT f w) where traverse f = fmap CofreeT . traverse (bitraverse f (traverse f)) . runCofreeT -instance Functor f => ComonadTrans (CofreeT f) where+instance ComonadTrans (CofreeT f) where lower = fmap headF . runCofreeT instance (Functor f, Comonad w) => ComonadCofree f (CofreeT f w) where unwrap = tailF . extract . runCofreeT +instance (Functor f, ComonadEnv e w) => ComonadEnv e (CofreeT f w) where+ ask = ask . lower+ {-# INLINE ask #-}++instance Functor f => ComonadHoist (CofreeT f) where+ cohoist g = CofreeT . fmap (second (cohoist g)) . g . runCofreeT+ instance Show (w (CofreeF f a (CofreeT f w a))) => Show (CofreeT f w a) where showsPrec d (CofreeT w) = showParen (d > 10) $ showString "CofreeT " . showsPrec 11 w@@ -153,8 +197,6 @@ compare (CofreeT a) (CofreeT b) = compare a b instance (Alternative f, Monad w) => Monad (CofreeT f w) where- return = CofreeT . return . (:< empty)- {-# INLINE return #-} CofreeT cx >>= f = CofreeT $ do a :< m <- cx b :< n <- runCofreeT $ f a@@ -177,75 +219,24 @@ (a :< fa, b :< fb) <- mzip ma mb return $ (a, b) :< (uncurry mzip <$> mzip fa fb) +-- | Lift a natural transformation from @f@ to @g@ into a comonad homomorphism from @'CofreeT' f w@ to @'CofreeT' g w@+transCofreeT :: (Functor g, Comonad w) => (forall x. f x -> g x) -> CofreeT f w a -> CofreeT g w a+transCofreeT t = CofreeT . liftW (fmap (transCofreeT t) . transCofreeF t) . runCofreeT+ -- | Unfold a @CofreeT@ comonad transformer from a coalgebra and an initial comonad. coiterT :: (Functor f, Comonad w) => (w a -> f (w a)) -> w a -> CofreeT f w a coiterT psi = CofreeT . extend (\w -> extract w :< fmap (coiterT psi) (psi w)) -#if __GLASGOW_HASKELL__ < 707--instance Typeable1 f => Typeable2 (CofreeF f) where- typeOf2 t = mkTyConApp cofreeFTyCon [typeOf1 (f t)] where- f :: CofreeF f a b -> f a- f = undefined--instance (Typeable1 f, Typeable1 w) => Typeable1 (CofreeT f w) where- typeOf1 t = mkTyConApp cofreeTTyCon [typeOf1 (f t), typeOf1 (w t)] where- f :: CofreeT f w a -> f a- f = undefined- w :: CofreeT f w a -> w a- w = undefined--cofreeFTyCon, cofreeTTyCon :: TyCon-#if __GLASGOW_HASKELL__ < 704-cofreeTTyCon = mkTyCon "Control.Comonad.Trans.Cofree.CofreeT"-cofreeFTyCon = mkTyCon "Control.Comonad.Trans.Cofree.CofreeF"-#else-cofreeTTyCon = mkTyCon3 "free" "Control.Comonad.Trans.Cofree" "CofreeT"-cofreeFTyCon = mkTyCon3 "free" "Control.Comonad.Trans.Cofree" "CofreeF"-#endif-{-# NOINLINE cofreeTTyCon #-}-{-# NOINLINE cofreeFTyCon #-}--#else-#define Typeable1 Typeable-#endif--instance- ( Typeable1 f, Typeable a, Typeable b+deriving instance+ ( Typeable f , Data a, Data (f b), Data b- ) => Data (CofreeF f a b) where- gfoldl f z (a :< as) = z (:<) `f` a `f` as- toConstr _ = cofreeFConstr- gunfold k z c = case constrIndex c of- 1 -> k (k (z (:<)))- _ -> error "gunfold"- dataTypeOf _ = cofreeFDataType- dataCast1 f = gcast1 f+ ) => Data (CofreeF f a b) -instance- ( Typeable1 f, Typeable1 w, Typeable a+deriving instance+ ( Typeable f, Typeable w , Data (w (CofreeF f a (CofreeT f w a))) , Data a- ) => Data (CofreeT f w a) where- gfoldl f z (CofreeT w) = z CofreeT `f` w- toConstr _ = cofreeTConstr- gunfold k z c = case constrIndex c of- 1 -> k (z CofreeT)- _ -> error "gunfold"- dataTypeOf _ = cofreeTDataType- dataCast1 f = gcast1 f--cofreeFConstr, cofreeTConstr :: Constr-cofreeFConstr = mkConstr cofreeFDataType ":<" [] Infix-cofreeTConstr = mkConstr cofreeTDataType "CofreeT" [] Prefix-{-# NOINLINE cofreeFConstr #-}-{-# NOINLINE cofreeTConstr #-}--cofreeFDataType, cofreeTDataType :: DataType-cofreeFDataType = mkDataType "Control.Comonad.Trans.Cofree.CofreeF" [cofreeFConstr]-cofreeTDataType = mkDataType "Control.Comonad.Trans.Cofree.CofreeT" [cofreeTConstr]-{-# NOINLINE cofreeFDataType #-}-{-# NOINLINE cofreeTDataType #-}+ ) => Data (CofreeT f w a) -- lowerF :: (Functor f, Comonad w) => CofreeT f w a -> f a -- lowerF = fmap extract . unwrap
src/Control/Comonad/Trans/Coiter.hs view
@@ -1,11 +1,9 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-#if __GLASGOW_HASKELL__ >= 707-{-# LANGUAGE DeriveDataTypeable #-}-#endif+{-# LANGUAGE Safe #-}+{-# LANGUAGE StandaloneDeriving #-} ----------------------------------------------------------------------------- -- |@@ -27,7 +25,7 @@ -- They are the dual notion of iterative monads. While iterative computations -- produce no values or eventually terminate with one, coiterative -- computations constantly produce values and they never terminate.- -- + -- -- It's simpler form, 'Coiter', is an infinite stream of data. 'CoiterT' -- extends this so that each step of the computation can be performed in -- a comonadic context.@@ -58,31 +56,39 @@ import Data.Bitraversable import Data.Data import Data.Foldable-import Data.Function (on)+import Data.Functor.Classes import Data.Functor.Identity import Data.Traversable import Prelude hiding (id,(.))-import Prelude.Extras -- | This is the coiterative comonad generated by a comonad newtype CoiterT w a = CoiterT { runCoiterT :: w (a, CoiterT w a) }-#if __GLASGOW_HASKELL__ >= 707- deriving Typeable-#endif -instance (Functor w, Eq1 w) => Eq1 (CoiterT w) where- (==#) = on (==#) (fmap (fmap Lift1) . runCoiterT)+instance (Eq1 w) => Eq1 (CoiterT w) where+ liftEq eq = go+ where+ go (CoiterT x) (CoiterT y) = liftEq (liftEq2 eq go) x y -instance (Functor w, Ord1 w) => Ord1 (CoiterT w) where- compare1 = on compare1 (fmap (fmap Lift1) . runCoiterT)+instance (Ord1 w) => Ord1 (CoiterT w) where+ liftCompare cmp = go+ where+ go (CoiterT x) (CoiterT y) = liftCompare (liftCompare2 cmp go) x y -instance (Functor w, Show1 w) => Show1 (CoiterT w) where- showsPrec1 d (CoiterT as) = showParen (d > 10) $- showString "CoiterT " . showsPrec1 11 (fmap (fmap Lift1) as)+instance (Show1 w) => Show1 (CoiterT w) where+ liftShowsPrec sp sl = go+ where+ goList = liftShowList sp sl+ go d (CoiterT x) = showsUnaryWith+ (liftShowsPrec (liftShowsPrec2 sp sl go goList) (liftShowList2 sp sl go goList))+ "CoiterT" d x -instance (Functor w, Read1 w) => Read1 (CoiterT w) where- readsPrec1 d = readParen (d > 10) $ \r ->- [ (CoiterT (fmap (fmap lower1) m),t) | ("CoiterT",s) <- lex r, (m,t) <- readsPrec1 11 s]+instance (Read1 w) => Read1 (CoiterT w) where+ liftReadsPrec rp rl = go+ where+ goList = liftReadList rp rl+ go = readsData $ readsUnaryWith+ (liftReadsPrec (liftReadsPrec2 rp rl go goList) (liftReadList2 rp rl go goList))+ "CoiterT" CoiterT -- | The coiterative comonad type Coiter = CoiterT Identity@@ -121,11 +127,11 @@ instance Comonad w => ComonadCofree Identity (CoiterT w) where unwrap = Identity . snd . extract . runCoiterT {-# INLINE unwrap #-}- + instance ComonadEnv e w => ComonadEnv e (CoiterT w) where ask = ask . lower {-# INLINE ask #-}- + instance ComonadHoist CoiterT where cohoist g = CoiterT . fmap (second (cohoist g)) . g . runCoiterT @@ -147,65 +153,29 @@ {-# INLINE seeks #-} {-# INLINE experiment #-} -instance Show (w (a, CoiterT w a)) => Show (CoiterT w a) where- showsPrec d w = showParen (d > 10) $- showString "CoiterT " . showsPrec 11 w+instance (Show1 w, Show a) => Show (CoiterT w a) where+ showsPrec = showsPrec1 -instance Read (w (a, CoiterT w a)) => Read (CoiterT w a) where- readsPrec d = readParen (d > 10) $ \r ->- [(CoiterT w, t) | ("CoiterT", s) <- lex r, (w, t) <- readsPrec 11 s]+instance (Read1 w, Read a) => Read (CoiterT w a) where+ readsPrec = readsPrec1 -instance Eq (w (a, CoiterT w a)) => Eq (CoiterT w a) where- CoiterT a == CoiterT b = a == b+instance (Eq1 w, Eq a) => Eq (CoiterT w a) where+ (==) = eq1 {-# INLINE (==) #-} -instance Ord (w (a, CoiterT w a)) => Ord (CoiterT w a) where- compare (CoiterT a) (CoiterT b) = compare a b+instance (Ord1 w, Ord a) => Ord (CoiterT w a) where+ compare = compare1 {-# INLINE compare #-} -- | Unfold a @CoiterT@ comonad transformer from a cokleisli arrow and an initial comonadic seed. unfold :: Comonad w => (w a -> a) -> w a -> CoiterT w a unfold psi = CoiterT . extend (extract &&& unfold psi . extend psi) -#if __GLASGOW_HASKELL__ < 707--instance Typeable1 w => Typeable1 (CoiterT w) where- typeOf1 t = mkTyConApp coiterTTyCon [typeOf1 (w t)] where- w :: CoiterT w a -> w a- w = undefined--coiterTTyCon :: TyCon-#if __GLASGOW_HASKELL__ < 704-coiterTTyCon = mkTyCon "Control.Comonad.Trans.Coiter.CoiterT"-#else-coiterTTyCon = mkTyCon3 "free" "Control.Comonad.Trans.Coiter" "CoiterT"-#endif-{-# NOINLINE coiterTTyCon #-}--#else-#define Typeable1 Typeable-#endif--instance- ( Typeable1 w, Typeable a+deriving instance+ ( Typeable w , Data (w (a, CoiterT w a)) , Data a- ) => Data (CoiterT w a) where- gfoldl f z (CoiterT w) = z CoiterT `f` w- toConstr _ = coiterTConstr- gunfold k z c = case constrIndex c of- 1 -> k (z CoiterT)- _ -> error "gunfold"- dataTypeOf _ = coiterTDataType- dataCast1 f = gcast1 f--coiterTConstr :: Constr-coiterTConstr = mkConstr coiterTDataType "CoiterT" [] Prefix-{-# NOINLINE coiterTConstr #-}--coiterTDataType :: DataType-coiterTDataType = mkDataType "Control.Comonad.Trans.Coiter.CoiterT" [coiterTConstr]-{-# NOINLINE coiterTDataType #-}+ ) => Data (CoiterT w a) {- $example
src/Control/Monad/Free.hs view
@@ -1,15 +1,12 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Rank2Types #-}-#if __GLASGOW_HASKELL__ >= 707-{-# LANGUAGE DeriveDataTypeable #-}-#endif-#ifndef MIN_VERSION_base-#define MIN_VERSION_base(x,y,z) 1-#endif+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE Safe #-}+ ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.Free@@ -28,16 +25,20 @@ , retract , liftF , iter+ , iterA , iterM , hoistFree , foldFree , toFreeT , cutoff+ , unfold+ , unfoldM , _Pure, _Free ) where import Control.Applicative-import Control.Monad (liftM, MonadPlus(..))+import Control.Arrow ((>>>))+import Control.Monad (liftM, MonadPlus(..), (>=>)) import Control.Monad.Fix import Control.Monad.Trans.Class import qualified Control.Monad.Trans.Free as FreeT@@ -48,15 +49,27 @@ import Control.Monad.Error.Class import Control.Monad.Cont.Class import Data.Functor.Bind+import Data.Functor.Classes+import Data.Functor.WithIndex import Data.Foldable+import Data.Foldable.WithIndex import Data.Profunctor import Data.Traversable+import Data.Traversable.WithIndex import Data.Semigroup.Foldable import Data.Semigroup.Traversable import Data.Data+import GHC.Generics import Prelude hiding (foldr)-import Prelude.Extras +-- $setup+-- >>> import Control.Applicative (Const (..))+-- >>> import Data.Functor.Identity (Identity (..))+-- >>> import Data.Monoid (First (..))+-- >>> import Data.Tagged (Tagged (..))+-- >>> let preview l x = getFirst (getConst (l (Const . First . Just) x))+-- >>> let review l x = runIdentity (unTagged (l (Tagged (Identity x))))+ -- | The 'Free' 'Monad' for a 'Functor' @f@. -- -- /Formally/@@ -76,7 +89,7 @@ -- -- then 'Free' is the left adjoint to @U@. ----- Being 'Free' being left adjoint to @U@ means that there is an isomorphism between+-- 'Free' being left adjoint to @U@ means that there is an isomorphism between -- -- @'Free' f -> m@ in the category of monads and @f -> U m@ in the category of functors. --@@ -102,64 +115,50 @@ -- -- * @'Free' 'Maybe'@ can be used to model a partiality monad where each layer represents running the computation for a while longer. data Free f a = Pure a | Free (f (Free f a))-#if __GLASGOW_HASKELL__ >= 707- deriving (Typeable)-#endif+ deriving (Generic, Generic1) -instance (Functor f, Eq1 f) => Eq1 (Free f) where- Pure a ==# Pure b = a == b- Free fa ==# Free fb = fmap Lift1 fa ==# fmap Lift1 fb- _ ==# _ = False+deriving instance (Typeable f, Data (f (Free f a)), Data a) => Data (Free f a) -instance (Eq (f (Free f a)), Eq a) => Eq (Free f a) where- Pure a == Pure b = a == b- Free fa == Free fb = fa == fb- _ == _ = False+instance Eq1 f => Eq1 (Free f) where+ liftEq eq = go+ where+ go (Pure a) (Pure b) = eq a b+ go (Free fa) (Free fb) = liftEq go fa fb+ go _ _ = False -instance (Functor f, Ord1 f) => Ord1 (Free f) where- Pure a `compare1` Pure b = a `compare` b- Pure _ `compare1` Free _ = LT- Free _ `compare1` Pure _ = GT- Free fa `compare1` Free fb = fmap Lift1 fa `compare1` fmap Lift1 fb+instance (Eq1 f, Eq a) => Eq (Free f a) where+ (==) = eq1 -instance (Ord (f (Free f a)), Ord a) => Ord (Free f a) where- Pure a `compare` Pure b = a `compare` b- Pure _ `compare` Free _ = LT- Free _ `compare` Pure _ = GT- Free fa `compare` Free fb = fa `compare` fb+instance Ord1 f => Ord1 (Free f) where+ liftCompare cmp = go+ where+ go (Pure a) (Pure b) = cmp a b+ go (Pure _) (Free _) = LT+ go (Free _) (Pure _) = GT+ go (Free fa) (Free fb) = liftCompare go fa fb -instance (Functor f, Show1 f) => Show1 (Free f) where- showsPrec1 d (Pure a) = showParen (d > 10) $- showString "Pure " . showsPrec 11 a- showsPrec1 d (Free m) = showParen (d > 10) $- showString "Free " . showsPrec1 11 (fmap Lift1 m)+instance (Ord1 f, Ord a) => Ord (Free f a) where+ compare = compare1 -instance (Show (f (Free f a)), Show a) => Show (Free f a) where- showsPrec d (Pure a) = showParen (d > 10) $- showString "Pure " . showsPrec 11 a- showsPrec d (Free m) = showParen (d > 10) $- showString "Free " . showsPrec 11 m+instance Show1 f => Show1 (Free f) where+ liftShowsPrec sp sl = go+ where+ go d (Pure a) = showsUnaryWith sp "Pure" d a+ go d (Free fa) = showsUnaryWith (liftShowsPrec go (liftShowList sp sl)) "Free" d fa -instance (Functor f, Read1 f) => Read1 (Free f) where- readsPrec1 d r = readParen (d > 10)- (\r' -> [ (Pure m, t)- | ("Pure", s) <- lex r'- , (m, t) <- readsPrec 11 s]) r- ++ readParen (d > 10)- (\r' -> [ (Free (fmap lower1 m), t)- | ("Free", s) <- lex r'- , (m, t) <- readsPrec1 11 s]) r+instance (Show1 f, Show a) => Show (Free f a) where+ showsPrec = showsPrec1 -instance (Read (f (Free f a)), Read a) => Read (Free f a) where- readsPrec d r = readParen (d > 10)- (\r' -> [ (Pure m, t)- | ("Pure", s) <- lex r'- , (m, t) <- readsPrec 11 s]) r- ++ readParen (d > 10)- (\r' -> [ (Free m, t)- | ("Free", s) <- lex r'- , (m, t) <- readsPrec 11 s]) r+instance Read1 f => Read1 (Free f) where+ liftReadsPrec rp rl = go+ where+ go = readsData $+ readsUnaryWith rp "Pure" Pure `mappend`+ readsUnaryWith (liftReadsPrec go (liftReadList rp rl)) "Free" Free +instance (Read1 f, Read a) => Read (Free f a) where+ readsPrec = readsPrec1+ instance Functor f => Functor (Free f) where fmap f = go where go (Pure a) = Pure (f a)@@ -183,7 +182,7 @@ Free m >>- f = Free ((>>- f) <$> m) instance Functor f => Monad (Free f) where- return = Pure+ return = pure {-# INLINE return #-} Pure a >>= f = f a Free m >>= f = Free ((>>= f) <$> m)@@ -199,7 +198,7 @@ {-# INLINE (<|>) #-} -- | This violates the MonadPlus laws, handle with care.-instance (Functor v, MonadPlus v) => MonadPlus (Free v) where+instance MonadPlus v => MonadPlus (Free v) where mzero = Free mzero {-# INLINE mzero #-} a `mplus` b = Free (return a `mplus` return b)@@ -223,14 +222,12 @@ Free fa -> foldr (flip go) r fa {-# INLINE foldr #-} -#if MIN_VERSION_base(4,6,0) foldl' f = go where go r free = case free of Pure a -> f r a Free fa -> foldl' go r fa {-# INLINE foldl' #-}-#endif instance Foldable1 f => Foldable1 (Free f) where foldMap1 f = go where@@ -250,7 +247,22 @@ go (Free fa) = Free <$> traverse1 go fa {-# INLINE traverse1 #-} -instance (Functor m, MonadWriter e m) => MonadWriter e (Free m) where+instance FunctorWithIndex i f => FunctorWithIndex [i] (Free f) where+ imap f (Pure a) = Pure $ f [] a+ imap f (Free s) = Free $ imap (\i -> imap (f . (:) i)) s+ {-# INLINE imap #-}++instance FoldableWithIndex i f => FoldableWithIndex [i] (Free f) where+ ifoldMap f (Pure a) = f [] a+ ifoldMap f (Free s) = ifoldMap (\i -> ifoldMap (f . (:) i)) s+ {-# INLINE ifoldMap #-}++instance TraversableWithIndex i f => TraversableWithIndex [i] (Free f) where+ itraverse f (Pure a) = Pure <$> f [] a+ itraverse f (Free s) = Free <$> itraverse (\i -> itraverse (f . (:) i)) s+ {-# INLINE itraverse #-}++instance MonadWriter e m => MonadWriter e (Free m) where tell = lift . tell {-# INLINE tell #-} listen = lift . listen . retract@@ -258,25 +270,25 @@ pass = lift . pass . retract {-# INLINE pass #-} -instance (Functor m, MonadReader e m) => MonadReader e (Free m) where+instance MonadReader e m => MonadReader e (Free m) where ask = lift ask {-# INLINE ask #-} local f = lift . local f . retract {-# INLINE local #-} -instance (Functor m, MonadState s m) => MonadState s (Free m) where+instance MonadState s m => MonadState s (Free m) where get = lift get {-# INLINE get #-} put s = lift (put s) {-# INLINE put #-} -instance (Functor m, MonadError e m) => MonadError e (Free m) where+instance MonadError e m => MonadError e (Free m) where throwError = lift . throwError {-# INLINE throwError #-} catchError as f = lift (catchError (retract as) (retract . f)) {-# INLINE catchError #-} -instance (Functor m, MonadCont m) => MonadCont (Free m) where+instance MonadCont m => MonadCont (Free m) where callCC f = lift (callCC (retract . f . liftM lift)) {-# INLINE callCC #-} @@ -300,18 +312,23 @@ iter _ (Pure a) = a iter phi (Free m) = phi (iter phi <$> m) --- | Like iter for monadic values.+-- | Like 'iter' for applicative values.+iterA :: (Applicative p, Functor f) => (f (p a) -> p a) -> Free f a -> p a+iterA _ (Pure x) = pure x+iterA phi (Free f) = phi (iterA phi <$> f)++-- | Like 'iter' for monadic values. iterM :: (Monad m, Functor f) => (f (m a) -> m a) -> Free f a -> m a iterM _ (Pure x) = return x-iterM phi (Free f) = phi $ fmap (iterM phi) f+iterM phi (Free f) = phi (iterM phi <$> f) --- | Lift a natural transformation from @f@ to @g@ into a natural transformation from @'FreeT' f@ to @'FreeT' g@.+-- | Lift a natural transformation from @f@ to @g@ into a natural transformation from @'Free' f@ to @'Free' g@. hoistFree :: Functor g => (forall a. f a -> g a) -> Free f b -> Free g b hoistFree _ (Pure a) = Pure a hoistFree f (Free as) = Free (hoistFree f <$> f as) --- | The very definition of a free monoid is that given a natural transformation you get a monoid homomorphism.-foldFree :: (Functor m, Monad m) => (forall x . f x -> m x) -> Free f a -> m a+-- | The very definition of a free monad is that given a natural transformation you get a monad homomorphism.+foldFree :: Monad m => (forall x . f x -> m x) -> Free f a -> m a foldFree _ (Pure a) = return a foldFree f (Free as) = f as >>= foldFree f @@ -332,13 +349,21 @@ -- prop> cutoff (n+1) . lift == lift . liftM Just -- prop> cutoff (n+1) . wrap == wrap . fmap (cutoff n) ----- Calling 'retract . cutoff n' is always terminating, provided each of the+-- Calling @'retract' '.' 'cutoff' n@ is always terminating, provided each of the -- steps in the iteration is terminating. cutoff :: (Functor f) => Integer -> Free f a -> Free f (Maybe a) cutoff n _ | n <= 0 = return Nothing cutoff n (Free f) = Free $ fmap (cutoff (n - 1)) f cutoff _ m = Just <$> m +-- | Unfold a free monad from a seed.+unfold :: Functor f => (b -> Either a (f b)) -> b -> Free f a+unfold f = f >>> either Pure (Free . fmap (unfold f))++-- | Unfold a free monad from a seed, monadically.+unfoldM :: (Traversable f, Monad m) => (b -> m (Either a (f b))) -> b -> m (Free f a)+unfoldM f = f >=> either (pure . pure) (fmap Free . traverse (unfoldM f))+ -- | This is @Prism' (Free f a) a@ in disguise -- -- >>> preview _Pure (Pure 3)@@ -355,60 +380,18 @@ {-# INLINE impure #-} {-# INLINE _Pure #-} --- | This is @Prism' (Free f a) (f (Free f a))@ in disguise+-- | This is @Prism (Free f a) (Free g a) (f (Free f a)) (g (Free g a))@ in disguise -- -- >>> preview _Free (review _Free (Just (Pure 3))) -- Just (Just (Pure 3)) -- -- >>> review _Free (Just (Pure 3)) -- Free (Just (Pure 3))-_Free :: forall f m a p. (Choice p, Applicative m)- => p (f (Free f a)) (m (f (Free f a))) -> p (Free f a) (m (Free f a))+_Free :: forall f g m a p. (Choice p, Applicative m)+ => p (f (Free f a)) (m (g (Free g a))) -> p (Free f a) (m (Free g a)) _Free = dimap unfree (either pure (fmap Free)) . right' where unfree (Free x) = Right x- unfree x = Left x+ unfree (Pure x) = Left (Pure x) {-# INLINE unfree #-} {-# INLINE _Free #-}---#if __GLASGOW_HASKELL__ < 707-instance Typeable1 f => Typeable1 (Free f) where- typeOf1 t = mkTyConApp freeTyCon [typeOf1 (f t)] where- f :: Free f a -> f a- f = undefined--freeTyCon :: TyCon-#if __GLASGOW_HASKELL__ < 704-freeTyCon = mkTyCon "Control.Monad.Free.Free"-#else-freeTyCon = mkTyCon3 "free" "Control.Monad.Free" "Free"-#endif-{-# NOINLINE freeTyCon #-}--instance- ( Typeable1 f, Typeable a- , Data a, Data (f (Free f a))- ) => Data (Free f a) where- gfoldl f z (Pure a) = z Pure `f` a- gfoldl f z (Free as) = z Free `f` as- toConstr Pure{} = pureConstr- toConstr Free{} = freeConstr- gunfold k z c = case constrIndex c of- 1 -> k (z Pure)- 2 -> k (z Free)- _ -> error "gunfold"- dataTypeOf _ = freeDataType- dataCast1 f = gcast1 f--pureConstr, freeConstr :: Constr-pureConstr = mkConstr freeDataType "Pure" [] Prefix-freeConstr = mkConstr freeDataType "Free" [] Prefix-{-# NOINLINE pureConstr #-}-{-# NOINLINE freeConstr #-}--freeDataType :: DataType-freeDataType = mkDataType "Control.Monad.Free.FreeF" [pureConstr, freeConstr]-{-# NOINLINE freeDataType #-}--#endif
+ src/Control/Monad/Free/Ap.hs view
@@ -0,0 +1,349 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE StandaloneDeriving #-}++--------------------------------------------------------------------------------+-- |+-- \"Applicative Effects in Free Monads\"+--+-- Often times, the '(\<*\>)' operator can be more efficient than 'ap'.+-- Conventional free monads don't provide any means of modeling this.+-- The free monad can be modified to make use of an underlying applicative.+-- But it does require some laws, or else the '(\<*\>)' = 'ap' law is broken.+-- When interpreting this free monad with 'foldFree',+-- the natural transformation must be an applicative homomorphism.+-- An applicative homomorphism @hm :: (Applicative f, Applicative g) => f x -> g x@+-- will satisfy these laws.+--+-- * @hm (pure a) = pure a@+-- * @hm (f \<*\> a) = hm f \<*\> hm a@+--+-- This is based on the \"Applicative Effects in Free Monads\" series of articles by Will Fancher+--+-- * <http://elvishjerricco.github.io/2016/04/08/applicative-effects-in-free-monads.html Applicative Effects in Free Monads>+--+-- * <http://elvishjerricco.github.io/2016/04/13/more-on-applicative-effects-in-free-monads.html More on Applicative Effects in Free Monads>+--------------------------------------------------------------------------------+module Control.Monad.Free.Ap+ ( MonadFree(..)+ , Free(..)+ , retract+ , liftF+ , iter+ , iterA+ , iterM+ , hoistFree+ , foldFree+ , toFreeT+ , cutoff+ , unfold+ , unfoldM+ , _Pure, _Free+ ) where++import Control.Applicative+import Control.Arrow ((>>>))+import Control.Monad (liftM, MonadPlus(..), (>=>))+import Control.Monad.Fix+import Control.Monad.Trans.Class+import qualified Control.Monad.Trans.Free.Ap as FreeT+import Control.Monad.Free.Class+import Control.Monad.Reader.Class+import Control.Monad.Writer.Class+import Control.Monad.State.Class+import Control.Monad.Error.Class+import Control.Monad.Cont.Class+import Data.Functor.Bind+import Data.Functor.Classes+import Data.Foldable+import Data.Profunctor+import Data.Traversable+import Data.Semigroup.Foldable+import Data.Semigroup.Traversable+import Data.Data+import GHC.Generics+import Prelude hiding (foldr)++-- $setup+-- >>> import Control.Applicative (Const (..))+-- >>> import Data.Functor.Identity (Identity (..))+-- >>> import Data.Monoid (First (..))+-- >>> import Data.Tagged (Tagged (..))+-- >>> let preview l x = getFirst (getConst (l (Const . First . Just) x))+-- >>> let review l x = runIdentity (unTagged (l (Tagged (Identity x))))++-- | A free monad given an applicative+data Free f a = Pure a | Free (f (Free f a))+ deriving (Generic, Generic1)++deriving instance+ ( Typeable f+ , Data a, Data (f (Free f a))+ ) => Data (Free f a)++instance Eq1 f => Eq1 (Free f) where+ liftEq eq = go+ where+ go (Pure a) (Pure b) = eq a b+ go (Free fa) (Free fb) = liftEq go fa fb+ go _ _ = False++instance (Eq1 f, Eq a) => Eq (Free f a) where+ (==) = eq1++instance Ord1 f => Ord1 (Free f) where+ liftCompare cmp = go+ where+ go (Pure a) (Pure b) = cmp a b+ go (Pure _) (Free _) = LT+ go (Free _) (Pure _) = GT+ go (Free fa) (Free fb) = liftCompare go fa fb++instance (Ord1 f, Ord a) => Ord (Free f a) where+ compare = compare1++instance Show1 f => Show1 (Free f) where+ liftShowsPrec sp sl = go+ where+ go d (Pure a) = showsUnaryWith sp "Pure" d a+ go d (Free fa) = showsUnaryWith (liftShowsPrec go (liftShowList sp sl)) "Free" d fa++instance (Show1 f, Show a) => Show (Free f a) where+ showsPrec = showsPrec1++instance Read1 f => Read1 (Free f) where+ liftReadsPrec rp rl = go+ where+ go = readsData $+ readsUnaryWith rp "Pure" Pure `mappend`+ readsUnaryWith (liftReadsPrec go (liftReadList rp rl)) "Free" Free++instance (Read1 f, Read a) => Read (Free f a) where+ readsPrec = readsPrec1++instance Functor f => Functor (Free f) where+ fmap f = go where+ go (Pure a) = Pure (f a)+ go (Free fa) = Free (go <$> fa)+ {-# INLINE fmap #-}++instance Apply f => Apply (Free f) where+ Pure a <.> Pure b = Pure (a b)+ Pure a <.> Free fb = Free $ fmap a <$> fb+ Free fa <.> Pure b = Free $ fmap ($ b) <$> fa+ Free fa <.> Free fb = Free $ fmap (<.>) fa <.> fb++instance Applicative f => Applicative (Free f) where+ pure = Pure+ {-# INLINE pure #-}+ Pure a <*> Pure b = Pure $ a b+ Pure a <*> Free mb = Free $ fmap a <$> mb+ Free ma <*> Pure b = Free $ fmap ($ b) <$> ma+ Free ma <*> Free mb = Free $ fmap (<*>) ma <*> mb++instance Apply f => Bind (Free f) where+ Pure a >>- f = f a+ Free m >>- f = Free ((>>- f) <$> m)++instance Applicative f => Monad (Free f) where+ return = pure+ {-# INLINE return #-}+ Pure a >>= f = f a+ Free m >>= f = Free ((>>= f) <$> m)++instance Applicative f => MonadFix (Free f) where+ mfix f = a where a = f (impure a); impure (Pure x) = x; impure (Free _) = error "mfix (Free f): Free"++-- | This violates the Alternative laws, handle with care.+instance Alternative v => Alternative (Free v) where+ empty = Free empty+ {-# INLINE empty #-}+ a <|> b = Free (pure a <|> pure b)+ {-# INLINE (<|>) #-}++-- | This violates the MonadPlus laws, handle with care.+instance MonadPlus v => MonadPlus (Free v) where+ mzero = Free mzero+ {-# INLINE mzero #-}+ a `mplus` b = Free (return a `mplus` return b)+ {-# INLINE mplus #-}++-- | This is not a true monad transformer. It is only a monad transformer \"up to 'retract'\".+instance MonadTrans Free where+ lift = Free . liftM Pure+ {-# INLINE lift #-}++instance Foldable f => Foldable (Free f) where+ foldMap f = go where+ go (Pure a) = f a+ go (Free fa) = foldMap go fa+ {-# INLINE foldMap #-}++ foldr f = go where+ go r free =+ case free of+ Pure a -> f a r+ Free fa -> foldr (flip go) r fa+ {-# INLINE foldr #-}++ foldl' f = go where+ go r free =+ case free of+ Pure a -> f r a+ Free fa -> foldl' go r fa+ {-# INLINE foldl' #-}++instance Foldable1 f => Foldable1 (Free f) where+ foldMap1 f = go where+ go (Pure a) = f a+ go (Free fa) = foldMap1 go fa+ {-# INLINE foldMap1 #-}++instance Traversable f => Traversable (Free f) where+ traverse f = go where+ go (Pure a) = Pure <$> f a+ go (Free fa) = Free <$> traverse go fa+ {-# INLINE traverse #-}++instance Traversable1 f => Traversable1 (Free f) where+ traverse1 f = go where+ go (Pure a) = Pure <$> f a+ go (Free fa) = Free <$> traverse1 go fa+ {-# INLINE traverse1 #-}++instance MonadWriter e m => MonadWriter e (Free m) where+ tell = lift . tell+ {-# INLINE tell #-}+ listen = lift . listen . retract+ {-# INLINE listen #-}+ pass = lift . pass . retract+ {-# INLINE pass #-}++instance MonadReader e m => MonadReader e (Free m) where+ ask = lift ask+ {-# INLINE ask #-}+ local f = lift . local f . retract+ {-# INLINE local #-}++instance MonadState s m => MonadState s (Free m) where+ get = lift get+ {-# INLINE get #-}+ put s = lift (put s)+ {-# INLINE put #-}++instance MonadError e m => MonadError e (Free m) where+ throwError = lift . throwError+ {-# INLINE throwError #-}+ catchError as f = lift (catchError (retract as) (retract . f))+ {-# INLINE catchError #-}++instance MonadCont m => MonadCont (Free m) where+ callCC f = lift (callCC (retract . f . liftM lift))+ {-# INLINE callCC #-}++instance Applicative f => MonadFree f (Free f) where+ wrap = Free+ {-# INLINE wrap #-}++-- |+-- 'retract' is the left inverse of 'lift' and 'liftF'+--+-- @+-- 'retract' . 'lift' = 'id'+-- 'retract' . 'liftF' = 'id'+-- @+retract :: Monad f => Free f a -> f a+retract = foldFree id++-- | Given an applicative homomorphism from @f@ to 'Identity', tear down a 'Free' 'Monad' using iteration.+iter :: Applicative f => (f a -> a) -> Free f a -> a+iter _ (Pure a) = a+iter phi (Free m) = phi (iter phi <$> m)++-- | Like 'iter' for applicative values.+iterA :: (Applicative p, Applicative f) => (f (p a) -> p a) -> Free f a -> p a+iterA _ (Pure x) = pure x+iterA phi (Free f) = phi (iterA phi <$> f)++-- | Like 'iter' for monadic values.+iterM :: (Monad m, Applicative f) => (f (m a) -> m a) -> Free f a -> m a+iterM _ (Pure x) = return x+iterM phi (Free f) = phi (iterM phi <$> f)++-- | Lift an applicative homomorphism from @f@ to @g@ into a monad homomorphism from @'Free' f@ to @'Free' g@.+hoistFree :: (Applicative f, Applicative g) => (forall a. f a -> g a) -> Free f b -> Free g b+hoistFree f = foldFree (liftF . f)++-- | Given an applicative homomorphism, you get a monad homomorphism.+foldFree :: (Applicative f, Monad m) => (forall x . f x -> m x) -> Free f a -> m a+foldFree _ (Pure a) = return a+foldFree f (Free as) = f as >>= foldFree f++-- | Convert a 'Free' monad from "Control.Monad.Free.Ap" to a 'FreeT.FreeT' monad+-- from "Control.Monad.Trans.Free.Ap".+-- WARNING: This assumes that 'liftF' is an applicative homomorphism.+toFreeT :: (Applicative f, Monad m) => Free f a -> FreeT.FreeT f m a+toFreeT = foldFree liftF++-- | Cuts off a tree of computations at a given depth.+-- If the depth is 0 or less, no computation nor+-- monadic effects will take place.+--+-- Some examples (n ≥ 0):+--+-- prop> cutoff 0 _ == return Nothing+-- prop> cutoff (n+1) . return == return . Just+-- prop> cutoff (n+1) . lift == lift . liftM Just+-- prop> cutoff (n+1) . wrap == wrap . fmap (cutoff n)+--+-- Calling 'retract . cutoff n' is always terminating, provided each of the+-- steps in the iteration is terminating.+cutoff :: (Applicative f) => Integer -> Free f a -> Free f (Maybe a)+cutoff n _ | n <= 0 = return Nothing+cutoff n (Free f) = Free $ fmap (cutoff (n - 1)) f+cutoff _ m = Just <$> m++-- | Unfold a free monad from a seed.+unfold :: Applicative f => (b -> Either a (f b)) -> b -> Free f a+unfold f = f >>> either Pure (Free . fmap (unfold f))++-- | Unfold a free monad from a seed, monadically.+unfoldM :: (Applicative f, Traversable f, Monad m) => (b -> m (Either a (f b))) -> b -> m (Free f a)+unfoldM f = f >=> either (pure . pure) (fmap Free . traverse (unfoldM f))++-- | This is @Prism' (Free f a) a@ in disguise+--+-- >>> preview _Pure (Pure 3)+-- Just 3+--+-- >>> review _Pure 3 :: Free Maybe Int+-- Pure 3+_Pure :: forall f m a p. (Choice p, Applicative m)+ => p a (m a) -> p (Free f a) (m (Free f a))+_Pure = dimap impure (either pure (fmap Pure)) . right'+ where+ impure (Pure x) = Right x+ impure x = Left x+ {-# INLINE impure #-}+{-# INLINE _Pure #-}++-- | This is @Prism' (Free f a) (f (Free f a))@ in disguise+--+-- >>> preview _Free (review _Free (Just (Pure 3)))+-- Just (Just (Pure 3))+--+-- >>> review _Free (Just (Pure 3))+-- Free (Just (Pure 3))+_Free :: forall f m a p. (Choice p, Applicative m)+ => p (f (Free f a)) (m (f (Free f a))) -> p (Free f a) (m (Free f a))+_Free = dimap unfree (either pure (fmap Free)) . right'+ where+ unfree (Free x) = Right x+ unfree x = Left x+ {-# INLINE unfree #-}+{-# INLINE _Free #-}
src/Control/Monad/Free/Church.hs view
@@ -1,12 +1,10 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-#ifndef MIN_VERSION_base-#define MIN_VERSION_base(x,y,z) 1-#endif+{-# LANGUAGE Safe #-}+ ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.Free.Church@@ -48,14 +46,15 @@ -- -- This is based on the \"Free Monads for Less\" series of articles by Edward Kmett: ----- * <http://comonad.com/reader/2011/free-monads-for-less/ Free monads for less — Part 1>+-- * <https://ekmett.github.io/reader/2011/free-monads-for-less/ Free monads for less — Part 1> ----- * <http://comonad.com/reader/2011/free-monads-for-less-2/ Free monads for less — Part 2>+-- * <https://ekmett.github.io/reader/2011/free-monads-for-less-2/ Free monads for less — Part 2> ---------------------------------------------------------------------------- module Control.Monad.Free.Church ( F(..) , improve , fromF+ , iter , iterM , toF , retract@@ -69,26 +68,32 @@ import Control.Applicative import Control.Monad as Monad import Control.Monad.Fix-import Control.Monad.Free hiding (retract, iterM, cutoff)-import qualified Control.Monad.Free as Free+import Control.Monad.Free hiding (retract, iter, iterM, cutoff) import Control.Monad.Reader.Class import Control.Monad.Writer.Class import Control.Monad.Cont.Class import Control.Monad.Trans.Class import Control.Monad.State.Class import Data.Foldable+import Data.Traversable import Data.Functor.Bind+import Data.Semigroup.Foldable+import Data.Semigroup.Traversable import Prelude hiding (foldr) -- | The Church-encoded free monad for a functor @f@. -- -- It is /asymptotically/ more efficient to use ('>>=') for 'F' than it is to ('>>=') with 'Free'. ----- <http://comonad.com/reader/2011/free-monads-for-less-2/>+-- <https://ekmett.github.io/reader/2011/free-monads-for-less-2/> newtype F f a = F { runF :: forall r. (a -> r) -> (f r -> r) -> r } +-- | Tear down a 'Free' 'Monad' using iteration.+iter :: (f a -> a) -> F f a -> a+iter phi xs = runF xs id phi+ -- | Like iter for monadic values.-iterM :: (Monad m, Functor f) => (f (m a) -> m a) -> F f a -> m a+iterM :: Monad m => (f (m a) -> m a) -> F f a -> m a iterM phi xs = runF xs return phi instance Functor (F f) where@@ -110,7 +115,7 @@ (>>-) = (>>=) instance Monad (F f) where- return a = F (\kp _ -> kp a)+ return = pure F m >>= f = F (\kp kf -> m (\a -> runF (f a) kp kf) kf) instance MonadFix (F f) where@@ -118,15 +123,26 @@ a = f (impure a) impure (F x) = x id (error "MonadFix (F f): wrap") -instance (Foldable f, Functor f) => Foldable (F f) where+instance Foldable f => Foldable (F f) where+ foldMap f xs = runF xs f fold+ {-# INLINE foldMap #-}+ foldr f r xs = runF xs f (foldr (.) id) r {-# INLINE foldr #-} -#if MIN_VERSION_base(4,6,0) foldl' f z xs = runF xs (\a !r -> f r a) (flip $ foldl' $ \r g -> g r) z {-# INLINE foldl' #-}-#endif +instance Traversable f => Traversable (F f) where+ traverse f m = runF m (fmap return . f) (fmap wrap . sequenceA)+ {-# INLINE traverse #-}++instance Foldable1 f => Foldable1 (F f) where+ foldMap1 f m = runF m f fold1++instance Traversable1 f => Traversable1 (F f) where+ traverse1 f m = runF m (fmap return . f) (fmap wrap . sequence1)+ -- | This violates the MonadPlus laws, handle with care. instance MonadPlus f => MonadPlus (F f) where mzero = F (\_ kf -> kf mzero)@@ -169,7 +185,7 @@ hoistF :: (forall x. f x -> g x) -> F f a -> F g a hoistF t (F m) = F (\p f -> m p (f . t)) --- | The very definition of a free monoid is that given a natural transformation you get a monoid homomorphism.+-- | The very definition of a free monad is that given a natural transformation you get a monad homomorphism. foldF :: Monad m => (forall x. f x -> m x) -> F f a -> m a foldF f (F m) = m return (Monad.join . f) @@ -188,9 +204,9 @@ -- -- This is based on the \"Free Monads for Less\" series of articles by Edward Kmett: ----- * <http://comonad.com/reader/2011/free-monads-for-less/ Free monads for less — Part 1>+-- * <https://ekmett.github.io/reader/2011/free-monads-for-less/ Free monads for less — Part 1> ----- * <http://comonad.com/reader/2011/free-monads-for-less-2/ Free monads for less — Part 2>+-- * <https://ekmett.github.io/reader/2011/free-monads-for-less-2/ Free monads for less — Part 2> -- -- and <http://www.iai.uni-bonn.de/~jv/mpc08.pdf \"Asymptotic Improvement of Computations over Free Monads\"> by Janis Voightländer. improve :: Functor f => (forall m. MonadFree f m => m a) -> Free f a@@ -211,6 +227,23 @@ -- -- Calling @'retract' . 'cutoff' n@ is always terminating, provided each of the -- steps in the iteration is terminating.+{-# INLINE cutoff #-} cutoff :: (Functor f) => Integer -> F f a -> F f (Maybe a)-cutoff n = toF . Free.cutoff n . fromF+cutoff n m+ | n <= 0 = return Nothing+ | n <= toInteger (maxBound :: Int) = cutoffI (fromInteger n :: Int) m+ | otherwise = cutoffI n m +{-# SPECIALIZE cutoffI :: (Functor f) => Int -> F f a -> F f (Maybe a) #-}+{-# SPECIALIZE cutoffI :: (Functor f) => Integer -> F f a -> F f (Maybe a) #-}+cutoffI :: (Functor f, Integral n) => n -> F f a -> F f (Maybe a)+cutoffI n m = F m' where+ m' kp kf = runF m kpn kfn n where+ kpn a i+ | i <= 0 = kp Nothing+ | otherwise = kp (Just a)+ kfn fr i+ | i <= 0 = kp Nothing+ | otherwise = let+ i' = i - 1+ in i' `seq` kf (fmap ($ i') fr)
src/Control/Monad/Free/Class.hs view
@@ -1,12 +1,16 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE Safe #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+#if !(MIN_VERSION_transformers(0,6,0))+{-# OPTIONS_GHC -Wno-deprecations #-} #endif-{-# OPTIONS_GHC -fno-warn-deprecations #-}+ ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.Free.Class@@ -25,7 +29,6 @@ , wrapT ) where -import Control.Applicative import Control.Monad import Control.Monad.Trans.Class import Control.Monad.Trans.Reader@@ -37,12 +40,14 @@ import qualified Control.Monad.Trans.RWS.Lazy as Lazy import Control.Monad.Trans.Cont import Control.Monad.Trans.Maybe-import Control.Monad.Trans.List-import Control.Monad.Trans.Error+import Control.Monad.Trans.Except import Control.Monad.Trans.Identity--- import Control.Monad.Trans.Either-import Data.Monoid +#if !(MIN_VERSION_transformers(0,6,0))+import Control.Monad.Trans.Error+import Control.Monad.Trans.List+#endif+ -- | -- Monads provide substitution ('fmap') and renormalization ('Control.Monad.join'): --@@ -96,10 +101,8 @@ -- wrap (fmap f x) ≡ wrap (fmap return x) >>= f -- @ wrap :: f (m a) -> m a-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704 default wrap :: (m ~ t n, MonadTrans t, MonadFree f n, Functor f) => f (m a) -> m a wrap = join . lift . wrap . fmap return-#endif instance (Functor f, MonadFree f m) => MonadFree f (ReaderT e m) where wrap fm = ReaderT $ \e -> wrap $ flip runReaderT e <$> fm@@ -131,14 +134,19 @@ instance (Functor f, MonadFree f m) => MonadFree f (IdentityT m) where wrap = IdentityT . wrap . fmap runIdentityT -instance (Functor f, MonadFree f m) => MonadFree f (ListT m) where- wrap = ListT . wrap . fmap runListT+instance (Functor f, MonadFree f m) => MonadFree f (ExceptT e m) where+ wrap = ExceptT . wrap . fmap runExceptT +-- instance (Functor f, MonadFree f m) => MonadFree f (EitherT e m) where+-- wrap = EitherT . wrap . fmap runEitherT++#if !(MIN_VERSION_transformers(0,6,0)) instance (Functor f, MonadFree f m, Error e) => MonadFree f (ErrorT e m) where wrap = ErrorT . wrap . fmap runErrorT --- instance (Functor f, MonadFree f m) => MonadFree f (EitherT e m) where--- wrap = EitherT . wrap . fmap runEitherT+instance (Functor f, MonadFree f m) => MonadFree f (ListT m) where+ wrap = ListT . wrap . fmap runListT+#endif -- | A version of lift that can be used with just a Functor for f. liftF :: (Functor f, MonadFree f m) => f a -> m a
src/Control/Monad/Free/TH.hs view
@@ -1,3 +1,10 @@+{-# LANGUAGE CPP #-}+#if MIN_VERSION_template_haskell(2,12,0)+{-# LANGUAGE Safe #-}+#else+{-# LANGUAGE Trustworthy #-}+#endif+ ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.Trans.TH@@ -27,10 +34,12 @@ ) where import Control.Arrow-import Control.Applicative import Control.Monad import Data.Char (toLower)-import Language.Haskell.TH+import Data.List ((\\), nub)+import Language.Haskell.TH.Datatype.TyVarBndr+import Language.Haskell.TH.Ppr (pprint)+import Language.Haskell.TH.Syntax data Arg = Captured Type Exp@@ -52,10 +61,6 @@ zipExprs ps (c:cs) (Captured _ _ : as) = c : zipExprs ps cs as zipExprs _ _ _ = [] -tyVarBndrName :: TyVarBndr -> Name-tyVarBndrName (PlainTV name) = name-tyVarBndrName (KindedTV name _) = name- findTypeOrFail :: String -> Q Name findTypeOrFail s = lookupTypeName s >>= maybe (fail $ s ++ " is not in scope") return @@ -68,19 +73,19 @@ mkOpName :: String -> Q String mkOpName (':':name) = return name mkOpName ( c :name) = return $ toLower c : name-mkOpName _ = fail "null constructor name"+mkOpName _ = fail "impossible happened: empty (null) constructor name" -- | Check if parameter is used in type. usesTV :: Name -> Type -> Bool usesTV n (VarT name) = n == name usesTV n (AppT t1 t2) = any (usesTV n) [t1, t2] usesTV n (SigT t _ ) = usesTV n t-usesTV n (ForallT bs _ t) = usesTV n t && n `notElem` map tyVarBndrName bs+usesTV n (ForallT bs _ t) = usesTV n t && n `notElem` map tvName bs usesTV _ _ = False -- | Analyze constructor argument.-mkArg :: Name -> Type -> Q Arg-mkArg n t+mkArg :: Type -> Type -> Q Arg+mkArg (VarT n) t | usesTV n t = case t of -- if parameter is used as is, the return type should be ()@@ -91,19 +96,50 @@ -- expression is an N-tuple secion (,...,). AppT (AppT ArrowT _) _ -> do (ts, name) <- arrowsToTuple t- when (name /= n) $ fail "return type is not the parameter"- let tup = foldl AppT (TupleT $ length ts) ts+ when (any (usesTV n) ts) $ fail $ unlines+ [ "type variable " ++ pprint n ++ " is forbidden"+ , "in a type like (a1 -> ... -> aN -> " ++ pprint n ++ ")"+ , "in a constructor's argument type: " ++ pprint t ]+ when (name /= n) $ fail $ unlines+ [ "expected final return type `" ++ pprint n ++ "'"+ , "but got `" ++ pprint name ++ "'"+ , "in a constructor's argument type: `" ++ pprint t ++ "'" ]+ let tup = nonUnaryTupleT ts xs <- mapM (const $ newName "x") ts- return $ Captured tup (LamE (map VarP xs) (TupE (map VarE xs)))- _ -> fail "don't know how to make Arg"+ return $ Captured tup (LamE (map VarP xs) (nonUnaryTupE $ map VarE xs))+ _ -> fail $ unlines+ [ "expected a type variable `" ++ pprint n ++ "'"+ , "or a type like (a1 -> ... -> aN -> " ++ pprint n ++ ")"+ , "but got `" ++ pprint t ++ "'"+ , "in a constructor's argument" ] | otherwise = return $ Param t where- arrowsToTuple (AppT (AppT ArrowT t1) (VarT name)) = return ([t1], name) arrowsToTuple (AppT (AppT ArrowT t1) t2) = do (ts, name) <- arrowsToTuple t2 return (t1:ts, name)- arrowsToTuple _ = fail "return type is not a variable"+ arrowsToTuple (VarT name) = return ([], name)+ arrowsToTuple rt = fail $ unlines+ [ "expected final return type `" ++ pprint n ++ "'"+ , "but got `" ++ pprint rt ++ "'"+ , "in a constructor's argument type: `" ++ pprint t ++ "'" ] + nonUnaryTupleT :: [Type] -> Type+ nonUnaryTupleT [t'] = t'+ nonUnaryTupleT ts = foldl AppT (TupleT $ length ts) ts++ nonUnaryTupE :: [Exp] -> Exp+ nonUnaryTupE [e] = e+ nonUnaryTupE es = TupE $+#if MIN_VERSION_template_haskell(2,16,0)+ map Just+#endif+ es++mkArg n _ = fail $ unlines+ [ "expected a type variable"+ , "but got `" ++ pprint n ++ "'"+ , "as the last parameter of the type constructor" ]+ -- | Apply transformation to the return value independently of how many -- parameters does @e@ have. -- E.g. @mapRet Just (\x y z -> x + y * z)@ goes to@@ -135,9 +171,23 @@ unifyCaptured a [] = return (VarT a, []) unifyCaptured _ [(t, e)] = return (t, [e]) unifyCaptured _ [x, y] = unifyT x y-unifyCaptured _ _ = fail "can't unify more than 2 arguments that use type parameter"+unifyCaptured _ xs = fail $ unlines+ [ "can't unify more than 2 return types"+ , "that use type parameter"+ , "when unifying return types: "+ , unlines (map (pprint . fst) xs) ] -liftCon' :: Bool -> [TyVarBndr] -> Cxt -> Type -> Name -> [Name] -> Name -> [Type] -> Q [Dec]+extractVars :: Type -> [Name]+extractVars (ForallT bs _ t) = extractVars t \\ map tvName bs+extractVars (VarT n) = [n]+extractVars (AppT x y) = extractVars x ++ extractVars y+extractVars (SigT x k) = extractVars x ++ extractVars k+extractVars (InfixT x _ y) = extractVars x ++ extractVars y+extractVars (UInfixT x _ y) = extractVars x ++ extractVars y+extractVars (ParensT x) = extractVars x+extractVars _ = []++liftCon' :: Bool -> [TyVarBndrSpec] -> Cxt -> Type -> Type -> [Type] -> Name -> [Type] -> Q [Dec] liftCon' typeSig tvbs cx f n ns cn ts = do -- prepare some names opName <- mkName <$> mkOpName (nameBase cn)@@ -159,51 +209,83 @@ let pat = map VarP xs -- this is LHS exprs = zipExprs (map VarE xs) es args -- this is what ctor would be applied to fval = foldl AppE (ConE cn) exprs -- this is RHS without liftF- q = tvbs ++ map PlainTV (qa ++ m : ns)+ ns' = nub (concatMap extractVars ns)+ q = filter nonNext tvbs ++ map plainTVSpecified (qa ++ m : ns') qa = case retType of VarT b | a == b -> [a]; _ -> []- f' = foldl AppT f (map VarT ns)+ f' = foldl AppT f ns return $ concat [ if typeSig-#if MIN_VERSION_template_haskell(2,10,0) then [ SigD opName (ForallT q (cx ++ [ConT monadFree `AppT` f' `AppT` VarT m]) opType) ]-#else- then [ SigD opName (ForallT q (cx ++ [ClassP monadFree [f', VarT m]]) opType) ]-#endif else [] , [ FunD opName [ Clause pat (NormalB $ AppE (VarE liftF) fval) [] ] ] ]+ where+ nonNext tv = VarT (tvName tv) /= n -- | Provide free monadic actions for a single value constructor.-liftCon :: Bool -> [TyVarBndr] -> Cxt -> Type -> Name -> [Name] -> Con -> Q [Dec]-liftCon typeSig ts cx f n ns con =- case con of- NormalC cName fields -> liftCon' typeSig ts cx f n ns cName $ map snd fields- RecC cName fields -> liftCon' typeSig ts cx f n ns cName $ map (\(_, _, ty) -> ty) fields- InfixC (_,t1) cName (_,t2) -> liftCon' typeSig ts cx f n ns cName [t1, t2]- ForallC ts' cx' con' -> liftCon typeSig (ts ++ ts') (cx ++ cx') f n ns con'+liftCon :: Bool -> [TyVarBndrSpec] -> Cxt -> Type -> Type -> [Type] -> Maybe [Name] -> Con -> Q [Dec]+liftCon typeSig ts cx f n ns onlyCons con+ | not (any (`melem` onlyCons) (constructorNames con)) = return []+ | otherwise = case con of+ NormalC cName fields -> liftCon' typeSig ts cx f n ns cName $ map snd fields+ RecC cName fields -> liftCon' typeSig ts cx f n ns cName $ map (\(_, _, ty) -> ty) fields+ InfixC (_,t1) cName (_,t2) -> liftCon' typeSig ts cx f n ns cName [t1, t2]+ ForallC ts' cx' con' -> liftCon typeSig (ts ++ ts') (cx ++ cx') f n ns onlyCons con'+ GadtC cNames fields resType -> do+ decs <- forM (filter (`melem` onlyCons) cNames) $ \cName ->+ liftGadtC cName fields resType typeSig ts cx f+ return (concat decs)+ RecGadtC cNames fields resType -> do+ let fields' = map (\(_, x, y) -> (x, y)) fields+ decs <- forM (filter (`melem` onlyCons) cNames) $ \cName ->+ liftGadtC cName fields' resType typeSig ts cx f+ return (concat decs) +splitAppT :: Type -> (Type, [Type])+splitAppT ty = go ty ty []+ where+ go :: Type -> Type -> [Type] -> (Type, [Type])+ go _ (AppT ty1 ty2) args = go ty1 ty1 (ty2:args)+ go origTy (SigT ty' _) args = go origTy ty' args+ go origTy (InfixT ty1 n ty2) args = go origTy (ConT n `AppT` ty1 `AppT` ty2) args+ go origTy (ParensT ty') args = go origTy ty' args+ go origTy _ args = (origTy, args)++liftGadtC :: Name -> [BangType] -> Type -> Bool -> [TyVarBndrSpec] -> Cxt -> Type -> Q [Dec]+liftGadtC cName fields resType typeSig ts cx f =+ liftCon typeSig ts cx f nextTy (init tys) Nothing (NormalC cName fields)+ where+ (_f, tys) = splitAppT resType+ nextTy = last tys++melem :: Eq a => a -> Maybe [a] -> Bool+melem _ Nothing = True+melem x (Just xs) = x `elem` xs++-- | Get construstor name(s).+constructorNames :: Con -> [Name]+constructorNames (NormalC name _) = [name]+constructorNames (RecC name _) = [name]+constructorNames (InfixC _ name _) = [name]+constructorNames (ForallC _ _ c) = constructorNames c+constructorNames (GadtC names _ _) = names+constructorNames (RecGadtC names _ _) = names+ -- | Provide free monadic actions for a type declaration. liftDec :: Bool -- ^ Include type signature? -> Maybe [Name] -- ^ Include only mentioned constructor names. Use all constructors when @Nothing@. -> Dec -- ^ Data type declaration. -> Q [Dec]-liftDec typeSig onlyCons (DataD _ tyName tyVarBndrs cons _)- | null tyVarBndrs = fail $ "Type " ++ show tyName ++ " needs at least one free variable"- | otherwise = concat <$> mapM (liftCon typeSig [] [] con nextTyName (init tyNames)) cons'+liftDec typeSig onlyCons (DataD _ tyName tyVarBndrs _ cons _)+ | null tyVarBndrs = fail $ "Type constructor " ++ pprint tyName ++ " needs at least one type parameter"+ | otherwise = concat <$> mapM (liftCon typeSig [] [] con nextTy (init tys) onlyCons) cons where- cons' = case onlyCons of- Nothing -> cons- Just ns -> filter (\c -> constructorName c `elem` ns) cons- tyNames = map tyVarBndrName tyVarBndrs- nextTyName = last tyNames+ tys = map (VarT . tvName) tyVarBndrs+ nextTy = last tys con = ConT tyName-liftDec _ _ dec = fail $ "liftDec: Don't know how to lift " ++ show dec---- | Get construstor name.-constructorName :: Con -> Name-constructorName (NormalC name _) = name-constructorName (RecC name _) = name-constructorName (InfixC _ name _) = name-constructorName (ForallC _ _ c) = constructorName c+liftDec _ _ dec = fail $ unlines+ [ "failed to derive makeFree operations:"+ , "expected a data type constructor"+ , "but got " ++ pprint dec ] -- | Generate monadic actions for a data type. genFree :: Bool -- ^ Include type signature?@@ -223,15 +305,17 @@ genFreeCon typeSig cname = do info <- reify cname case info of- DataConI _ _ tname _ -> genFree typeSig (Just [cname]) tname- _ -> fail "makeFreeCon expects a data constructor"+ DataConI _ _ tname -> genFree typeSig (Just [cname]) tname+ _ -> fail $ unlines+ [ "expected a data constructor"+ , "but got " ++ pprint info ] -- | @$('makeFree' ''T)@ provides free monadic actions for the -- constructors of the given data type @T@. makeFree :: Name -> Q [Dec] makeFree = genFree True Nothing --- | Like 'makeFreeCon', but does not provide type signatures.+-- | Like 'makeFree', but does not provide type signatures. -- This can be used to attach Haddock comments to individual arguments -- for each generated function. --
src/Control/Monad/Trans/Free.hs view
@@ -1,17 +1,13 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE Rank2Types #-}-#if __GLASGOW_HASKELL__ >= 707-{-# LANGUAGE DeriveDataTypeable #-}-#endif+{-# LANGUAGE Safe #-} -#ifndef MIN_VERSION_mtl-#define MIN_VERSION_mtl(x,y,z) 1-#endif ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.Trans.Free@@ -38,7 +34,9 @@ , iterT , iterTM , hoistFreeT+ , foldFreeT , transFreeT+ , joinFreeT , cutoff , partialIterT , intersperseT@@ -54,8 +52,11 @@ import Control.Applicative import Control.Monad (liftM, MonadPlus(..), ap, join)+import Control.Monad.Base (MonadBase(..))+import Control.Monad.Catch (MonadThrow(..), MonadCatch(..)) import Control.Monad.Trans.Class import Control.Monad.Free.Class+import qualified Control.Monad.Fail as Fail import Control.Monad.IO.Class import Control.Monad.Reader.Class import Control.Monad.Writer.Class@@ -63,61 +64,52 @@ import Control.Monad.Error.Class import Control.Monad.Cont.Class import Data.Functor.Bind hiding (join)-import Data.Monoid-import Data.Foldable-import Data.Function (on)+import Data.Functor.Classes import Data.Functor.Identity import Data.Traversable import Data.Bifunctor import Data.Bifoldable import Data.Bitraversable import Data.Data-import Prelude.Extras+import GHC.Generics -- | The base functor for a free monad. data FreeF f a b = Pure a | Free (f b)- deriving (Eq,Ord,Show,Read-#if __GLASGOW_HASKELL__ >= 707- ,Typeable-#endif- )+ deriving (Eq,Ord,Show,Read,Generic,Generic1,Data) instance Show1 f => Show2 (FreeF f) where- showsPrec2 d (Pure a) = showParen (d > 10) $ showString "Pure " . showsPrec 11 a- showsPrec2 d (Free as) = showParen (d > 10) $ showString "Free " . showsPrec1 11 as+ liftShowsPrec2 spa _sla _spb _slb d (Pure a) =+ showsUnaryWith spa "Pure" d a+ liftShowsPrec2 _spa _sla spb slb d (Free as) =+ showsUnaryWith (liftShowsPrec spb slb) "Free" d as instance (Show1 f, Show a) => Show1 (FreeF f a) where- showsPrec1 = showsPrec2+ liftShowsPrec = liftShowsPrec2 showsPrec showList instance Read1 f => Read2 (FreeF f) where- readsPrec2 d r = readParen (d > 10)- (\r' -> [ (Pure m, t)- | ("Pure", s) <- lex r'- , (m, t) <- readsPrec 11 s]) r- ++ readParen (d > 10)- (\r' -> [ (Free m, t)- | ("Free", s) <- lex r'- , (m, t) <- readsPrec1 11 s]) r+ liftReadsPrec2 rpa _rla rpb rlb = readsData $+ readsUnaryWith rpa "Pure" Pure `mappend`+ readsUnaryWith (liftReadsPrec rpb rlb) "Free" Free instance (Read1 f, Read a) => Read1 (FreeF f a) where- readsPrec1 = readsPrec2+ liftReadsPrec = liftReadsPrec2 readsPrec readList instance Eq1 f => Eq2 (FreeF f) where- Pure a ==## Pure b = a == b- Free as ==## Free bs = as ==# bs- _ ==## _ = False+ liftEq2 eq _ (Pure a) (Pure b) = eq a b+ liftEq2 _ eq (Free as) (Free bs) = liftEq eq as bs+ liftEq2 _ _ _ _ = False instance (Eq1 f, Eq a) => Eq1 (FreeF f a) where- (==#) = (==##)+ liftEq = liftEq2 (==) instance Ord1 f => Ord2 (FreeF f) where- Pure a `compare2` Pure b = a `compare` b- Pure _ `compare2` Free _ = LT- Free _ `compare2` Pure _ = GT- Free fa `compare2` Free fb = fa `compare1` fb+ liftCompare2 cmp _ (Pure a) (Pure b) = cmp a b+ liftCompare2 _ _ (Pure _) (Free _) = LT+ liftCompare2 _ _ (Free _) (Pure _) = GT+ liftCompare2 _ cmp (Free fa) (Free fb) = liftCompare cmp fa fb instance (Ord1 f, Ord a) => Ord1 (FreeF f a) where- compare1 = compare2+ liftCompare = liftCompare2 compare instance Functor f => Functor (FreeF f a) where fmap _ (Pure a) = Pure a@@ -170,34 +162,46 @@ free = FreeT . Identity {-# INLINE free #-} -deriving instance Eq (m (FreeF f a (FreeT f m a))) => Eq (FreeT f m a)+instance (Eq1 f, Eq1 m, Eq a) => Eq (FreeT f m a) where+ (==) = eq1 -instance (Functor f, Eq1 f, Functor m, Eq1 m) => Eq1 (FreeT f m) where- (==#) = on (==#) (fmap (Lift1 . fmap Lift1) . runFreeT)+instance (Eq1 f, Eq1 m) => Eq1 (FreeT f m) where+ liftEq eq = go+ where+ go (FreeT x) (FreeT y) = liftEq (liftEq2 eq go) x y -deriving instance Ord (m (FreeF f a (FreeT f m a))) => Ord (FreeT f m a)+instance (Ord1 f, Ord1 m, Ord a) => Ord (FreeT f m a) where+ compare = compare1 -instance (Functor f, Ord1 f, Functor m, Ord1 m) => Ord1 (FreeT f m) where- compare1 = on compare1 (fmap (Lift1 . fmap Lift1) . runFreeT)+instance (Ord1 f, Ord1 m) => Ord1 (FreeT f m) where+ liftCompare cmp = go+ where+ go (FreeT x) (FreeT y) = liftCompare (liftCompare2 cmp go) x y -instance (Functor f, Show1 f, Functor m, Show1 m) => Show1 (FreeT f m) where- showsPrec1 d (FreeT m) = showParen (d > 10) $- showString "FreeT " . showsPrec1 11 (Lift1 . fmap Lift1 <$> m)+instance (Show1 f, Show1 m) => Show1 (FreeT f m) where+ liftShowsPrec sp sl = go+ where+ goList = liftShowList sp sl+ go d (FreeT x) = showsUnaryWith+ (liftShowsPrec (liftShowsPrec2 sp sl go goList) (liftShowList2 sp sl go goList))+ "FreeT" d x -instance Show (m (FreeF f a (FreeT f m a))) => Show (FreeT f m a) where- showsPrec d (FreeT m) = showParen (d > 10) $- showString "FreeT " . showsPrec 11 m+instance (Show1 f, Show1 m, Show a) => Show (FreeT f m a) where+ showsPrec = showsPrec1 -instance (Functor f, Read1 f, Functor m, Read1 m) => Read1 (FreeT f m) where- readsPrec1 d = readParen (d > 10) $ \r ->- [ (FreeT (fmap lower1 . lower1 <$> m),t) | ("FreeT",s) <- lex r, (m,t) <- readsPrec1 11 s]+instance (Read1 f, Read1 m) => Read1 (FreeT f m) where+ liftReadsPrec rp rl = go+ where+ goList = liftReadList rp rl+ go = readsData $ readsUnaryWith+ (liftReadsPrec (liftReadsPrec2 rp rl go goList) (liftReadList2 rp rl go goList))+ "FreeT" FreeT -instance Read (m (FreeF f a (FreeT f m a))) => Read (FreeT f m a) where- readsPrec d = readParen (d > 10) $ \r ->- [ (FreeT m,t) | ("FreeT",s) <- lex r, (m,t) <- readsPrec 11 s]+instance (Read1 f, Read1 m, Read a) => Read (FreeT f m a) where+ readsPrec = readsPrec1 -instance (Functor f, Monad m) => Functor (FreeT f m) where- fmap f (FreeT m) = FreeT (liftM f' m) where+instance (Functor f, Functor m) => Functor (FreeT f m) where+ fmap f (FreeT m) = FreeT (fmap f' m) where f' (Pure a) = Pure (f a) f' (Free as) = Free (fmap (fmap f) as) @@ -214,14 +218,20 @@ (>>-) = (>>=) instance (Functor f, Monad m) => Monad (FreeT f m) where- fail e = FreeT (fail e)- return a = FreeT (return (Pure a))+ return = pure {-# INLINE return #-} FreeT m >>= f = FreeT $ m >>= \v -> case v of Pure a -> runFreeT (f a) Free w -> return (Free (fmap (>>= f) w)) -instance MonadTrans (FreeT f) where+#if !MIN_VERSION_base(4,13,0)+ fail e = FreeT (fail e)+#endif++instance (Functor f, Fail.MonadFail m) => Fail.MonadFail (FreeT f m) where+ fail e = FreeT (Fail.fail e)++instance Functor f => MonadTrans (FreeT f) where lift = FreeT . liftM Pure {-# INLINE lift #-} @@ -229,6 +239,10 @@ liftIO = lift . liftIO {-# INLINE liftIO #-} +instance (Functor f, MonadBase b m) => MonadBase b (FreeT f m) where+ liftBase = lift . liftBase+ {-# INLINE liftBase #-}+ instance (Functor f, MonadReader r m) => MonadReader r (FreeT f m) where ask = lift ask {-# INLINE ask #-}@@ -241,27 +255,23 @@ listen (FreeT m) = FreeT $ liftM concat' $ listen (fmap listen `liftM` m) where concat' (Pure x, w) = Pure (x, w)- concat' (Free y, w) = Free $ fmap (second (w <>)) <$> y+ concat' (Free y, w) = Free $ fmap (second (w `mappend`)) <$> y pass m = FreeT . pass' . runFreeT . hoistFreeT clean $ listen m where clean = pass . liftM (\x -> (x, const mempty)) pass' = join . liftM g g (Pure ((x, f), w)) = tell (f w) >> return (Pure x) g (Free f) = return . Free . fmap (FreeT . pass' . runFreeT) $ f-#if MIN_VERSION_mtl(2,1,1) writer w = lift (writer w) {-# INLINE writer #-}-#endif instance (Functor f, MonadState s m) => MonadState s (FreeT f m) where get = lift get {-# INLINE get #-} put = lift . put {-# INLINE put #-}-#if MIN_VERSION_mtl(2,1,1) state f = lift (state f) {-# INLINE state #-}-#endif instance (Functor f, MonadError e m) => MonadError e (FreeT f m) where throwError = lift . throwError@@ -286,6 +296,15 @@ wrap = FreeT . return . Free {-# INLINE wrap #-} +instance (Functor f, MonadThrow m) => MonadThrow (FreeT f m) where+ throwM = lift . throwM+ {-# INLINE throwM #-}++instance (Functor f, MonadCatch m) => MonadCatch (FreeT f m) where+ FreeT m `catch` f = FreeT $ liftM (fmap (`Control.Monad.Catch.catch` f)) m+ `Control.Monad.Catch.catch` (runFreeT . f)+ {-# INLINE catch #-}+ -- | Tear down a free monad transformer using iteration. iterT :: (Functor f, Monad m) => (f (m a) -> m a) -> FreeT f m a -> m a iterT f (FreeT m) = do@@ -310,14 +329,30 @@ -- | Lift a monad homomorphism from @m@ to @n@ into a monad homomorphism from @'FreeT' f m@ to @'FreeT' f n@ ----- @'hoistFreeT' :: ('Monad' m, 'Functor' f) => (m ~> n) -> 'FreeT' f m ~> 'FreeT' f n@-hoistFreeT :: (Monad m, Functor f) => (forall a. m a -> n a) -> FreeT f m b -> FreeT f n b-hoistFreeT mh = FreeT . mh . liftM (fmap (hoistFreeT mh)) . runFreeT+-- @'hoistFreeT' :: ('Functor' m, 'Functor' f) => (m ~> n) -> 'FreeT' f m ~> 'FreeT' f n@+hoistFreeT :: (Functor m, Functor f) => (forall a. m a -> n a) -> FreeT f m b -> FreeT f n b+hoistFreeT mh = FreeT . mh . fmap (fmap (hoistFreeT mh)) . runFreeT --- | Lift a natural transformation from @f@ to @g@ into a monad homomorphism from @'FreeT' f m@ to @'FreeT' g n@+-- | The very definition of a free monad transformer is that given a natural+-- transformation you get a monad transformer homomorphism.+foldFreeT :: (MonadTrans t, Monad (t m), Monad m)+ => (forall n x. Monad n => f x -> t n x) -> FreeT f m a -> t m a+foldFreeT f (FreeT m) = lift m >>= foldFreeF+ where+ foldFreeF (Pure a) = return a+ foldFreeF (Free as) = f as >>= foldFreeT f++-- | Lift a natural transformation from @f@ to @g@ into a monad homomorphism from @'FreeT' f m@ to @'FreeT' g m@ transFreeT :: (Monad m, Functor g) => (forall a. f a -> g a) -> FreeT f m b -> FreeT g m b transFreeT nt = FreeT . liftM (fmap (transFreeT nt) . transFreeF nt) . runFreeT +-- | Pull out and join @m@ layers of @'FreeT' f m a@.+joinFreeT :: (Monad m, Traversable f) => FreeT f m a -> m (Free f a)+joinFreeT (FreeT m) = m >>= joinFreeF+ where+ joinFreeF (Pure x) = return (return x)+ joinFreeF (Free f) = wrap `liftM` Data.Traversable.mapM joinFreeT f+ -- | -- 'retract' is the left inverse of 'liftF' --@@ -406,77 +441,9 @@ -- @ -- 'intercalateT' f ≡ 'retractT' . 'intersperseT' f -- @-intercalateT :: (Monad m, MonadTrans t, Monad (t m), Functor (t m)) => t m a -> FreeT (t m) m b -> t m b+intercalateT :: (Monad m, MonadTrans t, Monad (t m)) => t m a -> FreeT (t m) m b -> t m b intercalateT f (FreeT m) = do val <- lift m case val of Pure x -> return x Free y -> y >>= iterTM (\x -> f >> join x)--#if __GLASGOW_HASKELL__ < 707-instance Typeable1 f => Typeable2 (FreeF f) where- typeOf2 t = mkTyConApp freeFTyCon [typeOf1 (f t)] where- f :: FreeF f a b -> f a- f = undefined--instance (Typeable1 f, Typeable1 w) => Typeable1 (FreeT f w) where- typeOf1 t = mkTyConApp freeTTyCon [typeOf1 (f t), typeOf1 (w t)] where- f :: FreeT f w a -> f a- f = undefined- w :: FreeT f w a -> w a- w = undefined--freeFTyCon, freeTTyCon :: TyCon-#if __GLASGOW_HASKELL__ < 704-freeTTyCon = mkTyCon "Control.Monad.Trans.Free.FreeT"-freeFTyCon = mkTyCon "Control.Monad.Trans.Free.FreeF"-#else-freeTTyCon = mkTyCon3 "free" "Control.Monad.Trans.Free" "FreeT"-freeFTyCon = mkTyCon3 "free" "Control.Monad.Trans.Free" "FreeF"-#endif-{-# NOINLINE freeTTyCon #-}-{-# NOINLINE freeFTyCon #-}--instance- ( Typeable1 f, Typeable a, Typeable b- , Data a, Data (f b), Data b- ) => Data (FreeF f a b) where- gfoldl f z (Pure a) = z Pure `f` a- gfoldl f z (Free as) = z Free `f` as- toConstr Pure{} = pureConstr- toConstr Free{} = freeConstr- gunfold k z c = case constrIndex c of- 1 -> k (z Pure)- 2 -> k (z Free)- _ -> error "gunfold"- dataTypeOf _ = freeFDataType- dataCast1 f = gcast1 f--instance- ( Typeable1 f, Typeable1 w, Typeable a- , Data (w (FreeF f a (FreeT f w a)))- , Data a- ) => Data (FreeT f w a) where- gfoldl f z (FreeT w) = z FreeT `f` w- toConstr _ = freeTConstr- gunfold k z c = case constrIndex c of- 1 -> k (z FreeT)- _ -> error "gunfold"- dataTypeOf _ = freeTDataType- dataCast1 f = gcast1 f--pureConstr, freeConstr, freeTConstr :: Constr-pureConstr = mkConstr freeFDataType "Pure" [] Prefix-freeConstr = mkConstr freeFDataType "Free" [] Prefix-freeTConstr = mkConstr freeTDataType "FreeT" [] Prefix-{-# NOINLINE pureConstr #-}-{-# NOINLINE freeConstr #-}-{-# NOINLINE freeTConstr #-}--freeFDataType, freeTDataType :: DataType-freeFDataType = mkDataType "Control.Monad.Trans.Free.FreeF" [pureConstr, freeConstr]-freeTDataType = mkDataType "Control.Monad.Trans.Free.FreeT" [freeTConstr]-{-# NOINLINE freeFDataType #-}-{-# NOINLINE freeTDataType #-}-#endif-
+ src/Control/Monad/Trans/Free/Ap.hs view
@@ -0,0 +1,443 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE Safe #-}++--------------------------------------------------------------------------------+-- |+-- Given an applicative, the free monad transformer.+--------------------------------------------------------------------------------++module Control.Monad.Trans.Free.Ap+ (+ -- * The base functor+ FreeF(..)+ -- * The free monad transformer+ , FreeT(..)+ -- * The free monad+ , Free, free, runFree+ -- * Operations+ , liftF+ , iterT+ , iterTM+ , hoistFreeT+ , transFreeT+ , joinFreeT+ , cutoff+ , partialIterT+ , intersperseT+ , intercalateT+ , retractT+ -- * Operations of free monad+ , retract+ , iter+ , iterM+ -- * Free Monads With Class+ , MonadFree(..)+ ) where++import Control.Applicative+import Control.Monad (liftM, MonadPlus(..), join)+import Control.Monad.Catch (MonadThrow(..), MonadCatch(..))+import Control.Monad.Trans.Class+import qualified Control.Monad.Fail as Fail+import Control.Monad.Free.Class+import Control.Monad.IO.Class+import Control.Monad.Reader.Class+import Control.Monad.Writer.Class+import Control.Monad.State.Class+import Control.Monad.Error.Class+import Control.Monad.Cont.Class+import Data.Functor.Bind hiding (join)+import Data.Functor.Classes+import Data.Functor.Identity+import Data.Traversable+import Data.Bifunctor+import Data.Bifoldable+import Data.Bitraversable+import Data.Data+import GHC.Generics++-- | The base functor for a free monad.+data FreeF f a b = Pure a | Free (f b)+ deriving (Eq,Ord,Show,Read,Data,Generic,Generic1)++instance Show1 f => Show2 (FreeF f) where+ liftShowsPrec2 spa _sla _spb _slb d (Pure a) =+ showsUnaryWith spa "Pure" d a+ liftShowsPrec2 _spa _sla spb slb d (Free as) =+ showsUnaryWith (liftShowsPrec spb slb) "Free" d as++instance (Show1 f, Show a) => Show1 (FreeF f a) where+ liftShowsPrec = liftShowsPrec2 showsPrec showList++instance Read1 f => Read2 (FreeF f) where+ liftReadsPrec2 rpa _rla rpb rlb = readsData $+ readsUnaryWith rpa "Pure" Pure `mappend`+ readsUnaryWith (liftReadsPrec rpb rlb) "Free" Free++instance (Read1 f, Read a) => Read1 (FreeF f a) where+ liftReadsPrec = liftReadsPrec2 readsPrec readList++instance Eq1 f => Eq2 (FreeF f) where+ liftEq2 eq _ (Pure a) (Pure b) = eq a b+ liftEq2 _ eq (Free as) (Free bs) = liftEq eq as bs+ liftEq2 _ _ _ _ = False++instance (Eq1 f, Eq a) => Eq1 (FreeF f a) where+ liftEq = liftEq2 (==)++instance Ord1 f => Ord2 (FreeF f) where+ liftCompare2 cmp _ (Pure a) (Pure b) = cmp a b+ liftCompare2 _ _ (Pure _) (Free _) = LT+ liftCompare2 _ _ (Free _) (Pure _) = GT+ liftCompare2 _ cmp (Free fa) (Free fb) = liftCompare cmp fa fb++instance (Ord1 f, Ord a) => Ord1 (FreeF f a) where+ liftCompare = liftCompare2 compare++instance Functor f => Functor (FreeF f a) where+ fmap _ (Pure a) = Pure a+ fmap f (Free as) = Free (fmap f as)+ {-# INLINE fmap #-}++instance Foldable f => Foldable (FreeF f a) where+ foldMap f (Free as) = foldMap f as+ foldMap _ _ = mempty+ {-# INLINE foldMap #-}++instance Traversable f => Traversable (FreeF f a) where+ traverse _ (Pure a) = pure (Pure a)+ traverse f (Free as) = Free <$> traverse f as+ {-# INLINE traverse #-}++instance Functor f => Bifunctor (FreeF f) where+ bimap f _ (Pure a) = Pure (f a)+ bimap _ g (Free as) = Free (fmap g as)+ {-# INLINE bimap #-}++instance Foldable f => Bifoldable (FreeF f) where+ bifoldMap f _ (Pure a) = f a+ bifoldMap _ g (Free as) = foldMap g as+ {-# INLINE bifoldMap #-}++instance Traversable f => Bitraversable (FreeF f) where+ bitraverse f _ (Pure a) = Pure <$> f a+ bitraverse _ g (Free as) = Free <$> traverse g as+ {-# INLINE bitraverse #-}++transFreeF :: (forall x. f x -> g x) -> FreeF f a b -> FreeF g a b+transFreeF _ (Pure a) = Pure a+transFreeF t (Free as) = Free (t as)+{-# INLINE transFreeF #-}++-- | The \"free monad transformer\" for an applicative @f@+newtype FreeT f m a = FreeT { runFreeT :: m (FreeF f a (FreeT f m a)) }++-- | The \"free monad\" for an applicative @f@.+type Free f = FreeT f Identity++-- | Evaluates the first layer out of a free monad value.+runFree :: Free f a -> FreeF f a (Free f a)+runFree = runIdentity . runFreeT+{-# INLINE runFree #-}++-- | Pushes a layer into a free monad value.+free :: FreeF f a (Free f a) -> Free f a+free = FreeT . Identity+{-# INLINE free #-}++deriving instance+ ( Typeable f, Typeable m+ , Data (m (FreeF f a (FreeT f m a)))+ , Data a+ ) => Data (FreeT f m a)++instance (Eq1 f, Eq1 m, Eq a) => Eq (FreeT f m a) where+ (==) = eq1++instance (Eq1 f, Eq1 m) => Eq1 (FreeT f m) where+ liftEq eq = go+ where+ go (FreeT x) (FreeT y) = liftEq (liftEq2 eq go) x y++instance (Ord1 f, Ord1 m, Ord a) => Ord (FreeT f m a) where+ compare = compare1++instance (Ord1 f, Ord1 m) => Ord1 (FreeT f m) where+ liftCompare cmp = go+ where+ go (FreeT x) (FreeT y) = liftCompare (liftCompare2 cmp go) x y++instance (Show1 f, Show1 m) => Show1 (FreeT f m) where+ liftShowsPrec sp sl = go+ where+ goList = liftShowList sp sl+ go d (FreeT x) = showsUnaryWith+ (liftShowsPrec (liftShowsPrec2 sp sl go goList) (liftShowList2 sp sl go goList))+ "FreeT" d x++instance (Show1 f, Show1 m, Show a) => Show (FreeT f m a) where+ showsPrec = showsPrec1++instance (Read1 f, Read1 m) => Read1 (FreeT f m) where+ liftReadsPrec rp rl = go+ where+ goList = liftReadList rp rl+ go = readsData $ readsUnaryWith+ (liftReadsPrec (liftReadsPrec2 rp rl go goList) (liftReadList2 rp rl go goList))+ "FreeT" FreeT++instance (Read1 f, Read1 m, Read a) => Read (FreeT f m a) where+ readsPrec = readsPrec1++instance (Functor f, Functor m) => Functor (FreeT f m) where+ fmap f (FreeT m) = FreeT (fmap f' m) where+ f' (Pure a) = Pure (f a)+ f' (Free as) = Free (fmap (fmap f) as)++instance (Applicative f, Applicative m) => Applicative (FreeT f m) where+ pure a = FreeT (pure (Pure a))+ {-# INLINE pure #-}+ FreeT f <*> FreeT a = FreeT $ g <$> f <*> a where+ g (Pure f') (Pure a') = Pure (f' a')+ g (Pure f') (Free as) = Free $ fmap f' <$> as+ g (Free fs) (Pure a') = Free $ fmap ($ a') <$> fs+ g (Free fs) (Free as) = Free $ (<*>) <$> fs <*> as+ {-# INLINE (<*>) #-}++instance (Apply f, Apply m) => Apply (FreeT f m) where+ FreeT f <.> FreeT a = FreeT $ g <$> f <.> a where+ g (Pure f') (Pure a') = Pure (f' a')+ g (Pure f') (Free as) = Free $ fmap f' <$> as+ g (Free fs) (Pure a') = Free $ fmap ($ a') <$> fs+ g (Free fs) (Free as) = Free $ (<.>) <$> fs <.> as++instance (Apply f, Apply m, Monad m) => Bind (FreeT f m) where+ FreeT m >>- f = FreeT $ m >>= \v -> case v of+ Pure a -> runFreeT (f a)+ Free w -> return (Free (fmap (>>- f) w))++instance (Applicative f, Monad m) => Monad (FreeT f m) where+ return = pure+ {-# INLINE return #-}+ FreeT m >>= f = FreeT $ m >>= \v -> case v of+ Pure a -> runFreeT (f a)+ Free w -> return (Free (fmap (>>= f) w))+#if !MIN_VERSION_base(4,13,0)+ fail e = FreeT (fail e)+#endif++instance (Applicative f, Fail.MonadFail m) => Fail.MonadFail (FreeT f m) where+ fail e = FreeT (Fail.fail e)++instance Applicative f => MonadTrans (FreeT f) where+ lift = FreeT . liftM Pure+ {-# INLINE lift #-}++instance (Applicative f, MonadIO m) => MonadIO (FreeT f m) where+ liftIO = lift . liftIO+ {-# INLINE liftIO #-}++instance (Applicative f, MonadReader r m) => MonadReader r (FreeT f m) where+ ask = lift ask+ {-# INLINE ask #-}+ local f = hoistFreeT (local f)+ {-# INLINE local #-}++instance (Applicative f, MonadWriter w m) => MonadWriter w (FreeT f m) where+ tell = lift . tell+ {-# INLINE tell #-}+ listen (FreeT m) = FreeT $ liftM concat' $ listen (fmap listen `liftM` m)+ where+ concat' (Pure x, w) = Pure (x, w)+ concat' (Free y, w) = Free $ fmap (second (w `mappend`)) <$> y+ pass m = FreeT . pass' . runFreeT . hoistFreeT clean $ listen m+ where+ clean = pass . liftM (\x -> (x, const mempty))+ pass' = join . liftM g+ g (Pure ((x, f), w)) = tell (f w) >> return (Pure x)+ g (Free f) = return . Free . fmap (FreeT . pass' . runFreeT) $ f+ writer w = lift (writer w)+ {-# INLINE writer #-}++instance (Applicative f, MonadState s m) => MonadState s (FreeT f m) where+ get = lift get+ {-# INLINE get #-}+ put = lift . put+ {-# INLINE put #-}+ state f = lift (state f)+ {-# INLINE state #-}++instance (Applicative f, MonadError e m) => MonadError e (FreeT f m) where+ throwError = lift . throwError+ {-# INLINE throwError #-}+ FreeT m `catchError` f = FreeT $ liftM (fmap (`catchError` f)) m `catchError` (runFreeT . f)++instance (Applicative f, MonadCont m) => MonadCont (FreeT f m) where+ callCC f = FreeT $ callCC (\k -> runFreeT $ f (lift . k . Pure))++instance (Applicative f, MonadPlus m) => Alternative (FreeT f m) where+ empty = FreeT mzero+ FreeT ma <|> FreeT mb = FreeT (mplus ma mb)+ {-# INLINE (<|>) #-}++instance (Applicative f, MonadPlus m) => MonadPlus (FreeT f m) where+ mzero = FreeT mzero+ {-# INLINE mzero #-}+ mplus (FreeT ma) (FreeT mb) = FreeT (mplus ma mb)+ {-# INLINE mplus #-}++instance (Applicative f, Monad m) => MonadFree f (FreeT f m) where+ wrap = FreeT . return . Free+ {-# INLINE wrap #-}++instance (Applicative f, MonadThrow m) => MonadThrow (FreeT f m) where+ throwM = lift . throwM+ {-# INLINE throwM #-}++instance (Applicative f, MonadCatch m) => MonadCatch (FreeT f m) where+ FreeT m `catch` f = FreeT $ liftM (fmap (`Control.Monad.Catch.catch` f)) m+ `Control.Monad.Catch.catch` (runFreeT . f)+ {-# INLINE catch #-}++-- | Given an applicative homomorphism from @f (m a)@ to @m a@,+-- tear down a free monad transformer using iteration.+iterT :: (Applicative f, Monad m) => (f (m a) -> m a) -> FreeT f m a -> m a+iterT f (FreeT m) = do+ val <- m+ case fmap (iterT f) val of+ Pure x -> return x+ Free y -> f y++-- | Given an applicative homomorphism from @f (t m a)@ to @t m a@,+-- tear down a free monad transformer using iteration over a transformer.+iterTM :: (Applicative f, Monad m, MonadTrans t, Monad (t m)) => (f (t m a) -> t m a) -> FreeT f m a -> t m a+iterTM f (FreeT m) = do+ val <- lift m+ case fmap (iterTM f) val of+ Pure x -> return x+ Free y -> f y++instance (Foldable m, Foldable f) => Foldable (FreeT f m) where+ foldMap f (FreeT m) = foldMap (bifoldMap f (foldMap f)) m++instance (Monad m, Traversable m, Traversable f) => Traversable (FreeT f m) where+ traverse f (FreeT m) = FreeT <$> traverse (bitraverse f (traverse f)) m++-- | Lift a monad homomorphism from @m@ to @n@ into a monad homomorphism from @'FreeT' f m@ to @'FreeT' f n@+--+-- @'hoistFreeT' :: ('Functor' m, 'Applicative' f) => (m ~> n) -> 'FreeT' f m ~> 'FreeT' f n@+hoistFreeT :: (Functor m, Applicative f) => (forall a. m a -> n a) -> FreeT f m b -> FreeT f n b+hoistFreeT mh = FreeT . mh . fmap (fmap (hoistFreeT mh)) . runFreeT++-- | Lift an applicative homomorphism from @f@ to @g@ into a monad homomorphism from @'FreeT' f m@ to @'FreeT' g m@+transFreeT :: (Monad m, Applicative g) => (forall a. f a -> g a) -> FreeT f m b -> FreeT g m b+transFreeT nt = FreeT . liftM (fmap (transFreeT nt) . transFreeF nt) . runFreeT++-- | Pull out and join @m@ layers of @'FreeT' f m a@.+joinFreeT :: (Monad m, Traversable f, Applicative f) => FreeT f m a -> m (Free f a)+joinFreeT (FreeT m) = m >>= joinFreeF+ where+ joinFreeF (Pure x) = return (return x)+ joinFreeF (Free f) = wrap `liftM` Data.Traversable.mapM joinFreeT f++-- |+-- 'retract' is the left inverse of 'liftF'+--+-- @+-- 'retract' . 'liftF' = 'id'+-- @+retract :: Monad f => Free f a -> f a+retract m =+ case runIdentity (runFreeT m) of+ Pure a -> return a+ Free as -> as >>= retract++-- | Given an applicative homomorphism from @f@ to 'Identity', tear down a 'Free' 'Monad' using iteration.+iter :: Applicative f => (f a -> a) -> Free f a -> a+iter phi = runIdentity . iterT (Identity . phi . fmap runIdentity)++-- | Like 'iter' for monadic values.+iterM :: (Applicative f, Monad m) => (f (m a) -> m a) -> Free f a -> m a+iterM phi = iterT phi . hoistFreeT (return . runIdentity)++-- | Cuts off a tree of computations at a given depth.+-- If the depth is @0@ or less, no computation nor+-- monadic effects will take place.+--+-- Some examples (@n ≥ 0@):+--+-- @+-- 'cutoff' 0 _ ≡ 'return' 'Nothing'+-- 'cutoff' (n+1) '.' 'return' ≡ 'return' '.' 'Just'+-- 'cutoff' (n+1) '.' 'lift' ≡ 'lift' '.' 'liftM' 'Just'+-- 'cutoff' (n+1) '.' 'wrap' ≡ 'wrap' '.' 'fmap' ('cutoff' n)+-- @+--+-- Calling @'retract' '.' 'cutoff' n@ is always terminating, provided each of the+-- steps in the iteration is terminating.+cutoff :: (Applicative f, Monad m) => Integer -> FreeT f m a -> FreeT f m (Maybe a)+cutoff n _ | n <= 0 = return Nothing+cutoff n (FreeT m) = FreeT $ bimap Just (cutoff (n - 1)) `liftM` m++-- | @partialIterT n phi m@ interprets first @n@ layers of @m@ using @phi@.+-- This is sort of the opposite for @'cutoff'@.+--+-- Some examples (@n ≥ 0@):+--+-- @+-- 'partialIterT' 0 _ m ≡ m+-- 'partialIterT' (n+1) phi '.' 'return' ≡ 'return'+-- 'partialIterT' (n+1) phi '.' 'lift' ≡ 'lift'+-- 'partialIterT' (n+1) phi '.' 'wrap' ≡ 'join' . 'lift' . phi+-- @+partialIterT :: Monad m => Integer -> (forall a. f a -> m a) -> FreeT f m b -> FreeT f m b+partialIterT n phi m+ | n <= 0 = m+ | otherwise = FreeT $ do+ val <- runFreeT m+ case val of+ Pure a -> return (Pure a)+ Free f -> phi f >>= runFreeT . partialIterT (n - 1) phi++-- | @intersperseT f m@ inserts a layer @f@ between every two layers in+-- @m@.+--+-- @+-- 'intersperseT' f '.' 'return' ≡ 'return'+-- 'intersperseT' f '.' 'lift' ≡ 'lift'+-- 'intersperseT' f '.' 'wrap' ≡ 'wrap' '.' 'fmap' ('iterTM' ('wrap' '.' ('<$' f) '.' 'wrap'))+-- @+intersperseT :: (Monad m, Applicative f) => f a -> FreeT f m b -> FreeT f m b+intersperseT f (FreeT m) = FreeT $ do+ val <- m+ case val of+ Pure x -> return $ Pure x+ Free y -> return . Free $ fmap (iterTM (wrap . (<$ f) . wrap)) y++-- | Tear down a free monad transformer using Monad instance for @t m@.+retractT :: (MonadTrans t, Monad (t m), Monad m) => FreeT (t m) m a -> t m a+retractT (FreeT m) = do+ val <- lift m+ case val of+ Pure x -> return x+ Free y -> y >>= retractT++-- | @intercalateT f m@ inserts a layer @f@ between every two layers in+-- @m@ and then retracts the result.+--+-- @+-- 'intercalateT' f ≡ 'retractT' . 'intersperseT' f+-- @+intercalateT :: (Monad m, MonadTrans t, Monad (t m)) => t m a -> FreeT (t m) m b -> t m b+intercalateT f (FreeT m) = do+ val <- lift m+ case val of+ Pure x -> return x+ Free y -> y >>= iterTM (\x -> f >> join x)
src/Control/Monad/Trans/Free/Church.hs view
@@ -1,13 +1,9 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE Safe #-} {-# LANGUAGE UndecidableInstances #-} -#ifndef MIN_VERSION_mtl-#define MIN_VERSION_mtl(x,y,z) 1-#endif- ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.Trans.Free.Church@@ -17,7 +13,7 @@ -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : provisional -- Portability : non-portable (rank-2 polymorphism, MTPCs)--- +-- -- Church-encoded free monad transformer. -- -----------------------------------------------------------------------------@@ -28,11 +24,13 @@ -- * The free monad , F, free, runF -- * Operations+ , improveT , toFT, fromFT , iterT , iterTM , hoistFT , transFT+ , joinFT , cutoff -- * Operations of free monad , improve@@ -49,6 +47,8 @@ import Control.Applicative import Control.Category ((<<<), (>>>)) import Control.Monad+import Control.Monad.Catch (MonadCatch(..), MonadThrow(..))+import qualified Control.Monad.Fail as Fail import Control.Monad.Identity import Control.Monad.Trans.Class import Control.Monad.IO.Class@@ -60,22 +60,26 @@ import Control.Monad.Free.Class import Control.Monad.Trans.Free (FreeT(..), FreeF(..), Free) import qualified Control.Monad.Trans.Free as FreeT-import Data.Foldable (Foldable) import qualified Data.Foldable as F-import Data.Traversable (Traversable) import qualified Data.Traversable as T import Data.Functor.Bind hiding (join)-import Data.Function+import Data.Functor.Classes -- | The \"free monad transformer\" for a functor @f@-newtype FT f m a = FT {runFT :: forall r. (a -> m r) -> (f (m r) -> m r) -> m r}+newtype FT f m a = FT { runFT :: forall r. (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r } -instance (Functor f, Monad m, Eq (FreeT f m a)) => Eq (FT f m a) where- (==) = (==) `on` fromFT+instance (Functor f, Monad m, Eq1 f, Eq1 m) => Eq1 (FT f m) where+ liftEq eq x y = liftEq eq (fromFT x) (fromFT y) -instance (Functor f, Monad m, Ord (FreeT f m a)) => Ord (FT f m a) where- compare = compare `on` fromFT+instance (Functor f, Monad m, Ord1 f, Ord1 m) => Ord1 (FT f m) where+ liftCompare cmp x y= liftCompare cmp (fromFT x) (fromFT y) +instance (Functor f, Monad m, Eq1 f, Eq1 m, Eq a) => Eq (FT f m a) where+ (==) = eq1++instance (Functor f, Monad m, Ord1 f, Ord1 m, Ord a) => Ord (FT f m a) where+ compare = compare1+ instance Functor (FT f m) where fmap f (FT k) = FT $ \a fr -> k (a . f) fr @@ -93,9 +97,13 @@ return = pure FT fk >>= f = FT $ \b fr -> fk (\d -> runFT (f d) b fr) fr -instance (Functor f) => MonadFree f (FT f m) where- wrap f = FT (\kp kf -> kf (fmap (\(FT m) -> m kp kf) f))+instance Fail.MonadFail m => Fail.MonadFail (FT f m) where+ fail = lift . Fail.fail+ {-# INLINE fail #-} +instance MonadFree f (FT f m) where+ wrap f = FT (\kp kf -> kf (\ft -> runFT ft kp kf) f)+ instance MonadTrans (FT f) where lift m = FT (\a _ -> m >>= a) @@ -110,22 +118,20 @@ instance (Foldable f, Foldable m, Monad m) => Foldable (FT f m) where foldr f r xs = F.foldr (<<<) id inner r where- inner = runFT xs (return . f) (F.foldr (liftM2 (<<<)) (return id))+ inner = runFT xs (return . f) (\xg xf -> F.foldr (liftM2 (<<<) . xg) (return id) xf) {-# INLINE foldr #-} -#if MIN_VERSION_base(4,6,0) foldl' f z xs = F.foldl' (!>>>) id inner z where (!>>>) h g = \r -> g $! h r- inner = runFT xs (return . flip f) (F.foldr (liftM2 (>>>)) (return id))+ inner = runFT xs (return . flip f) (\xg xf -> F.foldr (liftM2 (>>>) . xg) (return id) xf) {-# INLINE foldl' #-}-#endif instance (Monad m, Traversable m, Traversable f) => Traversable (FT f m) where traverse f (FT k) = fmap (join . lift) . T.sequenceA $ k traversePure traverseFree where traversePure = return . fmap return . f- traverseFree = return . fmap (wrap . fmap (join . lift)) . T.sequenceA . fmap T.sequenceA+ traverseFree xg = return . fmap (wrap . fmap (join . lift)) . T.traverse (T.sequenceA . xg) instance (MonadIO m) => MonadIO (FT f m) where liftIO = lift . liftIO@@ -136,10 +142,10 @@ {-# INLINE throwError #-} m `catchError` f = toFT $ fromFT m `catchError` (fromFT . f) -instance (MonadCont m) => MonadCont (FT f m) where+instance MonadCont m => MonadCont (FT f m) where callCC f = join . lift $ callCC (\k -> return $ f (lift . k . return)) -instance (Functor f, MonadReader r m) => MonadReader r (FT f m) where+instance MonadReader r m => MonadReader r (FT f m) where ask = lift ask {-# INLINE ask #-} local f = hoistFT (local f)@@ -150,64 +156,72 @@ {-# INLINE tell #-} listen = toFT . listen . fromFT pass = toFT . pass . fromFT-#if MIN_VERSION_mtl(2,1,1) writer w = lift (writer w) {-# INLINE writer #-}-#endif -instance (Functor f, MonadState s m) => MonadState s (FT f m) where+instance MonadState s m => MonadState s (FT f m) where get = lift get {-# INLINE get #-} put = lift . put {-# INLINE put #-}-#if MIN_VERSION_mtl(2,1,1) state f = lift (state f) {-# INLINE state #-}-#endif +instance MonadThrow m => MonadThrow (FT f m) where+ throwM = lift . throwM+ {-# INLINE throwM #-}++instance (Functor f, MonadCatch m) => MonadCatch (FT f m) where+ catch m f = toFT $ fromFT m `Control.Monad.Catch.catch` (fromFT . f)+ {-# INLINE catch #-}+ -- | Generate a Church-encoded free monad transformer from a 'FreeT' monad -- transformer.-toFT :: (Monad m, Functor f) => FreeT f m a -> FT f m a+toFT :: Monad m => FreeT f m a -> FT f m a toFT (FreeT f) = FT $ \ka kfr -> do freef <- f case freef of Pure a -> ka a- Free fb -> kfr $ fmap (($ kfr) . ($ ka) . runFT . toFT) fb+ Free fb -> kfr (\x -> runFT (toFT x) ka kfr) fb -- | Convert to a 'FreeT' free monad representation. fromFT :: (Monad m, Functor f) => FT f m a -> FreeT f m a-fromFT (FT k) = FreeT $ k (return . Pure) (runFreeT . wrap . fmap FreeT)+fromFT (FT k) = FreeT $ k (return . Pure) (\xg -> runFreeT . wrap . fmap (FreeT . xg)) -- | The \"free monad\" for a functor @f@. type F f = FT f Identity -- | Unwrap the 'Free' monad to obtain it's Church-encoded representation. runF :: Functor f => F f a -> (forall r. (a -> r) -> (f r -> r) -> r)-runF (FT m) = \kp kf -> runIdentity $ m (return . kp) (return . kf . fmap runIdentity)+runF (FT m) = \kp kf -> runIdentity $ m (return . kp) (\xg -> return . kf . fmap (runIdentity . xg)) -- | Wrap a Church-encoding of a \"free monad\" as the free monad for a functor.-free :: Functor f => (forall r. (a -> r) -> (f r -> r) -> r) -> F f a-free f = FT (\kp kf -> return $ f (runIdentity . kp) (runIdentity . kf . fmap return))+free :: (forall r. (a -> r) -> (f r -> r) -> r) -> F f a+free f = FT (\kp kf -> return $ f (runIdentity . kp) (runIdentity . kf return)) -- | Tear down a free monad transformer using iteration. iterT :: (Functor f, Monad m) => (f (m a) -> m a) -> FT f m a -> m a-iterT phi (FT m) = m return phi+iterT phi (FT m) = m return (\xg -> phi . fmap xg) {-# INLINE iterT #-} -- | Tear down a free monad transformer using iteration over a transformer. iterTM :: (Functor f, Monad m, MonadTrans t, Monad (t m)) => (f (t m a) -> t m a) -> FT f m a -> t m a-iterTM f (FT m) = join . lift $ m (return . return) (return . f . fmap (join .lift))+iterTM f (FT m) = join . lift $ m (return . return) (\xg -> return . f . fmap (join . lift . xg)) -- | Lift a monad homomorphism from @m@ to @n@ into a monad homomorphism from @'FT' f m@ to @'FT' f n@ -- -- @'hoistFT' :: ('Monad' m, 'Monad' n, 'Functor' f) => (m ~> n) -> 'FT' f m ~> 'FT' f n@-hoistFT :: (Monad m, Monad n, Functor f) => (forall a. m a -> n a) -> FT f m b -> FT f n b-hoistFT phi (FT m) = FT (\kp kf -> join . phi $ m (return . kp) (return . kf . fmap (join . phi)))+hoistFT :: (Monad m, Monad n) => (forall a. m a -> n a) -> FT f m b -> FT f n b+hoistFT phi (FT m) = FT (\kp kf -> join . phi $ m (return . kp) (\xg -> return . kf (join . phi . xg))) -- | Lift a natural transformation from @f@ to @g@ into a monad homomorphism from @'FT' f m@ to @'FT' g n@-transFT :: (Monad m, Functor g) => (forall a. f a -> g a) -> FT f m b -> FT g m b-transFT phi (FT m) = FT (\kp kf -> m kp (kf . phi))+transFT :: (forall a. f a -> g a) -> FT f m b -> FT g m b+transFT phi (FT m) = FT (\kp kf -> m kp (\xg -> kf xg . phi)) +-- | Pull out and join @m@ layers of @'FreeT' f m a@.+joinFT :: (Monad m, Traversable f) => FT f m a -> m (F f a)+joinFT (FT m) = m (return . return) (\xg -> liftM wrap . T.mapM xg)+ -- | Cuts off a tree of computations at a given depth. -- If the depth is 0 or less, no computation nor -- monadic effects will take place.@@ -230,13 +244,13 @@ -- @ -- 'retract' . 'liftF' = 'id' -- @-retract :: (Functor f, Monad f) => F f a -> f a+retract :: Monad f => F f a -> f a retract m = runF m return join {-# INLINE retract #-} -- | Tear down a free monad transformer using iteration over a transformer. retractT :: (MonadTrans t, Monad (t m), Monad m) => FT (t m) m a -> t m a-retractT (FT m) = join . lift $ m (return . return) $ \x -> return $ x >>= join . lift+retractT (FT m) = join . lift $ m (return . return) (\xg xf -> return $ xf >>= join . lift . xg) -- | Tear down an 'F' 'Monad' using iteration. iter :: Functor f => (f a -> a) -> F f a -> a@@ -253,7 +267,7 @@ {-# INLINE fromF #-} -- | Generate a Church-encoded free monad from a 'Free' monad.-toF :: (Functor f) => Free f a -> F f a+toF :: Free f a -> F f a toF = toFT {-# INLINE toF #-} @@ -261,8 +275,8 @@ -- -- This is based on the \"Free Monads for Less\" series of articles by Edward Kmett: ----- <http://comonad.com/reader/2011/free-monads-for-less/>--- <http://comonad.com/reader/2011/free-monads-for-less-2/>+-- <https://ekmett.github.io/reader/2011/free-monads-for-less/>+-- <https://ekmett.github.io/reader/2011/free-monads-for-less-2/> -- -- and \"Asymptotic Improvement of Computations over Free Monads\" by Janis Voightländer: --@@ -270,4 +284,12 @@ improve :: Functor f => (forall m. MonadFree f m => m a) -> Free f a improve m = fromF m {-# INLINE improve #-}++-- | Improve the asymptotic performance of code that builds a free monad transformer+-- with only binds and returns by using 'FT' behind the scenes.+--+-- Similar to 'improve'.+improveT :: (Functor f, Monad m) => (forall t. MonadFree f (t m) => t m a) -> FreeT f m a+improveT m = fromFT m+{-# INLINE improveT #-}
src/Control/Monad/Trans/Iter.hs view
@@ -1,14 +1,11 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Rank2Types #-}-{-# LANGUAGE DeriveDataTypeable #-}--#ifndef MIN_VERSION_mtl-#define MIN_VERSION_mtl(x,y,z) 1-#endif+{-# LANGUAGE Safe #-}+{-# LANGUAGE StandaloneDeriving #-} ----------------------------------------------------------------------------- -- |@@ -73,9 +70,11 @@ ) where import Control.Applicative+import Control.Monad.Catch (MonadCatch(..), MonadThrow(..)) import Control.Monad (ap, liftM, MonadPlus(..), join) import Control.Monad.Fix import Control.Monad.Trans.Class+import qualified Control.Monad.Fail as Fail import Control.Monad.Free.Class import Control.Monad.State.Class import Control.Monad.Error.Class@@ -87,26 +86,23 @@ import Data.Bitraversable import Data.Either import Data.Functor.Bind hiding (join)+import Data.Functor.Classes import Data.Functor.Identity-import Data.Foldable hiding (fold)-import Data.Function (on)-import Data.Traversable hiding (mapM)-import Data.Monoid import Data.Semigroup.Foldable import Data.Semigroup.Traversable import Data.Typeable import Data.Data-import Prelude.Extras +#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup+#endif+ -- | The monad supporting iteration based over a base monad @m@. -- -- @ -- 'IterT' ~ 'FreeT' 'Identity' -- @ newtype IterT m a = IterT { runIterT :: m (Either a (IterT m a)) }-#if __GLASGOW_HASKELL__ >= 707- deriving (Typeable)-#endif -- | Plain iterative computations. type Iter = IterT Identity@@ -125,33 +121,43 @@ runIter = runIdentity . runIterT {-# INLINE runIter #-} -instance (Functor m, Eq1 m) => Eq1 (IterT m) where- (==#) = on (==#) (fmap (fmap Lift1) . runIterT)+instance (Eq1 m) => Eq1 (IterT m) where+ liftEq eq = go+ where+ go (IterT x) (IterT y) = liftEq (liftEq2 eq go) x y -instance Eq (m (Either a (IterT m a))) => Eq (IterT m a) where- IterT m == IterT n = m == n+instance (Eq1 m, Eq a) => Eq (IterT m a) where+ (==) = eq1 -instance (Functor m, Ord1 m) => Ord1 (IterT m) where- compare1 = on compare1 (fmap (fmap Lift1) . runIterT)+instance (Ord1 m) => Ord1 (IterT m) where+ liftCompare cmp = go+ where+ go (IterT x) (IterT y) = liftCompare (liftCompare2 cmp go) x y -instance Ord (m (Either a (IterT m a))) => Ord (IterT m a) where- compare (IterT m) (IterT n) = compare m n+instance (Ord1 m, Ord a) => Ord (IterT m a) where+ compare = compare1 -instance (Functor m, Show1 m) => Show1 (IterT m) where- showsPrec1 d (IterT m) = showParen (d > 10) $- showString "IterT " . showsPrec1 11 (fmap (fmap Lift1) m)+instance (Show1 m) => Show1 (IterT m) where+ liftShowsPrec sp sl = go+ where+ goList = liftShowList sp sl+ go d (IterT x) = showsUnaryWith+ (liftShowsPrec (liftShowsPrec2 sp sl go goList) (liftShowList2 sp sl go goList))+ "IterT" d x -instance Show (m (Either a (IterT m a))) => Show (IterT m a) where- showsPrec d (IterT m) = showParen (d > 10) $- showString "IterT " . showsPrec 11 m+instance (Show1 m, Show a) => Show (IterT m a) where+ showsPrec = showsPrec1 -instance (Functor m, Read1 m) => Read1 (IterT m) where- readsPrec1 d = readParen (d > 10) $ \r ->- [ (IterT (fmap (fmap lower1) m),t) | ("IterT",s) <- lex r, (m,t) <- readsPrec1 11 s]+instance (Read1 m) => Read1 (IterT m) where+ liftReadsPrec rp rl = go+ where+ goList = liftReadList rp rl+ go = readsData $ readsUnaryWith+ (liftReadsPrec (liftReadsPrec2 rp rl go goList) (liftReadList2 rp rl go goList))+ "IterT" IterT -instance Read (m (Either a (IterT m a))) => Read (IterT m a) where- readsPrec d = readParen (d > 10) $ \r ->- [ (IterT m,t) | ("IterT",s) <- lex r, (m,t) <- readsPrec 11 s]+instance (Read1 m, Read a) => Read (IterT m a) where+ readsPrec = readsPrec1 instance Monad m => Functor (IterT m) where fmap f = IterT . liftM (bimap f (fmap f)) . runIterT@@ -164,10 +170,16 @@ {-# INLINE (<*>) #-} instance Monad m => Monad (IterT m) where- return = IterT . return . Left+ return = pure {-# INLINE return #-} IterT m >>= k = IterT $ m >>= either (runIterT . k) (return . Right . (>>= k)) {-# INLINE (>>=) #-}+#if !MIN_VERSION_base(4,13,0)+ fail = Fail.fail+ {-# INLINE fail #-}+#endif++instance Monad m => Fail.MonadFail (IterT m) where fail _ = never {-# INLINE fail #-} @@ -232,27 +244,23 @@ listen (IterT m) = IterT $ liftM concat' $ listen (fmap listen `liftM` m) where concat' (Left x, w) = Left (x, w)- concat' (Right y, w) = Right $ second (w <>) <$> y+ concat' (Right y, w) = Right $ second (w `mappend`) <$> y pass m = IterT . pass' . runIterT . hoistIterT clean $ listen m where clean = pass . liftM (\x -> (x, const mempty)) pass' = join . liftM g g (Left ((x, f), w)) = tell (f w) >> return (Left x) g (Right f) = return . Right . IterT . pass' . runIterT $ f-#if MIN_VERSION_mtl(2,1,1) writer w = lift (writer w) {-# INLINE writer #-}-#endif instance MonadState s m => MonadState s (IterT m) where get = lift get {-# INLINE get #-} put s = lift (put s) {-# INLINE put #-}-#if MIN_VERSION_mtl(2,1,1) state f = lift (state f) {-# INLINE state #-}-#endif instance MonadError e m => MonadError e (IterT m) where throwError = lift . throwError@@ -269,6 +277,14 @@ wrap = IterT . return . Right . runIdentity {-# INLINE wrap #-} +instance MonadThrow m => MonadThrow (IterT m) where+ throwM = lift . throwM+ {-# INLINE throwM #-}++instance MonadCatch m => MonadCatch (IterT m) where+ catch (IterT m) f = IterT $ liftM (fmap (`Control.Monad.Catch.catch` f)) m `Control.Monad.Catch.catch` (runIterT . f)+ {-# INLINE catch #-}+ -- | Adds an extra layer to a free monad value. -- -- In particular, for the iterative monad 'Iter', this makes the@@ -372,17 +388,9 @@ interleave_ xs = IterT $ liftM (Right . interleave_ . rights) $ mapM runIterT xs {-# INLINE interleave_ #-} -instance (Monad m, Monoid a) => Monoid (IterT m a) where+instance (Monad m, Semigroup a, Monoid a) => Monoid (IterT m a) where mempty = return mempty- x `mappend` y = IterT $ do- x' <- runIterT x- y' <- runIterT y- case (x', y') of- ( Left a, Left b) -> return . Left $ a `mappend` b- ( Left a, Right b) -> return . Right $ liftM (a `mappend`) b- (Right a, Left b) -> return . Right $ liftM (`mappend` b) a- (Right a, Right b) -> return . Right $ a `mappend` b-+ mappend = (<>) mconcat = mconcat' . map Right where mconcat' :: (Monad m, Monoid a) => [Either a (IterT m a)] -> IterT m a@@ -400,46 +408,23 @@ compact' a [] = [Left a] compact' a (r@(Right _):xs) = (Left a):(r:(compact xs))- compact' a ( (Left a'):xs) = compact' (a <> a') xs--#if __GLASGOW_HASKELL__ < 707-instance Typeable1 m => Typeable1 (IterT m) where- typeOf1 t = mkTyConApp freeTyCon [typeOf1 (f t)] where- f :: IterT m a -> m a- f = undefined--freeTyCon :: TyCon-#if __GLASGOW_HASKELL__ < 704-freeTyCon = mkTyCon "Control.Monad.Iter.IterT"-#else-freeTyCon = mkTyCon3 "free" "Control.Monad.Iter" "IterT"-#endif-{-# NOINLINE freeTyCon #-}+ compact' a ( (Left a'):xs) = compact' (a `mappend` a') xs -#else-#define Typeable1 Typeable-#endif+instance (Monad m, Semigroup a) => Semigroup (IterT m a) where+ x <> y = IterT $ do+ x' <- runIterT x+ y' <- runIterT y+ case (x', y') of+ ( Left a, Left b) -> return . Left $ a <> b+ ( Left a, Right b) -> return . Right $ liftM (a <>) b+ (Right a, Left b) -> return . Right $ liftM (<> b) a+ (Right a, Right b) -> return . Right $ a <> b -instance- ( Typeable1 m, Typeable a+deriving instance+ ( Typeable m , Data (m (Either a (IterT m a))) , Data a- ) => Data (IterT m a) where- gfoldl f z (IterT as) = z IterT `f` as- toConstr IterT{} = iterConstr- gunfold k z c = case constrIndex c of- 1 -> k (z IterT)- _ -> error "gunfold"- dataTypeOf _ = iterDataType- dataCast1 f = gcast1 f--iterConstr :: Constr-iterConstr = mkConstr iterDataType "IterT" [] Prefix-{-# NOINLINE iterConstr #-}--iterDataType :: DataType-iterDataType = mkDataType "Control.Monad.Iter.IterT" [iterConstr]-{-# NOINLINE iterDataType #-}+ ) => Data (IterT m a) {- $examples