#if defined(__GLASGOW_HASKELL__)
#if __GLASGOW_HASKELL__ >= 702
#endif
#endif
#ifndef MIN_VERSION_base
#define MIN_VERSION_base(x,y,z) 1
#endif
module Bound.Scope.Simple
(Scope(..)
, abstract, abstract1
, instantiate, instantiate1
, fromScope
, toScope
, splat
, bindings
, mapBound
, mapScope
, liftMBound
, liftMScope
, foldMapBound
, foldMapScope
, traverseBound_
, traverseScope_
, mapMBound_
, mapMScope_
, traverseBound
, traverseScope
, mapMBound
, mapMScope
, serializeScope
, deserializeScope
, hoistScope
, bitraverseScope
, bitransverseScope
, transverseScope
, instantiateVars
) where
import Bound.Class
import Bound.Var
import Control.Applicative
import Control.Monad hiding (mapM, mapM_)
import Control.Monad.Morph
import Data.Bifunctor
import Data.Bifoldable
import qualified Data.Binary as Binary
import Data.Binary (Binary)
import Data.Bitraversable
import Data.Bytes.Get
import Data.Bytes.Put
import Data.Bytes.Serial
import Data.Data
import Data.Foldable
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 hiding (foldr, mapM, mapM_)
newtype Scope b f a = Scope { unscope :: f (Var b a) }
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 707
deriving Typeable
#endif
instance Functor f => Functor (Scope b f) where
fmap f (Scope a) = Scope (fmap (fmap f) a)
instance Foldable f => Foldable (Scope b f) where
foldMap f (Scope a) = foldMap (foldMap f) a
instance Traversable f => Traversable (Scope b f) where
traverse f (Scope a) = Scope <$> traverse (traverse f) a
#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))
(<*>) = ap
instance Monad f => Monad (Scope b f) where
#if __GLASGOW_HASKELL__ < 710
return a = Scope (return (F a))
#endif
Scope e >>= f = Scope $ e >>= \v -> case v of
B b -> return (B b)
F a -> unscope (f a)
instance MonadTrans (Scope b) where
lift ma = Scope (liftM F ma)
instance MFunctor (Scope b) where
#if __GLASGOW_HASKELL__ < 710
hoist f = hoistScope f
#else
hoist = hoistScope
#endif
#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
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) => Read1 (Scope b f) where
readsPrec1 d = readParen (d > 10) $ \r -> do
("Scope", r') <- lex r
(s, r'') <- readsPrec1 11 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)
instance (Hashable b, Hashable1 f) => Hashable1 (Scope b f) where
liftHashWithSalt h n m = liftHashWithSalt (liftHashWithSalt h) n (unscope m)
instance (Hashable b, Hashable1 f, Hashable a) => Hashable (Scope b f a) where
hashWithSalt n m = hashWithSalt1 n (unscope m)
abstract :: Functor f => (a -> Maybe b) -> f a -> Scope b f a
abstract f e = Scope (fmap k e) where
k y = case f y of
Just z -> B z
Nothing -> F y
abstract1 :: (Functor f, Eq a) => a -> f a -> Scope () f a
abstract1 a = abstract (\b -> if a == b then Just () else Nothing)
instantiate :: Monad f => (b -> f a) -> Scope b f a -> f a
instantiate k e = unscope e >>= \v -> case v of
B b -> k b
F a -> return a
instantiate1 :: Monad f => f a -> Scope n f a -> f a
instantiate1 e = instantiate (const e)
hoistScope :: (f (Var b a) -> g (Var b a)) -> Scope b f a -> Scope b g a
hoistScope f = Scope . f . unscope
fromScope :: Scope b f a -> f (Var b a)
fromScope = unscope
toScope :: f (Var b a) -> Scope b f a
toScope = Scope
splat :: Monad f => (a -> f c) -> (b -> f c) -> Scope b f a -> f c
splat f unbind s = unscope s >>= \v -> case v of
B b -> unbind b
F a -> f a
bindings :: Foldable f => Scope b f a -> [b]
bindings (Scope s) = foldr f [] s where
f (B v) vs = v : vs
f _ vs = vs
mapBound :: Functor f => (b -> b') -> Scope b f a -> Scope b' f a
mapBound f (Scope s) = Scope (fmap f' s) where
f' (B b) = B (f b)
f' (F a) = F a
mapScope :: Functor f => (b -> d) -> (a -> c) -> Scope b f a -> Scope d f c
mapScope f g (Scope s) = Scope $ fmap (bimap f g) s
liftMBound :: Monad m => (b -> b') -> Scope b m a -> Scope b' m a
liftMBound f (Scope s) = Scope (liftM f' s) where
f' (B b) = B (f b)
f' (F a) = F a
liftMScope :: Monad m => (b -> d) -> (a -> c) -> Scope b m a -> Scope d m c
liftMScope f g (Scope s) = Scope $ liftM (bimap f g) s
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
f' _ = mempty
foldMapScope :: (Foldable f, Monoid r) =>
(b -> r) -> (a -> r) -> Scope b f a -> r
foldMapScope f g (Scope s) = foldMap (bifoldMap f g) s
traverseBound_ :: (Applicative g, Foldable f) =>
(b -> g d) -> Scope b f a -> g ()
traverseBound_ f (Scope s) = traverse_ f' s
where f' (B a) = () <$ f a
f' _ = pure ()
traverseScope_ :: (Applicative g, Foldable f) =>
(b -> g d) -> (a -> g c) -> Scope b f a -> g ()
traverseScope_ f g (Scope s) = traverse_ (bitraverse_ f g) s
mapMBound_ :: (Monad g, Foldable f) => (b -> g d) -> Scope b f a -> g ()
mapMBound_ f (Scope s) = mapM_ f' s where
f' (B a) = do _ <- f a; return ()
f' _ = return ()
mapMScope_ :: (Monad m, Foldable f) =>
(b -> m d) -> (a -> m c) -> Scope b f a -> m ()
mapMScope_ f g (Scope s) = mapM_ (bimapM_ f g) s
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
f' (B b) = B <$> f b
f' (F a) = pure (F a)
traverseScope :: (Applicative g, Traversable f) =>
(b -> g d) -> (a -> g c) -> Scope b f a -> g (Scope d f c)
traverseScope f g (Scope s) = Scope <$> traverse (bitraverse f g) s
bitraverseScope :: (Bitraversable t, Applicative f) => (k -> f k') -> (a -> f a') -> Scope b (t k) a -> f (Scope b (t k') a')
bitraverseScope f = bitransverseScope (bitraverse f)
transverseScope :: (Functor f)
=> (forall r. g r -> f (h r))
-> Scope b g a -> f (Scope b h a)
transverseScope tau (Scope s) = Scope <$> tau s
instantiateVars :: Monad t => [a] -> Scope Int t a -> t a
instantiateVars as = instantiate (vs !!) where
vs = map return as
bitransverseScope :: Applicative f => (forall a a'. (a -> f a') -> t a -> f (u a'))
-> forall a a'. (a -> f a') -> Scope b t a -> f (Scope b u a')
bitransverseScope tau f (Scope s) = Scope <$> tau (traverse f) s
mapMBound :: (Monad m, Traversable f) =>
(b -> m c) -> Scope b f a -> m (Scope c f a)
mapMBound f (Scope s) = liftM Scope (mapM f' s) where
f' (B b) = liftM B (f b)
f' (F a) = return (F a)
mapMScope :: (Monad m, Traversable f) =>
(b -> m d) -> (a -> m c) -> Scope b f a -> m (Scope d f c)
mapMScope f g (Scope s) = liftM Scope (mapM (bimapM f g) s)
serializeScope :: (Serial1 f, MonadPut m) => (b -> m ()) -> (v -> m ()) -> Scope b f v -> m ()
serializeScope pb pv (Scope body) = serializeWith (serializeWith2 pb pv) body
deserializeScope :: (Serial1 f, MonadGet m) => m b -> m v -> m (Scope b f v)
deserializeScope gb gv = liftM Scope $ deserializeWith (deserializeWith2 gb gv)
instance (Serial b, Serial1 f) => Serial1 (Scope b f) where
serializeWith = serializeScope serialize
deserializeWith = deserializeScope deserialize
instance (Serial b, Serial1 f, Serial a) => Serial (Scope b f a) where
serialize = serializeScope serialize serialize
deserialize = deserializeScope deserialize deserialize
instance (Binary b, Serial1 f, Binary a) => Binary (Scope b f a) where
put = serializeScope Binary.put Binary.put
get = deserializeScope Binary.get Binary.get
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 a))) => Data (Scope b f a)
#endif