packages feed

codec 0.1 → 0.1.1

raw patch · 6 files changed

+309/−20 lines, 6 files

Files

− Control/Lens/Codec.hs 
@@ -1,18 +0,0 @@-{-# LANGUAGE RankNTypes #-}--module Control.Lens.Codec (lensCodec) where--import Control.Applicative-import Control.Monad.Identity-import Control.Monad.Reader-import Control.Monad.State--import Data.Codec---- | Turn a `Lens` into a `Codec` operating in a `MonadReader`/`MonadState`.-lensCodec :: (MonadReader s fr, MonadState s fw)-  => (forall f. (a -> f a) -> s -> f s) -> Codec fr fw a-lensCodec l = Codec-  { parse = liftM getConst $ asks (l Const)-  , produce = \x -> modify (runIdentity . l (const $ Identity x))-  }
+ Data/Codec/Codec.hs view
@@ -0,0 +1,115 @@+module Data.Codec.Codec+  ( -- * Codecs+    Codec'(..), Codec+  , (>-<)+    -- * Concrete codecs+  , ConcreteCodec, concrete, parseVal, produceVal+    -- * Partial codecs+    -- | Partial codecs are useful for creating codecs+    -- for types with multiple constructors. See @examples/Multi.hs@.+  , PartialCodec, cbuild, assume, covered, (<->), produceMaybe+    -- * Codec combinators+  , opt, mapCodec, mapCodecF, mapCodecM+  )+where++import Control.Applicative+import Control.Monad ((>=>))+import Control.Monad.Reader (ReaderT(..))+import Data.Codec.Field+import Data.Functor.Compose+import Data.Maybe (fromMaybe)++-- | De/serializer for the given types. Usually w ~ r, but they are separate+-- to allow for an `Applicative` instance.+data Codec' fr fw w r = Codec+  { parse :: fr r+  , produce :: w -> fw () +  }+  deriving Functor++-- | De/serializer for @a@.+type Codec fr fw a = Codec' fr fw a a++-- Build up a serializer in parallel to a deserializer.+instance (Applicative fw, Applicative fr) => Applicative (Codec' fr fw w) where+  pure x = Codec (pure x) (const $ pure ())+  Codec f fw <*> Codec x xw+    = Codec (f <*> x) (\w -> fw w *> xw w)++-- | Associate a `Field` with a `Codec` to create a `Codec` `Build`.+(>-<) :: Functor fr => Field r a x y -> Codec fr fw a -> Build r (Codec' fr fw r) x y+Field c g >-< Codec r w+  = Build (c <$> Codec r (w . g))++-- Codec combinators++-- | Given a `Codec` for @a@, make one for `Maybe` @a@ that applies its deserializer optionally+-- and does nothing when serializing `Nothing`.+opt :: (Alternative fr, Applicative fw) => Codec fr fw a -> Codec fr fw (Maybe a)+opt (Codec r w) = Codec (optional r) (maybe (pure ()) w)++-- | Turn a @`Codec` a@ into a @`Codec` b@ by providing an isomorphism.+mapCodec :: Functor fr => (a -> b) -> (b -> a) -> Codec fr fw a -> Codec fr fw b+mapCodec to from (Codec r w)+  = Codec (to <$> r) (w . from)++-- | Map a field codec monadically. Useful for error handling but care must be taken to make sure that+-- the results are still complementary.+mapCodecM :: (Monad fr, Monad fw) => (a -> fr b) -> (b -> fw a) -> Codec fr fw a -> Codec fr fw b+mapCodecM to from (Codec r w)+  = Codec (r >>= to) (from >=> w)++-- | Map the contexts of a given `Codec`.+mapCodecF :: (fr a -> gr a) -> (fw () -> gw ()) -> Codec fr fw a -> Codec gr gw a+mapCodecF fr fw (Codec r w)+  = Codec (fr r) (fw . w)++-- | A codec where `a` can be produced from a concrete value of `b` in context `f`,+-- and a concrete type of value `b` can always be produced.+type ConcreteCodec b f a = Codec (ReaderT b f) (Const b) a++-- | Create a concrete codec from a reader and a writer.+concrete :: (b -> f a) -> (a -> b) -> ConcreteCodec b f a+concrete r w = Codec (ReaderT r) (Const . w)++-- | Parse a concrete value with a given `ConcreteCodec`.+parseVal :: ConcreteCodec b f a -> b -> f a+parseVal (Codec r _) = runReaderT r++-- | Produce a concrete value with a given `ConcreteCodec`.+produceVal :: ConcreteCodec b f a -> a -> b+produceVal (Codec _ w) = getConst . w++-- | A codec that can only serialize a subset of values.+type PartialCodec fr fw a = Codec fr (Compose Maybe fw) a++-- | Finish a codec construction with a @`Con` r@ to produce a `PartialCodec`.+-- This will check that the given record has the appropriate constructor+-- before serializing.+cbuild :: (Functor fr, Buildable r y)+  => Con r x -> Build r (Codec' fr fw r) x y -> PartialCodec fr fw r+cbuild (Con c p) = assume p . build c++-- | Guard a `Codec` with a predicate to create a `PartialCodec`.+assume :: (a -> Bool) -> Codec fr fw a -> PartialCodec fr fw a+assume p (Codec r w)+  = Codec r (\x -> Compose $ if p x then Just (w x) else Nothing)++-- | Convert a `PartialCodec` into a `Codec`, throwing an error+-- on values it cannot serialize.+covered :: PartialCodec fr fw a -> Codec fr fw a+covered cd+  = Codec (parse cd) (fromMaybe (error "Could not serialize value.") . produceMaybe cd)++-- | Combine alternative `PartialCodec`s.+(<->) :: Alternative fr => PartialCodec fr fw a -> PartialCodec fr fw a -> PartialCodec fr fw a+cd <-> acd = Codec+  { parse = parse cd <|> parse acd+  , produce = \x -> Compose $ produceMaybe cd x <|> produceMaybe acd x+}++-- | Attempt to get a serialization for a given value.+produceMaybe :: PartialCodec fr fw a -> a -> Maybe (fw ())+produceMaybe (Codec _ w) x+  = getCompose (w x)
+ Data/Codec/Field.hs view
@@ -0,0 +1,68 @@+module Data.Codec.Field+  ( +  -- * First-class record construction+    Field(..)+  , Build(..)+  , Con(..)+  , ($>>), (>>>), done+  , X(X), Buildable(..)+  , having, build+  ) where++import Control.Applicative+import Control.Category+import Prelude hiding ((.), id)++-- | `Field`s partially apply constructors and replace arguments with this type.+data X = X++-- | The class of constructor applications that have been completely filled in by composing+-- `Build`s. If you see an error message involving this, it means that you forgot to specify+-- a `Build` for a field.+class Buildable r a where+  give :: a -> r++instance Buildable r r where+  give = id++instance Buildable r b => Buildable r (X -> b) where+  give f = give $ f X++-- | Describes how to apply a constructor argument and how to extract from a record.+-- @y@ should be @x@ with one argument knocked out: e. g.+--+-- @+-- Field MyType Int (Int -> a2 -> MyType) (X -> a2 -> MyType)+-- @+data Field r a x y = Field (a -> x -> y) (r -> a)++-- Static (Backwards f) + phantom parameter+-- | An ongoing record construction of an @r@ in context @f@.+-- Applicative actions are sequenced in the direction of `>>>`.+newtype Build r f x y = Build (f (x -> y))++-- | Combine a `Field` and a way to produce an @a@ to get a `Build`.+having :: Functor f => Field r a x y -> f a -> Build r f x y+having (Field c _) p = Build (c <$> p)++-- | No-op `Build` (same as `id`).+done :: Applicative f => Build r f x x+done = id++instance Applicative f => Category (Build r f) where+  id = Build (pure id)+  Build f . Build g+    = Build ((>>>) <$> g <*> f)++-- | Finish a construction given a constructor.+build :: (Functor f, Buildable r y) => x -> Build r f x y -> f r+build x (Build b)+  = (\f -> give $ f x) <$> b++-- | Infix version of `build`.+($>>) :: (Functor f, Buildable r y) => x -> Build r f x y -> f r+($>>) = build+infixr 1 $>>++-- | A constructor for a given record and a way to check whether it has it.+data Con r x = Con x (r -> Bool)
+ Data/Codec/TH.hs view
@@ -0,0 +1,89 @@+module Data.Codec.TH (genFields) where++import Control.Applicative+import Data.Foldable (foldl')+import Data.Traversable (for, traverse)+import Language.Haskell.TH as TH+import Language.Haskell.TH.Syntax as TH++import Data.Codec.Field as F++replaceAt :: a -> Int -> [ a ] -> [ a ]+replaceAt x i xs = pr ++ x : suf+  where ( pr, _ : suf ) = splitAt i xs++deleteAt :: Int -> [ a ] -> [ a ]+deleteAt i xs = pr ++ suf+  where ( pr, _ : suf ) = splitAt i xs++fun :: Type -> Type -> Type+fun x = AppT (AppT ArrowT x)++genField :: [ Name ] -> Type -> Int -> ( Int, VarStrictType ) -> Q [ Dec ]+genField recVars recType fc ( i, ( fn, _, ft ) ) = do+  polyNames <- for [1..fc] $ \j -> do+    let pn = "arg" ++ show j+    if any (\rv -> nameBase rv == pn) recVars+      then newName pn+      else return $ mkName pn+  let polyTypes = map VarT polyNames+      polyArgs = map (\j -> mkName $ "arg" ++ show j) [1..fc]+      fieldVars = map PlainTV $ recVars ++ deleteAt i polyNames+      fieldName = mkName ("f_" ++ nameBase fn)+      r = pure recType+      a = pure ft+      x = pure $ foldr fun recType $ replaceAt ft i polyTypes+      y = pure $ foldr fun recType $ replaceAt (ConT ''X) i polyTypes+      mkApplicator c v = pure $ LamE argPats app+        where+          app = foldl' AppE (VarE c) $ map VarE $ replaceAt v i polyArgs+          argPats = replaceAt WildP i $ map VarP polyArgs+      -- \c x -> \a1 -> .. \_ -> .. \an -> c a1 .. x .. an+      applicator = [|\v c -> $(mkApplicator 'c 'v)|]+      extractor = pure $ VarE fn+  fieldType <- ForallT fieldVars [] <$>+    [t|Field $r $a $x $y|]+  fieldBody <-+    [|Field $applicator $extractor|]+  return [ SigD fieldName fieldType, ValD (VarP fieldName) (NormalB fieldBody) [] ]++genCon :: [ Name ] -> Type -> Int -> TH.Con -> Q [ Dec ]+genCon recVars recType cc+  = \case+    RecC cName fields -> genCon' cName fields+    NormalC cName [] -> genCon' cName []+    _ -> fail "Unsupported constructor."+  where+    genCon' cName fields = do+      let fieldTypes = [ ft | ( _, _, ft ) <- fields ]+          conName = mkName ("c_" ++ nameBase cName)+          cType = foldr fun recType fieldTypes+          conMatch+            | cc == 1 = [|const True|]+            | otherwise = [|\r -> $(mkConMatch 'r)|]+          mkConMatch r = pure $ CaseE (VarE r)+                         [ Match (RecP cName []) (NormalB (ConE 'True)) []+                         , Match WildP (NormalB (ConE 'False)) []+                         ]+          fc = length fields+      conType <- ForallT (map PlainTV recVars) [] <$> [t|F.Con $(pure recType) $(pure cType)|]+      conBody <- [|F.Con $(pure $ ConE cName) $conMatch|]+      fDecs <- traverse (genField recVars recType fc) $ zip [0..] fields+      return $+        [ SigD conName conType+        , ValD (VarP conName) (NormalB conBody) []+        ] ++ concat fDecs++-- | Generate `Field`s for a given data type. Currently only single-constructor records are supported.+-- Each record field @a@ will be turned into a `Field` @f_a@, and all constructors will be turned into `Con`s.+genFields :: Name -> Q [ Dec ]+genFields n = reify n >>= \case+  TyConI (DataD [] _ vs cs _) -> do+      recVars <- for vs $ \case+        PlainTV vn -> return vn+        KindedTV vn k | k == starK -> return vn+        _ -> fail "Only simple type variables supported."+      let recType = foldl' (\t v -> AppT t (VarT v)) (ConT n) recVars+          cc = length cs+      concat <$> traverse (genCon recVars recType cc) cs+  _ -> fail "Unsupported record type."
+ Data/Codec/Tuple.hs view
@@ -0,0 +1,32 @@+module Data.Codec.Tuple+  ( Field1(..), Field2(..)+  , c_Left, c_Right, f_left, f_right+  ) where++import Data.Either++import Data.Codec.Field (Field(..), Con(..), X)++class Field1 r a x y | r x -> y, r y -> x, r -> a, x y -> r where+  f_1 :: Field r a x y++instance Field1 ( a, b ) a (a -> a2 -> ( a, b )) (X -> a2 -> ( a, b )) where+  f_1 = Field (\x c _ a2 -> c x a2) fst++class Field2 r a x y | r x -> y, r y -> x, r -> a, x y -> r where+  f_2 :: Field r a x y++instance Field2 ( a, b ) b (a1 -> b -> ( a, b )) (a1 -> X -> ( a, b )) where+  f_2 = Field (\x c a1 _ -> c a1 x) snd++c_Left :: Con (Either a b) (a -> Either a b)+c_Left = Con Left (\case { Left _ -> True; _ -> False })++c_Right :: Con (Either a b) (b -> Either a b)+c_Right = Con Right (\case { Right _ -> True; _ -> False })++f_left :: Field (Either a b) a (a -> Either a b) (X -> Either a b)+f_left = Field (\x c _ -> c x) (\(Left l) -> l)++f_right :: Field (Either a b) b (b -> Either a b) (X -> Either a b)+f_right = Field (\x c _ -> c x) (\(Right l) -> l)
codec.cabal view
@@ -1,5 +1,5 @@ name:                codec-version:             0.1+version:             0.1.1 license:             BSD3 license-file:        LICENSE synopsis:            First-class record construction and bidirectional serialization@@ -87,9 +87,12 @@  library   exposed-modules:     Data.Codec,+                       Data.Codec.Field,+                       Data.Codec.Codec,+                       Data.Codec.TH,+                       Data.Codec.Tuple,                        Data.Codec.Testing, -                       Control.Lens.Codec,                        Data.Aeson.Codec,                        Data.Binary.Codec,                        Data.Binary.Bits.Codec,