imprint (empty) → 0.0.1.0
raw patch · 8 files changed
+414/−0 lines, 8 filesdep +basedep +binarydep +bytestringsetup-changed
Dependencies added: base, binary, bytestring, constraints, hspec, imprint
Files
- CHANGELOG.md +3/−0
- Data/Imprint.hs +244/−0
- LICENSE.md +28/−0
- README.md +30/−0
- Setup.hs +6/−0
- imprint.cabal +53/−0
- tests/Data/ImprintSpec.hs +49/−0
- tests/Spec.hs +1/−0
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+## Imprint 0.0.1.0++* Initial release.
+ Data/Imprint.hs view
@@ -0,0 +1,244 @@+-- |+-- 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
+ LICENSE.md view
@@ -0,0 +1,28 @@+Copyright © 2018 Mark Karpov++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++* Neither the name Mark Karpov nor the names of contributors may be used to+ endorse or promote products derived from this software without specific+ prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY EXPRESS+OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES+OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN+NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,+EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,30 @@+# Imprint++[](http://opensource.org/licenses/BSD-3-Clause)+[](https://hackage.haskell.org/package/imprint)+[](http://stackage.org/nightly/package/imprint)+[](http://stackage.org/lts/package/imprint)+[](https://travis-ci.org/mrkkrp/imprint)+[](https://coveralls.io/github/mrkkrp/imprint?branch=master)++Serialization of arbitrary Haskell expressions. Currently supports+serialization of++* Values with a `Binary` instance+* Monomorphic functions+* Closures built upon the two previous components++See the Haddock for a proper introduction.++## Contribution++Issues, bugs, and questions may be reported in [the GitHub issue tracker for+this project](https://github.com/mrkkrp/imprint/issues).++Pull requests are also welcome and will be reviewed quickly.++## License++Copyright © 2018 Mark Karpov++Distributed under BSD 3 clause license.
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain
+ imprint.cabal view
@@ -0,0 +1,53 @@+name: imprint+version: 0.0.1.0+cabal-version: >= 1.18+tested-with: GHC==8.2.2+license: BSD3+license-file: LICENSE.md+author: Mark Karpov <markkarpov92@gmail.com>+maintainer: Mark Karpov <markkarpov92@gmail.com>+homepage: https://github.com/mrkkrp/imprint+bug-reports: https://github.com/mrkkrp/imprint/issues+category: Serialization+synopsis: Serialization of arbitrary Haskell expressions+build-type: Simple+description: Serialization of arbitrary Haskell expressions.+extra-doc-files: CHANGELOG.md+ , README.md++source-repository head+ type: git+ location: https://github.com/mrkkrp/imprint.git++flag dev+ description: Turn on development settings.+ manual: True+ default: False++library+ build-depends: base >= 4.10 && < 5.0+ , binary >= 0.8.5 && < 0.10+ , bytestring >= 0.2 && < 0.11+ , constraints >= 0.9 && < 0.10+ exposed-modules: Data.Imprint+ if flag(dev)+ ghc-options: -Wall -Werror+ else+ ghc-options: -O2 -Wall+ default-language: Haskell2010++test-suite tests+ main-is: Spec.hs+ hs-source-dirs: tests+ type: exitcode-stdio-1.0+ build-depends: base >= 4.10 && < 5.0+ , binary >= 0.8.5 && < 0.10+ , constraints >= 0.9 && < 0.10+ , hspec >= 2.0 && < 3.0+ , imprint+ other-modules: Data.ImprintSpec+ if flag(dev)+ ghc-options: -Wall -Werror+ else+ ghc-options: -O2 -Wall+ default-language: Haskell2010
+ tests/Data/ImprintSpec.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StaticPointers #-}+{-# LANGUAGE TypeOperators #-}++module Data.ImprintSpec (spec) where++import Data.Binary+import Data.Imprint (Imprint, Col (..), Dict (..), (<:>))+import Test.Hspec+import qualified Data.Imprint as I++spec :: Spec+spec = do+ testS "binary serialization works" intImprint $ \n ->+ n `shouldBe` 4+ testS "static serialization works" funImprint $ \f -> do+ f 4 "Here we have: " `shouldBe` "Here we have: 4"+ f 10 "And 10 == " `shouldBe` "And 10 == 10"+ testS "closure serialization works" closureImprint $ \f ->+ f "Here we have: " `shouldBe` "Here we have: 4"++----------------------------------------------------------------------------+-- Test imprints++intImprint :: Imprint 'Z Int+intImprint = I.binary (static Dict) 4++funImprint :: Imprint 'Z (Int -> String -> String)+funImprint = I.static (static f)+ where+ f n str = str ++ show n++closureImprint :: Imprint ('Z ':~> Int) (String -> String)+closureImprint = funImprint <:> intImprint++----------------------------------------------------------------------------+-- Helpers++testS :: forall bs a. Binary (Imprint bs a)+ => String+ -> Imprint bs a+ -> (a -> IO ())+ -> Spec+testS name imprint m =+ it name $ do+ let x = decode (encode imprint) :: Imprint bs a+ m (I.restore x)
+ tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}