imprint-0.0.1.0: Data/Imprint.hs
-- |
-- Module : Data.Imprint
-- Copyright : © 2018 Mark Karpov
-- License : BSD 3 clause
--
-- Maintainer : Mark Karpov <markkarpov92@gmail.com>
-- Stability : experimental
-- Portability : portable
--
-- This package provides a solution for serialization of arbitrary Haskell
-- values, monomorphic functions, and closures without relying on remote
-- tables or Template Haskell, with minimum boilderplate.
--
-- To use the package, be sure to enable the following language extensions:
--
-- * [DataKinds](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#datatype-promotion)
-- * [StaticPointers](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#static-pointers)
-- * [TypeOperators](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#type-operators)
--
-- The following form of import is recommended:
--
-- > import Data.Imprint (Imprint, Col (..), Dict (..), (<:>))
-- > import qualified Data.Imprint as I
--
-- To serialize a value, we must first create an 'Imprint' of it. If the
-- value in question is an instance of the 'Binary' type class, then the
-- 'binary' function should be used:
--
-- > intImprint :: Imprint 'Z Int
-- > intImprint = I.binary (static Dict) 4
--
-- The @static@ keyword has to do with the concept of static pointers, see
-- the link above. We won't go into the details here, but it suffices to say
-- that we need to have an evidence of existence of 'Binary' instance in
-- serializable form. @static@, being a keyword, not a function, has to be
-- used like this and cannot be put inside 'binary', because it creates a
-- pointer to a concrete thing that is passed to it. This little ceremony of
-- passing @static Dict@ as the first argument of 'binary' every time you
-- create an 'Imprint' of a value that has a 'Binary' instance is the only
-- boilderplate we have to put up with, though.
--
-- To create an 'Imprint' of a function or indeed almost anything that has
-- no 'Binary' instance, we use the 'static' function:
--
-- > funImprint :: Imprint 'Z (Int -> String -> String)
-- > funImprint = I.static (static f)
-- > where
-- > f n str = str ++ show n
--
-- The @f@ function we want to serialize may be defined anywhere. Note that
-- the resulting 'Imprint' is opaque and has no sign of how it was created
-- (with 'binary' or with 'static').
--
-- Finally, there is a way to apply an 'Imprint' of a value to an 'Imprint'
-- of a function with @('<:>')@:
--
-- > closureImprint :: Imprint ('Z ':~> Int) (String -> String)
-- > closureImprint = funImprint <:> intImprint
--
-- Note how the applied arguments are collected in the phantom type (the
-- first argument of 'Imprint' type constructor). There is no requirement to
-- apply all arguments, you may transmit a partially applied function all
-- right.
--
-- Now, to serialization. That is quite simple, because 'Imprint' is an
-- instance of 'Binary' and so it is perfectly serializable. On the
-- receiving site, you however must know the full type of 'Imprint',
-- including the collection of applied arguments in order to restore it.
--
-- If a more dynamic approach is desirable, we could adopt the
-- representation of closures used in @distributed-process@ as a special
-- case with the following type of 'Imprint':
--
-- > Imprint ('Z ':~> ByteString) (Process ())
--
-- In that case we would need to serialize all the arguments beforehand and
-- put the deserializing code into the @ByteString -> Process ()@ function.
--
-- Finally, we give the guarantee that if you have a value of the type
-- @'Imprint' as a@, then you can have the @a@ value back, see 'restore':
--
-- > restore :: Imprint bs a -> a
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Imprint
( -- * Types
Imprint
, Col (..)
, Dict (..)
-- * Creation of imprints
, binary
, static
, (<:>)
-- * Elimination of imprints
, restore )
where
import Data.Binary
import Data.Constraint (Dict (..), withDict)
import Data.Proxy
import Data.Typeable (Typeable)
import GHC.Fingerprint
import GHC.StaticPtr
import System.IO.Unsafe (unsafePerformIO)
import Type.Reflection
-- | @'Imprint' bs a@ is an image of @a@ that is isomorphic to @a@ and
-- serializable.
data Imprint (bs :: Col *) a where
BinaryImprint :: Typeable a
=> StaticPtr (Dict (Binary a))
-> a
-> Imprint 'Z a
StaticImprint :: Typeable a
=> StaticPtr a
-> Imprint 'Z a
AppImprint
:: Imprint bs (b -> a)
-> Imprint 'Z b
-> Imprint (bs ':~> b) a
-- | This helper type is used to build the phantom type holding types of the
-- arguments applied to an 'Imprint' of a function.
data Col a where
Z :: Col a
(:~>) :: Col a -> a -> Col a
infixl 4 :~>
instance Typeable a => Binary (Imprint 'Z a) where
put = \case
BinaryImprint dict a -> do
putWord8 0
put (someTypeRep (Proxy :: Proxy a))
putStatic dict
withDict (deRefStaticPtr dict) (put a)
StaticImprint ptr -> do
putWord8 1
put (someTypeRep (Proxy :: Proxy a))
putStatic ptr
get = do
h <- getWord8
case h of
0 -> withTypeRep (Proxy :: Proxy a) $ do
dict <- getStatic
a <- withDict (deRefStaticPtr dict) get
return (binary dict a)
1 -> withTypeRep (Proxy :: Proxy a) $
static <$> getStatic
_ -> fail "Data.Imprint: decoding failure, invalid header"
instance ( Binary (Imprint bs (b -> a))
, Typeable a
, Typeable b ) => Binary (Imprint (bs ':~> b) a) where
put (AppImprint ab a) = do
putWord8 2
put ab
put a
get = do
h <- getWord8
case h of
2 -> AppImprint <$> get <*> get
_ -> fail "Data.Imprint: decoding failure, invalid header"
----------------------------------------------------------------------------
-- Creation of imprints
-- | Create an 'Imprint' of a value with 'Binary' instance.
--
-- > intImprint :: Imprint 'Z Int
-- > intImprint = I.binary (static Dict) 4
binary :: Typeable a => StaticPtr (Dict (Binary a)) -> a -> Imprint 'Z a
binary = BinaryImprint
-- | Create an 'Imprint' of a value without 'Binary' instance.
--
-- > funImprint :: Imprint 'Z (Int -> String -> String)
-- > funImprint = I.static (static f)
-- > where
-- > f n str = str ++ show n
static :: Typeable a => StaticPtr a -> Imprint 'Z a
static = StaticImprint
-- | Apply 'Imprint' of a value to an 'Imprint' of a function building a
-- closure.
--
-- > closureImprint :: Imprint ('Z ':~> Int) (String -> String)
-- > closureImprint = funImprint <:> intImprint
(<:>) :: Imprint bs (b -> a) -> Imprint 'Z b -> Imprint (bs ':~> b) a
(<:>) = AppImprint
infixl 4 <:>
----------------------------------------------------------------------------
-- Elimination of imprints
-- | Restore a value from its 'Imprint'.
restore :: Imprint as a -> a
restore = \case
BinaryImprint _ a -> a
StaticImprint ptr -> deRefStaticPtr ptr
AppImprint f x ->
restore f (restore x)
----------------------------------------------------------------------------
-- Helpers
putStatic :: StaticPtr a -> Put
putStatic ptr = do
let (Fingerprint hi lo) = staticKey ptr
put hi
put lo
getStatic :: Get (StaticPtr a)
getStatic = do
key <- Fingerprint <$> get <*> get
case unsaferLookupStaticPtr key of
Nothing -> fail "Data.Imprint: lookup of static pointer failed"
Just ptr -> return ptr
withTypeRep :: forall a b. Typeable a => Proxy a -> Get b -> Get b
withTypeRep Proxy m = do
trep <- get
if someTypeRep (Proxy :: Proxy a) == trep
then m
else fail "Data.Imprint: type rep mismatch"
unsaferLookupStaticPtr :: StaticKey -> Maybe (StaticPtr a)
unsaferLookupStaticPtr = unsafePerformIO . unsafeLookupStaticPtr