typed-encoding 0.1.0.0 → 0.2.0.0
raw patch · 41 files changed
+2019/−860 lines, 41 files
Files
- ChangeLog.md +26/−0
- README.md +10/−2
- src/Data/TypedEncoding.hs +42/−18
- src/Data/TypedEncoding/Instances/ASCII.hs +0/−119
- src/Data/TypedEncoding/Instances/Base64.hs +0/−155
- src/Data/TypedEncoding/Instances/Do/Sample.hs +58/−0
- src/Data/TypedEncoding/Instances/Enc/Base64.hs +150/−0
- src/Data/TypedEncoding/Instances/Encode/Sample.hs +0/−59
- src/Data/TypedEncoding/Instances/Restriction/ASCII.hs +119/−0
- src/Data/TypedEncoding/Instances/Restriction/Common.hs +40/−0
- src/Data/TypedEncoding/Instances/Restriction/UTF8.hs +130/−0
- src/Data/TypedEncoding/Instances/Support.hs +7/−2
- src/Data/TypedEncoding/Instances/ToEncString/Common.hs +43/−0
- src/Data/TypedEncoding/Instances/UTF8.hs +0/−136
- src/Data/TypedEncoding/Internal/Class.hs +41/−197
- src/Data/TypedEncoding/Internal/Class/Decode.hs +81/−0
- src/Data/TypedEncoding/Internal/Class/Encode.hs +71/−0
- src/Data/TypedEncoding/Internal/Class/IsStringR.hs +64/−0
- src/Data/TypedEncoding/Internal/Class/Recreate.hs +67/−0
- src/Data/TypedEncoding/Internal/Class/Util.hs +88/−0
- src/Data/TypedEncoding/Internal/Combinators.hs +51/−0
- src/Data/TypedEncoding/Internal/Instances/Combinators.hs +89/−0
- src/Data/TypedEncoding/Internal/Types.hs +50/−70
- src/Data/TypedEncoding/Internal/Types/CheckedEnc.hs +85/−0
- src/Data/TypedEncoding/Internal/Types/Common.hs +4/−0
- src/Data/TypedEncoding/Internal/Types/Enc.hs +93/−0
- src/Data/TypedEncoding/Internal/Types/SomeAnnotation.hs +34/−0
- src/Data/TypedEncoding/Internal/Types/SomeEnc.hs +61/−0
- src/Data/TypedEncoding/Internal/Types/UncheckedEnc.hs +52/−0
- src/Data/TypedEncoding/Internal/Types/Unsafe.hs +29/−0
- src/Data/TypedEncoding/Internal/Util.hs +26/−0
- src/Data/TypedEncoding/Internal/Utils.hs +0/−13
- src/Data/TypedEncoding/Unsafe.hs +4/−26
- src/Examples/TypedEncoding.hs +3/−0
- src/Examples/TypedEncoding/Conversions.hs +16/−14
- src/Examples/TypedEncoding/DiySignEncoding.hs +4/−8
- src/Examples/TypedEncoding/Overview.hs +35/−25
- src/Examples/TypedEncoding/ToEncString.hs +315/−0
- src/Examples/TypedEncoding/Unsafe.hs +5/−8
- test/Spec.hs +1/−1
- typed-encoding.cabal +25/−7
ChangeLog.md view
@@ -1,5 +1,31 @@ # Changelog for typed-encoding ++## Unreleased changes++## 0.2.0.0+ - breaking:+ - Data.TypedEncoding.Instances modules reorganized+ - Data.TypedEncoding.Internal.Class modules reorganized+ - Data.TypedEncoding.Internal.Utils module renamed+ - Several TypeAnnotations friendly changes:+ * Removed polymorphic kinds in most places+ * Changed typeclass name from `Subset` to `Superset`+ * flipped type parameters on FlattenAs, HasA typeclass functions+ * Removed Proxy parameters from several methods (few methods have a '_' backward compatible version which still has them)+ - new functionality:+ - `ToEncString` - class allowing to convert types to `Enc` encoded strings+ - `FromEncString` - class reverses ToEncString+ - `CheckedEnc` untyped version of `Enc` containing valid encoding+ - `SomeEnc` existentially quantified version of `Enc` + - `UncheckedEnc` for working with not validated encoding+ - `RecreateExUnkStep` constructor added to RecreateEx+ - utility `IsStringR` - reverse to `IsString` class+ - utility `SymbolList` class+ - docs: + - ToEncString example++ ## 0.1.0.0 - initial release
README.md view
@@ -2,7 +2,7 @@ Type level annotations, string transformations, and other goodies that make programming strings safer. ## Motivation-I have recently spent a lot of time troubleshooting various `Base64`, `quoted-printable`, and `Utf8` encoding issues. +I have recently spent a lot of time troubleshooting various `Base64`, `quoted-printable`, and `UTF-8` encoding issues. I decided to write a library that will help avoiding issues like these. This library allows to specify and work with types like@@ -15,11 +15,19 @@ myData :: Enc '["enc-B64", "r-UTF8"] ByteString ``` +It allows to define precise string content annotations like:++```Haskell+mydata :: Enc '["r-IpV4"] Text+```+ and provides ways for - encoding - decoding - recreation (encoding validation) - type conversions+ - converting types to encoded strings+ - typesafe conversion of encoded strings to types ... but this approach seems to be a bit more... @@ -38,7 +46,7 @@ ## Examples Please see `Examples.TypedEncoding` it the module list.- + ## Dependencies on other encoding libs Currently it uses
src/Data/TypedEncoding.hs view
@@ -1,10 +1,7 @@ {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DataKinds #-} -- |--- Main Module in typed-encoding. --- -- = Overview -- -- This library allows to specify and work with types like@@ -27,6 +24,13 @@ -- upper = ... -- @ --+-- or define precise types to use with 'toEncString' and 'fromEncString'+-- +-- @+-- date :: Enc '["r-date-%d/%b/%Y:%X %Z"] Text+-- date = toEncString ...+-- @+-- -- Primary focus of type-encodings is to provide type safe -- -- * /encoding/@@ -37,6 +41,13 @@ -- of string-like data (@ByteString@, @Text@) that is subject of some -- encoding or formatting restrictions. --+-- as well as+--+-- * /toEncString/ +-- * /fromEncString/ +--+-- conversions.+-- -- = Groups of annotations -- -- typed-encoding uses type annotations grouped into semantic categories@@ -67,14 +78,16 @@ -- -- = Usage ----- To use this library import this module and one or more "instance" modules.+-- To use this library import this module and one or more /instance/ module. -- -- Here is list of instance modules available in typed-encoding library itself ----- * "Data.TypedEncoding.Instances.Base64"--- * "Data.TypedEncoding.Instances.ASCII" --- * "Data.TypedEncoding.Instances.UTF8" --- * "Data.TypedEncoding.Instances.Encode.Sample" +-- * "Data.TypedEncoding.Instances.Enc.Base64"+-- * "Data.TypedEncoding.Instances.Restriction.Common" +-- * "Data.TypedEncoding.Instances.Restriction.ASCII" +-- * "Data.TypedEncoding.Instances.Restriction.UTF8" +-- * "Data.TypedEncoding.Instances.Do.Sample" +-- * "Data.TypedEncoding.Instances.ToEncString.Common" -- -- This list is not intended to be exhaustive, rather separate libraries -- can provide instances for other encodings and transformations.@@ -92,25 +105,36 @@ module Data.TypedEncoding -- * Classes , module Data.TypedEncoding.Internal.Class+ -- * Combinators+ , module Data.TypedEncoding.Internal.Combinators -- * Types , Enc+ , CheckedEnc , EncodeEx(..) , RecreateEx(..) , UnexpectedDecodeEx(..)- -- * Combinators+ , EncAnn + -- * Existentially quantified version of @Enc@ and basic combinators+ , module Data.TypedEncoding.Internal.Types.SomeEnc+ -- * Types and combinators for not verfied encoding + , module Data.TypedEncoding.Internal.Types.UncheckedEnc+ -- * Basic @Enc@ Combinators , getPayload , unsafeSetPayload , fromEncoding , toEncoding+ -- * Basic @CheckedEnc@ Combinators + , unsafeCheckedEnc+ , getCheckedPayload+ , getCheckedEncPayload+ , toCheckedEnc+ , fromCheckedEnc+ -- * Other Basic Combinators + , recreateErrUnknown ) where -import Data.TypedEncoding.Internal.Types (Enc- , RecreateEx(..)- , UnexpectedDecodeEx(..)- , EncodeEx(..)- , getPayload- , unsafeSetPayload- , toEncoding- , fromEncoding- )+import Data.TypedEncoding.Internal.Types+import Data.TypedEncoding.Internal.Types.SomeEnc+import Data.TypedEncoding.Internal.Types.UncheckedEnc import Data.TypedEncoding.Internal.Class+import Data.TypedEncoding.Internal.Combinators
− src/Data/TypedEncoding/Instances/ASCII.hs
@@ -1,119 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}---- | Strings can move to 'Enc "r-ASCII' only if they contain only ascii characters.--- they always decode back--- >>> :set -XOverloadedStrings -XMultiParamTypeClasses -XDataKinds--- >>> encodeFAll . toEncoding () $ "Hello World" :: Either EncodeEx (Enc '["r-ASCII"] () T.Text)--- Right (MkEnc Proxy () "Hello World")------ >>> encodeFAll . toEncoding () $ "\194\160" :: Either EncodeEx (Enc '["r-ASCII"] () T.Text)--- Left (EncodeEx "r-ASCII" (NonAsciiChar '\194'))-module Data.TypedEncoding.Instances.ASCII where--import Data.TypedEncoding.Instances.Support--import Data.Proxy-import Data.Functor.Identity-import GHC.TypeLits--import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Encoding as TE -import qualified Data.Text.Lazy.Encoding as TEL --import qualified Data.ByteString.Char8 as B8-import qualified Data.ByteString.Lazy.Char8 as BL8--import Data.Char-import Data.TypedEncoding.Internal.Utils (explainBool)-import Data.TypedEncoding.Unsafe (withUnsafe)-import Control.Arrow---- tst = encodeFAll . toEncoding () $ "Hello World" :: Either EncodeEx (Enc '["r-ASCII"] () T.Text)--- tst2 = encodeFAll . toEncoding () $ "\194\160" :: Either EncodeEx (Enc '["r-ASCII"] () T.Text)--- tst3 = encodeFAll . toEncoding () $ "\194\160" :: Either EncodeEx (Enc '["r-ASCII"] () B.ByteString)---------------------- Conversions ----------------------byteString2TextS :: Enc ("r-ASCII" ': ys) c B.ByteString -> Enc ("r-ASCII" ': ys) c T.Text -byteString2TextS = withUnsafe (fmap TE.decodeUtf8)--byteString2TextL :: Enc ("r-ASCII" ': ys) c BL.ByteString -> Enc ("r-ASCII" ': ys) c TL.Text -byteString2TextL = withUnsafe (fmap TEL.decodeUtf8)--text2ByteStringS :: Enc ("r-ASCII" ': ys) c T.Text -> Enc ("r-ASCII" ': ys) c B.ByteString -text2ByteStringS = withUnsafe (fmap TE.encodeUtf8)--text2ByteStringL :: Enc ("r-ASCII" ': ys) c TL.Text -> Enc ("r-ASCII" ': ys) c BL.ByteString -text2ByteStringL = withUnsafe (fmap TEL.encodeUtf8)----- | allow to treat ASCII encodings as UTF8 forgetting about B64 encoding--- --- >>> let Right tstAscii = encodeFAll . toEncoding () $ "Hello World" :: Either EncodeEx (Enc '["r-ASCII"] () T.Text)--- >>> displ (inject (Proxy :: Proxy "r-UTF8") tstAscii)--- "MkEnc '[r-UTF8] () (Text Hello World)"-instance Subset "r-ASCII" "r-UTF8" where---------------------- Encondings ----------------------data NonAsciiChar = NonAsciiChar Char deriving (Eq, Show)--prxyAscii = Proxy :: Proxy "r-ASCII"--instance EncodeF (Either EncodeEx) (Enc xs c Char) (Enc ("r-ASCII" ': xs) c Char) where- encodeF = implEncodeF prxyAscii (\c -> explainBool NonAsciiChar (c, isAscii c)) -instance Applicative f => DecodeF f (Enc ("r-ASCII" ': xs) c Char) (Enc xs c Char) where- decodeF = implTranP id --instance EncodeF (Either EncodeEx) (Enc xs c T.Text) (Enc ("r-ASCII" ': xs) c T.Text) where- encodeF = implEncodeF prxyAscii (encodeImpl T.partition T.head T.null)-instance (RecreateErr f, Applicative f) => RecreateF f (Enc xs c T.Text) (Enc ("r-ASCII" ': xs) c T.Text) where- checkPrevF = implCheckPrevF (asRecreateErr prxyAscii . encodeImpl T.partition T.head T.null)-instance Applicative f => DecodeF f (Enc ("r-ASCII" ': xs) c T.Text) (Enc xs c T.Text) where- decodeF = implTranP id --instance EncodeF (Either EncodeEx) (Enc xs c TL.Text) (Enc ("r-ASCII" ': xs) c TL.Text) where- encodeF = implEncodeF prxyAscii (encodeImpl TL.partition TL.head TL.null)-instance (RecreateErr f, Applicative f) => RecreateF f (Enc xs c TL.Text) (Enc ("r-ASCII" ': xs) c TL.Text) where - checkPrevF = implCheckPrevF (asRecreateErr prxyAscii . encodeImpl TL.partition TL.head TL.null)-instance Applicative f => DecodeF f (Enc ("r-ASCII" ': xs) c TL.Text) (Enc xs c TL.Text) where- decodeF = implTranP id --instance EncodeF (Either EncodeEx) (Enc xs c B.ByteString) (Enc ("r-ASCII" ': xs) c B.ByteString) where- encodeF = implEncodeF prxyAscii (encodeImpl (\p -> B8.filter p &&& B8.filter (not . p)) B8.head B8.null)-instance (RecreateErr f, Applicative f) => RecreateF f (Enc xs c B.ByteString) (Enc ("r-ASCII" ': xs) c B.ByteString) where- checkPrevF = implCheckPrevF (asRecreateErr prxyAscii . encodeImpl (\p -> B8.filter p &&& B8.filter (not . p)) B8.head B8.null)-instance Applicative f => DecodeF f (Enc ("r-ASCII" ': xs) c B.ByteString) (Enc xs c B.ByteString) where- decodeF = implTranP id --instance EncodeF (Either EncodeEx) (Enc xs c BL.ByteString) (Enc ("r-ASCII" ': xs) c BL.ByteString) where- encodeF = implEncodeF prxyAscii (encodeImpl (\p -> BL8.filter p &&& BL8.filter (not . p)) BL8.head BL8.null)-instance (RecreateErr f, Applicative f) => RecreateF f (Enc xs c BL.ByteString) (Enc ("r-ASCII" ': xs) c BL.ByteString) where- checkPrevF = implCheckPrevF (asRecreateErr prxyAscii . encodeImpl (\p -> BL8.filter p &&& BL8.filter (not . p)) BL8.head BL8.null)-instance Applicative f => DecodeF f (Enc ("r-ASCII" ': xs) c BL.ByteString) (Enc xs c BL.ByteString) where- decodeF = implTranP id --encodeImpl :: - ((Char -> Bool) -> a -> (a, a))- -> (a -> Char)- -> (a -> Bool)- -> a- -> Either NonAsciiChar a-encodeImpl partitionf headf nullf t = - let (tascii, nonascii) = partitionf isAscii t - in if nullf nonascii - then Right tascii- else Left . NonAsciiChar $ headf nonascii -
− src/Data/TypedEncoding/Instances/Base64.hs
@@ -1,155 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}---module Data.TypedEncoding.Instances.Base64 where--import Data.TypedEncoding-import Data.TypedEncoding.Instances.Support--import Data.Proxy-import Data.Functor.Identity-import GHC.TypeLits--import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Encoding as TE -import qualified Data.Text.Lazy.Encoding as TEL --import qualified Data.ByteString.Base64 as B64-import qualified Data.ByteString.Base64.Lazy as BL64--import qualified Data.ByteString.Base64.URL as B64URL-import qualified Data.ByteString.Base64.URL.Lazy as BL64URL---- $setup--- >>> :set -XScopedTypeVariables -XKindSignatures -XMultiParamTypeClasses -XDataKinds -XPolyKinds -XPartialTypeSignatures -XFlexibleInstances--- >>> import Test.QuickCheck--- >>> import Test.QuickCheck.Instances.Text()--- >>> import Test.QuickCheck.Instances.ByteString()----------------------- Conversions ------------------------ | Type-safer version of Byte-string to text conversion that prevent invalid UTF8 bytestrings--- to be conversted to B64 encoded Text.-byteString2TextS :: Enc ("enc-B64" ': "r-UTF8" ': ys) c B.ByteString -> Enc ("enc-B64" ': ys) c T.Text -byteString2TextS = withUnsafeCoerce (TE.decodeUtf8)--byteString2TextL :: Enc ("enc-B64" ': "r-UTF8" ': ys) c BL.ByteString -> Enc ("enc-B64" ': ys) c TL.Text -byteString2TextL = withUnsafeCoerce (TEL.decodeUtf8)---- | Converts encoded text to ByteString adding "r-UTF8" annotation.--- The question is why "r-UTF8", not for example, "r-UTF16"?--- No reason, there maybe a diffrent combinator for that in the future or one that accepts a proxy.-text2ByteStringS :: Enc ("enc-B64" ': ys) c T.Text -> Enc ("enc-B64" ': "r-UTF8" ': ys) c B.ByteString -text2ByteStringS = withUnsafeCoerce (TE.encodeUtf8)--text2ByteStringL :: Enc ("enc-B64" ': ys) c TL.Text -> Enc ("enc-B64" ': "r-UTF8" ': ys) c BL.ByteString -text2ByteStringL = withUnsafeCoerce (TEL.encodeUtf8)----- | B64 encoded bytestring can be converted to Text as "enc-B64-nontext" preventing it from --- being B64-decoded directly to Text-byteString2TextS' :: Enc ("enc-B64" ': ys) c B.ByteString -> Enc ("enc-B64-nontext" ': ys) c T.Text -byteString2TextS' = withUnsafeCoerce (TE.decodeUtf8)--byteString2TextL' :: Enc ("enc-B64" ': ys) c BL.ByteString -> Enc ("enc-B64-nontext" ': ys) c TL.Text -byteString2TextL' = withUnsafeCoerce (TEL.decodeUtf8)--text2ByteStringS' :: Enc ("enc-B64-nontext" ': ys) c T.Text -> Enc ("enc-B64" ': ys) c B.ByteString -text2ByteStringS' = withUnsafeCoerce (TE.encodeUtf8)--text2ByteStringL' :: Enc ("enc-B64-nontext" ': ys) c TL.Text -> Enc ("enc-B64" ': ys) c BL.ByteString -text2ByteStringL' = withUnsafeCoerce (TEL.encodeUtf8)--acceptLenientS :: Enc ("enc-B64-len" ': ys) c B.ByteString -> Enc ("enc-B64" ': ys) c B.ByteString -acceptLenientS = withUnsafeCoerce (B64.encode . B64.decodeLenient)--acceptLenientL :: Enc ("enc-B64-len" ': ys) c BL.ByteString -> Enc ("enc-B64" ': ys) c BL.ByteString -acceptLenientL = withUnsafeCoerce (BL64.encode . BL64.decodeLenient)---- | allow to treat B64 encodings as ASCII forgetting about B64 encoding--- ------ >>> let tstB64 = encodeAll . toEncoding () $ "Hello World" :: Enc '["enc-B64"] () B.ByteString--- >>> displ (flattenAs (Proxy :: Proxy "r-ASCII") tstB64 :: Enc '["r-ASCII"] () B.ByteString)--- "MkEnc '[r-ASCII] () (ByteString SGVsbG8gV29ybGQ=)"-instance FlattenAs "enc-B64-nontext" "r-ASCII" where-instance FlattenAs "enc-B64" "r-ASCII" where----------------------- Encodings ----------------------prxyB64 = Proxy :: Proxy "enc-B64"--instance Applicative f => EncodeF f (Enc xs c B.ByteString) (Enc ("enc-B64" ': xs) c B.ByteString) where- encodeF = implEncodeP B64.encode - --- | Effectful instance for corruption detection.--- This protocol is used, for example, in emails. --- It is a well known encoding and hackers will have no problem --- making undetectable changes, but error handling at this stage--- could verify that email was corrupted.-instance (UnexpectedDecodeErr f, Applicative f) => DecodeF f (Enc ("enc-B64" ': xs) c B.ByteString) (Enc xs c B.ByteString) where- decodeF = implDecodeF (asUnexpected prxyB64 . B64.decode) --instance (RecreateErr f, Applicative f) => RecreateF f (Enc xs c B.ByteString) (Enc ("enc-B64" ': xs) c B.ByteString) where- checkPrevF = implCheckPrevF (asRecreateErr prxyB64 . B64.decode) --instance Applicative f => RecreateF f (Enc xs c B.ByteString) (Enc ("enc-B64-len" ': xs) c B.ByteString) where- checkPrevF = implTranP (id) --instance Applicative f => EncodeF f (Enc xs c BL.ByteString) (Enc ("enc-B64" ': xs) c BL.ByteString) where- encodeF = implEncodeP BL64.encode --instance (UnexpectedDecodeErr f, Applicative f) => DecodeF f (Enc ("enc-B64" ': xs) c BL.ByteString) (Enc xs c BL.ByteString) where- decodeF = implDecodeF (asUnexpected prxyB64 . BL64.decode)--instance (RecreateErr f, Applicative f) => RecreateF f (Enc xs c BL.ByteString) (Enc ("enc-B64" ': xs) c BL.ByteString) where- checkPrevF = implCheckPrevF (asRecreateErr prxyB64 . BL64.decode) --instance Applicative f => RecreateF f (Enc xs c BL.ByteString) (Enc ("enc-B64-len" ': xs) c BL.ByteString) where- checkPrevF = implTranP (id) ---- B64URL currently not supported--- instance Applicative f => EncodeF f (Enc xs c B.ByteString) (Enc ("enc-B64URL" ': xs) c B.ByteString) where--- encodeF = implEncodeP B64URL.encode --- instance DecodeF (Either String) (Enc ("enc-B64URL" ': xs) c B.ByteString) (Enc xs c B.ByteString) where--- decodeF = implDecodeF B64URL.decode --- instance DecodeF Identity (Enc ("enc-B64URL" ': xs) c B.ByteString) (Enc xs c B.ByteString) where--- decodeF = implTranP B64URL.decodeLenient ---- instance Applicative f => EncodeF f (Enc xs c BL.ByteString) (Enc ("enc-B64URL" ': xs) c BL.ByteString) where--- encodeF = implEncodeP BL64URL.encode --- instance DecodeF (Either String) (Enc ("enc-B64URL" ': xs) c BL.ByteString) (Enc xs c BL.ByteString) where--- decodeF = implDecodeF BL64URL.decode --- instance DecodeF Identity (Enc ("enc-B64URL" ': xs) c BL.ByteString) (Enc xs c BL.ByteString) where--- decodeF = implTranP BL64URL.decodeLenient --instance Applicative f => EncodeF f (Enc xs c T.Text) (Enc ("enc-B64" ': xs) c T.Text) where- encodeF = implEncodeP (TE.decodeUtf8 . B64.encode . TE.encodeUtf8) --instance (UnexpectedDecodeErr f, Applicative f) => DecodeF f (Enc ("enc-B64" ': xs) c T.Text) (Enc xs c T.Text) where- decodeF = implDecodeF (asUnexpected prxyB64 . fmap TE.decodeUtf8 . B64.decode . TE.encodeUtf8) --instance (RecreateErr f, Applicative f) => RecreateF f (Enc xs c T.Text) (Enc ("enc-B64" ': xs) c T.Text) where- checkPrevF = implCheckPrevF (asRecreateErr prxyB64 . fmap TE.decodeUtf8 . B64.decode . TE.encodeUtf8) --instance Applicative f => EncodeF f (Enc xs c TL.Text) (Enc ("enc-B64" ': xs) c TL.Text) where- encodeF = implEncodeP (TEL.decodeUtf8 . BL64.encode . TEL.encodeUtf8) --instance (UnexpectedDecodeErr f, Applicative f) => DecodeF f (Enc ("enc-B64" ': xs) c TL.Text) (Enc xs c TL.Text) where- decodeF = implDecodeF (asUnexpected prxyB64 . fmap TEL.decodeUtf8 . BL64.decode . TEL.encodeUtf8) --instance (RecreateErr f, Applicative f) => RecreateF f (Enc xs c TL.Text) (Enc ("enc-B64" ': xs) c TL.Text) where- checkPrevF = implCheckPrevF (asRecreateErr prxyB64 . fmap TEL.decodeUtf8 . BL64.decode . TEL.encodeUtf8)
+ src/Data/TypedEncoding/Instances/Do/Sample.hs view
@@ -0,0 +1,58 @@++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | This module defines some sample "do-" encodings+-- currently for example use only.+module Data.TypedEncoding.Instances.Do.Sample where++import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.ByteString as B+-- import qualified Data.ByteString.Lazy as BL+import Data.Char++import Data.TypedEncoding.Instances.Support++++instance Applicative f => EncodeF f (Enc xs c T.Text) (Enc ("do-UPPER" ': xs) c T.Text) where+ encodeF = implEncodeP T.toUpper+instance (RecreateErr f, Applicative f) => RecreateF f (Enc xs c T.Text) (Enc ("do-UPPER" ': xs) c T.Text) where+ checkPrevF = implCheckPrevF (asRecreateErr @"do-UPPER" . (\t -> + let (g,b) = T.partition isUpper t+ in if T.null b+ then Right t+ else Left $ "Found not upper case chars " ++ T.unpack b)+ )+instance Applicative f => EncodeF f (Enc xs c TL.Text) (Enc ("do-UPPER" ': xs) c TL.Text) where+ encodeF = implEncodeP TL.toUpper ++instance Applicative f => EncodeF f (Enc xs c T.Text) (Enc ("do-lower" ': xs) c T.Text) where+ encodeF = implEncodeP T.toLower +instance Applicative f => EncodeF f (Enc xs c TL.Text) (Enc ("do-lower" ': xs) c TL.Text) where+ encodeF = implEncodeP TL.toLower ++instance Applicative f => EncodeF f (Enc xs c T.Text) (Enc ("do-Title" ': xs) c T.Text) where+ encodeF = implEncodeP T.toTitle +instance Applicative f => EncodeF f (Enc xs c TL.Text) (Enc ("do-Title" ': xs) c TL.Text) where+ encodeF = implEncodeP TL.toTitle ++instance Applicative f => EncodeF f (Enc xs c T.Text) (Enc ("do-reverse" ': xs) c T.Text) where+ encodeF = implEncodeP T.reverse +instance Applicative f => EncodeF f (Enc xs c TL.Text) (Enc ("do-reverse" ': xs) c TL.Text) where+ encodeF = implEncodeP TL.reverse ++newtype SizeLimit = SizeLimit {unSizeLimit :: Int} deriving (Eq, Show)+instance (HasA SizeLimit c, Applicative f) => EncodeF f (Enc xs c T.Text) (Enc ("do-size-limit" ': xs) c T.Text) where+ encodeF = implEncodeP' (T.take . unSizeLimit . has @ SizeLimit) +instance (HasA SizeLimit c, Applicative f) => EncodeF f (Enc xs c B.ByteString) (Enc ("do-size-limit" ': xs) c B.ByteString) where+ encodeF = implEncodeP' (B.take . unSizeLimit . has @ SizeLimit) +
+ src/Data/TypedEncoding/Instances/Enc/Base64.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeApplications #-}++-- | Defines /Base64/ encoding+module Data.TypedEncoding.Instances.Enc.Base64 where++import Data.TypedEncoding+import Data.TypedEncoding.Instances.Support++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Encoding as TE +import qualified Data.Text.Lazy.Encoding as TEL ++import qualified Data.ByteString.Base64 as B64+import qualified Data.ByteString.Base64.Lazy as BL64++-- import qualified Data.ByteString.Base64.URL as B64URL+-- import qualified Data.ByteString.Base64.URL.Lazy as BL64URL++-- $setup+-- >>> :set -XScopedTypeVariables -XKindSignatures -XMultiParamTypeClasses -XDataKinds -XPolyKinds -XPartialTypeSignatures -XFlexibleInstances+-- >>> import Test.QuickCheck+-- >>> import Test.QuickCheck.Instances.Text()+-- >>> import Test.QuickCheck.Instances.ByteString()++-----------------+-- Conversions --+-----------------++-- | Type-safer version of Byte-string to text conversion that prevent invalid UTF8 bytestrings+-- to be conversted to B64 encoded Text.+byteString2TextS :: Enc ("enc-B64" ': "r-UTF8" ': ys) c B.ByteString -> Enc ("enc-B64" ': ys) c T.Text +byteString2TextS = withUnsafeCoerce TE.decodeUtf8++byteString2TextL :: Enc ("enc-B64" ': "r-UTF8" ': ys) c BL.ByteString -> Enc ("enc-B64" ': ys) c TL.Text +byteString2TextL = withUnsafeCoerce TEL.decodeUtf8++-- | Converts encoded text to ByteString adding "r-UTF8" annotation.+-- The question is why "r-UTF8", not for example, "r-UTF16"?+-- No reason, there maybe a diffrent combinator for that in the future or one that accepts a proxy.+text2ByteStringS :: Enc ("enc-B64" ': ys) c T.Text -> Enc ("enc-B64" ': "r-UTF8" ': ys) c B.ByteString +text2ByteStringS = withUnsafeCoerce TE.encodeUtf8++text2ByteStringL :: Enc ("enc-B64" ': ys) c TL.Text -> Enc ("enc-B64" ': "r-UTF8" ': ys) c BL.ByteString +text2ByteStringL = withUnsafeCoerce TEL.encodeUtf8+++-- | B64 encoded bytestring can be converted to Text as "enc-B64-nontext" preventing it from +-- being B64-decoded directly to Text+byteString2TextS' :: Enc ("enc-B64" ': ys) c B.ByteString -> Enc ("enc-B64-nontext" ': ys) c T.Text +byteString2TextS' = withUnsafeCoerce TE.decodeUtf8++byteString2TextL' :: Enc ("enc-B64" ': ys) c BL.ByteString -> Enc ("enc-B64-nontext" ': ys) c TL.Text +byteString2TextL' = withUnsafeCoerce TEL.decodeUtf8++text2ByteStringS' :: Enc ("enc-B64-nontext" ': ys) c T.Text -> Enc ("enc-B64" ': ys) c B.ByteString +text2ByteStringS' = withUnsafeCoerce TE.encodeUtf8++text2ByteStringL' :: Enc ("enc-B64-nontext" ': ys) c TL.Text -> Enc ("enc-B64" ': ys) c BL.ByteString +text2ByteStringL' = withUnsafeCoerce TEL.encodeUtf8++acceptLenientS :: Enc ("enc-B64-len" ': ys) c B.ByteString -> Enc ("enc-B64" ': ys) c B.ByteString +acceptLenientS = withUnsafeCoerce (B64.encode . B64.decodeLenient)++acceptLenientL :: Enc ("enc-B64-len" ': ys) c BL.ByteString -> Enc ("enc-B64" ': ys) c BL.ByteString +acceptLenientL = withUnsafeCoerce (BL64.encode . BL64.decodeLenient)++-- | allow to treat B64 encodings as ASCII forgetting about B64 encoding+-- +--+-- >>> let tstB64 = encodeAll . toEncoding () $ "Hello World" :: Enc '["enc-B64"] () B.ByteString+-- >>> displ (flattenAs tstB64 :: Enc '["r-ASCII"] () B.ByteString)+-- "MkEnc '[r-ASCII] () (ByteString SGVsbG8gV29ybGQ=)"+instance FlattenAs "r-ASCII" "enc-B64-nontext" where+instance FlattenAs "r-ASCII" "enc-B64" where+++-----------------+-- Encodings --+-----------------+++instance Applicative f => EncodeF f (Enc xs c B.ByteString) (Enc ("enc-B64" ': xs) c B.ByteString) where+ encodeF = implEncodeP B64.encode + +-- | Effectful instance for corruption detection.+-- This protocol is used, for example, in emails. +-- It is a well known encoding and hackers will have no problem +-- making undetectable changes, but error handling at this stage+-- could verify that email was corrupted.+instance (UnexpectedDecodeErr f, Applicative f) => DecodeF f (Enc ("enc-B64" ': xs) c B.ByteString) (Enc xs c B.ByteString) where+ decodeF = implDecodeF (asUnexpected @"enc-B64" . B64.decode) ++instance (RecreateErr f, Applicative f) => RecreateF f (Enc xs c B.ByteString) (Enc ("enc-B64" ': xs) c B.ByteString) where+ checkPrevF = implCheckPrevF (asRecreateErr @"enc-B64" . B64.decode) ++instance Applicative f => RecreateF f (Enc xs c B.ByteString) (Enc ("enc-B64-len" ': xs) c B.ByteString) where+ checkPrevF = implTranP id++instance Applicative f => EncodeF f (Enc xs c BL.ByteString) (Enc ("enc-B64" ': xs) c BL.ByteString) where+ encodeF = implEncodeP BL64.encode ++instance (UnexpectedDecodeErr f, Applicative f) => DecodeF f (Enc ("enc-B64" ': xs) c BL.ByteString) (Enc xs c BL.ByteString) where+ decodeF = implDecodeF (asUnexpected @"enc-B64" . BL64.decode)++instance (RecreateErr f, Applicative f) => RecreateF f (Enc xs c BL.ByteString) (Enc ("enc-B64" ': xs) c BL.ByteString) where+ checkPrevF = implCheckPrevF (asRecreateErr @"enc-B64" . BL64.decode) ++instance Applicative f => RecreateF f (Enc xs c BL.ByteString) (Enc ("enc-B64-len" ': xs) c BL.ByteString) where+ checkPrevF = implTranP id++-- B64URL currently not supported+-- instance Applicative f => EncodeF f (Enc xs c B.ByteString) (Enc ("enc-B64URL" ': xs) c B.ByteString) where+-- encodeF = implEncodeP B64URL.encode +-- instance DecodeF (Either String) (Enc ("enc-B64URL" ': xs) c B.ByteString) (Enc xs c B.ByteString) where+-- decodeF = implDecodeF B64URL.decode +-- instance DecodeF Identity (Enc ("enc-B64URL" ': xs) c B.ByteString) (Enc xs c B.ByteString) where+-- decodeF = implTranP B64URL.decodeLenient ++-- instance Applicative f => EncodeF f (Enc xs c BL.ByteString) (Enc ("enc-B64URL" ': xs) c BL.ByteString) where+-- encodeF = implEncodeP BL64URL.encode +-- instance DecodeF (Either String) (Enc ("enc-B64URL" ': xs) c BL.ByteString) (Enc xs c BL.ByteString) where+-- decodeF = implDecodeF BL64URL.decode +-- instance DecodeF Identity (Enc ("enc-B64URL" ': xs) c BL.ByteString) (Enc xs c BL.ByteString) where+-- decodeF = implTranP BL64URL.decodeLenient ++instance Applicative f => EncodeF f (Enc xs c T.Text) (Enc ("enc-B64" ': xs) c T.Text) where+ encodeF = implEncodeP (TE.decodeUtf8 . B64.encode . TE.encodeUtf8) ++instance (UnexpectedDecodeErr f, Applicative f) => DecodeF f (Enc ("enc-B64" ': xs) c T.Text) (Enc xs c T.Text) where+ decodeF = implDecodeF (asUnexpected @"enc-B64" . fmap TE.decodeUtf8 . B64.decode . TE.encodeUtf8) ++instance (RecreateErr f, Applicative f) => RecreateF f (Enc xs c T.Text) (Enc ("enc-B64" ': xs) c T.Text) where+ checkPrevF = implCheckPrevF (asRecreateErr @"enc-B64" . fmap TE.decodeUtf8 . B64.decode . TE.encodeUtf8) ++instance Applicative f => EncodeF f (Enc xs c TL.Text) (Enc ("enc-B64" ': xs) c TL.Text) where+ encodeF = implEncodeP (TEL.decodeUtf8 . BL64.encode . TEL.encodeUtf8) ++instance (UnexpectedDecodeErr f, Applicative f) => DecodeF f (Enc ("enc-B64" ': xs) c TL.Text) (Enc xs c TL.Text) where+ decodeF = implDecodeF (asUnexpected @"enc-B64" . fmap TEL.decodeUtf8 . BL64.decode . TEL.encodeUtf8) ++instance (RecreateErr f, Applicative f) => RecreateF f (Enc xs c TL.Text) (Enc ("enc-B64" ': xs) c TL.Text) where+ checkPrevF = implCheckPrevF (asRecreateErr @"enc-B64" . fmap TEL.decodeUtf8 . BL64.decode . TEL.encodeUtf8)
− src/Data/TypedEncoding/Instances/Encode/Sample.hs
@@ -1,59 +0,0 @@--{-# LANGUAGE DataKinds #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}---- | This module defines some sample "do-" encodings--- currently for example use only.-module Data.TypedEncoding.Instances.Encode.Sample where--import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import qualified Data.ByteString as B--- import qualified Data.ByteString.Lazy as BL--import Data.TypedEncoding.Instances.Support--import Data.Proxy-import GHC.TypeLits-import Data.Char---instance Applicative f => EncodeF f (Enc xs c T.Text) (Enc ("do-UPPER" ': xs) c T.Text) where- encodeF = implEncodeP T.toUpper-instance (RecreateErr f, Applicative f) => RecreateF f (Enc xs c T.Text) (Enc ("do-UPPER" ': xs) c T.Text) where- checkPrevF = implCheckPrevF (asRecreateErr (Proxy :: Proxy "do-UPPER") . (\t -> - let (g,b) = T.partition isUpper t- in if T.null b- then Right t- else Left $ "Found not upper case chars " ++ T.unpack b)- )-instance Applicative f => EncodeF f (Enc xs c TL.Text) (Enc ("do-UPPER" ': xs) c TL.Text) where- encodeF = implEncodeP TL.toUpper --instance Applicative f => EncodeF f (Enc xs c T.Text) (Enc ("do-lower" ': xs) c T.Text) where- encodeF = implEncodeP T.toLower -instance Applicative f => EncodeF f (Enc xs c TL.Text) (Enc ("do-lower" ': xs) c TL.Text) where- encodeF = implEncodeP TL.toLower --instance Applicative f => EncodeF f (Enc xs c T.Text) (Enc ("do-Title" ': xs) c T.Text) where- encodeF = implEncodeP T.toTitle -instance Applicative f => EncodeF f (Enc xs c TL.Text) (Enc ("do-Title" ': xs) c TL.Text) where- encodeF = implEncodeP TL.toTitle --instance Applicative f => EncodeF f (Enc xs c T.Text) (Enc ("do-reverse" ': xs) c T.Text) where- encodeF = implEncodeP T.reverse -instance Applicative f => EncodeF f (Enc xs c TL.Text) (Enc ("do-reverse" ': xs) c TL.Text) where- encodeF = implEncodeP TL.reverse --newtype SizeLimit = SizeLimit {unSizeLimit :: Int} deriving (Eq, Show)-instance (HasA c SizeLimit, Applicative f) => EncodeF f (Enc xs c T.Text) (Enc ("do-size-limit" ': xs) c T.Text) where- encodeF = implEncodeP' (T.take . unSizeLimit . has (Proxy :: Proxy SizeLimit)) -instance (HasA c SizeLimit, Applicative f) => EncodeF f (Enc xs c B.ByteString) (Enc ("do-size-limit" ': xs) c B.ByteString) where- encodeF = implEncodeP' (B.take . unSizeLimit . has (Proxy :: Proxy SizeLimit)) -
+ src/Data/TypedEncoding/Instances/Restriction/ASCII.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeApplications #-}++-- | Strings can move to 'Enc "r-ASCII' only if they contain only ascii characters.+-- they always decode back+-- >>> :set -XOverloadedStrings -XMultiParamTypeClasses -XDataKinds+-- >>> encodeFAll . toEncoding () $ "Hello World" :: Either EncodeEx (Enc '["r-ASCII"] () T.Text)+-- Right (MkEnc Proxy () "Hello World")+--+-- >>> encodeFAll . toEncoding () $ "\194\160" :: Either EncodeEx (Enc '["r-ASCII"] () T.Text)+-- Left (EncodeEx "r-ASCII" (NonAsciiChar '\194'))+module Data.TypedEncoding.Instances.Restriction.ASCII where++import Data.TypedEncoding.Instances.Support++import Data.Proxy++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Encoding as TE +import qualified Data.Text.Lazy.Encoding as TEL ++import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy.Char8 as BL8++import Data.Char+import Data.TypedEncoding.Internal.Util (explainBool)+import Data.TypedEncoding.Unsafe (withUnsafe)+import Control.Arrow++-- $setup+-- >>> :set -XDataKinds -XTypeApplications++-----------------+-- Conversions --+-----------------++byteString2TextS :: Enc ("r-ASCII" ': ys) c B.ByteString -> Enc ("r-ASCII" ': ys) c T.Text +byteString2TextS = withUnsafe (fmap TE.decodeUtf8)++byteString2TextL :: Enc ("r-ASCII" ': ys) c BL.ByteString -> Enc ("r-ASCII" ': ys) c TL.Text +byteString2TextL = withUnsafe (fmap TEL.decodeUtf8)++text2ByteStringS :: Enc ("r-ASCII" ': ys) c T.Text -> Enc ("r-ASCII" ': ys) c B.ByteString +text2ByteStringS = withUnsafe (fmap TE.encodeUtf8)++text2ByteStringL :: Enc ("r-ASCII" ': ys) c TL.Text -> Enc ("r-ASCII" ': ys) c BL.ByteString +text2ByteStringL = withUnsafe (fmap TEL.encodeUtf8)+++-- | allow to treat ASCII encodings as UTF8 forgetting about B64 encoding+-- +-- >>> let Right tstAscii = encodeFAll . toEncoding () $ "Hello World" :: Either EncodeEx (Enc '["r-ASCII"] () T.Text)+-- >>> displ (inject @ "r-UTF8" tstAscii)+-- "MkEnc '[r-UTF8] () (Text Hello World)"+instance Superset "r-UTF8" "r-ASCII" where++-----------------+-- Encondings --+-----------------++newtype NonAsciiChar = NonAsciiChar Char deriving (Eq, Show)++prxyAscii = Proxy :: Proxy "r-ASCII"++instance EncodeF (Either EncodeEx) (Enc xs c Char) (Enc ("r-ASCII" ': xs) c Char) where+ encodeF = implEncodeF_ prxyAscii (\c -> explainBool NonAsciiChar (c, isAscii c)) +instance Applicative f => DecodeF f (Enc ("r-ASCII" ': xs) c Char) (Enc xs c Char) where+ decodeF = implTranP id ++instance EncodeF (Either EncodeEx) (Enc xs c T.Text) (Enc ("r-ASCII" ': xs) c T.Text) where+ encodeF = implEncodeF_ prxyAscii (encodeImpl T.partition T.head T.null)+instance (RecreateErr f, Applicative f) => RecreateF f (Enc xs c T.Text) (Enc ("r-ASCII" ': xs) c T.Text) where+ checkPrevF = implCheckPrevF (asRecreateErr @"r-ASCII" . encodeImpl T.partition T.head T.null)+instance Applicative f => DecodeF f (Enc ("r-ASCII" ': xs) c T.Text) (Enc xs c T.Text) where+ decodeF = implTranP id ++instance EncodeF (Either EncodeEx) (Enc xs c TL.Text) (Enc ("r-ASCII" ': xs) c TL.Text) where+ encodeF = implEncodeF_ prxyAscii (encodeImpl TL.partition TL.head TL.null)+instance (RecreateErr f, Applicative f) => RecreateF f (Enc xs c TL.Text) (Enc ("r-ASCII" ': xs) c TL.Text) where + checkPrevF = implCheckPrevF (asRecreateErr @"r-ASCII" . encodeImpl TL.partition TL.head TL.null)+instance Applicative f => DecodeF f (Enc ("r-ASCII" ': xs) c TL.Text) (Enc xs c TL.Text) where+ decodeF = implTranP id ++instance EncodeF (Either EncodeEx) (Enc xs c B.ByteString) (Enc ("r-ASCII" ': xs) c B.ByteString) where+ encodeF = implEncodeF_ prxyAscii (encodeImpl (\p -> B8.filter p &&& B8.filter (not . p)) B8.head B8.null)+instance (RecreateErr f, Applicative f) => RecreateF f (Enc xs c B.ByteString) (Enc ("r-ASCII" ': xs) c B.ByteString) where+ checkPrevF = implCheckPrevF (asRecreateErr @"r-ASCII" . encodeImpl (\p -> B8.filter p &&& B8.filter (not . p)) B8.head B8.null)+instance Applicative f => DecodeF f (Enc ("r-ASCII" ': xs) c B.ByteString) (Enc xs c B.ByteString) where+ decodeF = implTranP id ++instance EncodeF (Either EncodeEx) (Enc xs c BL.ByteString) (Enc ("r-ASCII" ': xs) c BL.ByteString) where+ encodeF = implEncodeF_ prxyAscii (encodeImpl (\p -> BL8.filter p &&& BL8.filter (not . p)) BL8.head BL8.null)+instance (RecreateErr f, Applicative f) => RecreateF f (Enc xs c BL.ByteString) (Enc ("r-ASCII" ': xs) c BL.ByteString) where+ checkPrevF = implCheckPrevF (asRecreateErr @"r-ASCII" . encodeImpl (\p -> BL8.filter p &&& BL8.filter (not . p)) BL8.head BL8.null)+instance Applicative f => DecodeF f (Enc ("r-ASCII" ': xs) c BL.ByteString) (Enc xs c BL.ByteString) where+ decodeF = implTranP id ++encodeImpl :: + ((Char -> Bool) -> a -> (a, a))+ -> (a -> Char)+ -> (a -> Bool)+ -> a+ -> Either NonAsciiChar a+encodeImpl partitionf headf nullf t = + let (tascii, nonascii) = partitionf isAscii t + in if nullf nonascii + then Right tascii+ else Left . NonAsciiChar $ headf nonascii ++-- tst = encodeFAll . toEncoding () $ "Hello World" :: Either EncodeEx (Enc '["r-ASCII"] () T.Text)+-- tst2 = encodeFAll . toEncoding () $ "\194\160" :: Either EncodeEx (Enc '["r-ASCII"] () T.Text)+-- tst3 = encodeFAll . toEncoding () $ "\194\160" :: Either EncodeEx (Enc '["r-ASCII"] () B.ByteString)
+ src/Data/TypedEncoding/Instances/Restriction/Common.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Common /restriction/ "r-" instances+module Data.TypedEncoding.Instances.Restriction.Common where++import Data.Word+import Data.String++-- import qualified Data.ByteString as B+-- import qualified Data.ByteString.Lazy as BL+-- import qualified Data.Text as T+-- import qualified Data.Text.Lazy as TL++import Data.TypedEncoding.Internal.Class.IsStringR+import Data.TypedEncoding.Internal.Instances.Combinators+import Data.TypedEncoding.Instances.Support++-- $setup+-- >>> import qualified Data.Text as T+++instance (IsStringR str, IsString str) => EncodeF (Either EncodeEx) (Enc xs c str) (Enc ("r-Word8-decimal" ': xs) c str) where+ encodeF = implEncodeF @"r-Word8-decimal" (verifyWithRead @Word8 "Word8-decimal")+instance (IsStringR str, IsString str, RecreateErr f, Applicative f) => RecreateF f (Enc xs c str) (Enc ("r-Word8-decimal" ': xs) c str) where+ checkPrevF = implCheckPrevF (asRecreateErr @"r-Word8-decimal" . verifyWithRead @Word8 "Word8-decimal")+instance (IsStringR str, IsString str, Applicative f) => DecodeF f (Enc ("r-Word8-decimal" ': xs) c str) (Enc xs c str) where+ decodeF = implTranP id ++++-- tst :: T.Text+-- tst = fromString $ show $ (fromString $ "123" :: T.Text)
+ src/Data/TypedEncoding/Instances/Restriction/UTF8.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE TypeApplications #-}++-- | 'UTF-8' encoding+module Data.TypedEncoding.Instances.Restriction.UTF8 where++import Data.TypedEncoding.Instances.Support++import Data.Proxy+import GHC.TypeLits++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Encoding as TE +import qualified Data.Text.Lazy.Encoding as TEL ++-- import qualified Data.ByteString.Char8 as B8+-- import qualified Data.ByteString.Lazy.Char8 as BL8++import Data.Either++-- $setup+-- >>> :set -XScopedTypeVariables -XKindSignatures -XMultiParamTypeClasses -XDataKinds -XPolyKinds -XPartialTypeSignatures -XFlexibleInstances -XTypeApplications+-- >>> import Test.QuickCheck+-- >>> import Test.QuickCheck.Instances.Text()+-- >>> import Test.QuickCheck.Instances.ByteString()+-- >>> import Data.TypedEncoding.Internal.Util (proxiedId)+-- >>> let prxyArb = Proxy :: Proxy (Either EncodeEx (Enc '["r-UTF8"] () B.ByteString))+-- >>> :{+-- >>> instance Arbitrary (Enc '["r-UTF8"] () B.ByteString) where +-- arbitrary = fmap (fromRight (emptyUTF8B ())) +-- . flip suchThat isRight +-- . fmap (proxiedId prxyArb . encodeFAll . toEncoding ()) $ arbitrary +-- :}++-- | empty string is valid utf8+emptyUTF8B :: c -> Enc '["r-UTF8"] c B.ByteString+emptyUTF8B c = unsafeSetPayload c "" ++-----------------+-- Conversions --+-----------------++-- Right tst = encodeFAll . toEncoding () $ "Hello World" :: Either EncodeEx (Enc '["r-UTF8"] () B.ByteString)+-- tstTxt = byteString2TextS tst++-- | Type-safer version of @Data.Text.Encoding.encodeUtf8@+--+-- >>> displ $ text2ByteStringS $ toEncoding () ("text" :: T.Text)+-- "MkEnc '[r-UTF8] () (ByteString text)"+text2ByteStringS :: Enc ys c T.Text -> Enc ("r-UTF8" ': ys) c B.ByteString+text2ByteStringS = withUnsafeCoerce TE.encodeUtf8++-- | Type-safer version of Data.Text.Encoding.decodeUtf8+--+-- >>> let Right tst = encodeFAll . toEncoding () $ "Hello World" :: Either EncodeEx (Enc '["r-UTF8"] () B.ByteString)+-- >>> displ $ byteString2TextS tst+-- "MkEnc '[] () (Text Hello World)"+byteString2TextS :: Enc ("r-UTF8" ': ys) c B.ByteString -> Enc ys c T.Text +byteString2TextS = withUnsafeCoerce TE.decodeUtf8++-- | Identity property "byteString2TextS . text2ByteStringS == id"+-- prop> \t -> t == (fromEncoding . txtBsSIdProp (Proxy :: Proxy '[]) . toEncoding () $ t)+txtBsSIdProp :: Proxy (ys :: [Symbol]) -> Enc ys c T.Text -> Enc ys c T.Text+txtBsSIdProp _ = byteString2TextS . text2ByteStringS ++-- | Identity property "text2ByteStringS . byteString2TextS == id".+--+-- prop> \(t :: Enc '["r-UTF8"] () B.ByteString) -> t == (bsTxtIdProp (Proxy :: Proxy '[]) $ t)+bsTxtIdProp :: Proxy (ys :: [Symbol]) -> Enc ("r-UTF8" ': ys) c B.ByteString -> Enc ("r-UTF8" ': ys) c B.ByteString+bsTxtIdProp _ = text2ByteStringS . byteString2TextS++text2ByteStringL :: Enc ys c TL.Text -> Enc ("r-UTF8" ': ys) c BL.ByteString+text2ByteStringL = withUnsafeCoerce TEL.encodeUtf8++byteString2TextL :: Enc ("r-UTF8" ': ys) c BL.ByteString -> Enc ys c TL.Text +byteString2TextL = withUnsafeCoerce TEL.decodeUtf8++-----------------+-- Encondings --+-----------------++prxyUtf8 = Proxy :: Proxy "r-UTF8"++-- TODO these are quick and dirty++-- | UTF8 encodings are defined for ByteString only as that would not make much sense for Text+--+-- >>> encodeFAll . toEncoding () $ "\xc3\xb1" :: Either EncodeEx (Enc '["r-UTF8"] () B.ByteString)+-- Right (MkEnc Proxy () "\195\177")+-- >>> encodeFAll . toEncoding () $ "\xc3\x28" :: Either EncodeEx (Enc '["r-UTF8"] () B.ByteString)+-- Left (EncodeEx "r-UTF8" (Cannot decode byte '\xc3': Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream))+--+-- Following test uses 'verEncoding' helper that checks that bytes are encoded as Right iff they are valid UTF8 bytes+--+-- prop> \(b :: B.ByteString) -> verEncoding b (fmap (fromEncoding . decodeAll . proxiedId (Proxy :: Proxy (Enc '["r-UTF8"] _ _))) . (encodeFAll :: _ -> Either EncodeEx _). toEncoding () $ b)++instance EncodeF (Either EncodeEx) (Enc xs c B.ByteString) (Enc ("r-UTF8" ': xs) c B.ByteString) where+ encodeF = implEncodeF_ prxyUtf8 (fmap TE.encodeUtf8 . TE.decodeUtf8')+instance (RecreateErr f, Applicative f) => RecreateF f (Enc xs c B.ByteString) (Enc ("r-UTF8" ': xs) c B.ByteString) where+ checkPrevF = implCheckPrevF (asRecreateErr @"r-UTF8" . fmap TE.encodeUtf8 . TE.decodeUtf8')+instance Applicative f => DecodeF f (Enc ("r-UTF8" ': xs) c B.ByteString) (Enc xs c B.ByteString) where+ decodeF = implTranP id ++instance EncodeF (Either EncodeEx) (Enc xs c BL.ByteString) (Enc ("r-UTF8" ': xs) c BL.ByteString) where+ encodeF = implEncodeF_ prxyUtf8 (fmap TEL.encodeUtf8 . TEL.decodeUtf8')+instance (RecreateErr f, Applicative f) => RecreateF f (Enc xs c BL.ByteString) (Enc ("r-UTF8" ': xs) c BL.ByteString) where+ checkPrevF = implCheckPrevF (asRecreateErr @"r-UTF8" . fmap TEL.encodeUtf8 . TEL.decodeUtf8')+instance Applicative f => DecodeF f (Enc ("r-UTF8" ': xs) c BL.ByteString) (Enc xs c BL.ByteString) where+ decodeF = implTranP id ++--- Utilities ---++-- | helper function checks that given ByteString, +-- if is encoded as Left is must be not Utf8 decodable+-- is is encoded as Right is must be Utf8 encodable +verEncoding :: B.ByteString -> Either err B.ByteString -> Bool+verEncoding bs (Left _) = isLeft . TE.decodeUtf8' $ bs+verEncoding bs (Right _) = isRight . TE.decodeUtf8' $ bs
src/Data/TypedEncoding/Instances/Support.hs view
@@ -1,11 +1,16 @@ --- | Exports for encoding instance creation+-- | Exports for instance creation.+-- +-- Contains typical things needed when implementing+-- encoding, decoding, recreate, or type to string conversions. module Data.TypedEncoding.Instances.Support ( -- * Types module Data.TypedEncoding.Internal.Types -- * Classes , module Data.TypedEncoding.Internal.Class+ -- * Combinators+ , module Data.TypedEncoding.Internal.Instances.Combinators ) where import Data.TypedEncoding.Internal.Types import Data.TypedEncoding.Internal.Class -+import Data.TypedEncoding.Internal.Instances.Combinators
+ src/Data/TypedEncoding/Instances/ToEncString/Common.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Common 'ToEncString' and 'FromEncString' instances.+module Data.TypedEncoding.Instances.ToEncString.Common where+++-- import qualified Data.Text as T+-- import qualified Data.Text.Lazy as TL+-- import qualified Data.ByteString as B+-- -- import qualified Data.ByteString.Lazy as BL++import Data.TypedEncoding.Instances.Support+import Data.TypedEncoding.Internal.Class.IsStringR++import Data.String+import Data.Proxy+import Data.Word+import Text.Read+import Data.Functor.Identity+++instance IsString str => ToEncString "r-()" str Identity () where+ toEncStringF _ = Identity $ MkEnc Proxy () (fromString "()")++instance IsString str => ToEncString "r-Int-decimal" str Identity Int where+ toEncStringF i = Identity $ MkEnc Proxy () (fromString . show $ i)++instance IsString str => ToEncString "r-Word8-decimal" str Identity Word8 where+ toEncStringF i = Identity $ MkEnc Proxy () (fromString . show $ i)++instance (IsStringR str, UnexpectedDecodeErr f, Applicative f) => FromEncString Word8 f str "r-Word8-decimal" where+ fromEncStringF = asUnexpected @ "r-Word8-decimal" . readEither . toString . getPayload
− src/Data/TypedEncoding/Instances/UTF8.hs
@@ -1,136 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE PartialTypeSignatures #-}--- | -module Data.TypedEncoding.Instances.UTF8 where--import Data.TypedEncoding.Instances.Support--- import Data.TypedEncoding.Internal.Utils (proxiedId)-import Data.TypedEncoding.Unsafe (withUnsafe)--import Data.Proxy-import Data.Functor.Identity-import GHC.TypeLits--import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Encoding as TE -import qualified Data.Text.Lazy.Encoding as TEL --import qualified Data.ByteString.Char8 as B8-import qualified Data.ByteString.Lazy.Char8 as BL8--import GHC.TypeLits-import Data.Char-import Control.Arrow-import Data.Text.Encoding.Error (UnicodeException)--import Data.Either---- $setup--- >>> :set -XScopedTypeVariables -XKindSignatures -XMultiParamTypeClasses -XDataKinds -XPolyKinds -XPartialTypeSignatures -XFlexibleInstances--- >>> import Test.QuickCheck--- >>> import Test.QuickCheck.Instances.Text()--- >>> import Test.QuickCheck.Instances.ByteString()--- >>> import Data.TypedEncoding.Internal.Utils (proxiedId)--- >>> let prxyArb = Proxy :: Proxy (Either EncodeEx (Enc '["r-UTF8"] () B.ByteString))--- >>> :{--- >>> instance Arbitrary (Enc '["r-UTF8"] () B.ByteString) where --- arbitrary = fmap (fromRight (emptyUTF8B ())) --- . flip suchThat isRight --- . fmap (proxiedId prxyArb . encodeFAll . toEncoding ()) $ arbitrary --- :}---- | empty string is valid utf8-emptyUTF8B :: c -> Enc '["r-UTF8"] c B.ByteString-emptyUTF8B c = unsafeSetPayload c "" ---------------------- Conversions ------------------------ Right tst = encodeFAll . toEncoding () $ "Hello World" :: Either EncodeEx (Enc '["r-UTF8"] () B.ByteString)--- tstTxt = byteString2TextS tst---- | Type-safer version of @Data.Text.Encoding.encodeUtf8@------ >>> displ $ text2ByteStringS $ toEncoding () ("text" :: T.Text)--- "MkEnc '[r-UTF8] () (ByteString text)"-text2ByteStringS :: Enc ys c T.Text -> Enc ("r-UTF8" ': ys) c B.ByteString-text2ByteStringS = withUnsafeCoerce TE.encodeUtf8---- | Type-safer version of Data.Text.Encoding.decodeUtf8------ >>> let Right tst = encodeFAll . toEncoding () $ "Hello World" :: Either EncodeEx (Enc '["r-UTF8"] () B.ByteString)--- >>> displ $ byteString2TextS tst--- "MkEnc '[] () (Text Hello World)"-byteString2TextS :: Enc ("r-UTF8" ': ys) c B.ByteString -> Enc ys c T.Text -byteString2TextS = withUnsafeCoerce TE.decodeUtf8---- | Identity property "byteString2TextS . text2ByteStringS == id"--- prop> \t -> t == (fromEncoding . txtBsSIdProp (Proxy :: Proxy '[]) . toEncoding () $ t)-txtBsSIdProp :: Proxy (ys :: [Symbol]) -> Enc ys c T.Text -> Enc ys c T.Text-txtBsSIdProp _ = byteString2TextS . text2ByteStringS ---- | Identity property "text2ByteStringS . byteString2TextS == id".------ prop> \(t :: Enc '["r-UTF8"] () B.ByteString) -> t == (bsTxtIdProp (Proxy :: Proxy '[]) $ t)-bsTxtIdProp :: Proxy (ys :: [Symbol]) -> Enc ("r-UTF8" ': ys) c B.ByteString -> Enc ("r-UTF8" ': ys) c B.ByteString-bsTxtIdProp _ = text2ByteStringS . byteString2TextS--text2ByteStringL :: Enc ys c TL.Text -> Enc ("r-UTF8" ': ys) c BL.ByteString-text2ByteStringL = withUnsafeCoerce TEL.encodeUtf8--byteString2TextL :: Enc ("r-UTF8" ': ys) c BL.ByteString -> Enc ys c TL.Text -byteString2TextL = withUnsafeCoerce TEL.decodeUtf8---------------------- Encondings ----------------------prxyUtf8 = Proxy :: Proxy "r-UTF8"---- TODO these are quick and dirty---- | UTF8 encodings are defined for ByteString only as that would not make much sense for Text------ >>> encodeFAll . toEncoding () $ "\xc3\xb1" :: Either EncodeEx (Enc '["r-UTF8"] () B.ByteString)--- Right (MkEnc Proxy () "\195\177")--- >>> encodeFAll . toEncoding () $ "\xc3\x28" :: Either EncodeEx (Enc '["r-UTF8"] () B.ByteString)--- Left (EncodeEx "r-UTF8" (Cannot decode byte '\xc3': Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream))------ Following test uses 'verEncoding' helper that checks that bytes are encoded as Right iff they are valid UTF8 bytes------ prop> \(b :: B.ByteString) -> verEncoding b (fmap (fromEncoding . decodeAll . proxiedId (Proxy :: Proxy (Enc '["r-UTF8"] _ _))) . (encodeFAll :: _ -> Either EncodeEx _). toEncoding () $ b)--instance EncodeF (Either EncodeEx) (Enc xs c B.ByteString) (Enc ("r-UTF8" ': xs) c B.ByteString) where- encodeF = implEncodeF prxyUtf8 (fmap TE.encodeUtf8 . TE.decodeUtf8')-instance (RecreateErr f, Applicative f) => RecreateF f (Enc xs c B.ByteString) (Enc ("r-UTF8" ': xs) c B.ByteString) where- checkPrevF = implCheckPrevF (asRecreateErr prxyUtf8 . fmap TE.encodeUtf8 . TE.decodeUtf8')-instance Applicative f => DecodeF f (Enc ("r-UTF8" ': xs) c B.ByteString) (Enc xs c B.ByteString) where- decodeF = implTranP id --instance EncodeF (Either EncodeEx) (Enc xs c BL.ByteString) (Enc ("r-UTF8" ': xs) c BL.ByteString) where- encodeF = implEncodeF prxyUtf8 (fmap TEL.encodeUtf8 . TEL.decodeUtf8')-instance (RecreateErr f, Applicative f) => RecreateF f (Enc xs c BL.ByteString) (Enc ("r-UTF8" ': xs) c BL.ByteString) where- checkPrevF = implCheckPrevF (asRecreateErr prxyUtf8 . fmap TEL.encodeUtf8 . TEL.decodeUtf8')-instance Applicative f => DecodeF f (Enc ("r-UTF8" ': xs) c BL.ByteString) (Enc xs c BL.ByteString) where- decodeF = implTranP id ----- Utilities ------- | helper function checks that given ByteString, --- if is encoded as Left is must be not Utf8 decodable--- is is encoded as Right is must be Utf8 encodable -verEncoding :: B.ByteString -> Either err B.ByteString -> Bool-verEncoding bs (Left _) = isLeft . TE.decodeUtf8' $ bs-verEncoding bs (Right _) = isRight . TE.decodeUtf8' $ bs
src/Data/TypedEncoding/Internal/Class.hs view
@@ -5,218 +5,62 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE UndecidableInstances #-}+-- {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}--- {-# LANGUAGE PartialTypeSignatures #-}+-- {-# LANGUAGE TypeFamilies #-}+-- {-# LANGUAGE TypeApplications #-}+-- {-# LANGUAGE AllowAmbiguousTypes #-} -module Data.TypedEncoding.Internal.Class where+module Data.TypedEncoding.Internal.Class (+ module Data.TypedEncoding.Internal.Class+ , module Data.TypedEncoding.Internal.Class.Util+ , module Data.TypedEncoding.Internal.Class.Encode+ , module Data.TypedEncoding.Internal.Class.Decode+ , module Data.TypedEncoding.Internal.Class.Recreate + ) where +import Data.TypedEncoding.Internal.Class.Util+import Data.TypedEncoding.Internal.Class.Encode+import Data.TypedEncoding.Internal.Class.Decode+import Data.TypedEncoding.Internal.Class.Recreate+ import Data.TypedEncoding.Internal.Types (Enc(..) - , toEncoding- , getPayload- , withUnsafeCoerce- , unsafeChangePayload- , RecreateEx(..)- , UnexpectedDecodeEx(..))-import Data.Proxy+ , withUnsafeCoerce) import Data.Functor.Identity import GHC.TypeLits-import Data.Semigroup ((<>))-import qualified Data.ByteString.Char8 as B-import qualified Data.ByteString.Lazy.Char8 as BL-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL -import qualified Data.List as L ---- $setup--- >>> :set -XScopedTypeVariables -XKindSignatures -XMultiParamTypeClasses -XDataKinds -XPolyKinds -XFlexibleInstances -XFlexibleContexts--- >>> import Data.TypedEncoding.Internal.Types (unsafeSetPayload)--class EncodeF f instr outstr where - encodeF :: instr -> f outstr--class EncodeFAll f (xs :: [k]) c str where- encodeFAll :: (Enc '[] c str) -> f (Enc xs c str)--instance Applicative f => EncodeFAll f '[] c str where- encodeFAll (MkEnc _ c str) = pure $ toEncoding c str --instance (Monad f, EncodeFAll f xs c str, EncodeF f (Enc xs c str) (Enc (x ': xs) c str)) => EncodeFAll f (x ': xs) c str where- encodeFAll str = - let re :: f (Enc xs c str) = encodeFAll str- in re >>= encodeF---encodeAll :: EncodeFAll Identity (xs :: [k]) c str => - (Enc '[] c str) - -> (Enc xs c str)-encodeAll = runIdentity . encodeFAll ----class DecodeF f instr outstr where - decodeF :: instr -> f outstr--class DecodeFAll f (xs :: [k]) c str where- decodeFAll :: (Enc xs c str) -> f (Enc '[] c str)--instance Applicative f => DecodeFAll f '[] c str where- decodeFAll (MkEnc _ c str) = pure $ toEncoding c str --instance (Monad f, DecodeFAll f xs c str, DecodeF f (Enc (x ': xs) c str) (Enc (xs) c str)) => DecodeFAll f (x ': xs) c str where- decodeFAll str = - let re :: f (Enc xs c str) = decodeF str- in re >>= decodeFAll--decodeAll :: DecodeFAll Identity (xs :: [k]) c str => - (Enc xs c str)- -> (Enc '[] c str) -decodeAll = runIdentity . decodeFAll ---- | Used to safely recover encoded data validating all encodingss-class RecreateF f instr outstr where - checkPrevF :: outstr -> f instr--class (Functor f) => RecreateFAll f (xs :: [k]) c str where- checkFAll :: (Enc xs c str) -> f (Enc '[] c str)- recreateFAll :: (Enc '[] c str) -> f (Enc xs c str)- recreateFAll str@(MkEnc _ _ pay) = - let str0 :: Enc xs c str = withUnsafeCoerce id str- in fmap (withUnsafeCoerce (const pay)) $ checkFAll str0 --instance Applicative f => RecreateFAll f '[] c str where- checkFAll (MkEnc _ c str) = pure $ toEncoding c str +-- TODO would be nice to have EncodeFAll1 and DecodeFAll1 that starts+-- end stops at frist encoding. +-- | +-- Generalized Java @toString@ or a type safe version of Haskell's 'Show'.+--+-- Encodes @a@ as @Enc '[xs]@.+--+class KnownSymbol x => ToEncString x str f a where+ toEncStringF :: a -> f (Enc '[x] () str) -instance (Monad f, RecreateFAll f xs c str, RecreateF f (Enc xs c str) (Enc (x ': xs) c str)) => RecreateFAll f (x ': xs) c str where- checkFAll str = - let re :: f (Enc xs c str) = checkPrevF str- in re >>= checkFAll+toEncString :: forall x str f a . (ToEncString x str Identity a) => a -> Enc '[x] () str+toEncString = runIdentity . toEncStringF -recreateAll :: RecreateFAll Identity (xs :: [k]) c str => - (Enc '[] c str) - -> (Enc xs c str)-recreateAll = runIdentity . recreateFAll -- ---- | TODO use singletons definition instead?-type family Append (xs :: [k]) (ys :: [k]) :: [k] where- Append '[] xs = xs- Append (y ': ys) xs = y ': (Append ys xs)--encodeFPart :: forall f xs xsf c str . (Functor f, EncodeFAll f xs c str) => Proxy xs -> (Enc xsf c str) -> f (Enc (Append xs xsf) c str)-encodeFPart p (MkEnc _ conf str) = - let re :: f (Enc xs c str) = encodeFAll $ MkEnc Proxy conf str- in (MkEnc Proxy conf . getPayload) <$> re --encodePart :: EncodeFAll Identity (xs :: [k]) c str => - Proxy xs - -> (Enc xsf c str)- -> (Enc (Append xs xsf) c str) -encodePart p = runIdentity . encodeFPart p+-- | +-- Reverse of 'ToEncString' decodes encoded string back to @a@+class (KnownSymbol x) => FromEncString a f str x where+ fromEncStringF :: Enc '[x] () str -> f a --- | Unsafe implementation guarded by safe type definition-decodeFPart :: forall f xs xsf c str . (Functor f, DecodeFAll f xs c str) => Proxy xs -> (Enc (Append xs xsf) c str) -> f (Enc xsf c str)-decodeFPart p (MkEnc _ conf str) = - let re :: f (Enc '[] c str) = decodeFAll $ MkEnc (Proxy :: Proxy xs) conf str- in (MkEnc Proxy conf . getPayload) <$> re - -decodePart :: DecodeFAll Identity (xs :: [k]) c str => - Proxy xs - -> (Enc (Append xs xsf) c str) - -> (Enc xsf c str) -decodePart p = runIdentity . decodeFPart p+fromEncString :: forall a str x . (FromEncString a Identity str x) => Enc '[x] () str -> a+fromEncString = runIdentity . fromEncStringF -- Other classes -- --- subsets are useful for restriction encodings+-- | subsets are useful for restriction encodings -- like r-UFT8 but not for other encodings.-class Subset (x :: k) (y :: k) where- inject :: Proxy y -> Enc (x ': xs) c str -> Enc (y ': xs) c str- inject _ = withUnsafeCoerce id--class FlattenAs (x :: k) (y :: k) where- flattenAs :: Proxy y -> Enc (x ': xs) c str -> Enc '[y] c str- flattenAs _ = withUnsafeCoerce id---- | Polymorphic data payloads used to encode/decode-class HasA c a where- has :: Proxy a -> c -> a--instance HasA a () where- has _ = const ()---- | With type safety in pace decoding errors should be unexpected--- this class can be used to provide extra info if decoding could fail-class UnexpectedDecodeErr f where - unexpectedDecodeErr :: UnexpectedDecodeEx -> f a--instance UnexpectedDecodeErr Identity where- unexpectedDecodeErr x = fail $ show x--instance UnexpectedDecodeErr (Either UnexpectedDecodeEx) where- unexpectedDecodeErr = Left --asUnexpected :: (UnexpectedDecodeErr f, Applicative f, Show err, KnownSymbol x) => Proxy x -> Either err a -> f a-asUnexpected p (Left err) = unexpectedDecodeErr $ UnexpectedDecodeEx p err-asUnexpected _ (Right r) = pure r---- TODO using RecreateErr typeclass is overkill---- | Recovery errors are expected unless Recovery allows Identity instance-class RecreateErr f where - recoveryErr :: RecreateEx -> f a--instance RecreateErr (Either RecreateEx) where- recoveryErr = Left --asRecreateErr :: (RecreateErr f, Applicative f, Show err, KnownSymbol x) => Proxy x -> Either err a -> f a-asRecreateErr p (Left err) = recoveryErr $ RecreateEx p err-asRecreateErr _ (Right r) = pure r----- * Display ---- | Human friendly version of Show-class Displ x where - displ :: x -> String--instance Displ String where- displ = id -instance Displ T.Text where- displ x = "(Text " ++ T.unpack x ++ ")"-instance Displ TL.Text where- displ x = "(TL.Text " ++ TL.unpack x ++ ")"-instance Displ B.ByteString where- displ x = "(ByteString " ++ B.unpack x ++ ")" -instance Displ BL.ByteString where- displ x = "(ByteString " ++ BL.unpack x ++ ")" ---instance Displ (Proxy '[]) where- displ _ = ""---- |--- >>> displ (Proxy :: Proxy ["FIRST", "SECOND"])--- "FIRST,SECOND"-instance (pxs ~ Proxy xs, Displ pxs, KnownSymbol x) => Displ (Proxy (x ': xs)) where- displ _ = L.dropWhileEnd (',' ==) $ symbolVal (Proxy :: Proxy x) ++ "," ++ displ (Proxy :: Proxy xs)---- >>> let disptest = unsafeSetPayload () "hello" :: Enc '["TEST"] () T.Text--- >>> displ disptest--- "MkEnc '[TEST] () hello"-instance (Displ (Proxy xs), Show c, Displ str) => Displ ( Enc xs c str) where- displ (MkEnc p c s) = - "MkEnc '[" ++ displ p ++ "] " ++ show c ++ " " ++ displ s----- Utils --+class Superset (y :: Symbol) (x :: Symbol) where+ inject :: Enc (x ': xs) c str -> Enc (y ': xs) c str+ inject = withUnsafeCoerce id -errorOnLeft :: Show err => Either err a -> a-errorOnLeft (Left e) = error $ "You trusted encodings too much " <> show e-errorOnLeft (Right r) = r+class FlattenAs (y :: Symbol) (x :: Symbol) where+ flattenAs :: Enc (x ': xs) c str -> Enc '[y] c str+ flattenAs = withUnsafeCoerce id
+ src/Data/TypedEncoding/Internal/Class/Decode.hs view
@@ -0,0 +1,81 @@++{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE AllowAmbiguousTypes #-}++module Data.TypedEncoding.Internal.Class.Decode where++import Data.TypedEncoding.Internal.Class.Util++import Data.TypedEncoding.Internal.Types (Enc(..) + , toEncoding+ , getPayload+ , UnexpectedDecodeEx(..))+import Data.Proxy+import Data.Functor.Identity+import GHC.TypeLits+++class DecodeF f instr outstr where + decodeF :: instr -> f outstr++class DecodeFAll f (xs :: [Symbol]) c str where+ decodeFAll :: Enc xs c str -> f (Enc '[] c str)++instance Applicative f => DecodeFAll f '[] c str where+ decodeFAll (MkEnc _ c str) = pure $ toEncoding c str ++instance (Monad f, DecodeFAll f xs c str, DecodeF f (Enc (x ': xs) c str) (Enc xs c str)) => DecodeFAll f (x ': xs) c str where+ decodeFAll str = + let re :: f (Enc xs c str) = decodeF str+ in re >>= decodeFAll++decodeAll :: DecodeFAll Identity (xs :: [Symbol]) c str => + Enc xs c str+ -> Enc '[] c str+decodeAll = runIdentity . decodeFAll +++decodeFPart_ :: forall f xs xsf c str . (Functor f, DecodeFAll f xs c str) => Proxy xs -> Enc (Append xs xsf) c str -> f (Enc xsf c str)+decodeFPart_ p (MkEnc _ conf str) = + let re :: f (Enc '[] c str) = decodeFAll $ MkEnc (Proxy :: Proxy xs) conf str+ in MkEnc Proxy conf . getPayload <$> re ++decodeFPart :: forall (xs :: [Symbol]) xsf f c str . (Functor f, DecodeFAll f xs c str) => Enc (Append xs xsf) c str -> f (Enc xsf c str)+decodeFPart = decodeFPart_ (Proxy :: Proxy xs) ++decodePart_ :: DecodeFAll Identity (xs :: [Symbol]) c str => + Proxy xs + -> Enc (Append xs xsf) c str + -> Enc xsf c str +decodePart_ p = runIdentity . decodeFPart_ p++decodePart :: forall (xs :: [Symbol]) xsf c str . DecodeFAll Identity xs c str => + Enc (Append xs xsf) c str + -> Enc xsf c str+decodePart = decodePart_ (Proxy :: Proxy xs) ++-- | With type safety in place decoding errors should be unexpected.+-- This class can be used to provide extra info if decoding could fail+class UnexpectedDecodeErr f where + unexpectedDecodeErr :: UnexpectedDecodeEx -> f a++instance UnexpectedDecodeErr Identity where+ unexpectedDecodeErr x = fail $ show x++instance UnexpectedDecodeErr (Either UnexpectedDecodeEx) where+ unexpectedDecodeErr = Left ++asUnexpected_ :: (KnownSymbol x, UnexpectedDecodeErr f, Applicative f, Show err) => Proxy x -> Either err a -> f a+asUnexpected_ p (Left err) = unexpectedDecodeErr $ UnexpectedDecodeEx p err+asUnexpected_ _ (Right r) = pure r++asUnexpected :: forall x f err a . (KnownSymbol x, UnexpectedDecodeErr f, Applicative f, Show err) => Either err a -> f a+asUnexpected = asUnexpected_ (Proxy :: Proxy x)
+ src/Data/TypedEncoding/Internal/Class/Encode.hs view
@@ -0,0 +1,71 @@++{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+-- {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE AllowAmbiguousTypes #-}++module Data.TypedEncoding.Internal.Class.Encode where++import Data.TypedEncoding.Internal.Class.Util++import Data.TypedEncoding.Internal.Types (Enc(..) + , toEncoding+ , getPayload+ )+import Data.Proxy+import Data.Functor.Identity+import GHC.TypeLits+++class EncodeF f instr outstr where + encodeF :: instr -> f outstr++class EncodeFAll f (xs :: [Symbol]) c str where+ encodeFAll :: Enc '[] c str -> f (Enc xs c str)++instance Applicative f => EncodeFAll f '[] c str where+ encodeFAll (MkEnc _ c str) = pure $ toEncoding c str ++instance (Monad f, EncodeFAll f xs c str, EncodeF f (Enc xs c str) (Enc (x ': xs) c str)) => EncodeFAll f (x ': xs) c str where+ encodeFAll str = + let re :: f (Enc xs c str) = encodeFAll str+ in re >>= encodeF+++encodeAll :: EncodeFAll Identity (xs :: [Symbol]) c str => + Enc '[] c str + -> Enc xs c str+encodeAll = runIdentity . encodeFAll ++++encodeFPart_ :: forall f xs xsf c str . (Functor f, EncodeFAll f xs c str) => Proxy xs -> Enc xsf c str -> f (Enc (Append xs xsf) c str)+encodeFPart_ p (MkEnc _ conf str) = + let re :: f (Enc xs c str) = encodeFAll $ MkEnc Proxy conf str+ in MkEnc Proxy conf . getPayload <$> re +++encodeFPart :: forall (xs :: [Symbol]) xsf f c str . (Functor f, EncodeFAll f xs c str) => Enc xsf c str -> f (Enc (Append xs xsf) c str)+encodeFPart = encodeFPart_ (Proxy :: Proxy xs) +++encodePart_ :: EncodeFAll Identity (xs :: [Symbol]) c str => + Proxy xs + -> Enc xsf c str+ -> Enc (Append xs xsf) c str +encodePart_ p = runIdentity . encodeFPart_ p++-- | for some reason ApplyTypes syntax does not want to work if xs is specified with +-- polymorphic [Symbol]+encodePart :: forall (xs :: [Symbol]) xsf c str . EncodeFAll Identity xs c str => + Enc xsf c str+ -> Enc (Append xs xsf) c str +encodePart = encodePart_ (Proxy :: Proxy xs) +
+ src/Data/TypedEncoding/Internal/Class/IsStringR.hs view
@@ -0,0 +1,64 @@+++{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE AllowAmbiguousTypes #-}++module Data.TypedEncoding.Internal.Class.IsStringR where++import Data.Proxy++import Data.String+-- import qualified Data.ByteString.Char8 as B+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL++++-- $setup+-- >>> :set -XScopedTypeVariables -XTypeApplications -XAllowAmbiguousTypes+-- >>> import Test.QuickCheck+-- >>> import Test.QuickCheck.Instances.Text()+-- >>> import Test.QuickCheck.Instances.ByteString()++-- | Reverses 'Data.String.IsString'+--+-- laws:+--+-- @+-- toString . fromString == id+-- fromString . toString == id+-- @+--+-- Note: ByteString is not a valid instance, ByteString "r-ASCII", or "r-UTF8" would+-- be needed.+-- @B.unpack $ B.pack "\160688" == "\176"@+class IsStringR a where+ toString :: a -> String++prop_fromStringToString :: forall s . (IsString s, IsStringR s, Eq s) => s -> Bool+prop_fromStringToString x = x == (fromString @s . toString $ x)++prop_toStringFromString :: forall s . (IsString s, IsStringR s) => Proxy s -> String -> Bool+prop_toStringFromString _ x = x == (toString @s . fromString $ x)++-- This would not work+-- @B.unpack $ B.pack "\160688" == "\176"@+--+-- prop> prop_toStringFromString (Proxy :: Proxy B.ByteString) +-- prop> prop_fromStringToString @B.ByteString+-- instance IsStringR B.ByteString where+-- toString = B.unpack+ ++-- |+-- prop> prop_toStringFromString (Proxy :: Proxy T.Text) +-- prop> prop_fromStringToString @T.Text+instance IsStringR T.Text where+ toString = T.unpack ++-- |+-- prop> prop_toStringFromString (Proxy :: Proxy TL.Text) +-- prop> prop_fromStringToString @TL.Text+instance IsStringR TL.Text where+ toString = TL.unpack
+ src/Data/TypedEncoding/Internal/Class/Recreate.hs view
@@ -0,0 +1,67 @@++{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+-- {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE AllowAmbiguousTypes #-}++module Data.TypedEncoding.Internal.Class.Recreate where++import Data.TypedEncoding.Internal.Types (Enc(..) + , toEncoding+ , withUnsafeCoerce+ , RecreateEx(..)+ )+import Data.Proxy+import Data.Functor.Identity+import GHC.TypeLits+++-- | Used to safely recover encoded data validating all encodingss+class RecreateF f instr outstr where + checkPrevF :: outstr -> f instr++class (Functor f) => RecreateFAll f (xs :: [Symbol]) c str where+ checkFAll :: Enc xs c str -> f (Enc '[] c str)+ recreateFAll :: Enc '[] c str -> f (Enc xs c str)+ recreateFAll str@(MkEnc _ _ pay) = + let str0 :: Enc xs c str = withUnsafeCoerce id str+ in withUnsafeCoerce (const pay) <$> checkFAll str0 ++instance Applicative f => RecreateFAll f '[] c str where+ checkFAll (MkEnc _ c str) = pure $ toEncoding c str +++instance (Monad f, RecreateFAll f xs c str, RecreateF f (Enc xs c str) (Enc (x ': xs) c str)) => RecreateFAll f (x ': xs) c str where+ checkFAll str = + let re :: f (Enc xs c str) = checkPrevF str+ in re >>= checkFAll+++recreateAll :: forall xs c str . RecreateFAll Identity xs c str => + Enc '[] c str + -> Enc xs c str+recreateAll = runIdentity . recreateFAll ++-- TODO using RecreateErr typeclass is overkill++-- | Recovery errors are expected unless Recovery allows Identity instance+class RecreateErr f where + recoveryErr :: RecreateEx -> f a++instance RecreateErr (Either RecreateEx) where+ recoveryErr = Left ++asRecreateErr_ :: (RecreateErr f, Applicative f, Show err, KnownSymbol x) => Proxy x -> Either err a -> f a+asRecreateErr_ p (Left err) = recoveryErr $ RecreateEx p err+asRecreateErr_ _ (Right r) = pure r+++asRecreateErr :: forall x f err a . (RecreateErr f, Applicative f, Show err, KnownSymbol x) => Either err a -> f a+asRecreateErr = asRecreateErr_ (Proxy :: Proxy x)
+ src/Data/TypedEncoding/Internal/Class/Util.hs view
@@ -0,0 +1,88 @@++{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE AllowAmbiguousTypes #-}++module Data.TypedEncoding.Internal.Class.Util where++import Data.TypedEncoding.Internal.Types.Common++import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as BL+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL++import Data.Proxy+import qualified Data.List as L+import GHC.TypeLits++-- $setup+-- >>> :set -XScopedTypeVariables -XTypeApplications -XAllowAmbiguousTypes -XDataKinds++-- * Symbol List++class SymbolList (xs::[Symbol]) where + symbolVals :: [String]++instance SymbolList '[] where+ symbolVals = []++-- |+-- >>> symbolVals @ '["FIRST", "SECOND"]+-- ["FIRST","SECOND"]+instance (SymbolList xs, KnownSymbol x) => SymbolList (x ': xs) where+ symbolVals = symbolVal (Proxy :: Proxy x) : symbolVals @xs+ +symbolVals_ :: forall xs . SymbolList xs => Proxy xs -> [String]+symbolVals_ _ = symbolVals @xs++-- * Display ++-- | Human friendly version of Show+class Displ x where + displ :: x -> String++instance Displ EncAnn where+ displ = id +instance Displ [EncAnn] where + displ x = "[" ++ L.intercalate "," (map displ x) ++ "]"+instance Displ T.Text where+ displ x = "(Text " ++ T.unpack x ++ ")"+instance Displ TL.Text where+ displ x = "(TL.Text " ++ TL.unpack x ++ ")"+instance Displ B.ByteString where+ displ x = "(ByteString " ++ B.unpack x ++ ")" +instance Displ BL.ByteString where+ displ x = "(ByteString " ++ BL.unpack x ++ ")" ++++-- |+-- >>> displ (Proxy :: Proxy ["FIRST", "SECOND"])+-- "[FIRST,SECOND]"+instance (SymbolList xs) => Displ (Proxy xs) where+ displ _ = displ $ symbolVals @ xs+ -- "[" ++ (L.intercalate "," $ map displ $ symbolVals @ xs) ++ "]"+++-- * Other++-- | TODO should this be imported from somewhere?+type family Append (xs :: [k]) (ys :: [k]) :: [k] where+ Append '[] xs = xs+ Append (y ': ys) xs = y ': Append ys xs++-- | Polymorphic data payloads used to encode/decode+class HasA a c where+ has :: c -> a++instance HasA () c where+ has = const ()
+ src/Data/TypedEncoding/Internal/Combinators.hs view
@@ -0,0 +1,51 @@++{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE DataKinds #-}+-- {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-}++module Data.TypedEncoding.Internal.Combinators where++import Data.TypedEncoding.Internal.Types+import Data.TypedEncoding.Internal.Class.IsStringR ()+import Data.TypedEncoding.Internal.Class.Recreate+import Data.TypedEncoding.Internal.Class.Util (SymbolList)+import GHC.TypeLits++-- $setup+-- >>> :set -XTypeApplications+-- >>> import qualified Data.Text as T+-- >>> import Data.Word++-- * Converting 'UncheckedEnc' to 'Enc'++-- | Maybe signals annotation mismatch, effect @f@ is not evaluated unless there is match+verifyUncheckedEnc :: forall (xs :: [Symbol]) f c str . (+ RecreateFAll f xs c str+ , RecreateErr f+ , Applicative f+ , SymbolList xs+ ) + =>+ UncheckedEnc c str+ -> Maybe (f (Enc xs c str))++verifyUncheckedEnc x = + -- let perr = Proxy :: Proxy "e-mismatch"+ --in + case verifyAnn @xs x of+ Left err -> Nothing -- asRecreateErr_ perr $ Left err+ Right (MkUncheckedEnc _ c str) -> Just $ recreateFAll . toEncoding c $ str+++verifyUncheckedEnc' :: forall (xs :: [Symbol]) c str . (+ RecreateFAll (Either RecreateEx) xs c str+ , SymbolList xs+ ) + =>+ UncheckedEnc c str+ -> Maybe (Either RecreateEx (Enc xs c str))+verifyUncheckedEnc' = verifyUncheckedEnc
+ src/Data/TypedEncoding/Internal/Instances/Combinators.hs view
@@ -0,0 +1,89 @@++{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- {-# LANGUAGE AllowAmbiguousTypes #-}+-- {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-}++-- | Combinators that can be helpful in instance creation.+module Data.TypedEncoding.Internal.Instances.Combinators where++import Data.String+import Data.Proxy+import Text.Read+import Data.TypedEncoding.Internal.Types+import Data.TypedEncoding.Internal.Class.IsStringR +import GHC.TypeLits++-- $setup+-- >>> :set -XTypeApplications+-- >>> import qualified Data.Text as T+-- >>> import Data.Word+++-- * Composite encodings from 'Foldable' 'Functor' types++-- | allows to fold payload in Enc to create another Enc, assumes homogeneous input encodings.+-- This yields not a type safe code, better implementation code should use fixed size+-- dependently typed @Vect n@ or some @HList@ like foldable.+foldEnc :: forall (xs2 :: [Symbol]) (xs1 :: [Symbol]) f c s1 s2 + . (Foldable f, Functor f) + => c -> (s1 -> s2 -> s2) -> s2 -> f (Enc xs1 c s1) -> Enc xs2 c s2+foldEnc c f sinit = unsafeSetPayload c . foldr f sinit . fmap getPayload ++-- | Similar to 'foldEnc', assumes that destination payload has @IsString@ instance and uses @""@ as base case. +foldEncStr :: forall (xs2 :: [Symbol]) (xs1 :: [Symbol]) f c s1 s2 + . (Foldable f, Functor f, IsString s2) + => c -> (s1 -> s2 -> s2) -> f (Enc xs1 c s1) -> Enc xs2 c s2+foldEncStr c f = foldEnc c f ""++-- | Similar to 'foldEnc', works with untyped 'CheckedEnc'+foldCheckedEnc :: forall (xs2 :: [Symbol]) f c s1 s2 + . (Foldable f, Functor f) + => c -> ([EncAnn] -> s1 -> s2 -> s2) -> s2 -> f (CheckedEnc c s1) -> Enc xs2 c s2+foldCheckedEnc c f sinit = unsafeSetPayload c . foldr (uncurry f) sinit . fmap getCheckedEncPayload++-- | Similar to 'foldEncStr', works with untyped 'CheckedEnc'+foldCheckedEncStr :: forall (xs2 :: [Symbol]) f c s1 s2 . (Foldable f, Functor f, IsString s2) => c -> ([EncAnn] -> s1 -> s2 -> s2) -> f (CheckedEnc c s1) -> Enc xs2 c s2+foldCheckedEncStr c f = foldCheckedEnc c f ""+++-- * Composite encoding: Recreate and Encode helpers++-- | Splits composite payload into homogenious chunks+splitPayload :: forall (xs2 :: [Symbol]) (xs1 :: [Symbol]) c s1 s2 . + (s1 -> [s2]) + -> Enc xs1 c s1 + -> [Enc xs2 c s2]+splitPayload f (MkEnc _ c s1) = map (MkEnc Proxy c) (f s1)+ +-- | Untyped version of 'splitPayload'+splitSomePayload :: forall c s1 s2 . + ([EncAnn] -> s1 -> [([EncAnn], s2)]) + -> CheckedEnc c s1 + -> [CheckedEnc c s2]+splitSomePayload f (MkCheckedEnc ann1 c s1) = map (\(ann2, s2) -> MkCheckedEnc ann2 c s2) (f ann1 s1)+++-- * Utility combinators ++-- | sometimes show . read is not identity, eg. Word8:+--+-- >>> read "256" :: Word8+-- 0+--+-- >>> verifyWithRead @Word8 "Word8-decimal" (T.pack "256")+-- Left "Payload does not satisfy format Word8-decimal: 256"+-- >>> verifyWithRead @Word8 "Word8-decimal" (T.pack "123")+-- Right "123"+verifyWithRead :: forall a str . (IsStringR str, IsString str, Read a, Show a) => String -> str -> Either String str+verifyWithRead msg x = + let s = toString x+ a :: Maybe a = readMaybe s+ check = (show <$> a) == Just s + in if check+ then Right x+ else Left $ "Payload does not satisfy format " ++ msg ++ ": " ++ s
src/Data/TypedEncoding/Internal/Types.hs view
@@ -1,95 +1,61 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-}-{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+-- {-# LANGUAGE RankNTypes #-} -- | -- Internal definition of types -module Data.TypedEncoding.Internal.Types where--import Data.Proxy-import Data.Functor.Identity-import GHC.TypeLits---- Not a Functor on purpose-data Enc enc conf str where- -- | constructor is to be treated as Unsafe to Encode and Decode instance implementations- -- particular encoding instances may expose smart constructors for limited data types- MkEnc :: Proxy enc -> conf -> str -> Enc enc conf str- deriving (Show, Eq) - -toEncoding :: conf -> str -> Enc '[] conf str-toEncoding conf str = MkEnc Proxy conf str--fromEncoding :: Enc '[] conf str -> str-fromEncoding = getPayload---- TODO make all implTran functions module-private--- TODO disambiguate implEncode from implDecode, from implCheckPrevF for type safety--- especially since these are always used in combo with asRecreateErr or asUnexpected --implTranF :: Functor f => (str -> f str) -> Enc enc1 conf str -> f (Enc enc2 conf str)-implTranF f = implTranF' (\c -> f)---- TODO could this type be more precise?-implEncodeF :: (Show err, KnownSymbol x) => Proxy x -> (str -> Either err str) -> Enc enc1 conf str -> Either EncodeEx (Enc enc2 conf str) -implEncodeF p f = implTranF (either (Left . EncodeEx p) Right . f) --implDecodeF :: Functor f => (str -> f str) -> Enc enc1 conf str -> f (Enc enc2 conf str)-implDecodeF = implTranF--implCheckPrevF :: Functor f => (str -> f str) -> Enc enc1 conf str -> f (Enc enc2 conf str)-implCheckPrevF = implTranF---implTranF' :: Functor f => (conf -> str -> f str) -> Enc enc1 conf str -> f (Enc enc2 conf str)-implTranF' f (MkEnc _ conf str) = (MkEnc Proxy conf) <$> f conf str--implEncodeF' :: (Show err, KnownSymbol x) => Proxy x -> (conf -> str -> Either err str) -> Enc enc1 conf str -> Either EncodeEx (Enc enc2 conf str) -implEncodeF' p f = implTranF' (\c -> either (Left . EncodeEx p) Right . f c) --implDecodeF' :: Functor f => (conf -> str -> f str) -> Enc enc1 conf str -> f (Enc enc2 conf str)-implDecodeF' = implTranF'--implTranP :: Applicative f => (str -> str) -> Enc enc1 conf str -> f (Enc enc2 conf str)-implTranP f = implTranF' (\c -> pure . f)--implEncodeP :: Applicative f => (str -> str) -> Enc enc1 conf str -> f (Enc enc2 conf str)-implEncodeP = implTranP--implTranP' :: Applicative f => (conf -> str -> str) -> Enc enc1 conf str -> f (Enc enc2 conf str)-implTranP' f = implTranF' (\c -> pure . f c)+module Data.TypedEncoding.Internal.Types (+ module Data.TypedEncoding.Internal.Types+ -- * Main encoding type and basic combinators.+ , module Data.TypedEncoding.Internal.Types.Enc+ -- * Untyped version and existentially quantified versions of Enc+ , module Data.TypedEncoding.Internal.Types.CheckedEnc+ -- * Not verified encoded data+ , module Data.TypedEncoding.Internal.Types.UncheckedEnc+ -- * Commmon types+ , module Data.TypedEncoding.Internal.Types.Common+ ) where -implEncodeP' :: Applicative f => (conf -> str -> str) -> Enc enc1 conf str -> f (Enc enc2 conf str)-implEncodeP' = implTranP'+import Data.TypedEncoding.Internal.Types.Enc+import Data.TypedEncoding.Internal.Types.CheckedEnc+import Data.TypedEncoding.Internal.Types.UncheckedEnc+import Data.TypedEncoding.Internal.Types.Common -getPayload :: Enc enc conf str -> str -getPayload (MkEnc _ _ str) = str--unsafeSetPayload :: conf -> str -> Enc enc conf str -unsafeSetPayload c str = MkEnc Proxy c str--withUnsafeCoerce :: (s1 -> s2) -> Enc e1 c s1 -> Enc e2 c s2-withUnsafeCoerce f (MkEnc _ conf str) = (MkEnc Proxy conf (f str)) --unsafeChangePayload :: (s1 -> s2) -> Enc e c s1 -> Enc e c s2-unsafeChangePayload f (MkEnc p conf str) = (MkEnc p conf (f str)) +import Data.Proxy+-- import Data.Functor.Identity+import GHC.TypeLits+-- import Data.TypedEncoding.Internal.Class.Util +-- $setup+-- >>> :set -XOverloadedStrings -XMultiParamTypeClasses -XDataKinds -XAllowAmbiguousTypes+-- >>> import qualified Data.Text as T -- | Represents errors in recovery (recreation of encoded types). data RecreateEx where- RecreateEx:: (Show e, KnownSymbol x) => Proxy x -> e -> RecreateEx + RecreateEx:: (Show e, KnownSymbol x) => Proxy x -> e -> RecreateEx+ RecreateExUnkStep:: (Show e) => e -> RecreateEx instance Show RecreateEx where show (RecreateEx prxy a) = "(RecreateEx \"" ++ symbolVal prxy ++ "\" (" ++ show a ++ "))"+ show (RecreateExUnkStep a) = "(UnknownDecodeStep (" ++ show a ++ "))" +recreateErrUnknown :: (Show e) => e -> RecreateEx+recreateErrUnknown = RecreateExUnkStep++-- instance Eq RecreateEx where+-- (RecreateEx prxy1 a1) == RecreateEx prxy2 a2 = (symbolVal prxy1) == (symbolVal prxy2)++ -- | Represents errors in encoding data EncodeEx where EncodeEx:: (Show a, KnownSymbol x) => Proxy x -> a -> EncodeEx @@ -98,7 +64,6 @@ show (EncodeEx prxy a) = "(EncodeEx \"" ++ symbolVal prxy ++ "\" (" ++ show a ++ "))" - -- | Type safety over encodings makes decoding process safe. -- However failures are still possible due to bugs or unsafe payload modifications. -- UnexpectedDecodeEx represents such errors.@@ -107,3 +72,18 @@ instance Show UnexpectedDecodeEx where show (UnexpectedDecodeEx prxy a) = "(UnexpectedDecodeEx \"" ++ symbolVal prxy ++ "\" (" ++ show a ++ "))"+++-- * Base combinators that rely on types defined here++-- TODO could this type be more precise?+implEncodeF_ :: (Show err, KnownSymbol x) => Proxy x -> (str -> Either err str) -> Enc enc1 conf str -> Either EncodeEx (Enc enc2 conf str) +implEncodeF_ p f = implTranF (either (Left . EncodeEx p) Right . f) ++implEncodeF :: forall x enc1 enc2 err conf str . + (Show err, KnownSymbol x) + => (str -> Either err str) -> Enc enc1 conf str -> Either EncodeEx (Enc enc2 conf str) +implEncodeF = implEncodeF_ (Proxy :: Proxy x)++implEncodeF_' :: (Show err, KnownSymbol x) => Proxy x -> (conf -> str -> Either err str) -> Enc enc1 conf str -> Either EncodeEx (Enc enc2 conf str) +implEncodeF_' p f = implTranF' (\c -> either (Left . EncodeEx p) Right . f c)
+ src/Data/TypedEncoding/Internal/Types/CheckedEnc.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- {-# LANGUAGE PolyKinds #-}+-- {-# LANGUAGE DataKinds #-}+-- {-# LANGUAGE TypeOperators #-}+-- {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE RankNTypes #-}++-- |+-- Module defines 'CheckedEnc' - untyped ADT version of 'Enc' ++module Data.TypedEncoding.Internal.Types.CheckedEnc where++import Data.TypedEncoding.Internal.Types.Enc+import Data.TypedEncoding.Internal.Types.Common+import Data.TypedEncoding.Internal.Class.Util+import Data.Proxy++-- $setup+-- >>> :set -XOverloadedStrings -XMultiParamTypeClasses -XDataKinds -XAllowAmbiguousTypes+-- >>> import qualified Data.Text as T+++-- * Untyped Enc++-- constructor is to be treated as Unsafe to Encode and Decode instance implementations+-- particular encoding instances may expose smart constructors for limited data types++-- | Represents some validated encoded string. +--+-- @CheckedEnc@ is untyped version of 'Data.TypedEncoding.Internal.Types.Enc.Enc'. +-- @CheckedEnc@ contains verified encoded data, encoding is visible+-- at the value level only.+data CheckedEnc conf str = MkCheckedEnc [EncAnn] conf str+ deriving (Show, Eq) ++unsafeCheckedEnc:: [EncAnn] -> c -> s -> CheckedEnc c s+unsafeCheckedEnc = MkCheckedEnc++getCheckedPayload :: CheckedEnc conf str -> str+getCheckedPayload = snd . getCheckedEncPayload++getCheckedEncPayload :: CheckedEnc conf str -> ([EncAnn], str) +getCheckedEncPayload (MkCheckedEnc t _ s) = (t,s)++toCheckedEnc :: forall xs c str . (SymbolList xs) => Enc xs c str -> CheckedEnc c str +toCheckedEnc (MkEnc p c s) = + MkCheckedEnc (symbolVals @ xs) c s +++fromCheckedEnc :: forall xs c str . SymbolList xs => CheckedEnc c str -> Maybe (Enc xs c str)+fromCheckedEnc (MkCheckedEnc xs c s) = + let p = Proxy :: Proxy xs+ in if symbolVals @ xs == xs+ then Just $ MkEnc p c s+ else Nothing++------------------------++-- |+-- >>> let encsometest = MkCheckedEnc ["TEST"] () $ T.pack "hello"+-- >>> proc_toCheckedEncFromCheckedEnc @'["TEST"] encsometest+-- True+-- >>> proc_toCheckedEncFromCheckedEnc @'["TEST1"] encsometest+-- False+proc_toCheckedEncFromCheckedEnc :: forall xs c str . (SymbolList xs, Eq c, Eq str) => CheckedEnc c str -> Bool+proc_toCheckedEncFromCheckedEnc x = (== Just x) . fmap (toCheckedEnc @ xs) . fromCheckedEnc $ x++-- |+-- >>> let enctest = unsafeSetPayload () "hello" :: Enc '["TEST"] () T.Text+-- >>> proc_fromCheckedEncToCheckedEnc enctest+-- True+proc_fromCheckedEncToCheckedEnc :: forall xs c str . (SymbolList xs, Eq c, Eq str) => Enc xs c str -> Bool+proc_fromCheckedEncToCheckedEnc x = (== Just x) . fromCheckedEnc . toCheckedEnc $ x++-- |+-- >>> displ $ unsafeCheckedEnc ["TEST"] () ("hello" :: T.Text)+-- "MkCheckedEnc [TEST] () (Text hello)"+instance (Show c, Displ str) => Displ (CheckedEnc c str) where+ displ (MkCheckedEnc xs c s) = + "MkCheckedEnc " ++ displ xs ++ " " ++ show c ++ " " ++ displ s+
+ src/Data/TypedEncoding/Internal/Types/Common.hs view
@@ -0,0 +1,4 @@+module Data.TypedEncoding.Internal.Types.Common where++-- | Represents value level (single) annotation.+type EncAnn = String
+ src/Data/TypedEncoding/Internal/Types/Enc.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+-- {-# LANGUAGE RankNTypes #-}++-- |+-- Internal definition of types++module Data.TypedEncoding.Internal.Types.Enc where++import Data.Proxy++import Data.TypedEncoding.Internal.Class.Util++-- $setup+-- >>> :set -XOverloadedStrings -XMultiParamTypeClasses -XDataKinds -XAllowAmbiguousTypes+-- >>> import qualified Data.Text as T++-- This type contains type level encoding information as well as+-- configuration and payload.+data Enc enc conf str where+ -- | constructor is to be treated as Unsafe to Encode and Decode instance implementations+ -- particular encoding instances may expose smart constructors for limited data types+ MkEnc :: Proxy enc -> conf -> str -> Enc enc conf str+ deriving (Show, Eq) ++-- |+-- >>> let disptest = unsafeSetPayload () "hello" :: Enc '["TEST"] () T.Text+-- >>> displ disptest+-- "MkEnc '[TEST] () (Text hello)"+instance (SymbolList xs, Show c, Displ str) => Displ ( Enc xs c str) where+ displ (MkEnc p c s) = + "MkEnc '" ++ displ (Proxy :: Proxy xs) ++ " " ++ show c ++ " " ++ displ s+++toEncoding :: conf -> str -> Enc '[] conf str+toEncoding = MkEnc Proxy ++fromEncoding :: Enc '[] conf str -> str+fromEncoding = getPayload++-- TODO make all implTran functions module-private+-- TODO disambiguate implEncode from implDecode, from implCheckPrevF for type safety+-- especially since these are always used in combo with asRecreateErr_ or asUnexpected ++implTranF :: Functor f => (str -> f str) -> Enc enc1 conf str -> f (Enc enc2 conf str)+implTranF f = implTranF' (const f)+++implDecodeF :: Functor f => (str -> f str) -> Enc enc1 conf str -> f (Enc enc2 conf str)+implDecodeF = implTranF++implCheckPrevF :: Functor f => (str -> f str) -> Enc enc1 conf str -> f (Enc enc2 conf str)+implCheckPrevF = implTranF+++implTranF' :: Functor f => (conf -> str -> f str) -> Enc enc1 conf str -> f (Enc enc2 conf str)+implTranF' f (MkEnc _ conf str) = MkEnc Proxy conf <$> f conf str+++implDecodeF' :: Functor f => (conf -> str -> f str) -> Enc enc1 conf str -> f (Enc enc2 conf str)+implDecodeF' = implTranF'++implTranP :: Applicative f => (str -> str) -> Enc enc1 conf str -> f (Enc enc2 conf str)+implTranP f = implTranF' (\c -> pure . f)++implEncodeP :: Applicative f => (str -> str) -> Enc enc1 conf str -> f (Enc enc2 conf str)+implEncodeP = implTranP++implTranP' :: Applicative f => (conf -> str -> str) -> Enc enc1 conf str -> f (Enc enc2 conf str)+implTranP' f = implTranF' (\c -> pure . f c)++implEncodeP' :: Applicative f => (conf -> str -> str) -> Enc enc1 conf str -> f (Enc enc2 conf str)+implEncodeP' = implTranP'+++getPayload :: Enc enc conf str -> str +getPayload (MkEnc _ _ str) = str++unsafeSetPayload :: conf -> str -> Enc enc conf str +unsafeSetPayload = MkEnc Proxy ++withUnsafeCoerce :: (s1 -> s2) -> Enc e1 c s1 -> Enc e2 c s2+withUnsafeCoerce f (MkEnc _ conf str) = MkEnc Proxy conf (f str)++unsafeChangePayload :: (s1 -> s2) -> Enc e c s1 -> Enc e c s2+unsafeChangePayload f (MkEnc p conf str) = MkEnc p conf (f str)
+ src/Data/TypedEncoding/Internal/Types/SomeAnnotation.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE RankNTypes #-}++-- | internally used existential type for taking track of annotations+module Data.TypedEncoding.Internal.Types.SomeAnnotation where++import Data.TypedEncoding.Internal.Types.Common+import Data.TypedEncoding.Internal.Class.Util+import Data.TypedEncoding.Internal.Util+import Data.Proxy+import GHC.TypeLits+++data SomeAnnotation where+ MkSomeAnnotation :: SymbolList xs => Proxy xs -> SomeAnnotation++withSomeAnnotation :: SomeAnnotation -> (forall xs . SymbolList xs => Proxy xs -> r) -> r+withSomeAnnotation (MkSomeAnnotation p) fn = fn p++-- folds over SomeSymbol list using withSomeSymbol and proxyCons+someAnnValue :: [EncAnn] -> SomeAnnotation+someAnnValue xs = + foldr (fn . someSymbolVal) (MkSomeAnnotation (Proxy :: Proxy '[])) xs+ where + somesymbs = map someSymbolVal xs+ fn ss (MkSomeAnnotation pxs) = withSomeSymbol ss (\px -> MkSomeAnnotation (px `proxyCons` pxs)) ++proxyCons :: forall (x :: Symbol) (xs :: [Symbol]) . Proxy x -> Proxy xs -> Proxy (x ': xs)+proxyCons _ _ = Proxy
+ src/Data/TypedEncoding/Internal/Types/SomeEnc.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- {-# LANGUAGE PolyKinds #-}+-- {-# LANGUAGE DataKinds #-}+-- {-# LANGUAGE TypeOperators #-}+-- {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE RankNTypes #-}++-- |+-- Module defines 'SomeEnc' - existentially quantified version of @Enc@+-- and basic combinators++module Data.TypedEncoding.Internal.Types.SomeEnc where++import Data.TypedEncoding.Internal.Types.Enc+import Data.TypedEncoding.Internal.Class.Util+import Data.TypedEncoding.Internal.Types.SomeAnnotation+import Data.TypedEncoding.Internal.Types.CheckedEnc++-- $setup+-- >>> :set -XOverloadedStrings -XMultiParamTypeClasses -XDataKinds -XAllowAmbiguousTypes+-- >>> import qualified Data.Text as T++++-- | Existentially quantified quanitified @Enc@+-- effectively isomorphic to 'CheckedEnc'+data SomeEnc conf str where+ MkSomeEnc :: SymbolList xs => Enc xs conf str -> SomeEnc conf str+ +withSomeEnc :: SomeEnc conf str -> (forall xs . SymbolList xs => Enc xs conf str -> r) -> r+withSomeEnc (MkSomeEnc enc) f = f enc++toSome :: SymbolList xs => Enc xs conf str -> SomeEnc conf str+toSome = MkSomeEnc++-- | +-- >>> let enctest = unsafeSetPayload () "hello" :: Enc '["TEST"] () T.Text+-- >>> someToChecked . MkSomeEnc $ enctest+-- MkCheckedEnc ["TEST"] () "hello"+someToChecked :: SomeEnc conf str -> CheckedEnc conf str+someToChecked se = withSomeEnc se toCheckedEnc++-- | +-- >>> let tst = unsafeCheckedEnc ["TEST"] () "test"+-- >>> displ $ checkedToSome tst+-- "Some (MkEnc '[TEST] () test)"+checkedToSome :: CheckedEnc conf str -> SomeEnc conf str+checkedToSome (MkCheckedEnc xs c s) = withSomeAnnotation (someAnnValue xs) (\p -> MkSomeEnc (MkEnc p c s))+++-- |+-- >>> let enctest = unsafeSetPayload () "hello" :: Enc '["TEST"] () T.Text+-- >>> displ $ MkSomeEnc enctest+-- "Some (MkEnc '[TEST] () (Text hello))"+instance (Show c, Displ str) => Displ (SomeEnc c str) where+ displ (MkSomeEnc en) = + "Some (" ++ displ en ++ ")"
+ src/Data/TypedEncoding/Internal/Types/UncheckedEnc.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE AllowAmbiguousTypes #-}++-- |+-- Internal definition of types++module Data.TypedEncoding.Internal.Types.UncheckedEnc where++import Data.Proxy+import Data.TypedEncoding.Internal.Class.Util+import Data.TypedEncoding.Internal.Types.Common++-- $setup+-- >>> :set -XOverloadedStrings -XMultiParamTypeClasses -XDataKinds -XAllowAmbiguousTypes+-- >>> import qualified Data.Text as T+++-- * UncheckedEnc for recreate, similar to CheckedEnc only not verified++-- | Represents some encoded string where encoding was not validated.+--+-- Similar to 'Data.TypedEncoding.Internal.Types.CheckedEnc' but unlike+-- @CheckedEnc@ it can contain payloads that have invalid encoding.+-- +data UncheckedEnc c str = MkUncheckedEnc [EncAnn] c str deriving (Show, Eq)++toUncheckedEnc :: [EncAnn] -> c -> str -> UncheckedEnc c str+toUncheckedEnc = MkUncheckedEnc++getUncheckedEncAnn :: UncheckedEnc c str -> [EncAnn]+getUncheckedEncAnn (MkUncheckedEnc ann _ _) = ann++verifyAnn :: forall xs c str . SymbolList xs => UncheckedEnc c str -> Either String (UncheckedEnc c str)+verifyAnn x@(MkUncheckedEnc xs _ _) = + let p = Proxy :: Proxy xs+ in if symbolVals @ xs == xs+ then Right x+ else Left $ "UncheckedEnc has not matching annotation " ++ displ xs++-- |+-- >>> displ $ MkUncheckedEnc ["TEST"] () ("hello" :: T.Text)+-- "MkUncheckedEnc [TEST] () (Text hello)"+instance (Show c, Displ str) => Displ (UncheckedEnc c str) where+ displ (MkUncheckedEnc xs c s) = + "MkUncheckedEnc " ++ displ xs ++ " " ++ show c ++ " " ++ displ s
+ src/Data/TypedEncoding/Internal/Types/Unsafe.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}++module Data.TypedEncoding.Internal.Types.Unsafe where++import Data.Proxy+import Data.TypedEncoding.Internal.Types++ +-- | Allows to operate within Enc. These are considered unsafe.+-- keeping the same list of encodings +newtype Unsafe enc conf str = Unsafe {runUnsafe :: Enc enc conf str} deriving (Show)++withUnsafe :: (Unsafe e c s1 -> Unsafe e c s2) -> Enc e c s1 -> Enc e c s2+withUnsafe f enc = runUnsafe . f $ Unsafe enc++instance Functor (Unsafe enc conf) where+ fmap f (Unsafe (MkEnc p c x)) = Unsafe (MkEnc p c (f x))+ +instance Applicative (Unsafe enc ()) where+ pure = Unsafe . MkEnc Proxy () + Unsafe (MkEnc p c1 f) <*> Unsafe (MkEnc _ c2 x) = Unsafe (MkEnc p () (f x)) ++instance Monad (Unsafe enc ()) where + Unsafe (MkEnc _ _ x) >>= f = f x +
+ src/Data/TypedEncoding/Internal/Util.hs view
@@ -0,0 +1,26 @@++{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}++module Data.TypedEncoding.Internal.Util where++import Data.Proxy+import GHC.TypeLits++explainBool :: (a -> err) -> (a, Bool) -> Either err a+explainBool _ (a, True) = Right a+explainBool f (a, False) = Left $ f a +++-- | Sometimes is easier to pass around a proxy than do TypeApplications+proxiedId :: Proxy a -> a -> a+proxiedId _ = id++-- | explicit mapM+extractEither :: Traversable t => t (Either err a) -> Either err (t a)+extractEither = sequence -- mapM id++withSomeSymbol :: SomeSymbol -> (forall x. KnownSymbol x => Proxy x -> r) -> r+withSomeSymbol s fn = case s of + SomeSymbol p -> fn p
− src/Data/TypedEncoding/Internal/Utils.hs
@@ -1,13 +0,0 @@-module Data.TypedEncoding.Internal.Utils where--import Data.Proxy--explainBool :: (a -> err) -> (a, Bool) -> Either err a-explainBool _ (a, True) = Right a-explainBool f (a, False) = Left $ f a ---proxiedId :: Proxy a -> a -> a-proxiedId _ = id--
src/Data/TypedEncoding/Unsafe.hs view
@@ -1,34 +1,12 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-}-{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-} -module Data.TypedEncoding.Unsafe where--import Data.Proxy-import Data.Functor.Identity-import Data.TypedEncoding.Internal.Types-- --- | Allows to operate within Enc. These are considered unsafe.--- keeping the same list of encodings -newtype Unsafe enc conf str = Unsafe {runUnsafe :: Enc enc conf str} deriving (Show)--withUnsafe :: (Unsafe e c s1 -> Unsafe e c s2) -> Enc e c s1 -> Enc e c s2-withUnsafe f enc = runUnsafe . f $ Unsafe enc--instance Functor (Unsafe enc conf) where- fmap f (Unsafe (MkEnc p c x)) = Unsafe (MkEnc p c (f x))- -instance Applicative (Unsafe enc ()) where- pure = Unsafe . MkEnc Proxy () - Unsafe (MkEnc p c1 f) <*> Unsafe (MkEnc _ c2 x) = Unsafe (MkEnc p () (f x)) --instance Monad (Unsafe enc ()) where - Unsafe (MkEnc _ _ x) >>= f = f x ----TODO JSON instances +module Data.TypedEncoding.Unsafe (+ module Data.TypedEncoding.Internal.Types.Unsafe+ ) where +import Data.TypedEncoding.Internal.Types.Unsafe
src/Examples/TypedEncoding.hs view
@@ -5,6 +5,8 @@ , module Examples.TypedEncoding.Conversions -- * Adding new encodings, error handling , module Examples.TypedEncoding.DiySignEncoding+ -- * Converting other types to and from encoded strings + , module Examples.TypedEncoding.ToEncString -- * Modifying encoded payload , module Examples.TypedEncoding.Unsafe ) where@@ -13,3 +15,4 @@ import Examples.TypedEncoding.Conversions import Examples.TypedEncoding.DiySignEncoding import Examples.TypedEncoding.Unsafe +import Examples.TypedEncoding.ToEncString
src/Examples/TypedEncoding/Conversions.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-} -- | Examples or moving between type annotated encodings --@@ -15,17 +16,17 @@ module Examples.TypedEncoding.Conversions where import Data.TypedEncoding-import qualified Data.TypedEncoding.Instances.Base64 as EnB64-import qualified Data.TypedEncoding.Instances.ASCII as EnASCII-import qualified Data.TypedEncoding.Instances.UTF8 as EnUTF8--import Data.Proxy+import qualified Data.TypedEncoding.Instances.Enc.Base64 as EnB64+import qualified Data.TypedEncoding.Instances.Restriction.ASCII as EnASCII+-- import qualified Data.TypedEncoding.Instances.Restriction.UTF8 as EnUTF8 import qualified Data.Text as T import qualified Data.ByteString as B -- $setup--- >>> :set -XOverloadedStrings -XMultiParamTypeClasses -XDataKinds+-- >>> :set -XOverloadedStrings -XMultiParamTypeClasses -XDataKinds -XTypeApplications+-- >>> import Data.TypedEncoding.Instances.Restriction.UTF8 ()+-- >>> import Data.Proxy -- -- This module contains some ghci friendly values to play with. --@@ -57,8 +58,9 @@ -- * Subsets + helloUtf8B :: Enc '["r-UTF8"] () B.ByteString-helloUtf8B = inject Proxy helloAsciiB+helloUtf8B = inject helloAsciiB -- ^ To get UTF8 annotation, instead of doing this: -- -- >>> encodeFAll . toEncoding () $ "HeLlo world" :: Either EncodeEx (Enc '["r-UTF8"] () B.ByteString)@@ -66,11 +68,11 @@ -- -- We should be able to convert the ASCII version. ----- This is done using 'Subset' typeclass.+-- This is done using 'Superset' typeclass. -- -- @inject@ method accepts proxy to specify superset to use. ----- >>> displ $ inject (Proxy :: Proxy "r-UTF8") helloAsciiB+-- >>> displ $ inject @ "r-UTF8" helloAsciiB -- "MkEnc '[r-UTF8] () (ByteString HeLlo world)" @@ -78,10 +80,10 @@ -- * More complex rules helloUtf8B64B :: Enc '["enc-B64", "r-UTF8"] () B.ByteString-helloUtf8B64B = encodePart (Proxy :: Proxy '["enc-B64"]) helloUtf8B +helloUtf8B64B = encodePart @'["enc-B64"] helloUtf8B -- ^ We put Base64 on the UFT8 ByteString ----- >>> displ $ encodePart (Proxy :: Proxy '["enc-B64"]) helloUtf8B+-- >>> displ $ encodePart_ (Proxy :: Proxy '["enc-B64"]) helloUtf8B -- "MkEnc '[enc-B64,r-UTF8] () (ByteString SGVMbG8gd29ybGQ=)" helloUtf8B64T :: Enc '["enc-B64"] () T.Text@@ -152,11 +154,11 @@ -- * Flattening b64IsAscii :: Enc '["r-ASCII"] () B.ByteString-b64IsAscii = flattenAs Proxy helloUtf8B64B+b64IsAscii = flattenAs helloUtf8B64B -- ^ Base 64 encodes binary data as ASCII text. -- thus, we should be able to treat "enc-B64" as "r-ASCII" losing some information. -- this is done using 'FlattenAs' type class ----- >>> :t flattenAs (Proxy :: Proxy "r-ASCII") helloUtf8B64B--- flattenAs (Proxy :: Proxy "r-ASCII") helloUtf8B64B+-- >>> :t flattenAs @ "r-ASCII" helloUtf8B64B+-- flattenAs @ "r-ASCII" helloUtf8B64B -- ... :: Enc '["r-ASCII"] () B.ByteString
src/Examples/TypedEncoding/DiySignEncoding.hs view
@@ -5,6 +5,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+ -- {-# LANGUAGE PartialTypeSignatures #-} -- | Simple DIY encoding example that "signs" Text with its length.@@ -27,14 +29,9 @@ import Data.TypedEncoding import qualified Data.TypedEncoding.Instances.Support as EnT -import Data.Proxy-import Data.Functor.Identity-import GHC.TypeLits- import qualified Data.Text as T import Data.Char import Data.Semigroup ((<>))-import Control.Arrow import Text.Read (readMaybe) -- $setup@@ -104,7 +101,6 @@ -- >>> recreateFAll . toEncoding () $ payload :: Either RecreateEx (Enc '["my-sign"] () T.Text) -- Right (MkEnc Proxy () "11:Hello World") -prxyMySign = Proxy :: Proxy "my-sign" -- | Because encoding function is pure we can create instance of EncodeF -- that is polymorphic in effect @f@. This is done using 'EnT.implTranP' combinator.@@ -117,9 +113,9 @@ -- 'UnexpectedDecodeErr' has Identity instance allowing for decoding that assumes errors are not possible. -- For debugging purposes or when unsafe changes to "my-sign" @Error UnexpectedDecodeEx@ instance can be used. instance (UnexpectedDecodeErr f, Applicative f) => DecodeF f (Enc ("my-sign" ': xs) c T.Text) (Enc xs c T.Text) where- decodeF = EnT.implDecodeF (asUnexpected prxyMySign . decodeSign) + decodeF = EnT.implDecodeF (asUnexpected @"my-sign" . decodeSign) -- | Recreation allows effectful @f@ to check for tampering with data. -- Implementation simply uses 'EnT.implCheckPrevF' combinator on the recovery function. instance (RecreateErr f, Applicative f) => RecreateF f (Enc xs c T.Text) (Enc ("my-sign" ': xs) c T.Text) where - checkPrevF = EnT.implCheckPrevF (asRecreateErr prxyMySign . decodeSign) + checkPrevF = EnT.implCheckPrevF (asRecreateErr @"my-sign" . decodeSign)
src/Examples/TypedEncoding/Overview.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-} -- | type-encoding overview examples. --@@ -10,28 +11,24 @@ -- -- This module uses encoding instances found in ----- * "Data.TypedEncoding.Instances.Base64"--- * "Data.TypedEncoding.Instances.ASCII"--- * "Data.TypedEncoding.Instances.Encode.Sample"+-- * "Data.TypedEncoding.Instances.Enc.Base64"+-- * "Data.TypedEncoding.Instances.Restriction.ASCII"+-- * "Data.TypedEncoding.Instances.Do.Sample" -- module Examples.TypedEncoding.Overview where import Data.TypedEncoding-import Data.TypedEncoding.Instances.Base64-import Data.TypedEncoding.Instances.ASCII-import Data.TypedEncoding.Instances.Encode.Sample+import Data.TypedEncoding.Instances.Enc.Base64 ()+import Data.TypedEncoding.Instances.Restriction.ASCII ()+import Data.TypedEncoding.Instances.Do.Sample -import GHC.TypeLits import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T-import Data.Proxy-import Data.Functor.Identity -- $setup--- >>> :set -XOverloadedStrings -XMultiParamTypeClasses -XDataKinds+-- >>> :set -XOverloadedStrings -XMultiParamTypeClasses -XDataKinds -XTypeApplications -- -- This module contains some ghci friendly values to play with. --@@ -68,6 +65,19 @@ -- -- >>> recreateFAll . toEncoding () $ "SGVsbG8gV29ybGQ" :: Either RecreateEx (Enc '["enc-B64"] () B.ByteString) -- Left (RecreateEx "enc-B64" ("invalid padding"))+--+-- The above example start by placing payload in zero-encoded @Enc '[] ()@ type and then apply 'recreateFAll'+-- this is a good way to recreate encoded type if encoding is known. +--+-- If is it not, 'UncheckedEnc' type can be used. +--+-- (See 'Examples.TypedEncoding.ToEncString' for better example).+-- +-- This module is concerned only with the first approach. +--+-- >>> let unchecked = toUncheckedEnc ["enc-B64"] () ("SGVsbG8gV29ybGQ=" :: T.Text)+-- >>> verifyUncheckedEnc' @'["enc-B64"] unchecked+-- Just (Right (MkEnc Proxy () "SGVsbG8gV29ybGQ=")) helloB64Recovered :: Either RecreateEx (Enc '["enc-B64"] () B.ByteString) helloB64Recovered = recreateFAll . toEncoding () $ "SGVsbG8gV29ybGQ=" @@ -84,13 +94,13 @@ -- | Double Base64 encoded "Hello World" with one layer of encoding removed ----- >>> decodePart (Proxy :: Proxy '["enc-B64"]) $ helloB64B64 :: Enc '["enc-B64"] () B.ByteString+-- >>> decodePart @'["enc-B64"] $ helloB64B64 :: Enc '["enc-B64"] () B.ByteString -- MkEnc Proxy () "SGVsbG8gV29ybGQ=" -- -- >>> helloB64B64PartDecode == helloB64 -- True helloB64B64PartDecode :: Enc '["enc-B64"] () B.ByteString-helloB64B64PartDecode = decodePart (Proxy :: Proxy '["enc-B64"]) $ helloB64B64+helloB64B64PartDecode = decodePart @'["enc-B64"] helloB64B64 -- | 'helloB64B64' all the way to 'B.ByteString' --@@ -101,14 +111,14 @@ -- -- We can also decode all the parts: ----- >>> fromEncoding . decodePart (Proxy :: Proxy '["enc-B64","enc-B64"]) $ helloB64B64+-- >>> fromEncoding . decodePart @'["enc-B64","enc-B64"] $ helloB64B64 -- "Hello World" helloB64B64Decoded :: B.ByteString helloB64B64Decoded = fromEncoding . decodeAll $ helloB64B64 -- | what happens when we try to recover encoded once text to @Enc '["enc-B64", "enc-B64"]@. ----- Again, notice the same expression is used as in previous recovery.+-- Again, notice the same expression is used as in previous recovery. -- -- >>> recreateFAll . toEncoding () $ "SGVsbG8gV29ybGQ=" :: Either RecreateEx (Enc '["enc-B64", "enc-B64"] () B.ByteString) -- Left (RecreateEx "enc-B64" ("invalid padding"))@@ -120,7 +130,7 @@ -- * "do-" Encodings -- |--- "do-UPPER" (from 'Data.TypedEncoding.Instances.Encode.Sample' module) encoding applied to "Hello World"+-- "do-UPPER" (from 'Data.TypedEncoding.Instances.Do.Sample' module) encoding applied to "Hello World" -- -- Notice a namespace thing going on, "enc-" is encoding, "do-" is some transformation. -- These are typically not reversible, some could be recoverable.@@ -144,13 +154,13 @@ -- * Configuration -- | Example configuration-data Config = Config {+newtype Config = Config { sizeLimit :: SizeLimit } deriving (Show) exampleConf = Config (SizeLimit 8) -instance HasA Config SizeLimit where- has _ = sizeLimit +instance HasA SizeLimit Config where+ has = sizeLimit -- | `helloTitle' is needed in following examples --@@ -171,10 +181,10 @@ -- -- Instead, encode previously defined 'helloTitle' by reversing it and adding size limit ----- >>> encodePart (Proxy :: Proxy '["do-size-limit", "do-reverse"]) helloTitle :: Enc '["do-size-limit", "do-reverse", "do-Title"] Config T.Text+-- >>> encodePart @'["do-size-limit", "do-reverse"] helloTitle :: Enc '["do-size-limit", "do-reverse", "do-Title"] Config T.Text -- MkEnc Proxy (Config {sizeLimit = SizeLimit {unSizeLimit = 8}}) "dlroW ol" helloRevLimit :: Enc '["do-size-limit", "do-reverse", "do-Title"] Config T.Text-helloRevLimit = encodePart (Proxy :: Proxy '["do-size-limit", "do-reverse"]) helloTitle+helloRevLimit = encodePart @'["do-size-limit", "do-reverse"] helloTitle -- >>> encodeAll . toEncoding exampleConf $ "HeLlo world" :: Enc '["enc-B64", "do-size-limit"] Config B.ByteString -- MkEnc Proxy (Config {sizeLimit = SizeLimit {unSizeLimit = 8}}) "SGVMbG8gd28="@@ -183,10 +193,10 @@ -- | ... and we unwrap the B64 part only -- --- >>> decodePart (Proxy :: Proxy '["enc-B64"]) $ helloLimitB64+-- >>> decodePart @'["enc-B64"] $ helloLimitB64 -- MkEnc Proxy (Config {sizeLimit = SizeLimit {unSizeLimit = 8}}) "HeLlo wo" helloRevLimitParDec :: Enc '["do-size-limit"] Config B.ByteString-helloRevLimitParDec = decodePart (Proxy :: Proxy '["enc-B64"]) $ helloLimitB64+helloRevLimitParDec = decodePart @'["enc-B64"] helloLimitB64 @@ -217,7 +227,7 @@ helloAsciiB64 = encodeFAll . toEncoding () $ "Hello World" -- |--- >>> decodePart (Proxy :: Proxy '["enc-B64"]) <$> helloAsciiB64+-- >>> decodePart @'["enc-B64"] <$> helloAsciiB64 -- Right (MkEnc Proxy () "Hello World") helloAsciiB64PartDec :: Either EncodeEx (Enc '["r-ASCII"] () B.ByteString)-helloAsciiB64PartDec = decodePart (Proxy :: Proxy '["enc-B64"]) <$> helloAsciiB64 +helloAsciiB64PartDec = decodePart @'["enc-B64"] <$> helloAsciiB64
+ src/Examples/TypedEncoding/ToEncString.hs view
@@ -0,0 +1,315 @@+{-# LANGUAGE MultiParamTypeClasses #-}+-- {-# LANGUAGE PolyKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PartialTypeSignatures #-}++{-# OPTIONS_GHC -Wno-partial-type-signatures #-}++-- |+-- This module shows use of 'ToEncString' and 'FromEncString'+-- and demonstrates /composite/ encoding.+--+-- @Show@ and @Read@ classes use a very permissive String type. This often results in +-- read errors. type-encoding approach provides type safety over decoding process.+--+-- This module includes a simplified email example. This is a non-homogenious case, +-- email parts do not have the same encoding. +--+-- Examples here could be made more type safe with use of dependently typed+-- concepts like @Vect@, @HList@ or variant equivalents of these types.+--+-- Current version of typed-encoding does not have dependencies on such types. +--+-- These examples use 'CheckedEnc' when untyped version of 'Enc' is needed.+-- Alternatively, an existentially quantified 'SomeEnc' type could have been used.+-- Both are isomorphic. +module Examples.TypedEncoding.ToEncString where++import Data.TypedEncoding+import qualified Data.TypedEncoding.Instances.Support as EnT+import Data.TypedEncoding.Instances.Restriction.Common ()+import Data.TypedEncoding.Instances.ToEncString.Common ()+import Data.TypedEncoding.Instances.Enc.Base64 ()+import Data.TypedEncoding.Instances.Restriction.ASCII ()+import Data.TypedEncoding.Instances.Restriction.UTF8 ()++import Data.Word+import Data.Functor.Identity+import qualified Data.Text as T+import qualified Data.ByteString as B+import Control.Applicative -- ((<|>))+import Data.Maybe+import Data.Semigroup ((<>))++++-- $setup+-- >>> :set -XMultiParamTypeClasses -XDataKinds -XPolyKinds -XFlexibleInstances -XTypeApplications -XOverloadedStrings+-- >>> import qualified Data.List as L+++-- * IpV4 example++type IpV4 = IpV4F Word8++-- | +-- In this example all data fields have the same type. +-- This simplifies encoding work as all fields will be encoded the same way.+-- We use IP address since all fields are single byte size.+data IpV4F a = IpV4F {+ oct1 :: a+ , oct2 :: a+ , oct3 :: a+ , oct4 :: a+ } deriving (Show, Functor, Foldable)++tstIp :: IpV4+tstIp = IpV4F 128 1 1 10++++-- |+-- In this example @toEncString@ converts 'IpV4' to @Enc '["r-IPv4"] Text@.+-- +-- This is done with help of existing @"r-Word8-decimal"@ annotation defined+-- in "Data.TypedEncoding.Instances.Restriction.Common"+--+-- >>> toEncString @"r-IPv4" @T.Text tstIp+-- MkEnc Proxy () "128.1.1.10"+--+-- Implementation is a classic map reduce where reduce is done with help of+-- 'EnT.foldEncStr'+--+-- >>> let fn a b = if b == "" then a else a <> "." <> b+-- >>> let reduce = EnT.foldEncStr @'["r-IPv4"] @'["r-Word8-decimal"] () fn+-- >>> displ . reduce . fmap toEncString $ tstIp+-- "MkEnc '[r-IPv4] () 128.1.1.10" +--+-- Note lack of type safety here, the same code would work just fine if we added+-- 5th field to 'IpV4F' constructor. +--+-- Using something like a dependently typed+--+-- @+-- Vect 4 (Enc '["r-Word8-decimal"] () T.Text)+-- @ +-- +-- would have improved this situation.+-- @HList@ could be used for record types with heterogeneous fields.+--+-- Currently, 'type-encoding' library does not have these types in scope. +instance ToEncString "r-IPv4" T.Text Identity IpV4 where+ toEncStringF = Identity . reduce . map+ where map :: IpV4F Word8 -> IpV4F (Enc '["r-Word8-decimal"] () T.Text) + map = fmap toEncString++ reduce :: IpV4F (Enc '["r-Word8-decimal"] () T.Text) -> Enc '["r-IPv4"] () T.Text + reduce = EnT.foldEncStr () (\a b-> if b == "" then a else a <> "." <> b) ++-- |+--+-- >>> let enc = toEncString @"r-IPv4" @T.Text tstIp+-- >>> fromEncString @IpV4 enc+-- IpV4F {oct1 = 128, oct2 = 1, oct3 = 1, oct4 = 10}+--+-- To get 'IpV4' out of the string we need to reverse previous @reduce@.+-- This is currently done using helper 'EnT.splitPayload' combinator. +--+-- >>> EnT.splitPayload @ '["r-Word8-decimal"] (T.splitOn $ T.pack ".") $ enc +-- [MkEnc Proxy () "128",MkEnc Proxy () "1",MkEnc Proxy () "1",MkEnc Proxy () "10"]+-- +-- The conversion of a list to IpV4F needs handle errors but these errors +-- are considered unexpected.+--+-- Note, again, the error condition exposed by this implementation could have been avoided+-- if 'EnT.splitPayload' returned fixed size @Vect 4@.+instance (UnexpectedDecodeErr f, Applicative f) => FromEncString IpV4 f T.Text "r-IPv4" where + fromEncStringF = fmap map . unreduce+ where unreduce :: Enc '["r-IPv4"] () T.Text -> f (IpV4F (Enc '["r-Word8-decimal"] () T.Text))+ unreduce = asUnexpected @"r-IPv4" . recover . EnT.splitPayload @ '["r-Word8-decimal"] (T.splitOn ".")+ + map :: IpV4F (Enc '["r-Word8-decimal"] () T.Text) -> IpV4F Word8 + map = fmap fromEncString++ recover :: Show a => [a] -> Either String (IpV4F a)+ recover [o1,o2,o3,o4] = pure $ IpV4F o1 o2 o3 o4+ recover x = Left $ "Invalid Content" ++ show x+++++-- * Simplified email example+++-- | Simplified Part header +type PartHeader = [String]++-- | Simplified Email header +type EmailHeader = String++-- | This section shows a type safe processing of emails.+--+-- 'SimplifiedEmailF' is an over-simplified email type, it has parts that can be either +-- +-- * binary and have to be Base 64 encoded or +-- * are text that have either UTF8 or ASCII character set +--+-- The text parts can be optionally can be Base 64 encoded but do not have to be.+--+-- For simplicity, the layout of simplified headers is assumed the same as encoding annotations in this library.+data SimplifiedEmailF a = SimplifiedEmailF {+ emailHeader :: EmailHeader+ , parts :: [a]+ } deriving (Show, Eq, Functor, Foldable, Traversable)++type SimplifiedEmail = SimplifiedEmailF (PartHeader, B.ByteString)++type SimplifiedEmailEncB = SimplifiedEmailF (CheckedEnc () B.ByteString)++-- TODO+-- type SimplifiedEmailEncT = SimplifiedEmailF (CheckedEnc () T.Text)++-- | @tstEmail@ contains some simple data to play with+tstEmail :: SimplifiedEmail+tstEmail = SimplifiedEmailF {+ emailHeader = "Some Header"+ , parts = [+ (["enc-B64","image"], "U29tZSBBU0NJSSBUZXh0") + , (["enc-B64","r-ASCII"], "U29tZSBBU0NJSSBUZXh0")+ , (["enc-B64","r-UTF8"], "U29tZSBVVEY4IFRleHQ=") + , (["r-ASCII"], "Some ASCII plain text") + ]+ }++-- | +-- This example encodes fields in 'SimplifiedEmailF' into an untyped version of @Enc@ which +-- stores verified encoded data and encoding information is stored at the value level: +-- @CheckedEnc () B.ByteString@.+-- +-- Part of email are first converted to 'UncheckedEnc' (that stores encoding information at the value level as well).+-- 'UncheckedEnc' that can easily represent parts of the email+--+-- >>> let part = parts tstEmail L.!! 2+-- >>> part+-- (["enc-B64","r-UTF8"],"U29tZSBVVEY4IFRleHQ=")+-- >>> let unchecked = toUncheckedEnc (fst part) () (snd part)+-- >>> unchecked +-- MkUncheckedEnc ["enc-B64","r-UTF8"] () "U29tZSBVVEY4IFRleHQ="+--+-- We can play 'Alternative' ('<|>') game (we acually use @Maybe@) with final option being a 'RecreateEx' error:+--+-- >>> verifyUncheckedEnc' @'["enc-B64","r-ASCII"] $ unchecked+-- Nothing+-- >>> verifyUncheckedEnc' @'["enc-B64","r-UTF8"] $ unchecked+-- Just (Right (MkEnc Proxy () "U29tZSBVVEY4IFRleHQ="))+--+-- Since the data is heterogeneous (each piece has a different encoding annotation), we need wrap the result in another plain ADT: 'CheckedEnc'.+-- +-- 'CheckedEnc' is similar to 'UncheckedEnc' with the difference that the only (safe) way to get values of this type is+-- from properly encoded 'Enc' values. +--+-- Using 'unsafeCheckedEnc' would break type safety here. +-- +-- It is important to handle all cases during encoding so decoding errors become impossible.+--+-- Again, use of dependently typed variant types that could enumerate all possible encodings+-- would made this code nicer.+recreateEncoding :: SimplifiedEmail -> Either RecreateEx SimplifiedEmailEncB+recreateEncoding = mapM encodefn+ where + -- | simplified parse header assumes email has the same layout as encodings+ -- image is ingored, since [enc-B64] annotation on ByteString permits base 64+ -- encoded bytes+ parseHeader :: PartHeader -> [EncAnn]+ parseHeader ["enc-B64","image"] = ["enc-B64"] + parseHeader x = x++ encodefn :: (PartHeader, B.ByteString) -> Either RecreateEx (CheckedEnc () B.ByteString)+ encodefn (parth, body) = + runAlternatives' (fromMaybe def) [try1, try2, try3, try4, try5] body+ where+ unchecked = toUncheckedEnc (parseHeader parth) () + try1 = fmap (fmap toCheckedEnc) . verifyUncheckedEnc' @'["enc-B64","r-UTF8"] . unchecked+ try2 = fmap (fmap toCheckedEnc) . verifyUncheckedEnc' @'["enc-B64","r-ASCII"] . unchecked+ try3 = fmap (fmap toCheckedEnc) . verifyUncheckedEnc' @'["r-ASCII"] . unchecked+ try4 = fmap (fmap toCheckedEnc) . verifyUncheckedEnc' @'["r-UTF8"] . unchecked+ try5 = fmap (fmap toCheckedEnc) . verifyUncheckedEnc' @'["enc-B64"] . unchecked+ def = Left $ recreateErrUnknown ("Invalid Header " ++ show parth) +++-- | +-- Example decodes parts of email that are base 64 encoded text and nothing else.+--+-- This provides a type safety assurance that we do not decode certain parts of email+-- (like trying to decode base 64 on a plain text part).+--+-- >>> decodeB64ForTextOnly <$> recreateEncoding tstEmail+-- Right (SimplifiedEmailF {emailHeader = "Some Header", parts = [MkCheckedEnc ["enc-B64"] () "U29tZSBBU0NJSSBUZXh0",MkCheckedEnc ["r-ASCII"] () "Some ASCII Text",MkCheckedEnc ["r-UTF8"] () "Some UTF8 Text",MkCheckedEnc ["r-ASCII"] () "Some ASCII plain text"]})+--+-- Combinator @fromCheckedEnc \@'["enc-B64", "r-UTF8"]@ acts as a selector and picks only the+-- @["enc-B64", "r-UTF8"]@ values from our 'Traversable' type. +--+-- We play the ('<|>') game on all the selectors we want picking and decoding right pieces only.+--+-- Imagine this is one of the pieces:+--+-- >>> let piece = unsafeCheckedEnc ["enc-B64","r-ASCII"] () ("U29tZSBBU0NJSSBUZXh0" :: B.ByteString)+-- >>> displ piece+-- "MkCheckedEnc [enc-B64,r-ASCII] () (ByteString U29tZSBBU0NJSSBUZXh0)"+--+-- This code will not pick it up:+--+-- >>> fromCheckedEnc @ '["enc-B64", "r-UTF8"] $ piece+-- Nothing+--+-- But this one will:+--+-- >>> fromCheckedEnc @ '["enc-B64", "r-ASCII"] $ piece+-- Just (MkEnc Proxy () "U29tZSBBU0NJSSBUZXh0")+--+-- so we can apply the decoding on the selected piece +--+-- >>> fmap (toCheckedEnc . decodePart @'["enc-B64"]) . fromCheckedEnc @ '["enc-B64", "r-ASCII"] $ piece+-- Just (MkCheckedEnc ["r-ASCII"] () "Some ASCII Text")++decodeB64ForTextOnly :: SimplifiedEmailEncB -> SimplifiedEmailEncB+decodeB64ForTextOnly = fmap (runAlternatives fromMaybe [tryUtf8, tryAscii]) + where+ tryUtf8, tryAscii :: CheckedEnc c B.ByteString -> Maybe (CheckedEnc c B.ByteString)+ tryUtf8 = fmap (toCheckedEnc . decodeToUtf8) . fromCheckedEnc @ '["enc-B64", "r-UTF8"] + tryAscii = fmap (toCheckedEnc . decodeToAscii) . fromCheckedEnc @ '["enc-B64", "r-ASCII"] + + decodeToUtf8 :: Enc '["enc-B64", "r-UTF8"] c B.ByteString -> _+ decodeToUtf8 = decodePart @'["enc-B64"]++ decodeToAscii :: Enc '["enc-B64", "r-ASCII"] c B.ByteString -> _+ decodeToAscii = decodePart @'["enc-B64"]+++-- * Helpers++-- | Provides easy to read encoding information+instance Displ a => Displ (IpV4F a) where+ displ = show . fmap displ++-- | Provides easy to read encoding information+instance Displ a => Displ (SimplifiedEmailF a) where+ displ = show . fmap displ ++runAlternatives' :: Alternative f => (f b -> b) -> [a -> f b] -> a -> b+runAlternatives' defF fns = defF . alternatives fns++runAlternatives :: Alternative f => (a -> f b -> b) -> [a -> f b] -> a -> b+runAlternatives defF fns a = defF a . alternatives fns $ a++alternatives :: Alternative f => [a -> f b] -> a -> f b+alternatives fns a = foldr ((<|>) . ($ a)) empty fns
src/Examples/TypedEncoding/Unsafe.hs view
@@ -14,18 +14,13 @@ module Examples.TypedEncoding.Unsafe where --import Data.Proxy- import qualified Data.Text as T--import Data.Char+import Data.Semigroup ((<>)) import Data.TypedEncoding-import qualified Data.TypedEncoding.Instances.ASCII as EnASCII import qualified Data.TypedEncoding.Unsafe as Unsafe+import qualified Data.TypedEncoding.Instances.Restriction.ASCII() -import Data.Semigroup ((<>)) -- $setup -- >>> :set -XOverloadedStrings -XMultiParamTypeClasses -XDataKinds@@ -48,6 +43,8 @@ -- >>> recreateFAll . toEncoding () $ newPayload :: Either RecreateEx (Enc '["r-ASCII"] () T.Text) -- Right (MkEnc Proxy () "HELLO some extra stuff") --+-- Alternatively, 'UncheckedEnc' type can be used in recreation, see 'Examples.TypedEncoding.Overview'+-- modifiedAsciiT :: Either RecreateEx (Enc '["r-ASCII"] () T.Text) modifiedAsciiT = recreateFAll . toEncoding () . ( <> " some extra stuff") . getPayload $ exAsciiT @@ -70,7 +67,7 @@ -- but @Enc '["r-ASCII"] () T.Text@ does not expose it -- We use Functor instance of Unsafe wrapper type to accomplish this toLowerAscii :: Either EncodeEx (Enc '["r-ASCII"] () T.Text)-toLowerAscii = exAsciiTE >>= pure . Unsafe.withUnsafe (fmap T.toLower)+toLowerAscii = Unsafe.withUnsafe (fmap T.toLower) <$> exAsciiTE -- | -- Similar example uses applicative instance of 'Unsafe.Unsafe'
test/Spec.hs view
@@ -1,3 +1,3 @@ -- {-# OPTIONS_GHC -F -pgmF doctest-discover #-} main :: IO ()-main = putStrLn "Test suite not yet implemented"+main = putStrLn "Only doctest suite is implemented, no other tests"
typed-encoding.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: e2dc0ab6f8312959f012e795327b2395efd87de964449886a61a2cc19f64accd+-- hash: 1589fa6653cfa6d1278a74078d61a95a0fe2caa0df5157deafd3f3dc4644385d name: typed-encoding-version: 0.1.0.0+version: 0.2.0.0 synopsis: Type safe string transformations description: See README.md in the project github repository. category: Data, Text@@ -30,24 +30,42 @@ library exposed-modules: Data.TypedEncoding- Data.TypedEncoding.Instances.ASCII- Data.TypedEncoding.Instances.Base64- Data.TypedEncoding.Instances.Encode.Sample+ Data.TypedEncoding.Instances.Do.Sample+ Data.TypedEncoding.Instances.Enc.Base64+ Data.TypedEncoding.Instances.Restriction.ASCII+ Data.TypedEncoding.Instances.Restriction.Common+ Data.TypedEncoding.Instances.Restriction.UTF8 Data.TypedEncoding.Instances.Support- Data.TypedEncoding.Instances.UTF8+ Data.TypedEncoding.Instances.ToEncString.Common Data.TypedEncoding.Internal.Class+ Data.TypedEncoding.Internal.Class.Decode+ Data.TypedEncoding.Internal.Class.Encode+ Data.TypedEncoding.Internal.Class.IsStringR+ Data.TypedEncoding.Internal.Class.Recreate+ Data.TypedEncoding.Internal.Class.Util+ Data.TypedEncoding.Internal.Combinators+ Data.TypedEncoding.Internal.Instances.Combinators Data.TypedEncoding.Internal.Types- Data.TypedEncoding.Internal.Utils+ Data.TypedEncoding.Internal.Types.CheckedEnc+ Data.TypedEncoding.Internal.Types.Common+ Data.TypedEncoding.Internal.Types.Enc+ Data.TypedEncoding.Internal.Types.SomeAnnotation+ Data.TypedEncoding.Internal.Types.SomeEnc+ Data.TypedEncoding.Internal.Types.UncheckedEnc+ Data.TypedEncoding.Internal.Types.Unsafe+ Data.TypedEncoding.Internal.Util Data.TypedEncoding.Unsafe Examples.TypedEncoding Examples.TypedEncoding.Conversions Examples.TypedEncoding.DiySignEncoding Examples.TypedEncoding.Overview+ Examples.TypedEncoding.ToEncString Examples.TypedEncoding.Unsafe other-modules: Paths_typed_encoding hs-source-dirs: src+ ghc-options: -fwarn-unused-imports -fwarn-incomplete-patterns -fprint-explicit-kinds build-depends: base >=4.7 && <5 , base64-bytestring >=1.0 && <1.1