bound 1.0.6 → 1.0.7

raw patch · 10 files changed

+537/−69 lines, 10 filesdep +template-haskelldep ~cerealPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: template-haskell

Dependency ranges changed: cereal

API changes (from Hackage documentation)

Files

• .travis.yml +38/−18
• CHANGELOG.markdown +5/−0
• README.markdown +1/−1
• bound.cabal +25/−12
• examples/Overkill.hs +86/−32
• src/Bound.hs +8/−1
• src/Bound/Scope.hs +4/−3
• src/Bound/Scope/Simple.hs +3/−1
• src/Bound/TH.hs +366/−0
• src/Bound/Var.hs +1/−1

@@ -1,22 +1,45 @@-language: haskell-before_install:-  # Uncomment whenever hackage is down.-  # - mkdir -p ~/.cabal && cp travis/config ~/.cabal/config && cabal update-  - cabal update+language: c+sudo: false -  # Try installing some of the build-deps with apt-get for speed.-  - travis/cabal-apt-install $mode+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++before_install:+ - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH+ - export CABAL=cabal-$CABALVER+ - $CABAL --version+ install:-  - cabal install packunused packdeps-  - cabal configure $mode-  - cabal build --ghc-options=-ddump-minimal-imports+ - travis_retry $CABAL update+ - $CABAL install "Cabal == $CABALVER.*"+ - $CABAL install --enable-tests --only-dependencies  script:-  - $script-  - packdeps bound.cabal-  - packunused-  - hlint src --cpp-define HLINT+ - $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  notifications:   irc:@@ -24,7 +47,4 @@       - "irc.freenode.org#haskell-lens"     skip_join: true     template:-      - "\x0313bound\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}"--env:-  - mode="--enable-tests" script="cabal test --show-details=always"+      - "\x0313bound\x0f/\x0306%{branch}\x0f \x0314%{commit}\x0f %{message} \x0302\x1f%{build_url}\x0f"

@@ -1,3 +1,8 @@+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.+* Support `cereal` 0.5+ 1.0.6 ----- * Compiles warning-free on GHC 7.10

@@ -1,7 +1,7 @@ Bound ===== -[![Build Status](https://secure.travis-ci.org/ekmett/bound.png?branch=master)](http://travis-ci.org/ekmett/bound)+[![Hackage](https://img.shields.io/hackage/v/bound.svg)](https://hackage.haskell.org/package/bound) [![Build Status](https://secure.travis-ci.org/ekmett/bound.png?branch=master)](http://travis-ci.org/ekmett/bound)  Goals -----

@@ -1,6 +1,6 @@ name:          bound category:      Language, Compilers/Interpreters-version:       1.0.6+version:       1.0.7 license:       BSD3 cabal-version: >= 1.9.2 license-file:  LICENSE@@ -48,6 +48,14 @@   CHANGELOG.markdown   AUTHORS.markdown +flag template-haskell+  description:+    You can disable the use of the `template-haskell` package using `-f-template-haskell`.+    .+    Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users.+  default: True+  manual: True+ source-repository head   type: git   location: git://github.com/ekmett/bound.git@@ -62,25 +70,30 @@     Bound.Scope     Bound.Scope.Simple     Bound.Term+    Bound.TH     Bound.Var    build-depends:-    base            >= 4       && < 5,-    bifunctors      >= 3       && < 6,-    binary          >= 0.5     && < 0.8,-    bytes           >= 0.4     && < 1,-    cereal          >= 0.3.5.2 && < 0.5,-    comonad         >= 3       && < 5,-    hashable        >= 1.1     && < 1.3,-    hashable-extras >= 0.1     && < 1,-    prelude-extras  >= 0.3     && < 1,-    profunctors     >= 3.3     && < 6,-    transformers    >= 0.2     && < 0.5+    base             >= 4       && < 5,+    bifunctors       >= 3       && < 6,+    binary           >= 0.5     && < 0.8,+    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,+    profunctors      >= 3.3     && < 6,+    template-haskell >= 2.7     && < 3,+    transformers     >= 0.2     && < 0.5    ghc-options: -Wall -O2 -fspec-constr -fdicts-cheap -funbox-strict-fields    if impl(ghc >=7.4 && < 7.6)     build-depends: ghc-prim++  if flag(template-haskell) && impl(ghc)+    build-depends: template-haskell >= 2.7 && < 3.0  test-suite Simple   type: exitcode-stdio-1.0

@@ -1,14 +1,11 @@-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE PolyKinds #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE TypeOperators #-}++{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}+ module Overkill where  import Data.Vector as Vector hiding ((++), map)@@ -17,12 +14,10 @@ import Data.Traversable import Data.Monoid (Monoid(..)) import Control.Monad-import Control.Monad.Trans.Class import Control.Applicative import Prelude hiding (foldr) import Prelude.Extras-import GHC.Prim (Constraint(..))-import Unsafe.Coerce+import Data.Type.Equality import Bound  infixl 9 :@@@ -41,10 +36,10 @@ data Index = VarI | WildI | AsI Index | ConI [Index]  data Pat :: Index -> (* -> *) -> * -> * where-  VarP  ::                             Pat VarI f a-  WildP ::                             Pat WildI f a-  AsP   :: Pat i f a                -> Pat (AsI i) f a-  ConP  :: String    -> Pats bs f a -> Pat (ConI bs) f a+  VarP  ::                             Pat 'VarI f a+  WildP ::                             Pat 'WildI f a+  AsP   :: Pat i f a                -> Pat ('AsI i) f a+  ConP  :: String    -> Pats bs f a -> Pat ('ConI bs) f a   ViewP :: f a       -> Pat b f a   -> Pat b f a -- TODO: allow references to earlier variables  data Pats :: [Index] -> (* -> *) -> * -> * where@@ -52,10 +47,10 @@   (:>) :: Pat b f a -> Pats bs f a -> Pats (b ': bs) f a  data Path :: Index -> * where-  V :: Path VarI-  L :: Path (AsI a)-  R :: Path a -> Path (AsI a)-  C :: MPath as -> Path (ConI as)+  V :: Path 'VarI+  L :: Path ('AsI a)+  R :: Path a -> Path ('AsI a)+  C :: MPath as -> Path ('ConI as)  data MPath :: [Index] -> * where   H :: Path a   -> MPath (a ':as)@@ -88,7 +83,11 @@ instance Eq1 Exp where   Var a     ==# Var b     = a == b   (a :@ b)  ==# (c :@ d)  = a ==# c && b ==# d-  Lam ps a  ==# Lam qs b  = eqPat ps qs && a ==# unsafeCoerce b -- eqPat proves equal shape+  Lam ps a  ==# Lam qs b  =+    case eqPat' ps qs of+      Nothing -> False+      Just Refl -> a ==# b+   Let as a  ==# Let bs b  = as == bs && a ==# b   _         ==# _         = False @@ -126,8 +125,8 @@     go :: [P a] -> Ps a     go [] = Ps NilP [] (const Nothing)     go (P p as f : xs) = case go xs of-      Ps ps ass g -> Ps (p :> ps) (as ++ ass) $ \v ->-        T <$> g v <|> H <$> f v+      Ps ps' ass g' -> Ps (p :> ps') (as ++ ass) $ \v ->+        T <$> g' v <|> H <$> f v  -- * smart lam lam :: P a -> Exp a -> Exp a@@ -149,7 +148,23 @@ 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 +-- 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+  Just Refl+eqPat' (ConP g ps) (ConP h qs) = do+  guard (g == h)+  Refl <- eqPats' ps qs+  Just Refl+eqPat' (ViewP e p) (ViewP f q) = guard (e ==# f) >> eqPat' 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 @@ -170,7 +185,7 @@  instance Foldable f => Foldable (Pat b f) where   foldMap f (AsP p)     = foldMap f p-  foldMap f (ConP g ps) = foldMap f ps+  foldMap f (ConP _g ps) = foldMap f ps   foldMap f (ViewP e p) = foldMap f e `mappend` foldMap f p   foldMap _ _           = mempty @@ -194,6 +209,16 @@ eqPats (p :> ps) (q :> qs) = eqPat p q && eqPats 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+  Just Refl+eqPats' _ _ = Nothing+ instance Eq1 f         => Eq1 (Pats bs f)   where (==#) = eqPats instance (Eq1 f, Eq a) => Eq  (Pats bs f a) where (==)  = eqPats @@ -212,7 +237,7 @@   foldMap _ _    = mempty  instance Traversable f => Traversable (Pats bs f) where-  traverse f NilP = pure NilP+  traverse _f NilP = pure NilP   traverse f (p :> ps) = (:>) <$> traverse f p <*> traverse f ps  instance Bound (Pats bs) where@@ -220,19 +245,32 @@   (p :> ps) >>>= f = (p >>>= f) :> (ps >>>= f)  -- ** Path into Pats+-- Internally, this is only used to implement eqPath, which is only+-- used to implement this. eqMPath :: MPath is -> MPath js -> Bool eqMPath (H m) (H n) = eqPath m n eqMPath (T p) (T q) = eqMPath p q eqMPath _     _     = False-instance Eq (MPath is) where (==) = eqMPath +instance Eq (MPath is) where+    H m == H n = m == n+    T p == T q = p == q+    _   == _   = False++-- Internally, this is only used to define comparePath, which+-- is only used here to define this. compareMPath :: MPath is -> MPath js -> Ordering compareMPath (H m) (H n) = comparePath m n compareMPath (H _) (T _) = LT compareMPath (T p) (T q) = compareMPath p q compareMPath (T _) (H _) = GT-instance Ord (MPath is) where compare = compareMPath +instance Ord (MPath is) where+    compare (H m) (H n) = compare m n+    compare (H _) (T _) = LT+    compare (T p) (T q) = compare p q+    compare (T _) (H _) = GT+ instance Show (MPath is) where   showsPrec d (H m) = showParen (d > 10) $ showString "H " . showsPrec 11 m   showsPrec d (T p) = showParen (d > 10) $ showString "T " . showsPrec 11 p@@ -240,6 +278,8 @@ -- instance Read (MPath is)  -- ** Path into Pat+-- Internally, this is only used to implement eqMPath, which is only used+-- to implement this. eqPath :: Path i -> Path j -> Bool eqPath V     V     = True eqPath L     L     = True@@ -247,8 +287,13 @@ eqPath (C p) (C q) = eqMPath p q eqPath _     _     = False -instance Eq (Path i) where (==) = eqPath+instance Eq (Path i) where+    p == q = case compare p q of+               EQ -> True+               _ -> False +-- Internally, this is only used to define compareMPath, which+-- is only used here to define this. comparePath :: Path i -> Path j -> Ordering comparePath V     V     = EQ comparePath V     _     = LT@@ -263,12 +308,21 @@ comparePath (C _) _     = GT  instance Ord (Path i) where-  compare V     V     = EQ-  compare L     L     = EQ-  compare L     _     = LT-  compare (R _) L     = GT-  compare (R m) (R n) = compare m n-  compare (C p) (C q) = compare p q+    compare V y = case (y :: Path 'VarI) of V -> EQ+    compare L y = cpL y+        where+          cpL :: Path ('AsI a) -> Ordering+          cpL L = EQ+          cpL (R _) = LT+    compare (R r) y = cpR r y+        where+          cpR :: Path a -> Path ('AsI a) -> Ordering+          cpR _ L = GT+          cpR m (R n) = compare m n+    compare (C c) y = cpC c y+        where+          cpC :: MPath as -> Path ('ConI as) -> Ordering+          cpC p (C q) = compare p q  instance Show (Path i) where   showsPrec _ V     = showString "V"

@@ -1,3 +1,5 @@+{-# LANGUAGE CPP             #-}+ ----------------------------------------------------------------------------- -- | -- Copyright   :  (C) 2012 Edward Kmett@@ -89,7 +91,7 @@ -- (1) /Simple.hs/ provides an untyped lambda calculus with recursive let --   bindings and includes an evaluator for the untyped lambda calculus and a --   longer example taken from Lennart Augustsson's "λ-calculus cooked four---   ways" available from <http://www.augustsson.net/Darcs/Lambda/top.pdf>+--   ways" available from <http://foswiki.cs.uu.nl/foswiki/pub/USCS/InterestingPapers/AugustsonLambdaCalculus.pdf> -- -- 2. /Derived.hs/ shows how much of the API can be automated with --    DeriveTraversable and adds combinators for building binders that support@@ -119,9 +121,14 @@   , Var(..)   , fromScope   , toScope+  -- * Deriving instances +  , makeBound   ) where  import Bound.Var import Bound.Class import Bound.Scope import Bound.Term+#ifdef MIN_VERSION_template_haskell+import Bound.TH+#endif

@@ -137,7 +137,7 @@   {-# INLINE traverse #-}  instance (Functor f, Monad f) => Applicative (Scope b f) where-  pure = return+  pure a = Scope (return (F (return a)))   {-# INLINE pure #-}   (<*>) = ap   {-# INLINE (<*>) #-}@@ -145,8 +145,10 @@ -- | The monad permits substitution on free variables, while preserving -- bound variables instance Monad f => Monad (Scope b f) where+#if __GLASGOW_HASKELL__ < 710   return a = Scope (return (F (return a)))   {-# INLINE return #-}+#endif   Scope e >>= f = Scope $ e >>= \v -> case v of     B b -> return (B b)     F ea -> ea >>= unscope . f@@ -318,8 +320,7 @@ liftMScope f g (Scope s) = Scope $ liftM (bimap f (liftM g)) s {-# INLINE liftMScope #-} --- | Obtain a result by collecting information from both bound and free--- variables+-- | Obtain a result by collecting information from bound variables foldMapBound :: (Foldable f, Monoid r) => (b -> r) -> Scope b f a -> r foldMapBound f (Scope s) = foldMap f' s where   f' (B a) = f a

@@ -129,7 +129,7 @@   {-# INLINE traverse #-}  instance (Functor f, Monad f) => Applicative (Scope b f) where-  pure = return+  pure a = Scope (return (F a))   {-# INLINE pure #-}   (<*>) = ap   {-# INLINE (<*>) #-}@@ -137,8 +137,10 @@ -- | The monad permits substitution on free variables, while preserving -- bound variables instance Monad f => Monad (Scope b f) where+#if __GLASGOW_HASKELL__ < 710   return a = Scope (return (F a))   {-# INLINE return #-}+#endif   Scope e >>= f = Scope $ e >>= \v -> case v of     B b -> return (B b)     F a -> unscope (f a)

@@ -0,0 +1,366 @@+{-# LANGUAGE CPP             #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE PatternGuards   #-}++-----------------------------------------------------------------------------+-- |+-- Copyright   :  (C) 2012-2013 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  experimental+-- Portability :  portable+--+-- This is a Template Haskell module for deriving 'Applicative' and+-- 'Monad' instances for data types.+----------------------------------------------------------------------------++module Bound.TH +  (+#ifdef MIN_VERSION_template_haskell+    makeBound+#endif+  ) where++#ifdef MIN_VERSION_template_haskell+import Data.List        (intercalate)+import Data.Traversable (for)+import Control.Monad    (foldM)+import Bound.Class      (Bound((>>>=)))+import Language.Haskell.TH+#if __GLASGOW_HASKELL__ < 710+import Control.Applicative (Applicative, pure, (<*>))+#endif++-- | +-- 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+-- +-- @+-- {-# LANGUAGE DeriveAnyClass  #-}+-- {-# LANGUAGE DeriveFunctor   #-}+-- {-# LANGUAGE TemplateHaskell #-}+-- +-- import Bound          (Scope, makeBound)+-- import Prelude.Extras (Read1, Show1)+--+-- data Exp a +--   = V a +--   | App (Exp a) (Exp a) +--   | Lam (Scope () Exp a) +--   | I Int +--   deriving (Functor, Read, Read1, Show, Show1)+-- +-- makeBound ''Exp+-- @+-- +-- 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> :{+-- 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| makeBound ''Exp+-- 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:+-- +-- @+-- instance Eq1 Exp+-- deriving instance Eq a => Eq (Exp a)+-- +-- instance Ord1 Exp+-- deriving instance Ord a => Ord (Exp a)+-- @+-- +-- 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+-- @+-- +-- because their 'Eq' and 'Ord' 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)+-- @+-- +-- 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++      bind :: ExpQ+      bind = constructBind name++#if __GLASGOW_HASKELL__ < 708+      def :: Name -> DecQ -> [DecQ]+#if __GLASGOW_HASKELL__ < 706+      def _theName dec = [dec]+#else +      def theName  dec = [pragInlD theName Inline FunLike AllPhases, dec]+#endif++      pureBody :: Name -> [DecQ]+      pureBody pure'or'return = +        def pure'or'return +          (valD (varP pure'or'return) (normalB var) [])++      bindBody :: [DecQ]+      bindBody = +        def '(>>=)+          (valD (varP '(>>=)) (normalB bind) [])++  apBody <- do +    ff <- newName "ff"  +    fy <- newName "fy"+    f  <- newName "f"  +    y  <- newName "y"++    -- \ff fy -> do+    --   f <- ff+    --   y <- fy+    --   pure (f x)+    let ap :: ExpQ+        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))])++    pure (def '(<*>) (valD (varP '(<*>)) (normalB ap) []))++  -- instance Applicative $name where+  --   pure   = $var+  --   (<*>)  = \ff fy -> do+  --     f <- ff+  --     y <- fy+  --     pure (f y)+  applicative <- +    instanceD (cxt []) (appT (conT ''Applicative) (conT name))+      (pureBody 'pure ++ apBody)++  -- instance Monad $name where+  --   return = $var+  --   (>>=)  = $bind+  monad <- +    instanceD (cxt []) (appT (conT ''Monad) (conT name))+      (pureBody 'return ++ bindBody)++  pure [applicative, monad]+#else+  [d| instance Applicative $(conT name) where+        pure = $var+        {-# INLINE pure #-}++        ff <*> fy = do+          f <- ff+          y <- fy+          pure (f y)+        {-# INLINE (<*>) #-}++      instance Monad $(conT name) where+# if __GLASGOW_HASKELL__ < 710+        return = $var+        {-# INLINE return #-}+# endif++        (>>=)  = $bind+        {-# INLINE (>>=) #-}+    |]+#endif++-- Internals+data Prop +  = Bound +  | Konst +  | Exp +  deriving Show++data Components +  = Component Name [(Name, Prop)]+  | Variable Name+  deriving Show++constructBind :: Name -> ExpQ+constructBind name = do+  TyConI dec <- reify name++  interpret =<< construct dec++construct :: Dec -> Q [Components]+construct (DataD _ name tyvar constructors _) = do+  var <- getPure name+  for constructors $ \con -> do+    case con of+      NormalC conName [(_, _)] +        | conName == var +        -> pure (Variable conName)+      NormalC conName types+        -> Component conName `fmap` mapM typeToBnd [ ty | (_, ty) <- types ]+      RecC conName types+        -> Component conName `fmap` mapM typeToBnd [ ty | (_, _, ty) <- types ]+      InfixC (_, a) conName (_, b)+        -> do+        bndA <- typeToBnd a+        bndB <- typeToBnd b+        pure (Component conName [bndA, bndB])+      ForallC{} -> error "Not implemented."++  where+  expa :: Type+  expa = ConT name `AppT` VarT (getName (last tyvar))++  typeToBnd :: Type -> Q (Name, Prop)+  typeToBnd ty = do+    boundInstance <- isBound 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++  -- Checks whether a type is an instance of Bound by stripping its last+  -- two type arguments:+  --     isBound (Scope () EXP a)+  --  -> isInstance ''Bound [Scope ()]+  --  -> True+  isBound :: Type -> Q Bool+  isBound ty +    | Just a <- stripLast2 ty = isInstance ''Bound [a]+    | otherwise               = return False+construct _ = error "Must be a data type."++interpret :: [Components] -> ExpQ+interpret bnds = do+  x       <- newName "x"+  f       <- newName "f"++  let+    bind :: Components -> MatchQ+    bind (Variable name) = do+      a <- newName "a"+      match+        (conP name [varP a])+        (normalB (varE f `appE` varE a))+        []++    bind (Component name bounds) = do+     exprs <- foldM bindOne (ConE name) bounds+     pure $ +       Match+       (ConP name [ VarP arg | (arg, _) <- bounds ])+       (NormalB +         exprs)+        []++    bindOne :: Exp -> (Name, Prop) -> Q Exp+    bindOne expr (name, bnd) = case bnd of+      Bound -> +        pure expr `appE` (varE '(>>>=) `appE` varE name `appE` varE f)+      Konst -> +        pure expr `appE` varE name+      Exp   -> +        pure expr `appE` (varE '(>>=) `appE` varE name `appE` varE f)++  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) +  | AppT{} <- d = Nothing+  | otherwise   = Just (a `AppT` b)+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 +    findReturn :: Type -> [(Name, [Type])] -> Name+    findReturn ty constrs = +      case [ constr | (constr, [ty']) <- constrs, ty' == ty ] of+        []  -> error "Too few candidates for a variable constructor."+        [x] -> x+        --   data Exp a = Var1 a | Var2 a | ...+        -- result in+        --   Too many candidates: Var1, Var2+        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 -> +        (conName, [ ty |    (_, ty) <- tys ])+      RecC conName tys -> +        (conName, [ ty | (_, _, ty) <- tys ])+      InfixC (_, t1) conName (_, t2) -> +        (conName, [ t1, t2 ])+      ForallC _ _ conName ->+         allTypeArgs conName++  return (findReturn lastTyVar (allTypeArgs `fmap` cons)) +#else+#endif

@@ -181,7 +181,7 @@   {-# INLINE (<*>) #-}  instance Monad (Var b) where-  return = F+  return = pure   {-# INLINE return #-}   F a >>= f = f a   B b >>= _ = B b