content: {-# LANGUAGE CPP #-}
  
  #ifdef __GLASGOW_HASKELL__
  {-# LANGUAGE DeriveDataTypeable #-}
  {-# LANGUAGE DeriveGeneric #-}
  {-# LANGUAGE Trustworthy #-}
  #endif
  -----------------------------------------------------------------------------
  -- |
  -- Copyright   :  (C) 2012 Edward Kmett
  -- License     :  BSD-style (see the file LICENSE)
  --
  -- Maintainer  :  Edward Kmett <ekmett@gmail.com>
  -- Stability   :  experimental
  -- Portability :  portable
  --
  ----------------------------------------------------------------------------
  module Bound.Var
    ( Var(..)
    , unvar
    , _B
    , _F
    ) where
  
  import Control.DeepSeq
  import Control.Monad (liftM, ap)
  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
  import Data.Profunctor
  import qualified Data.Serialize as Serialize
  import Data.Serialize (Serialize)
  #ifdef __GLASGOW_HASKELL__
  import Data.Data
  import GHC.Generics
  #endif
  
  ----------------------------------------------------------------------------
  -- Bound and Free Variables
  ----------------------------------------------------------------------------
  
  -- | \"I am not a number, I am a /free monad/!\"
  --
  -- A @'Var' b a@ is a variable that may either be \"bound\" ('B') or \"free\" ('F').
  --
  -- (It is also technically a free monad in the same near-trivial sense as
  -- 'Either'.)
  data Var b a
    = B b -- ^ this is a bound variable
    | F a -- ^ this is a free variable
    deriving
    ( Eq
    , Ord
    , Show
    , Read
  #ifdef __GLASGOW_HASKELL__
    , Data
    , Generic
    , Generic1
  #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
    {-# INLINE liftHashWithSalt2 #-}
  instance Hashable b => Hashable1 (Var b) where
    liftHashWithSalt = liftHashWithSalt2 hashWithSalt
    {-# INLINE liftHashWithSalt #-}
  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
    {-# INLINE hashWithSalt #-}
  
  instance Serial2 Var where
    serializeWith2 pb _  (B b) = putWord8 0 >> pb b
    serializeWith2 _  pf (F f) = putWord8 1 >> pf f
    {-# INLINE serializeWith2 #-}
  
    deserializeWith2 gb gf = getWord8 >>= \b -> case b of
      0 -> liftM B gb
      1 -> liftM F gf
      _ -> fail $ "getVar: Unexpected constructor code: " ++ show b
    {-# INLINE deserializeWith2 #-}
  
  instance Serial b => Serial1 (Var b) where
    serializeWith = serializeWith2 serialize
    {-# INLINE serializeWith #-}
    deserializeWith = deserializeWith2 deserialize
    {-# INLINE deserializeWith #-}
  
  instance (Serial b, Serial a) => Serial (Var b a) where
    serialize = serializeWith2 serialize serialize
    {-# INLINE serialize #-}
    deserialize = deserializeWith2 deserialize deserialize
    {-# INLINE 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
  {-# INLINE unvar #-}
  
  -- |
  -- This provides a @Prism@ that can be used with @lens@ library to access a bound 'Var'.
  --
  -- @
  -- '_B' :: 'Prism' (Var b a) (Var b' a) b b'@
  -- @
  _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'
  {-# INLINE _B #-}
  
  -- |
  -- This provides a @Prism@ that can be used with @lens@ library to access a free 'Var'.
  --
  -- @
  -- '_F' :: 'Prism' (Var b a) (Var b a') a a'@
  -- @
  _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'
  {-# INLINE _F #-}
  
  ----------------------------------------------------------------------------
  -- Instances
  ----------------------------------------------------------------------------
  
  instance Functor (Var b) where
    fmap _ (B b) = B b
    fmap f (F a) = F (f a)
    {-# INLINE fmap #-}
  
  instance Foldable (Var b) where
    foldMap f (F a) = f a
    foldMap _ _ = mempty
    {-# INLINE foldMap #-}
  
  instance Traversable (Var b) where
    traverse f (F a) = F <$> f a
    traverse _ (B b) = pure (B b)
    {-# INLINE traverse #-}
  
  instance Applicative (Var b) where
    pure = F
    {-# INLINE pure #-}
    (<*>) = ap
    {-# INLINE (<*>) #-}
  
  instance Monad (Var b) where
    return = pure
    {-# INLINE return #-}
    F a >>= f = f a
    B b >>= _ = B b
    {-# INLINE (>>=) #-}
  
  instance Bifunctor Var where
    bimap f _ (B b) = B (f b)
    bimap _ g (F a) = F (g a)
    {-# INLINE bimap #-}
  
  instance Bifoldable Var where
    bifoldMap f _ (B b) = f b
    bifoldMap _ g (F a) = g a
    {-# INLINE bifoldMap #-}
  
  instance Bitraversable Var where
    bitraverse f _ (B b) = B <$> f b
    bitraverse _ g (F a) = F <$> g a
    {-# INLINE bitraverse #-}
  
  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
  
  instance (NFData a, NFData b) => NFData (Var b a) where
    rnf (B b) = rnf b
    rnf (F f) = rnf f
  