summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorryanglscott <>2017-05-12 15:01:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-05-12 15:01:00 (GMT)
commitd593f1a4099513d54a252b3915b135c6d53a3a54 (patch)
tree530a28184916c14660ba1708758e97e14fd92a0e
parent8e90c90dccd85e40a4c018e6e8eb80b566af506b (diff)
version 22
-rw-r--r--.travis.yml111
-rw-r--r--CHANGELOG.markdown11
-rw-r--r--README.markdown21
-rw-r--r--Setup.lhs62
-rw-r--r--bound.cabal85
-rw-r--r--examples/Deriving.hs38
-rw-r--r--examples/Imperative.hs293
-rw-r--r--examples/Overkill.hs119
-rw-r--r--examples/Simple.hs24
-rw-r--r--src/Bound.hs31
-rw-r--r--src/Bound/Class.hs3
-rw-r--r--src/Bound/Name.hs70
-rw-r--r--src/Bound/Scope.hs97
-rw-r--r--src/Bound/Scope/Simple.hs94
-rw-r--r--src/Bound/TH.hs332
-rw-r--r--src/Bound/Var.hs79
-rw-r--r--tests/doctests.hs43
17 files changed, 1075 insertions, 438 deletions
diff --git a/.travis.yml b/.travis.yml
index 07eb958..3c88048 100644
--- a/.travis.yml
+++ b/.travis.yml
@@ -1,45 +1,94 @@
+# This Travis job script has been generated by a script via
+#
+# make_travis_yml_2.hs 'bound.cabal'
+#
+# For more information, see https://github.com/hvr/multi-ghc-travis
+#
language: c
sudo: false
+git:
+ submodules: false # whether to recursively clone submodules
+
+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
+
matrix:
include:
- - env: CABALVER=1.16 GHCVER=7.4.2
- addons: {apt: {packages: [cabal-install-1.16,ghc-7.4.2], sources: [hvr-ghc]}}
- - env: CABALVER=1.16 GHCVER=7.6.3
- addons: {apt: {packages: [cabal-install-1.16,ghc-7.6.3], sources: [hvr-ghc]}}
- - env: CABALVER=1.18 GHCVER=7.8.4
- addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4], sources: [hvr-ghc]}}
- - env: CABALVER=1.22 GHCVER=7.10.1
- addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.1],sources: [hvr-ghc]}}
- - env: CABALVER=head GHCVER=head
- addons: {apt: {packages: [cabal-install-head,ghc-head], sources: [hvr-ghc]}}
-
- allow_failures:
- - env: CABALVER=head GHCVER=head
+ - compiler: "ghc-7.4.2"
+ # env: TEST=--disable-tests BENCH=--disable-benchmarks
+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,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-head,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-head,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-head,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-head,ghc-8.0.2], sources: [hvr-ghc]}}
+ - compiler: "ghc-8.2.1"
+ # env: TEST=--disable-tests BENCH=--disable-benchmarks
+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.1], sources: [hvr-ghc]}}
before_install:
- - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
- - export CABAL=cabal-$CABALVER
- - $CABAL --version
+ - HC=${CC}
+ - unset CC
+ - PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$PATH
+ - PKGNAME='bound'
install:
- - travis_retry $CABAL update
- - $CABAL install "Cabal == $CABALVER.*"
- - $CABAL install --enable-tests --only-dependencies
+ - cabal --version
+ - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
+ - BENCH=${BENCH---enable-benchmarks}
+ - TEST=${TEST---enable-tests}
+ - travis_retry cabal update -v
+ - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
+ - rm -fv cabal.project.local
+ - "echo 'packages: .' > cabal.project"
+ - rm -f cabal.project.freeze
+ - cabal new-build -w ${HC} ${TEST} ${BENCH} --dep -j2 all
+ - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --dep -j2 all
+# 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:
- - $CABAL configure -v2 --enable-tests
- - $CABAL build
- - $CABAL test
- - $CABAL sdist
- - export SRC_TGZ=$($CABAL info . | awk '{print $2 ".tar.gz";exit}') ;
- cd dist/;
- if [ -f "$SRC_TGZ" ]; then
- $CABAL install "$SRC_TGZ";
- else
- echo "expected '$SRC_TGZ' not found";
- exit 1;
- fi
+ - if [ -f configure.ac ]; then autoreconf -i; fi
+ - rm -rf dist/
+ - cabal sdist # test that a source-distribution can be generated
+ - cd dist/
+ - SRCTAR=(${PKGNAME}-*.tar.gz)
+ - SRC_BASENAME="${SRCTAR/%.tar.gz}"
+ - tar -xvf "./$SRC_BASENAME.tar.gz"
+ - cd "$SRC_BASENAME/"
+## from here on, CWD is inside the extracted source-tarball
+ - rm -fv cabal.project.local
+ - "echo 'packages: .' > cabal.project"
+ # this builds all libraries and executables (without tests/benchmarks)
+ - rm -f cabal.project.freeze
+ - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all
+ # this builds all libraries and executables (including tests/benchmarks)
+ # - rm -rf ./dist-newstyle
+
+ # build & run tests
+ - cabal new-build -w ${HC} ${TEST} ${BENCH} all
+ - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} all; fi
+
+# EOF
notifications:
irc:
diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown
index 10555ac..3c88e08 100644
--- a/CHANGELOG.markdown
+++ b/CHANGELOG.markdown
@@ -1,3 +1,14 @@
+2
+-
+* GHC 8.0 and 8.2 support
+* Converted from `prelude-extras` to `transformers` + `transformers-compat` for the `Eq1`, `Ord1`, `Show1`, and `Read1` functionality.
+* `makeBound` supports `Functor` components
+* Add `MFunctor` instance for `Scope`
+* Add `NFData` instances for `Name`, `Scope`, and `Var`
+* Revamp `Setup.hs` to use `cabal-doctest`. This makes it build
+ with `Cabal-1.25`, and makes the `doctest`s work with `cabal new-build` and
+ sandboxes.
+
1.0.7
------
* Added an `-f-template-haskell` option to allow disabling `template-haskell` support. This is an unsupported configuration but may be useful for expert users in sandbox configurations.
diff --git a/README.markdown b/README.markdown
index 6037fa5..ff872a4 100644
--- a/README.markdown
+++ b/README.markdown
@@ -16,21 +16,21 @@ See [the documentation](http://hackage.haskell.org/package/bound) on hackage for
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE TemplateHaskell #-}
+
import Bound
-import Prelude.Extras
import Control.Applicative
import Control.Monad
+import Data.Functor.Classes
import Data.Foldable
import Data.Traversable
+import Data.Eq.Deriving (deriveEq1) -- these two are from the
+import Text.Show.Deriving (deriveShow1) -- deriving-compat package
infixl 9 :@
data Exp a = V a | Exp a :@ Exp a | Lam (Scope () Exp a)
- deriving (Eq,Ord,Show,Read,Functor,Foldable,Traversable)
+ deriving (Eq,Show,Functor,Foldable,Traversable)
-instance Eq1 Exp
-instance Ord1 Exp
-instance Show1 Exp
-instance Read1 Exp
instance Applicative Exp where pure = V; (<*>) = ap
instance Monad Exp where
@@ -47,6 +47,15 @@ whnf (f :@ a) = case whnf f of
Lam b -> whnf (instantiate1 a b)
f' -> f' :@ a
whnf e = e
+
+deriveEq1 ''Exp
+deriveShow1 ''Exp
+
+main :: IO ()
+main = do
+ let term = lam 'x' (V 'x') :@ V 'y'
+ print term -- Lam (Scope (V (B ()))) :@ V 'y'
+ print $ whnf term -- V 'y'
```
There are longer examples in the [examples/ folder](https://github.com/ekmett/bound/tree/master/examples).
diff --git a/Setup.lhs b/Setup.lhs
index 0aea03c..faedcd3 100644
--- a/Setup.lhs
+++ b/Setup.lhs
@@ -1,44 +1,34 @@
-#!/usr/bin/runhaskell
\begin{code}
+{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -Wall #-}
module Main (main) where
-import Data.List ( nub )
-import Data.Version ( showVersion )
-import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName )
-import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) )
-import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )
-import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose )
-import Distribution.Simple.BuildPaths ( autogenModulesDir )
-import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag )
-import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) )
-import Distribution.Verbosity ( Verbosity )
-import System.FilePath ( (</>) )
+#ifndef MIN_VERSION_cabal_doctest
+#define MIN_VERSION_cabal_doctest(x,y,z) 0
+#endif
+#if MIN_VERSION_cabal_doctest(1,0,0)
+
+import Distribution.Extra.Doctest ( defaultMainWithDoctests )
main :: IO ()
-main = defaultMainWithHooks simpleUserHooks
- { buildHook = \pkg lbi hooks flags -> do
- generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi
- buildHook simpleUserHooks pkg lbi hooks flags
- }
-
-generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()
-generateBuildModule verbosity pkg lbi = do
- let dir = autogenModulesDir lbi
- createDirectoryIfMissingVerbose verbosity True dir
- withLibLBI pkg lbi $ \_ libcfg -> do
- withTestLBI pkg lbi $ \suite suitecfg -> do
- rewriteFile (dir </> "Build_" ++ testName suite ++ ".hs") $ unlines
- [ "module Build_" ++ testName suite ++ " where"
- , "deps :: [String]"
- , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg))
- ]
- where
- formatdeps = map (formatone . snd)
- formatone p = case packageName p of
- PackageName n -> n ++ "-" ++ showVersion (packageVersion p)
-
-testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]
-testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys
+main = defaultMainWithDoctests "doctests"
+
+#else
+
+#ifdef MIN_VERSION_Cabal
+-- If the macro is defined, we have new cabal-install,
+-- but for some reason we don't have cabal-doctest in package-db
+--
+-- Probably we are running cabal sdist, when otherwise using new-build
+-- workflow
+import Warning ()
+#endif
+
+import Distribution.Simple
+
+main :: IO ()
+main = defaultMain
+
+#endif
\end{code}
diff --git a/bound.cabal b/bound.cabal
index 19f425e..a9e31f2 100644
--- a/bound.cabal
+++ b/bound.cabal
@@ -1,6 +1,6 @@
name: bound
category: Language, Compilers/Interpreters
-version: 1.0.7
+version: 2
license: BSD3
cabal-version: >= 1.9.2
license-file: LICENSE
@@ -19,7 +19,7 @@ description:
and we traverse to find free variables, and use the Monad to perform
substitution that avoids bound variables.
.
- Slides describing and motivating this approach to name binding are available
+ Slides describing and motivating this approach to name binding are available
online at:
.
<http://www.slideshare.net/ekmett/bound-making-de-bruijn-succ-less>
@@ -30,7 +30,7 @@ description:
With generalized de Bruijn term you can 'lift' whole trees instead of just
applying 'succ' to individual variables, weakening the all variables bound
by a scope and greatly speeding up instantiation. By giving binders more
- structure we permit easy simultaneous substitution and further speed up
+ structure we permit easy simultaneous substitution and further speed up
instantiation.
extra-source-files:
@@ -48,6 +48,14 @@ extra-source-files:
CHANGELOG.markdown
AUTHORS.markdown
+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.1
+
flag template-haskell
description:
You can disable the use of the `template-haskell` package using `-f-template-haskell`.
@@ -56,6 +64,12 @@ flag template-haskell
default: True
manual: True
+custom-setup
+ setup-depends:
+ base >= 4 && <5,
+ Cabal,
+ cabal-doctest >= 1.0.1 && <1.1
+
source-repository head
type: git
location: git://github.com/ekmett/bound.git
@@ -76,16 +90,17 @@ library
build-depends:
base >= 4 && < 5,
bifunctors >= 3 && < 6,
- binary >= 0.5 && < 0.8,
+ binary >= 0.5 && < 0.9,
bytes >= 0.4 && < 1,
cereal >= 0.3.5.2 && < 0.6,
- comonad >= 3 && < 5,
- hashable >= 1.1 && < 1.3,
- hashable-extras >= 0.1 && < 1,
- prelude-extras >= 0.3 && < 1,
+ comonad >= 3 && < 6,
+ hashable >= 1.2.5.0 && < 1.3,
+ mmorph >= 1.0 && < 1.1,
+ deepseq >= 1.1 && < 1.5,
profunctors >= 3.3 && < 6,
template-haskell >= 2.7 && < 3,
- transformers >= 0.2 && < 0.5
+ transformers >= 0.2 && < 0.6,
+ transformers-compat >= 0.5 && < 1
ghc-options: -Wall -O2 -fspec-constr -fdicts-cheap -funbox-strict-fields
@@ -99,12 +114,53 @@ test-suite Simple
type: exitcode-stdio-1.0
main-is: Simple.hs
hs-source-dirs: examples
+ buildable: True
+
ghc-options: -Wall -threaded
build-depends:
base,
bound,
- prelude-extras,
- transformers
+ deriving-compat >=0.3.4 && <0.4,
+ transformers,
+ transformers-compat
+
+test-suite Overkill
+ type: exitcode-stdio-1.0
+ main-is: Overkill.hs
+ hs-source-dirs: examples
+ ghc-options: -Wall -threaded -main-is Overkill
+ build-depends:
+ base,
+ bound,
+ transformers,
+ transformers-compat,
+ functor-classes-compat,
+ vector
+ if !impl(ghc >= 7.8)
+ buildable: False
+
+test-suite Deriving
+ type: exitcode-stdio-1.0
+ main-is: Deriving.hs
+ hs-source-dirs: examples
+ ghc-options: -Wall -threaded -main-is Deriving
+ build-depends:
+ base,
+ bound,
+ transformers,
+ transformers-compat
+
+test-suite Imperative
+ type: exitcode-stdio-1.0
+ main-is: Imperative.hs
+ hs-source-dirs: examples
+ ghc-options: -Wall -threaded -main-is Imperative
+ build-depends:
+ base,
+ bound,
+ transformers,
+ transformers-compat,
+ void
test-suite doctests
type: exitcode-stdio-1.0
@@ -113,7 +169,6 @@ test-suite doctests
ghc-options: -Wall -threaded
build-depends:
base,
- directory >= 1.0 && < 1.3,
- doctest >= 0.9 && < 0.10,
- filepath,
- vector >= 0.9 && < 0.11
+ doctest >= 0.11.2 && < 0.12,
+ vector >= 0.9 && < 0.13,
+ void
diff --git a/examples/Deriving.hs b/examples/Deriving.hs
index 6ac23c7..231bf67 100644
--- a/examples/Deriving.hs
+++ b/examples/Deriving.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
+{-# LANGUAGE CPP, DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
module Deriving where
import Data.List
@@ -6,7 +6,7 @@ import Data.Foldable
import Data.Traversable
import Control.Monad
import Control.Applicative
-import Prelude.Extras
+import Data.Functor.Classes
import Bound
infixl 9 :@
@@ -17,7 +17,7 @@ data Exp a
| Lam {-# UNPACK #-} !Int (Pat Exp a) (Scope Int Exp a)
| Let {-# UNPACK #-} !Int [Scope Int Exp a] (Scope Int Exp a)
| Case (Exp a) [Alt Exp a]
- deriving (Eq,Ord,Show,Read,Functor,Foldable,Traversable)
+ deriving (Eq,Functor,Foldable,Traversable)
instance Applicative Exp where
pure = V
@@ -31,10 +31,18 @@ instance Monad Exp where
Let n bs e >>= f = Let n (map (>>>= f) bs) (e >>>= f)
Case e as >>= f = Case (e >>= f) (map (>>>= f) as)
+#if MIN_VERSION_transformers(0,5,0) || !MIN_VERSION_transformers(0,4,0)
+instance Eq1 Exp where
+ liftEq eq (V a) (V b) = eq a b
+ liftEq eq (a :@ a') (b :@ b') = liftEq eq a b && liftEq eq a' b'
+ liftEq eq (Lam n p e) (Lam n' p' e') = n == n' && liftEq eq p p' && liftEq eq e e'
+ liftEq eq (Let n bs e) (Let n' bs' e') = n == n' && liftEq (liftEq eq) bs bs' && liftEq eq e e'
+ liftEq eq (Case e as) (Case e' as') = liftEq eq e e' && liftEq (liftEq eq) as as'
+ liftEq _ _ _ = False
+#else
instance Eq1 Exp
-instance Ord1 Exp
-instance Show1 Exp
-instance Read1 Exp
+#endif
+-- And "similarly" for Ord1, Show1 and Read1
data Pat f a
= VarP
@@ -44,6 +52,16 @@ data Pat f a
| ViewP (Scope Int f a) (Pat f a)
deriving (Eq,Ord,Show,Read,Functor,Foldable,Traversable)
+#if MIN_VERSION_transformers(0,5,0) || !MIN_VERSION_transformers(0,4,0)
+instance (Eq1 f, Monad f) => Eq1 (Pat f) where
+ liftEq _ VarP VarP = True
+ liftEq _ WildP WildP = True
+ liftEq eq (AsP p) (AsP p') = liftEq eq p p'
+ liftEq eq (ConP g ps) (ConP g' ps') = g == g' && liftEq (liftEq eq) ps ps'
+ liftEq eq (ViewP e p) (ViewP e' p') = liftEq eq e e' && liftEq eq p p'
+ liftEq _ _ _ = False
+#endif
+
instance Bound Pat where
VarP >>>= _ = VarP
WildP >>>= _ = WildP
@@ -52,7 +70,13 @@ instance Bound Pat where
ViewP e p >>>= f = ViewP (e >>>= f) (p >>>= f)
data Alt f a = Alt {-# UNPACK #-} !Int (Pat f a) (Scope Int f a)
- deriving (Eq,Ord,Show,Read,Functor,Foldable,Traversable)
+ deriving (Eq,Functor,Foldable,Traversable)
+
+#if MIN_VERSION_transformers(0,5,0) || !MIN_VERSION_transformers(0,4,0)
+instance (Eq1 f, Monad f) => Eq1 (Alt f) where
+ liftEq eq (Alt n p b) (Alt n' p' b') =
+ n == n' && liftEq eq p p' && liftEq eq b b'
+#endif
instance Bound Alt where
Alt n p b >>>= f = Alt n (p >>>= f) (b >>>= f)
diff --git a/examples/Imperative.hs b/examples/Imperative.hs
new file mode 100644
index 0000000..0ff7ef6
--- /dev/null
+++ b/examples/Imperative.hs
@@ -0,0 +1,293 @@
+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable, RankNTypes, ScopedTypeVariables #-}
+module Imperative where
+
+-- It's possible to use bound "sideways" in order to support terms which do not
+-- have a Monad instance. A typical situation in which this would happen is when
+-- modelling an imperative language: variables are bound by statements, but they
+-- are used in positions where it would make no sense to replace them by another
+-- statement.
+
+import Bound.Class
+import Bound.Scope.Simple
+import Bound.Term
+import Bound.Var
+import Control.Applicative
+import Control.Monad (ap)
+import Control.Monad.Trans.Class (lift)
+import Data.Foldable
+import Data.Functor.Identity
+import Data.IORef
+import Data.Traversable
+import Data.Void (Void, absurd)
+
+
+-- PART 1: We want to model a tiny assembly language.
+--
+-- %0 = add 1 2
+-- %1 = add %0 %0
+-- ret %1
+--
+-- Add binds a fresh variable, and its operands can either be literals or
+-- previously-bound variables. Ret must be the last instruction.
+--
+-- Operand is monadic, traversable, and satisfies all the other requirements in
+-- order to be used with bound. But this is not sufficient, since Operand is
+-- not the whole language: we also need to define Prog, the sequence of
+-- instructions.
+data Operand a
+ = Lit Int
+ | Var a
+ deriving (Eq,Ord,Show,Read,Functor,Foldable,Traversable)
+
+instance Applicative Operand where
+ pure = Var
+ (<*>) = ap
+
+instance Monad Operand where
+ return = pure
+ Lit i >>= _ = Lit i
+ Var x >>= f = f x
+
+-- The following definition correctly models the instructions and their free
+-- variables. But since the Var in Operand cannot be replaced with a Prog, this
+-- definition is not monadic, and so we cannot manipulate the (Scope () Prog a)
+-- using bound's functions. This defeats the point of using Scope at all!
+--
+-- data Prog a
+-- = Ret (Operand a)
+-- | Add (Operand a) (Operand a)
+-- (Scope () Prog a) -- one more bound variable, available
+-- -- in the rest of the program
+--
+-- The sideways trick is to replace the Operand constructor with a (* -> *) type
+-- parameter. Instantiating this with the real Operand will allow Operand to
+-- access the same free variables as Prog. But if we instantiate this with
+-- (Scope () Operand) instead, then the operands will have access to one extra
+-- bound variable! This way, we can bind fresh variables which can only be used
+-- inside the operands, and not in Prog.
+data Prog operand a
+ = Ret (operand a)
+ | Add (operand a) (operand a)
+ (Prog (Scope () operand) a)
+ deriving (Eq,Ord,Show,Read,Functor,Foldable,Traversable)
+
+-- The fact that the variables are not available in Prog after they are bound
+-- might seem strange, and we'll fix this in part 2, but it is actually a good
+-- thing. We want to be able to replace those variables with operand values, and
+-- that would not be possible if variables were allowed to appear inside Prog
+-- but outside of an operand.
+pInstantiate1 :: forall operand b a. (Applicative operand, Monad operand)
+ => operand a
+ -> Prog (Scope b operand) a
+ -> Prog operand a
+pInstantiate1 = go instantiate1
+ where
+ -- A value of type (Prog (Scope b operand) a) contains operands of type
+ -- (Scope b operand a), on which we can call instantiate1:
+ --
+ -- instantiate1 :: operand a -> Scope b operand a -> operand a
+ --
+ -- In the function below, (Scope b operand) and operand become o and o',
+ -- and instantiate1 is called f:
+ --
+ -- f :: operand v -> o v -> o' v
+ go :: forall o o' u
+ . (forall v. operand v -> o v -> o' v)
+ -> operand u -> Prog o u -> Prog o' u
+ go f x (Ret o) = Ret (f x o)
+ go f x (Add o1 o2 cc) = Add (f x o1) (f x o2)
+ $ go f' x cc
+ where
+ -- The rest of the program has access to one extra variable:
+ --
+ -- cc :: Prog (Scope () (Scope b operand)) a
+ --
+ -- In there, the operands have type (Scope () (Scope b operand) a), and
+ -- this time we cannot call instantiate1 because it would instantiate ()
+ -- instead of instantiating b. Instead, we create a function f' which
+ -- preserves the outer (Scope ()):
+ --
+ -- f' :: operand a -> Scope () (Scope b operand) a -> Scope () operand a
+ -- f' :: operand a -> Scope () o a -> Scope () o' a
+ --
+ -- In the recursive call to go, (Scope () (Scope b operand)) and
+ -- (Scope () operand) become o and o', and f' is called f.
+ f' :: operand v -> Scope () o v -> Scope () o' v
+ f' v = Scope . f (fmap F v) . unscope
+
+pAbstract1 :: forall operand a. (Applicative operand, Monad operand, Eq a)
+ => a
+ -> Prog operand a
+ -> Prog (Scope () operand) a
+pAbstract1 = go abstract1
+ where
+ go :: forall o o' u. Eq u
+ => (forall v. Eq v => v -> o v -> o' v)
+ -> u -> Prog o u -> Prog o' u
+ go f x (Ret o) = Ret (f x o)
+ go f x (Add o1 o2 cc) = Add (f x o1) (f x o2)
+ $ go f' x cc
+ where
+ f' :: forall v. Eq v => v -> Scope () o v -> Scope () o' v
+ f' v = Scope . f (F v) . unscope
+
+evalOperand :: Operand Void -> Int
+evalOperand (Lit i) = i
+evalOperand (Var void) = absurd void
+
+-- |
+-- >>> :{
+-- let Just prog = closed
+-- $ Add (Lit 1) (Lit 2) $ pAbstract1 "%0"
+-- $ Add (Var "%0") (Var "%0") $ pAbstract1 "%1"
+-- $ Ret (Var "%1")
+-- :}
+--
+-- >>> evalProg prog
+-- 6
+evalProg :: Prog Operand Void -> Int
+evalProg (Ret o) = evalOperand o
+evalProg (Add o1 o2 cc) = evalProg cc'
+ where
+ result :: Int
+ result = evalOperand o1 + evalOperand o2
+
+ cc' :: Prog Operand Void
+ cc' = pInstantiate1 (Lit result) cc
+
+
+-- PART 2: Here's a slightly more complicated language.
+--
+-- %0 = add 1 2
+-- %1 = add %0 %0
+-- swp %0 %1
+-- ret %1
+--
+-- The new swp command swaps the contents of two variables, so the two arguments
+-- must be previously-bound variables, they cannot be literals. This time the
+-- naïve definition looks like this:
+--
+-- data Prog' a
+-- = Ret' (Operand a)
+-- | Swp' a a
+-- (Prog' a)
+-- | Add' (Operand a) (Operand a)
+-- (Scope () Prog' a)
+--
+-- If we apply the sideways trick to this definition, the newly-bound variables
+-- will only be available in the operands, and so it won't be possible to call
+-- swp on them. The first step towards a solution is to add seemingly-useless
+-- Identity wrappers:
+--
+-- data Prog' a
+-- = Ret' (Operand a)
+-- | Swp' (Identity a) (Identity a)
+-- (Prog' a)
+-- | Add' (Operand a) (Operand a)
+-- (Scope () Prog' a)
+--
+-- We can now apply the sideways trick twice: once for Operand, and once for
+-- Identity. This gives us a lot of control: we can bind fresh variables which
+-- can only be used inside the operands, we can bind fresh variables which can
+-- be used inside Prog but not inside the operands, and as required for this
+-- example, we can bind fresh variables which can be used in both.
+data Prog' operand identity a
+ = Ret' (operand a)
+ | Swp' (identity a) (identity a)
+ (Prog' operand identity a)
+ | Add' (operand a) (operand a)
+ (Prog' (Scope () operand) (Scope () identity) a)
+ deriving (Eq,Ord,Show,Read,Functor,Foldable,Traversable)
+
+-- Bound variables can now occur in both operand and identity, so we can no
+-- longer instantiate them with operands. Instead, we'll have to instantiate
+-- them with a value which both (Operand a) and (Identity a) can contain:
+-- a free variable.
+pInstantiate1' :: ( Applicative operand, Monad operand
+ , Applicative identity, Monad identity
+ )
+ => a
+ -> Prog' (Scope () operand) (Scope () identity) a
+ -> Prog' operand identity a
+pInstantiate1' = go (instantiate1 . pure) (instantiate1 . pure)
+ where
+ go :: forall o o' i i' u
+ . (forall v. v -> o v -> o' v)
+ -> (forall v. v -> i v -> i' v)
+ -> u -> Prog' o i u -> Prog' o' i' u
+ go fo fi x = go'
+ where
+ go' (Ret' o) = Ret' (fo x o)
+ go' (Swp' i1 i2 cc) = Swp' (fi x i1)
+ (fi x i2)
+ (go' cc)
+ go' (Add' o1 o2 cc) = Add' (fo x o1)
+ (fo x o2)
+ (go fo' fi' x cc)
+
+ fo' :: v -> Scope () o v -> Scope () o' v
+ fo' v = Scope . fo (F v) . unscope
+
+ fi' :: v -> Scope () i v -> Scope () i' v
+ fi' v = Scope . fi (F v) . unscope
+
+pAbstract1' :: ( Applicative operand, Monad operand
+ , Applicative identity, Monad identity
+ , Eq a
+ )
+ => a
+ -> Prog' operand identity a
+ -> Prog' (Scope () operand) (Scope () identity) a
+pAbstract1' = go abstract1 abstract1
+ where
+ go :: forall o o' i i' u. Eq u
+ => (forall v. Eq v => v -> o v -> o' v)
+ -> (forall v. Eq v => v -> i v -> i' v)
+ -> u -> Prog' o i u -> Prog' o' i' u
+ go fo fi x = go'
+ where
+ go' (Ret' o) = Ret' (fo x o)
+ go' (Swp' i1 i2 cc) = Swp' (fi x i1)
+ (fi x i2)
+ (go' cc)
+ go' (Add' o1 o2 cc) = Add' (fo x o1)
+ (fo x o2)
+ (go fo' fi' x cc)
+
+ fo' :: Eq v => v -> Scope () o v -> Scope () o' v
+ fo' v = Scope . fo (F v) . unscope
+
+ fi' :: Eq v => v -> Scope () i v -> Scope () i' v
+ fi' v = Scope . fi (F v) . unscope
+
+evalOperand' :: Operand (IORef Int) -> IO Int
+evalOperand' (Lit i) = return i
+evalOperand' (Var ref) = readIORef ref
+
+-- |
+-- >>> :{
+-- let Just prog' = closed
+-- $ Add' (Lit 1) (Lit 2) $ pAbstract1' "%0"
+-- $ Add' (Var "%0") (Var "%0") $ pAbstract1' "%1"
+-- $ Swp' (Identity "%0") (Identity "%1")
+-- $ Ret' (Var "%1")
+-- :}
+--
+-- >>> evalProg' prog'
+-- 3
+evalProg' :: Prog' Operand Identity (IORef Int) -> IO Int
+evalProg' (Ret' o) = evalOperand' o
+evalProg' (Swp' (Identity ref1) (Identity ref2) cc) = do
+ x <- readIORef ref1
+ y <- readIORef ref2
+ writeIORef ref1 y
+ writeIORef ref2 x
+ evalProg' cc
+evalProg' (Add' o1 o2 cc) = do
+ result <- (+) <$> evalOperand' o1 <*> evalOperand' o2
+ ref <- newIORef result
+ evalProg' (pInstantiate1' ref cc)
+
+
+main :: IO ()
+main = return ()
diff --git a/examples/Overkill.hs b/examples/Overkill.hs
index 832beac..ad7af8e 100644
--- a/examples/Overkill.hs
+++ b/examples/Overkill.hs
@@ -1,13 +1,17 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeOperators #-}
-{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
+{-# OPTIONS_GHC -fwarn-incomplete-patterns -fno-warn-orphans #-}
module Overkill where
+-- Dara.Functor.Classes in transformers 0.4.0 are totally different
+#if MIN_VERSION_transformers(0,5,0) || !MIN_VERSION_transformers(0,4,0)
+
import Data.Vector as Vector hiding ((++), map)
import Data.List as List
import Data.Foldable
@@ -16,17 +20,14 @@ import Data.Monoid (Monoid(..))
import Control.Monad
import Control.Applicative
import Prelude hiding (foldr)
-import Prelude.Extras
+import Data.Functor.Classes
+import Data.Vector.Functor.Classes ()
import Data.Type.Equality
import Bound
infixl 9 :@
infixr 5 :>
--- little orphan instances
-instance Show1 Vector where showsPrec1 = showsPrec
-instance Eq1 Vector where (==#) = (==)
-
data Exp a
= Var a
| Exp a :@ Exp a
@@ -79,24 +80,24 @@ instance Monad Exp where
Lam p e >>= f = Lam (p >>>= f) (e >>>= f)
Let bs e >>= f = Let (fmap (>>>= f) bs) (e >>>= f)
-instance Eq a => Eq (Exp a) where (==) = (==#)
+instance Eq a => Eq (Exp a) where (==) = eq1
instance Eq1 Exp where
- Var a ==# Var b = a == b
- (a :@ b) ==# (c :@ d) = a ==# c && b ==# d
- Lam ps a ==# Lam qs b =
- case eqPat' ps qs of
+ liftEq eq (Var a) (Var b) = eq a b
+ liftEq eq (a :@ a') (b :@ b') = liftEq eq a b && liftEq eq a' b'
+ liftEq eq (Lam ps a) (Lam qs b) =
+ case eqPat' eq ps qs of
Nothing -> False
- Just Refl -> a ==# b
+ Just Refl -> liftEq eq a b
- Let as a ==# Let bs b = as == bs && a ==# b
- _ ==# _ = False
+ liftEq eq (Let as a) (Let bs b) = liftEq (liftEq eq) as bs && liftEq eq a b
+ liftEq _ _ _ = False
instance Show a => Show (Exp a) where showsPrec = showsPrec1
instance Show1 Exp where
- showsPrec1 d (Var a) = showParen (d > 10) $ showString "Var " . showsPrec 11 a
- showsPrec1 d (a :@ b) = showParen (d > 9) $ showsPrec1 9 a . showString " :@ " . showsPrec1 10 b
- showsPrec1 d (Lam ps b) = showParen (d > 10) $ showString "Lam " . showsPrec1 11 ps . showChar ' ' . showsPrec1 11 b
- showsPrec1 d (Let bs b) = showParen (d > 10) $ showString "Let " . showsPrec1 11 bs . showChar ' ' . showsPrec1 11 b
+ liftShowsPrec s _ d (Var a) = showParen (d > 10) $ showString "Var " . s 11 a
+ liftShowsPrec s sl d (a :@ b) = showParen (d > 9) $ liftShowsPrec s sl 9 a . showString " :@ " . liftShowsPrec s sl 10 b
+ liftShowsPrec s sl d (Lam ps b) = showParen (d > 10) $ showString "Lam " . liftShowsPrec s sl 11 ps . showChar ' ' . liftShowsPrec s sl 11 b
+ liftShowsPrec s sl d (Let bs b) = showParen (d > 10) $ showString "Let " . liftShowsPrec (liftShowsPrec s sl) (liftShowList s sl) 11 bs . showChar ' ' . liftShowsPrec s sl 11 b
-- * smart lam
@@ -142,39 +143,40 @@ let_ bs b = Let (Vector.fromList $ map (abstr . snd) bs) (abstr b)
-- ** A Kind of Shape
-eqPat :: (Eq1 f, Eq a) => Pat b f a -> Pat b' f a -> Bool
-eqPat VarP VarP = True
-eqPat WildP WildP = True
-eqPat (AsP p) (AsP q) = eqPat p q
-eqPat (ConP g ps) (ConP h qs) = g == h && eqPats ps qs
-eqPat (ViewP e p) (ViewP f q) = e ==# f && eqPat p q
-eqPat _ _ = False
+eqPat :: (Eq1 f) => (a -> b -> Bool) -> Pat i f a -> Pat i' f b -> Bool
+eqPat _ VarP VarP = True
+eqPat _ WildP WildP = True
+eqPat eq (AsP p) (AsP q) = eqPat eq p q
+eqPat eq (ConP g ps) (ConP h qs) = g == h && eqPats eq ps qs
+eqPat eq (ViewP e p) (ViewP f q) = liftEq eq e f && eqPat eq p q
+eqPat _ _ _ = False
-- The same as eqPat, but if the patterns are equal, it returns a
-- proof that their type arguments are the same.
-eqPat' :: (Eq1 f, Eq a) => Pat b f a -> Pat b' f a -> Maybe (b :~: b')
-eqPat' VarP VarP = Just Refl
-eqPat' WildP WildP = Just Refl
-eqPat' (AsP p) (AsP q) = do
- Refl <- eqPat' p q
+eqPat' :: (Eq1 f) => (a -> a' -> Bool) -> Pat b f a -> Pat b' f a' -> Maybe (b :~: b')
+eqPat' _ VarP VarP = Just Refl
+eqPat' _ WildP WildP = Just Refl
+eqPat' eq (AsP p) (AsP q) = do
+ Refl <- eqPat' eq p q
Just Refl
-eqPat' (ConP g ps) (ConP h qs) = do
+eqPat' eq (ConP g ps) (ConP h qs) = do
guard (g == h)
- Refl <- eqPats' ps qs
+ Refl <- eqPats' eq ps qs
Just Refl
-eqPat' (ViewP e p) (ViewP f q) = guard (e ==# f) >> eqPat' p q
-eqPat' _ _ = Nothing
+eqPat' eq (ViewP e p) (ViewP f q) = guard (liftEq eq e f) >> eqPat' eq p q
+eqPat' _ _ _ = Nothing
+
+instance Eq1 f => Eq1 (Pat b f) where liftEq = eqPat
+instance (Eq1 f, Eq a) => Eq (Pat b f a) where (==) = eq1
-instance Eq1 f => Eq1 (Pat b f) where (==#) = eqPat
-instance (Eq1 f, Eq a) => Eq (Pat b f a) where (==) = eqPat
+instance (Show1 f, Show a) => Show (Pat b f a) where showsPrec = showsPrec1
-instance Show1 f => Show1 (Pat b f) where showsPrec1 = showsPrec
-instance (Show1 f, Show a) => Show (Pat b f a) where
- showsPrec _ VarP = showString "VarP"
- showsPrec _ WildP = showString "WildP"
- showsPrec d (AsP p) = showParen (d > 10) $ showString "AsP " . showsPrec 11 p
- showsPrec d (ConP g ps) = showParen (d > 10) $ showString "ConP " . showsPrec 11 g . showChar ' ' . showsPrec 11 ps
- showsPrec d (ViewP e p) = showParen (d > 10) $ showString "ViewP " . showsPrec1 11 e . showChar ' ' . showsPrec 11 p
+instance Show1 f => Show1 (Pat b f) where
+ liftShowsPrec _ _ _ VarP = showString "VarP"
+ liftShowsPrec _ _ _ WildP = showString "WildP"
+ liftShowsPrec s sl d (AsP p) = showParen (d > 10) $ showString "AsP " . liftShowsPrec s sl 11 p
+ liftShowsPrec s sl d (ConP g ps) = showParen (d > 10) $ showString "ConP " . showsPrec 11 g . showChar ' ' . liftShowsPrec s sl 11 ps
+ liftShowsPrec s sl d (ViewP e p) = showParen (d > 10) $ showString "ViewP " . liftShowsPrec s sl 11 e . showChar ' ' . liftShowsPrec s sl 11 p
instance Functor f => Functor (Pat b f) where
fmap _ VarP = VarP
@@ -204,29 +206,29 @@ instance Bound (Pat b) where
ViewP e p >>>= f = ViewP (e >>= f) (p >>>= f)
-- ** Pats
-eqPats :: (Eq1 f, Eq a) => Pats bs f a -> Pats bs' f a -> Bool
-eqPats NilP NilP = True
-eqPats (p :> ps) (q :> qs) = eqPat p q && eqPats ps qs
-eqPats _ _ = False
+eqPats :: (Eq1 f) => (a -> b -> Bool) -> Pats bs f a -> Pats bs' f b -> Bool
+eqPats _ NilP NilP = True
+eqPats eq (p :> ps) (q :> qs) = eqPat eq p q && eqPats eq ps qs
+eqPats _ _ _ = False
-- Like eqPats, but if the patses are equal, it returns a proof that their
-- type arguments are the same.
-eqPats' :: (Eq1 f, Eq a) => Pats bs f a -> Pats bs' f a -> Maybe (bs :~: bs')
-eqPats' NilP NilP = Just Refl
-eqPats' (p :> ps) (q :> qs) = do
- Refl <- eqPat' p q
- Refl <- eqPats' ps qs
+eqPats' :: (Eq1 f) => (a -> a' -> Bool) -> Pats bs f a -> Pats bs' f a' -> Maybe (bs :~: bs')
+eqPats' _ NilP NilP = Just Refl
+eqPats' eq (p :> ps) (q :> qs) = do
+ Refl <- eqPat' eq p q
+ Refl <- eqPats' eq ps qs
Just Refl
-eqPats' _ _ = Nothing
+eqPats' _ _ _ = Nothing
-instance Eq1 f => Eq1 (Pats bs f) where (==#) = eqPats
-instance (Eq1 f, Eq a) => Eq (Pats bs f a) where (==) = eqPats
+instance Eq1 f => Eq1 (Pats bs f) where liftEq = eqPats
+instance (Eq1 f, Eq a) => Eq (Pats bs f a) where (==) = eq1
instance (Show1 f, Show a) => Show (Pats bs f a) where showsPrec = showsPrec1
instance Show1 f => Show1 (Pats bs f) where
- showsPrec1 _ NilP = showString "NilP"
- showsPrec1 d (p :> ps) = showParen (d > 5) $
- showsPrec1 6 p . showString " :> " . showsPrec1 5 ps
+ liftShowsPrec _ _ _ NilP = showString "NilP"
+ liftShowsPrec s sl d (p :> ps) = showParen (d > 5) $
+ liftShowsPrec s sl 6 p . showString " :> " . liftShowsPrec s sl 5 ps
instance Functor f => Functor (Pats bs f) where
fmap _ NilP = NilP
@@ -339,5 +341,6 @@ instance Show (Path i) where
--
-- >>> lam (conp "Hello" [varp "x", wildp]) (Var "y")
-- Lam (ConP "Hello" (VarP :> WildP :> NilP)) (Scope (Var (F (Var "y"))))
+#endif
main :: IO ()
main = return ()
diff --git a/examples/Simple.hs b/examples/Simple.hs
index f7fff4f..a4e0606 100644
--- a/examples/Simple.hs
+++ b/examples/Simple.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP, TemplateHaskell #-}
module Main where
-- this is a simple example where lambdas only bind a single variable at a time
@@ -8,13 +9,14 @@ import Data.Foldable hiding (notElem)
import Data.Maybe (fromJust)
import Data.Traversable
import Control.Monad
-import Control.Monad.Trans.Class
import Control.Applicative
import Prelude hiding (foldr,abs)
-import Prelude.Extras
+import Data.Deriving (deriveEq1, deriveOrd1, deriveRead1, deriveShow1)
+import Data.Functor.Classes
import Bound
import System.Exit
+
infixl 9 :@
data Exp a
@@ -22,7 +24,6 @@ data Exp a
| Exp a :@ Exp a
| Lam (Scope () Exp a)
| Let [Scope Int Exp a] (Scope Int Exp a)
- deriving (Eq,Ord,Show,Read)
-- | A smart constructor for Lam
--
@@ -58,11 +59,15 @@ instance Monad Exp where
Lam e >>= f = Lam (e >>>= f)
Let bs b >>= f = Let (map (>>>= f) bs) (b >>>= f)
--- these 4 classes are needed to help Eq, Ord, Show and Read pass through Scope
-instance Eq1 Exp where (==#) = (==)
-instance Ord1 Exp where compare1 = compare
-instance Show1 Exp where showsPrec1 = showsPrec
-instance Read1 Exp where readsPrec1 = readsPrec
+deriveEq1 ''Exp
+deriveOrd1 ''Exp
+deriveRead1 ''Exp
+deriveShow1 ''Exp
+
+instance Eq a => Eq (Exp a) where (==) = eq1
+instance Ord a => Ord (Exp a) where compare = compare1
+instance Show a => Show (Exp a) where showsPrec = showsPrec1
+instance Read a => Read (Exp a) where readsPrec = readsPrec1
-- | Compute the normal form of an expression
nf :: Exp a -> Exp a
@@ -156,11 +161,12 @@ prettyWith :: [String] -> Exp String -> String
prettyWith vs t = prettyPrec (filter (`notElem` toList t) vs) False 0 t ""
pretty :: Exp String -> String
-pretty = prettyWith $ [ [i] | i <- ['a'..'z']] ++ [i : show j | j <- [1..], i <- ['a'..'z'] ]
+pretty = prettyWith $ [ [i] | i <- ['a'..'z']] ++ [i : show j | j <- [1 :: Int ..], i <- ['a'..'z'] ]
pp :: Exp String -> IO ()
pp = putStrLn . pretty
+main :: IO ()
main = do
pp cooked
let result = nf cooked
diff --git a/src/Bound.hs b/src/Bound.hs
index 1623220..364992b 100644
--- a/src/Bound.hs
+++ b/src/Bound.hs
@@ -18,38 +18,45 @@
-- An untyped lambda calculus:
--
-- @
--- {-\# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable \#-}
+-- {-\# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable, TemplateHaskell \#-}
-- import Bound
-- import Control.Applicative
-- import Control.Monad ('Control.Monad.ap')
--- import Prelude.Extras
+-- import Data.Functor.Classes
-- import Data.Foldable
-- import Data.Traversable
+-- -- This is from deriving-compat package
+-- import Data.Deriving (deriveEq1, deriveOrd1, deriveRead1, deriveShow1)
-- @
--
-- @
-- infixl 9 :\@
-- data Exp a = V a | Exp a :\@ Exp a | Lam ('Scope' () Exp a)
--- deriving ('Eq','Ord','Show','Read','Functor','Data.Foldable.Foldable','Data.Foldable.Traversable')
+-- deriving ('Functor','Data.Foldable.Foldable','Data.Foldable.Traversable')
-- @
--
-- @
--- instance 'Prelude.Extras.Eq1' Exp
--- instance 'Prelude.Extras.Ord1' Exp
--- instance 'Prelude.Extras.Show1' Exp
--- instance 'Prelude.Extras.Read1' Exp
-- instance 'Control.Applicative.Applicative' Exp where 'Control.Applicative.pure' = V; ('<*>') = 'Control.Monad.ap'
--- @
---
--- @
-- instance 'Monad' Exp where
-- 'return' = V
-- V a '>>=' f = f a
--- (x :\@ y) '>>=' f = (x '>>=' f) :\@ (y >>= f)
+-- (x :\@ y) '>>=' f = (x '>>=' f) :\@ (y '>>=' f)
-- Lam e '>>=' f = Lam (e '>>>=' f)
-- @
--
-- @
+-- deriveEq1 ''Exp
+-- deriveOrd1 ''Exp
+-- deriveRead1 ''Exp
+-- deriveShow1 ''Exp
+--
+-- instance 'Eq' a => 'Eq' (Exp a) where (==) = eq1
+-- instance 'Ord' a => 'Ord' (Exp a) where compare = compare1
+-- instance 'Show' a => 'Show' (Exp a) where showsPrec = showsPrec1
+-- instance 'Read' a => 'Read' (Exp a) where readsPrec = readsPrec1
+-- @
+--
+-- @
-- lam :: 'Eq' a => a -> 'Exp' a -> 'Exp' a
-- lam v b = Lam ('abstract1' v b)
-- @
@@ -80,7 +87,7 @@
-- recursion pattern in their generalized de Bruijn representation. It is named
-- 'Scope' to match up with the terminology and usage pattern from Conor McBride
-- and James McKinna's \"I am not a number: I am a free variable\", available
--- from <http://www.cs.st-andrews.ac.uk/~james/RESEARCH/notanum.pdf>, but since
+-- from <http://www.cs.ru.nl/~james/RESEARCH/haskell2004.pdf>, but since
-- the set of variables is visible in the type, we can provide stronger type
-- safety guarantees.
--
diff --git a/src/Bound/Class.hs b/src/Bound/Class.hs
index 8728cb2..ea8f365 100644
--- a/src/Bound/Class.hs
+++ b/src/Bound/Class.hs
@@ -56,6 +56,9 @@ infixl 1 >>>=
-- This is useful for types like expression lists, case alternatives,
-- schemas, etc. that may not be expressions in their own right, but often
-- contain expressions.
+--
+-- /Note:/ 'Control.Monad.Free.Free' isn't "really" a monad transformer, even if
+-- the kind matches. Therefore there isn't @'Bound' 'Control.Monad.Free.Free'@ instance.
class Bound t where
-- | Perform substitution
--
diff --git a/src/Bound/Name.hs b/src/Bound/Name.hs
index 77eb1ce..76eb642 100644
--- a/src/Bound/Name.hs
+++ b/src/Bound/Name.hs
@@ -47,6 +47,7 @@ import Bound.Var
import Control.Applicative
#endif
import Control.Comonad
+import Control.DeepSeq
import Control.Monad (liftM, liftM2)
#if __GLASGOW_HASKELL__ < 710
import Data.Foldable
@@ -59,18 +60,18 @@ import qualified Data.Binary as Binary
import Data.Binary (Binary)
import Data.Bitraversable
import Data.Bytes.Serial
+import Data.Functor.Classes
#ifdef __GLASGOW_HASKELL__
import Data.Data
# if __GLASGOW_HASKELL__ >= 704
import GHC.Generics
# endif
#endif
-import Data.Hashable
-import Data.Hashable.Extras
+import Data.Hashable (Hashable(..))
+import Data.Hashable.Lifted (Hashable1(..), Hashable2(..))
import Data.Profunctor
import qualified Data.Serialize as Serialize
import Data.Serialize (Serialize)
-import Prelude.Extras
-------------------------------------------------------------------------------
-- Names
@@ -118,12 +119,12 @@ instance Eq b => Eq (Name n b) where
{-# INLINE (==) #-}
instance Hashable2 Name where
- hashWithSalt2 m (Name _ a) = hashWithSalt m a
- {-# INLINE hashWithSalt2 #-}
+ liftHashWithSalt2 _ h s (Name _ a) = h s a
+ {-# INLINE liftHashWithSalt2 #-}
instance Hashable1 (Name n) where
- hashWithSalt1 m (Name _ a) = hashWithSalt m a
- {-# INLINE hashWithSalt1 #-}
+ liftHashWithSalt h s (Name _ a) = h s a
+ {-# INLINE liftHashWithSalt #-}
instance Hashable a => Hashable (Name n a) where
hashWithSalt m (Name _ a) = hashWithSalt m a
@@ -163,24 +164,45 @@ instance Comonad (Name n) where
extend f w@(Name n _) = Name n (f w)
{-# INLINE extend #-}
-instance Eq1 (Name b) where
- (==#) = (==)
- {-# INLINE (==#) #-}
-instance Ord1 (Name b) where
- compare1 = compare
- {-# INLINE compare1 #-}
+#if MIN_VERSION_transformers(0,5,0) || !MIN_VERSION_transformers(0,4,0)
+
+instance Eq2 Name where
+ liftEq2 _ g (Name _ b) (Name _ d) = g b d
+
+instance Ord2 Name where
+ liftCompare2 _ g (Name _ b) (Name _ d) = g b d
+
+instance Show2 Name where
+ liftShowsPrec2 f _ h _ d (Name a b) = showsBinaryWith f h "Name" d a b
+
+instance Read2 Name where
+ liftReadsPrec2 f _ h _ = readsData $ readsBinaryWith f h "Name" Name
+
+instance Eq1 (Name b) where
+ liftEq f (Name _ b) (Name _ d) = f b d
+
+instance Ord1 (Name b) where
+ liftCompare f (Name _ b) (Name _ d) = f b d
+
+instance Show b => Show1 (Name b) where
+ liftShowsPrec f _ d (Name a b) = showsBinaryWith showsPrec f "Name" d a b
+
+instance Read b => Read1 (Name b) where
+ liftReadsPrec f _ = readsData $ readsBinaryWith readsPrec f "Name" Name
+
+#else
+
+instance Eq1 (Name b) where eq1 = (==)
+instance Ord1 (Name b) where compare1 = compare
instance Show b => Show1 (Name b) where showsPrec1 = showsPrec
instance Read b => Read1 (Name b) where readsPrec1 = readsPrec
--- these are slightly too restrictive, but still safe
-instance Eq2 Name where
- (==##) = (==)
- {-# INLINE (==##) #-}
-instance Ord2 Name where
- compare2 = compare
- {-# INLINE compare2 #-}
-instance Show2 Name where showsPrec2 = showsPrec
-instance Read2 Name where readsPrec2 = readsPrec
+--instance Eq2 Name where eq2 = (==)
+--instance Ord2 Name where compare2 = compare
+--instance Show2 Name where showsPrec2 = showsPrec
+--instance Read2 Name where readsPrec2 = readsPrec
+
+#endif
instance Serial2 Name where
serializeWith2 pb pf (Name b a) = pb b >> pf a
@@ -209,6 +231,10 @@ instance (Serialize b, Serialize a) => Serialize (Name b a) where
put = serializeWith2 Serialize.put Serialize.put
get = deserializeWith2 Serialize.get Serialize.get
+# if __GLASGOW_HASKELL__ >= 704
+instance (NFData b, NFData a) => NFData (Name b a)
+# endif
+
-------------------------------------------------------------------------------
-- Abstraction
-------------------------------------------------------------------------------
diff --git a/src/Bound/Scope.hs b/src/Bound/Scope.hs
index 8d749e4..16351c6 100644
--- a/src/Bound/Scope.hs
+++ b/src/Bound/Scope.hs
@@ -69,8 +69,9 @@ module Bound.Scope
import Bound.Class
import Bound.Var
import Control.Applicative
+import Control.DeepSeq
import Control.Monad hiding (mapM, mapM_)
-import Control.Monad.Trans.Class
+import Control.Monad.Morph
import Data.Bifunctor
import Data.Bifoldable
import qualified Data.Binary as Binary
@@ -80,16 +81,19 @@ import Data.Bytes.Get
import Data.Bytes.Put
import Data.Bytes.Serial
import Data.Foldable
-import Data.Hashable
-import Data.Hashable.Extras
+import Data.Functor.Classes
+import Data.Hashable (Hashable (..))
+import Data.Hashable.Lifted (Hashable1(..), hashWithSalt1)
import Data.Monoid
import qualified Data.Serialize as Serialize
import Data.Serialize (Serialize)
import Data.Traversable
-import Prelude.Extras
import Prelude hiding (foldr, mapM, mapM_)
import Data.Data
+-- $setup
+-- >>> import Bound.Var
+
-------------------------------------------------------------------------------
-- Scopes
-------------------------------------------------------------------------------
@@ -118,7 +122,6 @@ newtype Scope b f a = Scope { unscope :: f (Var b (f a)) }
deriving Typeable
#endif
-
-------------------------------------------------------------------------------
-- Instances
-------------------------------------------------------------------------------
@@ -158,46 +161,90 @@ instance MonadTrans (Scope b) where
lift m = Scope (return (F m))
{-# INLINE lift #-}
-instance (Monad f, Eq b, Eq1 f, Eq a) => Eq (Scope b f a) where
- (==) = (==#)
- {-# INLINE (==) #-}
-instance (Monad f, Eq b, Eq1 f) => Eq1 (Scope b f) where
- a ==# b = fromScope a ==# fromScope b
- {-# INLINE (==#) #-}
-
-instance (Monad f, Ord b, Ord1 f, Ord a) => Ord (Scope b f a) where
- compare = compare1
- {-# INLINE compare #-}
-instance (Monad f, Ord b, Ord1 f) => Ord1 (Scope b f) where
+instance MFunctor (Scope b) where
+#if __GLASGOW_HASKELL__ < 710
+ hoist t (Scope b) = Scope $ t (liftM (liftM t) b)
+#else
+ hoist = hoistScope
+#endif
+ {-# INLINE hoist #-}
+
+instance (Monad f, Eq b, Eq1 f, Eq a) => Eq (Scope b f a) where (==) = eq1
+instance (Monad f, Ord b, Ord1 f, Ord a) => Ord (Scope b f a) where compare = compare1
+
+#if MIN_VERSION_transformers(0,5,0) || !(MIN_VERSION_transformers(0,4,0))
+
+--------------------------------------------------------------------------------
+-- * transformers 0.5 Data.Functor.Classes
+--------------------------------------------------------------------------------
+
+instance (Read b, Read1 f, Read a) => Read (Scope b f a) where readsPrec = readsPrec1
+instance (Show b, Show1 f, Show a) => Show (Scope b f a) where showsPrec = showsPrec1
+
+instance (Monad f, Eq b, Eq1 f) => Eq1 (Scope b f) where
+ liftEq f m n = liftEq (liftEq f) (fromScope m) (fromScope n)
+
+instance (Monad f, Ord b, Ord1 f) => Ord1 (Scope b f) where
+ liftCompare f m n = liftCompare (liftCompare f) (fromScope m) (fromScope n)
+
+instance (Show b, Show1 f) => Show1 (Scope b f) where
+ liftShowsPrec f g d m = showsUnaryWith (liftShowsPrec (liftShowsPrec f' g') (liftShowList f' g')) "Scope" d (unscope m) where
+ f' = liftShowsPrec f g
+ g' = liftShowList f g
+
+instance (Read b, Read1 f) => Read1 (Scope b f) where
+ liftReadsPrec f g = readsData $ readsUnaryWith (liftReadsPrec (liftReadsPrec f' g') (liftReadList f' g')) "Scope" Scope where
+ f' = liftReadsPrec f g
+ g' = liftReadList f g
+
+#else
+
+--------------------------------------------------------------------------------
+-- * transformers 0.4 Data.Functor.Classes
+--------------------------------------------------------------------------------
+
+instance (Functor f, Read b, Read1 f, Read a) => Read (Scope b f a) where readsPrec = readsPrec1
+instance (Functor f, Show b, Show1 f, Show a) => Show (Scope b f a) where showsPrec = showsPrec1
+
+instance (Monad f, Eq b, Eq1 f) => Eq1 (Scope b f) where
+ eq1 a b = eq1 (fromScope a) (fromScope b)
+
+instance (Monad f, Ord b, Ord1 f) => Ord1 (Scope b f) where
compare1 a b = fromScope a `compare1` fromScope b
- {-# INLINE compare1 #-}
-instance (Functor f, Show b, Show1 f, Show a) => Show (Scope b f a) where
- showsPrec = showsPrec1
+newtype Lift1 f a = Lift1 { lower1 :: f a }
+instance (Show1 f, Show a) => Show (Lift1 f a) where showsPrec d (Lift1 m) = showsPrec1 d m
+instance (Read1 f, Read a) => Read (Lift1 f a) where
+ readsPrec d m = fmap (first Lift1) $ readsPrec1 d m
+
instance (Functor f, Show b, Show1 f) => Show1 (Scope b f) where
showsPrec1 d a = showParen (d > 10) $
showString "Scope " . showsPrec1 11 (fmap (fmap Lift1) (unscope a))
-instance (Functor f, Read b, Read1 f, Read a) => Read (Scope b f a) where
- readsPrec = readsPrec1
-instance (Functor f, Read b, Read1 f) => Read1 (Scope b f) where
+instance (Functor f, Read b, Read1 f) => Read1 (Scope b f) where
readsPrec1 d = readParen (d > 10) $ \r -> do
("Scope", r') <- lex r
(s, r'') <- readsPrec1 11 r'
return (Scope (fmap (fmap lower1) s), r'')
+#endif
instance Bound (Scope b) where
Scope m >>>= f = Scope (liftM (fmap (>>= f)) m)
{-# INLINE (>>>=) #-}
+-- {-# INLINE hashWithSalt1 #-}
+
instance (Hashable b, Monad f, Hashable1 f) => Hashable1 (Scope b f) where
- hashWithSalt1 n m = hashWithSalt1 n (fromScope m)
- {-# INLINE hashWithSalt1 #-}
+ liftHashWithSalt h s m = liftHashWithSalt (liftHashWithSalt h) s (fromScope m)
+ {-# INLINE liftHashWithSalt #-}
instance (Hashable b, Monad f, Hashable1 f, Hashable a) => Hashable (Scope b f a) where
hashWithSalt n m = hashWithSalt1 n (fromScope m)
{-# INLINE hashWithSalt #-}
+instance NFData (f (Var b (f a))) => NFData (Scope b f a) where
+ rnf scope = rnf (unscope scope)
+
-------------------------------------------------------------------------------
-- Abstraction
-------------------------------------------------------------------------------
@@ -362,7 +409,7 @@ mapMScope_ :: (Monad m, Foldable f) =>
mapMScope_ f g (Scope s) = mapM_ (bimapM_ f (mapM_ g)) s
{-# INLINE mapMScope_ #-}
--- | Traverse both bound and free variables
+-- | 'traverse' the bound variables in a 'Scope'.
traverseBound :: (Applicative g, Traversable f) =>
(b -> g c) -> Scope b f a -> g (Scope c f a)
traverseBound f (Scope s) = Scope <$> traverse f' s where
diff --git a/src/Bound/Scope/Simple.hs b/src/Bound/Scope/Simple.hs
index 5d485a6..c8c43d9 100644
--- a/src/Bound/Scope/Simple.hs
+++ b/src/Bound/Scope/Simple.hs
@@ -68,7 +68,7 @@ import Bound.Class
import Bound.Var
import Control.Applicative
import Control.Monad hiding (mapM, mapM_)
-import Control.Monad.Trans.Class
+import Control.Monad.Morph
import Data.Bifunctor
import Data.Bifoldable
import qualified Data.Binary as Binary
@@ -79,15 +79,18 @@ import Data.Bytes.Put
import Data.Bytes.Serial
import Data.Data
import Data.Foldable
-import Data.Hashable
-import Data.Hashable.Extras
+import Data.Functor.Classes
+import Data.Hashable (Hashable(..))
+import Data.Hashable.Lifted (Hashable1(..), hashWithSalt1)
import Data.Monoid
import qualified Data.Serialize as Serialize
import Data.Serialize (Serialize)
import Data.Traversable
-import Prelude.Extras
import Prelude hiding (foldr, mapM, mapM_)
+-- $setup
+-- >>> import Bound.Var
+
-------------------------------------------------------------------------------
-- Scopes
-------------------------------------------------------------------------------
@@ -128,7 +131,11 @@ instance Traversable f => Traversable (Scope b f) where
traverse f (Scope a) = Scope <$> traverse (traverse f) a
{-# INLINE traverse #-}
+#if __GLASGOW_HASKELL__ < 710
instance (Functor f, Monad f) => Applicative (Scope b f) where
+#else
+instance Monad f => Applicative (Scope b f) where
+#endif
pure a = Scope (return (F a))
{-# INLINE pure #-}
(<*>) = ap
@@ -150,33 +157,72 @@ instance MonadTrans (Scope b) where
lift ma = Scope (liftM F ma)
{-# INLINE lift #-}
-instance (Functor f, Eq b, Eq1 f, Eq a) => Eq (Scope b f a) where
- (==) = (==#)
- {-# INLINE (==) #-}
-instance (Functor f, Eq b, Eq1 f) => Eq1 (Scope b f) where
- a ==# b = unscope a ==# unscope b
- {-# INLINE (==#) #-}
+instance MFunctor (Scope b) where
+#if __GLASGOW_HASKELL__ < 710
+ hoist f = hoistScope f
+#else
+ hoist = hoistScope
+#endif
+ {-# INLINE hoist #-}
+
+#if (MIN_VERSION_transformers(0,5,0)) || !(MIN_VERSION_transformers(0,4,0))
+instance (Eq b, Eq1 f) => Eq1 (Scope b f) where
+ liftEq f m n = liftEq (liftEq f) (unscope m) (unscope n)
-instance (Functor f, Ord b, Ord1 f, Ord a) => Ord (Scope b f a) where
+instance (Ord b, Ord1 f) => Ord1 (Scope b f) where
+ liftCompare f m n = liftCompare (liftCompare f) (unscope m) (unscope n)
+
+instance (Show b, Show1 f) => Show1 (Scope b f) where
+ liftShowsPrec f g d m = showParen (d > 10) $
+ showString "Scope " . liftShowsPrec (liftShowsPrec f g) (liftShowList f g) 11 (unscope m)
+
+instance (Read b, Read1 f) => Read1 (Scope b f) where
+ liftReadsPrec f g d = readParen (d > 10) $ \r -> do
+ ("Scope", r') <- lex r
+ (s, r'') <- liftReadsPrec (liftReadsPrec f g) (liftReadList f g) 11 r'
+ return (Scope s, r'')
+
+instance (Eq b, Eq1 f, Eq a) => Eq (Scope b f a) where
+ (==) = eq1
+
+instance (Ord b, Ord1 f, Ord a) => Ord (Scope b f a) where
compare = compare1
- {-# INLINE compare #-}
-instance (Functor f, Ord b, Ord1 f) => Ord1 (Scope b f) where
- compare1 a b = unscope a `compare1` unscope b
- {-# INLINE compare1 #-}
-instance (Functor f, Show b, Show1 f, Show a) => Show (Scope b f a) where
+instance (Show b, Show1 f, Show a) => Show (Scope b f a) where
showsPrec = showsPrec1
+
+instance (Read b, Read1 f, Read a) => Read (Scope b f a) where
+ readsPrec = readsPrec1
+#else
+
+instance (Functor f, Eq b, Eq1 f) => Eq1 (Scope b f) where
+ eq1 m n = eq1 (unscope m) (unscope n)
+
+instance (Functor f, Ord b, Ord1 f) => Ord1 (Scope b f) where
+ compare1 m n = compare1 (unscope m) (unscope n)
+
instance (Functor f, Show b, Show1 f) => Show1 (Scope b f) where
showsPrec1 d a = showParen (d > 10) $
showString "Scope " . showsPrec1 11 (unscope a)
-instance (Functor f, Read b, Read1 f, Read a) => Read (Scope b f a) where
- readsPrec = readsPrec1
-instance (Functor f, Read b, Read1 f) => Read1 (Scope b f) where
+instance (Functor f, Read b, Read1 f) => Read1 (Scope b f) where
readsPrec1 d = readParen (d > 10) $ \r -> do
("Scope", r') <- lex r
(s, r'') <- readsPrec1 11 r'
- return (Scope (fmap lower1 s), r'')
+ return (Scope s, r'')
+
+instance (Functor f, Eq b, Eq1 f, Eq a) => Eq (Scope b f a) where
+ (==) = eq1
+
+instance (Functor f, Ord b, Ord1 f, Ord a) => Ord (Scope b f a) where
+ compare = compare1
+
+instance (Functor f, Show b, Show1 f, Show a) => Show (Scope b f a) where
+ showsPrec = showsPrec1
+
+instance (Functor f, Read b, Read1 f, Read a) => Read (Scope b f a) where
+ readsPrec = readsPrec1
+#endif
instance Bound (Scope b) where
Scope m >>>= f = Scope $ m >>= \v -> case v of
@@ -184,11 +230,11 @@ instance Bound (Scope b) where
F a -> liftM F (f a)
{-# INLINE (>>>=) #-}
-instance (Hashable b, Monad f, Hashable1 f) => Hashable1 (Scope b f) where
- hashWithSalt1 n m = hashWithSalt1 n (unscope m)
- {-# INLINE hashWithSalt1 #-}
+instance (Hashable b, Hashable1 f) => Hashable1 (Scope b f) where
+ liftHashWithSalt h n m = liftHashWithSalt (liftHashWithSalt h) n (unscope m)
+ {-# INLINE liftHashWithSalt #-}
-instance (Hashable b, Monad f, Hashable1 f, Hashable a) => Hashable (Scope b f a) where
+instance (Hashable b, Hashable1 f, Hashable a) => Hashable (Scope b f a) where
hashWithSalt n m = hashWithSalt1 n (unscope m)
{-# INLINE hashWithSalt #-}
diff --git a/src/Bound/TH.hs b/src/Bound/TH.hs
index 3892f35..4f66e91 100644
--- a/src/Bound/TH.hs
+++ b/src/Bound/TH.hs
@@ -15,7 +15,7 @@
-- 'Monad' instances for data types.
----------------------------------------------------------------------------
-module Bound.TH
+module Bound.TH
(
#ifdef MIN_VERSION_template_haskell
makeBound
@@ -23,146 +23,145 @@ module Bound.TH
) where
#ifdef MIN_VERSION_template_haskell
-import Data.List (intercalate)
+import Data.List (intercalate, foldr1)
import Data.Traversable (for)
-import Control.Monad (foldM)
+import Control.Monad (foldM, mzero, guard)
import Bound.Class (Bound((>>>=)))
import Language.Haskell.TH
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative (Applicative, pure, (<*>))
#endif
--- |
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.Maybe (MaybeT (..))
+
+-- |
-- Use to automatically derive 'Applicative' and 'Monad' instances for
-- your datatype.
---
--- In GHC 7.10 or later the @DeriveAnyClass@ extension may be used to derive the 'Show1' and 'Read1' instances
---
+--
+-- Also works for components that are lists or instances of 'Functor',
+-- but still does not work for a great deal of other things.
+--
+-- @deriving-compat@ package may be used to derive the 'Show1' and 'Read1' instances
+--
-- @
--- {-# LANGUAGE DeriveAnyClass #-}
--- {-# LANGUAGE DeriveFunctor #-}
--- {-# LANGUAGE TemplateHaskell #-}
---
--- import Bound (Scope, makeBound)
--- import Prelude.Extras (Read1, Show1)
+-- {-\# LANGUAGE DeriveFunctor #-}
+-- {-\# LANGUAGE TemplateHaskell #-}
+--
+-- import Bound (Scope, makeBound)
+-- import Data.Functor.Classes (Show1, Read1, shosPrec1, readsPrec1)
+-- import Data.Deriving (deriveShow1, deriveRead1)
+--
+-- data Exp a
+-- = V a
+-- | App (Exp a) (Exp a)
+-- | Lam (Scope () Exp a)
+-- | ND [Exp a]
+-- | I Int
+-- deriving (Functor)
--
--- data Exp a
--- = V a
--- | App (Exp a) (Exp a)
--- | Lam (Scope () Exp a)
--- | I Int
--- deriving (Functor, Read, Read1, Show, Show1)
---
-- makeBound ''Exp
+-- deriveShow1 ''Exp
+-- deriveRead1 ''Exp
+-- instance Read a => Read (Exp a) where readsPrec = readsPrec1
+-- instance Show a => Show (Exp a) where showsPrec = showsPrec1
-- @
---
+--
-- and in GHCi
---
--- @
--- ghci> :set -XDeriveAnyClass
--- ghci> :set -XDeriveFunctor
--- ghci> :set -XTemplateHaskell
--- ghci> import Bound (Scope, makeBound)
--- ghci> import Prelude.Extras (Read1, Show1)
--- ghci> data Exp a = V a | App (Exp a) (Exp a) | Lam (Scope () Exp a) | I Int deriving (Functor, Read, Read1, Show, Show1); makeBound ''Exp
--- @
--
--- or
---
--- @
--- ghci> :{
--- ghci| data Exp a = V a | App (Exp a) (Exp a) | Lam (Scope () Exp a) | I Int deriving (Functor, Read, Read1, Show, Show1)
--- ghci| makeBound ''Exp
--- ghci| :}
---
--- If @DeriveAnyClass@ is not used the instances must be declared explicitly:
---
--- @
--- data Exp a
--- = V a
--- | App (Exp a) (Exp a)
--- | Lam (Scope () Exp a)
--- | I Int
--- deriving (Functor, Read, Show)
--- instance Read1 Exp
--- instance Show1 Exp
---
--- makeBound ''Exp
--- @
---
--- or in GHCi:
---
-- @
+-- ghci> :set -XDeriveFunctor
+-- ghci> :set -XTemplateHaskell
+-- ghci> import Bound (Scope, makeBound)
+-- ghci> import Data.Functor.Classes (Show1, Read1, showsPrec1, readsPrec1)
+-- ghci> import Data.Deriving (deriveShow1, deriveRead1)
-- ghci> :{
--- ghci| data Exp a = V a | App (Exp a) (Exp a) | Lam (Scope () Exp a) | I Int deriving (Functor, Read, Show)
--- ghci| instance Read1 Exp
--- ghci| instance Show1 Exp
+-- ghci| data Exp a = V a | App (Exp a) (Exp a) | Lam (Scope () Exp a) | ND [Exp a] | I Int deriving (Functor)
-- ghci| makeBound ''Exp
+-- ghci| deriveShow1 ''Exp
+-- ghci| deriveRead1 ''Exp
+-- ghci| instance Read a => Read (Exp a) where readsPrec = readsPrec1
+-- ghci| instance Show a => Show (Exp a) where showsPrec = showsPrec1
-- ghci| :}
-- @
---
--- 'Eq' and 'Ord' instances need to be derived differently if the data
--- type's immediate components include 'Scope' (or other instances of
--- 'Bound')
---
--- In a file with @{-# LANGUAGE StandaloneDeriving #-}@ at the top:
---
+--
+-- 'Eq' and 'Ord' instances can be derived similarly
+--
-- @
--- instance Eq1 Exp
--- deriving instance Eq a => Eq (Exp a)
---
--- instance Ord1 Exp
--- deriving instance Ord a => Ord (Exp a)
+-- import Data.Functor.Classes (Eq1, Ord1, eq1, compare1)
+-- import Data.Deriving (deriveEq1, deriveOrd1)
+--
+-- deriveEq1 ''Exp
+-- deriveOrd1 ''Exp
+-- instance Eq a => Eq (Exp a) where (==) = eq1
+-- instance Ord a => Ord (Exp a) where compare = compare1
-- @
---
+--
-- or in GHCi:
--
-- @
--- ghci> :set -XStandaloneDeriving
--- ghci> deriving instance Eq a => Eq (Exp a); instance Eq1 Exp
--- ghci> deriving instance Ord a => Ord (Exp a); instance Ord1 Exp
+-- ghci> import Data.Functor.Classes (Eq1, Ord1, eq1, compare1)
+-- ghci> import Data.Deriving (deriveEq1, deriveOrd1)
+-- ghci> :{
+-- ghci| deriveEq1 ''Exp
+-- ghci| deriveOrd1 ''Exp
+-- ghci| instance Eq a => Eq (Exp a) where (==) = eq1
+-- ghci| instance Ord a => Ord (Exp a) where compare = compare1
+-- ghci| :}
-- @
---
--- because their 'Eq' and 'Ord' instances require @Exp@ to be a 'Monad':
---
+--
+-- We cannot automatically derive 'Eq' and 'Ord' using the standard GHC mechanism,
+-- because instances require @Exp@ to be a 'Monad':
+--
-- @
--- instance (Monad f, Eq b, Eq1 f, Eq a) => Eq (Scope b f a)
--- instance (Monad f, Ord b, Ord1 f, Ord a) => Ord (Scope b f a)
+-- instance (Monad f, Eq b, Eq1 f, Eq a) => Eq (Scope b f a)
+-- instance (Monad f, Ord b, Ord1 f, Ord a) => Ord (Scope b f a)
-- @
---
--- Does not work yet for components that are lists or instances of
--- 'Functor' or with a great deal other things.
makeBound :: Name -> DecsQ
makeBound name = do
- let var :: ExpQ
- var = ConE `fmap` getPure name
+ TyConI dec <- reify name
+ case dec of
+#if MIN_VERSION_template_haskell(2,11,0)
+ DataD _ _name vars _ cons _ -> makeBound' name vars cons
+#else
+ DataD _ _name vars cons _ -> makeBound' name vars cons
+#endif
+ _ -> fail $ show name ++ " Must be a data type."
+
+makeBound' :: Name -> [TyVarBndr] -> [Con] -> DecsQ
+makeBound' name vars cons = do
+ let instanceHead :: Type
+ instanceHead = name `conAppsT` map VarT (typeVars (init vars))
+
+ var :: ExpQ
+ var = ConE `fmap` getPure name vars cons
bind :: ExpQ
- bind = constructBind name
+ bind = constructBind name vars cons
#if __GLASGOW_HASKELL__ < 708
def :: Name -> DecQ -> [DecQ]
#if __GLASGOW_HASKELL__ < 706
def _theName dec = [dec]
-#else
+#else
def theName dec = [pragInlD theName Inline FunLike AllPhases, dec]
#endif
pureBody :: Name -> [DecQ]
- pureBody pure'or'return =
- def pure'or'return
+ pureBody pure'or'return =
+ def pure'or'return
(valD (varP pure'or'return) (normalB var) [])
bindBody :: [DecQ]
- bindBody =
+ bindBody =
def '(>>=)
(valD (varP '(>>=)) (normalB bind) [])
- apBody <- do
- ff <- newName "ff"
+ apBody <- do
+ ff <- newName "ff"
fy <- newName "fy"
- f <- newName "f"
+ f <- newName "f"
y <- newName "y"
-- \ff fy -> do
@@ -170,7 +169,7 @@ makeBound name = do
-- y <- fy
-- pure (f x)
let ap :: ExpQ
- ap = lamE [varP ff, varP fy] (doE
+ ap = lamE [varP ff, varP fy] (doE
[bindS (varP f) (varE ff),
bindS (varP y) (varE fy),
noBindS (varE 'pure `appE` (varE f `appE` varE y))])
@@ -183,20 +182,20 @@ makeBound name = do
-- f <- ff
-- y <- fy
-- pure (f y)
- applicative <-
- instanceD (cxt []) (appT (conT ''Applicative) (conT name))
+ applicative <-
+ instanceD (cxt []) (appT (conT ''Applicative) (pure instanceHead))
(pureBody 'pure ++ apBody)
-- instance Monad $name where
-- return = $var
-- (>>=) = $bind
- monad <-
- instanceD (cxt []) (appT (conT ''Monad) (conT name))
+ monad <-
+ instanceD (cxt []) (appT (conT ''Monad) (pure instanceHead))
(pureBody 'return ++ bindBody)
pure [applicative, monad]
#else
- [d| instance Applicative $(conT name) where
+ [d| instance Applicative $(pure instanceHead) where
pure = $var
{-# INLINE pure #-}
@@ -206,7 +205,7 @@ makeBound name = do
pure (f y)
{-# INLINE (<*>) #-}
- instance Monad $(conT name) where
+ instance Monad $(pure instanceHead) where
# if __GLASGOW_HASKELL__ < 710
return = $var
{-# INLINE return #-}
@@ -218,30 +217,29 @@ makeBound name = do
#endif
-- Internals
-data Prop
- = Bound
- | Konst
- | Exp
+data Prop
+ = Bound
+ | Konst
+ | Funktor Int -- ^ number tells how many layers are there
+ | Exp
deriving Show
-data Components
+data Components
= Component Name [(Name, Prop)]
| Variable Name
deriving Show
-constructBind :: Name -> ExpQ
-constructBind name = do
- TyConI dec <- reify name
-
- interpret =<< construct dec
+constructBind :: Name -> [TyVarBndr] -> [Con] -> ExpQ
+constructBind name vars cons = do
+ interpret =<< construct name vars cons
-construct :: Dec -> Q [Components]
-construct (DataD _ name tyvar constructors _) = do
- var <- getPure name
+construct :: Name -> [TyVarBndr] -> [Con] -> Q [Components]
+construct name vars constructors = do
+ var <- getPure name vars constructors
for constructors $ \con -> do
case con of
- NormalC conName [(_, _)]
- | conName == var
+ NormalC conName [(_, _)]
+ | conName == var
-> pure (Variable conName)
NormalC conName types
-> Component conName `fmap` mapM typeToBnd [ ty | (_, ty) <- types ]
@@ -252,25 +250,26 @@ construct (DataD _ name tyvar constructors _) = do
bndA <- typeToBnd a
bndB <- typeToBnd b
pure (Component conName [bndA, bndB])
- ForallC{} -> error "Not implemented."
+ _ -> error "Not implemented."
where
expa :: Type
- expa = ConT name `AppT` VarT (getName (last tyvar))
+ expa = name `conAppsT` map VarT (typeVars vars)
typeToBnd :: Type -> Q (Name, Prop)
typeToBnd ty = do
boundInstance <- isBound ty
+ functorApp <- isFunctorApp ty
var <- newName "var"
- pure $
- case () of ()
- | ty == expa -> (var, Exp)
- | boundInstance -> (var, Bound)
- | ConT{} <- ty -> (var, Konst)
- | otherwise -> error $ "This is bad: "
- ++ show ty
- ++ " "
- ++ show boundInstance
+ pure $ case () of
+ _ | ty == expa -> (var, Exp)
+ | boundInstance -> (var, Bound)
+ | isKonst ty -> (var, Konst)
+ | Just n <- functorApp -> (var, Funktor n)
+ | otherwise -> error $ "This is bad: "
+ ++ show ty
+ ++ " "
+ ++ show boundInstance
-- Checks whether a type is an instance of Bound by stripping its last
-- two type arguments:
@@ -278,10 +277,27 @@ construct (DataD _ name tyvar constructors _) = do
-- -> isInstance ''Bound [Scope ()]
-- -> True
isBound :: Type -> Q Bool
- isBound ty
- | Just a <- stripLast2 ty = isInstance ''Bound [a]
+ isBound ty
+ -- We might fail with kind error, but we don't care
+ | Just a <- stripLast2 ty = pure False `recover` isInstance ''Bound [a]
| otherwise = return False
-construct _ = error "Must be a data type."
+
+ isKonst :: Type -> Bool
+ isKonst ConT {} = True
+ isKonst (VarT n) = n /= getName (last vars)
+ isKonst (AppT a b) = isKonst a && isKonst b
+ isKonst _ = False
+
+ isFunctorApp :: Type -> Q (Maybe Int)
+ isFunctorApp = runMaybeT . go
+ where
+ go x | x == expa = pure 0
+ go (f `AppT` x) = do
+ isFunctor <- lift $ isInstance ''Functor [f]
+ guard isFunctor
+ n <- go x
+ pure $ n + 1
+ go _ = mzero
interpret :: [Components] -> ExpQ
interpret bnds = do
@@ -299,43 +315,46 @@ interpret bnds = do
bind (Component name bounds) = do
exprs <- foldM bindOne (ConE name) bounds
- pure $
+ pure $
Match
(ConP name [ VarP arg | (arg, _) <- bounds ])
- (NormalB
+ (NormalB
exprs)
[]
bindOne :: Exp -> (Name, Prop) -> Q Exp
bindOne expr (name, bnd) = case bnd of
- Bound ->
+ Bound ->
pure expr `appE` (varE '(>>>=) `appE` varE name `appE` varE f)
- Konst ->
+ Konst ->
pure expr `appE` varE name
- Exp ->
+ Exp ->
pure expr `appE` (varE '(>>=) `appE` varE name `appE` varE f)
+ Funktor n ->
+ pure expr `appE` (pure (fmapN n) `appE` (varE '(>>=) `sectionR` varE f) `appE` varE name)
+
+ fmapN :: Int -> Exp
+ fmapN n = foldr1 (\a b -> VarE '(.) `AppE` a `AppE` b) $ replicate n (VarE 'fmap)
matches <- for bnds bind
pure $ LamE [VarP x, VarP f] (CaseE (VarE x) matches)
stripLast2 :: Type -> Maybe Type
-stripLast2 (a `AppT` b `AppT` _ `AppT` d)
+stripLast2 (a `AppT` b `AppT` _ `AppT` d)
| AppT{} <- d = Nothing
| otherwise = Just (a `AppT` b)
-stripLast2 _ = Nothing
+stripLast2 _ = Nothing
getName :: TyVarBndr -> Name
getName (PlainTV name) = name
getName (KindedTV name _) = name
--- Returns candidate
-getPure :: Name -> Q Name
-getPure name = do
- TyConI (DataD _ _ tyvr cons _) <- reify name
-
- let
+-- Returns candidate
+getPure :: Name -> [TyVarBndr] -> [Con] -> Q Name
+getPure _name tyvr cons= do
+ let
findReturn :: Type -> [(Name, [Type])] -> Name
- findReturn ty constrs =
+ findReturn ty constrs =
case [ constr | (constr, [ty']) <- constrs, ty' == ty ] of
[] -> error "Too few candidates for a variable constructor."
[x] -> x
@@ -345,22 +364,41 @@ getPure name = do
xs -> error ("Too many candidates: " ++ intercalate ", " (map pprint xs))
-- Gets the last type variable, given 'data Exp a b c = ...'
- --
+ --
-- lastTyVar = c
lastTyVar :: Type
lastTyVar = VarT (last (map getName tyvr))
allTypeArgs :: Con -> (Name, [Type])
allTypeArgs con = case con of
- NormalC conName tys ->
+ NormalC conName tys ->
(conName, [ ty | (_, ty) <- tys ])
- RecC conName tys ->
+ RecC conName tys ->
(conName, [ ty | (_, _, ty) <- tys ])
- InfixC (_, t1) conName (_, t2) ->
+ InfixC (_, t1) conName (_, t2) ->
(conName, [ t1, t2 ])
ForallC _ _ conName ->
allTypeArgs conName
+#if MIN_VERSION_template_haskell(0,2,11)
+ _ -> error "Not implemented"
+#endif
- return (findReturn lastTyVar (allTypeArgs `fmap` cons))
+ return (findReturn lastTyVar (allTypeArgs `fmap` cons))
#else
#endif
+
+-------------------------------------------------------------------------------
+-- Type mangling
+-------------------------------------------------------------------------------
+
+-- | Extraty type variables
+typeVars :: [TyVarBndr] -> [Name]
+typeVars = map varBindName
+
+varBindName :: TyVarBndr -> Name
+varBindName (PlainTV n) = n
+varBindName (KindedTV n _) = n
+
+-- | Apply arguments to a type constructor.
+conAppsT :: Name -> [Type] -> Type
+conAppsT conName = foldl AppT (ConT conName)
diff --git a/src/Bound/Var.hs b/src/Bound/Var.hs
index 33d7e24..0c9a104 100644
--- a/src/Bound/Var.hs
+++ b/src/Bound/Var.hs
@@ -32,14 +32,15 @@ module Bound.Var
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
+import Control.DeepSeq
import Control.Monad (liftM, ap)
#if __GLASGOW_HASKELL__ < 710
import Data.Foldable
import Data.Traversable
-import Data.Monoid (mempty)
+import Data.Monoid (Monoid(..))
#endif
-import Data.Hashable
-import Data.Hashable.Extras
+import Data.Hashable (Hashable(..))
+import Data.Hashable.Lifted (Hashable1(..), Hashable2(..))
import Data.Bifunctor
import Data.Bifoldable
import qualified Data.Binary as Binary
@@ -48,6 +49,7 @@ import Data.Bitraversable
import Data.Bytes.Get
import Data.Bytes.Put
import Data.Bytes.Serial
+import Data.Functor.Classes
#ifdef __GLASGOW_HASKELL__
import Data.Data
# if __GLASGOW_HASKELL__ >= 704
@@ -60,7 +62,6 @@ import Data.Serialize (Serialize)
#if __GLASGOW_HASKELL__ < 710
import Data.Word
#endif
-import Prelude.Extras
----------------------------------------------------------------------------
-- Bound and Free Variables
@@ -92,8 +93,13 @@ data Var b a
distinguisher :: Int
distinguisher = fromIntegral $ (maxBound :: Word) `quot` 3
-instance Hashable2 Var
-instance Hashable b => Hashable1 (Var b)
+instance Hashable2 Var where
+ liftHashWithSalt2 h _ s (B b) = h s b
+ liftHashWithSalt2 _ h s (F a) = h s a `hashWithSalt` distinguisher
+ {-# INLINE liftHashWithSalt2 #-}
+instance Hashable b => Hashable1 (Var b) where
+ liftHashWithSalt = liftHashWithSalt2 hashWithSalt
+ {-# INLINE liftHashWithSalt #-}
instance (Hashable b, Hashable a) => Hashable (Var b a) where
hashWithSalt s (B b) = hashWithSalt s b
hashWithSalt s (F a) = hashWithSalt s a `hashWithSalt` distinguisher
@@ -202,20 +208,49 @@ instance Bitraversable Var where
bitraverse _ g (F a) = F <$> g a
{-# INLINE bitraverse #-}
-instance Eq2 Var where
- (==##) = (==)
- {-# INLINE (==##) #-}
-instance Ord2 Var where
- compare2 = compare
- {-# INLINE compare2 #-}
-instance Show2 Var where showsPrec2 = showsPrec
-instance Read2 Var where readsPrec2 = readsPrec
-
-instance Eq b => Eq1 (Var b) where
- (==#) = (==)
- {-# INLINE (==#) #-}
-instance Ord b => Ord1 (Var b) where
- compare1 = compare
- {-# INLINE compare1 #-}
+#if (MIN_VERSION_transformers(0,5,0)) || !(MIN_VERSION_transformers(0,4,0))
+instance Eq2 Var where
+ liftEq2 f _ (B a) (B c) = f a c
+ liftEq2 _ g (F b) (F d) = g b d
+ liftEq2 _ _ _ _ = False
+
+instance Ord2 Var where
+ liftCompare2 f _ (B a) (B c) = f a c
+ liftCompare2 _ _ B{} F{} = LT
+ liftCompare2 _ _ F{} B{} = GT
+ liftCompare2 _ g (F b) (F d) = g b d
+
+instance Show2 Var where
+ liftShowsPrec2 f _ _ _ d (B a) = showsUnaryWith f "B" d a
+ liftShowsPrec2 _ _ h _ d (F a) = showsUnaryWith h "F" d a
+
+instance Read2 Var where
+ liftReadsPrec2 f _ h _ = readsData $ readsUnaryWith f "B" B `mappend` readsUnaryWith h "F" F
+
+instance Eq b => Eq1 (Var b) where
+ liftEq = liftEq2 (==)
+
+instance Ord b => Ord1 (Var b) where
+ liftCompare = liftCompare2 compare
+
+instance Show b => Show1 (Var b) where
+ liftShowsPrec = liftShowsPrec2 showsPrec showList
+
+instance Read b => Read1 (Var b) where
+ liftReadsPrec = liftReadsPrec2 readsPrec readList
+
+#else
+--instance Eq2 Var where eq2 = (==)
+--instance Ord2 Var where compare2 = compare
+--instance Show2 Var where showsPrec2 = showsPrec
+--instance Read2 Var where readsPrec2 = readsPrec
+
+instance Eq b => Eq1 (Var b) where eq1 = (==)
+instance Ord b => Ord1 (Var b) where compare1 = compare
instance Show b => Show1 (Var b) where showsPrec1 = showsPrec
-instance Read b => Read1 (Var b) where readsPrec1 = readsPrec
+instance Read b => Read1 (Var b) where readsPrec1 = readsPrec
+#endif
+
+# if __GLASGOW_HASKELL__ >= 704
+instance (NFData a, NFData b) => NFData (Var b a)
+# endif
diff --git a/tests/doctests.hs b/tests/doctests.hs
index 6ceefc5..2d080e7 100644
--- a/tests/doctests.hs
+++ b/tests/doctests.hs
@@ -1,30 +1,25 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Main (doctests)
+-- Copyright : (C) 2012-14 Edward Kmett
+-- License : BSD-style (see the file LICENSE)
+-- Maintainer : Edward Kmett <ekmett@gmail.com>
+-- Stability : provisional
+-- Portability : portable
+--
+-- This module provides doctests for a project based on the actual versions
+-- of the packages it was built with. It requires a corresponding Setup.lhs
+-- to be added to the project
+-----------------------------------------------------------------------------
module Main where
-import Build_doctests (deps)
-import Control.Applicative
-import Control.Monad
-import Data.List
-import System.Directory
-import System.FilePath
+import Build_doctests (flags, pkgs, module_sources)
+import Data.Foldable (traverse_)
import Test.DocTest
main :: IO ()
-main = getSources >>= \sources -> doctest $
- "-isrc"
- : "-idist/build/autogen"
- : "-optP-include"
- : "-optPdist/build/autogen/cabal_macros.h"
- : "-hide-all-packages"
- : map ("-package="++) deps ++ sources
-
-getSources :: IO [FilePath]
-getSources = filter (isSuffixOf ".hs") <$> go "src"
+main = do
+ traverse_ putStrLn args
+ doctest args
where
- go dir = do
- (dirs, files) <- getFilesAndDirectories dir
- (files ++) . concat <$> mapM go dirs
-
-getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])
-getFilesAndDirectories dir = do
- c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir
- (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c
+ args = flags ++ pkgs ++ module_sources