#ifdef __GLASGOW_HASKELL__
#if __GLASGOW_HASKELL__ >= 702
#endif
#endif
#ifndef MIN_VERSION_base
#define MIN_VERSION_base(x,y,z) 1
#endif
module Bound.Scope
( 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.DeepSeq
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.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_)
import Data.Data
newtype Scope b f a = Scope { unscope :: f (Var b (f 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 (fmap f)) a)
instance Foldable f => Foldable (Scope b f) where
foldMap f (Scope a) = foldMap (foldMap (foldMap f)) a
instance Traversable f => Traversable (Scope b f) where
traverse f (Scope a) = Scope <$> traverse (traverse (traverse f)) a
instance (Functor f, Monad f) => Applicative (Scope b f) where
pure a = Scope (return (F (return a)))
(<*>) = ap
instance Monad f => Monad (Scope b f) where
#if __GLASGOW_HASKELL__ < 710
return a = Scope (return (F (return a)))
#endif
Scope e >>= f = Scope $ e >>= \v -> case v of
B b -> return (B b)
F ea -> ea >>= unscope . f
instance MonadTrans (Scope b) where
lift m = Scope (return (F m))
instance MFunctor (Scope b) where
#if __GLASGOW_HASKELL__ < 710
hoist t (Scope b) = Scope $ t (liftM (liftM t) b)
#else
hoist = hoistScope
#endif
instance (Monad f, Eq b, Eq1 f, Eq a) => Eq (Scope b f a) where (==) = eq1
instance (Monad f, Ord b, Ord1 f, Ord a) => Ord (Scope b f a) where compare = compare1
#if MIN_VERSION_transformers(0,5,0) || !(MIN_VERSION_transformers(0,4,0))
instance (Read b, Read1 f, Read a) => Read (Scope b f a) where readsPrec = readsPrec1
instance (Show b, Show1 f, Show a) => Show (Scope b f a) where showsPrec = showsPrec1
instance (Monad f, Eq b, Eq1 f) => Eq1 (Scope b f) where
liftEq f m n = liftEq (liftEq f) (fromScope m) (fromScope n)
instance (Monad f, Ord b, Ord1 f) => Ord1 (Scope b f) where
liftCompare f m n = liftCompare (liftCompare f) (fromScope m) (fromScope n)
instance (Show b, Show1 f) => Show1 (Scope b f) where
liftShowsPrec f g d m = showsUnaryWith (liftShowsPrec (liftShowsPrec f' g') (liftShowList f' g')) "Scope" d (unscope m) where
f' = liftShowsPrec f g
g' = liftShowList f g
instance (Read b, Read1 f) => Read1 (Scope b f) where
liftReadsPrec f g = readsData $ readsUnaryWith (liftReadsPrec (liftReadsPrec f' g') (liftReadList f' g')) "Scope" Scope where
f' = liftReadsPrec f g
g' = liftReadList f g
#else
instance (Functor f, Read b, Read1 f, Read a) => Read (Scope b f a) where readsPrec = readsPrec1
instance (Functor f, Show b, Show1 f, Show a) => Show (Scope b f a) where showsPrec = showsPrec1
instance (Monad f, Eq b, Eq1 f) => Eq1 (Scope b f) where
eq1 a b = eq1 (fromScope a) (fromScope b)
instance (Monad f, Ord b, Ord1 f) => Ord1 (Scope b f) where
compare1 a b = fromScope a `compare1` fromScope b
newtype Lift1 f a = Lift1 { lower1 :: f a }
instance (Show1 f, Show a) => Show (Lift1 f a) where showsPrec d (Lift1 m) = showsPrec1 d m
instance (Read1 f, Read a) => Read (Lift1 f a) where
readsPrec d m = fmap (first Lift1) $ readsPrec1 d m
instance (Functor f, Show b, Show1 f) => Show1 (Scope b f) where
showsPrec1 d a = showParen (d > 10) $
showString "Scope " . showsPrec1 11 (fmap (fmap Lift1) (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 (fmap (fmap lower1) s), r'')
#endif
instance Bound (Scope b) where
Scope m >>>= f = Scope (liftM (fmap (>>= f)) m)
instance (Hashable b, Monad f, Hashable1 f) => Hashable1 (Scope b f) where
liftHashWithSalt h s m = liftHashWithSalt (liftHashWithSalt h) s (fromScope m)
instance (Hashable b, Monad f, Hashable1 f, Hashable a) => Hashable (Scope b f a) where
hashWithSalt n m = hashWithSalt1 n (fromScope m)
instance NFData (f (Var b (f a))) => NFData (Scope b f a) where
rnf scope = rnf (unscope scope)
abstract :: Monad f => (a -> Maybe b) -> f a -> Scope b f a
abstract f e = Scope (liftM k e) where
k y = case f y of
Just z -> B z
Nothing -> F (return y)
abstract1 :: (Monad 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 -> a
instantiate1 :: Monad f => f a -> Scope n f a -> f a
instantiate1 e = instantiate (const e)
fromScope :: Monad f => Scope b f a -> f (Var b a)
fromScope (Scope s) = s >>= \v -> case v of
F e -> liftM F e
B b -> return (B b)
toScope :: Monad f => f (Var b a) -> Scope b f a
toScope e = Scope (liftM (fmap return) e)
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 ea -> ea >>= f
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 (fmap 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 (liftM 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 (foldMap 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 (traverse_ 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 (mapM_ 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 (traverse 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 (mapM g)) s)
serializeScope :: (Serial1 f, MonadPut m) => (b -> m ()) -> (v -> m ()) -> Scope b f v -> m ()
serializeScope pb pv (Scope body) = serializeWith (serializeWith2 pb $ serializeWith pv) body
deserializeScope :: (Serial1 f, MonadGet m) => m b -> m v -> m (Scope b f v)
deserializeScope gb gv = liftM Scope $ deserializeWith (deserializeWith2 gb $ deserializeWith gv)
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 :: (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)
bitransverseScope :: Applicative f => (forall a a'. (a -> f a') -> t a -> f (u a')) -> (c -> f c') -> Scope b t c -> f (Scope b u c')
bitransverseScope tau f = fmap Scope . tau (_F (tau f)) . unscope
instantiateVars :: Monad t => [a] -> Scope Int t a -> t a
instantiateVars as = instantiate (vs !!) where
vs = map return as
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)
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 (f a)))) => Data (Scope b f a)
#endif