#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702
#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
) where
import Bound.Class
import Bound.Var
import Control.Applicative
import Control.Monad hiding (mapM, mapM_)
import Control.Monad.Trans.Class
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.Foldable
import Data.Hashable
import Data.Hashable.Extras
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_)
newtype Scope b f a = Scope { unscope :: f (Var b a) }
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
instance Monad f => Monad (Scope b f) where
return a = Scope (return (F a))
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 (Functor f, Eq b, Eq1 f, Eq a) => Eq (Scope b f a) where
(==) = (==#)
instance (Functor f, Eq b, Eq1 f) => Eq1 (Scope b f) where
a ==# b = unscope a ==# unscope b
instance (Functor f, Ord b, Ord1 f, Ord a) => Ord (Scope b f a) where
compare = compare1
instance (Functor f, Ord b, Ord1 f) => Ord1 (Scope b f) where
compare1 a b = unscope a `compare1` unscope b
instance (Functor f, Show b, Show1 f, Show a) => Show (Scope b f a) where
showsPrec = showsPrec1
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
readsPrec1 d = readParen (d > 10) $ \r -> do
("Scope", r') <- lex r
(s, r'') <- readsPrec1 11 r'
return (Scope (fmap lower1 s), r'')
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, Monad f, Hashable1 f) => Hashable1 (Scope b f) where
hashWithSalt1 n m = hashWithSalt1 n (unscope m)
instance (Hashable b, Monad f, 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)
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
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