lexi-lambda/freer-simple
1
1
Fork 0
mirror of https://github.com/lexi-lambda/freer-simple.git synced 2024-09-11 08:05:51 +03:00
Code Issues Projects Releases Wiki Activity

Reformat project to make the style a little more idiomatic

Browse Source
This commit is contained in:
Alexis King 2017-12-06 11:45:33 -08:00
parent 4b2ffbb8a0
commit 1cd5705bef
36 changed files with 539 additions and 1152 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

168
.gitignore vendored
View File

@ -1,168 +1,2 @@
# This file was generated using:
#
# https://github.com/trskop/snippets/blob/master/scripts/mkgitignore.sh
#
# and it's based on snippets taken from:
#
# https://github.com/github/gitignore
# {{{ Global/Archives.gitignore ###############################################
# It's better to unpack these files and commit the raw source because
# git has its own built in compression methods.
*.7z
*.jar
*.rar
*.zip
*.gz
*.bzip
*.bz2
*.xz
*.lzma
*.cab
#packing-only formats
*.iso
*.tar
#package management formats
*.dmg
*.xpi
*.gem
*.egg
*.deb
*.rpm
*.msi
*.msm
*.msp
# }}} Global/Archives.gitignore ###############################################
# {{{ Global/Emacs.gitignore ##################################################
# -*- mode: gitignore; -*-
*~
\#*\#
/.emacs.desktop
/.emacs.desktop.lock
*.elc
auto-save-list
tramp
.\#*
# Org-mode
.org-id-locations
*_archive
# flymake-mode
*_flymake.*
# eshell files
/eshell/history
/eshell/lastdir
# elpa packages
/elpa/
# reftex files
*.rel
# AUCTeX auto folder
/auto/
# cask packages
.cask/
dist/
# Flycheck
flycheck_*.el
# server auth directory
/server/
# projectiles files
.projectile
# directory configuration
.dir-locals.el
# }}} Global/Emacs.gitignore ##################################################
# {{{ Global/Linux.gitignore ##################################################
*~
# temporary files which can be created if a process still has a handle open of a deleted file
.fuse_hidden*
# KDE directory preferences
.directory
# Linux trash folder which might appear on any partition or disk
.Trash-*
# .nfs files are created when an open file is removed but is still being accessed
.nfs*
# }}} Global/Linux.gitignore ##################################################
# {{{ Global/Vim.gitignore ####################################################
# swap
[._]*.s[a-v][a-z]
[._]*.sw[a-p]
[._]s[a-v][a-z]
[._]sw[a-p]
# session
Session.vim
# temporary
.netrwhist
*~
# auto-generated tag files
tags
# }}} Global/Vim.gitignore ####################################################
# {{{ Global/Windows.gitignore ################################################
# Windows thumbnail cache files
Thumbs.db
ehthumbs.db
ehthumbs_vista.db
# Folder config file
Desktop.ini
# Recycle Bin used on file shares
$RECYCLE.BIN/
# Windows Installer files
*.cab
*.msi
*.msm
*.msp
# Windows shortcuts
*.lnk
# }}} Global/Windows.gitignore ################################################
# {{{ Haskell.gitignore #######################################################
dist
dist-*
cabal-dev
*.o
*.hi
*.chi
*.chs.h
*.dyn_o
*.dyn_hi
.hpc
.hsenv
.cabal-sandbox/
cabal.sandbox.config
*.prof
*.aux
*.hp
*.eventlog
.stack-work/
cabal.project.local
.HTF/
# }}} Haskell.gitignore #######################################################
# {{{ Local ###################################################################
# Prevent stack.yaml to be commited. Let users decide how they want to use this
# package.
stack.yaml
# }}} Local ###################################################################
*.cabal

32
bench/Core.hs
View File

@ -1,32 +1,8 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
module Main (main) where
import Prelude ((-))
import Control.Monad (replicateM_)
import Control.Applicative (pure)
import Control.Monad ((>>=), (>>), replicateM_)
import Data.Either (Either(Left, Right))
import Data.Function ((.), ($), id)
import Data.Functor (Functor)
import Data.Int (Int)
import Data.Maybe (Maybe)
import Data.Ord ((<=))
import Data.String (String)
import System.IO (IO)
#if MIN_VERSION_mtl(2,2,1)
import qualified Control.Monad.Except as MTL
#else
import qualified Control.Monad.Error as MTL
#endif
import qualified Control.Monad.State as MTL
import qualified Control.Monad.Free as Free
@ -39,9 +15,9 @@ import Control.Monad.Freer.Error (runError, throwError)
import Control.Monad.Freer.State (get, put, runState)
import Control.Monad.Freer.StateRW (ask, tell, runStateR)
import qualified Control.Eff as EE (run)
import qualified Control.Eff.Exception as EE (runExc, throwExc)
import qualified Control.Eff.State.Lazy as EE (runState, get, put)
import qualified Control.Eff as EE
import qualified Control.Eff.Exception as EE
import qualified Control.Eff.State.Lazy as EE
--------------------------------------------------------------------------------
-- State Benchmarks --

10
examples/src/Capitalize.hs
View File

@ -1,8 +1,3 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeOperators #-}
module Capitalize
( Capitalize
, capitalize
@ -10,12 +5,7 @@ module Capitalize
, runCapitalizeM'
) where
import Control.Applicative (pure)
import Data.Char (toUpper)
import Data.Either (Either(Left, Right))
import Data.Function (($), (.))
import Data.List (map)
import Data.String (String)
import Control.Monad.Freer (Member, interpret, send)
import Control.Monad.Freer.Internal (Eff(Val, E), decomp, qApp, tsingleton)

19
examples/src/Console.hs
View File

@ -1,11 +1,3 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
module Console
( Console
, exitSuccess'
@ -17,17 +9,8 @@ module Console
, runConsolePureM
) where
import Prelude (error)
import Control.Applicative (pure)
import Control.Monad ((>>=), (>>))
import Data.Either (either)
import Data.Function (($), (&), (.), const, flip)
import Data.Maybe (Maybe(Just, Nothing))
import Data.String (String)
import Data.Tuple (fst, snd)
import Data.Function ((&))
import System.Exit (exitSuccess)
import System.IO (IO, getLine, putStrLn)
import Control.Monad.Freer (Eff, LastMember, Member, interpretM, reinterpret3, run, runM, send)
import Control.Monad.Freer.Error (Error, runError, throwError)

1
examples/src/Coroutine.hs
View File

@ -1,4 +1,3 @@
{-# LANGUAGE NoImplicitPrelude #-}
module Coroutine () where
-- import Control.Monad.Freer.Coroutine

1
examples/src/Cut.hs
View File

@ -1,4 +1,3 @@
{-# LANGUAGE NoImplicitPrelude #-}
module Cut () where
-- import Control.Monad.Freer.Cut

15
examples/src/Fresh.hs
View File

@ -1,15 +1,8 @@
{-# LANGUAGE NoImplicitPrelude #-}
module Fresh (module Fresh) where
import Data.Function (($), flip)
import Data.Monoid ((<>))
import System.IO (IO)
import Text.Show (show)
import Control.Monad.Freer.Fresh (evalFresh, fresh)
import Control.Monad.Freer.Trace (runTrace, trace)
-- | Generate two fresh values.
--
-- >>> traceFresh
@ -17,7 +10,7 @@ import Control.Monad.Freer.Trace (runTrace, trace)
-- Fresh 1
traceFresh :: IO ()
traceFresh = runTrace $ flip evalFresh 0 $ do
n <- fresh
trace $ "Fresh " <> show n
n' <- fresh
trace $ "Fresh " <> show n'
n <- fresh
trace $ "Fresh " ++ show n
n' <- fresh
trace $ "Fresh " ++ show n'

30
examples/src/Main.hs
View File

@ -1,36 +1,26 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Main (main) where
import Control.Monad ((>>=), forever, when)
import Data.Function (($), (.))
import Data.List (intercalate, lookup, map, null)
import Control.Monad (forever, when)
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import Data.String (String)
import Data.Tuple (fst)
import Data.List (intercalate)
import System.Environment (getArgs)
import System.IO (IO, print, putStrLn)
import Control.Monad.Freer (Eff, Member, run, runM)
import Capitalize (Capitalize, capitalize, runCapitalizeM)
import Console
( Console
, exitSuccess'
, getLine'
, putStrLn'
, runConsolePureM
, runConsoleM
)
( Console
, exitSuccess'
, getLine'
, putStrLn'
, runConsolePureM
, runConsoleM
)
import Coroutine ()
import Cut ()
import Fresh ()
import Trace ()
-------------------------------------------------------------------------------
-- Example
-------------------------------------------------------------------------------
@ -76,4 +66,4 @@ main = getArgs >>= \case
_ -> e
where
e = putStrLn msg
msg = "Usage: prog [" <> intercalate "|" (map fst examples) <> "]"
msg = "Usage: prog [" ++ intercalate "|" (map fst examples) ++ "]"

5
examples/src/Trace.hs
View File

@ -1,9 +1,6 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
module Trace (module Trace) where
import Prelude ((+))
module Trace (module Trace) where
import Control.Applicative ((<$>), (<*>), pure)
import Data.Function (($))

127
freer-effects.cabal
View File

@ -2,37 +2,32 @@
--
-- see: https://github.com/sol/hpack
name: freer-effects
version: 0.3.0.0
synopsis: Implementation of effect system for Haskell.
description: Implementation of effect system for Haskell (actively maintained fork of
<http://hackage.haskell.org/package/freer freer>), which is based on the
work of Oleg Kiselyov et al.:
.
* <http://okmij.org/ftp/Haskell/extensible/more.pdf Freer Monads, More Extensible Effects>
.
* <http://okmij.org/ftp/Haskell/zseq.pdf Reflection without Remorse>
.
* <http://okmij.org/ftp/Haskell/extensible/exteff.pdf Extensible Effects>
.
The key features are:
.
* An efficient effect system for Haskell - as a library!
.
* Reimplementations of several common Haskell monad transformers as effects.
.
* Core components for defining your own Effects.
license-file: LICENSE
tested-with: GHC==8.0.2, GHC==8.0.1, GHC==7.10.3, GHC==7.8.4
category: Control
homepage: https://github.com/IxpertaSolutions/freer-effects#readme
bug-reports: https://github.com/IxpertaSolutions/freer-effects/issues
author: Allele Dev, Ixcom Core Team, and other contributors
maintainer: ixcom-core@ixperta.com
copyright: (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o.
license: BSD3
build-type: Simple
cabal-version: >= 1.10
name: freer-effects
version: 0.3.0.0
synopsis: Implementation of effect system for Haskell.
description: Implementation of effect system for Haskell (actively maintained fork of
<http://hackage.haskell.org/package/freer freer>), which is based on the
work of Oleg Kiselyov et al.:
.
* <http://okmij.org/ftp/Haskell/extensible/more.pdf Freer Monads, More Extensible Effects>
* <http://okmij.org/ftp/Haskell/zseq.pdf Reflection without Remorse>
* <http://okmij.org/ftp/Haskell/extensible/exteff.pdf Extensible Effects>
.
The key features are:
.
* An efficient effect system for Haskell - as a library!
* Reimplementations of several common Haskell monad transformers as effects.
* Core components for defining your own Effects.
category: Control
homepage: https://github.com/lexi-lambda/freer-effects#readme
bug-reports: https://github.com/lexi-lambda/freer-effects/issues
author: Allele Dev, Ixcom Core Team, Alexis King, and other contributors
maintainer: Alexis King <lexi.lambda@gmail.com>
copyright: (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o.; 2017 Alexis King
license: BSD3
license-file: LICENSE
build-type: Simple
cabal-version: >= 1.10
extra-source-files:
changelog.md
@ -40,30 +35,17 @@ extra-source-files:
source-repository head
type: git
location: https://github.com/IxpertaSolutions/freer-effects
flag pedantic
description: Pass additional warning flags and -Werror to GHC.
manual: True
default: False
flag test-hlint
description: Enable test suite that checks sources using HLint.
manual: True
default: False
location: https://github.com/lexi-lambda/freer-effects
library
hs-source-dirs:
src
ghc-options: -Wall -fwarn-tabs -fwarn-implicit-prelude
default-extensions: ConstraintKinds DataKinds DeriveFunctor FlexibleContexts FlexibleInstances GADTs LambdaCase MultiParamTypeClasses RankNTypes ScopedTypeVariables TypeApplications TypeOperators
ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints
build-depends:
base >=4.9 && <5
, natural-transformation >=0.2
base >= 4.9 && < 5
, natural-transformation >= 0.2
, transformers-base
if flag(pedantic)
ghc-options: -Werror
if impl(ghc >=8)
ghc-options: -Wredundant-constraints -Wmissing-import-lists
exposed-modules:
Control.Monad.Freer
Control.Monad.Freer.Coroutine
@ -88,14 +70,11 @@ executable freer-examples
main-is: Main.hs
hs-source-dirs:
examples/src
ghc-options: -Wall -fwarn-tabs -fwarn-implicit-prelude
default-extensions: ConstraintKinds DataKinds DeriveFunctor FlexibleContexts FlexibleInstances GADTs LambdaCase MultiParamTypeClasses RankNTypes ScopedTypeVariables TypeApplications TypeOperators
ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints
build-depends:
base >=4.9 && <5
base >= 4.9 && < 5
, freer-effects
if flag(pedantic)
ghc-options: -Werror
if impl(ghc >=8)
ghc-options: -Wredundant-constraints -Wmissing-import-lists
other-modules:
Capitalize
Console
@ -105,43 +84,20 @@ executable freer-examples
Trace
default-language: Haskell2010
test-suite hlint
type: exitcode-stdio-1.0
main-is: hlint.hs
hs-source-dirs:
tests
ghc-options: -Wall -fwarn-tabs -fwarn-implicit-prelude -threaded -with-rtsopts=-N
build-depends:
base >=4.9 && <5
if flag(pedantic)
ghc-options: -Werror
if impl(ghc >=8)
ghc-options: -Wredundant-constraints -Wmissing-import-lists
if flag(test-hlint)
build-depends:
hlint >=1.9
buildable: True
else
buildable: False
default-language: Haskell2010
test-suite unit
type: exitcode-stdio-1.0
main-is: Tests.hs
hs-source-dirs:
tests
ghc-options: -Wall -fwarn-tabs -fwarn-implicit-prelude
default-extensions: ConstraintKinds DataKinds DeriveFunctor FlexibleContexts FlexibleInstances GADTs LambdaCase MultiParamTypeClasses RankNTypes ScopedTypeVariables TypeApplications TypeOperators
ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints
build-depends:
base >=4.9 && <5
base >= 4.9 && < 5
, QuickCheck
, freer-effects
, tasty
, tasty-hunit
, tasty-quickcheck
if flag(pedantic)
ghc-options: -Werror
if impl(ghc >=8)
ghc-options: -Wredundant-constraints -Wmissing-import-lists
other-modules:
Tests.Coroutine
Tests.Exception
@ -157,16 +113,13 @@ benchmark core
main-is: Core.hs
hs-source-dirs:
bench
ghc-options: -Wall -fwarn-tabs -fwarn-implicit-prelude -O2
default-extensions: ConstraintKinds DataKinds DeriveFunctor FlexibleContexts FlexibleInstances GADTs LambdaCase MultiParamTypeClasses RankNTypes ScopedTypeVariables TypeApplications TypeOperators
ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -O2
build-depends:
base >=4.9 && <5
base >= 4.9 && < 5
, criterion
, extensible-effects >= 1.11 && < 1.12
, free
, freer-effects
, mtl
if flag(pedantic)
ghc-options: -Werror
if impl(ghc >=8)
ghc-options: -Wredundant-constraints -Wmissing-import-lists
default-language: Haskell2010

122
package.yaml
View File

@ -6,66 +6,55 @@ description: |
Implementation of effect system for Haskell (actively maintained fork of
<http://hackage.haskell.org/package/freer freer>), which is based on the
work of Oleg Kiselyov et al.:
.
* <http://okmij.org/ftp/Haskell/extensible/more.pdf Freer Monads, More Extensible Effects>
.
* <http://okmij.org/ftp/Haskell/zseq.pdf Reflection without Remorse>
.
* <http://okmij.org/ftp/Haskell/extensible/exteff.pdf Extensible Effects>
.
* <http://okmij.org/ftp/Haskell/extensible/more.pdf Freer Monads, More Extensible Effects>
* <http://okmij.org/ftp/Haskell/zseq.pdf Reflection without Remorse>
* <http://okmij.org/ftp/Haskell/extensible/exteff.pdf Extensible Effects>
The key features are:
.
* An efficient effect system for Haskell - as a library!
.
* Reimplementations of several common Haskell monad transformers as effects.
.
* Core components for defining your own Effects.
github: IxpertaSolutions/freer-effects
tested-with: GHC==8.0.2, GHC==8.0.1, GHC==7.10.3, GHC==7.8.4
* An efficient effect system for Haskell - as a library!
* Reimplementations of several common Haskell monad transformers as effects.
* Core components for defining your own Effects.
github: lexi-lambda/freer-effects
license: BSD3
author: Allele Dev, Ixcom Core Team, and other contributors
maintainer: ixcom-core@ixperta.com
copyright: (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o.
author: Allele Dev, Ixcom Core Team, Alexis King, and other contributors
maintainer: Alexis King <lexi.lambda@gmail.com>
copyright: (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o.; 2017 Alexis King
extra-source-files:
- README.md
- changelog.md
flags:
pedantic:
description: Pass additional warning flags and -Werror to GHC.
manual: true
default: false
test-hlint:
description: Enable test suite that checks sources using HLint.
manual: true
default: false
when:
- condition: flag(pedantic)
ghc-options:
- -Werror
- condition: impl(ghc >=8)
ghc-options:
# Introduced in GHC 8.
- -Wredundant-constraints
# Older Cabal generates warnings with its Paths_* module.
- -Wmissing-import-lists
- README.md
- changelog.md
ghc-options:
- -Wall
- -fwarn-tabs
- -fwarn-implicit-prelude
- -Wall
- -Wcompat
- -Wincomplete-record-updates
- -Wincomplete-uni-patterns
- -Wredundant-constraints
default-extensions:
- ConstraintKinds
- DataKinds
- DeriveFunctor
- FlexibleContexts
- FlexibleInstances
- GADTs
- LambdaCase
- MultiParamTypeClasses
- RankNTypes
- ScopedTypeVariables
- TypeApplications
- TypeOperators
dependencies:
- base >=4.9 && <5
- base >= 4.9 && < 5
library:
source-dirs: src
dependencies:
- natural-transformation >=0.2
- natural-transformation >= 0.2
- transformers-base
executables:
@ -73,34 +62,18 @@ executables:
source-dirs: examples/src
main: Main.hs
dependencies:
- freer-effects
- freer-effects
tests:
unit:
source-dirs: tests
main: Tests.hs
dependencies:
# TODO: bounds
- QuickCheck
- freer-effects
- tasty
- tasty-hunit
- tasty-quickcheck
hlint:
source-dirs: tests
main: hlint.hs
other-modules: []
ghc-options:
- -threaded
- -with-rtsopts=-N
when:
- condition: flag(test-hlint)
then:
buildable: true
dependencies: [hlint >=1.9]
else:
buildable: false
- QuickCheck
- freer-effects
- tasty
- tasty-hunit
- tasty-quickcheck
benchmarks:
core:
@ -108,9 +81,8 @@ benchmarks:
main: Core.hs
ghc-options: -O2
dependencies:
# TODO: bounds
- criterion
- extensible-effects >= 1.11 && < 1.12
- free
- freer-effects
- mtl
- criterion
- extensible-effects >= 1.11 && < 1.12
- free
- freer-effects
- mtl

14
src/Control/Monad/Freer.hs
View File

@ -1,10 +1,5 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
-- |
-- Module: Control.Monad.Freer
-- Description: Freer - an extensible effects library
@ -50,12 +45,9 @@ module Control.Monad.Freer
, interposeWith
) where
import qualified Control.Monad.Freer.Internal as Internal
import Control.Applicative (pure)
import Control.Monad (Monad, (>>=))
import Control.Natural (type (~>))
import Data.Function ((.))
import qualified Control.Monad.Freer.Internal as Internal
import Control.Monad.Freer.Internal
( Eff

44
src/Control/Monad/Freer/Coroutine.hs
View File

@ -1,8 +1,3 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeOperators #-}
-- |
-- Module: Control.Monad.Freer.Coroutine
-- Description: Composable coroutine effects layer.
@ -16,26 +11,19 @@
--
-- Using <http://okmij.org/ftp/Haskell/extensible/Eff1.hs> as a starting point.
module Control.Monad.Freer.Coroutine
(
-- * Yield Control
Yield(..)
, yield
( -- * Yield Control
Yield(..)
, yield
-- * Handle Yield Effect
, Status(..)
, runC
, interposeC
, replyC
)
where
import Control.Applicative (pure)
import Data.Function (($), (.))
import Data.Functor (Functor)
, Status(..)
, runC
, interposeC
, replyC
) where
import Control.Monad.Freer.Internal (Eff, Member, handleRelay, interpose, send)
-- | A type representing a yielding of control.
--
-- Type variables have following meaning:
@ -57,11 +45,11 @@ yield x f = send (Yield x f)
-- | Represents status of a coroutine.
data Status effs a b r
= Done r
-- ^ Coroutine is done with a result value of type @r@.
| Continue a (b -> Eff effs (Status effs a b r))
-- ^ Reporting a value of the type @a@, and resuming with the value of type
-- @b@, possibly ending with a value of type @x@.
= Done r
-- ^ Coroutine is done with a result value of type @r@.
| Continue a (b -> Eff effs (Status effs a b r))
-- ^ Reporting a value of the type @a@, and resuming with the value of type
-- @b@, possibly ending with a value of type @x@.
-- | Reply to a coroutine effect by returning the Continue constructor.
replyC
@ -77,7 +65,7 @@ runC = handleRelay (pure . Done) replyC
-- | Launch a coroutine and report its status, without handling (removing)
-- 'Yield' from the typelist. This is useful for reducing nested coroutines.
interposeC
:: Member (Yield a b) effs
=> Eff effs r
-> Eff effs (Status effs a b r)
:: Member (Yield a b) effs
=> Eff effs r
-> Eff effs (Status effs a b r)
interposeC = interpose (pure . Done) replyC

14
src/Control/Monad/Freer/Cut.hs
View File

@ -1,7 +1,3 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeOperators #-}
-- |
-- Module: Control.Monad.Freer.Cut
-- Description: An implementation of logical Cut.
@ -16,17 +12,15 @@
--
-- Using <http://okmij.org/ftp/Haskell/extensible/Eff1.hs> as a starting point.
module Control.Monad.Freer.Cut
( CutFalse(..)
, cutFalse
-- , call
)
where
( CutFalse(..)
, cutFalse
-- , call
) where
-- import Control.Monad
import Control.Monad.Freer.Error (Error, throwError)
import Control.Monad.Freer.Internal (Eff, Member)
data CutFalse = CutFalse
-- data Choose a b = Choose [a] b

22
src/Control/Monad/Freer/Error.hs
View File

@ -1,7 +1,3 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeOperators #-}
-- |
-- Module: Control.Monad.Freer.Error
-- Description: An Error effect and handler.
@ -16,21 +12,15 @@
--
-- Using <http://okmij.org/ftp/Haskell/extensible/Eff1.hs> as a starting point.
module Control.Monad.Freer.Error
( Error(..)
, throwError
, runError
, catchError
, handleError
)
where
import Control.Applicative (pure)
import Data.Either (Either(Left, Right))
import Data.Function ((.))
( Error(..)
, throwError
, runError
, catchError
, handleError
) where
import Control.Monad.Freer.Internal (Eff, Member, handleRelay, interpose, send)
--------------------------------------------------------------------------------
-- Exceptions --
--------------------------------------------------------------------------------

32
src/Control/Monad/Freer/Fresh.hs
View File

@ -1,9 +1,3 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeOperators #-}
-- |
-- Module: Control.Monad.Freer.Fresh
-- Description: Generation of fresh integers as an effect.
@ -19,28 +13,18 @@
-- Using <http://okmij.org/ftp/Haskell/extensible/Eff1.hs> as a starting point.
module Control.Monad.Freer.Fresh
( Fresh(..)
, fresh
, runFresh
, evalFresh
, runFresh'
)
where
import Prelude (($!), (+))
import Control.Applicative (pure)
import Data.Function ((.))
import Data.Functor ((<$>))
import Data.Int (Int)
import Data.Tuple (fst)
( Fresh(..)
, fresh
, runFresh
, evalFresh
, runFresh'
) where
import Control.Monad.Freer.Internal (Eff, Member, handleRelayS, send)
-- | Fresh effect model.
data Fresh a where
Fresh :: Fresh Int
Fresh :: Fresh Int
-- | Request a fresh effect.
fresh :: Member Fresh effs => Eff effs Int
@ -50,7 +34,7 @@ fresh = send Fresh
-- return value includes the next fresh value.
runFresh :: Eff (Fresh ': effs) a -> Int -> Eff effs (a, Int)
runFresh m s =
handleRelayS s (\s' a -> pure (a, s')) (\s' Fresh k -> (k $! s' + 1) s') m
handleRelayS s (\s' a -> pure (a, s')) (\s' Fresh k -> (k $! s' + 1) s') m
-- | Handler for 'Fresh' effects, with an 'Int' for a starting value. Discards
-- the next fresh value.

202
src/Control/Monad/Freer/Internal.hs
View File

@ -1,15 +1,8 @@
{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- Due to sendM.
{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
-- The following is needed to define MonadPlus instance. It is decidable
-- (there is no recursion!), but GHC cannot see that.
@ -17,10 +10,7 @@
-- TODO: Remove once GHC can deduce the decidability of this instance.
{-# LANGUAGE UndecidableInstances #-}
-- Due to re-export of Data.FTCQueue, and Data.OpenUnion.
{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}
-- Due to sendM.
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
-- |
-- Module: Control.Monad.Freer.Internal
@ -39,66 +29,56 @@
--
-- Using <http://okmij.org/ftp/Haskell/extensible/Eff1.hs> as a starting point.
module Control.Monad.Freer.Internal
(
-- * Effect Monad
Eff(..)
, Arr
, Arrs
( -- * Effect Monad
Eff(..)
, Arr
, Arrs
-- ** Open Union
--
-- | Open Union (type-indexed co-product) of effects.
, module Data.OpenUnion
, module Data.OpenUnion
-- ** Fast Type-aligned Queue
--
-- | Fast type-aligned queue optimized to effectful functions of type
-- @(a -> m b)@.
, module Data.FTCQueue
, module Data.FTCQueue
-- ** Sending Arbitrary Effect
, send
, sendM
, send
, sendM
-- ** Lifting Effect Stacks
, raise
, raise
-- * Handling Effects
, run
, runM
, run
, runM
-- ** Building Effect Handlers
, handleRelay
, handleRelayS
, interpose
, replaceRelay
, replaceRelayS
, replaceRelayN
, handleRelay
, handleRelayS
, interpose
, replaceRelay
, replaceRelayS
, replaceRelayN
-- *** Low-level Functions for Building Effect Handlers
, qApp
, qComp
, qApp
, qComp
-- ** Nondeterminism Effect
, NonDet(..)
)
where
, NonDet(..)
) where
import Prelude (error) -- Function error is used for imposible cases.
import Control.Applicative (Alternative((<|>), empty), Applicative((<*>), pure))
import Control.Monad (Monad((>>=), return), MonadPlus(mplus, mzero))
import Control.Monad.Base (MonadBase(liftBase))
import Data.Bool (Bool)
import Data.Either (Either(Left, Right))
import Data.Function (($), (.))
import Data.Functor (Functor(fmap))
import Data.Maybe (Maybe(Just))
import Control.Applicative (Alternative(..))
import Control.Monad (MonadPlus(..))
import Control.Monad.Base (MonadBase, liftBase)
import Data.FTCQueue
import Data.OpenUnion
-- | Effectful arrow type: a function from @a :: *@ to @b :: *@ that also does
-- effects denoted by @effs :: [* -> *]@.
type Arr effs a b = a -> Eff effs b
@ -113,20 +93,20 @@ type Arrs effs a b = FTCQueue (Eff effs) a b
-- different types of effects can be interleaved, and so that the produced code
-- is efficient.
data Eff effs a
= Val a
-- ^ Pure value (@'return' = 'pure' = 'Val'@).
| forall b. E (Union effs b) (Arrs effs b a)
-- ^ Sending a request of type @Union effs@ with the continuation
-- @'Arrs' r b a@.
= Val a
-- ^ Pure value (@'return' = 'pure' = 'Val'@).
| forall b. E (Union effs b) (Arrs effs b a)
-- ^ Sending a request of type @Union effs@ with the continuation
-- @'Arrs' r b a@.
-- | Function application in the context of an array of effects,
-- @'Arrs' effs b w@.
qApp :: Arrs effs b w -> b -> Eff effs w
qApp q' x = case tviewl q' of
TOne k -> k x
k :| t -> case k x of
Val y -> qApp t y
E u q -> E u (q >< t)
TOne k -> k x
k :| t -> case k x of
Val y -> qApp t y
E u q -> E u (q >< t)
-- | Composition of effectful arrows ('Arrs'). Allows for the caller to change
-- the effect environment, as well.
@ -134,31 +114,27 @@ qComp :: Arrs effs a b -> (Eff effs b -> Eff effs' c) -> Arr effs' a c
qComp g h a = h $ qApp g a
instance Functor (Eff effs) where
fmap f (Val x) = Val (f x)
fmap f (E u q) = E u (q |> (Val . f))
{-# INLINE fmap #-}
fmap f (Val x) = Val (f x)
fmap f (E u q) = E u (q |> (Val . f))
{-# INLINE fmap #-}
instance Applicative (Eff effs) where
pure = Val
{-# INLINE pure #-}
pure = Val
{-# INLINE pure #-}
Val f <*> Val x = Val $ f x
Val f <*> E u q = E u (q |> (Val . f))
E u q <*> m = E u (q |> (`fmap` m))
{-# INLINE (<*>) #-}
Val f <*> Val x = Val $ f x
Val f <*> E u q = E u (q |> (Val . f))
E u q <*> m = E u (q |> (`fmap` m))
{-# INLINE (<*>) #-}
instance Monad (Eff effs) where
-- Future versions of GHC will consider any other definition as error.
return = pure
{-# INLINE return #-}
Val x >>= k = k x
E u q >>= k = E u (q |> k)
{-# INLINE (>>=) #-}
Val x >>= k = k x
E u q >>= k = E u (q |> k)
{-# INLINE (>>=) #-}
instance (MonadBase b m, LastMember m effs) => MonadBase b (Eff effs) where
liftBase = sendM . liftBase
{-# INLINE liftBase #-}
liftBase = sendM . liftBase
{-# INLINE liftBase #-}
-- | Send a request and wait for a reply.
send :: Member eff effs => eff a -> Eff effs a
@ -191,18 +167,18 @@ run _ = error "Internal:run - This (E) should never happen"
runM :: Monad m => Eff '[m] a -> m a
runM (Val x) = return x
runM (E u q) = case extract u of
mb -> mb >>= runM . qApp q
-- The other case is unreachable since Union [] a cannot be constructed.
-- Therefore, run is a total function if its argument terminates.
mb -> mb >>= runM . qApp q
-- The other case is unreachable since Union [] a cannot be constructed.
-- Therefore, run is a total function if its argument terminates.
-- | Like 'replaceRelay', but with support for an explicit state to help
-- implement the interpreter.
replaceRelayS
:: s
-> (s -> a -> Eff (v ': effs) w)
-> (forall x. s -> t x -> (s -> Arr (v ': effs) x w) -> Eff (v ': effs) w)
-> Eff (t ': effs) a
-> Eff (v ': effs) w
:: s
-> (s -> a -> Eff (v ': effs) w)
-> (forall x. s -> t x -> (s -> Arr (v ': effs) x w) -> Eff (v ': effs) w)
-> Eff (t ': effs) a
-> Eff (v ': effs) w
replaceRelayS s' pure' bind = loop s'
where
loop s (Val x) = pure' s x
@ -217,10 +193,10 @@ replaceRelayS s' pure' bind = loop s'
-- defined in terms of other ones without leaking intermediary implementation
-- details through the type signature.
replaceRelay
:: (a -> Eff (v ': effs) w)
-> (forall x. t x -> Arr (v ': effs) x w -> Eff (v ': effs) w)
-> Eff (t ': effs) a
-> Eff (v ': effs) w
:: (a -> Eff (v ': effs) w)
-> (forall x. t x -> Arr (v ': effs) x w -> Eff (v ': effs) w)
-> Eff (t ': effs) a
-> Eff (v ': effs) w
replaceRelay pure' bind = loop
where
loop (Val x) = pure' x
@ -250,13 +226,13 @@ replaceRelayN pure' bind = loop
-- | Given a request, either handle it or relay it.
handleRelay
:: (a -> Eff effs b)
-- ^ Handle a pure value.
-> (forall v. eff v -> Arr effs v b -> Eff effs b)
-- ^ Handle a request for effect of type @eff :: * -> *@.
-> Eff (eff ': effs) a
-> Eff effs b
-- ^ Result with effects of type @eff :: * -> *@ handled.
:: (a -> Eff effs b)
-- ^ Handle a pure value.
-> (forall v. eff v -> Arr effs v b -> Eff effs b)
-- ^ Handle a request for effect of type @eff :: * -> *@.
-> Eff (eff ': effs) a
-> Eff effs b
-- ^ Result with effects of type @eff :: * -> *@ handled.
handleRelay ret h = loop
where
loop (Val x) = ret x
@ -270,14 +246,14 @@ handleRelay ret h = loop
-- @s :: *@ to be handled for the target effect, or relayed to a handler that
-- can- handle the target effect.
handleRelayS
:: s
-> (s -> a -> Eff effs b)
-- ^ Handle a pure value.
-> (forall v. s -> eff v -> (s -> Arr effs v b) -> Eff effs b)
-- ^ Handle a request for effect of type @eff :: * -> *@.
-> Eff (eff ': effs) a
-> Eff effs b
-- ^ Result with effects of type @eff :: * -> *@ handled.
:: s
-> (s -> a -> Eff effs b)
-- ^ Handle a pure value.
-> (forall v. s -> eff v -> (s -> Arr effs v b) -> Eff effs b)
-- ^ Handle a request for effect of type @eff :: * -> *@.
-> Eff (eff ': effs) a
-> Eff effs b
-- ^ Result with effects of type @eff :: * -> *@ handled.
handleRelayS s' ret h = loop s'
where
loop s (Val x) = ret s x
@ -289,11 +265,11 @@ handleRelayS s' ret h = loop s'
-- | Intercept the request and possibly reply to it, but leave it unhandled.
interpose
:: Member eff effs
=> (a -> Eff effs b)
-> (forall v. eff v -> Arr effs v b -> Eff effs b)
-> Eff effs a
-> Eff effs b
:: Member eff effs
=> (a -> Eff effs b)
-> (forall v. eff v -> Arr effs v b -> Eff effs b)
-> Eff effs a
-> Eff effs b
interpose ret h = loop
where
loop (Val x) = ret x
@ -317,13 +293,13 @@ raise = loop
-- | A data type for representing nondeterminstic choice.
data NonDet a where
MZero :: NonDet a
MPlus :: NonDet Bool
MZero :: NonDet a
MPlus :: NonDet Bool
instance Member NonDet effs => Alternative (Eff effs) where
empty = mzero
(<|>) = mplus
empty = mzero
(<|>) = mplus
instance Member NonDet effs => MonadPlus (Eff effs) where
mzero = send MZero
mplus m1 m2 = send MPlus >>= \x -> if x then m1 else m2
mzero = send MZero
mplus m1 m2 = send MPlus >>= \x -> if x then m1 else m2

60
src/Control/Monad/Freer/NonDet.hs
View File

@ -1,8 +1,5 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeOperators #-}
-- |
-- Module: Control.Monad.Freer.NonDet
-- Description: Non deterministic effects
@ -14,51 +11,46 @@
--
-- Composable handler for 'NonDet' effects.
module Control.Monad.Freer.NonDet
( NonDet(..)
, makeChoiceA
, msplit
)
where
( NonDet(..)
, makeChoiceA
, msplit
) where
import Control.Applicative (Alternative, (<|>), empty, pure)
import Control.Monad (liftM2, msum, return)
import Data.Bool (Bool(False, True))
import Data.Function (($), (.))
import Data.Maybe (Maybe(Just, Nothing))
import Control.Applicative (Alternative, (<|>), empty)
import Control.Monad (msum)
import Control.Monad.Freer.Internal
( Eff(E, Val)
, Member
, NonDet(MPlus, MZero)
, handleRelay
, prj
, qApp
, qComp
, tsingleton
)
( Eff(E, Val)
, Member
, NonDet(MPlus, MZero)
, handleRelay
, prj
, qApp
, qComp
, tsingleton
)
-- | A handler for nondeterminstic effects.
makeChoiceA
:: Alternative f
=> Eff (NonDet ': effs) a
-> Eff effs (f a)
makeChoiceA = handleRelay (return . pure) $ \m k ->
case m of
MZero -> return empty
MPlus -> liftM2 (<|>) (k True) (k False)
makeChoiceA = handleRelay (pure . pure) $ \m k ->
case m of
MZero -> pure empty
MPlus -> (<|>) <$> k True <*> k False
msplit
:: Member NonDet effs
=> Eff effs a
-> Eff effs (Maybe (a, Eff effs a))
:: Member NonDet effs
=> Eff effs a
-> Eff effs (Maybe (a, Eff effs a))
msplit = loop []
where
loop jq (Val x) = return (Just (x, msum jq))
loop jq (Val x) = pure (Just (x, msum jq))
loop jq (E u q) = case prj u of
Just MZero -> case jq of
[] -> return Nothing
(j:jq') -> loop jq' j
[] -> pure Nothing
(j:jq') -> loop jq' j
Just MPlus -> loop (qApp q False : jq) (qApp q True)
Nothing -> E u (tsingleton k)
where

64
src/Control/Monad/Freer/Reader.hs
View File

@ -1,9 +1,3 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
-- |
-- Module: Control.Monad.Freer.Reader
-- Description: Reader effects, for encapsulating an environment.
@ -18,38 +12,32 @@
--
-- Using <http://okmij.org/ftp/Haskell/extensible/Eff1.hs> as a starting point.
module Control.Monad.Freer.Reader
(
-- * Reader Effect
Reader(..)
( -- * Reader Effect
Reader(..)
-- * Reader Operations
, ask
, asks
, local
, ask
, asks
, local
-- * Reader Handlers
, runReader
, runReader
-- * Example 1: Simple Reader Usage
-- $simpleReaderExample
-- * Example 2: Modifying Reader Content With @local@
-- $localExample
)
where
import Control.Applicative (pure)
import Data.Functor ((<$>))
) where
import Control.Monad.Freer.Internal
( Arr
, Eff
, Member
, handleRelay
, interpose
, send
)
( Arr
, Eff
, Member
, handleRelay
, interpose
, send
)
-- | Represents shared immutable environment of type @(e :: *)@ which is made
-- available to effectful computation.
@ -63,10 +51,10 @@ ask = send Reader
-- | Request a value of the environment, and apply as selector\/projection
-- function to it.
asks
:: Member (Reader e) effs
=> (e -> a)
-- ^ The selector\/projection function to be applied to the environment.
-> Eff effs a
:: Member (Reader e) effs
=> (e -> a)
-- ^ The selector\/projection function to be applied to the environment.
-> Eff effs a
asks f = f <$> ask
-- | Handler for 'Reader' effects.
@ -78,15 +66,15 @@ runReader m e = handleRelay pure (\Reader k -> k e) m
-- This function is like a relay; it is both an admin for 'Reader' requests,
-- and a requestor of them.
local
:: forall e a effs. Member (Reader e) effs
=> (e -> e)
-> Eff effs a
-> Eff effs a
:: forall e a effs. Member (Reader e) effs
=> (e -> e)
-> Eff effs a
-> Eff effs a
local f m = do
e <- f <$> ask
let h :: Reader e v -> Arr effs v a -> Eff effs a
h Reader k = k e
interpose pure h m
e <- f <$> ask
let h :: Reader e v -> Arr effs v a -> Eff effs a
h Reader k = k e
interpose pure h m
-- $simpleReaderExample
--

80
src/Control/Monad/Freer/State.hs
View File

@ -1,9 +1,3 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
-- |
-- Module: Control.Monad.Freer.State
-- Description: State effects, for state-carrying computations.
@ -24,44 +18,36 @@
--
-- Using <http://okmij.org/ftp/Haskell/extensible/Eff1.hs> as a starting point.
module Control.Monad.Freer.State
(
-- * State Effect
State(..)
( -- * State Effect
State(..)
-- * State Operations
, get
, put
, modify
, get
, put
, modify
-- * State Handlers
, runState
, evalState
, execState
, runState
, evalState
, execState
-- * State Utilities
, transactionState
)
where
, transactionState
) where
import Control.Monad ((>>), (>>=), return)
import Data.Either (Either(Left, Right))
import Data.Functor ((<$>), fmap)
import Data.Maybe (Maybe(Just))
import Data.Proxy (Proxy)
import Data.Tuple (fst, snd)
import Control.Monad.Freer.Internal
( Eff(E, Val)
, Member
, Union
, decomp
, prj
, qApp
, qComp
, send
, tsingleton
)
( Eff(E, Val)
, Member
, Union
, decomp
, prj
, qApp
, qComp
, send
, tsingleton
)
--------------------------------------------------------------------------------
-- State, strict --
@ -69,8 +55,8 @@ import Control.Monad.Freer.Internal
-- | Strict 'State' effects: one can either 'Get' values or 'Put' them.
data State s a where
Get :: State s s
Put :: !s -> State s ()
Get :: State s s
Put :: !s -> State s ()
-- | Retrieve the current value of the state of type @s :: *@.
get :: Member (State s) effs => Eff effs s
@ -89,9 +75,9 @@ modify f = fmap f get >>= put
runState :: Eff (State s ': effs) a -> s -> Eff effs (a, s)
runState (Val x) s = return (x, s)
runState (E u q) s = case decomp u of
Right Get -> runState (qApp q s) s
Right (Put s') -> runState (qApp q ()) s'
Left u' -> E u' (tsingleton (\x -> runState (qApp q x) s))
Right Get -> runState (qApp q s) s
Right (Put s') -> runState (qApp q ()) s'
Left u' -> E u' (tsingleton (\x -> runState (qApp q x) s))
-- | Run a 'State' effect, returning only the final state.
execState :: Eff (State s ': effs) a -> s -> Eff effs s
@ -104,16 +90,16 @@ evalState st s = fst <$> runState st s
-- | An encapsulated State handler, for transactional semantics. The global
-- state is updated only if the 'transactionState' finished successfully.
transactionState
:: forall s effs a
. Member (State s) effs
=> Proxy s
-> Eff effs a
-> Eff effs a
:: forall s effs a
. Member (State s) effs
=> Proxy s
-> Eff effs a
-> Eff effs a
transactionState _ m = do s <- get; loop s m
where
loop :: s -> Eff effs a -> Eff effs a
loop s (Val x) = put s >> return x
loop s (E (u :: Union r b) q) = case prj u :: Maybe (State s b) of
Just Get -> loop s (qApp q s)
Just (Put s') -> loop s'(qApp q ())
_ -> E u (tsingleton k) where k = qComp q (loop s)
Just Get -> loop s (qApp q s)
Just (Put s') -> loop s'(qApp q ())
_ -> E u (tsingleton k) where k = qComp q (loop s)

32
src/Control/Monad/Freer/StateRW.hs
View File

@ -1,8 +1,3 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeOperators #-}
-- |
-- Module: Control.Monad.Freer.StateRW
-- Description: State effects in terms of Reader and Writer.
@ -18,21 +13,16 @@
--
-- Using <http://okmij.org/ftp/Haskell/extensible/Eff1.hs> as a starting point.
module Control.Monad.Freer.StateRW
( runStateR
, Reader
, Writer
, tell
, ask
)
where
import Control.Monad (return)
import Data.Either (Either(Left, Right))
import Control.Monad.Freer.Reader (Reader(Reader), ask)
import Control.Monad.Freer.Writer (Writer(Writer), tell)
import Control.Monad.Freer.Internal (Eff(E, Val), decomp, qComp, tsingleton)
( runStateR
, Reader
, Writer
, tell
, ask
) where
import Control.Monad.Freer.Reader (Reader(..), ask)
import Control.Monad.Freer.Writer (Writer(..), tell)
import Control.Monad.Freer.Internal (Eff(..), decomp, qComp, tsingleton)
-- | State handler, using 'Reader' and 'Writer' effects.
runStateR :: Eff (Writer s ': Reader s ': effs) a -> s -> Eff effs (a, s)
@ -43,7 +33,7 @@ runStateR m s = loop s m
loop s' (E u q) = case decomp u of
Right (Writer o) -> k o ()
Left u' -> case decomp u' of
Right Reader -> k s' s'
Left u'' -> E u'' (tsingleton (k s'))
Right Reader -> k s' s'
Left u'' -> E u'' (tsingleton (k s'))
where
k s'' = qComp q (loop s'')

26
src/Control/Monad/Freer/Trace.hs
View File

@ -1,8 +1,3 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeOperators #-}
-- |
-- Module: Control.Monad.Freer.Trace
-- Description: Composable Trace effects.
@ -17,23 +12,16 @@
--
-- Using <http://okmij.org/ftp/Haskell/extensible/Eff1.hs> as a starting point.
module Control.Monad.Freer.Trace
( Trace(..)
, trace
, runTrace
)
where
import Control.Monad ((>>), return)
import Data.Function ((.))
import Data.String (String)
import System.IO (IO, putStrLn)
import Control.Monad.Freer.Internal (Eff(E, Val), Member, extract, qApp, send)
( Trace(..)
, trace
, runTrace
) where
import Control.Monad.Freer.Internal (Eff(..), Member, extract, qApp, send)
-- | A Trace effect; takes a 'String' and performs output.
data Trace a where
Trace :: String -> Trace ()
Trace :: String -> Trace ()
-- | Printing a string in a trace.
trace :: Member Trace effs => String -> Eff effs ()
@ -43,4 +31,4 @@ trace = send . Trace
runTrace :: Eff '[Trace] a -> IO a
runTrace (Val x) = return x
runTrace (E u q) = case extract u of
Trace s -> putStrLn s >> runTrace (qApp q ())
Trace s -> putStrLn s >> runTrace (qApp q ())

24
src/Control/Monad/Freer/Writer.hs
View File

@ -1,8 +1,3 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeOperators #-}
-- |
-- Module: Control.Monad.Freer.Writer
-- Description: Composable Writer effects.
@ -18,24 +13,19 @@
--
-- Using <http://okmij.org/ftp/Haskell/extensible/Eff1.hs> as a starting point.
module Control.Monad.Freer.Writer
( Writer(..)
, tell
, runWriter
)
where
( Writer(..)
, tell
, runWriter
) where
import Control.Applicative (pure)
import Control.Arrow (second)
import Data.Function (($))
import Data.Functor ((<$>))
import Data.Monoid (Monoid, (<>), mempty)
import Data.Monoid ((<>))
import Control.Monad.Freer.Internal (Eff, Member, handleRelay, send)
-- | Writer effects - send outputs to an effect environment.
data Writer w a where
Writer :: w -> Writer w ()
Writer :: w -> Writer w ()
-- | Send a change to the attached environment.
tell :: Member (Writer w) effs => w -> Eff effs ()
@ -44,4 +34,4 @@ tell w = send $ Writer w
-- | Simple handler for 'Writer' effects.
runWriter :: Monoid w => Eff (Writer w ': effs) a -> Eff effs (a, w)
runWriter = handleRelay (\a -> pure (a, mempty)) $ \(Writer w) k ->
second (w <>) <$> k ()
second (w <>) <$> k ()

30
src/Data/FTCQueue.hs
View File

@ -1,5 +1,3 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NoImplicitPrelude #-}
-- |
-- Module: Data.FTCQueue
-- Description: Fast type-aligned queue optimized to effectful functions.
@ -20,23 +18,21 @@
-- * Research: <http://okmij.org/ftp/Haskell/Reflection.html>
-- * <https://hackage.haskell.org/package/type-aligned type-aligned> (FTCQueue)
module Data.FTCQueue
( FTCQueue
, tsingleton
, (|>)
, snoc
, (><)
, append
, ViewL(..)
, tviewl
)
where
( FTCQueue
, tsingleton
, (|>)
, snoc
, (><)
, append
, ViewL(..)
, tviewl
) where
-- | Non-empty tree. Deconstruction operations make it more and more
-- left-leaning
data FTCQueue m a b where
Leaf :: (a -> m b) -> FTCQueue m a b
Node :: FTCQueue m a x -> FTCQueue m x b -> FTCQueue m a b
Leaf :: (a -> m b) -> FTCQueue m a b
Node :: FTCQueue m a x -> FTCQueue m x b -> FTCQueue m a b
-- | Build a leaf from a single operation. [O(1)]
tsingleton :: (a -> m b) -> FTCQueue m a b
@ -65,8 +61,8 @@ append = (><)
-- | Left view deconstruction data structure.
data ViewL m a b where
TOne :: (a -> m b) -> ViewL m a b
(:|) :: (a -> m x) -> FTCQueue m x b -> ViewL m a b
TOne :: (a -> m b) -> ViewL m a b
(:|) :: (a -> m x) -> FTCQueue m x b -> ViewL m a b
-- | Left view deconstruction. [average O(1)]
tviewl :: FTCQueue m a b -> ViewL m a b

59
src/Data/OpenUnion.hs
View File

@ -1,16 +1,7 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-- |
-- Module: Data.OpenUnion
-- Description: Open unions (type-indexed co-products) for extensible effects.
@ -23,44 +14,38 @@
-- Open unions (type-indexed co-products, i.e. type-indexed sums) for
-- extensible effects All operations are constant-time.
module Data.OpenUnion
(
-- * Open Union
Union
( -- * Open Union
Union
-- * Open Union Operations
, Weakens(..)
, (:++:)
, decomp
, weaken
, extract
, Weakens(..)
, (:++:)
, decomp
, weaken
, extract
-- * Open Union Membership Constraints
, Member(..)
, Members
, LastMember
)
where
, Member(..)
, Members
, LastMember
) where
#if MIN_VERSION_base(4,9,0)
import Data.Kind (Constraint)
#else
import GHC.Exts (Constraint)
#endif
import Data.OpenUnion.Internal
( Member(inj, prj)
, Union
, Weakens(weakens)
, (:++:)
, decomp
, extract
, weaken
)
( Member(inj, prj)
, Union
, Weakens(weakens)
, (:++:)
, decomp
, extract
, weaken
)
type family Members m r :: Constraint where
Members (t ': c) r = (Member t r, Members c r)
Members '[] r = ()
Members (t ': c) r = (Member t r, Members c r)
Members '[] r = ()
type family Last effs where
Last (eff ': '[]) = eff

82
src/Data/OpenUnion/Internal.hs
View File

@ -1,16 +1,8 @@
{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-- |
@ -37,24 +29,14 @@
-- Therefore, we can use a @Typeable@-like evidence in that universe. In our
-- case a simple index of an element in the type-list is sufficient
-- substitution for @Typeable@.
module Data.OpenUnion.Internal (module Data.OpenUnion.Internal)
where
module Data.OpenUnion.Internal where
import Prelude ((+), (-), error)
import Data.Bool (otherwise)
import Data.Either (Either(Left, Right))
import Data.Eq ((==))
import Data.Function (($), id)
import Data.Maybe (Maybe(Just, Nothing))
import Data.Word (Word)
import GHC.TypeLits (TypeError, ErrorMessage((:<>:), (:$$:), ShowType, Text))
import GHC.TypeLits (TypeError, ErrorMessage(..))
import Unsafe.Coerce (unsafeCoerce)
-- | Open union is a strong sum (existential with an evidence).
data Union (r :: [ * -> * ]) a where
Union :: {-# UNPACK #-} !Word -> t a -> Union r a
data Union (r :: [* -> *]) a where
Union :: {-# UNPACK #-} !Word -> t a -> Union r a
-- | Takes a request of type @t :: * -> *@, and injects it into the 'Union'.
--
@ -94,22 +76,22 @@ newtype P t r w = P {unP :: Word}
--
-- This is essentially a compile-time computation without run-time overhead.
class FindElem (t :: * -> *) (r :: [* -> *]) (w :: [* -> *]) where
-- | Position of the element @t :: * -> *@ in a type list @r :: [* -> *]@.
--
-- Position is computed during compilation, i.e. there is no run-time
-- overhead.
--
-- /O(1)/
elemNo :: P t r w
-- | Position of the element @t :: * -> *@ in a type list @r :: [* -> *]@.
--
-- Position is computed during compilation, i.e. there is no run-time
-- overhead.
--
-- /O(1)/
elemNo :: P t r w
-- | Base case; element is at the current position in the list.
instance FindElem t (t ': r) w where
elemNo = P 0
elemNo = P 0
-- | Recursion; element is not at the current position, but is somewhere in the
-- list.
instance {-# OVERLAPPABLE #-} FindElem t r w => FindElem t (t' ': r) w where
elemNo = P $ 1 + unP (elemNo :: P t r w)
elemNo = P $ 1 + unP (elemNo :: P t r w)
-- | If we reach an empty list, that’s a failure, since it means the type isn’t
-- in the list. For GHC >=8, we can render a custom type error that explicitly
@ -119,8 +101,8 @@ instance TypeError ('Text "‘" ':<>: 'ShowType t
':$$: 'Text " ‘" ':<>: 'ShowType w ':<>: 'Text "’"
':$$: 'Text "In the constraint ("
':<>: 'ShowType (Member t w) ':<>: 'Text ")")
=> FindElem t '[] w where
elemNo = error "impossible"
=> FindElem t '[] w where
elemNo = error "impossible"
-- | This type class is used for two following purposes:
--
@ -136,25 +118,25 @@ instance TypeError ('Text "‘" ':<>: 'ShowType t
-- 'prj' . 'inj' === 'Just'
-- @
class FindElem t r r => Member (t :: * -> *) r where
-- | Takes a request of type @t :: * -> *@, and injects it into the
-- 'Union'.
--
-- /O(1)/
inj :: t a -> Union r a
-- | Takes a request of type @t :: * -> *@, and injects it into the
-- 'Union'.
--
-- /O(1)/
inj :: t a -> Union r a
-- | Project a value of type @'Union' (t ': r) :: * -> *@ into a possible
-- summand of the type @t :: * -> *@. 'Nothing' means that @t :: * -> *@ is
-- not the value stored in the @'Union' (t ': r) :: * -> *@.
--
-- /O(1)/
prj :: Union r a -> Maybe (t a)
-- | Project a value of type @'Union' (t ': r) :: * -> *@ into a possible
-- summand of the type @t :: * -> *@. 'Nothing' means that @t :: * -> *@ is
-- not the value stored in the @'Union' (t ': r) :: * -> *@.
--
-- /O(1)/
prj :: Union r a -> Maybe (t a)
instance FindElem t r r => Member t r where
inj = unsafeInj $ unP (elemNo :: P t r r)
{-# INLINE inj #-}
inj = unsafeInj $ unP (elemNo :: P t r r)
{-# INLINE inj #-}
prj = unsafePrj $ unP (elemNo :: P t r r)
{-# INLINE prj #-}
prj = unsafePrj $ unP (elemNo :: P t r r)
{-# INLINE prj #-}
-- | Orthogonal decomposition of a @'Union' (t ': r) :: * -> *@. 'Right' value
-- is returned if the @'Union' (t ': r) :: * -> *@ contains @t :: * -> *@, and

9
stack.yaml Normal file
View File

@ -0,0 +1,9 @@
resolver: lts-8.21
packages:
- '.'
extra-deps: []
flags: {}
extra-package-dbs: []

37
tests/Tests.hs
View File

@ -1,14 +1,4 @@
{-# LANGUAGE NoImplicitPrelude #-}
module Main (main)
where
import Prelude ((+))
import Control.Applicative ((<$>), (<*>), pure)
import Data.Eq ((==))
import Data.Function (($))
import Data.Int (Int)
import System.IO (IO)
module Main (main) where
import Test.Tasty (TestTree, testGroup, defaultMain)
import Test.Tasty.QuickCheck (testProperty)
@ -23,7 +13,6 @@ import qualified Tests.Reader (tests)
import qualified Tests.State (tests)
import qualified Tests.Loop (tests)
--------------------------------------------------------------------------------
-- Pure Tests --
--------------------------------------------------------------------------------
@ -32,21 +21,21 @@ addInEff x y = run $ (+) <$> pure x <*> pure y
pureTests :: TestTree
pureTests = testGroup "Pure Eff tests"
[ testProperty "Pure run just works: (+)"
$ \x y -> addInEff x y == x + y
]
[ testProperty "Pure run just works: (+)"
$ \x y -> addInEff x y == x + y
]
--------------------------------------------------------------------------------
-- Runner --
--------------------------------------------------------------------------------
main :: IO ()
main = defaultMain $ testGroup "Tests"
[ pureTests
, Tests.Coroutine.tests
, Tests.Exception.tests
, Tests.Fresh.tests
, Tests.NonDet.tests
, Tests.Reader.tests
, Tests.State.tests
, Tests.Loop.tests
]
[ pureTests
, Tests.Coroutine.tests
, Tests.Exception.tests
, Tests.Fresh.tests
, Tests.NonDet.tests
, Tests.Reader.tests
, Tests.State.tests
, Tests.Loop.tests
]

43
tests/Tests/Coroutine.hs
View File

@ -1,34 +1,25 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Tests.Coroutine (tests)
where
-- This is necessary to work around a weird infinite loop bug in GHC 8.0.x. I
-- have no idea what causes it, but disabling these extensions in this module
-- avoids the problem.
{-# LANGUAGE NoGADTs #-}
{-# LANGUAGE NoMonoLocalBinds #-}
import Prelude ((+), even)
module Tests.Coroutine (tests) where
import Control.Applicative ((<*>), pure)
import Control.Monad ((>>), (>>=), unless)
import Data.Bool (Bool, (&&))
import Data.Eq ((==))
import Data.Function (($), (.))
import Data.Functor ((<$>))
import Data.Int (Int)
import Data.Tuple (snd)
import Control.Monad (unless)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck (testProperty)
import Control.Monad.Freer (Eff, Members, run)
import Control.Monad.Freer.Coroutine
( Status(Continue, Done)
, Yield
, runC
, yield
)
( Status(Continue, Done)
, Yield
, runC
, yield
)
import Control.Monad.Freer.State (State, modify, runState)
tests :: TestTree
tests = testGroup "Coroutine Eff tests"
[ testProperty "Counting consecutive pairs of odds"
@ -47,11 +38,11 @@ runTestCoroutine list = snd . run $ runState effTestCoroutine 0
where
testCoroutine :: Members '[Yield () Int, State Int] r => Eff r ()
testCoroutine = do
-- Yield for two elements and hope they're both odd.
b <- (&&)
<$> yield () (even :: Int -> Bool)
<*> yield () (even :: Int -> Bool)
unless b $ modify (+ (1 :: Int)) >> testCoroutine
-- Yield for two elements and hope they're both odd.
b <- (&&)
<$> yield () (even :: Int -> Bool)
<*> yield () (even :: Int -> Bool)
unless b $ modify (+ (1 :: Int)) >> testCoroutine
effTestCoroutine = runC testCoroutine >>= handleStatus list
where

64
tests/Tests/Exception.hs
View File

@ -1,23 +1,4 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeOperators #-}
module Tests.Exception (tests)
where
import Prelude ((+))
import Control.Applicative ((<*>), pure)
import Control.Monad ((>>), (>>=))
import Data.Either (Either(Left, Right))
import Data.Eq (Eq((==)))
import Data.Function (($), (.))
import Data.Functor ((<$>))
import Data.Int (Int)
import Data.Ord ((>))
import Data.String (String)
import Text.Show (Show)
module Tests.Exception (tests) where
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (testCase, (@?=))
@ -28,26 +9,25 @@ import Control.Monad.Freer.Error (Error, catchError, runError, throwError)
import Control.Monad.Freer.Reader (ask, runReader)
import Control.Monad.Freer.State (State, get, put, runState)
tests :: TestTree
tests = testGroup "Exception Eff tests"
[ testProperty "Error takes precedence"
$ \x y -> testExceptionTakesPriority x y == Left y
, testCase "uncaught: runState (runError t)"
$ ter1 @?= (Left "exc", 2)
, testCase "uncaught: runError (runState t)"
$ ter2 @?= Left "exc"
, testCase "caught: runState (runError t)"
$ ter3 @?= (Right "exc", 2)
, testCase "caught: runError (runState t)"
$ ter4 @?= Right ("exc", 2)
, testCase "success: runReader (runErrBig t)"
$ ex2rr @?= Right 5
, testCase "uncaught: runReader (runErrBig t)"
$ ex2rr1 @?= Left (TooBig 7)
, testCase "uncaught: runErrBig (runReader t)"
$ ex2rr2 @?= Left (TooBig 7)
]
[ testProperty "Error takes precedence"
$ \x y -> testExceptionTakesPriority x y == Left y
, testCase "uncaught: runState (runError t)"
$ ter1 @?= (Left "exc", 2)
, testCase "uncaught: runError (runState t)"
$ ter2 @?= Left "exc"
, testCase "caught: runState (runError t)"
$ ter3 @?= (Right "exc", 2)
, testCase "caught: runError (runState t)"
$ ter4 @?= Right ("exc", 2)
, testCase "success: runReader (runErrBig t)"
$ ex2rr @?= Right 5
, testCase "uncaught: runReader (runErrBig t)"
$ ex2rr1 @?= Left (TooBig 7)
, testCase "uncaught: runErrBig (runReader t)"
$ ex2rr2 @?= Left (TooBig 7)
]
testExceptionTakesPriority :: Int -> Int -> Either Int Int
testExceptionTakesPriority x y = run $ runError (go x y)
@ -89,10 +69,10 @@ newtype TooBig = TooBig Int
ex2 :: Member (Error TooBig) r => Eff r Int -> Eff r Int
ex2 m = do
v <- m
if v > 5
then throwError (TooBig v)
else pure v
v <- m
if v > 5
then throwError (TooBig v)
else pure v
-- | Specialization to tell the type of the exception.
runErrBig :: Eff (Error TooBig ': r) a -> Eff r (Either TooBig a)

24
tests/Tests/Fresh.hs
View File

@ -1,17 +1,6 @@
{-# LANGUAGE NoImplicitPrelude #-}
module Tests.Fresh (tests)
where
import Prelude ((-))
module Tests.Fresh (tests) where
import Control.Monad (replicateM)
import Data.Eq ((==))
import Data.Function (($), (.))
import Data.Functor ((<$>))
import Data.Int (Int)
import Data.List (last)
import Data.Ord ((>))
import Data.Tuple (fst)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit ((@?=), testCase)
@ -20,14 +9,13 @@ import Test.Tasty.QuickCheck ((==>), testProperty)
import Control.Monad.Freer (Eff, run)
import Control.Monad.Freer.Fresh (fresh, runFresh)
tests :: TestTree
tests = testGroup "Fresh tests"
[ testCase "Start at 0, refresh twice, yields 1"
$ testFresh 10 @?= 9
, testProperty "Freshening n times yields (n-1)"
$ \n -> n > 0 ==> testFresh n == (n-1)
]
[ testCase "Start at 0, refresh twice, yields 1"
$ testFresh 10 @?= 9
, testProperty "Freshening n times yields (n-1)"
$ \n -> n > 0 ==> testFresh n == (n-1)
]
makeFresh :: Int -> Eff r Int
makeFresh n = fst <$> runFresh (last <$> replicateM n fresh) 0

26
tests/Tests/Loop.hs
View File

@ -1,21 +1,15 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Tests.Loop (tests)
where
module Tests.Loop (tests) where
import Control.Concurrent (forkIO, killThread)
import Control.Concurrent.QSemN (newQSemN, signalQSemN, waitQSemN)
import Control.Monad ((>>), forever)
import Data.Function (($), (.), fix)
import System.IO (IO)
import Control.Monad (forever)
import Data.Function (fix)
import Test.Tasty (TestTree, localOption, mkTimeout, testGroup)
import Test.Tasty.HUnit (testCase)
import Control.Monad.Freer (Eff, Member, runM, send)
tests :: TestTree
tests = localOption timeout $ testGroup "Loop tests"
[ testCase "fix loop" $ testLoop fixLoop
@ -27,18 +21,18 @@ tests = localOption timeout $ testGroup "Loop tests"
testLoop :: (IO () -> Eff '[IO] ()) -> IO ()
testLoop loop = do
s <- newQSemN 0
t <- forkIO . runM . loop $ signalQSemN s 1
waitQSemN s 5
killThread t
s <- newQSemN 0
t <- forkIO . runM . loop $ signalQSemN s 1
waitQSemN s 5
killThread t
fixLoop :: Member IO r => IO () -> Eff r ()
fixLoop action = fix $ \fxLoop -> do
send action
fxLoop
send action
fxLoop
tailLoop :: Member IO r => IO () -> Eff r ()
tailLoop action = let loop = send action >> loop in loop
tailLoop action = let loop = send action *> loop in loop
foreverLoop :: Member IO r => IO () -> Eff r ()
foreverLoop action = forever $ send action

25
tests/Tests/NonDet.hs
View File

@ -1,20 +1,8 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Tests.NonDet (tests)
where
module Tests.NonDet (tests) where
import Prelude ((+), abs, mod)
import Control.Applicative ((<|>), pure)
import Control.Monad ((>>=), guard, msum, mzero)
import Data.Bool ((&&))
import Data.Eq ((==))
import Data.Function (($), (.), const)
import Data.Functor ((<$>))
import Data.Int (Int)
import Control.Applicative ((<|>))
import Control.Monad (guard, msum, mzero)
import Data.List ((\\))
import Data.Maybe (maybe)
import Data.Ord ((<))
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck (testProperty)
@ -22,12 +10,11 @@ import Test.Tasty.QuickCheck (testProperty)
import Control.Monad.Freer (Eff, Member, run)
import Control.Monad.Freer.NonDet (NonDet, makeChoiceA, msplit)
tests :: TestTree
tests = testGroup "NonDet tests"
[ testProperty "Primes in 2..n generated by ifte"
$ \n' -> let n = abs n' in testIfte [2 .. n] == primesTo n
]
[ testProperty "Primes in 2..n generated by ifte"
$ \n' -> let n = abs n' in testIfte [2 .. n] == primesTo n
]
-- https://wiki.haskell.org/Prime_numbers
primesTo :: Int -> [Int]

35
tests/Tests/Reader.hs
View File

@ -1,16 +1,4 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Tests.Reader (tests)
where
import Prelude (Integer, (+), (*), fromIntegral)
import Control.Applicative ((<*>), pure)
import Data.Eq (Eq((==)))
import Data.Function (($), (.), flip)
import Data.Functor ((<$>))
import Data.Int (Int)
module Tests.Reader (tests) where
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck (testProperty)
@ -18,16 +6,15 @@ import Test.Tasty.QuickCheck (testProperty)
import Control.Monad.Freer (run)
import Control.Monad.Freer.Reader (ask, local, runReader)
tests :: TestTree
tests = testGroup "Reader tests"
[ testProperty "Reader passes along environment: n + x"
$ \n x -> testReader n x == n + x
, testProperty "Multiple readers work"
$ \i n -> testMultiReader i n == (i + 2) + fromIntegral (n + 1)
, testProperty "Local injects into env"
$ \env inc -> testLocal env inc == 2 * (env + 1) + inc
]
[ testProperty "Reader passes along environment: n + x"
$ \n x -> testReader n x == n + x
, testProperty "Multiple readers work"
$ \i n -> testMultiReader i n == (i + 2) + fromIntegral (n + 1)
, testProperty "Local injects into env"
$ \env inc -> testLocal env inc == 2 * (env + 1) + inc
]
--------------------------------------------------------------------------------
-- Examples --
@ -45,9 +32,9 @@ testMultiReader :: Integer -> Int -> Integer
testMultiReader i = run . flip runReader i . runReader t2
where
t2 = do
v1 <- ask
v2 <- ask
pure $ fromIntegral (v1 + (1 :: Int)) + (v2 + (2 :: Integer))
v1 <- ask
v2 <- ask
pure $ fromIntegral (v1 + (1 :: Int)) + (v2 + (2 :: Integer))
-- The opposite order of layers
{- If we mess up, we get an error

80
tests/Tests/State.hs
View File

@ -1,15 +1,4 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Tests.State (tests)
where
import Prelude ((+))
import Control.Applicative (pure)
import Control.Monad ((>>))
import Data.Eq ((==))
import Data.Function (($), (.))
import Data.Int (Int)
module Tests.State (tests) where
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck (testProperty)
@ -18,28 +7,27 @@ import Control.Monad.Freer (run)
import Control.Monad.Freer.State (evalState, execState, get, put, runState)
import Control.Monad.Freer.StateRW (ask, runStateR, tell)
tests :: TestTree
tests = testGroup "State tests"
[ testProperty "get after put n yields (n, n)"
$ \n -> testPutGet n 0 == (n, n)
, testProperty "Final put determines stored state"
$ \p1 p2 start -> testPutGetPutGetPlus p1 p2 start == (p1 + p2, p2)
, testProperty "If only getting, start state determines outcome"
$ \start -> testGetStart start == (start, start)
, testProperty "testPutGet: State == StateRW"
$ \n -> testPutGet n 0 == testPutGetRW n 0
, testProperty "testPutGetPutGetPlus: State == StateRW"
$ \p1 p2 start ->
testPutGetPutGetPlus p1 p2 start
== testPutGetPutGetPlusRW p1 p2 start
, testProperty "testGetStart: State == StateRW"
$ \n -> testGetStart n == testGetStartRW n
, testProperty "testEvalState: evalState discards final state"
$ \n -> testEvalState n == n
, testProperty "testExecState: execState returns final state"
$ \n -> testExecState n == n
]
[ testProperty "get after put n yields (n, n)"
$ \n -> testPutGet n 0 == (n, n)
, testProperty "Final put determines stored state"
$ \p1 p2 start -> testPutGetPutGetPlus p1 p2 start == (p1 + p2, p2)
, testProperty "If only getting, start state determines outcome"
$ \start -> testGetStart start == (start, start)
, testProperty "testPutGet: State == StateRW"
$ \n -> testPutGet n 0 == testPutGetRW n 0
, testProperty "testPutGetPutGetPlus: State == StateRW"
$ \p1 p2 start ->
testPutGetPutGetPlus p1 p2 start
== testPutGetPutGetPlusRW p1 p2 start
, testProperty "testGetStart: State == StateRW"
$ \n -> testGetStart n == testGetStartRW n
, testProperty "testEvalState: evalState discards final state"
$ \n -> testEvalState n == n
, testProperty "testExecState: execState returns final state"
$ \n -> testExecState n == n
]
testPutGet :: Int -> Int -> (Int, Int)
testPutGet n start = run $ runState go start
@ -55,21 +43,21 @@ testPutGetPutGetPlus :: Int -> Int -> Int -> (Int, Int)
testPutGetPutGetPlus p1 p2 start = run $ runState go start
where
go = do
put p1
x <- get
put p2
y <- get
pure (x + y)
put p1
x <- get
put p2
y <- get
pure (x + y)
testPutGetPutGetPlusRW :: Int -> Int -> Int -> (Int, Int)
testPutGetPutGetPlusRW p1 p2 start = run $ runStateR go start
where
go = do
tell p1
x <- ask
tell p2
y <- ask
pure (x+y)
tell p1
x <- ask
tell p2
y <- ask
pure (x+y)
testGetStart :: Int -> (Int, Int)
testGetStart = run . runState get
@ -81,10 +69,10 @@ testEvalState :: Int -> Int
testEvalState = run . evalState go
where
go = do
x <- get
-- Destroy the previous state.
put (0 :: Int)
pure x
x <- get
-- Destroy the previous state.
put (0 :: Int)
pure x
testExecState :: Int -> Int
testExecState n = run $ execState (put n) 0

33
tests/hlint.hs
View File

@ -1,33 +0,0 @@
{-# LANGUAGE NoImplicitPrelude #-}
-- |
-- Module: Main
-- Description: HLint tests executor
-- Copyright: (c) 2015-2016, Ixperta Solutions s.r.o.
-- License: BSD3
--
-- Stability: stable
-- Portability: portable
--
-- HLint tests executor.
module Main (main)
where
import Control.Monad (unless)
import Data.Function (($))
import Data.List (null)
import Data.Monoid ((<>))
import System.Exit (exitFailure)
import System.IO (IO, putStrLn)
import Language.Haskell.HLint (hlint)
main :: IO ()
main = do
putStrLn "" -- less confusing output, test-framework does this too
hints <- hlint $ hlintOpts <> ["."]
unless (null hints) exitFailure
where
hlintOpts =
[ "-XNoPatternSynonyms"
]