summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEdwardKmett <>2015-12-18 21:18:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2015-12-18 21:18:00 (GMT)
commit8e90c90dccd85e40a4c018e6e8eb80b566af506b (patch)
tree5147f8dc9bf0c82c8fd5460d127b6fe86256fa6f
parent5681d96c0cd99798036a50001d41b8cdf94a2306 (diff)
version 1.0.71.0.7
-rwxr-xr-x[-rw-r--r--].ghci0
-rw-r--r--.travis.yml56
-rw-r--r--CHANGELOG.markdown5
-rw-r--r--README.markdown2
-rw-r--r--bound.cabal37
-rw-r--r--examples/Overkill.hs118
-rw-r--r--src/Bound.hs9
-rw-r--r--src/Bound/Scope.hs7
-rw-r--r--src/Bound/Scope/Simple.hs4
-rw-r--r--src/Bound/TH.hs366
-rw-r--r--src/Bound/Var.hs2
11 files changed, 537 insertions, 69 deletions
diff --git a/.ghci b/.ghci
index 231eb17..231eb17 100644..100755
--- a/.ghci
+++ b/.ghci
diff --git a/.travis.yml b/.travis.yml
index b1becb5..07eb958 100644
--- a/.travis.yml
+++ b/.travis.yml
@@ -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
+
+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]}}
- # Try installing some of the build-deps with apt-get for speed.
- - travis/cabal-apt-install $mode
+ 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 @@ notifications:
- "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"
diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown
index 7f77085..10555ac 100644
--- a/CHANGELOG.markdown
+++ b/CHANGELOG.markdown
@@ -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
diff --git a/README.markdown b/README.markdown
index dbd32a1..6037fa5 100644
--- a/README.markdown
+++ b/README.markdown
@@ -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
-----
diff --git a/bound.cabal b/bound.cabal
index ec18f2f..19f425e 100644
--- a/bound.cabal
+++ b/bound.cabal
@@ -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 @@ extra-source-files:
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,26 +70,31 @@ library
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
main-is: Simple.hs
diff --git a/examples/Overkill.hs b/examples/Overkill.hs
index 5441480..832beac 100644
--- a/examples/Overkill.hs
+++ b/examples/Overkill.hs
@@ -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.Foldable
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 Exp a
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 @@ data Pats :: [Index] -> (* -> *) -> * -> * where
(:>) :: 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 Eq a => Eq (Exp a) where (==) = (==#)
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 @@ conp g ps = case go ps of
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,6 +148,22 @@ 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
+
+-- 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 Functor f => Functor (Pat b f) where
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 NilP NilP = True
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 @@ instance Foldable f => Foldable (Pats bs f) where
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,18 +245,31 @@ instance Bound (Pats bs) where
(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
@@ -240,6 +278,8 @@ instance Show (MPath is) where
-- 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 (R m) (R n) = eqPath m n
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 p) (C q) = compareMPath p q
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"
diff --git a/src/Bound.hs b/src/Bound.hs
index a141976..1623220 100644
--- a/src/Bound.hs
+++ b/src/Bound.hs
@@ -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 @@ module Bound
, 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
diff --git a/src/Bound/Scope.hs b/src/Bound/Scope.hs
index b60bc80..8d749e4 100644
--- a/src/Bound/Scope.hs
+++ b/src/Bound/Scope.hs
@@ -137,7 +137,7 @@ instance Traversable f => Traversable (Scope b f) where
{-# 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 @@ instance (Functor f, Monad f) => Applicative (Scope b f) where
-- | 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 :: Monad m => (b -> d) -> (a -> c) -> Scope b m a -> Scope d m c
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
diff --git a/src/Bound/Scope/Simple.hs b/src/Bound/Scope/Simple.hs
index 94b0400..5d485a6 100644
--- a/src/Bound/Scope/Simple.hs
+++ b/src/Bound/Scope/Simple.hs
@@ -129,7 +129,7 @@ instance Traversable f => Traversable (Scope b f) where
{-# 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 @@ instance (Functor f, Monad f) => Applicative (Scope b f) where
-- | 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)
diff --git a/src/Bound/TH.hs b/src/Bound/TH.hs
new file mode 100644
index 0000000..3892f35
--- /dev/null
+++ b/src/Bound/TH.hs
@@ -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
diff --git a/src/Bound/Var.hs b/src/Bound/Var.hs
index 5f97055..33d7e24 100644
--- a/src/Bound/Var.hs
+++ b/src/Bound/Var.hs
@@ -181,7 +181,7 @@ instance Applicative (Var b) where
{-# INLINE (<*>) #-}
instance Monad (Var b) where
- return = F
+ return = pure
{-# INLINE return #-}
F a >>= f = f a
B b >>= _ = B b