diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,10 @@ +# 0.2.0.0 + +* Redesign the 'Mutable' type class's API. +* Provide helpers for doing zero-copy message creation in pure code. +* General improvements to the documentation. + # 0.1.0.0 -First release; basic read & write support, serialization only. +* First release; basic read & write support, serialization only. diff --git a/capnp.cabal b/capnp.cabal --- a/capnp.cabal +++ b/capnp.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: capnp -version: 0.1.0.0 +version: 0.2.0.0 stability: Experimental category: Data, Serialization copyright: 2016-2018 haskell-capnp contributors (see CONTRIBUTORS file). @@ -19,7 +19,7 @@ unstable, and is likely to change to accomodate RPC, facilitate improved performance, etc. . - The 'Data.Capnp.Tutorial' module is the best place to start reading; the + The "Data.Capnp.Tutorial" module is the best place to start reading; the reference documentation can seem bewildering without that context. build-type: Simple extra-source-files: @@ -63,16 +63,16 @@ common shared-opts build-depends: base >= 4.8 && < 5.0 - , array >= 0.5 && < 0.6 - , bytes >= 0.15.4 && < 0.16 - , bytestring >= 0.10 && < 0.11 - , exceptions >= 0.10.0 && < 0.11 - , mtl >= 2.2.2 && < 2.3 - , primitive >= 0.6.3 && < 0.7 - , reinterpret-cast >= 0.1.0 && < 0.2 - , text >= 1.2 && < 2.0 - , transformers >= 0.5.2 && < 0.6 - , vector >= 0.12.0 && < 0.13 + , array ^>= 0.5 + , bytes ^>= 0.15.4 + , bytestring ^>= 0.10 + , exceptions ^>= 0.10.0 + , mtl ^>= 2.2.2 + , primitive ^>= 0.6.3 + , reinterpret-cast ^>= 0.1.0 + , text >= 1.2 && < 2.0 + , transformers ^>= 0.5.2 + , vector ^>= 0.12.0 ghc-options: -Wnoncanonical-monad-instances -Wincomplete-patterns @@ -102,6 +102,13 @@ , Data.Capnp.Untyped.Pure , Data.Capnp.TraversalLimit , Data.Capnp.Tutorial + + , Data.Mutable + + , Capnp + , Capnp.ById + , Capnp.Capnp + -- BEGIN GENERATED SCHEMA MODULES , Capnp.Capnp.Cxx.Pure , Capnp.Capnp.Json.Pure @@ -131,12 +138,13 @@ other-modules: Internal.Util , Internal.Gen.Instances + , Internal.BuildPure , Codec.Capnp -- other-extensions: build-depends: - cpu >= 0.1.2 && < 0.2 - , data-default >= 0.7.1 && < 0.8 - , data-default-instances-vector >= 0.0.1 && < 0.1 + cpu ^>= 0.1.2 + , data-default ^>= 0.7.1 + , data-default-instances-vector ^>= 0.0.1 -------------------------------------------------------------------------------- @@ -153,14 +161,14 @@ hs-source-dirs: exe/capnpc-haskell build-depends: capnp - , binary >= 0.8.5 && < 0.9 - , cereal >= 0.5.5 && < 0.6 - , containers >= 0.5.10 && < 0.6 - , directory >= 1.3.0 && < 1.4 - , dlist >= 0.8.0 && < 0.9 - , filepath >= 1.4.1 && < 1.5 - , utf8-string >= 1.0.1 && < 1.1 - , wl-pprint-text >= 1.2 && <1.3 + , binary ^>= 0.8.5 + , cereal ^>= 0.5.5 + , containers ^>= 0.5.10 + , directory ^>= 1.3.0 + , dlist ^>= 0.8.0 + , filepath ^>= 1.4.1 + , utf8-string ^>= 1.0.1 + , wl-pprint-text ^>= 1.2 -------------------------------------------------------------------------------- diff --git a/lib/Capnp.hs b/lib/Capnp.hs new file mode 100644 --- /dev/null +++ b/lib/Capnp.hs @@ -0,0 +1,9 @@ +{- | +Module: Capnp +Description: Code generated by the schema compiler. + +The @Capnp@ module hierarchy contains code generated by the schema compiler. +See "Data.Capnp.Tutorial" for a description of what code is generated for +each schema, as well as a general introduction to the library. +-} +module Capnp () where diff --git a/lib/Capnp/ById.hs b/lib/Capnp/ById.hs new file mode 100644 --- /dev/null +++ b/lib/Capnp/ById.hs @@ -0,0 +1,16 @@ +{- | +Module: Capnp.ById +Description: Machine-addressable aliases for modules generated by the schema compiler. + +In addition to modules with human readable names, the schema compiler also generates +modules of the form @Capnp.ById.X\@. These are used internally by generated +code, so that generated modules with dependencies on other schema don't have to know +what the human-readable names of those schema are -- they import by id. + +Each module in this heirarchy just re-exports everthing from the module with +a human-readable name. + +This hierarchy is an implementation detail that most users don't need to know +about. +-} +module Capnp.ById () where diff --git a/lib/Capnp/Capnp.hs b/lib/Capnp/Capnp.hs new file mode 100644 --- /dev/null +++ b/lib/Capnp/Capnp.hs @@ -0,0 +1,8 @@ +{-| +Module: Capnp.Capnp +Description: Generated modules for the schema that ship with Cap'N Proto + +The modules under 'Capnp.Capnp' are generated code for the schema files that +ship with the Cap'N Proto reference implementation. +-} +module Capnp.Capnp () where diff --git a/lib/Data/Capnp.hs b/lib/Data/Capnp.hs --- a/lib/Data/Capnp.hs +++ b/lib/Data/Capnp.hs @@ -2,8 +2,12 @@ Module: Data.Capnp Description: The most commonly used functionality from the low-level API. +This module re-exports the most commonly used functionality from the +low-level API. See also "Data.Capnp.Pure", which similarly re-exports +functionality from the high-level API. + Users getting acquainted with the library are *strongly* encouraged to read the -'Data.Capnp.Tutorial' module before anything else. +"Data.Capnp.Tutorial" module before anything else. -} module Data.Capnp ( @@ -20,7 +24,6 @@ -- * Working with messages , Message.ConstMsg , Message.Message(..) - , Message.Mutable(..) , Message.MutMsg , Message.newMessage , decodeMessage @@ -48,6 +51,13 @@ -- * Managing resource limits , module Data.Capnp.TraversalLimit + + -- * Freezing and thawing values + , module Data.Mutable + + -- * Building messages in pure code + , PureBuilder + , createPure ) where import Control.Monad.Catch (MonadThrow) @@ -56,8 +66,10 @@ import qualified Data.ByteString.Builder as BB import Data.Capnp.TraversalLimit +import Data.Mutable -import Data.Capnp.IO (getValue, hGetValue) +import Data.Capnp.IO (getValue, hGetValue) +import Internal.BuildPure (PureBuilder, createPure) import qualified Codec.Capnp as Codec import qualified Data.Capnp.Basics as Basics diff --git a/lib/Data/Capnp/Address.hs b/lib/Data/Capnp/Address.hs --- a/lib/Data/Capnp/Address.hs +++ b/lib/Data/Capnp/Address.hs @@ -1,6 +1,11 @@ {-| Module: Data.Capnp.Address Description: Utilities for manipulating addresses within capnproto messages. + +This module provides facilities for manipulating raw addresses within +Cap'N Proto messages. + +This is a low level module that very few users will need to use directly. -} {-# LANGUAGE RecordWildCards #-} module Data.Capnp.Address @@ -32,7 +37,9 @@ -- | An address, i.e. a location that a pointer may point at. data Addr + -- | The address of some data in the message. = WordAddr !WordAddr + -- | The "address" of a capability. | CapAddr !CapAddr deriving(Show, Eq) diff --git a/lib/Data/Capnp/Basics.hs b/lib/Data/Capnp/Basics.hs --- a/lib/Data/Capnp/Basics.hs +++ b/lib/Data/Capnp/Basics.hs @@ -4,9 +4,9 @@ In particular -* Text and Data (which are primitive types in the schema language, - but are both the same as List(uint8) on the wire). -* List of types other than those in Data.Capnp.Untyped. +* 'Text' and 'Data' (which are primitive types in the schema language, + but are both the same as @List(UInt8)@ on the wire). +* Lists of types other than those in "Data.Capnp.Untyped". Whereas 'U.ListOf' only deals with low-level encodings of lists, this module's 'List' type can represent typed lists. -} @@ -59,7 +59,7 @@ -- bytes. newtype Data msg = Data (U.ListOf msg Word8) --- | @'newData' msg len@ Allocates a new data blob of length @len@ bytes +-- | @'newData' msg len@ allocates a new data blob of length @len@ bytes -- inside the message. newData :: M.WriteCtx m s => M.MutMsg s -> Int -> m (Data (M.MutMsg s)) newData msg len = Data <$> U.allocList8 msg len diff --git a/lib/Data/Capnp/Bits.hs b/lib/Data/Capnp/Bits.hs --- a/lib/Data/Capnp/Bits.hs +++ b/lib/Data/Capnp/Bits.hs @@ -1,6 +1,12 @@ {-| Module: Data.Capnp.Bits Description: Utilities for bitwhacking useful for capnproto. + +This module provides misc. utilities for bitwhacking that are useful +in dealing with low-level details of the Cap'N Proto wire format. + +This is mostly an implementation detail; users are unlikely to need +to use this module directly. -} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Data.Capnp.Bits @@ -20,6 +26,9 @@ , replaceBits ) where + +-- TODO: the only reason this module is in exposed-modules is so it can be +-- seen by the test suite. We should find a way to avoid this. import Data.Bits import Data.Int diff --git a/lib/Data/Capnp/Classes.hs b/lib/Data/Capnp/Classes.hs --- a/lib/Data/Capnp/Classes.hs +++ b/lib/Data/Capnp/Classes.hs @@ -46,8 +46,15 @@ import qualified Data.Capnp.Untyped as U -- | Types that can be converted to and from a 64-bit word. +-- +-- Anything that goes in the data section of a struct will have +-- an instance of this. class IsWord a where + -- | Convert from a 64-bit words Truncates the word if the + -- type has less than 64 bits. fromWord :: Word64 -> a + + -- | Convert to a 64-bit word. toWord :: a -> Word64 -- | Types which may be stored as an element of a capnproto list. @@ -92,12 +99,12 @@ -- | Extract the value from the message. decerialize :: U.ReadCtx m M.ConstMsg => Cerial M.ConstMsg a -> m a --- | Types which may be mashaled into a pre-allocated object in a message. +-- | Types which may be marshaled into a pre-allocated object in a message. class Decerialize a => Marshal a where -- | Marshal a value into the pre-allocated object inside the message. -- - -- Note that caller must arrange for the object to of the correct size. + -- Note that caller must arrange for the object to be of the correct size. -- This is is not necessarily guaranteed; for example, list types must -- coordinate the length of the list. marshalInto :: U.RWCtx m s => Cerial (M.MutMsg s) a -> a -> m () diff --git a/lib/Data/Capnp/GenHelpers.hs b/lib/Data/Capnp/GenHelpers.hs --- a/lib/Data/Capnp/GenHelpers.hs +++ b/lib/Data/Capnp/GenHelpers.hs @@ -5,7 +5,7 @@ This module provides various helpers used by generated code; developers are not expected to invoke them directly. -These helpers are used by the low-level api. 'Data.Capnp.GenHelpers.Pure' +These helpers are used by the low-level api. "Data.Capnp.GenHelpers.Pure" defines helpers used by high-level api. -} {-# LANGUAGE FlexibleContexts #-} diff --git a/lib/Data/Capnp/GenHelpers/Pure.hs b/lib/Data/Capnp/GenHelpers/Pure.hs --- a/lib/Data/Capnp/GenHelpers/Pure.hs +++ b/lib/Data/Capnp/GenHelpers/Pure.hs @@ -9,7 +9,7 @@ This module provides various helpers used by generated code; developers are not expected to invoke them directly. -These helpers are only used by the high-level api. 'Data.Capnp.GenHelpers' +These helpers are only used by the high-level api. "Data.Capnp.GenHelpers" defines helpers used by the low-level api. -} module Data.Capnp.GenHelpers.Pure where @@ -24,7 +24,7 @@ import qualified Data.Capnp.Message as M import qualified Data.Capnp.Untyped as U --- | A valid implementation for 'Data.Default' for any type that meets +-- | A valid implementation for 'Data.Default.Default' for any type that meets -- the given constraints. defaultStruct :: (C.Decerialize a, C.FromStruct M.ConstMsg (C.Cerial M.ConstMsg a)) => a defaultStruct = diff --git a/lib/Data/Capnp/IO.hs b/lib/Data/Capnp/IO.hs --- a/lib/Data/Capnp/IO.hs +++ b/lib/Data/Capnp/IO.hs @@ -1,6 +1,9 @@ {- | Module: Data.Capnp.IO Description: Utilities for reading and writing values to handles. + +This module provides utilities for reading and writing values to and +from file 'Handle's. -} {-# LANGUAGE FlexibleContexts #-} module Data.Capnp.IO @@ -17,12 +20,16 @@ import Data.Capnp.Classes (Cerialize(..), Decerialize(..), FromStruct(..), ToStruct(..)) import Data.Capnp.TraversalLimit (evalLimitT) +import Data.Mutable (Thaw(..)) import qualified Data.Capnp.Message as M -- | @'hGetValue' limit handle@ reads a message from @handle@, returning its root object. -- @limit@ is used as both a cap on the size of a message which may be read and, for types -- in the high-level API, the traversal limit when decoding the message. +-- +-- It may throw a 'Data.Capnp.Errors.Error' if there is a problem decoding the message, +-- or an 'IOError' raised by the underlying IO libraries. hGetValue :: FromStruct M.ConstMsg a => Handle -> Int -> IO a hGetValue handle limit = do msg <- M.hGetMsg handle limit @@ -33,14 +40,15 @@ getValue = hGetValue stdin -- | @'hPutValue' handle value@ writes @value@ to handle, as the root object of --- a message. +-- a message. If it throws an exception, it will be an 'IOError' raised by the +-- underlying IO libraries. hPutValue :: (Cerialize RealWorld a, ToStruct (M.MutMsg RealWorld) (Cerial (M.MutMsg RealWorld) a)) => Handle -> a -> IO () hPutValue handle value = do msg <- M.newMessage root <- evalLimitT maxBound $ cerialize msg value setRoot root - constMsg <- M.freeze msg + constMsg <- freeze msg M.hPutMsg handle constMsg -- | 'putValue' is equivalent to @'hPutValue' 'stdin'@ diff --git a/lib/Data/Capnp/Message.hs b/lib/Data/Capnp/Message.hs --- a/lib/Data/Capnp/Message.hs +++ b/lib/Data/Capnp/Message.hs @@ -8,33 +8,50 @@ Module: Data.Capnp.Message Description: Cap'N Proto messages +This module provides support for working directly with Cap'N Proto messages. -} -module Data.Capnp.Message - ( Message(..) - , ConstMsg(..) - , MutMsg(..) - , WriteCtx(..) - , Mutable(..) - , getSegment - , getWord - , setSegment - , setWord +module Data.Capnp.Message ( + -- * Reading and writing messages + hPutMsg + , hGetMsg + , putMsg + , getMsg + + -- * Limits on message size + , maxSegmentSize + , maxSegments + + -- * Converting between messages and 'ByteString's , encode , decode + + -- * Message type class + , Message(..) + + -- * Immutable messages + , empty + , ConstMsg + + -- * Reading data from messages + , getSegment + , getWord + + -- * Mutable Messages + , MutMsg + , newMessage + + -- ** Allocating space in messages , alloc , allocInSeg - , newMessage , newSegment - , empty - , maxSegmentSize - , maxSegments - , hPutMsg - , hGetMsg - , putMsg - , getMsg - ) - where + -- ** Modifying messages + , setWord + , setSegment + + , WriteCtx(..) + ) where + import Prelude hiding (read) import Data.Bits (shiftL) @@ -64,6 +81,7 @@ import Data.Capnp.Bits (WordCount(..), hi, lo) import Data.Capnp.Errors (Error(..)) import Data.Capnp.TraversalLimit (LimitT, MonadLimit(invoice), evalLimitT) +import Data.Mutable (Mutable(..)) import Internal.Util (checkIndex) @@ -101,22 +119,6 @@ -- | Convert a segment to a byte string. toByteString :: Segment msg -> m ByteString --- | The 'Mutable' type class relates mutable and immutable versions of a type. --- The instance is defined on the mutable variant; @'Frozen' a@ is the immutable --- version of a mutable type @a@. -class Mutable a where - -- | The state token for a mutable value. - type Scope a - - -- | The immutable version of @a@. - type Frozen a - - -- | Convert an immutable value to a mutable one. - thaw :: (MonadThrow m, PrimMonad m, PrimState m ~ Scope a) => Frozen a -> m a - - -- | Convert a mutable value to an immutable one. - freeze :: (MonadThrow m, PrimMonad m, PrimState m ~ Scope a) => a -> m (Frozen a) - -- | @'getSegment' message index@ fetches the given segment in the message. -- It throws a @BoundsError@ if the address is out of bounds. getSegment :: (MonadThrow m, Message m msg) => msg -> Int -> m (Segment msg) @@ -155,13 +157,11 @@ -- the underlying bytes are not copied. newtype ConstMsg = ConstMsg (V.Vector (Segment ConstMsg)) -instance MonadThrow m => Message m ConstMsg where +instance Monad m => Message m ConstMsg where newtype Segment ConstMsg = ConstSegment { constSegToVec :: SV.Vector Word64 } numSegs (ConstMsg vec) = pure $ V.length vec - internalGetSeg (ConstMsg vec) i = do - checkIndex i (V.length vec) - vec `V.indexM` i + internalGetSeg (ConstMsg vec) i = vec `V.indexM` i numWords (ConstSegment vec) = pure $ SV.length vec slice start len (ConstSegment vec) = pure $ ConstSegment (SV.slice start len vec) @@ -195,9 +195,12 @@ decodeSeg seg = do len <- numWords seg flip evalStateT (Nothing, 0) $ evalLimitT len $ - -- Note: we use the quota to avoid needing to do bounds checking here; - -- since readMessage invoices the quota before reading, we can rely on it - -- not to read past the end of the blob. + -- Note: we use the traversal limit to avoid needing to do bounds checking + -- here; since readMessage invoices the limit before reading, we can rely + -- on it not to read past the end of the blob. + -- + -- TODO: while this works, it means that we throw 'TraversalLimitError' + -- on failure, which makes for a confusing API. readMessage read32 readSegment where read32 = do @@ -215,7 +218,7 @@ put (cur, idx + len) lift $ lift $ slice idx len seg --- | @readMessage read32 readSegment@ reads in a message using the +-- | @'readMessage' read32 readSegment@ reads in a message using the -- monadic context, which should manage the current read position, -- into a message. read32 should read a 32-bit little-endian integer, -- and @readSegment n@ should read a blob of @n@ 64-bit words. @@ -232,7 +235,7 @@ V.mapM_ (invoice . fromIntegral) segSizes ConstMsg <$> V.mapM (readSegment . fromIntegral) segSizes --- | @writeMesage write32 writeSegment@ writes out the message. @write32@ +-- | @'writeMesage' write32 writeSegment@ writes out the message. @write32@ -- should write a 32-bit word in little-endian format to the output stream. -- @writeSegment@ should write a blob. writeMessage :: MonadThrow m => ConstMsg -> (Word32 -> m ()) -> (Segment ConstMsg -> m ()) -> m () @@ -244,7 +247,8 @@ V.forM_ segs writeSegment --- | @'hPutMsg' handle msg@ writes @msg@ to @handle@. +-- | @'hPutMsg' handle msg@ writes @msg@ to @handle@. If there is an exception, +-- it will be an 'IOError' raised by the underlying IO libraries. hPutMsg :: Handle -> ConstMsg -> IO () hPutMsg handle msg = encode msg >>= BB.hPutBuilder handle @@ -270,7 +274,7 @@ getMsg :: Int -> IO ConstMsg getMsg = hGetMsg stdin --- | A 'MutMsg' is a mutable capnproto message. The type parameter 's' is the +-- | A 'MutMsg' is a mutable capnproto message. The type parameter @s@ is the -- state token for the instance of 'PrimMonad' in which the message may be -- modified. -- @@ -288,7 +292,7 @@ -- | 'WriteCtx' is the context needed for most write operations. type WriteCtx m s = (PrimMonad m, s ~ PrimState m, MonadThrow m) -instance WriteCtx m s => Message m (MutMsg s) where +instance (PrimMonad m, s ~ PrimState m) => Message m (MutMsg s) where data Segment (MutMsg s) = MutSegment { mutSegVec :: !(SMV.MVector s Word64) -- ^ The underlying vector of words storing segment's data. @@ -397,32 +401,41 @@ newMessage :: WriteCtx m s => m (MutMsg s) newMessage = thaw empty -instance Mutable (Segment (MutMsg s)) where - type Scope (Segment (MutMsg s)) = s - type Frozen (Segment (MutMsg s)) = Segment ConstMsg +instance Thaw (Segment ConstMsg) where + type Mutable s (Segment ConstMsg) = Segment (MutMsg s) - thaw (ConstSegment vec) = do - mvec <- SV.thaw vec - pure MutSegment - { mutSegVec = mvec - , mutSegLen = SV.length vec - } - freeze seg@MutSegment{mutSegLen} = do - -- Slice before freezing, so we don't waste time copying - -- the unallocated portion: - MutSegment{mutSegVec} <- slice 0 mutSegLen seg - ConstSegment <$> SV.freeze mutSegVec + thaw = thawSeg SV.thaw + unsafeThaw = thawSeg SV.unsafeThaw + freeze = freezeSeg SV.freeze + unsafeFreeze = freezeSeg SV.unsafeFreeze +-- Helpers for @Segment ConstMsg@'s Thaw instance. +thawSeg thaw (ConstSegment vec) = do + mvec <- thaw vec + pure MutSegment + { mutSegVec = mvec + , mutSegLen = SV.length vec + } +freezeSeg freeze seg@MutSegment{mutSegLen} = do + -- Slice before freezing, so we don't waste time copying + -- the unallocated portion: + MutSegment{mutSegVec} <- slice 0 mutSegLen seg + ConstSegment <$> freeze mutSegVec -instance Mutable (MutMsg s) where - type Scope (MutMsg s) = s - type Frozen (MutMsg s) = ConstMsg +instance Thaw ConstMsg where + type Mutable s ConstMsg = MutMsg s - thaw (ConstMsg vec) = do - segments <- V.mapM thaw vec >>= V.thaw - MutMsg - <$> newMutVar segments - <*> newMutVar (MV.length segments) - freeze msg@MutMsg{mutMsgLen} = do + thaw = thawMsg thaw + unsafeThaw = thawMsg unsafeThaw + freeze = freezeMsg freeze + unsafeFreeze = freezeMsg unsafeFreeze + +-- Helpers for ConstMsg's Thaw instance. +thawMsg thaw (ConstMsg vec) = do + segments <- V.mapM thaw vec >>= V.unsafeThaw + MutMsg + <$> newMutVar segments + <*> newMutVar (MV.length segments) +freezeMsg freeze msg@MutMsg{mutMsgLen} = do len <- readMutVar mutMsgLen - ConstMsg <$> V.generateM len (getSegment msg >=> freeze) + ConstMsg <$> V.generateM len (internalGetSeg msg >=> freeze) diff --git a/lib/Data/Capnp/Pointer.hs b/lib/Data/Capnp/Pointer.hs --- a/lib/Data/Capnp/Pointer.hs +++ b/lib/Data/Capnp/Pointer.hs @@ -3,6 +3,7 @@ Description: Support for parsing/serializing capnproto pointers This module provides support for parsing and serializing capnproto pointers. +This is a low-level module; most users will not need to call it directly. -} module Data.Capnp.Pointer ( Ptr(..) diff --git a/lib/Data/Capnp/Pure.hs b/lib/Data/Capnp/Pure.hs --- a/lib/Data/Capnp/Pure.hs +++ b/lib/Data/Capnp/Pure.hs @@ -1,6 +1,12 @@ {- | Module: Data.Capnp.Pure Description: The most commonly used functionality from the high-level API. + +This module re-exports the most commonly used functionality from the high-level +API. See also "Data.Capnp", which does the same for the low-level API. + +Users getting acquainted with the library are *strongly* encouraged to read the +"Data.Capnp.Tutorial" module before anything else. -} module Data.Capnp.Pure ( diff --git a/lib/Data/Capnp/Tutorial.hs b/lib/Data/Capnp/Tutorial.hs --- a/lib/Data/Capnp/Tutorial.hs +++ b/lib/Data/Capnp/Tutorial.hs @@ -42,8 +42,6 @@ import Data.Capnp.Classes (FromStruct) -import qualified Data.Capnp.TraversalLimit - {- $overview The API is roughly divided into two parts: a low level API and a high @@ -128,8 +126,8 @@ * Capnp\/ById\/Xcd6db6afb4a0cf5c.hs The modules under @ById@ are an implementation detail. -@Capnp/Addressbook.hs@ is generated code for use with the low level API. -@Capnp/Addressbook/Pure.hs@ is generated code for use with the high +@Capnp\/Addressbook.hs@ is generated code for use with the low level API. +@Capnp\/Addressbook\/Pure.hs@ is generated code for use with the high level API. It will export the following data declarations (cleaned up for readability). @@ -178,7 +176,7 @@ * 'Show' * 'Read' * 'Eq' -* 'Generic' from 'GHC.Generics' +* 'Generic' from "GHC.Generics" * 'Default' from the @data-default@ package. * A number of type classes defined by the @capnp@ package. * Capnproto enums additionally implement the 'Enum' type class. @@ -264,13 +262,13 @@ 'defaultLimit' is a default value for the traversal limit, which acts to prevent denial of service vulnerabilities; See the documentation in -@Data.Capnp.TraversalLimit@ for more information. 'getValue' uses this +"Data.Capnp.TraversalLimit" for more information. 'getValue' uses this argument both to catch values that would cause excessive resource usage, and to simply limit the overall size of the incoming message. The default is approximately 64 MiB. If an error occurs, an exception will be thrown of type 'Error' from the -`Data.Capnp.Errors` module. +"Data.Capnp.Errors" module. -} @@ -285,7 +283,7 @@ * Lists map to 'Vector's from the Haskell vector package. Note that right now we use boxed vectors for everything; at some point this will likely change for performance reasons. Using the functions from - 'Data.Vector.Generic' will probably decrease the amount of code you + "Data.Vector.Generic" will probably decrease the amount of code you will need to modify when upgrading. * @Text@ maps to (strict) 'T.Text' from the Haskell `text` package. * @Data@ maps to (strict) 'BS.ByteString's @@ -339,7 +337,7 @@ Because of this, access to the message must occur inside of a monad which is an instance of `MonadThrow` from the exceptions package, and -`MonadLimit`, which is defined in `Data.Capnp.TraversalLimit`. We define +`MonadLimit`, which is defined in "Data.Capnp.TraversalLimit". We define a monad transformer `LimitT` for the latter. -} @@ -412,27 +410,34 @@ Writing messages using the low-level API has a similarly imperative feel. The below constructs the same message as in our high-level example above: -> {-# LANGUAGE DuplicateRecordFields #-} > import Capnp.Addressbook > -> import Capnp.Addressbook.Pure (Person'PhoneNumber(..)) -> > import Data.Capnp -> (defaultLimit, evalLimitT, freeze, index, newMessage, newRoot, putMsg) -> import Data.Capnp.Pure (cerialize, def) +> ( MutMsg +> , PureBuilder +> , createPure +> , defaultLimit +> , index +> , newMessage +> , newRoot +> , putMsg +> ) +> import Data.Capnp.Pure (cerialize) > -> import qualified Data.Text as T -> import qualified Data.Vector as V +> import qualified Data.Text as T > -> main = evalLimitT defaultLimit buildMsg >>= putMsg +> main = +> let Right msg = createPure defaultLimit buildMsg +> in putMsg msg > +> buildMsg :: PureBuilder s (MutMsg s) > buildMsg = do > -- newMessage allocates a new, initially empty, mutable message: > msg <- newMessage > > -- newRoot allocates a new struct as the root object of the message. > -- In this case the type of the struct can be inferred from our later -> -- use of Addressbook's accessors: +> -- use of AddressBook's accessors: > addressbook <- newRoot msg > > -- new_* accessors allocate a new value of the correct type for a @@ -487,5 +492,5 @@ > employment <- get_Person'employment bob > set_Person'employment'selfEmployed employment > -> freeze msg +> pure msg -} diff --git a/lib/Data/Capnp/Untyped.hs b/lib/Data/Capnp/Untyped.hs --- a/lib/Data/Capnp/Untyped.hs +++ b/lib/Data/Capnp/Untyped.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} @@ -16,7 +17,7 @@ lists, but are not schema aware. Each of the data types exported by this module is parametrized over a Message -type (see 'Data.Capnp.Message'), used as the underlying storage. +type (see "Data.Capnp.Message"), used as the underlying storage. -} module Data.Capnp.Untyped ( Ptr(..), List(..), Struct, ListOf @@ -68,6 +69,7 @@ ) import Data.Capnp.Pointer (ElementSize(..)) import Data.Capnp.TraversalLimit (MonadLimit(invoice)) +import Data.Mutable (Thaw(..)) import qualified Data.Capnp.Errors as E import qualified Data.Capnp.Message as M @@ -132,116 +134,215 @@ !Word16 -- Data section size. !Word16 -- Pointer section size. -instance M.Mutable msg => M.Mutable (Ptr msg) where - type Scope (Ptr msg) = M.Scope msg - type Frozen (Ptr msg) = Ptr (M.Frozen msg) - thaw (PtrCap cmsg n) = do - mmsg <- M.thaw cmsg - pure $ PtrCap mmsg n - thaw (PtrList l) = PtrList <$> M.thaw l - thaw (PtrStruct s) = PtrStruct <$> M.thaw s - freeze (PtrCap mmsg n) = do - cmsg <- M.freeze mmsg - pure $ PtrCap cmsg n - freeze (PtrList l) = PtrList <$> M.freeze l - freeze (PtrStruct s) = PtrStruct <$> M.freeze s -instance M.Mutable msg => M.Mutable (List msg) where - type Scope (List msg) = M.Scope msg - type Frozen (List msg) = List (M.Frozen msg) - thaw (List0 l) = List0 <$> M.thaw l - thaw (List1 l) = List1 <$> M.thaw l - thaw (List8 l) = List8 <$> M.thaw l - thaw (List16 l) = List16 <$> M.thaw l - thaw (List32 l) = List32 <$> M.thaw l - thaw (List64 l) = List64 <$> M.thaw l - thaw (ListPtr l) = ListPtr <$> M.thaw l - thaw (ListStruct l) = ListStruct <$> M.thaw l - freeze (List0 l) = List0 <$> M.freeze l - freeze (List1 l) = List1 <$> M.freeze l - freeze (List8 l) = List8 <$> M.freeze l - freeze (List16 l) = List16 <$> M.freeze l - freeze (List32 l) = List32 <$> M.freeze l - freeze (List64 l) = List64 <$> M.freeze l - freeze (ListPtr l) = ListPtr <$> M.freeze l - freeze (ListStruct l) = ListStruct <$> M.freeze l -instance M.Mutable msg => M.Mutable (NormalList msg) where - type Scope (NormalList msg) = M.Scope msg - type Frozen (NormalList msg) = NormalList (M.Frozen msg) - thaw NormalList{..} = do - mmsg <- M.thaw nMsg - pure NormalList { nMsg = mmsg, .. } - freeze NormalList{..} = do - cmsg <- M.freeze nMsg - pure NormalList { nMsg = cmsg, .. } -instance M.Mutable msg => M.Mutable (ListOf msg ()) where - type Scope (ListOf msg ()) = M.Scope msg - type Frozen (ListOf msg ()) = ListOf (M.Frozen msg) () - thaw (ListOfVoid cmsg n) = do - mmsg <- M.thaw cmsg - pure $ ListOfVoid mmsg n - freeze (ListOfVoid mmsg n) = do - cmsg <- M.freeze mmsg - pure $ ListOfVoid cmsg n +-- | 'TraverseMsg' is basically 'Traversable' from the prelude, but +-- the intent is that rather than conceptually being a "container", +-- the instance is a value backed by a message, and the point of the +-- type class is to be able to apply transformations to the underlying +-- message. +-- +-- We don't just use 'Traversable' for this because while algebraically +-- it makes sense, it would be very surprising to users to e.g. +-- have the 'Traversable' instance for 'List' not traverse over the +-- *elements* of the list. +-- +-- We also don't export this; it is mainly an implementation detail for +-- the 'Thaw' instances for these data types, which all just that/freeze +-- the underlying message. +class TraverseMsg f where + tMsg :: Applicative m => (msgA -> m msgB) -> f msgA -> m (f msgB) --- Annoyingly, we can't just have an instance @Mutable (ListOf msg a)@ --- because that would require that the implementation to be valid for e.g. --- @Mutable m (ListOf mmsg (Struct mmsg)) (ListOf cmsg (Struct mmsg))@ (note that the type --- parameter for 'Struct' does not change). So, instead, we define a separate instance for --- each possible parameter type. +instance TraverseMsg Ptr where + tMsg f = \case + PtrCap msgA n -> + PtrCap <$> f msgA <*> pure n + PtrList l -> + PtrList <$> tMsg f l + PtrStruct s -> + PtrStruct <$> tMsg f s + +instance TraverseMsg Struct where + tMsg f (Struct msg addr dataSz ptrSz) = Struct + <$> f msg + <*> pure addr + <*> pure dataSz + <*> pure ptrSz + +instance TraverseMsg List where + tMsg f = \case + List0 l -> List0 . unflip <$> tMsg f (FlipList l) + List1 l -> List1 . unflip <$> tMsg f (FlipList l) + List8 l -> List8 . unflip <$> tMsg f (FlipList l) + List16 l -> List16 . unflip <$> tMsg f (FlipList l) + List32 l -> List32 . unflip <$> tMsg f (FlipList l) + List64 l -> List64 . unflip <$> tMsg f (FlipList l) + ListPtr l -> ListPtr . unflipP <$> tMsg f (FlipListP l) + ListStruct l -> ListStruct . unflipS <$> tMsg f (FlipListS l) + +instance TraverseMsg NormalList where + tMsg f NormalList{..} = do + msg <- f nMsg + pure NormalList { nMsg = msg, .. } + +------------------------------------------------------------------------------- +-- newtype wrappers for the purpose of implementing 'TraverseMsg'; these adjust +-- the shape of 'ListOf' so that we can define an instance. We need a couple +-- different wrappers depending on the shape of the element type. +------------------------------------------------------------------------------- + +-- 'FlipList' wraps a @ListOf msg a@ where 'a' is of kind @*@. +newtype FlipList a msg = FlipList { unflip :: ListOf msg a } + +-- 'FlipListS' wraps a @ListOf msg (Struct msg)@. We can't use 'FlipList' for +-- our instances, because we need both instances of the 'msg' parameter to stay +-- equal. +newtype FlipListS msg = FlipListS { unflipS :: ListOf msg (Struct msg) } + +-- 'FlipListP' wraps a @ListOf msg (Maybe (Ptr msg))@. Pointers can't use +-- 'FlipList' for the same reason as structs. +newtype FlipListP msg = FlipListP { unflipP :: ListOf msg (Maybe (Ptr msg)) } + +------------------------------------------------------------------------------- +-- 'TraverseMsg' instances for 'FlipList' +------------------------------------------------------------------------------- + +instance TraverseMsg (FlipList ()) where + tMsg f (FlipList (ListOfVoid msg len)) = FlipList <$> (ListOfVoid <$> f msg <*> pure len) + +instance TraverseMsg (FlipList Bool) where + tMsg f (FlipList (ListOfBool nlist)) = FlipList . ListOfBool <$> tMsg f nlist + +instance TraverseMsg (FlipList Word8) where + tMsg f (FlipList (ListOfWord8 nlist)) = FlipList . ListOfWord8 <$> tMsg f nlist + +instance TraverseMsg (FlipList Word16) where + tMsg f (FlipList (ListOfWord16 nlist)) = FlipList . ListOfWord16 <$> tMsg f nlist + +instance TraverseMsg (FlipList Word32) where + tMsg f (FlipList (ListOfWord32 nlist)) = FlipList . ListOfWord32 <$> tMsg f nlist + +instance TraverseMsg (FlipList Word64) where + tMsg f (FlipList (ListOfWord64 nlist)) = FlipList . ListOfWord64 <$> tMsg f nlist + +------------------------------------------------------------------------------- +-- 'TraverseMsg' instances for struct and pointer lists. +------------------------------------------------------------------------------- + +instance TraverseMsg FlipListP where + tMsg f (FlipListP (ListOfPtr nlist)) = FlipListP . ListOfPtr <$> tMsg f nlist + +instance TraverseMsg FlipListS where + tMsg f (FlipListS (ListOfStruct tag size)) = + FlipListS <$> (ListOfStruct <$> tMsg f tag <*> pure size) + +-- helpers for applying tMsg to a @ListOf@. +tFlip f list = unflip <$> tMsg f (FlipList list) +tFlipS f list = unflipS <$> tMsg f (FlipListS list) +tFlipP f list = unflipP <$> tMsg f (FlipListP list) + +------------------------------------------------------------------------------- +-- Boilerplate 'Thaw' instances. -- --- TODO: generate this automatically. -instance M.Mutable msg => M.Mutable (ListOf msg Bool) where - type Scope (ListOf msg Bool) = M.Scope msg - type Frozen (ListOf msg Bool) = ListOf (M.Frozen msg) Bool - thaw (ListOfBool msg) = ListOfBool <$> M.thaw msg - freeze (ListOfBool msg) = ListOfBool <$> M.freeze msg -instance M.Mutable msg => M.Mutable (ListOf msg Word8) where - type Scope (ListOf msg Word8) = M.Scope msg - type Frozen (ListOf msg Word8) = ListOf (M.Frozen msg) Word8 - thaw (ListOfWord8 msg) = ListOfWord8 <$> M.thaw msg - freeze (ListOfWord8 msg) = ListOfWord8 <$> M.freeze msg -instance M.Mutable msg => M.Mutable (ListOf msg Word16) where - type Scope (ListOf msg Word16) = M.Scope msg - type Frozen (ListOf msg Word16) = ListOf (M.Frozen msg) Word16 - thaw (ListOfWord16 msg) = ListOfWord16 <$> M.thaw msg - freeze (ListOfWord16 msg) = ListOfWord16 <$> M.freeze msg -instance M.Mutable msg => M.Mutable (ListOf msg Word32) where - type Scope (ListOf msg Word32) = M.Scope msg - type Frozen (ListOf msg Word32) = ListOf (M.Frozen msg) Word32 - thaw (ListOfWord32 msg) = ListOfWord32 <$> M.thaw msg - freeze (ListOfWord32 msg) = ListOfWord32 <$> M.freeze msg -instance M.Mutable msg => M.Mutable (ListOf msg Word64) where - type Scope (ListOf msg Word64) = M.Scope msg - type Frozen (ListOf msg Word64) = ListOf (M.Frozen msg) Word64 - thaw (ListOfWord64 msg) = ListOfWord64 <$> M.thaw msg - freeze (ListOfWord64 msg) = ListOfWord64 <$> M.freeze msg -instance M.Mutable msg => M.Mutable (ListOf msg (Struct msg)) where - type Scope (ListOf msg (Struct msg)) = M.Scope msg - type Frozen (ListOf msg (Struct msg)) = ListOf (M.Frozen msg) (Struct (M.Frozen msg)) - thaw (ListOfStruct ctag size) = do - mtag <- M.thaw ctag - pure $ ListOfStruct mtag size - freeze (ListOfStruct mtag size) = do - ctag <- M.freeze mtag - pure $ ListOfStruct ctag size +-- These all just call the underlying methods on the message, using 'TraverseMsg'. +------------------------------------------------------------------------------- -instance M.Mutable msg => M.Mutable (ListOf msg (Maybe (Ptr msg))) where - type Scope (ListOf msg (Maybe (Ptr msg))) = M.Scope msg - type Frozen (ListOf msg (Maybe (Ptr msg))) = ListOf (M.Frozen msg) (Maybe (Ptr (M.Frozen msg))) +instance Thaw msg => Thaw (Ptr msg) where + type Mutable s (Ptr msg) = Ptr (Mutable s msg) - thaw (ListOfPtr msg) = ListOfPtr <$> M.thaw msg - freeze (ListOfPtr msg) = ListOfPtr <$> M.freeze msg + thaw = tMsg thaw + freeze = tMsg freeze + unsafeThaw = tMsg unsafeThaw + unsafeFreeze = tMsg unsafeFreeze -instance M.Mutable msg => M.Mutable (Struct msg) where - type Scope (Struct msg) = M.Scope msg - type Frozen (Struct msg) = Struct (M.Frozen msg) +instance Thaw msg => Thaw (List msg) where + type Mutable s (List msg) = List (Mutable s msg) - thaw (Struct cmsg addr dataSz ptrSz) = do - mmsg <- M.thaw cmsg - pure $ Struct mmsg addr dataSz ptrSz - freeze (Struct mmsg addr dataSz ptrSz) = do - cmsg <- M.freeze mmsg - pure $ Struct cmsg addr dataSz ptrSz + thaw = tMsg thaw + freeze = tMsg freeze + unsafeThaw = tMsg unsafeThaw + unsafeFreeze = tMsg unsafeFreeze + +instance Thaw msg => Thaw (NormalList msg) where + type Mutable s (NormalList msg) = NormalList (Mutable s msg) + + thaw = tMsg thaw + freeze = tMsg freeze + unsafeThaw = tMsg unsafeThaw + unsafeFreeze = tMsg unsafeFreeze + +instance Thaw msg => Thaw (ListOf msg ()) where + type Mutable s (ListOf msg ()) = ListOf (Mutable s msg) () + + thaw = tFlip thaw + freeze = tFlip freeze + unsafeThaw = tFlip unsafeThaw + unsafeFreeze = tFlip unsafeFreeze + +instance Thaw msg => Thaw (ListOf msg Bool) where + type Mutable s (ListOf msg Bool) = ListOf (Mutable s msg) Bool + + thaw = tFlip thaw + freeze = tFlip freeze + unsafeThaw = tFlip unsafeThaw + unsafeFreeze = tFlip unsafeFreeze + +instance Thaw msg => Thaw (ListOf msg Word8) where + type Mutable s (ListOf msg Word8) = ListOf (Mutable s msg) Word8 + + thaw = tFlip thaw + freeze = tFlip freeze + unsafeThaw = tFlip unsafeThaw + unsafeFreeze = tFlip unsafeFreeze + +instance Thaw msg => Thaw (ListOf msg Word16) where + type Mutable s (ListOf msg Word16) = ListOf (Mutable s msg) Word16 + + thaw = tFlip thaw + freeze = tFlip freeze + unsafeThaw = tFlip unsafeThaw + unsafeFreeze = tFlip unsafeFreeze + +instance Thaw msg => Thaw (ListOf msg Word32) where + type Mutable s (ListOf msg Word32) = ListOf (Mutable s msg) Word32 + + thaw = tFlip thaw + freeze = tFlip freeze + unsafeThaw = tFlip unsafeThaw + unsafeFreeze = tFlip unsafeFreeze + +instance Thaw msg => Thaw (ListOf msg Word64) where + type Mutable s (ListOf msg Word64) = ListOf (Mutable s msg) Word64 + + thaw = tFlip thaw + freeze = tFlip freeze + unsafeThaw = tFlip unsafeThaw + unsafeFreeze = tFlip unsafeFreeze + +instance Thaw msg => Thaw (ListOf msg (Struct msg)) where + type Mutable s (ListOf msg (Struct msg)) = ListOf (Mutable s msg) (Struct (Mutable s msg)) + + thaw = tFlipS thaw + freeze = tFlipS freeze + unsafeThaw = tFlipS unsafeThaw + unsafeFreeze = tFlipS unsafeFreeze + +instance Thaw msg => Thaw (ListOf msg (Maybe (Ptr msg))) where + type Mutable s (ListOf msg (Maybe (Ptr msg))) = + ListOf (Mutable s msg) (Maybe (Ptr (Mutable s msg))) + + thaw = tFlipP thaw + freeze = tFlipP freeze + unsafeThaw = tFlipP unsafeThaw + unsafeFreeze = tFlipP unsafeFreeze + +instance Thaw msg => Thaw (Struct msg) where + type Mutable s (Struct msg) = Struct (Mutable s msg) + + thaw = tMsg thaw + freeze = tMsg freeze + unsafeThaw = tMsg unsafeThaw + unsafeFreeze = tMsg unsafeFreeze + +------------------------------------------------------------------------------- -- | Types @a@ whose storage is owned by a message with blob type @b@. class HasMessage a msg where diff --git a/lib/Data/Capnp/Untyped/Pure.hs b/lib/Data/Capnp/Untyped/Pure.hs --- a/lib/Data/Capnp/Untyped/Pure.hs +++ b/lib/Data/Capnp/Untyped/Pure.hs @@ -7,13 +7,17 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-| This module provides an idiomatic Haskell interface for untyped capnp - data, based on algebraic datatypes. It forgoes some of the benefits of - the capnp wire format in favor of a more convienient API. +{-| +Module: Data.Capnp.Untyped.Pure +Description: high-level API for working with untyped Cap'N Proto values. - In addition to the algebraic data types themselves, this module also - provides support for converting from the lower-level types in - Data.Capnp.Untyped. +This module provides an idiomatic Haskell interface for untyped capnp +data, based on algebraic datatypes. It forgoes some of the benefits of +the capnp wire format in favor of a more convienient API. + +In addition to the algebraic data types themselves, this module also +provides support for converting from the lower-level types in +"Data.Capnp.Untyped". -} module Data.Capnp.Untyped.Pure ( Cap(..) diff --git a/lib/Data/Mutable.hs b/lib/Data/Mutable.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Mutable.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeFamilies #-} +{- | +Module: Data.Mutable +Description: Generic support for converting between mutable and immutable values. + +There is a common pattern in Haskell libraries that work with mutable data: + +* Two types, a mutable and an immutable variant of the same structure. +* @thaw@ and @freeze@ functions to convert between these. +* Sometimes unsafe variants of @thaw@ and @freeze@, which avoid a copy but + can break referential transparency if misused. + +This module abstracts out the above pattern into a generic type family 'Thaw', +and provides some of the common higher-level tools built on top of these +primitives. + +Note that there's nothing terribly Cap'N Proto specific about this module; we +may even factor it out into a separate package at some point. +-} +module Data.Mutable where + +import Control.Monad.Primitive (PrimMonad, PrimState) +import Control.Monad.ST (ST, runST) + +-- | The 'Thaw' type class relates mutable and immutable versions of a type. +-- The instance is defined on the immutable variant; @'Mutable' s a@ is the +-- mutable version of an immutable type @a@, bound to the state token @s@. +class Thaw a where + -- | The mutable version of @a@, bound to the state token @s@. + type Mutable s a + + -- | Convert an immutable value to a mutable one. + thaw :: (PrimMonad m, PrimState m ~ s) => a -> m (Mutable s a) + + -- | Convert a mutable value to an immutable one. + freeze :: (PrimMonad m, PrimState m ~ s) => Mutable s a -> m a + + -- | Like 'thaw', except that the caller is responsible for ensuring that + -- the original value is not subsequently used; doing so may violate + -- referential transparency. + -- + -- The default implementation of this is just the same as 'thaw', but + -- typically an instance will override this with a trivial (unsafe) cast, + -- hence the obligation described above. + unsafeThaw :: (PrimMonad m, PrimState m ~ s) => a -> m (Mutable s a) + unsafeThaw = thaw + + -- | Unsafe version of 'freeze' analagous to 'unsafeThaw'. The caller must + -- ensure that the original value is not used after this call. + unsafeFreeze :: (PrimMonad m, PrimState m ~ s) => Mutable s a -> m a + unsafeFreeze = freeze + +-- | Create and freeze a mutable value, safely, without doing a full copy. +-- internally, 'create' calls unsafeFreeze, but it cannot be directly used to +-- violate referential transparency, as the value is not available to the +-- caller after freezing. +create :: Thaw a => (forall s. ST s (Mutable s a)) -> a +create st = runST (st >>= unsafeFreeze) + +-- | Like 'create', but the result is wrapped in an instance of 'Traversable'. +createT :: (Traversable f, Thaw a) => (forall s. ST s (f (Mutable s a))) -> f a +createT st = runST (st >>= traverse unsafeFreeze) diff --git a/lib/Internal/BuildPure.hs b/lib/Internal/BuildPure.hs new file mode 100644 --- /dev/null +++ b/lib/Internal/BuildPure.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeFamilies #-} +{- | +Module: Internal.BuildPure +Description: Helpers for building capnproto messages in pure code. + +This module provides some helpers for building capnproto messages and values +in pure code, using the low-level API. +-} +module Internal.BuildPure + ( PureBuilder + , createPure + ) where + +import Control.Monad.Catch (MonadThrow(..), SomeException) +import Control.Monad.Catch.Pure (CatchT, runCatchT) +import Control.Monad.Primitive (PrimMonad(..)) +import Control.Monad.ST (ST) +import Control.Monad.Trans (MonadTrans(..)) + +import Data.Capnp.TraversalLimit (LimitT, MonadLimit, evalLimitT) +import Data.Mutable (Thaw(..), createT) + +-- | 'PureBuilder' is a monad transformer stack with the instnaces needed +-- manipulate mutable messages. @'PureBuilder' s a@ is morally equivalent +-- to @'LimitT ('CatchT' ('ST' s)) a@ +newtype PureBuilder s a = PureBuilder (LimitT (PrimCatchT (ST s)) a) + deriving(Functor, Applicative, Monad, MonadThrow, MonadLimit) + +instance PrimMonad (PureBuilder s) where + type PrimState (PureBuilder s) = s + primitive = PureBuilder . primitive + +runPureBuilder :: Int -> PureBuilder s a -> ST s (Either SomeException a) +runPureBuilder limit (PureBuilder m) = runPrimCatchT $ evalLimitT limit m + +-- | @'createPure' limit m@ creates a capnproto value in pure code according +-- to @m@, then freezes it without copying. If @m@ calls 'throwM' then +-- 'createPure' returns a 'Left' with the exception. +createPure :: Thaw a => Int -> (forall s. PureBuilder s (Mutable s a)) -> Either SomeException a +createPure limit m = createT (runPureBuilder limit m) + +-- | 'PrimCatchT' is a trivial wrapper around 'CatchT', which implements +-- 'PrimMonad'. This is a temporary workaround for: +-- +-- https://github.com/ekmett/exceptions/issues/65 +-- +-- If we can get that issue fixed, we can delete this and just bump the +-- min bound on the exceptions package. +newtype PrimCatchT m a = PrimCatchT (CatchT m a) + deriving(Functor, Applicative, Monad, MonadThrow) + +runPrimCatchT :: Monad m => PrimCatchT m a -> m (Either SomeException a) +runPrimCatchT (PrimCatchT m) = runCatchT m + +instance MonadTrans PrimCatchT where + lift = PrimCatchT . lift + +instance PrimMonad m => PrimMonad (PrimCatchT m) where + type PrimState (PrimCatchT m) = PrimState m + primitive = lift . primitive diff --git a/tests/simple-tests/Tests/Module/Capnp/Capnp/Schema.hs b/tests/simple-tests/Tests/Module/Capnp/Capnp/Schema.hs --- a/tests/simple-tests/Tests/Module/Capnp/Capnp/Schema.hs +++ b/tests/simple-tests/Tests/Module/Capnp/Capnp/Schema.hs @@ -10,6 +10,7 @@ import Data.Capnp (newRoot) import Data.Capnp.TraversalLimit (LimitT, evalLimitT) +import Data.Mutable (Thaw(..)) import Tests.Util (assertionsToTest, decodeValue) import qualified Data.Capnp.Message as M @@ -44,7 +45,7 @@ testCase BuildTest{..} = do msg <- M.newMessage evalLimitT maxBound $ builder msg - constMsg <- M.freeze msg + constMsg <- freeze msg actual <- decodeValue schemaSchema typeName constMsg when (actual /= expected) $ error $ "Expected:\n\n" ++ show expected ++ "\n\n...but got:\n\n" ++ show actual diff --git a/tests/simple-tests/Tests/Module/Capnp/Capnp/Schema/Pure.hs b/tests/simple-tests/Tests/Module/Capnp/Capnp/Schema/Pure.hs --- a/tests/simple-tests/Tests/Module/Capnp/Capnp/Schema/Pure.hs +++ b/tests/simple-tests/Tests/Module/Capnp/Capnp/Schema/Pure.hs @@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} module Tests.Module.Capnp.Capnp.Schema.Pure (pureSchemaTests) where import Data.Proxy @@ -44,6 +45,7 @@ ) import Data.Capnp.Pure (hGetValue, hPutValue) import Data.Capnp.TraversalLimit (defaultLimit, evalLimitT) +import Data.Mutable (Thaw(..)) import qualified Data.Capnp.Message as M import qualified Data.Capnp.Untyped as U @@ -82,7 +84,7 @@ msg <- M.newMessage cerialOut <- cerialize msg expectedValue setRoot cerialOut - M.freeze msg + freeze msg builder <- M.encode msg actualText <- capnpDecode (LBS.toStrict $ BB.toLazyByteString builder) @@ -801,7 +803,7 @@ msg <- M.newMessage cerialOut <- cerialize msg expected setRoot cerialOut - constMsg <- M.freeze msg + constMsg :: M.ConstMsg <- freeze msg root <- U.rootPtr constMsg cerialIn <- fromStruct root decerialize cerialIn diff --git a/tests/simple-tests/Tests/Module/Data/Capnp/Untyped.hs b/tests/simple-tests/Tests/Module/Data/Capnp/Untyped.hs --- a/tests/simple-tests/Tests/Module/Data/Capnp/Untyped.hs +++ b/tests/simple-tests/Tests/Module/Data/Capnp/Untyped.hs @@ -19,6 +19,7 @@ import Tests.Util import Data.Capnp.TraversalLimit (LimitT, evalLimitT, execLimitT) +import Data.Mutable (Thaw(..)) import qualified Data.Capnp.Classes as C import qualified Data.Capnp.Message as M @@ -261,9 +262,9 @@ testCase ModTest{..} = assertionsToTest (show testIn ++ " : " ++ testType ++ " == " ++ show testOut) $ pure $ do - msg <- M.thaw =<< encodeValue schemaText testType testIn + msg <- thaw =<< encodeValue schemaText testType testIn evalLimitT 128 $ rootPtr msg >>= testMod - actualOut <- decodeValue schemaText testType =<< M.freeze msg + actualOut <- decodeValue schemaText testType =<< freeze msg assertEqual ( actualOut ++ " == " ++ testOut) actualOut testOut schemaText = [there|tests/data/aircraft.capnp|]