diff --git a/codec.cabal b/codec.cabal index 3ee849e..dcdcb6f 100644 --- a/codec.cabal +++ b/codec.cabal @@ -20,6 +20,7 @@ source-repository head library exposed-modules: Control.Monad.Codec, + Control.Monad.Codec.Generic, Data.Aeson.Codec, Data.Binary.Codec, Data.Binary.Bits.Codec @@ -54,4 +55,4 @@ test-suite codec-tests generic-arbitrary, binary ghc-options: -Wall - default-language: Haskell2010 \ No newline at end of file + default-language: Haskell2010 diff --git a/src/Control/Monad/Codec/Generic.hs b/src/Control/Monad/Codec/Generic.hs new file mode 100644 index 0000000..bc0fb1b --- /dev/null +++ b/src/Control/Monad/Codec/Generic.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Control.Monad.Codec.Generic + ( SimplifyGeneric(..) + , match + , rchoose + , lchoose + , combine + , (|*|) + , (?>) + , ( SimpleGeneric a + unsimplifyGeneric :: SimpleGeneric a -> a p + +instance SimplifyGeneric U1 where + type SimpleGeneric U1 = () + simplifyGeneric = const () + unsimplifyGeneric = const U1 + +instance SimplifyGeneric (K1 i c) where + type SimpleGeneric (K1 i c) = c + simplifyGeneric = unK1 + unsimplifyGeneric = K1 + +instance SimplifyGeneric f => SimplifyGeneric (M1 i c f) where + type SimpleGeneric (M1 i c f) = SimpleGeneric f + simplifyGeneric = simplifyGeneric . unM1 + unsimplifyGeneric = M1 . unsimplifyGeneric + +instance (SimplifyGeneric a, SimplifyGeneric b) => + SimplifyGeneric (a :+: b) where + type SimpleGeneric (a :+: b) = Either (SimpleGeneric a) (SimpleGeneric b) + simplifyGeneric (L1 x) = Left $ simplifyGeneric x + simplifyGeneric (R1 x) = Right $ simplifyGeneric x + unsimplifyGeneric (Left x) = L1 $ unsimplifyGeneric x + unsimplifyGeneric (Right x) = R1 $ unsimplifyGeneric x + +instance (SimplifyGeneric a, SimplifyGeneric b) => + SimplifyGeneric (a :*: b) where + type SimpleGeneric (a :*: b) = (SimpleGeneric a, SimpleGeneric b) + simplifyGeneric (a :*: b) = (simplifyGeneric a, simplifyGeneric b) + unsimplifyGeneric (a, b) = unsimplifyGeneric a :*: unsimplifyGeneric b + +-- | Construct a codec for any type using the `Generic` instance. +-- The codec is usually obtained by using `combine`, `lchoose` and `rchoose` +match :: + (Generic a, Functor r, Functor w, SimplifyGeneric (Rep a)) + => Codec r w (SimpleGeneric (Rep a)) + -> Codec r w a +match = dimap (simplifyGeneric . from) (to . unsimplifyGeneric) + +-- | Combine two codecs to read / write a tuple of values +combine :: + (Applicative r, Applicative w) + => CodecFor r w a b + -> CodecFor r w c d + -> CodecFor r w (a, c) (b, d) +combine a b = (,) <$> fst =. a <*> snd =. b + +-- | Operator for `combine` +(|*|) :: + (Applicative r, Applicative w) + => CodecFor r w a b + -> CodecFor r w c d + -> CodecFor r w (a, c) (b, d) +(|*|) = combine + +infixl 7 |*| + +-- | Combine two codecs to read / write `Either` using `Left` as default when reading +lchoose :: + (Alternative r, Functor w) + => Codec r w a + -> Codec r w b + -> Codec r w (Either a b) +lchoose l r = + Codec + { codecIn = (Left <$> codecIn l) <|> (Right <$> codecIn r) + , codecOut = either (fmap Left . codecOut l) (fmap Right . codecOut r) + } + +-- | Operator for `lchoose` +(?>) :: + (Alternative r, Functor w) + => Codec r w a + -> Codec r w b + -> Codec r w (Either a b) +(?>) = lchoose + +infixl 6 ?> + +-- | Combine two codecs to read / write `Either` using `Right` as default when reading +rchoose :: + (Alternative r, Functor w) + => Codec r w a + -> Codec r w b + -> Codec r w (Either a b) +rchoose l r = + Codec + { codecIn = (Right <$> codecIn r) <|> (Left <$> codecIn l) + , codecOut = either (fmap Left . codecOut l) (fmap Right . codecOut r) + } + +-- | Operator for `rchoose` +( Codec r w a + -> Codec r w b + -> Codec r w (Either a b) +(