bound 1.0.7 → 2

raw patch · 18 files changed

+1072/−434 lines, 18 filesdep +deepseqdep +deriving-compatdep +functor-classes-compatdep −directorydep −filepathdep −hashable-extrasdep ~basedep ~binarydep ~comonadsetup-changednew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: deepseq, deriving-compat, functor-classes-compat, mmorph, transformers-compat, void

Dependencies removed: directory, filepath, hashable-extras, prelude-extras

Dependency ranges changed: base, binary, comonad, doctest, hashable, template-haskell, transformers, vector

API changes (from Hackage documentation)

Files

• .gitignore +1/−0
• .travis.yml +80/−31
• CHANGELOG.markdown +11/−0
• README.markdown +15/−6
• Setup.lhs +24/−34
• bound.cabal +70/−15
• examples/Deriving.hs +31/−7
• examples/Imperative.hs +293/−0
• examples/Overkill.hs +61/−58
• examples/Simple.hs +15/−9
• src/Bound.hs +19/−12
• src/Bound/Class.hs +3/−0
• src/Bound/Name.hs +48/−22
• src/Bound/Scope.hs +71/−24
• src/Bound/Scope/Simple.hs +70/−24
• src/Bound/TH.hs +185/−147
• src/Bound/Var.hs +56/−21
• tests/doctests.hs +19/−24

@@ -1,4 +1,5 @@ dist+dist-newstyle docs wiki TAGS

@@ -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:

@@ -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.

@@ -16,21 +16,21 @@ {-# 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 @@   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).

@@ -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-  }+main = defaultMainWithDoctests "doctests" -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)+#else -testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]-testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys+#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}

@@ -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 @@    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 @@    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 @@   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 @@   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 @@   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,13 +114,54 @@   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   main-is: doctests.hs@@ -113,7 +169,6 @@   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

@@ -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.Traversable import Control.Monad import Control.Applicative-import Prelude.Extras+import Data.Functor.Classes import Bound  infixl 9 :@@@ -17,7 +17,7 @@   | 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 @@   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 @@   | 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 @@   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)

@@ -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 ()

@@ -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 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 @@   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,40 +143,41 @@  -- ** 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 (==#) = eqPat-instance (Eq1 f, Eq a) => Eq (Pat b f a) where (==) = eqPat+instance Eq1 f   => Eq1 (Pat b f)        where liftEq = eqPat+instance (Eq1 f, Eq a) => Eq (Pat b f a) where (==) = eq1 -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, Show a) => Show (Pat b f a) where showsPrec = showsPrec1 +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   fmap _ WildP = WildP@@ -204,29 +206,29 @@   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 @@ -- -- >>> lam (conp "Hello" [varp "x", wildp]) (Var "y") -- Lam (ConP "Hello" (VarP :> WildP :> NilP)) (Scope (Var (F (Var "y"))))+#endif main :: IO () main = return ()

@@ -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.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 @@   | 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,12 +59,16 @@   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 nf e@V{}   = e@@ -156,11 +161,12 @@ 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

@@ -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. --

@@ -56,6 +56,9 @@ -- 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   --

@@ -47,6 +47,7 @@ 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 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 @@   {-# 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,25 +164,46 @@   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   {-# INLINE serializeWith2 #-}@@ -208,6 +230,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

@@ -69,8 +69,9 @@ 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.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 @@   deriving Typeable #endif - ------------------------------------------------------------------------------- -- Instances -------------------------------------------------------------------------------@@ -158,46 +161,90 @@   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 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, 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 (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_ 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

@@ -68,7 +68,7 @@ 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.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 @@   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,45 +157,84 @@   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 #-} -instance (Functor f, Ord b, Ord1 f, Ord a) => Ord  (Scope b f a) where+#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 (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     B b -> return (B b)     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 #-} 

@@ -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 @@   ) 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    #-} ----- data Exp a ---   = V a ---   | App (Exp a) (Exp a) ---   | Lam (Scope () Exp a) ---   | I Int ---   deriving (Functor, Read, Read1, Show, Show1)--- +-- 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)+-- -- 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 @@     --   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 @@   --     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 @@           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 @@ #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 @@         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,11 +277,28 @@   --  -> 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   x       <- newName "x"@@ -299,43 +315,46 @@      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 @@         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)

@@ -32,14 +32,15 @@ #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.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 @@ #if __GLASGOW_HASKELL__ < 710 import Data.Word #endif-import Prelude.Extras  ---------------------------------------------------------------------------- -- Bound and Free Variables@@ -92,8 +93,13 @@ 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 @@   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+#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 Eq b   => Eq1   (Var b) where-  (==#)      = (==)-  {-# INLINE (==#) #-}-instance Ord b  => Ord1  (Var b) where-  compare1   = compare-  {-# INLINE compare1 #-}+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

@@ -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