diff --git a/.ghci b/.ghci deleted file mode 100644 --- a/.ghci +++ /dev/null @@ -1,1 +0,0 @@ -:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h diff --git a/.hlint.yaml b/.hlint.yaml new file mode 100644 --- /dev/null +++ b/.hlint.yaml @@ -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} diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 --- a/.travis.yml +++ /dev/null @@ -1,146 +0,0 @@ -# This Travis job script has been generated by a script via -# -# runghc make_travis_yml_2.hs '-o' '.travis.yml' '--irc-channel=irc.freenode.org#haskell-lens' '--no-no-tests-no-bench' '--no-installed' 'cabal.project' -# -# For more information, see https://github.com/hvr/multi-ghc-travis -# -language: c -sudo: false - -git: - submodules: false # whether to recursively clone submodules - -notifications: - irc: - channels: - - "irc.freenode.org#haskell-lens" - skip_join: true - template: - - "\x0313free\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" - -cache: - directories: - - $HOME/.cabal/packages - - $HOME/.cabal/store - -before_cache: - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log - # remove files that are regenerated by 'cabal update' - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.* - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx - - - rm -rfv $HOME/.cabal/packages/head.hackage - -matrix: - include: - - compiler: "ghc-7.4.2" - # env: TEST=--disable-tests BENCH=--disable-benchmarks - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.0,ghc-7.4.2], sources: [hvr-ghc]}} - - compiler: "ghc-7.6.3" - # env: TEST=--disable-tests BENCH=--disable-benchmarks - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.0,ghc-7.6.3], sources: [hvr-ghc]}} - - compiler: "ghc-7.8.4" - # env: TEST=--disable-tests BENCH=--disable-benchmarks - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.0,ghc-7.8.4], sources: [hvr-ghc]}} - - compiler: "ghc-7.10.3" - # env: TEST=--disable-tests BENCH=--disable-benchmarks - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.0,ghc-7.10.3], sources: [hvr-ghc]}} - - compiler: "ghc-8.0.2" - # env: TEST=--disable-tests BENCH=--disable-benchmarks - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.0,ghc-8.0.2], sources: [hvr-ghc]}} - - compiler: "ghc-8.2.2" - # env: TEST=--disable-tests BENCH=--disable-benchmarks - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.0,ghc-8.2.2], sources: [hvr-ghc]}} - - compiler: "ghc-8.4.2" - # env: TEST=--disable-tests BENCH=--disable-benchmarks - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-8.4.2], sources: [hvr-ghc]}} - - compiler: "ghc-head" - env: GHCHEAD=true - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-head], sources: [hvr-ghc]}} - - allow_failures: - - compiler: "ghc-head" - -before_install: - - HC=${CC} - - HCPKG=${HC/ghc/ghc-pkg} - - unset CC - - ROOTDIR=$(pwd) - - mkdir -p $HOME/.local/bin - - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH" - - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') )) - - echo $HCNUMVER - -install: - - cabal --version - - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" - - BENCH=${BENCH---enable-benchmarks} - - TEST=${TEST---enable-tests} - - HADDOCK=${HADDOCK-true} - - INSTALLED=${INSTALLED-true} - - GHCHEAD=${GHCHEAD-false} - - travis_retry cabal update -v - - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config" - - rm -fv cabal.project cabal.project.local - # Overlay Hackage Package Index for GHC HEAD: https://github.com/hvr/head.hackage - - | - if $GHCHEAD; then - sed -i.bak 's/-- allow-newer:.*/allow-newer: *:base, *:template-haskell, *:ghc, *:Cabal/' ${HOME}/.cabal/config - - echo 'repository head.hackage' >> ${HOME}/.cabal/config - echo ' url: http://head.hackage.haskell.org/' >> ${HOME}/.cabal/config - echo ' secure: True' >> ${HOME}/.cabal/config - echo ' root-keys: 07c59cb65787dedfaef5bd5f987ceb5f7e5ebf88b904bbd4c5cbdeb2ff71b740' >> ${HOME}/.cabal/config - echo ' 2e8555dde16ebd8df076f1a8ef13b8f14c66bad8eafefd7d9e37d0ed711821fb' >> ${HOME}/.cabal/config - echo ' 8f79fd2389ab2967354407ec852cbe73f2e8635793ac446d09461ffb99527f6e' >> ${HOME}/.cabal/config - echo ' key-threshold: 3' >> ${HOME}/.cabal.config - - cabal new-update head.hackage -v - fi - - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$' - - "printf 'packages: \".\" \"./examples\"\\n' > cabal.project" - - echo 'package free-examples' >> cabal.project - - "echo ' flags: -mandelbrot-iter' >> cabal.project" - - cat cabal.project - - if [ -f "./configure.ac" ]; then - (cd "." && autoreconf -i); - fi - - if [ -f "./examples/configure.ac" ]; then - (cd "./examples" && autoreconf -i); - fi - - rm -f cabal.project.freeze - - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all - - rm -rf "."/.ghc.environment.* "./examples"/.ghc.environment.* "."/dist "./examples"/dist - - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) - -# Here starts the actual work to be performed for the package under test; -# any command which exits with a non-zero exit code causes the build to fail. -script: - # test that source-distributions can be generated - - (cd "." && cabal sdist) - - (cd "./examples" && cabal sdist) - - mv "."/dist/free-*.tar.gz "./examples"/dist/free-examples-*.tar.gz ${DISTDIR}/ - - cd ${DISTDIR} || false - - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \; - - "printf 'packages: free-*/*.cabal free-examples-*/*.cabal\\n' > cabal.project" - - echo 'package free-examples' >> cabal.project - - "echo ' flags: -mandelbrot-iter' >> cabal.project" - - cat cabal.project - - - # build & run tests, build benchmarks - - cabal new-build -w ${HC} ${TEST} ${BENCH} all - - # cabal check - - (cd free-* && cabal check) - - (cd free-examples-* && cabal check) - - # haddock - - rm -rf ./dist-newstyle - - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi - -# REGENDATA ["-o",".travis.yml","--irc-channel=irc.freenode.org#haskell-lens","--no-no-tests-no-bench","--no-installed","cabal.project"] -# EOF diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,71 @@ +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`. diff --git a/HLint.hs b/HLint.hs deleted file mode 100644 --- a/HLint.hs +++ /dev/null @@ -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" diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -1,7 +1,7 @@ free ==== -[![Hackage](https://img.shields.io/hackage/v/free.svg)](https://hackage.haskell.org/package/free) [![Build Status](https://secure.travis-ci.org/ekmett/free.png?branch=master)](http://travis-ci.org/ekmett/free) +[![Hackage](https://img.shields.io/hackage/v/free.svg)](https://hackage.haskell.org/package/free) [![Build Status](https://github.com/ekmett/free/workflows/Haskell-CI/badge.svg)](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. diff --git a/doc/proof/Control/Comonad/Trans/Cofree/instance-Applicative-CofreeT.md b/doc/proof/Control/Comonad/Trans/Cofree/instance-Applicative-CofreeT.md --- a/doc/proof/Control/Comonad/Trans/Cofree/instance-Applicative-CofreeT.md +++ b/doc/proof/Control/Comonad/Trans/Cofree/instance-Applicative-CofreeT.md @@ -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 diff --git a/doc/proof/Control/Comonad/Trans/Cofree/instance-Monad-CofreeT.md b/doc/proof/Control/Comonad/Trans/Cofree/instance-Monad-CofreeT.md --- a/doc/proof/Control/Comonad/Trans/Cofree/instance-Monad-CofreeT.md +++ b/doc/proof/Control/Comonad/Trans/Cofree/instance-Monad-CofreeT.md @@ -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 diff --git a/examples/Cabbage.lhs b/examples/Cabbage.lhs --- a/examples/Cabbage.lhs +++ b/examples/Cabbage.lhs @@ -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]) @@ -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 diff --git a/examples/MandelbrotIter.lhs b/examples/MandelbrotIter.lhs --- a/examples/MandelbrotIter.lhs +++ b/examples/MandelbrotIter.lhs @@ -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" diff --git a/examples/NewtonCoiter.lhs b/examples/NewtonCoiter.lhs --- a/examples/NewtonCoiter.lhs +++ b/examples/NewtonCoiter.lhs @@ -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. diff --git a/examples/PerfTH.hs b/examples/PerfTH.hs --- a/examples/PerfTH.hs +++ b/examples/PerfTH.hs @@ -6,20 +6,16 @@ module Main where import System.CPUTime.Rdtsc -import System.IO import System.IO.Unsafe import Data.IORef import Data.Word import Control.Monad -import Control.Monad.State.Strict +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.IO.Class -import Control.Monad.Trans.Maybe -import Control.Category ((>>>)) -import qualified Data.Foldable as F -import Text.Read.Compat (readMaybe) +import Control.Monad.Trans.State.Strict import Text.Printf -- | A data type representing basic commands for our performance-testing eDSL. @@ -56,7 +52,7 @@ runPerfFree :: (MonadIO m) => [String] -> Free PerfF () -> m () runPerfFree [] _ = return () runPerfFree (s:ss) x = case x of - Free (Output o next) -> do + Free (Output _o next) -> do runPerfFree (s:ss) next Free (Input next) -> do g_print_time_since_prev_call @@ -65,12 +61,12 @@ return a -- | Church-based interpreter -runPerfF :: (MonadIO m) => [String] -> Church.F PerfF () -> m () +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 + go (Output _o next) = do next go (Input next) = do g_print_time_since_prev_call @@ -79,7 +75,8 @@ next (read s) -- | Test input is the same for all cases -test_input = [show i | i<-([1..9999] ++ [0])] +test_input :: [String] +test_input = [show i | i<-([1..9999] ++ [0 :: Int])] -- | Tail-recursive program test_tail :: (MonadFree PerfF m) => m () diff --git a/examples/RetryTH.hs b/examples/RetryTH.hs --- a/examples/RetryTH.hs +++ b/examples/RetryTH.hs @@ -5,12 +5,14 @@ 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.Compat (readMaybe) +import Text.Read (readMaybe) -- | A data type representing basic commands for a retriable eDSL. data RetryF next where @@ -53,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 @@ -66,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 @@ -76,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 () @@ -92,4 +94,3 @@ main :: IO () main = runRetry test - diff --git a/examples/Teletype.lhs b/examples/Teletype.lhs --- a/examples/Teletype.lhs +++ b/examples/Teletype.lhs @@ -1,11 +1,11 @@ > {-# 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 System.IO.Error (ioeGetErrorString) > import System.Exit (exitSuccess) diff --git a/examples/ValidationForm.hs b/examples/ValidationForm.hs --- a/examples/ValidationForm.hs +++ b/examples/ValidationForm.hs @@ -1,12 +1,12 @@ 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.Compat (readEither) +import Text.Read (readEither) import Text.Printf import System.IO diff --git a/examples/free-examples.cabal b/examples/free-examples.cabal --- a/examples/free-examples.cabal +++ b/examples/free-examples.cabal @@ -2,7 +2,7 @@ category: Control, Monads version: 0.1 license: BSD3 -cabal-version: >= 1.18 +cabal-version: 1.18 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett @@ -10,7 +10,16 @@ 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 == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.2 +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 @@ -21,7 +30,6 @@ flag mandelbrot-iter default: True - manual: True library hs-source-dirs: . @@ -29,10 +37,10 @@ exposed-modules: Cabbage ghc-options: -Wall build-depends: - base == 4.*, + base >= 4.9 && < 5, free, - mtl >= 2.0.1 && < 2.3, - transformers >= 0.2 && < 0.6 + mtl >= 2.0.1 && < 2.4, + transformers >= 0.2 && < 0.7 executable free-mandelbrot-iter if !flag(mandelbrot-iter) @@ -42,11 +50,11 @@ main-is: MandelbrotIter.lhs ghc-options: -Wall build-depends: - base == 4.*, + base >= 4.9 && < 5, free, - HGL, - mtl >= 2.0.1 && < 2.3, - transformers >= 0.2 && < 0.6 + HGL >= 3.2.3.2, + mtl >= 2.0.1 && < 2.4, + transformers >= 0.2 && < 0.7 executable free-newton-coiter hs-source-dirs: . @@ -54,8 +62,8 @@ main-is: NewtonCoiter.lhs ghc-options: -Wall build-depends: - base == 4.*, - comonad >= 4 && < 6, + base >= 4.9 && < 5, + comonad >= 4 && < 6, free executable free-perf-th @@ -64,23 +72,21 @@ main-is: PerfTH.hs ghc-options: -Wall build-depends: - base == 4.*, - base-compat, + base >= 4.9 && < 5, free, - mtl >= 2.0.1 && < 2.3, rdtsc, - transformers >= 0.2 && < 0.6 + transformers >= 0.2 && < 0.7 executable free-retry-th hs-source-dirs: . default-language: Haskell2010 main-is: RetryTH.hs - ghc-options: -Wall + ghc-options: -Wall -fno-warn-orphans build-depends: - base == 4.*, - base-compat, + base >= 4.9 && < 5, free, - transformers >= 0.2 && < 0.6 + transformers >= 0.2 && < 0.7, + transformers-compat >= 0.6.4 && < 0.8 executable free-teletype hs-source-dirs: . @@ -88,7 +94,7 @@ main-is: Teletype.lhs ghc-options: -Wall build-depends: - base == 4.*, + base >= 4.9 && < 5, free, monad-loops @@ -98,7 +104,6 @@ main-is: ValidationForm.hs ghc-options: -Wall build-depends: - base == 4.*, - base-compat, + base >= 4.9 && < 5, free, - mtl >= 2.0.1 && < 2.3 + transformers >= 0.2 && < 0.7 diff --git a/free.cabal b/free.cabal --- a/free.cabal +++ b/free.cabal @@ -1,8 +1,8 @@ name: free category: Control, Monads -version: 5.0.2 +version: 5.2 license: BSD3 -cabal-version: >= 1.18 +cabal-version: 1.18 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett @@ -10,7 +10,16 @@ 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 == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.2 +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. @@ -29,25 +38,22 @@ . More information on free monads, including examples, can be found in the following blog posts: - - + + 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 - include/free-common.h extra-doc-files: examples/*.hs examples/*.lhs @@ -58,11 +64,8 @@ library hs-source-dirs: src - include-dirs: include - includes: free-common.h default-language: Haskell2010 - default-extensions: CPP other-extensions: MultiParamTypeClasses FunctionalDependencies @@ -72,21 +75,23 @@ GADTs build-depends: - base == 4.*, - bifunctors >= 4 && < 6, - comonad >= 4 && < 6, - distributive >= 0.2.1, - mtl >= 2.0.1.0 && < 2.3, - profunctors >= 4 && < 6, - semigroupoids >= 4 && < 6, - semigroups >= 0.8.3.1 && < 1, - transformers >= 0.2.0 && < 0.6, - transformers-base < 0.5, - transformers-compat >= 0.3 && < 1, - template-haskell >= 2.7.0.0 && < 3, - exceptions >= 0.6 && < 0.11, - containers < 0.6 + 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 @@ -108,13 +113,14 @@ Control.Monad.Trans.Free.Church Control.Monad.Trans.Iter - other-modules: - Data.Functor.Classes.Compat + ghc-options: -Wall -Wcompat -Wnoncanonical-monad-instances - ghc-options: -Wall + if !impl(ghc >= 8.8) + ghc-options: -Wnoncanonical-monadfail-instances - -- See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0#base-4.9.0.0 - if impl(ghc >= 8.0) - ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances - else - build-depends: fail == 4.9.* + 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 diff --git a/include/free-common.h b/include/free-common.h deleted file mode 100644 --- a/include/free-common.h +++ /dev/null @@ -1,19 +0,0 @@ -#ifndef MIN_VERSION_base -#define MIN_VERSION_base(x,y,z) 1 -#endif - -#ifndef MIN_VERSION_mtl -#define MIN_VERSION_mtl(x,y,z) 1 -#endif - -#if MIN_VERSION_base(4,9,0) -#define LIFTED_FUNCTOR_CLASSES 1 -#else -#if MIN_VERSION_transformers(0,5,0) -#define LIFTED_FUNCTOR_CLASSES 1 -#else -#if MIN_VERSION_transformers_compat(0,5,0) && !MIN_VERSION_transformers(0,4,0) -#define LIFTED_FUNCTOR_CLASSES 1 -#endif -#endif -#endif diff --git a/src/Control/Alternative/Free.hs b/src/Control/Alternative/Free.hs --- a/src/Control/Alternative/Free.hs +++ b/src/Control/Alternative/Free.hs @@ -2,11 +2,7 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} -#if __GLASGOW_HASKELL__ >= 707 -{-# LANGUAGE DeriveDataTypeable #-} -#endif -{-# OPTIONS_GHC -Wall #-} -#include "free-common.h" +{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | @@ -33,7 +29,6 @@ import Data.Functor.Apply import Data.Functor.Alt (()) import qualified Data.Functor.Alt as Alt -import Data.Typeable #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup @@ -44,14 +39,8 @@ 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 (AltF f) where fmap f (Pure a) = Pure $ f a @@ -136,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 diff --git a/src/Control/Alternative/Free/Final.hs b/src/Control/Alternative/Free/Final.hs --- a/src/Control/Alternative/Free/Final.hs +++ b/src/Control/Alternative/Free/Final.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | @@ -48,6 +49,8 @@ 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 (<>) = (<|>) diff --git a/src/Control/Applicative/Free.hs b/src/Control/Applicative/Free.hs --- a/src/Control/Applicative/Free.hs +++ b/src/Control/Applicative/Free.hs @@ -1,11 +1,6 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE GADTs #-} -#if __GLASGOW_HASKELL__ >= 707 -{-# LANGUAGE DeriveDataTypeable #-} -#endif -{-# OPTIONS_GHC -Wall #-} -#include "free-common.h" +{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | @@ -43,19 +38,16 @@ import Control.Applicative import Control.Comonad (Comonad(..)) import Data.Functor.Apply -import Data.Typeable +import Data.Foldable +import Data.Semigroup.Foldable +import Data.Functor.Classes -#if !(MIN_VERSION_base(4,8,0)) -import Data.Monoid -#endif +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@. -- @@ -93,7 +85,221 @@ 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) @@ -117,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 diff --git a/src/Control/Applicative/Free/Fast.hs b/src/Control/Applicative/Free/Fast.hs --- a/src/Control/Applicative/Free/Fast.hs +++ b/src/Control/Applicative/Free/Fast.hs @@ -1,14 +1,7 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} -#if __GLASGOW_HASKELL__ >= 707 -{-# LANGUAGE DeriveDataTypeable #-} -#endif -{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE Safe #-} -#ifndef MIN_VERSION_base -#define MIN_VERSION_base(x,y,z) 1 -#endif -------------------------------------------------------------------------------- -- | -- A faster free applicative. @@ -33,12 +26,7 @@ import Control.Applicative import Data.Functor.Apply -import Data.Typeable -#if !(MIN_VERSION_base(4,8,0)) -import Data.Monoid -#endif - -- | 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, @@ -47,9 +35,6 @@ data ASeq f a where ANil :: ASeq f () ACons :: f a -> ASeq f u -> ASeq f (a,u) -#if __GLASGOW_HASKELL__ >= 707 - deriving Typeable -#endif -- | Interprets the sequence of effects using the semantics for -- `pure` and `<*>` given by the Applicative instance for 'f'. @@ -85,9 +70,6 @@ { unAp :: forall u y z. (forall x. (x -> y) -> ASeq f x -> z) -> (u -> a -> y) -> ASeq f u -> z } -#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@. -- @@ -137,32 +119,3 @@ -- prop> retractApp == runAp id retractAp :: Applicative f => Ap f a -> f a retractAp x = unAp x (\f s -> f <$> reduceASeq s) (\() -> id) ANil - -#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.Fast.Ap" -#else -apTyCon = mkTyCon3 "free" "Control.Applicative.Free.Fast" "Ap" -#endif -{-# NOINLINE apTyCon #-} - -instance Typeable1 f => Typeable1 (ASeq f) where - typeOf1 t = mkTyConApp apTyCon [typeOf1 (f t)] where - f :: ASeq f a -> f a - f = undefined - -apSeqTyCon :: TyCon -#if __GLASGOW_HASKELL__ < 704 -apSeqTyCon = mkTyCon "Control.Applicative.Free.Fast.ASeq" -#else -apSeqTyCon = mkTyCon3 "free" "Control.Applicative.Free.Fast" "ASeq" -#endif -{-# NOINLINE apSeqTyCon #-} - -#endif diff --git a/src/Control/Applicative/Free/Final.hs b/src/Control/Applicative/Free/Final.hs --- a/src/Control/Applicative/Free/Final.hs +++ b/src/Control/Applicative/Free/Final.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} -#include "free-common.h" +{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | @@ -33,10 +32,6 @@ import Control.Applicative import Data.Functor.Apply - -#if !(MIN_VERSION_base(4,8,0)) -import Data.Monoid -#endif -- | 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 } diff --git a/src/Control/Applicative/Trans/Free.hs b/src/Control/Applicative/Trans/Free.hs --- a/src/Control/Applicative/Trans/Free.hs +++ b/src/Control/Applicative/Trans/Free.hs @@ -1,11 +1,6 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE GADTs #-} -#if __GLASGOW_HASKELL__ >= 707 -{-# LANGUAGE DeriveDataTypeable #-} -#endif -{-# OPTIONS_GHC -Wall #-} -#include "free-common.h" +{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | @@ -53,26 +48,15 @@ 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) @@ -133,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) @@ -200,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 diff --git a/src/Control/Comonad/Cofree.hs b/src/Control/Comonad/Cofree.hs --- a/src/Control/Comonad/Cofree.hs +++ b/src/Control/Comonad/Cofree.hs @@ -1,14 +1,12 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -#if __GLASGOW_HASKELL__ >= 707 -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE Safe #-} {-# LANGUAGE StandaloneDeriving #-} -#endif -#include "free-common.h" + ----------------------------------------------------------------------------- -- | -- Module : Control.Comonad.Cofree @@ -52,19 +50,20 @@ import Control.Monad(ap, (>=>), liftM) import Control.Monad.Zip import Data.Functor.Bind -import Data.Functor.Classes.Compat +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 Prelude hiding (id,(.)) -#if __GLASGOW_HASKELL__ >= 707 import GHC.Generics hiding (Infix, Prefix) -#endif +import Prelude hiding (id,(.)) infixr 5 :< @@ -91,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. -- @@ -110,11 +109,9 @@ -- For a practical application, check -- by Neil Ghani et al. data Cofree f a = a :< f (Cofree f a) -#if __GLASGOW_HASKELL__ >= 707 - deriving (Typeable, Generic, Generic1) + deriving (Generic, Generic1) deriving instance (Typeable f, Data (f (Cofree f a)), Data a) => Data (Cofree f a) -#endif -- | Use coiteration to generate a cofree comonad from a seed. -- @@ -203,27 +200,16 @@ (<*>) = ap {-# INLINE (<*>) #-} -#ifdef LIFTED_FUNCTOR_CLASSES 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 -#else -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) -#endif -#ifdef LIFTED_FUNCTOR_CLASSES instance (Show1 f, Show a) => Show (Cofree f a) where -#else -instance (Functor f, Show1 f, Show a) => Show (Cofree f a) where -#endif showsPrec = showsPrec1 -#ifdef LIFTED_FUNCTOR_CLASSES instance (Read1 f) => Read1 (Cofree f) where liftReadsPrec rp rl = go where @@ -233,69 +219,32 @@ (u, s) <- rp 6 r', (":<", t) <- lex s, (v, w) <- liftReadsPrec go goList 5 t]) r -#else -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 -#endif -#ifdef LIFTED_FUNCTOR_CLASSES instance (Read1 f, Read a) => Read (Cofree f a) where -#else -instance (Functor f, Read1 f, Read a) => Read (Cofree f a) where -#endif readsPrec = readsPrec1 -#ifdef LIFTED_FUNCTOR_CLASSES instance (Eq1 f, Eq a) => Eq (Cofree f a) where -#else -instance (Functor f, Eq1 f, Eq a) => Eq (Cofree f a) where -#endif (==) = eq1 -#ifdef LIFTED_FUNCTOR_CLASSES instance (Eq1 f) => Eq1 (Cofree f) where liftEq eq = go where go (a :< as) (b :< bs) = eq a b && liftEq go as bs -#else -instance (Functor f, Eq1 f) => Eq1 (Cofree f) where -#ifndef HLINT - eq1 (a :< as) (b :< bs) = a == b && eq1 (fmap Lift1 as) (fmap Lift1 bs) -#endif -#endif -#ifdef LIFTED_FUNCTOR_CLASSES instance (Ord1 f, Ord a) => Ord (Cofree f a) where -#else -instance (Functor f, Ord1 f, Ord a) => Ord (Cofree f a) where -#endif compare = compare1 -#ifdef LIFTED_FUNCTOR_CLASSES instance (Ord1 f) => Ord1 (Cofree f) where liftCompare cmp = go where go (a :< as) (b :< bs) = cmp a b `mappend` liftCompare go as bs -#else -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 -#endif instance Foldable f => Foldable (Cofree f) where foldMap f = go where go (a :< as) = f a `mappend` foldMap go as {-# INLINE foldMap #-} -#if __GLASGOW_HASKELL__ >= 709 length = go 0 where go s (_ :< as) = foldl' go (s + 1) as -#endif instance Foldable1 f => Foldable1 (Cofree f) where foldMap1 f = go where @@ -312,45 +261,17 @@ 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 - ( 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 FunctorWithIndex i f => FunctorWithIndex [i] (Cofree f) where + imap f (a :< as) = f [] a :< imap (\i -> imap (f . (:) i)) as + {-# INLINE imap #-} -cofreeConstr :: Constr -cofreeConstr = mkConstr cofreeDataType ":<" [] Infix -{-# NOINLINE cofreeConstr #-} +instance FoldableWithIndex i f => FoldableWithIndex [i] (Cofree f) where + ifoldMap f (a :< as) = f [] a `mappend` ifoldMap (\i -> ifoldMap (f . (:) i)) as + {-# INLINE ifoldMap #-} -cofreeDataType :: DataType -cofreeDataType = mkDataType "Control.Comonad.Cofree.Cofree" [cofreeConstr] -{-# NOINLINE cofreeDataType #-} -#endif +instance TraversableWithIndex i f => TraversableWithIndex [i] (Cofree f) where + itraverse f (a :< as) = (:<) <$> f [] a <*> itraverse (\i -> itraverse (f . (:) i)) as + {-# INLINE itraverse #-} instance ComonadHoist Cofree where cohoist = hoistCofree @@ -456,11 +377,7 @@ shoots :: (Applicative f, Traversable g) => (a -> f a) -> Cofree g a -> f (Cofree g a) shoots f = go where -#if __GLASGOW_HASKELL__ < 709 - go xxs@(x :< xs) | null (toList xs) = pure xxs -#else go xxs@(x :< xs) | null xs = pure xxs -#endif | otherwise = (:<) <$> f x <*> traverse go xs {-# INLINE shoots #-} @@ -478,10 +395,6 @@ leaves :: (Applicative f, Traversable g) => (a -> f a) -> Cofree g a -> f (Cofree g a) leaves f = go where -#if __GLASGOW_HASKELL__ < 709 - go (x :< xs) | null (toList xs) = (:< xs) <$> f x -#else go (x :< xs) | null xs = (:< xs) <$> f x -#endif | otherwise = (x :<) <$> traverse go xs {-# INLINE leaves #-} diff --git a/src/Control/Comonad/Cofree/Class.hs b/src/Control/Comonad/Cofree/Class.hs --- a/src/Control/Comonad/Cofree/Class.hs +++ b/src/Control/Comonad/Cofree/Class.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Safe #-} {-# LANGUAGE UndecidableInstances #-} -#include "free-common.h" + ----------------------------------------------------------------------------- -- | -- Module : Control.Comonad.Cofree.Class @@ -24,11 +24,8 @@ import Control.Comonad.Trans.Store import Control.Comonad.Trans.Traced import Control.Comonad.Trans.Identity -import Data.List.NonEmpty +import Data.List.NonEmpty (NonEmpty(..)) import Data.Tree -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid -#endif -- | Allows you to peel a layer off a cofree comonad. class (Functor f, Comonad w) => ComonadCofree f w | w -> f where diff --git a/src/Control/Comonad/Trans/Cofree.hs b/src/Control/Comonad/Trans/Cofree.hs --- a/src/Control/Comonad/Trans/Cofree.hs +++ b/src/Control/Comonad/Trans/Cofree.hs @@ -1,12 +1,11 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Rank2Types #-} -#if __GLASGOW_HASKELL__ >= 707 -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -#endif +{-# LANGUAGE Safe #-} +{-# LANGUAGE StandaloneDeriving #-} ----------------------------------------------------------------------------- -- | @@ -42,6 +41,7 @@ import Data.Bifoldable import Data.Bitraversable import Data.Foldable +import Data.Functor.Classes import Data.Functor.Identity import Data.Traversable import Control.Monad (liftM) @@ -49,24 +49,50 @@ import Control.Monad.Zip import Prelude hiding (id,(.)) import Data.Data -#if __GLASGOW_HASKELL__ >= 707 import GHC.Generics hiding (Infix, Prefix) -#endif -#if !(MIN_VERSION_base(4,8,0)) -import Data.Monoid -#endif - 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, Generic, Generic1 -#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 @@ -99,9 +125,6 @@ -- | 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 @@ -174,10 +197,6 @@ compare (CofreeT a) (CofreeT b) = compare a b instance (Alternative f, Monad w) => Monad (CofreeT f w) where -#if __GLASGOW_HASKELL__ < 710 - return = CofreeT . return . (:< empty) - {-# INLINE return #-} -#endif CofreeT cx >>= f = CofreeT $ do a :< m <- cx b :< n <- runCofreeT $ f a @@ -208,71 +227,16 @@ 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 diff --git a/src/Control/Comonad/Trans/Coiter.hs b/src/Control/Comonad/Trans/Coiter.hs --- a/src/Control/Comonad/Trans/Coiter.hs +++ b/src/Control/Comonad/Trans/Coiter.hs @@ -1,11 +1,9 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -#if __GLASGOW_HASKELL__ >= 707 -{-# LANGUAGE DeriveDataTypeable #-} -#endif -#include "free-common.h" +{-# 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,52 +56,32 @@ import Data.Bitraversable import Data.Data import Data.Foldable -import Data.Functor.Classes.Compat +import Data.Functor.Classes import Data.Functor.Identity import Data.Traversable import Prelude hiding (id,(.)) -- | 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 -#ifdef LIFTED_FUNCTOR_CLASSES instance (Eq1 w) => Eq1 (CoiterT w) where liftEq eq = go where go (CoiterT x) (CoiterT y) = liftEq (liftEq2 eq go) x y -#else -instance (Functor w, Eq1 w) => Eq1 (CoiterT w) where - eq1 = on eq1 (fmap (fmap Lift1) . runCoiterT) -#endif -#ifdef LIFTED_FUNCTOR_CLASSES instance (Ord1 w) => Ord1 (CoiterT w) where liftCompare cmp = go where go (CoiterT x) (CoiterT y) = liftCompare (liftCompare2 cmp go) x y -#else -instance (Functor w, Ord1 w) => Ord1 (CoiterT w) where - compare1 = on compare1 (fmap (fmap Lift1) . runCoiterT) -#endif -#ifdef LIFTED_FUNCTOR_CLASSES 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 -#else -instance (Functor w, Show1 w) => Show1 (CoiterT w) where - showsPrec1 d (CoiterT as) = showParen (d > 10) $ - showString "CoiterT " . showsPrec1 11 (fmap (fmap Lift1) as) -#endif + "CoiterT" d x -#ifdef LIFTED_FUNCTOR_CLASSES instance (Read1 w) => Read1 (CoiterT w) where liftReadsPrec rp rl = go where @@ -111,11 +89,6 @@ go = readsData $ readsUnaryWith (liftReadsPrec (liftReadsPrec2 rp rl go goList) (liftReadList2 rp rl go goList)) "CoiterT" CoiterT -#else -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] -#endif -- | The coiterative comonad type Coiter = CoiterT Identity @@ -154,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 @@ -180,33 +153,17 @@ {-# INLINE seeks #-} {-# INLINE experiment #-} -#ifdef LIFTED_FUNCTOR_CLASSES instance (Show1 w, Show a) => Show (CoiterT w a) where -#else -instance (Functor w, Show1 w, Show a) => Show (CoiterT w a) where -#endif showsPrec = showsPrec1 -#ifdef LIFTED_FUNCTOR_CLASSES instance (Read1 w, Read a) => Read (CoiterT w a) where -#else -instance (Functor w, Read1 w, Read a) => Read (CoiterT w a) where -#endif readsPrec = readsPrec1 -#ifdef LIFTED_FUNCTOR_CLASSES instance (Eq1 w, Eq a) => Eq (CoiterT w a) where -#else -instance (Functor w, Eq1 w, Eq a) => Eq (CoiterT w a) where -#endif (==) = eq1 {-# INLINE (==) #-} -#ifdef LIFTED_FUNCTOR_CLASSES instance (Ord1 w, Ord a) => Ord (CoiterT w a) where -#else -instance (Functor w, Ord1 w, Ord a) => Ord (CoiterT w a) where -#endif compare = compare1 {-# INLINE compare #-} @@ -214,45 +171,11 @@ 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 diff --git a/src/Control/Monad/Free.hs b/src/Control/Monad/Free.hs --- a/src/Control/Monad/Free.hs +++ b/src/Control/Monad/Free.hs @@ -1,14 +1,12 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Rank2Types #-} -#if __GLASGOW_HASKELL__ >= 707 -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE StandaloneDeriving #-} -#endif -#include "free-common.h" +{-# LANGUAGE Safe #-} + ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.Free @@ -51,18 +49,27 @@ import Control.Monad.Error.Class import Control.Monad.Cont.Class import Data.Functor.Bind -import Data.Functor.Classes.Compat +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 Prelude hiding (foldr) -#if __GLASGOW_HASKELL__ >= 707 import GHC.Generics -#endif +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)))) + -- | The 'Free' 'Monad' for a 'Functor' @f@. -- -- /Formally/ @@ -82,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. -- @@ -108,34 +115,20 @@ -- -- * @'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, Generic, Generic1) + deriving (Generic, Generic1) deriving instance (Typeable f, Data (f (Free f a)), Data a) => Data (Free f a) -#endif -#ifdef LIFTED_FUNCTOR_CLASSES 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 -#else -instance (Functor f, Eq1 f) => Eq1 (Free f) where - Pure a `eq1` Pure b = a == b - Free fa `eq1` Free fb = fmap Lift1 fa `eq1` fmap Lift1 fb - _ `eq1` _ = False -#endif -#ifdef LIFTED_FUNCTOR_CLASSES instance (Eq1 f, Eq a) => Eq (Free f a) where -#else -instance (Eq1 f, Functor f, Eq a) => Eq (Free f a) where -#endif (==) = eq1 -#ifdef LIFTED_FUNCTOR_CLASSES instance Ord1 f => Ord1 (Free f) where liftCompare cmp = go where @@ -143,66 +136,27 @@ go (Pure _) (Free _) = LT go (Free _) (Pure _) = GT go (Free fa) (Free fb) = liftCompare go fa fb -#else -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 -#endif -#ifdef LIFTED_FUNCTOR_CLASSES instance (Ord1 f, Ord a) => Ord (Free f a) where -#else -instance (Ord1 f, Functor f, Ord a) => Ord (Free f a) where -#endif compare = compare1 -#ifdef LIFTED_FUNCTOR_CLASSES 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 -#else -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) -#endif -#ifdef LIFTED_FUNCTOR_CLASSES instance (Show1 f, Show a) => Show (Free f a) where -#else -instance (Show1 f, Functor f, Show a) => Show (Free f a) where -#endif showsPrec = showsPrec1 -#ifdef LIFTED_FUNCTOR_CLASSES 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 -#else -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 -#endif -#ifdef LIFTED_FUNCTOR_CLASSES instance (Read1 f, Read a) => Read (Free f a) where -#else -instance (Read1 f, Functor f, Read a) => Read (Free f a) where -#endif readsPrec = readsPrec1 instance Functor f => Functor (Free f) where @@ -244,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) @@ -268,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 @@ -295,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 @@ -303,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 #-} @@ -355,7 +322,7 @@ iterM _ (Pure x) = return x 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) @@ -382,7 +349,7 @@ -- 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 @@ -394,7 +361,7 @@ unfold f = f >>> either Pure (Free . fmap (unfold f)) -- | Unfold a free monad from a seed, monadically. -unfoldM :: (Traversable f, Applicative m, Monad m) => (b -> m (Either a (f b))) -> b -> m (Free f a) +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 @@ -413,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 diff --git a/src/Control/Monad/Free/Ap.hs b/src/Control/Monad/Free/Ap.hs --- a/src/Control/Monad/Free/Ap.hs +++ b/src/Control/Monad/Free/Ap.hs @@ -1,13 +1,11 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Rank2Types #-} -#if __GLASGOW_HASKELL__ >= 707 -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -#endif -#include "free-common.h" +{-# LANGUAGE Safe #-} +{-# LANGUAGE StandaloneDeriving #-} -------------------------------------------------------------------------------- -- | @@ -61,46 +59,43 @@ import Control.Monad.Error.Class import Control.Monad.Cont.Class import Data.Functor.Bind -import Data.Functor.Classes.Compat +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 Prelude hiding (foldr) -#if __GLASGOW_HASKELL__ >= 707 import GHC.Generics -#endif +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)) -#if __GLASGOW_HASKELL__ >= 707 - deriving (Typeable, Generic, Generic1) -#endif + deriving (Generic, Generic1) -#ifdef LIFTED_FUNCTOR_CLASSES +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 -#else -instance (Functor f, Eq1 f) => Eq1 (Free f) where - Pure a `eq1` Pure b = a == b - Free fa `eq1` Free fb = fmap Lift1 fa `eq1` fmap Lift1 fb - _ `eq1` _ = False -#endif -#ifdef LIFTED_FUNCTOR_CLASSES instance (Eq1 f, Eq a) => Eq (Free f a) where -#else -instance (Eq1 f, Functor f, Eq a) => Eq (Free f a) where -#endif (==) = eq1 -#ifdef LIFTED_FUNCTOR_CLASSES instance Ord1 f => Ord1 (Free f) where liftCompare cmp = go where @@ -108,66 +103,27 @@ go (Pure _) (Free _) = LT go (Free _) (Pure _) = GT go (Free fa) (Free fb) = liftCompare go fa fb -#else -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 -#endif -#ifdef LIFTED_FUNCTOR_CLASSES instance (Ord1 f, Ord a) => Ord (Free f a) where -#else -instance (Ord1 f, Functor f, Ord a) => Ord (Free f a) where -#endif compare = compare1 -#ifdef LIFTED_FUNCTOR_CLASSES 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 -#else -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) -#endif -#ifdef LIFTED_FUNCTOR_CLASSES instance (Show1 f, Show a) => Show (Free f a) where -#else -instance (Show1 f, Functor f, Show a) => Show (Free f a) where -#endif showsPrec = showsPrec1 -#ifdef LIFTED_FUNCTOR_CLASSES 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 -#else -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 -#endif -#ifdef LIFTED_FUNCTOR_CLASSES instance (Read1 f, Read a) => Read (Free f a) where -#else -instance (Read1 f, Functor f, Read a) => Read (Free f a) where -#endif readsPrec = readsPrec1 instance Functor f => Functor (Free f) where @@ -211,7 +167,7 @@ {-# INLINE (<|>) #-} -- | This violates the MonadPlus laws, handle with care. -instance (Applicative 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) @@ -235,14 +191,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 @@ -262,7 +216,7 @@ go (Free fa) = Free <$> traverse1 go fa {-# INLINE traverse1 #-} -instance (Applicative m, MonadWriter e m) => MonadWriter e (Free m) where +instance MonadWriter e m => MonadWriter e (Free m) where tell = lift . tell {-# INLINE tell #-} listen = lift . listen . retract @@ -270,25 +224,25 @@ pass = lift . pass . retract {-# INLINE pass #-} -instance (Applicative 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 (Applicative 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 (Applicative 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 (Applicative m, MonadCont m) => MonadCont (Free m) where +instance MonadCont m => MonadCont (Free m) where callCC f = lift (callCC (retract . f . liftM lift)) {-# INLINE callCC #-} @@ -303,7 +257,7 @@ -- 'retract' . 'lift' = 'id' -- 'retract' . 'liftF' = 'id' -- @ -retract :: (Applicative f, Monad f) => Free f a -> f a +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. @@ -317,7 +271,7 @@ iterA phi (Free f) = phi (iterA phi <$> f) -- | Like 'iter' for monadic values. -iterM :: (Applicative m, Monad m, Applicative f) => (f (m a) -> m a) -> Free f a -> m a +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) @@ -326,14 +280,14 @@ hoistFree f = foldFree (liftF . f) -- | Given an applicative homomorphism, you get a monad homomorphism. -foldFree :: (Applicative f, Applicative m, Monad m) => (forall x . f x -> m x) -> Free f a -> m a +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, Applicative m, Monad m) => Free f a -> FreeT.FreeT f m a +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. @@ -359,7 +313,7 @@ unfold f = f >>> either Pure (Free . fmap (unfold f)) -- | Unfold a free monad from a seed, monadically. -unfoldM :: (Applicative f, Traversable f, Applicative m, Monad m) => (b -> m (Either a (f b))) -> b -> m (Free f a) +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 @@ -393,45 +347,3 @@ unfree x = Left 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 diff --git a/src/Control/Monad/Free/Church.hs b/src/Control/Monad/Free/Church.hs --- a/src/Control/Monad/Free/Church.hs +++ b/src/Control/Monad/Free/Church.hs @@ -1,10 +1,9 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -#include "free-common.h" +{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | @@ -47,9 +46,9 @@ -- -- This is based on the \"Free Monads for Less\" series of articles by Edward Kmett: -- --- * +-- * -- --- * +-- * ---------------------------------------------------------------------------- module Control.Monad.Free.Church ( F(..) @@ -86,7 +85,7 @@ -- -- It is /asymptotically/ more efficient to use ('>>=') for 'F' than it is to ('>>=') with 'Free'. -- --- +-- newtype F f a = F { runF :: forall r. (a -> r) -> (f r -> r) -> r } -- | Tear down a 'Free' 'Monad' using iteration. @@ -131,10 +130,8 @@ 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) @@ -207,9 +204,9 @@ -- -- This is based on the \"Free Monads for Less\" series of articles by Edward Kmett: -- --- * +-- * -- --- * +-- * -- -- and by Janis Voightländer. improve :: Functor f => (forall m. MonadFree f m => m a) -> Free f a diff --git a/src/Control/Monad/Free/Class.hs b/src/Control/Monad/Free/Class.hs --- a/src/Control/Monad/Free/Class.hs +++ b/src/Control/Monad/Free/Class.hs @@ -1,14 +1,15 @@ {-# 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 #-} -#include "free-common.h" ----------------------------------------------------------------------------- -- | @@ -39,14 +40,12 @@ 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 -#if !(MIN_VERSION_base(4,8,0)) -import Control.Applicative -import Data.Monoid +#if !(MIN_VERSION_transformers(0,6,0)) +import Control.Monad.Trans.Error +import Control.Monad.Trans.List #endif -- | @@ -102,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 @@ -137,17 +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, Error e) => MonadFree f (ErrorT e m) where - wrap = ErrorT . wrap . fmap runErrorT - 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 (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 diff --git a/src/Control/Monad/Free/TH.hs b/src/Control/Monad/Free/TH.hs --- a/src/Control/Monad/Free/TH.hs +++ b/src/Control/Monad/Free/TH.hs @@ -1,5 +1,9 @@ {-# LANGUAGE CPP #-} -#include "free-common.h" +#if MIN_VERSION_template_haskell(2,12,0) +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif ----------------------------------------------------------------------------- -- | @@ -33,13 +37,10 @@ import Control.Monad import Data.Char (toLower) import Data.List ((\\), nub) -import Language.Haskell.TH +import Language.Haskell.TH.Datatype.TyVarBndr +import Language.Haskell.TH.Ppr (pprint) import Language.Haskell.TH.Syntax -#if !(MIN_VERSION_base(4,8,0)) -import Control.Applicative -#endif - data Arg = Captured Type Exp | Param Type @@ -60,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 @@ -83,7 +80,7 @@ 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. @@ -107,9 +104,9 @@ [ "expected final return type `" ++ pprint n ++ "'" , "but got `" ++ pprint name ++ "'" , "in a constructor's argument type: `" ++ pprint t ++ "'" ] - let tup = foldl AppT (TupleT $ length ts) ts + let tup = nonUnaryTupleT ts xs <- mapM (const $ newName "x") ts - return $ Captured tup (LamE (map VarP xs) (TupE (map VarE xs))) + 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 ++ ")" @@ -126,6 +123,18 @@ , "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 ++ "'" @@ -169,25 +178,16 @@ , unlines (map (pprint . fst) xs) ] extractVars :: Type -> [Name] -extractVars (ForallT bs _ t) = extractVars t \\ map bndrName bs - where - bndrName (PlainTV n) = n - bndrName (KindedTV n _) = n +extractVars (ForallT bs _ t) = extractVars t \\ map tvName bs extractVars (VarT n) = [n] extractVars (AppT x y) = extractVars x ++ extractVars y -#if MIN_VERSION_template_haskell(2,8,0) extractVars (SigT x k) = extractVars x ++ extractVars k -#else -extractVars (SigT x k) = extractVars x -#endif -#if MIN_VERSION_template_haskell(2,11,0) extractVars (InfixT x _ y) = extractVars x ++ extractVars y extractVars (UInfixT x _ y) = extractVars x ++ extractVars y extractVars (ParensT x) = extractVars x -#endif extractVars _ = [] -liftCon' :: Bool -> [TyVarBndr] -> Cxt -> Type -> Type -> [Type] -> Name -> [Type] -> Q [Dec] +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) @@ -210,24 +210,19 @@ 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 ns' = nub (concatMap extractVars ns) - q = filter nonNext tvbs ++ map PlainTV (qa ++ m : ns') + q = filter nonNext tvbs ++ map plainTVSpecified (qa ++ m : ns') qa = case retType of VarT b | a == b -> [a]; _ -> [] 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 (PlainTV pn) = VarT pn /= n - nonNext (KindedTV kn _) = VarT kn /= n + nonNext tv = VarT (tvName tv) /= n -- | Provide free monadic actions for a single value constructor. -liftCon :: Bool -> [TyVarBndr] -> Cxt -> Type -> Type -> [Type] -> Maybe [Name] -> Con -> Q [Dec] +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 @@ -235,7 +230,6 @@ 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' -#if MIN_VERSION_template_haskell(2,11,0) GadtC cNames fields resType -> do decs <- forM (filter (`melem` onlyCons) cNames) $ \cName -> liftGadtC cName fields resType typeSig ts cx f @@ -245,21 +239,23 @@ decs <- forM (filter (`melem` onlyCons) cNames) $ \cName -> liftGadtC cName fields' resType typeSig ts cx f return (concat decs) -#endif - _ -> fail $ "Unsupported constructor type: `" ++ pprint con ++ "'" -#if MIN_VERSION_template_haskell(2,11,0) -splitAppT :: Type -> [Type] -splitAppT (AppT x y) = splitAppT x ++ [y] -splitAppT t = [t] +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 -> [TyVarBndr] -> Cxt -> Type -> Q [Dec] +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 + (_f, tys) = splitAppT resType nextTy = last tys -#endif melem :: Eq a => a -> Maybe [a] -> Bool melem _ Nothing = True @@ -271,26 +267,19 @@ constructorNames (RecC name _) = [name] constructorNames (InfixC _ name _) = [name] constructorNames (ForallC _ _ c) = constructorNames c -#if MIN_VERSION_template_haskell(2,11,0) constructorNames (GadtC names _ _) = names constructorNames (RecGadtC names _ _) = names -#endif -constructorNames con' = fail $ "Unsupported constructor type: `" ++ pprint con' ++ "'" -- | 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] -#if MIN_VERSION_template_haskell(2,11,0) liftDec typeSig onlyCons (DataD _ tyName tyVarBndrs _ cons _) -#else -liftDec typeSig onlyCons (DataD _ tyName tyVarBndrs cons _) -#endif | 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 - tys = map (VarT . tyVarBndrName) tyVarBndrs + tys = map (VarT . tvName) tyVarBndrs nextTy = last tys con = ConT tyName liftDec _ _ dec = fail $ unlines @@ -316,11 +305,7 @@ genFreeCon typeSig cname = do info <- reify cname case info of - DataConI _ _ tname -#if !(MIN_VERSION_template_haskell(2,11,0)) - _ -#endif - -> genFree typeSig (Just [cname]) tname + DataConI _ _ tname -> genFree typeSig (Just [cname]) tname _ -> fail $ unlines [ "expected a data constructor" , "but got " ++ pprint info ] diff --git a/src/Control/Monad/Trans/Free.hs b/src/Control/Monad/Trans/Free.hs --- a/src/Control/Monad/Trans/Free.hs +++ b/src/Control/Monad/Trans/Free.hs @@ -1,14 +1,12 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE Rank2Types #-} -#if __GLASGOW_HASKELL__ >= 707 -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -#endif -#include "free-common.h" +{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | @@ -66,31 +64,19 @@ import Control.Monad.Error.Class import Control.Monad.Cont.Class import Data.Functor.Bind hiding (join) -import Data.Functor.Classes.Compat +import Data.Functor.Classes import Data.Functor.Identity import Data.Traversable import Data.Bifunctor import Data.Bifoldable import Data.Bitraversable import Data.Data -#if __GLASGOW_HASKELL__ >= 707 import GHC.Generics -#endif -#if !(MIN_VERSION_base(4,8,0)) -import Data.Foldable -import Data.Monoid -#endif - -- | 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 ,Generic ,Generic1 -#endif - ) + deriving (Eq,Ord,Show,Read,Generic,Generic1,Data) -#ifdef LIFTED_FUNCTOR_CLASSES instance Show1 f => Show2 (FreeF f) where liftShowsPrec2 spa _sla _spb _slb d (Pure a) = showsUnaryWith spa "Pure" d a @@ -99,13 +85,7 @@ instance (Show1 f, Show a) => Show1 (FreeF f a) where liftShowsPrec = liftShowsPrec2 showsPrec showList -#else -instance (Show1 f, Show a) => Show1 (FreeF f a) where - showsPrec1 d (Pure a) = showParen (d > 10) $ showString "Pure " . showsPrec 11 a - showsPrec1 d (Free as) = showParen (d > 10) $ showString "Free " . showsPrec1 11 as -#endif -#ifdef LIFTED_FUNCTOR_CLASSES instance Read1 f => Read2 (FreeF f) where liftReadsPrec2 rpa _rla rpb rlb = readsData $ readsUnaryWith rpa "Pure" Pure `mappend` @@ -113,19 +93,7 @@ instance (Read1 f, Read a) => Read1 (FreeF f a) where liftReadsPrec = liftReadsPrec2 readsPrec readList -#else -instance (Read1 f, Read a) => Read1 (FreeF f a) 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 m, t) - | ("Free", s) <- lex r' - , (m, t) <- readsPrec1 11 s]) r -#endif -#ifdef LIFTED_FUNCTOR_CLASSES 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 @@ -133,14 +101,7 @@ instance (Eq1 f, Eq a) => Eq1 (FreeF f a) where liftEq = liftEq2 (==) -#else -instance (Eq1 f, Eq a) => Eq1 (FreeF f a) where - Pure a `eq1` Pure b = a == b - Free as `eq1` Free bs = as `eq1` bs - _ `eq1` _ = False -#endif -#ifdef LIFTED_FUNCTOR_CLASSES instance Ord1 f => Ord2 (FreeF f) where liftCompare2 cmp _ (Pure a) (Pure b) = cmp a b liftCompare2 _ _ (Pure _) (Free _) = LT @@ -149,13 +110,6 @@ instance (Ord1 f, Ord a) => Ord1 (FreeF f a) where liftCompare = liftCompare2 compare -#else -instance (Ord1 f, Ord a) => Ord1 (FreeF f a) where - Pure a `compare1` Pure b = a `compare` b - Pure _ `compare1` Free _ = LT - Free _ `compare1` Pure _ = GT - Free fa `compare1` Free fb = fa `compare1` fb -#endif instance Functor f => Functor (FreeF f a) where fmap _ (Pure a) = Pure a @@ -208,41 +162,22 @@ free = FreeT . Identity {-# INLINE free #-} -#ifdef LIFTED_FUNCTOR_CLASSES instance (Eq1 f, Eq1 m, Eq a) => Eq (FreeT f m a) where -#else -instance (Functor f, Eq1 f, Functor m, Eq1 m, Eq a)=> Eq (FreeT f m a) where -#endif (==) = eq1 -#ifdef LIFTED_FUNCTOR_CLASSES 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 -#else -instance (Functor f, Eq1 f, Functor m, Eq1 m) => Eq1 (FreeT f m) where - eq1 = on eq1 (fmap (Lift1 . fmap Lift1) . runFreeT) -#endif -#ifdef LIFTED_FUNCTOR_CLASSES instance (Ord1 f, Ord1 m, Ord a) => Ord (FreeT f m a) where -#else -instance (Functor f, Ord1 f, Functor m, Ord1 m, Ord a) => Ord (FreeT f m a) where -#endif compare = compare1 -#ifdef LIFTED_FUNCTOR_CLASSES 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 -#else -instance (Functor f, Ord1 f, Functor m, Ord1 m) => Ord1 (FreeT f m) where - compare1 = on compare1 (fmap (Lift1 . fmap Lift1) . runFreeT) -#endif -#ifdef LIFTED_FUNCTOR_CLASSES instance (Show1 f, Show1 m) => Show1 (FreeT f m) where liftShowsPrec sp sl = go where @@ -250,20 +185,10 @@ go d (FreeT x) = showsUnaryWith (liftShowsPrec (liftShowsPrec2 sp sl go goList) (liftShowList2 sp sl go goList)) "FreeT" d x -#else -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) -#endif -#ifdef LIFTED_FUNCTOR_CLASSES instance (Show1 f, Show1 m, Show a) => Show (FreeT f m a) where -#else -instance (Functor f, Show1 f, Functor m, Show1 m, Show a) => Show (FreeT f m a) where -#endif showsPrec = showsPrec1 -#ifdef LIFTED_FUNCTOR_CLASSES instance (Read1 f, Read1 m) => Read1 (FreeT f m) where liftReadsPrec rp rl = go where @@ -271,21 +196,12 @@ go = readsData $ readsUnaryWith (liftReadsPrec (liftReadsPrec2 rp rl go goList) (liftReadList2 rp rl go goList)) "FreeT" FreeT -#else -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] -#endif -#ifdef LIFTED_FUNCTOR_CLASSES instance (Read1 f, Read1 m, Read a) => Read (FreeT f m a) where -#else -instance (Functor f, Read1 f, Functor m, Read1 m, Read a) => Read (FreeT f m a) where -#endif 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) @@ -308,12 +224,14 @@ Pure a -> runFreeT (f a) Free w -> return (Free (fmap (>>= f) w)) - fail = Fail.fail - -instance (Functor f, Monad m) => Fail.MonadFail (FreeT f m) where +#if !MIN_VERSION_base(4,13,0) fail e = FreeT (fail e) +#endif -instance MonadTrans (FreeT f) where +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 #-} @@ -344,20 +262,16 @@ 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 @@ -415,9 +329,9 @@ -- | 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 -- | The very definition of a free monad transformer is that given a natural -- transformation you get a monad transformer homomorphism. @@ -527,80 +441,9 @@ -- @ -- 'intercalateT' f ≡ 'retractT' . 'intersperseT' f -- @ -#if __GLASGOW_HASKELL__ < 710 -intercalateT :: (Monad m, MonadTrans t, Monad (t m), Functor (t m)) => t m a -> FreeT (t m) m b -> t m b -#else intercalateT :: (Monad m, MonadTrans t, Monad (t m)) => t m a -> FreeT (t m) m b -> t m b -#endif 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 diff --git a/src/Control/Monad/Trans/Free/Ap.hs b/src/Control/Monad/Trans/Free/Ap.hs --- a/src/Control/Monad/Trans/Free/Ap.hs +++ b/src/Control/Monad/Trans/Free/Ap.hs @@ -1,14 +1,12 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE Rank2Types #-} -#if __GLASGOW_HASKELL__ >= 707 -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -#endif -#include "free-common.h" +{-# LANGUAGE Safe #-} -------------------------------------------------------------------------------- -- | @@ -56,31 +54,19 @@ import Control.Monad.Error.Class import Control.Monad.Cont.Class import Data.Functor.Bind hiding (join) -import Data.Functor.Classes.Compat +import Data.Functor.Classes import Data.Functor.Identity import Data.Traversable import Data.Bifunctor import Data.Bifoldable import Data.Bitraversable import Data.Data -#if __GLASGOW_HASKELL__ >= 707 import GHC.Generics -#endif -#if !(MIN_VERSION_base(4,8,0)) -import Data.Foldable -import Data.Monoid -#endif - -- | 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 ,Generic, Generic1 -#endif - ) + deriving (Eq,Ord,Show,Read,Data,Generic,Generic1) -#ifdef LIFTED_FUNCTOR_CLASSES instance Show1 f => Show2 (FreeF f) where liftShowsPrec2 spa _sla _spb _slb d (Pure a) = showsUnaryWith spa "Pure" d a @@ -89,13 +75,7 @@ instance (Show1 f, Show a) => Show1 (FreeF f a) where liftShowsPrec = liftShowsPrec2 showsPrec showList -#else -instance (Show1 f, Show a) => Show1 (FreeF f a) where - showsPrec1 d (Pure a) = showParen (d > 10) $ showString "Pure " . showsPrec 11 a - showsPrec1 d (Free as) = showParen (d > 10) $ showString "Free " . showsPrec1 11 as -#endif -#ifdef LIFTED_FUNCTOR_CLASSES instance Read1 f => Read2 (FreeF f) where liftReadsPrec2 rpa _rla rpb rlb = readsData $ readsUnaryWith rpa "Pure" Pure `mappend` @@ -103,19 +83,7 @@ instance (Read1 f, Read a) => Read1 (FreeF f a) where liftReadsPrec = liftReadsPrec2 readsPrec readList -#else -instance (Read1 f, Read a) => Read1 (FreeF f a) 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 m, t) - | ("Free", s) <- lex r' - , (m, t) <- readsPrec1 11 s]) r -#endif -#ifdef LIFTED_FUNCTOR_CLASSES 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 @@ -123,14 +91,7 @@ instance (Eq1 f, Eq a) => Eq1 (FreeF f a) where liftEq = liftEq2 (==) -#else -instance (Eq1 f, Eq a) => Eq1 (FreeF f a) where - Pure a `eq1` Pure b = a == b - Free as `eq1` Free bs = as `eq1` bs - _ `eq1` _ = False -#endif -#ifdef LIFTED_FUNCTOR_CLASSES instance Ord1 f => Ord2 (FreeF f) where liftCompare2 cmp _ (Pure a) (Pure b) = cmp a b liftCompare2 _ _ (Pure _) (Free _) = LT @@ -139,13 +100,6 @@ instance (Ord1 f, Ord a) => Ord1 (FreeF f a) where liftCompare = liftCompare2 compare -#else -instance (Ord1 f, Ord a) => Ord1 (FreeF f a) where - Pure a `compare1` Pure b = a `compare` b - Pure _ `compare1` Free _ = LT - Free _ `compare1` Pure _ = GT - Free fa `compare1` Free fb = fa `compare1` fb -#endif instance Functor f => Functor (FreeF f a) where fmap _ (Pure a) = Pure a @@ -198,41 +152,28 @@ free = FreeT . Identity {-# INLINE free #-} -#ifdef LIFTED_FUNCTOR_CLASSES +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 -#else -instance (Functor f, Eq1 f, Functor m, Eq1 m, Eq a)=> Eq (FreeT f m a) where -#endif (==) = eq1 -#ifdef LIFTED_FUNCTOR_CLASSES 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 -#else -instance (Functor f, Eq1 f, Functor m, Eq1 m) => Eq1 (FreeT f m) where - eq1 = on eq1 (fmap (Lift1 . fmap Lift1) . runFreeT) -#endif -#ifdef LIFTED_FUNCTOR_CLASSES instance (Ord1 f, Ord1 m, Ord a) => Ord (FreeT f m a) where -#else -instance (Functor f, Ord1 f, Functor m, Ord1 m, Ord a) => Ord (FreeT f m a) where -#endif compare = compare1 -#ifdef LIFTED_FUNCTOR_CLASSES 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 -#else -instance (Functor f, Ord1 f, Functor m, Ord1 m) => Ord1 (FreeT f m) where - compare1 = on compare1 (fmap (Lift1 . fmap Lift1) . runFreeT) -#endif -#ifdef LIFTED_FUNCTOR_CLASSES instance (Show1 f, Show1 m) => Show1 (FreeT f m) where liftShowsPrec sp sl = go where @@ -240,20 +181,10 @@ go d (FreeT x) = showsUnaryWith (liftShowsPrec (liftShowsPrec2 sp sl go goList) (liftShowList2 sp sl go goList)) "FreeT" d x -#else -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) -#endif -#ifdef LIFTED_FUNCTOR_CLASSES instance (Show1 f, Show1 m, Show a) => Show (FreeT f m a) where -#else -instance (Functor f, Show1 f, Functor m, Show1 m, Show a) => Show (FreeT f m a) where -#endif showsPrec = showsPrec1 -#ifdef LIFTED_FUNCTOR_CLASSES instance (Read1 f, Read1 m) => Read1 (FreeT f m) where liftReadsPrec rp rl = go where @@ -261,26 +192,17 @@ go = readsData $ readsUnaryWith (liftReadsPrec (liftReadsPrec2 rp rl go goList) (liftReadList2 rp rl go goList)) "FreeT" FreeT -#else -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] -#endif -#ifdef LIFTED_FUNCTOR_CLASSES instance (Read1 f, Read1 m, Read a) => Read (FreeT f m a) where -#else -instance (Functor f, Read1 f, Functor m, Read1 m, Read a) => Read (FreeT f m a) where -#endif 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) -instance (Applicative f, Applicative m, Monad m) => Applicative (FreeT f m) where - pure a = FreeT (return (Pure a)) +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') @@ -289,7 +211,7 @@ g (Free fs) (Free as) = Free $ (<*>) <$> fs <*> as {-# INLINE (<*>) #-} -instance (Apply f, Apply m, Monad m) => Apply (FreeT f m) where +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 @@ -301,32 +223,34 @@ Pure a -> runFreeT (f a) Free w -> return (Free (fmap (>>- f) w)) -instance (Applicative f, Applicative m, Monad m) => Monad (FreeT f m) where +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)) - fail = Fail.fail - -instance (Applicative f, Applicative m, Monad m) => Fail.MonadFail (FreeT f m) where +#if !MIN_VERSION_base(4,13,0) fail e = FreeT (fail e) +#endif -instance MonadTrans (FreeT f) where +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, Applicative m, MonadIO m) => MonadIO (FreeT f m) where +instance (Applicative f, MonadIO m) => MonadIO (FreeT f m) where liftIO = lift . liftIO {-# INLINE liftIO #-} -instance (Applicative f, Applicative m, MonadReader r m) => MonadReader r (FreeT f m) where +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, Applicative m, MonadWriter w m) => MonadWriter w (FreeT f m) where +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) @@ -339,49 +263,45 @@ 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 (Applicative f, Applicative m, MonadState s m) => MonadState s (FreeT f m) where +instance (Applicative 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 (Applicative f, Applicative m, MonadError e m) => MonadError e (FreeT f m) where +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, Applicative m, MonadCont m) => MonadCont (FreeT f m) where +instance (Applicative f, MonadCont m) => MonadCont (FreeT f m) where callCC f = FreeT $ callCC (\k -> runFreeT $ f (lift . k . Pure)) -instance (Applicative f, Applicative m, MonadPlus m) => Alternative (FreeT f m) where +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, Applicative m, MonadPlus m) => MonadPlus (FreeT f m) where +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, Applicative m, Monad m) => MonadFree f (FreeT f m) where +instance (Applicative f, Monad m) => MonadFree f (FreeT f m) where wrap = FreeT . return . Free {-# INLINE wrap #-} -instance (Applicative f, Applicative m, MonadThrow m) => MonadThrow (FreeT f m) where +instance (Applicative f, MonadThrow m) => MonadThrow (FreeT f m) where throwM = lift . throwM {-# INLINE throwM #-} -instance (Applicative f, Applicative m, MonadCatch m) => MonadCatch (FreeT f m) where +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 #-} @@ -412,9 +332,9 @@ -- | 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, Applicative 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, '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 @@ -462,7 +382,7 @@ -- -- Calling @'retract' '.' 'cutoff' n@ is always terminating, provided each of the -- steps in the iteration is terminating. -cutoff :: (Applicative f, Applicative m, Monad m) => Integer -> FreeT f m a -> FreeT f m (Maybe a) +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 @@ -494,7 +414,7 @@ -- 'intersperseT' f '.' 'lift' ≡ 'lift' -- 'intersperseT' f '.' 'wrap' ≡ 'wrap' '.' 'fmap' ('iterTM' ('wrap' '.' ('<$' f) '.' 'wrap')) -- @ -intersperseT :: (Monad m, Applicative m, Applicative f) => f a -> FreeT f m b -> FreeT f m b +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 @@ -515,80 +435,9 @@ -- @ -- 'intercalateT' f ≡ 'retractT' . 'intersperseT' f -- @ -#if __GLASGOW_HASKELL__ < 710 -intercalateT :: (Monad m, MonadTrans t, Monad (t m), Applicative (t m)) => t m a -> FreeT (t m) m b -> t m b -#else intercalateT :: (Monad m, MonadTrans t, Monad (t m)) => t m a -> FreeT (t m) m b -> t m b -#endif 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 diff --git a/src/Control/Monad/Trans/Free/Church.hs b/src/Control/Monad/Trans/Free/Church.hs --- a/src/Control/Monad/Trans/Free/Church.hs +++ b/src/Control/Monad/Trans/Free/Church.hs @@ -1,9 +1,8 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Safe #-} {-# LANGUAGE UndecidableInstances #-} -#include "free-common.h" ----------------------------------------------------------------------------- -- | @@ -49,6 +48,7 @@ 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 @@ -63,42 +63,21 @@ import qualified Data.Foldable as F import qualified Data.Traversable as T import Data.Functor.Bind hiding (join) -import Data.Functor.Classes.Compat - -#if !(MIN_VERSION_base(4,8,0)) -import Data.Foldable (Foldable) -import Data.Traversable (Traversable) -#endif +import Data.Functor.Classes -- | The \"free monad transformer\" for a functor @f@ newtype FT f m a = FT { runFT :: forall r. (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r } -#ifdef LIFTED_FUNCTOR_CLASSES 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, Ord1 f, Ord1 m) => Ord1 (FT f m) where liftCompare cmp x y= liftCompare cmp (fromFT x) (fromFT y) -#else -instance ( Functor f, Monad m, Eq1 f, Eq1 m -# if !(MIN_VERSION_base(4,8,0)) - , Functor m -# endif - ) => Eq1 (FT f m) where - eq1 x y = eq1 (fromFT x) (fromFT y) -instance ( Functor f, Monad m, Ord1 f, Ord1 m -# if !(MIN_VERSION_base(4,8,0)) - , Functor m -# endif - ) => Ord1 (FT f m) where - compare1 x y = compare1 (fromFT x) (fromFT y) -#endif - -instance (Eq1 (FT f m), Eq a) => Eq (FT f m a) where +instance (Functor f, Monad m, Eq1 f, Eq1 m, Eq a) => Eq (FT f m a) where (==) = eq1 -instance (Ord1 (FT f m), Ord a) => Ord (FT f m a) where +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 @@ -118,6 +97,10 @@ return = pure FT fk >>= f = FT $ \b fr -> fk (\d -> runFT (f d) b fr) fr +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) @@ -138,13 +121,11 @@ 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) (\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 @@ -175,20 +156,16 @@ {-# 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 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 @@ -267,11 +244,7 @@ -- @ -- 'retract' . 'liftF' = 'id' -- @ -#if __GLASGOW_HASKELL__ < 710 -retract :: (Functor f, Monad f) => F f a -> f a -#else retract :: Monad f => F f a -> f a -#endif retract m = runF m return join {-# INLINE retract #-} @@ -302,8 +275,8 @@ -- -- This is based on the \"Free Monads for Less\" series of articles by Edward Kmett: -- --- --- +-- +-- -- -- and \"Asymptotic Improvement of Computations over Free Monads\" by Janis Voightländer: -- diff --git a/src/Control/Monad/Trans/Iter.hs b/src/Control/Monad/Trans/Iter.hs --- a/src/Control/Monad/Trans/Iter.hs +++ b/src/Control/Monad/Trans/Iter.hs @@ -1,10 +1,11 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Rank2Types #-} -{-# LANGUAGE DeriveDataTypeable #-} -#include "free-common.h" +{-# LANGUAGE Safe #-} +{-# LANGUAGE StandaloneDeriving #-} ----------------------------------------------------------------------------- -- | @@ -85,18 +86,13 @@ import Data.Bitraversable import Data.Either import Data.Functor.Bind hiding (join) -import Data.Functor.Classes.Compat +import Data.Functor.Classes import Data.Functor.Identity import Data.Semigroup.Foldable import Data.Semigroup.Traversable import Data.Typeable import Data.Data -#if !(MIN_VERSION_base(4,8,0)) -import Data.Foldable hiding (fold) -import Data.Traversable hiding (mapM) -#endif - #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup #endif @@ -107,9 +103,6 @@ -- '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 @@ -128,41 +121,22 @@ runIter = runIdentity . runIterT {-# INLINE runIter #-} -#ifdef LIFTED_FUNCTOR_CLASSES instance (Eq1 m) => Eq1 (IterT m) where liftEq eq = go where go (IterT x) (IterT y) = liftEq (liftEq2 eq go) x y -#else -instance (Functor m, Eq1 m) => Eq1 (IterT m) where - eq1 = on eq1 (fmap (fmap Lift1) . runIterT) -#endif -#ifdef LIFTED_FUNCTOR_CLASSES instance (Eq1 m, Eq a) => Eq (IterT m a) where -#else -instance (Functor m, Eq1 m, Eq a) => Eq (IterT m a) where -#endif (==) = eq1 -#ifdef LIFTED_FUNCTOR_CLASSES instance (Ord1 m) => Ord1 (IterT m) where liftCompare cmp = go where go (IterT x) (IterT y) = liftCompare (liftCompare2 cmp go) x y -#else -instance (Functor m, Ord1 m) => Ord1 (IterT m) where - compare1 = on compare1 (fmap (fmap Lift1) . runIterT) -#endif -#ifdef LIFTED_FUNCTOR_CLASSES instance (Ord1 m, Ord a) => Ord (IterT m a) where -#else -instance (Functor m, Ord1 m, Ord a) => Ord (IterT m a) where -#endif compare = compare1 -#ifdef LIFTED_FUNCTOR_CLASSES instance (Show1 m) => Show1 (IterT m) where liftShowsPrec sp sl = go where @@ -170,20 +144,10 @@ go d (IterT x) = showsUnaryWith (liftShowsPrec (liftShowsPrec2 sp sl go goList) (liftShowList2 sp sl go goList)) "IterT" d x -#else -instance (Functor m, Show1 m) => Show1 (IterT m) where - showsPrec1 d (IterT m) = showParen (d > 10) $ - showString "IterT " . showsPrec1 11 (fmap (fmap Lift1) m) -#endif -#ifdef LIFTED_FUNCTOR_CLASSES instance (Show1 m, Show a) => Show (IterT m a) where -#else -instance (Functor m, Show1 m, Show a) => Show (IterT m a) where -#endif showsPrec = showsPrec1 -#ifdef LIFTED_FUNCTOR_CLASSES instance (Read1 m) => Read1 (IterT m) where liftReadsPrec rp rl = go where @@ -191,17 +155,8 @@ go = readsData $ readsUnaryWith (liftReadsPrec (liftReadsPrec2 rp rl go goList) (liftReadList2 rp rl go goList)) "IterT" IterT -#else -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] -#endif -#ifdef LIFTED_FUNCTOR_CLASSES instance (Read1 m, Read a) => Read (IterT m a) where -#else -instance (Functor m, Read1 m, Read a) => Read (IterT m a) where -#endif readsPrec = readsPrec1 instance Monad m => Functor (IterT m) where @@ -219,8 +174,10 @@ {-# 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 @@ -294,20 +251,16 @@ 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 @@ -467,44 +420,11 @@ (Right a, Left b) -> return . Right $ liftM (<> b) a (Right a, Right b) -> return . Right $ a <> b -#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 #-} - -#else -#define Typeable1 Typeable -#endif - -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 diff --git a/src/Data/Functor/Classes/Compat.hs b/src/Data/Functor/Classes/Compat.hs deleted file mode 100644 --- a/src/Data/Functor/Classes/Compat.hs +++ /dev/null @@ -1,43 +0,0 @@ -#include "free-common.h" -#ifdef LIFTED_FUNCTOR_CLASSES -module Data.Functor.Classes.Compat ( - mappend, - module Data.Functor.Classes, - ) where - -import Data.Functor.Classes - -#if !(MIN_VERSION_base(4,8,0)) -import Data.Monoid (mappend) -#endif -#else -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Data.Functor.Classes.Compat ( - Lift1 (..), - on, - module Data.Functor.Classes, - ) where - -------------------------------------------------------------------------------- --- transformers-0.4 helpers, copied from prelude-extras -------------------------------------------------------------------------------- - -# if !(MIN_VERSION_base(4,8,0)) -import Data.Foldable -import Data.Traversable -# endif -import Data.Functor.Classes -import Data.Function (on) - --- If Show1 and Read1 are ever derived by the same mechanism as --- Show and Read, rather than GND, that will change their behavior --- here. -newtype Lift1 f a = Lift1 { lower1 :: f a } - deriving (Functor, Foldable, Traversable, Eq1, Ord1, Show1, Read1) - -instance (Eq1 f, Eq a) => Eq (Lift1 f a) where (==) = eq1 -instance (Ord1 f, Ord a) => Ord (Lift1 f a) where compare = compare1 -instance (Show1 f, Show a) => Show (Lift1 f a) where showsPrec = showsPrec1 -instance (Read1 f, Read a) => Read (Lift1 f a) where readsPrec = readsPrec1 -#endif