summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEdwardKmett <>2014-03-06 21:11:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-03-06 21:11:00 (GMT)
commitb1822be28202820cb6794d198f1c0f2bf1fd0261 (patch)
tree5bff893415afc615d1a5892e66345c26c3f224a7
parent288c132f56e559da601d3943a73790e5b0eb264a (diff)
version 1.01.0
-rw-r--r--.gitignore13
-rw-r--r--CHANGELOG.markdown7
-rw-r--r--bound.cabal2
-rw-r--r--src/Bound.hs2
-rw-r--r--src/Bound/Class.hs48
-rw-r--r--src/Bound/Scope.hs69
-rw-r--r--src/Bound/Scope/Simple.hs49
7 files changed, 172 insertions, 18 deletions
diff --git a/.gitignore b/.gitignore
deleted file mode 100644
index bbcd5d4..0000000
--- a/.gitignore
+++ /dev/null
@@ -1,13 +0,0 @@
-dist
-docs
-wiki
-TAGS
-tags
-wip
-.DS_Store
-.*.swp
-.*.swo
-*.o
-*.hi
-*~
-*#
diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown
index a55c78a..150788f 100644
--- a/CHANGELOG.markdown
+++ b/CHANGELOG.markdown
@@ -1,3 +1,10 @@
+1.0
+---
+* Added instances for `Bound` for all of the `mtl` monads.
+* Added `Data` and `Typeable` support to both versions of `Scope`
+* Added the missing `Applictive` instance to `Bound.Scope.Simple`
+* Moved `hoistScope`, `bitraverseScope`, `transverseScope`, and `instantiateVars` here from the `ermine` compiler.
+
0.9.1.1
-------
* Updated to work with `bifunctors` 4.0
diff --git a/bound.cabal b/bound.cabal
index 160ac22..91a13bb 100644
--- a/bound.cabal
+++ b/bound.cabal
@@ -1,6 +1,6 @@
name: bound
category: Language, Compilers/Interpreters
-version: 0.9.1.1
+version: 1.0
license: BSD3
cabal-version: >= 1.9.2
license-file: LICENSE
diff --git a/src/Bound.hs b/src/Bound.hs
index ca30bcd..a141976 100644
--- a/src/Bound.hs
+++ b/src/Bound.hs
@@ -67,7 +67,7 @@
-- and the related combinators from "Bound.Name". They are not re-exported
-- from this module by default.
--
--- The approach used in this package was first elaborated upon by Richard Bird
+-- The approach used in this package was first elaborated upon by Richard Bird
-- and Ross Patterson
-- in \"de Bruijn notation as a nested data type\", available from
-- <http://www.cs.uwyo.edu/~jlc/courses/5000_fall_08/debruijn_as_nested_datatype.pdf>
diff --git a/src/Bound/Class.hs b/src/Bound/Class.hs
index 3c130cf..3363a82 100644
--- a/src/Bound/Class.hs
+++ b/src/Bound/Class.hs
@@ -22,11 +22,21 @@ module Bound.Class
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704
import Control.Monad.Trans.Class
#endif
+import Data.Monoid
+import Control.Monad.Trans.Cont
+import Control.Monad.Trans.Error
+import Control.Monad.Trans.Identity
+import Control.Monad.Trans.List
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.RWS
+import Control.Monad.Trans.Reader
+import Control.Monad.Trans.State
+import Control.Monad.Trans.Writer
infixl 1 >>>=
-- | Instances of 'Bound' generate left modules over monads.
---
+--
-- This means they should satisfy the following laws:
--
-- > m >>>= return ≡ m
@@ -56,6 +66,42 @@ class Bound t where
{-# INLINE (>>>=) #-}
#endif
+instance Bound (ContT c) where
+ m >>>= f = m >>= lift . f
+ {-# INLINE (>>>=) #-}
+
+instance Error e => Bound (ErrorT e) where
+ m >>>= f = m >>= lift . f
+ {-# INLINE (>>>=) #-}
+
+instance Bound IdentityT where
+ m >>>= f = m >>= lift . f
+ {-# INLINE (>>>=) #-}
+
+instance Bound ListT where
+ m >>>= f = m >>= lift . f
+ {-# INLINE (>>>=) #-}
+
+instance Bound MaybeT where
+ m >>>= f = m >>= lift . f
+ {-# INLINE (>>>=) #-}
+
+instance Monoid w => Bound (RWST r w s) where
+ m >>>= f = m >>= lift . f
+ {-# INLINE (>>>=) #-}
+
+instance Bound (ReaderT r) where
+ m >>>= f = m >>= lift . f
+ {-# INLINE (>>>=) #-}
+
+instance Bound (StateT s) where
+ m >>>= f = m >>= lift . f
+ {-# INLINE (>>>=) #-}
+
+instance Monoid w => Bound (WriterT w) where
+ m >>>= f = m >>= lift . f
+ {-# INLINE (>>>=) #-}
+
infixr 1 =<<<
-- | A flipped version of ('>>>=').
--
diff --git a/src/Bound/Scope.hs b/src/Bound/Scope.hs
index d3c5412..7216a58 100644
--- a/src/Bound/Scope.hs
+++ b/src/Bound/Scope.hs
@@ -1,7 +1,22 @@
{-# LANGUAGE CPP #-}
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702
+{-# LANGUAGE Rank2Types #-}
+#ifdef __GLASGOW_HASKELL__
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy #-}
#endif
+
+#endif
+
+#ifndef MIN_VERSION_base
+#define MIN_VERSION_base(x,y,z) 1
+#endif
+
-----------------------------------------------------------------------------
-- |
-- Copyright : (C) 2012-2013 Edward Kmett
@@ -44,6 +59,10 @@ module Bound.Scope
, mapMScope
, serializeScope
, deserializeScope
+ , hoistScope
+ , bitraverseScope
+ , transverseScope
+ , instantiateVars
) where
import Bound.Class
@@ -68,6 +87,7 @@ import Data.Serialize (Serialize)
import Data.Traversable
import Prelude.Extras
import Prelude hiding (foldr, mapM, mapM_)
+import Data.Data
-------------------------------------------------------------------------------
-- Scopes
@@ -93,6 +113,10 @@ import Prelude hiding (foldr, mapM, mapM_)
-- @f (Var b a)@, but the extra @f a@ inside permits us a cheaper 'lift'.
--
newtype Scope b f a = Scope { unscope :: f (Var b (f a)) }
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707
+ deriving Typeable
+#endif
+
-------------------------------------------------------------------------------
-- Instances
@@ -373,6 +397,28 @@ deserializeScope :: (Serial1 f, MonadGet m) => m b -> m v -> m (Scope b f v)
deserializeScope gb gv = liftM Scope $ deserializeWith (deserializeWith2 gb $ deserializeWith gv)
{-# INLINE deserializeScope #-}
+-- | This allows you to 'bitraverse' a 'Scope'.
+bitraverseScope :: (Bitraversable t, Applicative f) => (k -> f k') -> (a -> f a') -> Scope b (t k) a -> f (Scope b (t k') a')
+bitraverseScope f g = fmap Scope . bitraverse f (traverse (bitraverse f g)) . unscope
+{-# INLINE bitraverseScope #-}
+
+-- | This is a higher-order analogue of 'traverse'.
+transverseScope :: (Applicative f, Monad f, Traversable g)
+ => (forall r. g r -> f (h r))
+ -> Scope b g a -> f (Scope b h a)
+transverseScope tau (Scope e) = Scope <$> (tau =<< traverse (traverse tau) e)
+
+-- | instantiate bound variables using a list of new variables
+instantiateVars :: Monad t => [a] -> Scope Int t a -> t a
+instantiateVars as = instantiate (vs !!) where
+ vs = map return as
+{-# INLINE instantiateVars #-}
+
+-- | Lift a natural transformation from @f@ to @g@ into one between scopes.
+hoistScope :: Functor f => (forall x. f x -> g x) -> Scope b f a -> Scope b g a
+hoistScope t (Scope b) = Scope $ t (fmap t <$> b)
+{-# INLINE hoistScope #-}
+
instance (Serial b, Serial1 f) => Serial1 (Scope b f) where
serializeWith = serializeScope serialize
deserializeWith = deserializeScope deserialize
@@ -388,3 +434,24 @@ instance (Binary b, Serial1 f, Binary a) => Binary (Scope b f a) where
instance (Serialize b, Serial1 f, Serialize a) => Serialize (Scope b f a) where
put = serializeScope Serialize.put Serialize.put
get = deserializeScope Serialize.get Serialize.get
+
+#ifdef __GLASGOW_HASKELL__
+
+#if __GLASGOW_HASKELL__ < 707
+instance (Typeable b, Typeable1 f) => Typeable1 (Scope b f) where
+ typeOf1 _ = mkTyConApp scopeTyCon [typeOf (undefined :: b), typeOf1 (undefined :: f ())]
+
+scopeTyCon :: TyCon
+#if MIN_VERSION_base(4,4,0)
+scopeTyCon = mkTyCon3 "bound" "Bound.Scope" "Scope"
+#else
+scopeTyCon = mkTyCon "Bound.Scope.Scope"
+#endif
+
+#else
+#define Typeable1 Typeable
+#endif
+
+deriving instance (Typeable b, Typeable1 f, Data a, Data (f (Var b (f a)))) => Data (Scope b f a)
+
+#endif
diff --git a/src/Bound/Scope/Simple.hs b/src/Bound/Scope/Simple.hs
index 6e70f92..400eecd 100644
--- a/src/Bound/Scope/Simple.hs
+++ b/src/Bound/Scope/Simple.hs
@@ -1,7 +1,20 @@
{-# LANGUAGE CPP #-}
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702
+#if defined(__GLASGOW_HASKELL__)
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy #-}
#endif
+
+#endif
+
+#ifndef MIN_VERSION_base
+#define MIN_VERSION_base(x,y,z) 1
+#endif
-----------------------------------------------------------------------------
-- |
-- Copyright : (C) 2013 Edward Kmett
@@ -58,6 +71,7 @@ import Data.Bitraversable
import Data.Bytes.Get
import Data.Bytes.Put
import Data.Bytes.Serial
+import Data.Data
import Data.Foldable
import Data.Hashable
import Data.Hashable.Extras
@@ -87,6 +101,9 @@ import Prelude hiding (foldr, mapM, mapM_)
-- Another use case is for syntaxes not stable under substitution,
-- therefore with only a 'Functor' instance and no 'Monad' instance.
newtype Scope b f a = Scope { unscope :: f (Var b a) }
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 707
+ deriving Typeable
+#endif
-------------------------------------------------------------------------------
-- Instances
@@ -105,6 +122,12 @@ instance Traversable f => Traversable (Scope b f) where
traverse f (Scope a) = Scope <$> traverse (traverse f) a
{-# INLINE traverse #-}
+instance (Functor f, Monad f) => Applicative (Scope b f) where
+ pure = return
+ {-# INLINE pure #-}
+ (<*>) = ap
+ {-# INLINE (<*>) #-}
+
-- | The monad permits substitution on free variables, while preserving
-- bound variables
instance Monad f => Monad (Scope b f) where
@@ -366,3 +389,27 @@ instance (Binary b, Serial1 f, Binary a) => Binary (Scope b f a) where
instance (Serialize b, Serial1 f, Serialize a) => Serialize (Scope b f a) where
put = serializeScope Serialize.put Serialize.put
get = deserializeScope Serialize.get Serialize.get
+
+#ifdef __GLASGOW_HASKELL__
+
+#if __GLASGOW_HASKELL__ < 707
+instance (Typeable b, Typeable1 f) => Typeable1 (Scope b f) where
+ typeOf1 _ = mkTyConApp scopeTyCon [typeOf (undefined :: b), typeOf1 (undefined :: f ())]
+
+scopeTyCon :: TyCon
+#if MIN_VERSION_base(4,4,0)
+scopeTyCon = mkTyCon3 "bound" "Bound.Scope" "Scope"
+#else
+scopeTyCon = mkTyCon "Bound.Scope.Scope"
+#endif
+
+#else
+
+-- only needed for ghc7.8.1rc1 compatibility
+#define Typeable1 Typeable
+
+#endif
+
+deriving instance (Typeable b, Typeable1 f, Data a, Data (f (Var b a))) => Data (Scope b f a)
+
+#endif