content: {-# LANGUAGE CPP #-}
  {-# LANGUAGE ConstraintKinds #-}
  {-# LANGUAGE GADTs #-}
  {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE StaticPointers #-}
  
  -- | Private internals. You should not use this module unless you are determined
  -- to monkey with the internals. This module comes with no API stability
  -- guarantees whatsoever. Use at your own risks.
  
  #if !MIN_VERSION_binary(0,7,6)
  {-# OPTIONS_GHC -fno-warn-orphans #-} -- for binary < 0.7.6 compat.
  #endif
  #if __GLASGOW_HASKELL__ >= 800
  {-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
  #endif
  
  module Control.Distributed.Closure.Internal
    ( Serializable
    , Closure(..)
    , closure
    , unclosure
    , cpure
    , cap
    , capDup
    , cmap
    , cduplicate
    ) where
  
  import Data.Binary (Binary(..), Get, Put, decode, encode)
  import Data.Binary.Put (putWord8)
  import Data.Binary.Get (getWord8)
  import Data.Constraint (Dict(..))
  import Data.Typeable (Typeable)
  import Data.ByteString.Lazy (ByteString)
  import GHC.Base (Any)
  #if !MIN_VERSION_binary(0,7,6)
  import GHC.Fingerprint
  #endif
  import GHC.StaticPtr
  import Unsafe.Coerce (unsafeCoerce) -- for dynClosureApply
  import System.IO.Unsafe (unsafePerformIO)
  
  -- | Values that can be sent across the network.
  type Serializable a = (Binary a, Typeable a)
  
  -- | Type of serializable closures. Abstractly speaking, a closure is a code
  -- reference paired together with an environment. A serializable closure
  -- includes a /shareable/ code reference (i.e. a 'StaticPtr'). Closures can be
  -- serialized only if all expressions captured in the environment are
  -- serializable.
  data Closure a where
    -- XXX Can't unpack because of https://ghc.haskell.org/trac/ghc/ticket/12622.
    StaticPtr :: !(StaticPtr a) -> Closure a
    Encoded :: !ByteString -> Closure ByteString
    Ap :: !(Closure (a -> b)) -> !(Closure a) -> Closure b
    Duplicate :: Closure a -> Closure (Closure a)
    -- Cache the value a closure resolves to.
    Closure :: a -> !(Closure a) -> Closure a
  
  #if MIN_VERSION_base(4,9,0)
  instance IsStatic Closure where
    fromStaticPtr = closure
  #endif
  
  -- Will be obsoleted by https://ghc.haskell.org/trac/ghc/wiki/Typeable. We use
  -- our own datatype instead of Dynamic in order to support dynClosureApply.
  newtype DynClosure = DynClosure Any -- invariant: only values of type Closure.
  
  -- | Until GHC.StaticPtr can give us a proper TypeRep upon decoding, we have to
  -- pretend that this function doesn't need a 'Typeable' constraint to be safe.
  toDynClosure :: Closure a -> DynClosure
  toDynClosure = DynClosure . unsafeCoerce
  
  fromDynClosure :: Typeable a => DynClosure -> Closure a
  fromDynClosure (DynClosure x) = unsafeCoerce x
  
  dynClosureApply :: DynClosure -> DynClosure -> DynClosure
  dynClosureApply (DynClosure x1) (DynClosure x2) =
      case unsafeCoerce x1 of
        (clos1 :: Closure (a -> b)) -> case unsafeCoerce x2 of
          (clos2 :: Closure a) -> DynClosure $ unsafeCoerce $ Ap clos1 clos2
  
  dynClosureDuplicate :: DynClosure -> DynClosure
  dynClosureDuplicate (DynClosure x) =
      DynClosure $ unsafeCoerce $ Duplicate $ unsafeCoerce x
  
  -- | Until GHC.StaticPtr can give us a proper TypeRep upon decoding, we have to
  -- pretend that serializing/deserializing a @'Closure' a@ without a @'Typeable'
  -- a@ constraint, i.e. for /any/ @a@, is safe.
  putClosure :: Closure a -> Put
  putClosure (StaticPtr sptr) = putWord8 0 >> put (staticKey sptr)
  putClosure (Encoded bs) = putWord8 1 >> put bs
  putClosure (Ap clos1 clos2) = putWord8 2 >> putClosure clos1 >> putClosure clos2
  putClosure (Closure _ clos) = putClosure clos
  putClosure (Duplicate clos) = putWord8 3 >> putClosure clos
  
  getDynClosure :: Get DynClosure
  getDynClosure = getWord8 >>= \case
      0 -> get >>= \key -> case unsafePerformIO (unsafeLookupStaticPtr key) of
             Just sptr -> return $ toDynClosure $ StaticPtr sptr
             Nothing -> fail $ "Static pointer lookup failed: " ++ show key
      1 -> toDynClosure . Encoded <$> get
      2 -> dynClosureApply <$> getDynClosure <*> getDynClosure
      3 -> dynClosureDuplicate <$> getDynClosure
      _ -> fail "Binary.get(Closure): unrecognized tag."
  
  #if !MIN_VERSION_binary(0,7,6)
  -- Orphan instance
  instance Binary Fingerprint where
    put (Fingerprint x1 x2) = do
        put x1
        put x2
    get = do
        x1 <- get
        x2 <- get
        return $! Fingerprint x1 x2
  #endif
  
  instance Typeable a => Binary (Closure a) where
    put = putClosure
    get = do
        clos <- fromDynClosure <$> getDynClosure
        return $ Closure (unclosure clos) clos
  
  -- | Lift a Static pointer to a closure with an empty environment.
  closure :: StaticPtr a -> Closure a
  closure sptr = Closure (deRefStaticPtr sptr) (StaticPtr sptr)
  
  -- | Resolve a 'Closure' to the value that it represents. Calling 'unclosure'
  -- multiple times on the same closure is efficient: for most argument values the
  -- result is memoized.
  unclosure :: Closure a -> a
  unclosure (StaticPtr sptr) = deRefStaticPtr sptr
  unclosure (Encoded x) = x
  unclosure (Ap cf cx) = (unclosure cf) (unclosure cx)
  unclosure (Closure x _) = x
  unclosure (Duplicate x) = x
  
  -- | Turn a closure into a closure of a closure.
  cduplicate :: Closure a -> Closure (Closure a)
  cduplicate = Duplicate
  
  decodeD :: Dict (Serializable a) -> ByteString -> a
  decodeD Dict = decode
  
  -- | A closure can be created from any serializable value. 'cpure' corresponds
  -- to "Control.Applicative"'s 'Control.Applicative.pure', but restricted to
  -- lifting serializable values only.
  cpure :: Closure (Dict (Serializable a)) -> a -> Closure a
  cpure cdict x | Dict <- unclosure cdict =
      Closure x $
      StaticPtr (static decodeD) `cap`
      cdict `cap`
      Encoded (encode x)
  
  -- | Closure application. Note that 'Closure' is not a functor, let alone an
  -- applicative functor, even if it too has a meaningful notion of application.
  cap :: Typeable a          -- XXX 'Typeable' constraint only for forward compat.
      => Closure (a -> b)
      -> Closure a
      -> Closure b
  cap (Closure f closf) (Closure x closx) = Closure (f x) (Ap closf closx)
  cap closf closx = Ap closf closx
  
  -- | Nested closure application.
  capDup :: Typeable a => Closure (Closure a -> b) -> Closure a -> Closure b
  capDup cf = cap cf . cduplicate
  
  -- | 'Closure' is not a 'Functor', in that we cannot map arbitrary functions
  -- over it. That is, we cannot define 'fmap'. However, we can map a static
  -- pointer to a function over a 'Closure'.
  cmap :: Typeable a => StaticPtr (a -> b) -> Closure a -> Closure b
  cmap sf = cap (closure sf)
  {-# DEPRECATED cmap "Use staticMap instead." #-}
  