#ifdef __GLASGOW_HASKELL__
#if __GLASGOW_HASKELL__ >= 704
#endif
#if __GLASGOW_HASKELL__ >= 702
#endif
#endif
module Bound.Var
( Var(..)
, unvar
, _B
, _F
) where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
import Control.DeepSeq
import Control.Monad (liftM, ap)
#if __GLASGOW_HASKELL__ < 710
import Data.Foldable
import Data.Traversable
import Data.Monoid (Monoid(..))
#endif
import Data.Hashable (Hashable(..))
import Data.Hashable.Lifted (Hashable1(..), Hashable2(..))
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.Functor.Classes
#ifdef __GLASGOW_HASKELL__
import Data.Data
# if __GLASGOW_HASKELL__ >= 704
import GHC.Generics
# endif
#endif
import Data.Profunctor
import qualified Data.Serialize as Serialize
import Data.Serialize (Serialize)
#if __GLASGOW_HASKELL__ < 710
import Data.Word
#endif
data Var b a
= B b
| F a
deriving
( Eq
, Ord
, Show
, Read
#ifdef __GLASGOW_HASKELL__
, Data
, Typeable
# if __GLASGOW_HASKELL__ >= 704
, Generic
# endif
#endif
)
distinguisher :: Int
distinguisher = fromIntegral $ (maxBound :: Word) `quot` 3
instance Hashable2 Var where
liftHashWithSalt2 h _ s (B b) = h s b
liftHashWithSalt2 _ h s (F a) = h s a `hashWithSalt` distinguisher
instance Hashable b => Hashable1 (Var b) where
liftHashWithSalt = liftHashWithSalt2 hashWithSalt
instance (Hashable b, Hashable a) => Hashable (Var b a) where
hashWithSalt s (B b) = hashWithSalt s b
hashWithSalt s (F a) = hashWithSalt s a `hashWithSalt` distinguisher
instance Serial2 Var where
serializeWith2 pb _ (B b) = putWord8 0 >> pb b
serializeWith2 _ pf (F f) = putWord8 1 >> pf f
deserializeWith2 gb gf = getWord8 >>= \b -> case b of
0 -> liftM B gb
1 -> liftM F gf
_ -> fail $ "getVar: Unexpected constructor code: " ++ show b
instance Serial b => Serial1 (Var b) where
serializeWith = serializeWith2 serialize
deserializeWith = deserializeWith2 deserialize
instance (Serial b, Serial a) => Serial (Var b a) where
serialize = serializeWith2 serialize serialize
deserialize = deserializeWith2 deserialize deserialize
instance (Binary b, Binary a) => Binary (Var b a) where
put = serializeWith2 Binary.put Binary.put
get = deserializeWith2 Binary.get Binary.get
instance (Serialize b, Serialize a) => Serialize (Var b a) where
put = serializeWith2 Serialize.put Serialize.put
get = deserializeWith2 Serialize.get Serialize.get
unvar :: (b -> r) -> (a -> r) -> Var b a -> r
unvar f _ (B b) = f b
unvar _ g (F a) = g a
_B :: (Choice p, Applicative f) => p b (f b') -> p (Var b a) (f (Var b' a))
_B = dimap (unvar Right (Left . F)) (either pure (fmap B)) . right'
_F :: (Choice p, Applicative f) => p a (f a') -> p (Var b a) (f (Var b a'))
_F = dimap (unvar (Left . B) Right) (either pure (fmap F)) . right'
instance Functor (Var b) where
fmap _ (B b) = B b
fmap f (F a) = F (f a)
instance Foldable (Var b) where
foldMap f (F a) = f a
foldMap _ _ = mempty
instance Traversable (Var b) where
traverse f (F a) = F <$> f a
traverse _ (B b) = pure (B b)
instance Applicative (Var b) where
pure = F
(<*>) = ap
instance Monad (Var b) where
return = pure
F a >>= f = f a
B b >>= _ = B b
instance Bifunctor Var where
bimap f _ (B b) = B (f b)
bimap _ g (F a) = F (g a)
instance Bifoldable Var where
bifoldMap f _ (B b) = f b
bifoldMap _ g (F a) = g a
instance Bitraversable Var where
bitraverse f _ (B b) = B <$> f b
bitraverse _ g (F a) = F <$> g a
#if (MIN_VERSION_transformers(0,5,0)) || !(MIN_VERSION_transformers(0,4,0))
instance Eq2 Var where
liftEq2 f _ (B a) (B c) = f a c
liftEq2 _ g (F b) (F d) = g b d
liftEq2 _ _ _ _ = False
instance Ord2 Var where
liftCompare2 f _ (B a) (B c) = f a c
liftCompare2 _ _ B{} F{} = LT
liftCompare2 _ _ F{} B{} = GT
liftCompare2 _ g (F b) (F d) = g b d
instance Show2 Var where
liftShowsPrec2 f _ _ _ d (B a) = showsUnaryWith f "B" d a
liftShowsPrec2 _ _ h _ d (F a) = showsUnaryWith h "F" d a
instance Read2 Var where
liftReadsPrec2 f _ h _ = readsData $ readsUnaryWith f "B" B `mappend` readsUnaryWith h "F" F
instance Eq b => Eq1 (Var b) where
liftEq = liftEq2 (==)
instance Ord b => Ord1 (Var b) where
liftCompare = liftCompare2 compare
instance Show b => Show1 (Var b) where
liftShowsPrec = liftShowsPrec2 showsPrec showList
instance Read b => Read1 (Var b) where
liftReadsPrec = liftReadsPrec2 readsPrec readList
#else
instance Eq b => Eq1 (Var b) where eq1 = (==)
instance Ord b => Ord1 (Var b) where compare1 = compare
instance Show b => Show1 (Var b) where showsPrec1 = showsPrec
instance Read b => Read1 (Var b) where readsPrec1 = readsPrec
#endif
# if __GLASGOW_HASKELL__ >= 704
instance (NFData a, NFData b) => NFData (Var b a)
# endif