{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types #-}
#if defined(__GLASGOW_HASKELL__)
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE Trustworthy #-}
#endif

-----------------------------------------------------------------------------

-- |

-- Copyright   :  (C) 2013 Edward Kmett

-- License     :  BSD-style (see the file LICENSE)

--

-- Maintainer  :  Edward Kmett <ekmett@gmail.com>

-- Stability   :  experimental

-- Portability :  portable

--

-- 'Scope' provides a single traditional de Bruijn level

-- and is often used inside of the definition of binders.

--

----------------------------------------------------------------------------

module Bound.Scope.Simple
  (Scope(..)
  -- * Abstraction

  , abstract, abstract1
  -- * Instantiation

  , instantiate, instantiate1
  -- * Alternative names for 'unscope'/'Scope'

  , fromScope
  , toScope
  -- * Bound variable manipulation

  , 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.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_)
#if defined(__GLASGOW_HASKELL__)
import GHC.Generics (Generic, Generic1)
#endif

-- $setup

-- >>> import Bound.Var


-------------------------------------------------------------------------------

-- Scopes

-------------------------------------------------------------------------------


-- | @'Scope' b f a@ is an @f@ expression with bound variables in @b@,

-- and free variables in @a@

--

-- This implements traditional de Bruijn indices, while 'Bound.Scope'

-- implements generalized de Bruijn indices.

--

-- These traditional indices can be used to test the performance gain

-- of generalized indices.

--

-- While this type 'Scope' is identical to 'Control.Monad.Trans.EitherT'

-- this module focuses on a drop-in replacement for 'Bound.Scope'.

--

-- 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 { forall b (f :: * -> *) a. Scope b f a -> f (Var b a)
unscope :: f (Var b a) }
#if defined(__GLASGOW_HASKELL__)
  deriving forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall b (f :: * -> *) a x. Rep (Scope b f a) x -> Scope b f a
forall b (f :: * -> *) a x. Scope b f a -> Rep (Scope b f a) x
$cto :: forall b (f :: * -> *) a x. Rep (Scope b f a) x -> Scope b f a
$cfrom :: forall b (f :: * -> *) a x. Scope b f a -> Rep (Scope b f a) x
Generic
#endif
deriving instance Functor f => Generic1 (Scope b f)

-------------------------------------------------------------------------------

-- Instances

-------------------------------------------------------------------------------


instance NFData (f (Var b a)) => NFData (Scope b f a) where
  rnf :: Scope b f a -> ()
rnf (Scope f (Var b a)
x) = forall a. NFData a => a -> ()
rnf f (Var b a)
x

instance Functor f => Functor (Scope b f) where
  fmap :: forall a b. (a -> b) -> Scope b f a -> Scope b f b
fmap a -> b
f (Scope f (Var b a)
a) = forall b (f :: * -> *) a. f (Var b a) -> Scope b f a
Scope (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) f (Var b a)
a)
  {-# INLINE fmap #-}

-- | @'toList'@ is provides a list (with duplicates) of the free variables

instance Foldable f => Foldable (Scope b f) where
  foldMap :: forall m a. Monoid m => (a -> m) -> Scope b f a -> m
foldMap a -> m
f (Scope f (Var b a)
a) = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f) f (Var b a)
a
  {-# INLINE foldMap #-}

instance Traversable f => Traversable (Scope b f) where
  traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Scope b f a -> f (Scope b f b)
traverse a -> f b
f (Scope f (Var b a)
a) = forall b (f :: * -> *) a. f (Var b a) -> Scope b f a
Scope forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f) f (Var b a)
a
  {-# INLINE traverse #-}

instance Monad f => Applicative (Scope b f) where
  pure :: forall a. a -> Scope b f a
pure a
a = forall b (f :: * -> *) a. f (Var b a) -> Scope b f a
Scope (forall (m :: * -> *) a. Monad m => a -> m a
return (forall b a. a -> Var b a
F a
a))
  {-# INLINE pure #-}
  <*> :: forall a b. Scope b f (a -> b) -> Scope b f a -> Scope b f b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
  {-# INLINE (<*>) #-}

-- | The monad permits substitution on free variables, while preserving

-- bound variables

instance Monad f => Monad (Scope b f) where
  Scope f (Var b a)
e >>= :: forall a b. Scope b f a -> (a -> Scope b f b) -> Scope b f b
>>= a -> Scope b f b
f = forall b (f :: * -> *) a. f (Var b a) -> Scope b f a
Scope forall a b. (a -> b) -> a -> b
$ f (Var b a)
e forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Var b a
v -> case Var b a
v of
    B b
b -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall b a. b -> Var b a
B b
b)
    F a
a -> forall b (f :: * -> *) a. Scope b f a -> f (Var b a)
unscope (a -> Scope b f b
f a
a)
  {-# INLINE (>>=) #-}

instance MonadTrans (Scope b) where
  lift :: forall (m :: * -> *) a. Monad m => m a -> Scope b m a
lift m a
ma = forall b (f :: * -> *) a. f (Var b a) -> Scope b f a
Scope (forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall b a. a -> Var b a
F m a
ma)
  {-# INLINE lift #-}

instance MFunctor (Scope b) where
  hoist :: forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
(forall a. m a -> n a) -> Scope b m b -> Scope b n b
hoist forall a. m a -> n a
f = forall (f :: * -> *) b a (g :: * -> *).
(f (Var b a) -> g (Var b a)) -> Scope b f a -> Scope b g a
hoistScope forall a. m a -> n a
f
  {-# INLINE hoist #-}

instance (Eq b, Eq1 f) => Eq1 (Scope b f)  where
  liftEq :: forall a b. (a -> b -> Bool) -> Scope b f a -> Scope b f b -> Bool
liftEq a -> b -> Bool
f Scope b f a
m Scope b f b
n = forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq (forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq a -> b -> Bool
f) (forall b (f :: * -> *) a. Scope b f a -> f (Var b a)
unscope Scope b f a
m) (forall b (f :: * -> *) a. Scope b f a -> f (Var b a)
unscope Scope b f b
n)

instance (Ord b, Ord1 f) => Ord1 (Scope b f) where
  liftCompare :: forall a b.
(a -> b -> Ordering) -> Scope b f a -> Scope b f b -> Ordering
liftCompare a -> b -> Ordering
f Scope b f a
m Scope b f b
n = forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare (forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare a -> b -> Ordering
f) (forall b (f :: * -> *) a. Scope b f a -> f (Var b a)
unscope Scope b f a
m) (forall b (f :: * -> *) a. Scope b f a -> f (Var b a)
unscope Scope b f b
n)

instance (Show b, Show1 f) => Show1 (Scope b f) where
  liftShowsPrec :: forall a.
(Int -> a -> ShowS)
-> ([a] -> ShowS) -> Int -> Scope b f a -> ShowS
liftShowsPrec Int -> a -> ShowS
f [a] -> ShowS
g Int
d Scope b f a
m = Bool -> ShowS -> ShowS
showParen (Int
d forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$
    String -> ShowS
showString String
"Scope " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec (forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> a -> ShowS
f [a] -> ShowS
g) (forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> [f a] -> ShowS
liftShowList Int -> a -> ShowS
f [a] -> ShowS
g) Int
11 (forall b (f :: * -> *) a. Scope b f a -> f (Var b a)
unscope Scope b f a
m)

instance (Read b, Read1 f) => Read1 (Scope b f) where
  liftReadsPrec :: forall a.
(Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (Scope b f a)
liftReadsPrec Int -> ReadS a
f ReadS [a]
g Int
d = forall a. Bool -> ReadS a -> ReadS a
readParen (Int
d forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$ \String
r -> do
    (String
"Scope", String
r') <- ReadS String
lex String
r
    (f (Var b a)
s, String
r'') <- forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
liftReadsPrec (forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
liftReadsPrec Int -> ReadS a
f ReadS [a]
g) (forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> ReadS [f a]
liftReadList Int -> ReadS a
f ReadS [a]
g) Int
11 String
r'
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall b (f :: * -> *) a. f (Var b a) -> Scope b f a
Scope f (Var b a)
s, String
r'')

instance (Eq b, Eq1 f, Eq a) => Eq (Scope b f a) where
  == :: Scope b f a -> Scope b f a -> Bool
(==) = forall (f :: * -> *) a. (Eq1 f, Eq a) => f a -> f a -> Bool
eq1

instance (Ord b, Ord1 f, Ord a) => Ord (Scope b f a) where
  compare :: Scope b f a -> Scope b f a -> Ordering
compare = forall (f :: * -> *) a. (Ord1 f, Ord a) => f a -> f a -> Ordering
compare1

instance (Show b, Show1 f, Show a) => Show (Scope b f a) where
  showsPrec :: Int -> Scope b f a -> ShowS
showsPrec = forall (f :: * -> *) a. (Show1 f, Show a) => Int -> f a -> ShowS
showsPrec1

instance (Read b, Read1 f, Read a) => Read (Scope b f a) where
  readsPrec :: Int -> ReadS (Scope b f a)
readsPrec = forall (f :: * -> *) a. (Read1 f, Read a) => Int -> ReadS (f a)
readsPrec1

instance Bound (Scope b) where
  Scope f (Var b a)
m >>>= :: forall (f :: * -> *) a c.
Monad f =>
Scope b f a -> (a -> f c) -> Scope b f c
>>>= a -> f c
f = forall b (f :: * -> *) a. f (Var b a) -> Scope b f a
Scope forall a b. (a -> b) -> a -> b
$ f (Var b a)
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Var b a
v -> case Var b a
v of
    B b
b -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall b a. b -> Var b a
B b
b)
    F a
a -> forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall b a. a -> Var b a
F (a -> f c
f a
a)
  {-# INLINE (>>>=) #-}

instance (Hashable b, Hashable1 f) => Hashable1 (Scope b f) where
  liftHashWithSalt :: forall a. (Int -> a -> Int) -> Int -> Scope b f a -> Int
liftHashWithSalt Int -> a -> Int
h Int
n Scope b f a
m = forall (t :: * -> *) a.
Hashable1 t =>
(Int -> a -> Int) -> Int -> t a -> Int
liftHashWithSalt (forall (t :: * -> *) a.
Hashable1 t =>
(Int -> a -> Int) -> Int -> t a -> Int
liftHashWithSalt Int -> a -> Int
h) Int
n (forall b (f :: * -> *) a. Scope b f a -> f (Var b a)
unscope Scope b f a
m)
  {-# INLINE liftHashWithSalt #-}

instance (Hashable b, Hashable1 f, Hashable a) => Hashable (Scope b f a) where
  hashWithSalt :: Int -> Scope b f a -> Int
hashWithSalt Int
n Scope b f a
m = forall (f :: * -> *) a.
(Hashable1 f, Hashable a) =>
Int -> f a -> Int
hashWithSalt1 Int
n (forall b (f :: * -> *) a. Scope b f a -> f (Var b a)
unscope Scope b f a
m)
  {-# INLINE hashWithSalt #-}

-------------------------------------------------------------------------------

-- Abstraction

-------------------------------------------------------------------------------


-- | Capture some free variables in an expression to yield

-- a 'Scope' with bound variables in @b@

--

-- >>> :m + Data.List

-- >>> abstract (`elemIndex` "bar") "barry"

-- Scope [B 0,B 1,B 2,B 2,F 'y']

abstract :: Functor f => (a -> Maybe b) -> f a -> Scope b f a
abstract :: forall (f :: * -> *) a b.
Functor f =>
(a -> Maybe b) -> f a -> Scope b f a
abstract a -> Maybe b
f f a
e = forall b (f :: * -> *) a. f (Var b a) -> Scope b f a
Scope (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Var b a
k f a
e) where
  k :: a -> Var b a
k a
y = case a -> Maybe b
f a
y of
    Just b
z  -> forall b a. b -> Var b a
B b
z
    Maybe b
Nothing -> forall b a. a -> Var b a
F a
y
{-# INLINE abstract #-}

-- | Abstract over a single variable

--

-- >>> abstract1 'x' "xyz"

-- Scope [B (),F 'y',F 'z']

abstract1 :: (Functor f, Eq a) => a -> f a -> Scope () f a
abstract1 :: forall (f :: * -> *) a.
(Functor f, Eq a) =>
a -> f a -> Scope () f a
abstract1 a
a = forall (f :: * -> *) a b.
Functor f =>
(a -> Maybe b) -> f a -> Scope b f a
abstract (\a
b -> if a
a forall a. Eq a => a -> a -> Bool
== a
b then forall a. a -> Maybe a
Just () else forall a. Maybe a
Nothing)
{-# INLINE abstract1 #-}

-------------------------------------------------------------------------------

-- Instantiation

-------------------------------------------------------------------------------


-- | Enter a scope, instantiating all bound variables

--

-- >>> :m + Data.List

-- >>> instantiate (\x -> [toEnum (97 + x)]) $ abstract (`elemIndex` "bar") "barry"

-- "abccy"

instantiate :: Monad f => (b -> f a) -> Scope b f a -> f a
instantiate :: forall (f :: * -> *) b a.
Monad f =>
(b -> f a) -> Scope b f a -> f a
instantiate b -> f a
k Scope b f a
e = forall b (f :: * -> *) a. Scope b f a -> f (Var b a)
unscope Scope b f a
e forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Var b a
v -> case Var b a
v of
  B b
b -> b -> f a
k b
b
  F a
a -> forall (m :: * -> *) a. Monad m => a -> m a
return a
a
{-# INLINE instantiate #-}

-- | Enter a 'Scope' that binds one variable, instantiating it

--

-- >>> instantiate1 "x" $ Scope [B (),F 'y',F 'z']

-- "xyz"

instantiate1 :: Monad f => f a -> Scope n f a -> f a
instantiate1 :: forall (f :: * -> *) a n. Monad f => f a -> Scope n f a -> f a
instantiate1 f a
e = forall (f :: * -> *) b a.
Monad f =>
(b -> f a) -> Scope b f a -> f a
instantiate (forall a b. a -> b -> a
const f a
e)
{-# INLINE instantiate1 #-}

hoistScope :: (f (Var b a) -> g (Var b a)) -> Scope b f a -> Scope b g a
hoistScope :: forall (f :: * -> *) b a (g :: * -> *).
(f (Var b a) -> g (Var b a)) -> Scope b f a -> Scope b g a
hoistScope f (Var b a) -> g (Var b a)
f = forall b (f :: * -> *) a. f (Var b a) -> Scope b f a
Scope forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Var b a) -> g (Var b a)
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b (f :: * -> *) a. Scope b f a -> f (Var b a)
unscope
{-# INLINE hoistScope #-}

-------------------------------------------------------------------------------

-- Compatibility with Bound.Scope

-------------------------------------------------------------------------------


-- | @'fromScope'@ is just another name for 'unscope' and is exported

-- to mimick 'Bound.Scope.fromScope'.

-- In particular no 'Monad' constraint is required.

fromScope :: Scope b f a -> f (Var b a)
fromScope :: forall b (f :: * -> *) a. Scope b f a -> f (Var b a)
fromScope = forall b (f :: * -> *) a. Scope b f a -> f (Var b a)
unscope
{-# INLINE fromScope #-}

-- | @'toScope'@ is just another name for 'Scope' and is exported

-- to mimick 'Bound.Scope.toScope'.

-- In particular no 'Monad' constraint is required.

toScope :: f (Var b a) -> Scope b f a
toScope :: forall (f :: * -> *) b a. f (Var b a) -> Scope b f a
toScope = forall b (f :: * -> *) a. f (Var b a) -> Scope b f a
Scope
{-# INLINE toScope #-}

-------------------------------------------------------------------------------

-- Exotic Traversals of Bound Variables (not exported by default)

-------------------------------------------------------------------------------


-- | Perform substitution on both bound and free variables in a 'Scope'.

splat :: Monad f => (a -> f c) -> (b -> f c) -> Scope b f a -> f c
splat :: forall (f :: * -> *) a c b.
Monad f =>
(a -> f c) -> (b -> f c) -> Scope b f a -> f c
splat a -> f c
f b -> f c
unbind Scope b f a
s = forall b (f :: * -> *) a. Scope b f a -> f (Var b a)
unscope Scope b f a
s forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Var b a
v -> case Var b a
v of
  B b
b -> b -> f c
unbind b
b
  F a
a -> a -> f c
f a
a
{-# INLINE splat #-}

-- | Return a list of occurences of the variables bound by this 'Scope'.

bindings :: Foldable f => Scope b f a -> [b]
bindings :: forall (f :: * -> *) b a. Foldable f => Scope b f a -> [b]
bindings (Scope f (Var b a)
s) = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {a} {a}. Var a a -> [a] -> [a]
f [] f (Var b a)
s where
  f :: Var a a -> [a] -> [a]
f (B a
v) [a]
vs = a
v forall a. a -> [a] -> [a]
: [a]
vs
  f Var a a
_ [a]
vs     = [a]
vs
{-# INLINE bindings #-}

-- | Perform a change of variables on bound variables.

mapBound :: Functor f => (b -> b') -> Scope b f a -> Scope b' f a
mapBound :: forall (f :: * -> *) b b' a.
Functor f =>
(b -> b') -> Scope b f a -> Scope b' f a
mapBound b -> b'
f (Scope f (Var b a)
s) = forall b (f :: * -> *) a. f (Var b a) -> Scope b f a
Scope (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a}. Var b a -> Var b' a
f' f (Var b a)
s) where
  f' :: Var b a -> Var b' a
f' (B b
b) = forall b a. b -> Var b a
B (b -> b'
f b
b)
  f' (F a
a) = forall b a. a -> Var b a
F a
a
{-# INLINE mapBound #-}

-- | Perform a change of variables, reassigning both bound and free variables.

mapScope :: Functor f => (b -> d) -> (a -> c) -> Scope b f a -> Scope d f c
mapScope :: forall (f :: * -> *) b d a c.
Functor f =>
(b -> d) -> (a -> c) -> Scope b f a -> Scope d f c
mapScope b -> d
f a -> c
g (Scope f (Var b a)
s) = forall b (f :: * -> *) a. f (Var b a) -> Scope b f a
Scope forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap b -> d
f a -> c
g) f (Var b a)
s
{-# INLINE mapScope #-}

-- | Perform a change of variables on bound variables given only a 'Monad'

-- instance

liftMBound :: Monad m => (b -> b') -> Scope b m a -> Scope b' m a
liftMBound :: forall (m :: * -> *) b b' a.
Monad m =>
(b -> b') -> Scope b m a -> Scope b' m a
liftMBound b -> b'
f (Scope m (Var b a)
s) = forall b (f :: * -> *) a. f (Var b a) -> Scope b f a
Scope (forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall {a}. Var b a -> Var b' a
f' m (Var b a)
s) where
  f' :: Var b a -> Var b' a
f' (B b
b) = forall b a. b -> Var b a
B (b -> b'
f b
b)
  f' (F a
a) = forall b a. a -> Var b a
F a
a
{-# INLINE liftMBound #-}

-- | A version of 'mapScope' that can be used when you only have the 'Monad'

-- instance

liftMScope :: Monad m => (b -> d) -> (a -> c) -> Scope b m a -> Scope d m c
liftMScope :: forall (m :: * -> *) b d a c.
Monad m =>
(b -> d) -> (a -> c) -> Scope b m a -> Scope d m c
liftMScope b -> d
f a -> c
g (Scope m (Var b a)
s) = forall b (f :: * -> *) a. f (Var b a) -> Scope b f a
Scope forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap b -> d
f a -> c
g) m (Var b a)
s
{-# INLINE liftMScope #-}

-- | Obtain a result by collecting information from both bound and free

-- variables

foldMapBound :: (Foldable f, Monoid r) => (b -> r) -> Scope b f a -> r
foldMapBound :: forall (f :: * -> *) r b a.
(Foldable f, Monoid r) =>
(b -> r) -> Scope b f a -> r
foldMapBound b -> r
f (Scope f (Var b a)
s) = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall {a}. Var b a -> r
f' f (Var b a)
s where
  f' :: Var b a -> r
f' (B b
a) = b -> r
f b
a
  f' Var b a
_     = forall a. Monoid a => a
mempty
{-# INLINE foldMapBound #-}

-- | Obtain a result by collecting information from both bound and free

-- variables

foldMapScope :: (Foldable f, Monoid r) =>
                (b -> r) -> (a -> r) -> Scope b f a -> r
foldMapScope :: forall (f :: * -> *) r b a.
(Foldable f, Monoid r) =>
(b -> r) -> (a -> r) -> Scope b f a -> r
foldMapScope b -> r
f a -> r
g (Scope f (Var b a)
s) = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall (p :: * -> * -> *) m a b.
(Bifoldable p, Monoid m) =>
(a -> m) -> (b -> m) -> p a b -> m
bifoldMap b -> r
f a -> r
g) f (Var b a)
s
{-# INLINE foldMapScope #-}

-- | 'traverse_' the bound variables in a 'Scope'.

traverseBound_ :: (Applicative g, Foldable f) =>
                  (b -> g d) -> Scope b f a -> g ()
traverseBound_ :: forall (g :: * -> *) (f :: * -> *) b d a.
(Applicative g, Foldable f) =>
(b -> g d) -> Scope b f a -> g ()
traverseBound_ b -> g d
f (Scope f (Var b a)
s) = forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ forall {a}. Var b a -> g ()
f' f (Var b a)
s
  where f' :: Var b a -> g ()
f' (B b
a) = () forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ b -> g d
f b
a
        f' Var b a
_     = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
{-# INLINE traverseBound_ #-}

-- | 'traverse' both the variables bound by this scope and any free variables.

traverseScope_ :: (Applicative g, Foldable f) =>
                  (b -> g d) -> (a -> g c) -> Scope b f a -> g ()
traverseScope_ :: forall (g :: * -> *) (f :: * -> *) b d a c.
(Applicative g, Foldable f) =>
(b -> g d) -> (a -> g c) -> Scope b f a -> g ()
traverseScope_ b -> g d
f a -> g c
g (Scope f (Var b a)
s) = forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bifoldable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f ()
bitraverse_ b -> g d
f a -> g c
g) f (Var b a)
s
{-# INLINE traverseScope_ #-}

-- | mapM_ over the variables bound by this scope

mapMBound_ :: (Monad g, Foldable f) => (b -> g d) -> Scope b f a -> g ()
mapMBound_ :: forall (g :: * -> *) (f :: * -> *) b d a.
(Monad g, Foldable f) =>
(b -> g d) -> Scope b f a -> g ()
mapMBound_ b -> g d
f (Scope f (Var b a)
s) = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {a}. Var b a -> g ()
f' f (Var b a)
s where
  f' :: Var b a -> g ()
f' (B b
a) = do d
_ <- b -> g d
f b
a; forall (m :: * -> *) a. Monad m => a -> m a
return ()
  f' Var b a
_     = forall (m :: * -> *) a. Monad m => a -> m a
return ()
{-# INLINE mapMBound_ #-}

-- | A 'traverseScope_' that can be used when you only have a 'Monad'

-- instance

mapMScope_ :: (Monad m, Foldable f) =>
              (b -> m d) -> (a -> m c) -> Scope b f a -> m ()
mapMScope_ :: forall (m :: * -> *) (f :: * -> *) b d a c.
(Monad m, Foldable f) =>
(b -> m d) -> (a -> m c) -> Scope b f a -> m ()
mapMScope_ b -> m d
f a -> m c
g (Scope f (Var b a)
s) = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bifoldable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f ()
bimapM_ b -> m d
f a -> m c
g) f (Var b a)
s
{-# INLINE mapMScope_ #-}

-- | Traverse both bound and free variables

traverseBound :: (Applicative g, Traversable f) =>
                 (b -> g c) -> Scope b f a -> g (Scope c f a)
traverseBound :: forall (g :: * -> *) (f :: * -> *) b c a.
(Applicative g, Traversable f) =>
(b -> g c) -> Scope b f a -> g (Scope c f a)
traverseBound b -> g c
f (Scope f (Var b a)
s) = forall b (f :: * -> *) a. f (Var b a) -> Scope b f a
Scope forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {a}. Var b a -> g (Var c a)
f' f (Var b a)
s where
  f' :: Var b a -> g (Var c a)
f' (B b
b) = forall b a. b -> Var b a
B forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b -> g c
f b
b
  f' (F a
a) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall b a. a -> Var b a
F a
a)
{-# INLINE traverseBound #-}

-- | Traverse both bound and free variables

traverseScope :: (Applicative g, Traversable f) =>
                 (b -> g d) -> (a -> g c) -> Scope b f a -> g (Scope d f c)
traverseScope :: forall (g :: * -> *) (f :: * -> *) b d a c.
(Applicative g, Traversable f) =>
(b -> g d) -> (a -> g c) -> Scope b f a -> g (Scope d f c)
traverseScope b -> g d
f a -> g c
g (Scope f (Var b a)
s) = forall b (f :: * -> *) a. f (Var b a) -> Scope b f a
Scope forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse b -> g d
f a -> g c
g) f (Var b a)
s
{-# INLINE traverseScope #-}

-- | 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 :: forall (t :: * -> * -> *) (f :: * -> *) k k' a a' b.
(Bitraversable t, Applicative f) =>
(k -> f k')
-> (a -> f a') -> Scope b (t k) a -> f (Scope b (t k') a')
bitraverseScope k -> f k'
f = forall (f :: * -> *) (t :: * -> *) (u :: * -> *) b.
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 (forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse k -> f k'
f)
{-# INLINE bitraverseScope #-}

-- | This is a higher-order analogue of 'traverse'.

transverseScope :: (Functor f)
                => (forall r. g r -> f (h r))
                -> Scope b g a -> f (Scope b h a)
transverseScope :: forall (f :: * -> *) (g :: * -> *) (h :: * -> *) b a.
Functor f =>
(forall r. g r -> f (h r)) -> Scope b g a -> f (Scope b h a)
transverseScope forall r. g r -> f (h r)
tau (Scope g (Var b a)
s) = forall b (f :: * -> *) a. f (Var b a) -> Scope b f a
Scope forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r. g r -> f (h r)
tau g (Var b a)
s

-- | instantiate bound variables using a list of new variables

instantiateVars :: Monad t => [a] -> Scope Int t a -> t a
instantiateVars :: forall (t :: * -> *) a. Monad t => [a] -> Scope Int t a -> t a
instantiateVars [a]
as = forall (f :: * -> *) b a.
Monad f =>
(b -> f a) -> Scope b f a -> f a
instantiate ([t a]
vs forall a. [a] -> Int -> a
!!) where
  vs :: [t a]
vs = forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *) a. Monad m => a -> m a
return [a]
as
{-# INLINE instantiateVars #-}

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 :: forall (f :: * -> *) (t :: * -> *) (u :: * -> *) b.
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 forall a a'. (a -> f a') -> t a -> f (u a')
tau a -> f a'
f (Scope t (Var b a)
s) = forall b (f :: * -> *) a. f (Var b a) -> Scope b f a
Scope forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a a'. (a -> f a') -> t a -> f (u a')
tau (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f a'
f) t (Var b a)
s
{-# INLINE bitransverseScope #-}

-- | mapM over both bound and free variables

mapMBound :: (Monad m, Traversable f) =>
             (b -> m c) -> Scope b f a -> m (Scope c f a)
mapMBound :: forall (m :: * -> *) (f :: * -> *) b c a.
(Monad m, Traversable f) =>
(b -> m c) -> Scope b f a -> m (Scope c f a)
mapMBound b -> m c
f (Scope f (Var b a)
s) = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall b (f :: * -> *) a. f (Var b a) -> Scope b f a
Scope (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {a}. Var b a -> m (Var c a)
f' f (Var b a)
s) where
  f' :: Var b a -> m (Var c a)
f' (B b
b) = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall b a. b -> Var b a
B (b -> m c
f b
b)
  f' (F a
a) = forall (m :: * -> *) a. Monad m => a -> m a
return (forall b a. a -> Var b a
F a
a)
{-# INLINE mapMBound #-}

-- | A 'traverseScope' that can be used when you only have a 'Monad'

-- instance

mapMScope :: (Monad m, Traversable f) =>
             (b -> m d) -> (a -> m c) -> Scope b f a -> m (Scope d f c)
mapMScope :: forall (m :: * -> *) (f :: * -> *) b d a c.
(Monad m, Traversable f) =>
(b -> m d) -> (a -> m c) -> Scope b f a -> m (Scope d f c)
mapMScope b -> m d
f a -> m c
g (Scope f (Var b a)
s) = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall b (f :: * -> *) a. f (Var b a) -> Scope b f a
Scope (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bimapM b -> m d
f a -> m c
g) f (Var b a)
s)
{-# INLINE mapMScope #-}

serializeScope :: (Serial1 f, MonadPut m) => (b -> m ()) -> (v -> m ()) -> Scope b f v -> m ()
serializeScope :: forall (f :: * -> *) (m :: * -> *) b v.
(Serial1 f, MonadPut m) =>
(b -> m ()) -> (v -> m ()) -> Scope b f v -> m ()
serializeScope b -> m ()
pb v -> m ()
pv (Scope f (Var b v)
body) = forall (f :: * -> *) (m :: * -> *) a.
(Serial1 f, MonadPut m) =>
(a -> m ()) -> f a -> m ()
serializeWith (forall (f :: * -> * -> *) (m :: * -> *) a b.
(Serial2 f, MonadPut m) =>
(a -> m ()) -> (b -> m ()) -> f a b -> m ()
serializeWith2 b -> m ()
pb v -> m ()
pv) f (Var b v)
body
{-# INLINE serializeScope #-}

deserializeScope :: (Serial1 f, MonadGet m) => m b -> m v -> m (Scope b f v)
deserializeScope :: forall (f :: * -> *) (m :: * -> *) b v.
(Serial1 f, MonadGet m) =>
m b -> m v -> m (Scope b f v)
deserializeScope m b
gb m v
gv = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall b (f :: * -> *) a. f (Var b a) -> Scope b f a
Scope forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) (m :: * -> *) a.
(Serial1 f, MonadGet m) =>
m a -> m (f a)
deserializeWith (forall (f :: * -> * -> *) (m :: * -> *) a b.
(Serial2 f, MonadGet m) =>
m a -> m b -> m (f a b)
deserializeWith2 m b
gb m v
gv)
{-# INLINE deserializeScope #-}

instance (Serial b, Serial1 f) => Serial1 (Scope b f) where
  serializeWith :: forall (m :: * -> *) a.
MonadPut m =>
(a -> m ()) -> Scope b f a -> m ()
serializeWith = forall (f :: * -> *) (m :: * -> *) b v.
(Serial1 f, MonadPut m) =>
(b -> m ()) -> (v -> m ()) -> Scope b f v -> m ()
serializeScope forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize
  deserializeWith :: forall (m :: * -> *) a. MonadGet m => m a -> m (Scope b f a)
deserializeWith = forall (f :: * -> *) (m :: * -> *) b v.
(Serial1 f, MonadGet m) =>
m b -> m v -> m (Scope b f v)
deserializeScope forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize

instance (Serial b, Serial1 f, Serial a) => Serial (Scope b f a) where
  serialize :: forall (m :: * -> *). MonadPut m => Scope b f a -> m ()
serialize = forall (f :: * -> *) (m :: * -> *) b v.
(Serial1 f, MonadPut m) =>
(b -> m ()) -> (v -> m ()) -> Scope b f v -> m ()
serializeScope forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize
  deserialize :: forall (m :: * -> *). MonadGet m => m (Scope b f a)
deserialize = forall (f :: * -> *) (m :: * -> *) b v.
(Serial1 f, MonadGet m) =>
m b -> m v -> m (Scope b f v)
deserializeScope forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize

instance (Binary b, Serial1 f, Binary a) => Binary (Scope b f a) where
  put :: Scope b f a -> Put
put = forall (f :: * -> *) (m :: * -> *) b v.
(Serial1 f, MonadPut m) =>
(b -> m ()) -> (v -> m ()) -> Scope b f v -> m ()
serializeScope forall t. Binary t => t -> Put
Binary.put forall t. Binary t => t -> Put
Binary.put
  get :: Get (Scope b f a)
get = forall (f :: * -> *) (m :: * -> *) b v.
(Serial1 f, MonadGet m) =>
m b -> m v -> m (Scope b f v)
deserializeScope forall t. Binary t => Get t
Binary.get forall t. Binary t => Get t
Binary.get

instance (Serialize b, Serial1 f, Serialize a) => Serialize (Scope b f a) where
  put :: Putter (Scope b f a)
put = forall (f :: * -> *) (m :: * -> *) b v.
(Serial1 f, MonadPut m) =>
(b -> m ()) -> (v -> m ()) -> Scope b f v -> m ()
serializeScope forall t. Serialize t => Putter t
Serialize.put forall t. Serialize t => Putter t
Serialize.put
  get :: Get (Scope b f a)
get = forall (f :: * -> *) (m :: * -> *) b v.
(Serial1 f, MonadGet m) =>
m b -> m v -> m (Scope b f v)
deserializeScope forall t. Serialize t => Get t
Serialize.get forall t. Serialize t => Get t
Serialize.get

#ifdef __GLASGOW_HASKELL__
deriving instance (Typeable b, Typeable f, Data a, Data (f (Var b a))) => Data (Scope b f a)
#endif