module Control.Static.Closure where
import Control.Static.Closure.IsClosure (IsClosure(closure, unclosure, cap))
import Control.Static.Closure.IsPureClosure (IsPureClosure(cpure, ClosureConstraint))
import Control.Static.Closure.HasClosureDict (HasClosureDict(getClosureDict))
import GHC.StaticPtr (IsStatic(fromStaticPtr), StaticPtr, deRefStaticPtr, staticKey, unsafeLookupStaticPtr)
import Data.Binary (Put, Get, Binary(put, get), encode, decode)
import Data.Word (Word8)
import Data.Constraint (Dict(Dict))
import qualified Data.ByteString.Lazy as BSL
import System.IO.Unsafe (unsafePerformIO)
import Data.Typeable (Typeable)
data Closure t a where
CPure :: !(Closure t (t -> a)) -> t -> a -> Closure t a
CStaticPtr :: !(StaticPtr a) -> Closure t a
CAp :: !(Closure t (a -> b)) -> !(Closure t a) -> Closure t b
instance IsClosure (Closure t) where
closure = CStaticPtr
unclosure = \case
CPure _ _ x -> x
CStaticPtr p -> deRefStaticPtr p
CAp c1 c2 -> (unclosure c1) (unclosure c2)
cap = CAp
decodeWithDict :: Dict (Binary a) -> BSL.ByteString -> a
decodeWithDict Dict = decode
instance IsPureClosure (Closure BSL.ByteString) where
type ClosureConstraint (Closure BSL.ByteString) a = (Typeable a, HasClosureDict (Binary a))
cpure :: forall a. (Typeable a, HasClosureDict (Binary a)) => a -> Closure BSL.ByteString a
cpure = go getClosureDict where
go :: Closure BSL.ByteString (Dict (Binary a)) -> a -> Closure BSL.ByteString a
go closureDict x = CPure f (encode x) x where
f = static decodeWithDict `cap` closureDict
instance IsStatic (Closure t) where
fromStaticPtr = CStaticPtr
instance Binary t => Binary (Closure t a) where
put = putClosure
get = getClosure
newtype Tag = Tag Word8 deriving Binary
pattern PureTag :: Tag
pattern PureTag = (Tag 0)
pattern StaticPtrTag :: Tag
pattern StaticPtrTag = Tag 1
pattern ApTag :: Tag
pattern ApTag = Tag 2
putClosure :: Binary t => Closure t a -> Put
putClosure (CPure c bs _) = put PureTag >> put bs >> putClosure c
putClosure (CStaticPtr p) = put StaticPtrTag >> put (staticKey p)
putClosure (CAp c1 c2) = put ApTag >> putClosure c1 >> putClosure c2
getClosure :: Binary t => Get (Closure t a)
getClosure = get >>= \case
PureTag -> do
bs <- get
c <- getClosure
let x = (unclosure c) bs
pure $ CPure c bs x
StaticPtrTag -> get >>= \key -> case unsafePerformIO (unsafeLookupStaticPtr key) of
Just sptr -> pure $ CStaticPtr sptr
Nothing -> fail $ "Static pointer lookup failed: " ++ show key
ApTag -> CAp <$> getClosure <*> getClosure
_ -> fail "Binary.get(Closure): unrecognized tag."