diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -2,17 +2,39 @@ ## Anticipated future breaking changes -- ByteString / Text conversion functions in `Data.TypedEncoding.Instances.Restriction.ASCII`, - `Data.TypedEncoding.Instances.Restriction.ASCII` and `Data.TypedEncoding.Instances.Enc.Base64` - are now deprecated and will be removed. -- `EncodeFAll`, `DecodeFAll`, `RecreateFAll`, `EncodeF`, etc do not work well with more open - encoding annotation such as `"r-ban:soething"` they will be either changed or deprecated / replaced with constructions similar to `Encoder` in `Data.TypedEncoding.Internal.Class.Encoder`. - `Data.TypedEncoding.Internal.Class.IsStringR` expected to be be changed / replaced -- functions used to create encoding instances or encoding combinators (e.g. `implEncodeP`) will get more constraints. -- (never ending) rework of internal module stucture to make it easier to navigate -- Instance and Combinator modules will be merged. -- Displ String instance (used in examples, will be made consistent with Text and ByteString) - (post 0.3) "enc-B64" will be moved to a different package (more distant goal) + +## 0.3 + +- Breaking: Numerous changes on the implementation side, new version should be largely compatible on the call site except + for small differences in constraints and order for type variables (if `-XTypeApplications` is used). + See [v3 migration guide](https://github.com/rpeszek/typed-encoding/blob/master/doc/v3ConversionGuide.md). + - `EncodeFAll`, `DecodeFAll`, `RecreateFAll`, `EncodeF`, `DecodeF`, `RecreateF` replaced with + `EncodeAll`, `DecodeAll`, `ValidateAll`, `Encode`, `Decode`, `Validate`. + - functions used to create encoding instances or encoding combinators (e.g. `implEncodeP`) are now more precisely typed + - `Displ String` instance (used in examples, has been made consistent with Text and ByteString) + - Modules under `Data.TypedEncoding.Combinators` merged into `Data.TypedEncoding.Instances`. + - Modules under `Data.TypedEncoding.Internal` have been reorganized and moved outside of `Internal`. Various changes that make the library easier to navigate. + for better navigation and discovery. + - some previously exported combinators (e.g. `implTranF`) have moved to `Data.TypedEncoding.Instances.Support.Unsafe` + - `ToEncString`, `FromEncString` have more type variables and function name but backward compatible functions + have been provided. + - `Superset` typeclass removed, replaced with `IsSuperset` type family. + - Minor changes in `forall` variable order in combinators for `"r-bool:"` encodings. + - `Encoder` type removed, replaced by `Encodings`. + - `checkWithValidationsEnc` combinator renamed to `check` + - (Considered private) `MkCheckedEnc` constructor became `UnsafeMkCheckedEnc` + - (Considered private) `MkEnc` constructor became `UnsafeMkEnc` + +- new functionality + - new types and typeclasses are based on both encoding name and algorithm name allowing + typeclass definitions for open encodings like `"r-ban:"` that can contain arbitrary symbol literals. + - new set of combinators grouped into `_` (compiler decided algorithm), `'` (program specifies algorithm), and + `algorithm name ~ encoding name` categories + - `above` combinator subsumes partial encoding / decoding combinators + - `EncodingSuperset` class added + ## 0.2.2 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -63,7 +63,6 @@ Please see `Examples.TypedEncoding` it the module list. - ## Other encoding packages My approach will be to write specific encodings (e.g. _HTTP_) or wrap encodings from other packages using separate "bridge" projects. @@ -76,15 +75,16 @@ - [typed-encoding-encoding](https://github.com/rpeszek/typed-encoding-encoding) bridges [encoding](https://github.com/dmwit/encoding) package -## Plans, some TODOs +## News -- lensifying conversions -- better implementation type safety +- v0.3 has numerous changes and improvements. ## Tested with + - stack (1.9.3) lts-14.27 (ghc-8.6.5) - needs ghc >= 8.2.2, base >=4.10 for GHC.TypeLits support ## Known issues + - running test suite: cabal has problems with doctest, use stack https://github.com/haskell/cabal/issues/6087 diff --git a/src/Data/TypedEncoding.hs b/src/Data/TypedEncoding.hs --- a/src/Data/TypedEncoding.hs +++ b/src/Data/TypedEncoding.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE DataKinds #-} -- | -- = Overview @@ -35,7 +33,7 @@ -- -- * /encoding/ -- * /decoding/ --- * /recreation/ (verification of existing payload) +-- * /validation (recreation)/ (verification of existing payload) -- * type conversions between encoded types -- -- of string-like data (@ByteString@, @Text@) that is subject of some @@ -55,24 +53,24 @@ -- == "r-" restriction / predicate -- -- * /encoding/ is a partial identity --- * /recreation/ is a partial identity (matching encoding) +-- * /validation/ is a partial identity (matching encoding) -- * /decoding/ is identity -- --- Examples: @"r-UTF8"@, @"r-ASCII"@, upper alpha-numeric bound /r-ban/ restrictions like @"r-999-999-9999"@ +-- Examples: @"r-UTF8"@, @"r-ASCII"@, upper alpha-numeric bound /r-ban/ restrictions like @"r-ban:999-999-9999"@ -- -- == "do-" transformations -- -- * /encoding/ applies transformation to the string (could be partial) -- * /decoding/ - typically none --- * /recreation/ - typically none but, if present, verifies the payload has expected data (e.g. only uppercase chars for "do-UPPER") +-- * /validation/ - typically none but, if present, verifies the payload has expected data (e.g. only uppercase chars for "do-UPPER") -- -- Examples: @"do-UPPER"@, @"do-lower"@, @"do-reverse"@ -- -- == "enc-" data encoding that is not "r-" -- -- * /encoding/ applies encoding transformation to the string (could be partial) --- * /decoding/ reverses the transformation (can be used as pure function) --- * /recreation/ verifies that the payload has correctly encoded data +-- * /decoding/ reverses the transformation (can be now be used as pure function) +-- * /validation/ verifies that the payload has correctly encoded data -- -- Examples: @"enc-B64"@ -- @@ -84,39 +82,26 @@ -- -- Examples: -- --- @"boolOr:(r-ban:FFFFFFFF-FFFF-FFFF-FFFF-FFFFFFFFFFFF)(r-ban:FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF)"@ +-- @"boolOr:(r-ban:999-999-9999)(r-ban:(999) 999-9999)"@ -- -- "@boolNot:(r-ASCII)" -- -- --- = Usage +-- = Call Site Usage -- -- To use this library import this module and one or more /instance/ or /combinator/ module. -- -- Here is list of instance modules available in typed-encoding library itself -- -- * "Data.TypedEncoding.Instances.Enc.Base64" --- * "Data.TypedEncoding.Instances.Restriction.Common" +-- * "Data.TypedEncoding.Instances.Restriction.Misc" (replaces @Common@ from v0.2) -- * "Data.TypedEncoding.Instances.Restriction.ASCII" -- * "Data.TypedEncoding.Instances.Restriction.UTF8" +-- * "Data.TypedEncoding.Instances.Restriction.Bool" (experimental / early alpha version, moved from @Combinators@ to @Instances@ in v0.3) +-- * "Data.TypedEncoding.Instances.Restriction.BoundedAlphaNums" (moved from @Combinators@ to @Instances@ in v0.3) -- * "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. --- --- To implement a new encoding import this module and --- --- * "Data.TypedEncoding.Instances.Support" --- --- Defining annotations with combinators is an alternative to using typeclass instances. --- --- Combinator modules with be merged with Instances modules in the future. --- --- Included combinator modules: --- --- * "Data.TypedEncoding.Combinators.Restriction.Bool" --- * "Data.TypedEncoding.Combinators.Restriction.BoundedAlphaNums" +-- ... and needed conversions. -- -- Conversion combinator module structure is similar to one found in @text@ and @bytestring@ packages -- And can be found (since 0.2.2) in @@ -128,49 +113,84 @@ -- * "Data.TypedEncoding.Conv.ByteString.Char8" -- * "Data.TypedEncoding.Conv.ByteString.Lazy.Char8" -- +-- This list is not intended to be exhaustive, rather separate libraries +-- can provide instances for other encodings and transformations. -- +-- = New encoding instance creation +-- +-- To implement a new encoding import +-- +-- * "Data.TypedEncoding.Instances.Support" +-- -- = Examples -- -- Examples of how to use this library are included in -- -- * "Examples.TypedEncoding" module Data.TypedEncoding ( - module Data.TypedEncoding - -- * Classes - , module Data.TypedEncoding.Internal.Class - -- * Encoding class and Encoder (replaces EncodeFAll) - , module Data.TypedEncoding.Internal.Class.Encoder - -- * Combinators - , module Data.TypedEncoding.Internal.Combinators - -- * Types - , Enc - , CheckedEnc - , EncodeEx(..) - , RecreateEx(..) - , UnexpectedDecodeEx(..) - , 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 + + -- * @Enc@ and basic combinators + Enc , toEncoding - -- * Basic @CheckedEnc@ Combinators - , unsafeCheckedEnc - , getCheckedPayload - , getCheckedEncPayload - , toCheckedEnc - , fromCheckedEnc - -- * Other Basic Combinators - , recreateErrUnknown + , fromEncoding + , getPayload + + -- * Existentially quantified and untyped versions of @Enc@ + , module Data.TypedEncoding.Common.Types.SomeEnc + , module Data.TypedEncoding.Common.Types.CheckedEnc + + -- * @Encoding@ and basic combinators + , Encoding (..) + , _mkEncoding + , runEncoding' + , _runEncoding + + -- * List of encodings + , Encodings (..) + , runEncodings' + , _runEncodings + + -- * Similar to @Encoding@ and @Encodings@ but cover /Decoding/ and /Validation/ + , module Data.TypedEncoding.Common.Types.Decoding + , module Data.TypedEncoding.Common.Types.Validation + + -- * @UncheckedEnc@ is an /untyped/ version of Enc that represents not validated encoding + , module Data.TypedEncoding.Common.Types.UncheckedEnc + + -- * Classes + , module Data.TypedEncoding.Common.Class + + -- * Combinators + , module Data.TypedEncoding.Combinators.Common + , module Data.TypedEncoding.Combinators.Encode + , module Data.TypedEncoding.Combinators.Decode + , module Data.TypedEncoding.Combinators.Validate + , module Data.TypedEncoding.Combinators.Unsafe + , module Data.TypedEncoding.Combinators.ToEncStr + , module Data.TypedEncoding.Combinators.Promotion + + -- * Exceptions + , module Data.TypedEncoding.Common.Types.Exceptions + + -- * Other + , module Data.TypedEncoding.Common.Types.Common + ) where -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 -import Data.TypedEncoding.Internal.Class.Encoder +import Data.TypedEncoding.Common.Types.Enc +import Data.TypedEncoding.Common.Types.Decoding +import Data.TypedEncoding.Common.Types.Validation + +import Data.TypedEncoding.Common.Types.Common +import Data.TypedEncoding.Common.Types.CheckedEnc +import Data.TypedEncoding.Common.Types.SomeEnc +import Data.TypedEncoding.Common.Types.UncheckedEnc +import Data.TypedEncoding.Common.Types.Exceptions +import Data.TypedEncoding.Common.Class +import Data.TypedEncoding.Combinators.Common +import Data.TypedEncoding.Combinators.Encode +import Data.TypedEncoding.Combinators.Decode +import Data.TypedEncoding.Combinators.Validate +import Data.TypedEncoding.Combinators.Unsafe +import Data.TypedEncoding.Combinators.ToEncStr +import Data.TypedEncoding.Combinators.Promotion diff --git a/src/Data/TypedEncoding/Combinators/Common.hs b/src/Data/TypedEncoding/Combinators/Common.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypedEncoding/Combinators/Common.hs @@ -0,0 +1,52 @@ + +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} +-- {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} + +-- | Combinators reexported in Data.TypedEncoding +module Data.TypedEncoding.Combinators.Common where + +import Data.TypedEncoding.Common.Types +import Data.TypedEncoding.Combinators.Unsafe +import Data.TypedEncoding.Common.Class.Util (Append) +import GHC.TypeLits +import Data.Proxy + +-- $setup +-- >>> :set -XTypeApplications +-- >>> import qualified Data.Text as T +-- >>> import Data.Word + + +-- * Partial application of encoding / decoding / recreation + +-- | Any valid transformation of encodings (encoding / decoding / recreation) can be +-- replayed on top of another encoding stack. +-- +-- This subsumes various /encodePart, decodePart, recreatePart/ combinators. +aboveF :: forall (ts :: [Symbol]) xs ys f c str . (Functor f) => + (Enc xs c str -> f (Enc ys c str)) + -> Enc (Append xs ts) c str -> f (Enc (Append ys ts) c str) +aboveF fn (UnsafeMkEnc _ conf str) = + let re :: f (Enc ys c str) = fn $ UnsafeMkEnc Proxy conf str + in UnsafeMkEnc Proxy conf . getPayload <$> re + + +above :: forall (ts :: [Symbol]) xs ys c str . + (Enc xs c str -> Enc ys c str) + -> Enc (Append xs ts) c str -> Enc (Append ys ts) c str +above fn (UnsafeMkEnc _ conf str) = + let re ::Enc ys c str = fn $ UnsafeMkEnc Proxy conf str + in UnsafeMkEnc Proxy conf . getPayload $ re + + +-- * Other + +getTransformF :: forall e1 e2 f c s1 s2 . Functor f => (Enc e1 c s1 -> f (Enc e2 c s2)) -> c -> s1 -> f s2 +getTransformF fn c str = getPayload <$> fn (unsafeSetPayload c str) + + diff --git a/src/Data/TypedEncoding/Combinators/Decode.hs b/src/Data/TypedEncoding/Combinators/Decode.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypedEncoding/Combinators/Decode.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} + +-- | Combinators reexported in Data.TypedEncoding +module Data.TypedEncoding.Combinators.Decode where + +import Data.TypedEncoding.Common.Types.Enc +import Data.TypedEncoding.Common.Types.Decoding +import Data.TypedEncoding.Combinators.Common + +import Data.TypedEncoding.Common.Class.Util +import Data.TypedEncoding.Common.Class.Decode +import Data.Functor.Identity +import GHC.TypeLits + + +-- * Convenience combinators which mimic pre-v0.3 type signatures. These assume that @algs@ are the same as @nms@ + +decodeF :: forall nm xs f c str . (Decode f nm nm c str) => Enc (nm ': xs) c str -> f (Enc xs c str) +decodeF = decodeF' @nm @nm + +decodeFAll :: forall nms f c str . (Monad f, DecodeAll f nms nms c str) => + Enc nms c str + -> f (Enc ('[]::[Symbol]) c str) +decodeFAll = decodeFAll' @nms @nms + +-- | +-- +decodeAll :: forall nms c str . (DecodeAll Identity nms nms c str) => + Enc nms c str + -> Enc ('[]::[Symbol]) c str +decodeAll = decodeAll' @nms @nms + +decodeFPart :: forall xs xsf f c str . (Monad f, DecodeAll f xs xs c str) => Enc (Append xs xsf) c str -> f (Enc xsf c str) +decodeFPart = decodeFPart' @xs @xs + +decodePart :: forall xs xsf c str . (DecodeAll Identity xs xs c str) => Enc (Append xs xsf) c str -> Enc xsf c str +decodePart = decodePart' @xs @xs + + + +-- * Convenience combinators which mimic pre-v0.3 type signatures. These do not try to figure out @algs@ or assume much about them + +decodeF' :: forall alg nm xs f c str . (Decode f nm alg c str) => Enc (nm ': xs) c str -> f (Enc xs c str) +decodeF' = runDecoding (decoding @f @nm @alg) + +decodeFAll' :: forall algs nms f c str . (Monad f, DecodeAll f nms algs c str) => + Enc nms c str + -> f (Enc ('[]::[Symbol]) c str) +decodeFAll' = runDecodings @algs @nms @f decodings + +-- | +-- +decodeAll' :: forall algs nms c str . (DecodeAll Identity nms algs c str) => + Enc nms c str + -> Enc ('[]::[Symbol]) c str +decodeAll' = runIdentity . decodeFAll' @algs + +decodeFPart' :: forall algs xs xsf f c str . (Monad f, DecodeAll f xs algs c str) => Enc (Append xs xsf) c str -> f (Enc xsf c str) +decodeFPart' = aboveF @xsf @xs @'[] (decodeFAll' @algs) +-- decodeFPart' (UnsafeMkEnc _ conf str) = +-- let re :: f (Enc '[] c str) = decodeFAll' @algs @xs $ UnsafeMkEnc Proxy conf str +-- in UnsafeMkEnc Proxy conf . getPayload <$> re + +decodePart' :: forall algs xs xsf c str . (DecodeAll Identity xs algs c str) => Enc (Append xs xsf) c str -> Enc xsf c str +decodePart' = runIdentity . decodeFPart' @algs @xs + + diff --git a/src/Data/TypedEncoding/Combinators/Encode.hs b/src/Data/TypedEncoding/Combinators/Encode.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypedEncoding/Combinators/Encode.hs @@ -0,0 +1,68 @@ + +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} + +module Data.TypedEncoding.Combinators.Encode where + +import Data.TypedEncoding.Common.Types.Enc +import Data.TypedEncoding.Common.Class.Util -- Append +import Data.TypedEncoding.Combinators.Common +import Data.TypedEncoding.Common.Class.Encode +import GHC.TypeLits +import Data.Functor.Identity + + +-- * Convenience combinators which mimic pre-v0.3 type signatures. These assume that @algs@ are the same as @nms@ + +encodeF :: forall nm xs f c str . Encode f nm nm c str => Enc xs c str -> f (Enc (nm ': xs) c str) +encodeF = encodeF' @nm @nm + +encodeFAll :: forall nms f c str . (Monad f, EncodeAll f nms nms c str) => + Enc ('[]::[Symbol]) c str + -> f (Enc nms c str) +encodeFAll = encodeFAll' @nms @nms + +encodeAll :: forall nms c str . (EncodeAll Identity nms nms c str) => + Enc ('[]::[Symbol]) c str + -> Enc nms c str +encodeAll = encodeAll' @nms @nms + +encodeFPart :: forall xs xsf f c str . (Monad f, EncodeAll f xs xs c str) => Enc xsf c str -> f (Enc (Append xs xsf) c str) +encodeFPart = encodeFPart' @xs @xs + +encodePart :: forall xs xsf c str . (EncodeAll Identity xs xs c str) => Enc xsf c str -> Enc (Append xs xsf) c str +encodePart = encodePart' @xs @xs + + +-- * Convenience combinators which mimic pre-v0.3 type signatures. These do not try to figure out @algs@ or assume much about them + +encodeF' :: forall alg nm xs f c str . (Encode f nm alg c str) => Enc xs c str -> f (Enc (nm ': xs) c str) +encodeF' = runEncoding' (encoding @f @nm @alg) + +encodeFAll' :: forall algs nms f c str . (Monad f, EncodeAll f nms algs c str) => + Enc ('[]::[Symbol]) c str + -> f (Enc nms c str) +encodeFAll' = runEncodings' @algs @nms @f encodings + +-- | +-- +encodeAll' :: forall algs nms c str . (EncodeAll Identity nms algs c str) => + Enc ('[]::[Symbol]) c str + -> Enc nms c str +encodeAll' = runIdentity . encodeFAll' @algs + +encodeFPart' :: forall algs xs xsf f c str . (Monad f, EncodeAll f xs algs c str) => Enc xsf c str -> f (Enc (Append xs xsf) c str) +encodeFPart' = aboveF @xsf @'[] @xs (encodeFAll' @algs) +-- encodeFPart' (UnsafeMkEnc _ conf str) = +-- let re :: f (Enc xs c str) = encodeFAll' @algs $ UnsafeMkEnc Proxy conf str +-- in UnsafeMkEnc Proxy conf . getPayload <$> re + +encodePart' :: forall algs xs xsf c str . (EncodeAll Identity xs algs c str) => Enc xsf c str -> Enc (Append xs xsf) c str +encodePart' = runIdentity . encodeFPart' @algs @xs diff --git a/src/Data/TypedEncoding/Combinators/Encode/Experimental.hs b/src/Data/TypedEncoding/Combinators/Encode/Experimental.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypedEncoding/Combinators/Encode/Experimental.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Experimental features, slow to compile when used. +module Data.TypedEncoding.Combinators.Encode.Experimental where + +import Data.TypedEncoding.Combinators.Encode +import Data.TypedEncoding.Common.Types.Enc +import Data.TypedEncoding.Common.Types.Common +import Data.TypedEncoding.Common.Class.Util -- Append +import Data.TypedEncoding.Common.Class.Encode +import Data.Functor.Identity +import GHC.TypeLits + +-- * Combinators equivalent to "Data.TypedEncoding.Common.Class.Encode" that automatically figure out algorithm name. +-- Cause slow compilation when used + +_encodeF :: forall nm xs f c str alg . (Encode f nm alg c str, alg ~ AlgNm nm) => Enc xs c str -> f (Enc (nm ': xs) c str) +_encodeF = encodeF' @(AlgNm nm) @nm + +_encodeFAll :: forall nms f c str algs . (Monad f, EncodeAll f nms algs c str, algs ~ AlgNmMap nms) => + Enc ('[]::[Symbol]) c str + -> f (Enc nms c str) +_encodeFAll = encodeFAll' @(AlgNmMap nms) @nms + +_encodeAll :: forall nms c str algs . (EncodeAll Identity nms algs c str, algs ~ AlgNmMap nms) => + Enc ('[]::[Symbol]) c str + -> Enc nms c str +_encodeAll = encodeAll' @(AlgNmMap nms) @nms + +_encodeFPart :: forall xs xsf f c str algs . (Monad f, EncodeAll f xs algs c str, algs ~ AlgNmMap xs) => Enc xsf c str -> f (Enc (Append xs xsf) c str) +_encodeFPart = encodeFPart' @(AlgNmMap xs) @xs + +_encodePart :: forall xs xsf c str algs . (EncodeAll Identity xs algs c str, algs ~ AlgNmMap xs) => Enc xsf c str -> Enc (Append xs xsf) c str +_encodePart = encodePart' @(AlgNmMap xs) @xs + diff --git a/src/Data/TypedEncoding/Combinators/Promotion.hs b/src/Data/TypedEncoding/Combinators/Promotion.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypedEncoding/Combinators/Promotion.hs @@ -0,0 +1,101 @@ + + +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +-- {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | Promote and demote combinators. +module Data.TypedEncoding.Combinators.Promotion where + +import Data.TypedEncoding.Common.Class +import Data.TypedEncoding.Common.Util.TypeLits + +import Data.TypedEncoding.Common.Types (Enc(..) ) +import Data.TypedEncoding.Combinators.Unsafe (withUnsafeCoerce) + + +-- $setup +-- >>> :set -XOverloadedStrings -XMultiParamTypeClasses -XDataKinds -XTypeApplications +-- >>> import Data.TypedEncoding.Common.Class.Util (displ) +-- >>> import Data.TypedEncoding.Combinators.Unsafe (unsafeSetPayload) +-- >>> import Data.TypedEncoding.Instances.Restriction.UTF8 () +-- >>> import Data.TypedEncoding.Instances.Restriction.ASCII () +-- >>> import Data.Text as T + +-- | Remove redundant superset right after the top (at second last encoding position) +-- +-- >>> displ $ demoteFlattenTop (unsafeSetPayload () "" :: Enc '["r-ASCII", "r-UTF8", "r-boo"] () T.Text) +-- "Enc '[r-ASCII,r-boo] () (Text )" +-- +-- @since 0.2.2.0 (moved) +demoteFlattenTop :: forall y x xs c str . (IsSuperset y x ~ 'True) => Enc (x ': y ': xs) c str -> Enc (x ': xs) c str +demoteFlattenTop = withUnsafeCoerce id + +-- | add redundant superset right after +-- +-- >>> displ $ promoteUnFlattenTop @"r-UTF8" (unsafeSetPayload () "" :: Enc '["r-ASCII", "r-boo"] () T.Text) +-- "Enc '[r-ASCII,r-UTF8,r-boo] () (Text )" +-- +-- @since 0.2.2.0 (moved) +promoteUnFlattenTop :: forall y x xs c str . (IsSuperset y x ~ 'True) => Enc (x ': xs) c str -> Enc (x ': y ': xs) c str +promoteUnFlattenTop = withUnsafeCoerce id + +-- | remove redunant superset from the top (at last applied encoding position) +-- +-- >>> displ $ demoteRemoveTop (unsafeSetPayload () "" :: Enc '["r-UTF8", "r-ASCII", "r-boo"] () T.Text) +-- "Enc '[r-ASCII,r-boo] () (Text )" +-- +-- @since 0.2.2.0 (moved) +demoteRemoveTop :: forall y x xs c str . (IsSuperset y x ~ 'True) => Enc (y ': x ' : xs) c str -> Enc (x ': xs) c str +demoteRemoveTop = withUnsafeCoerce id + +-- | add redundant superset at the top +-- +-- >>> displ $ promoteAddTop @"r-UTF8" (unsafeSetPayload () "" :: Enc '["r-ASCII", "r-boo"] () T.Text) +-- "Enc '[r-UTF8,r-ASCII,r-boo] () (Text )" +-- +-- @since 0.2.2.0 (moved) +promoteAddTop :: forall y x xs c str . (IsSuperset y x ~ 'True) => Enc (x ': xs) c str -> Enc (y ': x ' : xs) c str +promoteAddTop = withUnsafeCoerce id + +-- | remove redundant superset at bottom (first encoding) position +-- +-- >>> displ $ demoteRemoveBot (unsafeSetPayload () "" :: Enc '["r-boo", "r-ASCII", "r-UTF8"] () T.Text) +-- "Enc '[r-boo,r-ASCII] () (Text )" +-- +-- @since 0.2.2.0 (moved) +demoteRemoveBot :: (UnSnoc xs ~ '(,) ys y, UnSnoc ys ~ '(,) zs x, IsSuperset y x ~ 'True) => Enc xs c str -> Enc ys c str +demoteRemoveBot = withUnsafeCoerce id + +-- | add redundant superset at bottom (first encoding) position +-- +-- >>> displ $ promoteAddBot @"r-UTF8" (unsafeSetPayload () "" :: Enc '["r-boo", "r-ASCII"] () T.Text) +-- "Enc '[r-boo,r-ASCII,r-UTF8] () (Text )" +promoteAddBot :: forall y x xs c str ys . (UnSnoc xs ~ '(,) ys x, IsSuperset y x ~ 'True) => Enc xs c str -> Enc (Snoc xs y) c str +promoteAddBot = withUnsafeCoerce id + +-- | remove redundant superset at second bottom (second encoding) position +-- +-- >>> displ $ demoteFlattenBot (unsafeSetPayload () "" :: Enc '["r-boo", "r-UTF8", "r-ASCII"] () T.Text) +-- "Enc '[r-boo,r-ASCII] () (Text )" +-- +-- @since 0.2.2.0 (moved) +demoteFlattenBot :: (UnSnoc xs ~ '(,) ys x, UnSnoc ys ~ '(,) zs y, IsSuperset y x ~ 'True) => Enc xs c str -> Enc (Snoc zs x) c str +demoteFlattenBot = withUnsafeCoerce id + +-- | add redundant superset at second bottom (second encoding) position +-- +-- >>> displ $ promoteUnFlattenBot @"r-UTF8" (unsafeSetPayload () "" :: Enc '["r-boo", "r-ASCII"] () T.Text) +-- "Enc '[r-boo,r-UTF8,r-ASCII] () (Text )" +-- +-- @since 0.2.2.0 (moved) +promoteUnFlattenBot :: forall y x xs c str ys . (UnSnoc xs ~ '(,) ys x, IsSuperset y x ~ 'True) => Enc xs c str -> Enc (Snoc (Snoc ys y) x) c str +promoteUnFlattenBot = withUnsafeCoerce id diff --git a/src/Data/TypedEncoding/Combinators/Restriction/Bool.hs b/src/Data/TypedEncoding/Combinators/Restriction/Bool.hs deleted file mode 100644 --- a/src/Data/TypedEncoding/Combinators/Restriction/Bool.hs +++ /dev/null @@ -1,395 +0,0 @@ - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Boolean algebra on encodings --- --- @since 0.2.1.0 --- --- == Grammar --- --- Simple grammar requires boolean terms to be included in parentheses --- --- @ --- bool[BinaryOp]:(leftTerm)(rightTerm) --- bool[UnaryOp]:(term) --- @ --- --- Expected behavior is described next to corresponding combinator. --- --- Typeclass encoding is not used to avoid instance overlapping. --- --- Use 'Data.TypedEncoding.Combinators.Restriction.Common.recWithEncR' --- to create manual recovery step that can be combined with 'recreateFPart'. - --- This is very much in beta state. --- -module Data.TypedEncoding.Combinators.Restriction.Bool where - - -import GHC.TypeLits -import Data.Proxy -import Data.Symbol.Ascii - -import Data.TypedEncoding -import Data.TypedEncoding.Instances.Support --- import Data.TypedEncoding.Internal.Util.TypeLits -import Data.TypedEncoding.Combinators.Restriction.Common - --- import qualified Data.Text as T --- import Data.TypedEncoding.Instances.Restriction.Common() - - --- $setup --- >>> :set -XOverloadedStrings -XMultiParamTypeClasses -XDataKinds -XTypeApplications --- >>> import qualified Data.Text as T --- >>> import Data.TypedEncoding.Instances.Restriction.Common() - - --- | --- See examples in 'encBoolOrRight'' -encBoolOrLeft :: forall f s t xs c str . ( - BoolOpIs s "or" ~ 'True - -- IsBoolOr s ~ 'True - , Functor f - , LeftTerm s ~ t - ) => (Enc xs c str -> f (Enc (t ': xs) c str)) -> Enc xs c str -> f (Enc (s ': xs) c str) -encBoolOrLeft = implChangeAnn - --- | --- See examples in 'encBoolOrRight'' -encBoolOrLeft' :: forall f s t xs c str . ( - BoolOpIs s "or" ~ 'True - -- IsBoolOr s ~ 'True - , Functor f - , LeftTerm s ~ t - , EncodeF f (Enc xs c str) (Enc (t ': xs) c str) - ) => Enc xs c str -> f (Enc (s ': xs) c str) -encBoolOrLeft' = encBoolOrLeft (encodeF @f @(Enc xs c str) @(Enc (t ': xs) c str)) - --- | --- -encBoolOrRight :: forall f s t xs c str . ( - BoolOpIs s "or" ~ 'True - -- IsBoolOr s ~ 'True - , Functor f - , RightTerm s ~ t - ) => (Enc xs c str -> f (Enc (t ': xs) c str)) -> Enc xs c str -> f (Enc (s ': xs) c str) -encBoolOrRight = implChangeAnn - --- | --- >>> :{ --- let tst1, tst2, tst3 :: Either EncodeEx (Enc '["boolOr:(r-Word8-decimal)(r-Int-decimal)"] () T.Text) --- tst1 = encBoolOrLeft' . toEncoding () $ "212" --- tst2 = encBoolOrRight' . toEncoding () $ "1000000" --- tst3 = encBoolOrLeft' . toEncoding () $ "1000000" --- :} --- --- >>> tst1 --- Right (MkEnc Proxy () "212") --- --- >>> tst2 --- Right (MkEnc Proxy () "1000000") --- --- >>> tst3 --- Left (EncodeEx "r-Word8-decimal" ("Payload does not satisfy format Word8-decimal: 1000000")) -encBoolOrRight' :: forall f s t xs c str . ( - BoolOpIs s "or" ~ 'True - -- IsBoolOr s ~ 'True - , Functor f - , RightTerm s ~ t - , EncodeF f (Enc xs c str) (Enc (t ': xs) c str) - ) => Enc xs c str -> f (Enc (s ': xs) c str) -encBoolOrRight' = encBoolOrRight (encodeF @f @(Enc xs c str) @(Enc (t ': xs) c str)) - -encBoolAnd :: forall f s t1 t2 xs c str . ( - BoolOpIs s "and" ~ 'True - , KnownSymbol s - -- IsBoolAnd s ~ 'True - , f ~ Either EncodeEx - , Eq str - , LeftTerm s ~ t1 - , RightTerm s ~ t2 - ) => - (Enc xs c str -> f (Enc (t1 ': xs) c str)) - -> (Enc xs c str -> f (Enc (t2 : xs) c str)) - -> Enc xs c str -> f (Enc (s ': xs) c str) -encBoolAnd fnl fnr en0 = - let - eent1 = fnl en0 - eent2 = fnr en0 - p = (Proxy :: Proxy s) - in - case (eent1, eent2) of - (Right ent1, Right ent2) -> - if getPayload ent1 == getPayload ent2 - then Right . withUnsafeCoerce id $ ent1 - else Left $ EncodeEx p "Left - right encoding do not match" - (_, _) -> mergeErrs (emptyEncErr p) (mergeEncodeEx p) eent1 eent2 - --- | --- @"boolOr:(enc1)(enc2)"@ contains strings that encode the same way under both encodings. --- for example @"boolOr:(r-UPPER)(r-lower)"@ valid elements would include @"123-34"@ but not @"abc"@ --- --- >>> :{ --- let tst1, tst2 :: Either EncodeEx (Enc '["boolAnd:(r-Word8-decimal)(r-Int-decimal)"] () T.Text) --- tst1 = encBoolAnd' . toEncoding () $ "234" --- tst2 = encBoolAnd' . toEncoding () $ "100000" --- :} --- --- >>> tst1 --- Right (MkEnc Proxy () "234") --- >>> tst2 --- Left (EncodeEx "r-Word8-decimal" ("Payload does not satisfy format Word8-decimal: 100000")) -encBoolAnd' :: forall f s t1 t2 xs c str . ( - BoolOpIs s "and" ~ 'True - , KnownSymbol s - -- IsBoolAnd s ~ 'True - , f ~ Either EncodeEx - , Eq str - , LeftTerm s ~ t1 - , RightTerm s ~ t2 - , EncodeF f (Enc xs c str) (Enc (t1 ': xs) c str) - , EncodeF f (Enc xs c str) (Enc (t2 ': xs) c str) - ) => Enc xs c str -> f (Enc (s ': xs) c str) -encBoolAnd' = encBoolAnd (encodeF @f @(Enc xs c str) @(Enc (t1 ': xs) c str)) (encodeF @f @(Enc xs c str) @(Enc (t2 ': xs) c str)) - - --- tst1, tst2 :: Either EncodeEx (Enc '["boolNot:(r-Word8-decimal)"] () T.Text) --- tst1 = encBoolNot' . toEncoding () $ "334" --- tst2 = encBoolNot' . toEncoding () $ "127" - -encBoolNot :: forall f s t xs c str . ( - BoolOpIs s "not" ~ 'True - , KnownSymbol s - , f ~ Either EncodeEx - , FirstTerm s ~ t - , KnownSymbol t - , IsR t ~ 'True - ) => (Enc xs c str -> f (Enc (t ': xs) c str)) -> Enc xs c str -> f (Enc (s ': xs) c str) -encBoolNot fn en0 = - let - een = fn en0 - p = (Proxy :: Proxy s) - pt = (Proxy :: Proxy t) - in - case een of - Left _ -> Right . withUnsafeCoerce id $ en0 - Right _ -> Left $ EncodeEx p $ "Encoding " ++ symbolVal pt ++ " succeeded" - - --- | --- >>> :{ --- let tst1, tst2 :: Either EncodeEx (Enc '["boolNot:(r-Word8-decimal)"] () T.Text) --- tst1 = encBoolNot' . toEncoding () $ "334" --- tst2 = encBoolNot' . toEncoding () $ "127" --- :} --- --- >>> tst1 --- Right (MkEnc Proxy () "334") --- >>> tst2 --- Left (EncodeEx "boolNot:(r-Word8-decimal)" ("Encoding r-Word8-decimal succeeded")) -encBoolNot' :: forall f s t xs c str . ( - BoolOpIs s "not" ~ 'True - , KnownSymbol s - , f ~ Either EncodeEx - , FirstTerm s ~ t - , KnownSymbol t - , IsR t ~ 'True - , EncodeF f (Enc xs c str) (Enc (t ': xs) c str) - ) => Enc xs c str -> f (Enc (s ': xs) c str) -encBoolNot' = encBoolNot (encodeF :: Enc xs c str -> f (Enc (t ': xs) c str)) - --- | --- Decodes boolean expression if all leaves are @"r-"@ -decBoolR :: forall f xs t s c str . ( - NestedR s ~ 'True - , Applicative f - ) => Enc (s ': xs) c str -> f (Enc xs c str) - -decBoolR = implTranP id - -recWithEncBoolR :: forall (s :: Symbol) xs c str . (NestedR s ~ 'True) - => (Enc xs c str -> Either EncodeEx (Enc (s ': xs) c str)) - -> Enc xs c str -> Either RecreateEx (Enc (s ': xs) c str) -recWithEncBoolR = unsafeRecWithEncR - --- * Type family based parser - --- | --- >>> :kind! BoolOpIs "boolAnd:(someenc)(otherenc)" "and" --- ... --- = 'True -type family BoolOpIs (s :: Symbol) (op :: Symbol) :: Bool where - BoolOpIs s op = AcceptEq ('Text "Invalid bool encoding " ':<>: ShowType s ) (CmpSymbol (BoolOp s) op) - --- | --- This works fast with @!kind@ but is much slower in declaration --- :kind! BoolOp "boolOr:()()" -type family BoolOp (s :: Symbol) :: Symbol where - BoolOp s = Fst (BoolOpHelper (Dupl s)) - -- ToLower (TakeUntil (Drop 4 s) ":") - -type family BoolOpHelper (x :: (Symbol, Symbol)) :: (Symbol, Bool) where - BoolOpHelper ('(,) s1 s2) = '(,) (ToLower (TakeUntil (Drop 4 s1) ":")) ( AcceptEq ('Text "Invalid bool encoding " ':<>: ShowType s2 ) (CmpSymbol "bool" (Take 4 s2))) - - -type family IsBool (s :: Symbol) :: Bool where - IsBool s = AcceptEq ('Text "Not boolean encoding " ':<>: ShowType s ) (CmpSymbol "bool" (Take 4 s)) - --- | --- --- >>> :kind! NestedR "boolOr:(r-abc)(r-cd)" --- ... --- = 'True --- --- >>> :kind! NestedR "boolOr:(boolAnd:(r-ab)(r-ac))(boolNot:(r-cd))" --- ... --- = 'True --- --- >>> :kind! NestedR "boolOr:(boolAnd:(r-ab)(ac))(boolNot:(r-cd))" --- ... --- ... (TypeError ...) --- ... -type family NestedR (s :: Symbol) :: Bool where - NestedR "" = 'True -- RightTerm, LeftTerm return "" on "r-" - NestedR s = Or (IsROrEmpty s) - (And (IsBool s) (And (NestedR (LeftTerm s)) (NestedR (RightTerm s)))) - --- Value level check --- --- nestedR :: String -> Bool --- nestedR s = isROrEmpty s || isBool s && (nestedR (leftTerm s) && nestedR (rightTerm s)) - --- isBool ('b' :'o' : 'o' : _) = True --- isBool _ = False - --- isROrEmpty "" = True --- isROrEmpty ('r' : '-' : _) = True --- isROrEmpty _ = False - - -type family FirstTerm (s :: Symbol) :: Symbol where - FirstTerm s = LeftTerm s - --- | --- returns "" for unary operator -type family SecondTerm (s :: Symbol) :: Symbol where - SecondTerm s = RightTerm s - - --- | --- >>> :kind! LeftTerm "boolSomeOp:(agag)(222)" --- ... --- = "agag" --- --- >>> :kind! LeftTerm "r-Int-decimal" --- ... --- = "" -type family LeftTerm (s :: Symbol) :: Symbol where - LeftTerm s = Concat (LDropLast( LTakeFstParen (LParenCnt (ToList s)))) - --- | --- >>> :kind! RightTerm "boolSomeOp:(agag)(222)" --- ... --- = "222" --- --- >>> :kind! RightTerm "r-Int-decimal" --- ... --- = "" -type family RightTerm (s :: Symbol) :: Symbol where - RightTerm s = Concat (LDropLast (LTakeSndParen 0 (LParenCnt (ToList s)))) - - -type family LDropLast (s :: [Symbol]) :: [Symbol] where - LDropLast '[] = '[] - LDropLast '[x] = '[] - LDropLast (x ': xs) = x ': LDropLast xs - - -type family LParenCnt (s :: [Symbol]) :: [(Symbol, Nat)] where - LParenCnt '[] = '[] - LParenCnt ("(" ': xs) = LParenCntHelper ('(,) "(" 'Decr) (LParenCnt xs) -- '(,) "(" (LParenCntFstCnt (LParenCnt xs) - 1) ': LParenCnt xs - LParenCnt (")" ': xs) = LParenCntHelper ('(,) ")" 'Incr) (LParenCnt xs) - LParenCnt (x ': xs) = LParenCntHelper ('(,) x 'NoChng) (LParenCnt xs) - -data Adjust = Incr | Decr | NoChng - -type family AdjHelper (a :: Adjust) (n :: Nat) :: Nat where - AdjHelper 'Incr n = n + 1 - AdjHelper 'Decr 0 = 0 - AdjHelper 'Decr n = n - 1 - AdjHelper 'NoChng n = n - -type family LParenCntHelper (s :: (Symbol, Adjust)) (sx :: [(Symbol, Nat)]) :: [(Symbol, Nat)] where - LParenCntHelper ('(,) x k) '[] = '(,) x (AdjHelper k 0) ': '[] - LParenCntHelper ('(,) x k) ('(,) c i : xs) = '(,) x (AdjHelper k i) ': '(,) c i ': xs - - -type family LTakeFstParen (si :: [(Symbol, Nat)]) :: [Symbol] where - LTakeFstParen '[] = '[] - LTakeFstParen ('(,) _ 0 ': xs) = LTakeFstParen xs - LTakeFstParen ('(,) ")" 1 ': _) = '[")"] - LTakeFstParen ('(,) a p ': xs) = a ': LTakeFstParen xs - - -type family LTakeSndParen (n :: Nat) (si :: [(Symbol, Nat)]) :: [Symbol] where - LTakeSndParen _ '[] = '[] - LTakeSndParen 0 ('(,) ")" 1 ': xs) = LTakeSndParen 1 xs - LTakeSndParen 1 ('(,) _ 0 : xs) = LTakeSndParen 1 xs - LTakeSndParen 0 ('(,) _ _ ': xs) = LTakeSndParen 0 xs - LTakeSndParen 1 ('(,) a _ ': xs) = a : LTakeSndParen 1 xs - LTakeSndParen n _ = '[] - --- -- * (Example) Value level equivalend of type family parsers - - --- -- map snd . parenCnt $ "((AGA)(bcd))(123) " --- -- dropLast . takeFstParen . parenCnt $ "((AGA)(bcd))(123)" --- -- dropLast . takeSndParen 0 . parenCnt $ "((AGA)(bcd))(123)" - --- leftTerm :: String -> String --- leftTerm = dropLast . takeFstParen . parenCnt - --- rightTerm :: String -> String --- rightTerm = dropLast . takeSndParen 0 . parenCnt - --- parenCnt :: String -> [(Char, Int)] --- parenCnt [] = [] --- parenCnt ('(' : xs) = parenCntHelper ('(', -1) (parenCnt xs) --('(', parenCntFstCnt (parenCnt xs) - 1) : parenCnt xs --- parenCnt (')' : xs) = parenCntHelper (')', 1) (parenCnt xs) -- (')', parenCntFstCnt (parenCnt xs) + 1) : parenCnt xs --- parenCnt (x : xs) = parenCntHelper (x, 0) (parenCnt xs) -- (x, parenCntFstCnt (parenCnt xs) ) : parenCnt xs - - --- parenCntHelper :: (Char, Int) -> [(Char, Int)] -> [(Char, Int)] --- parenCntHelper (x, k) [] = [(x,k)] --- parenCntHelper (x, k) ((c,i) : xs) = (x, i + k): (c,i) : xs - - --- takeFstParen :: [(Char, Int)] -> [Char] --- takeFstParen [] = [] --- takeFstParen ((_, 0) : xs) = takeFstParen xs --- takeFstParen ((')', 1) : _) = [')'] --- takeFstParen ((a, p) : xs) = a : takeFstParen xs - --- takeSndParen :: Int -> [(Char, Int)] -> [Char] --- takeSndParen _ [] = [] --- takeSndParen 0 ((')', 1) : xs) = takeSndParen 1 xs --- takeSndParen 1 ((_, 0) : xs) = takeSndParen 1 xs --- takeSndParen 0 ((_, _) : xs) = takeSndParen 0 xs --- takeSndParen 1 ((a, _) : xs) = a : takeSndParen 1 xs --- takeSndParen _ _ = [] - --- dropLast :: [Char] -> [Char] --- dropLast [] = [] --- dropLast [x] = [] --- dropLast (x:xs) = x : dropLast xs - diff --git a/src/Data/TypedEncoding/Combinators/Restriction/BoundedAlphaNums.hs b/src/Data/TypedEncoding/Combinators/Restriction/BoundedAlphaNums.hs deleted file mode 100644 --- a/src/Data/TypedEncoding/Combinators/Restriction/BoundedAlphaNums.hs +++ /dev/null @@ -1,112 +0,0 @@ - -{-# LANGUAGE MultiParamTypeClasses #-} --- {-# LANGUAGE PolyKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} --- {-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Restrictions @"r-ban:"@ cover commonly used fixed (short) size strings with restricted --- characters such as GUID, credit card numbers, etc. --- --- Alphanumeric chars are ordered: @0-9@ followed by @A-Z@, --- followed by @a-z@. Annotation specifies upper character bound. --- Any non alpha numeric characters are considered fixed delimiters --- and need to be present exactly as specified. --- For example @"r-ban:999-99-9999"@ could be used to describe SSN numbers, --- @"r-ban:FFFF" would describe strings consisting of 4 hex digits. --- --- This is a simple implementation that converts to @String@, should be used --- only with short length data. --- --- This module does not create instances of @EncodeF@ typeclass to avoid duplicate instance issues. --- --- Decoding function @decFR@ is located in --- "Data.TypedEncoding.Combinators.Restriction.Common" --- --- Use 'Data.TypedEncoding.Combinators.Restriction.Common.recWithEncR' --- to create manual recovery step that can be combined with 'recreateFPart'. --- --- @since 0.2.1.0 -module Data.TypedEncoding.Combinators.Restriction.BoundedAlphaNums where - - -import GHC.TypeLits -import qualified Data.List as L -import Data.Char -import Data.Proxy -import Data.Either - -import Data.TypedEncoding.Internal.Util.TypeLits -import Data.TypedEncoding.Internal.Class.IsStringR -import Data.TypedEncoding.Instances.Support - --- $setup --- >>> :set -XOverloadedStrings -XMultiParamTypeClasses -XDataKinds -XTypeApplications --- >>> import qualified Data.Text as T --- >>> import Data.TypedEncoding.Combinators.Restriction.Common - --- better compilation errors? -type family IsBan (s :: Symbol) :: Bool where - IsBan s = AcceptEq ('Text "Not ban restriction encoding " ':<>: ShowType s ) (CmpSymbol (TakeUntil s ":") "r-ban") - -type instance IsSupersetOpen "r-ASCII" "r-ban" xs = 'True - -instance (KnownSymbol s, "r-ban" ~ TakeUntil s ":" , IsStringR str, Encodings (Either EncodeEx) xs grps c str) => Encodings (Either EncodeEx) (s ': xs) ("r-ban" ': grps) c str where - encodings = AppendEnc encFBan encodings - --- | --- >>> encFBan . toEncoding () $ "C59F9FB7-4621-44D9-9020-CE37BF6E2BD1" :: Either EncodeEx (Enc '["r-ban:FFFFFFFF-FFFF-FFFF-FFFF-FFFFFFFFFFFF"] () T.Text) --- Right (MkEnc Proxy () "C59F9FB7-4621-44D9-9020-CE37BF6E2BD1") --- --- >>> recWithEncR encFBan . toEncoding () $ "211-22-9934" :: Either RecreateEx (Enc '["r-ban:999-99-9999"] () T.Text) --- Right (MkEnc Proxy () "211-22-9934") -encFBan :: forall f s t xs c str . - ( - IsStringR str - , KnownSymbol s - , IsBan s ~ 'True - , f ~ Either EncodeEx - ) => - Enc xs c str -> f (Enc (s ': xs) c str) -encFBan = implEncodeF @s (verifyBoundedAlphaNum (Proxy :: Proxy s)) - --- TODO v0.3 remove f from forall in encFBan (slightly breaking chanage) - - --- | --- >>> verifyBoundedAlphaNum (Proxy :: Proxy "r-ban:FF-FF") (T.pack "12-3E") --- Right "12-3E" --- >>> verifyBoundedAlphaNum (Proxy :: Proxy "r-ban:FF-FF") (T.pack "1G-3E") --- Left "'G' not boulded by 'F'" --- >>> verifyBoundedAlphaNum (Proxy :: Proxy "r-ban:FF-FF") (T.pack "13G3E") --- Left "'G' not matching '-'" --- >>> verifyBoundedAlphaNum (Proxy :: Proxy "r-ban:FF-FF") (T.pack "13-234") --- Left "Input list has wrong size expecting 5 but length \"13-234\" == 6" -verifyBoundedAlphaNum :: forall s a str . (KnownSymbol s, IsStringR str) => Proxy s -> str -> Either String str -verifyBoundedAlphaNum p str = - if pattl == inpl - then case lefts match of - (e: _) -> Left e - _ -> Right str - else Left $ "Input list has wrong size expecting " ++ show pattl ++ " but length " ++ show input ++ " == " ++ show inpl - where - patt = L.drop (L.length ("r-ban:" :: String)) . symbolVal $ p - input = toString str - pattl = L.length patt - inpl = L.length input - - match = L.zipWith fn input patt - - - fn ci cp = case (isAlphaNum ci, isAlphaNum cp, ci <= cp, ci == cp) of - (True, True, True, _) -> Right () - (_, _, _, True) -> Right () - (_, True, _, False) -> Left $ show ci ++ " not boulded by " ++ show cp - (_, False, _, False) -> Left $ show ci ++ " not matching " ++ show cp diff --git a/src/Data/TypedEncoding/Combinators/Restriction/Common.hs b/src/Data/TypedEncoding/Combinators/Restriction/Common.hs deleted file mode 100644 --- a/src/Data/TypedEncoding/Combinators/Restriction/Common.hs +++ /dev/null @@ -1,64 +0,0 @@ - --- {-# LANGUAGE PolyKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} --- {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} --- {-# LANGUAGE KindSignatures #-}s -{-# LANGUAGE UndecidableInstances #-} - --- | --- Common combinators used across encodings. --- --- @since 0.2.1.0 -module Data.TypedEncoding.Combinators.Restriction.Common where - -import GHC.TypeLits -import Data.TypedEncoding.Internal.Util.TypeLits -import Data.TypedEncoding.Instances.Support - --- $setup --- >>> :set -XOverloadedStrings -XMultiParamTypeClasses -XDataKinds -XTypeApplications - - --- | Universal decode for all "r-" types -decFR :: (IsR s ~ 'True, Applicative f) => - Enc (s ': xs) c str -> f (Enc xs c str) -decFR = implTranP id - - --- | --- Manual recreate step combinator converting @"r-"@ encode function to a recreate step. --- --- For "r-" encoding recreate and encode are the same other than the exception type used. --- --- The convention in @typed-encoding@ is to implement encode and convert it to recreate. -recWithEncR :: forall (s :: Symbol) xs c str . (IsR s ~ 'True) - => (Enc xs c str -> Either EncodeEx (Enc (s ': xs) c str)) - -> Enc xs c str -> Either RecreateEx (Enc (s ': xs) c str) -recWithEncR = unsafeRecWithEncR - - -unsafeRecWithEncR :: forall (s :: Symbol) xs c str . - (Enc xs c str -> Either EncodeEx (Enc (s ': xs) c str)) - -> Enc xs c str -> Either RecreateEx (Enc (s ': xs) c str) -unsafeRecWithEncR fn = either (Left . encToRecrEx) Right . fn - --- | --- >>> :kind! IsR "r-UPPER" --- ... --- ... 'True --- --- >>> :kind! IsR "do-UPPER" --- ... --- = (TypeError ... -type family IsR (s :: Symbol) :: Bool where - IsR s = AcceptEq ('Text "Not restriction encoding " ':<>: ShowType s ) (CmpSymbol "r-" (Take 2 s)) - - -type family IsROrEmpty (s :: Symbol) :: Bool where - IsROrEmpty "" = True - IsROrEmpty x = IsR x diff --git a/src/Data/TypedEncoding/Combinators/ToEncStr.hs b/src/Data/TypedEncoding/Combinators/ToEncStr.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypedEncoding/Combinators/ToEncStr.hs @@ -0,0 +1,50 @@ + +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | v0.2 like (backward compatible) combinators for covering to and from encoded string. +-- +-- @since 0.3.0.0 + +module Data.TypedEncoding.Combinators.ToEncStr where + +import Data.TypedEncoding.Common.Class +import Data.TypedEncoding.Common.Types (Enc(..) ) + +import Data.Functor.Identity + +toEncStringF :: forall nm f a str . (ToEncString f nm nm a str) => a -> f (Enc '[nm] () str) +toEncStringF = toEncStringF' @nm @nm + +toEncStringF' :: forall alg nm f a str . (ToEncString f nm alg a str) => a -> f (Enc '[nm] () str) +toEncStringF' = toEncF @f @nm @alg + +toEncString :: forall nm a str . (ToEncString Identity nm nm a str) => a -> Enc '[nm] () str +toEncString = toEncString' @nm @nm + +toEncString' :: forall alg nm a str . (ToEncString Identity nm alg a str) => a -> Enc '[nm] () str +toEncString' = runIdentity . toEncF @Identity @nm @alg + + + +-- backward compatible v0.2 like combinators +fromEncStringF :: forall nm f a str . (FromEncString f nm nm a str) => Enc '[nm] () str -> f a +fromEncStringF = fromEncStringF' @nm @nm + +fromEncStringF' :: forall alg nm f a str . (FromEncString f nm alg a str) => Enc '[nm] () str -> f a +fromEncStringF' = fromEncF @f @nm @alg + +fromEncString :: forall nm a str . (FromEncString Identity nm nm a str) => Enc '[nm] () str -> a +fromEncString = fromEncString' @nm @nm + +fromEncString' :: forall alg nm a str . (FromEncString Identity nm alg a str) => Enc '[nm] () str -> a +fromEncString' = runIdentity . fromEncF @Identity @nm @alg diff --git a/src/Data/TypedEncoding/Combinators/Unsafe.hs b/src/Data/TypedEncoding/Combinators/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypedEncoding/Combinators/Unsafe.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Basic unsafe operations on 'Enc' +module Data.TypedEncoding.Combinators.Unsafe where + +import Data.TypedEncoding.Common.Types.Enc +import Data.Proxy + + +-- | +-- Currently recommended way of recreating encoding from trusted input, +-- if avoiding cost of "Data.TypedEncoding.Common.Types.Validation" is important +-- +-- @since 0.1.0.0 (moved) +unsafeSetPayload :: conf -> str -> Enc enc conf str +unsafeSetPayload = UnsafeMkEnc Proxy + +-- | +-- @since 0.1.0.0 (moved) +withUnsafeCoerce :: (s1 -> s2) -> Enc e1 c s1 -> Enc e2 c s2 +withUnsafeCoerce f (UnsafeMkEnc _ conf str) = UnsafeMkEnc Proxy conf (f str) + +-- | +-- @since 0.3.0.0 +withUnsafeCoerceF :: forall e1 e2 f c s1 s2 . Functor f => (s1 -> f s2) -> Enc e1 c s1 -> f (Enc e2 c s2) +withUnsafeCoerceF f (UnsafeMkEnc _ conf str) = UnsafeMkEnc Proxy conf <$> f str + +-- | +-- @since 0.1.0.0 (moved) +unsafeChangePayload :: (s1 -> s2) -> Enc e c s1 -> Enc e c s2 +unsafeChangePayload f (UnsafeMkEnc p conf str) = UnsafeMkEnc p conf (f str) diff --git a/src/Data/TypedEncoding/Combinators/Validate.hs b/src/Data/TypedEncoding/Combinators/Validate.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypedEncoding/Combinators/Validate.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} + +-- | Combinators reexported in Data.TypedEncoding +module Data.TypedEncoding.Combinators.Validate where + +import Data.TypedEncoding.Combinators.Common +import Data.TypedEncoding.Combinators.Unsafe +import Data.TypedEncoding.Common.Types +import Data.TypedEncoding.Common.Class.Validate +import Data.TypedEncoding.Common.Class.Util (SymbolList, Append) +import GHC.TypeLits +import Data.Functor.Identity + + +-- * Validation + +-- | Maybe signals annotation mismatch, effect @f@ is not evaluated unless there is match +checkWithValidations :: forall algs (nms :: [Symbol]) f c str . ( + Monad f + , SymbolList nms + ) => Validations f nms algs c str -> UncheckedEnc c str -> Maybe (f (Enc nms c str)) +checkWithValidations vers x = + case verifyAnn @nms x of + Left err -> Nothing -- asRecreateErr_ perr $ Left err + Right (MkUncheckedEnc _ c str) -> Just $ recreateWithValidations vers . toEncoding c $ str + +check :: forall (nms :: [Symbol]) f c str . ( + Monad f + , ValidateAll f nms nms c str + , SymbolList nms + ) => UncheckedEnc c str -> Maybe (f (Enc nms c str)) +check = checkWithValidations @nms @nms @f validations + +check' :: forall algs (nms :: [Symbol]) f c str . ( + Monad f + , ValidateAll f nms algs c str + , SymbolList nms + ) => UncheckedEnc c str -> Maybe (f (Enc nms c str)) +check' = checkWithValidations @algs @nms @f validations + + +recreateWithValidations :: forall algs nms f c str . (Monad f) => Validations f nms algs c str -> Enc ('[]::[Symbol]) c str -> f (Enc nms c str) +recreateWithValidations vers str@(UnsafeMkEnc _ _ pay) = + let str0 :: Enc nms c str = withUnsafeCoerce id str + in withUnsafeCoerce (const pay) <$> runValidationChecks vers str0 + +-- * v0.2 style recreate functions + +recreateFAll :: forall nms f c str . (Monad f, ValidateAll f nms nms c str) => + Enc ('[]::[Symbol]) c str + -> f (Enc nms c str) +recreateFAll = recreateFAll' @nms @nms + +recreateAll :: forall nms c str . (ValidateAll Identity nms nms c str) => + Enc ('[]::[Symbol]) c str + -> Enc nms c str +recreateAll = recreateAll' @nms @nms + +recreateFPart :: forall xs xsf f c str . (Monad f, ValidateAll f xs xs c str) => Enc xsf c str -> f (Enc (Append xs xsf) c str) +recreateFPart = recreateFPart' @xs @xs + +-- * Convenience combinators which mimic pre-v0.3 type signatures. These do not try to figure out @algs@ or assume much about them + +recreateFAll' :: forall algs nms f c str . (Monad f, ValidateAll f nms algs c str) => + Enc ('[]::[Symbol]) c str + -> f (Enc nms c str) +recreateFAll' = recreateWithValidations @algs @nms @f validations + +recreateAll' :: forall algs nms c str . (ValidateAll Identity nms algs c str) => + Enc ('[]::[Symbol]) c str + -> Enc nms c str +recreateAll' = runIdentity . recreateFAll' @algs + +recreateFPart' :: forall algs xs xsf f c str . (Monad f, ValidateAll f xs algs c str) => Enc xsf c str -> f (Enc (Append xs xsf) c str) +recreateFPart' = aboveF @xsf @'[] @xs (recreateFAll' @algs) + +recreatePart' :: forall algs xs xsf c str . (ValidateAll Identity xs algs c str) => Enc xsf c str -> Enc (Append xs xsf) c str +recreatePart' = runIdentity . recreateFPart' @algs @xs + + +-------------------------------------------- diff --git a/src/Data/TypedEncoding/Common/Class.hs b/src/Data/TypedEncoding/Common/Class.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypedEncoding/Common/Class.hs @@ -0,0 +1,63 @@ + +{-# 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.Common.Class ( + module Data.TypedEncoding.Common.Class + , module Data.TypedEncoding.Common.Class.Util + , module Data.TypedEncoding.Common.Class.Encode + , module Data.TypedEncoding.Common.Class.Decode + , module Data.TypedEncoding.Common.Class.Validate + , module Data.TypedEncoding.Common.Class.Superset + ) where + +import Data.TypedEncoding.Common.Class.Util +import Data.TypedEncoding.Common.Class.Encode +import Data.TypedEncoding.Common.Class.Decode +import Data.TypedEncoding.Common.Class.Validate +import Data.TypedEncoding.Common.Class.Superset + +import Data.TypedEncoding.Common.Types (Enc(..) ) +import Data.TypedEncoding.Combinators.Unsafe (withUnsafeCoerce) + +import GHC.TypeLits + + + +-- | +-- Generalized Java @toString@ or a type safe version of Haskell's 'Show'. +-- +-- Encodes @a@ as @Enc '[xs]@ specifying algorithm @alg@ and using effect @f@ +-- +class (KnownSymbol nm, KnownSymbol ann) => ToEncString f nm ann a str where + toEncF :: a -> f (Enc '[nm] () str) + +-- | +-- Reverse of 'ToEncString' decodes encoded string back to @a@ +class (KnownSymbol nm, KnownSymbol ann) => FromEncString f nm ann a str where + fromEncF :: Enc '[nm] () str -> f a + + + +-- Other classes -- + +-- | Flatten is more permissive 'IsSuperset' +-- @ +-- instance FlattenAs "r-ASCII" "enc-B64" where -- OK +-- @ +-- +-- Now encoded data has form @Enc '["r-ASCII"] c str@ +-- and there is no danger of it begin incorrectly decoded. + +class FlattenAs (y :: Symbol) (x :: Symbol) where + flattenAs :: Enc (x ': xs) c str -> Enc '[y] c str + flattenAs = withUnsafeCoerce id diff --git a/src/Data/TypedEncoding/Common/Class/Decode.hs b/src/Data/TypedEncoding/Common/Class/Decode.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypedEncoding/Common/Class/Decode.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} + +module Data.TypedEncoding.Common.Class.Decode where + +import Data.TypedEncoding.Common.Types (UnexpectedDecodeEx(..)) +import Data.TypedEncoding.Common.Types.Decoding +import Data.Proxy +import Data.Functor.Identity +import GHC.TypeLits + +-- | +-- @since 0.3.0.0 +class Decode f nm alg conf str where + decoding :: Decoding f nm alg conf str + +-- | +-- @since 0.3.0.0 +class DecodeAll f nms algs conf str where + decodings :: Decodings f nms algs conf str + +instance DecodeAll f '[] '[] conf str where + decodings = ZeroD + +instance (DecodeAll f nms algs conf str, Decode f nm alg conf str) => DecodeAll f (nm ': nms) (alg ': algs) conf str where + decodings = ConsD decoding decodings + + +-- | With type safety in place decoding errors should be unexpected. +-- This class can be used to provide extra info if decoding could fail +-- +-- @since 0.1.0.0 +class UnexpectedDecodeErr f where + unexpectedDecodeErr :: UnexpectedDecodeEx -> f a + +instance UnexpectedDecodeErr Identity where + unexpectedDecodeErr x = fail $ show x + +instance UnexpectedDecodeErr (Either UnexpectedDecodeEx) where + unexpectedDecodeErr = Left + +-- | +-- @since 0.1.0.0 +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 + +-- | +-- @since 0.1.0.0 +asUnexpected :: forall x f err a . (KnownSymbol x, UnexpectedDecodeErr f, Applicative f, Show err) => Either err a -> f a +asUnexpected = asUnexpected_ (Proxy :: Proxy x) diff --git a/src/Data/TypedEncoding/Common/Class/Encode.hs b/src/Data/TypedEncoding/Common/Class/Encode.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypedEncoding/Common/Class/Encode.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} + +module Data.TypedEncoding.Common.Class.Encode where + +import Data.TypedEncoding.Common.Types.Enc + + +-- | +-- Using 2 Symbol type variables (@nm@ and @alg@) creates what seems like redundant typing +-- in statically defined instances such as @"r-ASCII"@, however it +-- provides future flexibility to +-- constrain @nm@ in some interesting way, different than @AlgNm nm ~ alg@. +-- +-- It also seems to be easier to understand as type variables used in the definition of 'Encoding' +-- match with what is on the typeclass. +-- +-- @alg@ is expected to be very statically defined and is needed to support more open instances such as @"r-ban"@. +-- +-- @since 0.3.0.0 +class Encode f nm alg conf str where + encoding :: Encoding f nm alg conf str + +-- | +-- @since 0.3.0.0 +class EncodeAll f nms algs conf str where + encodings :: Encodings f nms algs conf str + +instance EncodeAll f '[] '[] conf str where + encodings = ZeroE + +instance (EncodeAll f nms algs conf str, Encode f nm alg conf str) => EncodeAll f (nm ': nms) (alg ': algs) conf str where + encodings = ConsE encoding encodings + + + + diff --git a/src/Data/TypedEncoding/Common/Class/IsStringR.hs b/src/Data/TypedEncoding/Common/Class/IsStringR.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypedEncoding/Common/Class/IsStringR.hs @@ -0,0 +1,72 @@ + + +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | This Module will be removed in the future in favor of classes defined in +-- "Data.TypedEncoding.Common.Class.Util.StringConstraints" +module Data.TypedEncoding.Common.Class.IsStringR where + +import Data.Proxy + +import Data.String +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() + +-- | This class will be removed in 0.3.x.x in favor of classes definined in +-- "Data.TypedEncoding.Common.Class.Util.StringConstraints" +-- +-- 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 + +instance IsStringR [Char] where + toString = id diff --git a/src/Data/TypedEncoding/Common/Class/Superset.hs b/src/Data/TypedEncoding/Common/Class/Superset.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypedEncoding/Common/Class/Superset.hs @@ -0,0 +1,89 @@ + +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +-- {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +module Data.TypedEncoding.Common.Class.Superset where + +import Data.TypedEncoding.Common.Util.TypeLits + +import Data.TypedEncoding.Common.Types (Enc(..) ) +import Data.TypedEncoding.Combinators.Unsafe (withUnsafeCoerce) +import GHC.TypeLits +import Data.Symbol.Ascii + + +-- $setup +-- >>> :set -XOverloadedStrings -XMultiParamTypeClasses -XDataKinds -XTypeApplications +-- >>> import Data.TypedEncoding +-- >>> import Data.TypedEncoding.Instances.Restriction.UTF8 () +-- >>> import Data.TypedEncoding.Instances.Restriction.ASCII () +-- >>> import Data.Text as T + + +-- | +-- Replaces previous @Superset@ typeclass. +-- +-- Subsets are useful for restriction encodings +-- like r-UFT8 but should not be used for other encodings as +-- this would be dangerous. For example, considering "enc-" encoding as a superset of "r-" encoding would +-- permit converting encoded binary +-- @"Enc '["enc-"] c ByteString@ to @"Enc '["r-ASCII"] c ByteString@ and then to @"Enc '["r-ASCII"] c Text@, +-- which could result in runtime errors. +-- +-- The requirement is that that the decoding in the superset +-- can replace the decoding from injected subset. +-- +-- @IsSuperset bigger smaller@ reads as @bigger@ is a superset of @smaller@ +-- +-- @since 0.2.2.0 +type family IsSuperset (y :: Symbol) (x :: Symbol) :: Bool where + IsSuperset "r-ASCII" "r-ASCII" = 'True + IsSuperset "r-UTF8" "r-ASCII" = 'True + IsSuperset "r-UTF8" "r-UTF8" = 'True + IsSuperset y x = IsSupersetOpen y (TakeUntil x ":") (ToList x) + +type family IsSupersetOpen (y :: Symbol) (x :: Symbol) (xs :: [Symbol]) :: Bool + +-- | +-- >>> let Right tstAscii = encodeFAll . toEncoding () $ "Hello World" :: Either EncodeEx (Enc '["r-ASCII"] () T.Text) +-- >>> displ (injectInto @ "r-UTF8" tstAscii) +-- "Enc '[r-UTF8] () (Text Hello World)" +-- +-- @since 0.2.2.0 +injectInto :: forall y x xs c str . (IsSuperset y x ~ 'True) => Enc (x ': xs) c str -> Enc (y ': xs) c str +injectInto = withUnsafeCoerce id + +-- TODO consider expanding to +-- _injectInto ::forall y x xs c str . (IsSuperset y x ~ 'True) => Enc (x ': xs) c str -> Enc (Replace x y xs) c str + +-- | +-- IsSuperset is not intended for @"enc-"@ encodings. This class is. +-- +-- It allows to specify constraints that say, for example, that /Base 64/ encodes into +-- a subset of /ASCII/. +-- +-- @since 0.3.0.0 +class EncodingSuperset (enc :: Symbol) where + type EncSuperset enc :: Symbol + + implEncInto :: forall xs c str . Enc (enc ': xs) c str -> Enc (EncSuperset enc ': enc ': xs) c str + implEncInto = withUnsafeCoerce id + +{-# WARNING implEncInto "Using this method at the call site may not be backward compatible between minor version upgrades, use _encodesInto instead." #-} + +_encodesInto :: forall y enc xs c str r . (IsSuperset y r ~ 'True, EncodingSuperset enc, r ~ EncSuperset enc) => Enc (enc ': xs) c str -> Enc (y ': enc ': xs) c str +_encodesInto = injectInto . implEncInto + +-- prop_Superset :: forall y x xs c str . (Superset y x, Eq str) => Enc (x ': xs) c str -> Bool +-- prop_Superset x = getPayload x == (getPayload . inject @y @x $ x) + diff --git a/src/Data/TypedEncoding/Common/Class/Util.hs b/src/Data/TypedEncoding/Common/Class/Util.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypedEncoding/Common/Class/Util.hs @@ -0,0 +1,89 @@ + +{-# 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.Common.Class.Util where + +import Data.TypedEncoding.Common.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 x = "[" ++ L.intercalate "," 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 ++ ")" +instance Displ String where + displ x = "(String " ++ 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 () diff --git a/src/Data/TypedEncoding/Common/Class/Util/StringConstraints.hs b/src/Data/TypedEncoding/Common/Class/Util/StringConstraints.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypedEncoding/Common/Class/Util/StringConstraints.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | Future replacement for "Data.TypedEncoding.Common.Class.IsStringR" +module Data.TypedEncoding.Common.Class.Util.StringConstraints where + +import qualified Data.List as L +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Data.String +import Data.Proxy +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy.Char8 as BL8 + +-- $setup +-- >>> :set -XScopedTypeVariables -XTypeApplications -XAllowAmbiguousTypes +-- >>> import Test.QuickCheck +-- >>> import Test.QuickCheck.Instances.Text() +-- >>> import Test.QuickCheck.Instances.ByteString() + + +-- * IsString reversal + +-- | Reverses 'Data.String.IsString' +-- +-- law for types that are also @IsString@: +-- +-- @ +-- toString . fromString == id +-- @ +-- +-- Note: ByteString is not a valid instance, ByteString "r-ASCII", or "r-UTF8" would +-- be needed. +-- @B8.unpack $ B8.pack "\160688" == "\176"@ +-- +-- This class is separated from @ToStrIso@ to allow instances from /smaller/ types +-- the can inject into the 'String' type. +class ToStrInj str from where + toString :: from -> str + +prop_toStringFromString :: forall s . (IsString s, ToStrInj String s) => Proxy s -> String -> Bool +prop_toStringFromString _ x = x == (toString @String @s . fromString $ x) + + +-- | +-- prop> prop_toStringFromString (Proxy :: Proxy T.Text) +instance ToStrInj String T.Text where + toString = T.unpack + +-- | +-- prop> prop_toStringFromString (Proxy :: Proxy TL.Text) +instance ToStrInj String TL.Text where + toString = TL.unpack + + +instance ToStrInj String String where + toString = id + +-- will not work! +-- prop> prop_toStringFromString (Proxy :: Proxy B.ByteString) +-- instance ToStrInj String B.ByteString where +-- toString = B8.unpack + +-- will not work! +-- prop> prop_toStringFromString (Proxy :: Proxy BL.ByteString) +-- instance ToStrInj String BL.ByteString where +-- toString = BL8.unpack + + +-- | Same as @ToStrInj@ but with additional +-- +-- law for types that are also @IsString@: +-- @ +-- fromString . toString == id +-- @ +class ToStrInj str from => ToStrIso str from where + +prop_fromStringToString :: forall s . (IsString s, ToStrIso String s, Eq s) => s -> Bool +prop_fromStringToString x = x == (fromString @s . toString $ x) + +-- | +-- prop> prop_fromStringToString @T.Text +instance ToStrIso String T.Text where + +-- | +-- prop> prop_fromStringToString @TL.Text +instance ToStrIso String TL.Text where + +instance ToStrIso String String where + +-- | +-- Used to find exceptions that violated "r-" encoding +-- Expected to be used to check encoding of ASCII-7 so Text and ByteString are compatible. +class Char8Find str where + find :: (Char -> Bool) -> str -> Maybe Char + +instance Char8Find String where + find = L.find + +instance Char8Find T.Text where + find = T.find + +instance Char8Find TL.Text where + find = TL.find + +-- | +-- B8.pack is basically a convenient way to get Word8 elements into ByteString. +-- +-- During B8.pack conversion charters are downsized to the 0-255 range (become a Word8). +-- The length is preserved. +-- +-- >>> B8.pack "\160582" +-- "F" +-- +-- >>> B.length $ B8.pack "\160582" +-- 1 +-- +-- This instance allows to check elements of ByteString interpreting them as Char. +-- +-- Safe if restricting to 7bit code points. +instance Char8Find B.ByteString where + find = B8.find + +instance Char8Find BL.ByteString where + find = BL8.find diff --git a/src/Data/TypedEncoding/Common/Class/Validate.hs b/src/Data/TypedEncoding/Common/Class/Validate.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypedEncoding/Common/Class/Validate.hs @@ -0,0 +1,50 @@ + +{-# 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.Common.Class.Validate where + +import Data.TypedEncoding.Common.Types (RecreateEx(..)) +import Data.TypedEncoding.Common.Types.Validation + +import Data.Proxy +import GHC.TypeLits + + +class Validate f nm alg conf str where + validation :: Validation f nm alg conf str + +class ValidateAll f nms algs conf str where + validations :: Validations f nms algs conf str + +instance ValidateAll f '[] '[] conf str where + validations = ZeroV + +instance (ValidateAll f nms algs conf str, Validate f nm alg conf str) => ValidateAll f (nm ': nms) (alg ': algs) conf str where + validations = ConsV validation validations + + + +-- | 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) diff --git a/src/Data/TypedEncoding/Common/Types.hs b/src/Data/TypedEncoding/Common/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypedEncoding/Common/Types.hs @@ -0,0 +1,23 @@ + +-- | +-- Internal definition of types + +module Data.TypedEncoding.Common.Types ( + module Data.TypedEncoding.Common.Types + , module Data.TypedEncoding.Common.Types.Enc + , module Data.TypedEncoding.Common.Types.Decoding + , module Data.TypedEncoding.Common.Types.Validation + , module Data.TypedEncoding.Common.Types.CheckedEnc + , module Data.TypedEncoding.Common.Types.UncheckedEnc + , module Data.TypedEncoding.Common.Types.Common + , module Data.TypedEncoding.Common.Types.Exceptions + ) where + +import Data.TypedEncoding.Common.Types.Enc +import Data.TypedEncoding.Common.Types.Decoding +import Data.TypedEncoding.Common.Types.Validation +import Data.TypedEncoding.Common.Types.CheckedEnc +import Data.TypedEncoding.Common.Types.UncheckedEnc +import Data.TypedEncoding.Common.Types.Common +import Data.TypedEncoding.Common.Types.Exceptions + diff --git a/src/Data/TypedEncoding/Common/Types/CheckedEnc.hs b/src/Data/TypedEncoding/Common/Types/CheckedEnc.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypedEncoding/Common/Types/CheckedEnc.hs @@ -0,0 +1,86 @@ +{-# 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.Common.Types.CheckedEnc where + +import Data.TypedEncoding.Common.Types.Enc +import Data.TypedEncoding.Common.Types.Common +import Data.TypedEncoding.Common.Class.Util +import Data.Proxy + +-- $setup +-- >>> :set -XOverloadedStrings -XMultiParamTypeClasses -XDataKinds -XAllowAmbiguousTypes +-- >>> import qualified Data.Text as T +-- >>> import Data.TypedEncoding.Combinators.Unsafe (unsafeSetPayload) + + +-- * 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.Common.Types.Enc.Enc'. +-- @CheckedEnc@ contains verified encoded data, encoding is visible +-- at the value level only. +data CheckedEnc conf str = UnsafeMkCheckedEnc [EncAnn] conf str + deriving (Show, Eq) + +unsafeCheckedEnc:: [EncAnn] -> c -> s -> CheckedEnc c s +unsafeCheckedEnc = UnsafeMkCheckedEnc + +getCheckedPayload :: CheckedEnc conf str -> str +getCheckedPayload = snd . getCheckedEncPayload + +getCheckedEncPayload :: CheckedEnc conf str -> ([EncAnn], str) +getCheckedEncPayload (UnsafeMkCheckedEnc t _ s) = (t,s) + +toCheckedEnc :: forall xs c str . (SymbolList xs) => Enc xs c str -> CheckedEnc c str +toCheckedEnc (UnsafeMkEnc p c s) = + UnsafeMkCheckedEnc (symbolVals @ xs) c s + + +fromCheckedEnc :: forall xs c str . SymbolList xs => CheckedEnc c str -> Maybe (Enc xs c str) +fromCheckedEnc (UnsafeMkCheckedEnc xs c s) = + let p = Proxy :: Proxy xs + in if symbolVals @ xs == xs + then Just $ UnsafeMkEnc p c s + else Nothing + +------------------------ + +-- | +-- >>> let encsometest = UnsafeMkCheckedEnc ["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) +-- "UnsafeMkCheckedEnc [TEST] () (Text hello)" +instance (Show c, Displ str) => Displ (CheckedEnc c str) where + displ (UnsafeMkCheckedEnc xs c s) = + "UnsafeMkCheckedEnc " ++ displ xs ++ " " ++ show c ++ " " ++ displ s + diff --git a/src/Data/TypedEncoding/Common/Types/Common.hs b/src/Data/TypedEncoding/Common/Types/Common.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypedEncoding/Common/Types/Common.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +-- {-# LANGUAGE FlexibleInstances #-} +-- {-# LANGUAGE FlexibleContexts #-} +-- {-# LANGUAGE UndecidableInstances #-} +-- {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} + +module Data.TypedEncoding.Common.Types.Common where + +import Data.TypedEncoding.Common.Util.TypeLits +import GHC.TypeLits + + +-- $setup +-- >>> :set -XScopedTypeVariables -XTypeFamilies -XKindSignatures -XDataKinds + + +-- | Represents value level (single) annotation. +type EncAnn = String + +type Restriction s = (KnownSymbol s, IsR s ~ 'True) + +type Algorithm nm alg = AlgNm nm ~ alg + + +-- | +-- Converts encoding name to algorithm name, this assumes the ":" delimiter expected by this library. +-- +-- This allows working with open encoding definitions such as "r-ban" or "r-bool" +-- +-- >>> :kind! AlgNm "enc-B64" +-- ... +-- = "enc-B64" +-- +-- >>> :kind! AlgNm "r-ban:999-99-9999" +-- ... +-- = "r-ban" +-- +type family AlgNm (encnm :: Symbol) :: Symbol where + AlgNm encnm = TakeUntil encnm ":" + + +type family AlgNmMap (nms :: [Symbol]) :: [Symbol] where + AlgNmMap '[] = '[] + AlgNmMap (x ': xs) = AlgNm x ': AlgNmMap xs + +-- | +-- >>> :kind! IsR "r-UPPER" +-- ... +-- ... 'True +-- +-- >>> :kind! IsR "do-UPPER" +-- ... +-- = (TypeError ... +type family IsR (s :: Symbol) :: Bool where + IsR s = AcceptEq ('Text "Not restriction encoding " ':<>: ShowType s ) (CmpSymbol "r-" (Take 2 s)) + + +type family IsROrEmpty (s :: Symbol) :: Bool where + IsROrEmpty "" = True + IsROrEmpty x = IsR x + diff --git a/src/Data/TypedEncoding/Common/Types/Decoding.hs b/src/Data/TypedEncoding/Common/Types/Decoding.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypedEncoding/Common/Types/Decoding.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} + +-- | +-- Internal definition of types +-- +-- Decoding types for @Enc@ +module Data.TypedEncoding.Common.Types.Decoding where + +import Data.Proxy +import GHC.TypeLits + +import Data.TypedEncoding.Common.Types.Enc +import Data.TypedEncoding.Common.Types.Common + +-- | +-- Similar to 'Data.TypedEncoding.Common.Types.Enc.Encoding' +-- +-- Used to create instances of decoding. + +data Decoding f (nm :: Symbol) (alg :: Symbol) conf str where + -- | Consider this constructor as private or use it with care + -- + -- Using this constructor: + -- @ + -- MkDecoding :: Proxy nm -> (forall (xs :: [Symbol]) . Enc (nm ': xs) conf str -> f (Enc xs conf str)) -> Decoding f nm (AlgNm nm) conf str + -- @ + -- + -- would make compilation much slower + UnsafeMkDecoding :: Proxy nm -> (forall (xs :: [Symbol]) . Enc (nm ': xs) conf str -> f (Enc xs conf str)) -> Decoding f nm alg conf str + +-- | Type safe smart constructor +-- (See also 'Data.TypedEncoding.Common.Types.Enc._mkEncoding') +mkDecoding :: forall f (nm :: Symbol) conf str . (forall (xs :: [Symbol]) . Enc (nm ': xs) conf str -> f (Enc xs conf str)) -> Decoding f nm (AlgNm nm) conf str +mkDecoding = UnsafeMkDecoding Proxy + +runDecoding :: forall alg nm f xs conf str . Decoding f nm alg conf str -> Enc (nm ': xs) conf str -> f (Enc xs conf str) +runDecoding (UnsafeMkDecoding _ fn) = fn + +-- | Same as 'runDecoding" but compiler figures out algorithm name +-- +-- Using it can slowdown compilation +_runDecoding :: forall nm f xs conf str alg . (AlgNm nm ~ alg) => Decoding f nm alg conf str -> Enc (nm ': xs) conf str -> f (Enc xs conf str) +_runDecoding = runDecoding @(AlgNm nm) + +-- | +-- Wraps a list of @Decoding@ elements. +-- +-- Similarly to 'Data.TypedEncoding.Common.Types.Enc.Encodings' can be used with a typeclass +-- 'Data.TypedDecoding.Internal.Class.Decode.DecodeAll' +data Decodings f (nms :: [Symbol]) (algs :: [Symbol]) 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 + ZeroD :: Decodings f '[] '[] conf str + ConsD :: Decoding f nm alg conf str -> Decodings f nms algs conf str -> Decodings f (nm ': nms) (alg ': algs) conf str + +runDecodings :: forall algs nms f c str . (Monad f) => Decodings f nms algs c str -> Enc nms c str -> f (Enc ('[]::[Symbol]) c str) +runDecodings ZeroD enc0 = pure enc0 +runDecodings (ConsD fn xs) enc = + let re :: f (Enc _ c str) = runDecoding fn enc + in re >>= runDecodings xs + + +-- | At possibly big compilation cost, have compiler figure out algorithm names. +_runDecodings :: forall nms f c str algs . (Monad f, algs ~ AlgNmMap nms) => Decodings f nms algs c str -> Enc nms c str -> f (Enc ('[]::[Symbol]) c str) +_runDecodings = runDecodings @(AlgNmMap nms) diff --git a/src/Data/TypedEncoding/Common/Types/Enc.hs b/src/Data/TypedEncoding/Common/Types/Enc.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypedEncoding/Common/Types/Enc.hs @@ -0,0 +1,225 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} +-- | +-- Internal definition of types + +module Data.TypedEncoding.Common.Types.Enc where + +import Data.Proxy +import GHC.TypeLits + +import Data.TypedEncoding.Common.Class.Util +import Data.TypedEncoding.Common.Types.Common + +-- $setup +-- >>> :set -XOverloadedStrings -XMultiParamTypeClasses -XDataKinds -XAllowAmbiguousTypes +-- >>> import qualified Data.ByteString as B +-- >>> import qualified Data.Text as T +-- >>> import Data.Functor.Identity +-- >>> import Data.TypedEncoding +-- >>> import Data.TypedEncoding.Instances.Enc.Base64 () +-- >>> import Data.TypedEncoding.Instances.Restriction.BoundedAlphaNums () + +-- | +-- Contains encoded data annotated by +-- +-- * @nms@ list of @Symbol@s with encoding names (encoding stack) +-- * @conf@ that can contain configuration / encoding information such as digest. +-- * @str@ the encoded data +-- +-- Example: +-- +-- @ +-- Enc '["r-ASCII"] () ByteString +-- @ +-- +-- @since 0.1.0.0 +data Enc nms conf str where + -- | + -- @since 0.3.0.0 renamed from MkEnc + -- + -- Use of this constructor should be kept to a minimum. + -- + -- Use of 'Data.TypedEncoding.Combinators.Unsafe.unsafeSetPayload' currently recommended + -- for recovering 'Enc' from trusted input sources (if avoiding cost of "Data.TypedEncoding.Common.Types.Validation" is important). + UnsafeMkEnc :: Proxy nms -> conf -> str -> Enc nms conf str + deriving (Show, Eq) + +-- | +-- >>> let disptest = UnsafeMkEnc Proxy () "hello" :: Enc '["TEST"] () T.Text +-- >>> displ disptest +-- "Enc '[TEST] () (Text hello)" +instance (SymbolList xs, Show c, Displ str) => Displ ( Enc xs c str) where + displ (UnsafeMkEnc p c s) = + "Enc '" ++ displ (Proxy :: Proxy xs) ++ " " ++ show c ++ " " ++ displ s + +-- | +-- @since 0.1.0.0 +toEncoding :: conf -> str -> Enc ('[] :: [Symbol]) conf str +toEncoding = UnsafeMkEnc Proxy + +-- | +-- @since 0.1.0.0 +fromEncoding :: Enc '[] conf str -> str +fromEncoding = getPayload + +-- | +-- @since 0.1.0.0 +getPayload :: Enc enc conf str -> str +getPayload (UnsafeMkEnc _ _ str) = str + + + +-- | +-- Wraps the encoding function. +-- Contains type level information about the encoding name and the algorithm used. +-- +-- This type is used by programs implementing encoding instance. +-- Such program needs to define a value of this type. +-- It also implements 'Data.TypedEncoding.Common.Class.Encode.Encode' instance that simply returns that value. +-- +-- Programs using encoding can access this type using 'Data.TypedEncoding.Common.Class.Encode.Encode.encoding' +-- (from the @Encode@ typeclass) but a better (and recommended) approach is to use its plural sibling 'Encodings' +-- defined below. +-- +-- This type has 2 symbol type variables: +-- +-- * @nm@ defines the encoding +-- * @alg@ defines algorithm +-- +-- These two are related, currently this library only supports +-- +-- * Names @nm@ containing ":" using format "alg:...", for example name "r-ban:999" has "r-ban" algorithm +-- * Names without ":" require that @nm ~ alg@ +-- +-- Future version are likely to relax this, possibly introducing ability do define more than one algorithm +-- for given encoding. +-- +-- Using 2 variables allows us to define typeclass constraints that work +-- with definitions like @"r-ban"@ where @"r-ban:@" can be followed by arbitrary +-- string literal. +-- +-- Examples: +-- +-- @ +-- Encoding (Either EncodeEx) "r-ban:9" "r-ban" () String +-- @ +-- +-- encodes a single character @ <= 9'@ +-- +-- @ +-- Encoding Identity "enc-B64" "enc-B64" () ByteString +-- @ +-- +-- Represents a /Byte 64/ encoder that can operate on any stack of previous encodings. +-- (encoding name and algorithm name are "enc-B64", there is no +-- additional configuration @()@ needed and it runs in the @Identity@ Functor. +-- +-- Similar boilerplate for /Decoding/ and /Validation/ is specified in separate modules. +-- +-- @since 0.3.0.0 +data Encoding f (nm :: Symbol) (alg :: Symbol) conf str where + -- | Consider this constructor as private or use it with care + -- + -- Defining constructor like this: + -- @ + -- MkEncoding :: Proxy nm -> (forall (xs :: [Symbol]) . Enc xs conf str -> f (Enc (nm ': xs) conf str)) -> Encoding f nm (AlgNm nm) conf str + -- @ + -- + -- would make compilation much slower + UnsafeMkEncoding :: Proxy nm -> (forall (xs :: [Symbol]) . Enc xs conf str -> f (Enc (nm ': xs) conf str)) -> Encoding f nm alg conf str + +-- | Type safe smart constructor +-- +-- Adding the type family @(AlgNm nm)@ mapping to @Encoding@ constructor slows down the compilation. +-- Using smart constructor does not have that issue. +-- +-- This approach also provides more future flexibility with possibility of future overloads relaxing current +-- limitations on @alg@ names. +-- +-- /Notice underscore @_@ convention, it indicates a use of @Algorithm@ @AlgNm@: compiler figures out @alg@ value. These can be slower to compile when used. / +-- +-- Here are other conventions that relate to the existence of @alg@ +-- +-- * functions ending with: @'@, for example 'Data.TypedEncoding.Combinators.Encode.encodeF'' have @alg@ +-- as first type variable in the @forall@ list. +-- +-- * functions without tick tend to assume @nm ~ alg@ +-- +-- This particular function appears to not increase compilation time. +-- +-- @since 0.3.0.0 +_mkEncoding :: forall f (nm :: Symbol) conf str . (forall (xs :: [Symbol]) . Enc xs conf str -> f (Enc (nm ': xs) conf str)) -> Encoding f nm (AlgNm nm) conf str +_mkEncoding = UnsafeMkEncoding Proxy + +-- | +-- @since 0.3.0.0 +runEncoding' :: forall alg nm f xs conf str . Encoding f nm alg conf str -> Enc xs conf str -> f (Enc (nm ': xs) conf str) +runEncoding' (UnsafeMkEncoding _ fn) = fn + +-- | Same as 'runEncoding'' but compiler figures out algorithm name +-- +-- Using it can slowdown compilation +-- +-- This combinator has @Algorithm nm alg@ constraint (which stands for @TakeUntil ":" nm ~ alg@. +-- If rules on @alg@ are relaxed this will just return the /default/ algorithm. +-- +-- If that happens @-XTypeApplications@ annotations will be needed and @_@ methods will simply +-- use default algorithm name. +-- +-- @since 0.3.0.0 +_runEncoding :: forall nm f xs conf str alg . (Algorithm nm alg) => Encoding f nm alg conf str -> Enc xs conf str -> f (Enc (nm ': xs) conf str) +_runEncoding = runEncoding' @(AlgNm nm) + +-- | +-- HList like construction that defines a list of @Encoding@ elements. +-- +-- This type is used by programs using / manipulating encodings. +-- +-- Can be easily accessed with 'Data.TypedEncoding.Common.Class.Encode.EncodeAll' constraint using +-- 'Data.TypedEncoding.Common.Class.Encode.EncodeAll.encodings'. But could also be used by creating +-- @Encodings@ list by hand. +-- +-- @since 0.3.0.0 +data Encodings f (nms :: [Symbol]) (algs :: [Symbol]) 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 + ZeroE :: Encodings f '[] '[] conf str + ConsE :: Encoding f nm alg conf str -> Encodings f nms algs conf str -> Encodings f (nm ': nms) (alg ': algs) conf str + +-- | +-- Runs encodings, requires -XTypeApplication annotation specifying the algorithm(s) +-- +-- >>> runEncodings' @'["r-ban"] encodings . toEncoding () $ ("22") :: Either EncodeEx (Enc '["r-ban:111"] () T.Text) +-- Left (EncodeEx "r-ban:111" ("Input list has wrong size expecting 3 but length \"22\" == 2")) +-- +-- @since 0.3.0.0 +runEncodings' :: forall algs nms f c str . (Monad f) => Encodings f nms algs c str -> Enc ('[]::[Symbol]) c str -> f (Enc nms c str) +runEncodings' ZeroE enc0 = pure enc0 +runEncodings' (ConsE fn enc) enc0 = + let re :: f (Enc _ c str) = runEncodings' enc enc0 + in re >>= runEncoding' fn + + +-- | At a possibly some compilation cost, have compiler figure out algorithm names. +-- +-- >>> _runEncodings encodings . toEncoding () $ ("Hello World") :: Identity (Enc '["enc-B64","enc-B64"] () B.ByteString) +-- Identity (UnsafeMkEnc Proxy () "U0dWc2JHOGdWMjl5YkdRPQ==") +-- +-- >>> _runEncodings encodings . toEncoding () $ ("22") :: Either EncodeEx (Enc '["r-ban:111"] () T.Text) +-- Left (EncodeEx "r-ban:111" ("Input list has wrong size expecting 3 but length \"22\" == 2")) +-- +-- (see also '_runEncoding') +-- @since 0.3.0.0 +_runEncodings :: forall nms f c str algs . (Monad f, algs ~ AlgNmMap nms) => Encodings f nms algs c str -> Enc ('[]::[Symbol]) c str -> f (Enc nms c str) +_runEncodings = runEncodings' @(AlgNmMap nms) diff --git a/src/Data/TypedEncoding/Common/Types/Exceptions.hs b/src/Data/TypedEncoding/Common/Types/Exceptions.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypedEncoding/Common/Types/Exceptions.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +-- {-# LANGUAGE RankNTypes #-} + +-- | +-- Internal definition of types + +module Data.TypedEncoding.Common.Types.Exceptions where + + +import Data.Proxy +import GHC.TypeLits + + +-- $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 + 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 + +instance Show EncodeEx where + show (EncodeEx prxy a) = "(EncodeEx \"" ++ symbolVal prxy ++ "\" (" ++ show a ++ "))" + +asEncodeEx :: (Show a, KnownSymbol x) => Proxy x -> Either a b -> Either EncodeEx b +asEncodeEx p = either (Left . EncodeEx p) Right + + +-- | Useful when manually recreating using recovery +encToRecrEx :: EncodeEx -> RecreateEx +encToRecrEx (EncodeEx p a) = RecreateEx p a + +mergeEncodeEx :: KnownSymbol x => Proxy x -> EncodeEx -> Maybe EncodeEx -> EncodeEx +mergeEncodeEx _ ex Nothing = ex +mergeEncodeEx p (EncodeEx _ a) (Just (EncodeEx _ b)) = EncodeEx p $ "Errors: " ++ show (a,b) + +emptyEncErr :: KnownSymbol x => Proxy x -> EncodeEx +emptyEncErr p = EncodeEx p ("unexpected" :: String) + +-- | Type safety over encodings makes decoding process safe. +-- However failures are still possible due to bugs or unsafe payload modifications. +-- UnexpectedDecodeEx represents such errors. +data UnexpectedDecodeEx where + UnexpectedDecodeEx :: (Show a, KnownSymbol x) => Proxy x -> a -> UnexpectedDecodeEx + +instance Show UnexpectedDecodeEx where + show (UnexpectedDecodeEx prxy a) = "(UnexpectedDecodeEx \"" ++ symbolVal prxy ++ "\" (" ++ show a ++ "))" + + +-- * Base combinators that rely on types defined here + +mergeErrs :: err -> (err -> Maybe err -> err) -> Either err a -> Either err b -> Either err c +mergeErrs _ fn (Left er1) (Left er2) = Left (fn er1 $ Just er2) +mergeErrs _ fn (Left er1) _ = Left (fn er1 Nothing) +mergeErrs _ fn _ (Left er2) = Left (fn er2 Nothing) +mergeErrs de fn (Right r) (Right y) = Left de diff --git a/src/Data/TypedEncoding/Common/Types/SomeAnnotation.hs b/src/Data/TypedEncoding/Common/Types/SomeAnnotation.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypedEncoding/Common/Types/SomeAnnotation.hs @@ -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.Common.Types.SomeAnnotation where + +import Data.TypedEncoding.Common.Types.Common +import Data.TypedEncoding.Common.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 diff --git a/src/Data/TypedEncoding/Common/Types/SomeEnc.hs b/src/Data/TypedEncoding/Common/Types/SomeEnc.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypedEncoding/Common/Types/SomeEnc.hs @@ -0,0 +1,62 @@ +{-# 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.Common.Types.SomeEnc where + +import Data.TypedEncoding.Common.Types.Enc +import Data.TypedEncoding.Common.Class.Util +import Data.TypedEncoding.Common.Types.SomeAnnotation +import Data.TypedEncoding.Common.Types.CheckedEnc + +-- $setup +-- >>> :set -XOverloadedStrings -XMultiParamTypeClasses -XDataKinds -XAllowAmbiguousTypes +-- >>> import qualified Data.Text as T +-- >>> import Data.TypedEncoding.Combinators.Unsafe + + + +-- | Existentially quantified quantified @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 +-- UnsafeMkCheckedEnc ["TEST"] () "hello" +someToChecked :: SomeEnc conf str -> CheckedEnc conf str +someToChecked se = withSomeEnc se toCheckedEnc + +-- | +-- >>> let tst = unsafeCheckedEnc ["TEST"] () "test" +-- >>> displ $ checkedToSome tst +-- "Some (Enc '[TEST] () (String test))" +checkedToSome :: CheckedEnc conf str -> SomeEnc conf str +checkedToSome (UnsafeMkCheckedEnc xs c s) = withSomeAnnotation (someAnnValue xs) (\p -> MkSomeEnc (UnsafeMkEnc p c s)) + + +-- | +-- >>> let enctest = unsafeSetPayload () "hello" :: Enc '["TEST"] () T.Text +-- >>> displ $ MkSomeEnc enctest +-- "Some (Enc '[TEST] () (Text hello))" +instance (Show c, Displ str) => Displ (SomeEnc c str) where + displ (MkSomeEnc en) = + "Some (" ++ displ en ++ ")" diff --git a/src/Data/TypedEncoding/Common/Types/UncheckedEnc.hs b/src/Data/TypedEncoding/Common/Types/UncheckedEnc.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypedEncoding/Common/Types/UncheckedEnc.hs @@ -0,0 +1,53 @@ +{-# 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.Common.Types.UncheckedEnc where + +import Data.Proxy +import Data.TypedEncoding.Common.Class.Util +import Data.TypedEncoding.Common.Types.Common + +-- $setup +-- >>> :set -XOverloadedStrings -XMultiParamTypeClasses -XDataKinds -XAllowAmbiguousTypes +-- >>> import qualified Data.Text as T + + +-- * UncheckedEnc for validation, similar to CheckedEnc but not verified + +-- | Represents some encoded string where encoding was not validated. +-- +-- Similar to 'Data.TypedEncoding.Common.Types.CheckedEnc' but unlike +-- @CheckedEnc@ it can contain payloads that have invalid encoding. +-- +-- See 'Data.TypedEncoding.Combinators.Validate.check' +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 diff --git a/src/Data/TypedEncoding/Common/Types/Unsafe.hs b/src/Data/TypedEncoding/Common/Types/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypedEncoding/Common/Types/Unsafe.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} + +module Data.TypedEncoding.Common.Types.Unsafe where + +import Data.Proxy +import Data.TypedEncoding.Common.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 (UnsafeMkEnc p c x)) = Unsafe (UnsafeMkEnc p c (f x)) + +instance Applicative (Unsafe enc ()) where + pure = Unsafe . UnsafeMkEnc Proxy () + Unsafe (UnsafeMkEnc p c1 f) <*> Unsafe (UnsafeMkEnc _ c2 x) = Unsafe (UnsafeMkEnc p () (f x)) + +instance Monad (Unsafe enc ()) where + Unsafe (UnsafeMkEnc _ _ x) >>= f = f x + diff --git a/src/Data/TypedEncoding/Common/Types/Validation.hs b/src/Data/TypedEncoding/Common/Types/Validation.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypedEncoding/Common/Types/Validation.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} +-- | +-- Internal definition of types +-- +-- Validation types for @Enc@ +-- +-- See also +-- +-- * "Data.TypedEncoding.Combinators.Validate" +-- * "Data.TypedEncoding.Common.Class.Validate" +-- +-- Use of 'Data.TypedEncoding.Combinators.Unsafe.unsafeSetPayload' currently recommended +-- for recovering 'Enc' from trusted input sources (if avoiding cost of Validation is important). + +module Data.TypedEncoding.Common.Types.Validation where + +import Data.Proxy +import GHC.TypeLits + +import Data.TypedEncoding.Common.Types.Enc +import Data.TypedEncoding.Common.Types.Common + + +-- | +-- Validation unwraps a layer of encoding and offers payload data down the encoding stack +-- for further verification. +-- +-- For "enc-" encodings this will typically be decoding step. +-- +-- For "r-" encodings this will typically be encoding step. +data Validation f (nm :: Symbol) (alg :: Symbol) conf str where + UnsafeMkValidation :: Proxy nm -> (forall (xs :: [Symbol]) . Enc (nm ': xs) conf str -> f (Enc xs conf str)) -> Validation f nm alg conf str + +-- | Type safe smart constructor +-- adding the type family @(AlgNm nm)@ restriction to UnsafeMkValidation slows down compilation, especially in tests. +mkValidation :: forall f (nm :: Symbol) conf str . (forall (xs :: [Symbol]) . Enc (nm ': xs) conf str -> f (Enc xs conf str)) -> Validation f nm (AlgNm nm) conf str +mkValidation = UnsafeMkValidation Proxy + +runValidation :: forall alg nm f xs conf str . Validation f nm alg conf str -> Enc (nm ': xs) conf str -> f (Enc xs conf str) +runValidation (UnsafeMkValidation _ fn) = fn + +-- | Same as 'runValidation" but compiler figures out algorithm name +-- +-- Using it can slowdown compilation +_runValidation :: forall nm f xs conf str alg . (AlgNm nm ~ alg) => Validation f nm alg conf str -> Enc (nm ': xs) conf str -> f (Enc xs conf str) +_runValidation = runValidation @(AlgNm nm) + +-- | +-- Wraps a list of @Validation@ elements. +-- +-- Similarly to 'Validation' it can be used with a typeclass +-- 'Data.TypedValidation.Internal.Class.Encode.EncodeAll' +data Validations f (nms :: [Symbol]) (algs :: [Symbol]) 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 + ZeroV :: Validations f '[] '[] conf str + ConsV :: Validation f nm alg conf str -> Validations f nms algs conf str -> Validations f (nm ': nms) (alg ': algs) conf str + +-- | This basically puts payload in decoded state. +-- More useful combinators are in "Data.TypedEncoding.Combinators.Validate" +runValidationChecks :: forall algs nms f c str . (Monad f) => Validations f nms algs c str -> Enc nms c str -> f (Enc ('[]::[Symbol]) c str) +runValidationChecks ZeroV enc0 = pure enc0 +runValidationChecks (ConsV fn xs) enc = + let re :: f (Enc _ c str) = runValidation fn enc + in re >>= runValidationChecks xs + + +-- -- | At possibly big compilation cost, have compiler figure out algorithm names. +-- _runValidations :: forall nms f c str algs . (Monad f, algs ~ AlgNmMap nms) => Validations f nms algs c str -> Enc nms c str -> f (Enc ('[]::[Symbol]) c str) +-- _runValidations = runValidations @(AlgNmMap nms) diff --git a/src/Data/TypedEncoding/Common/Util/TypeLits.hs b/src/Data/TypedEncoding/Common/Util/TypeLits.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypedEncoding/Common/Util/TypeLits.hs @@ -0,0 +1,145 @@ + + +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + + +-- | TypeLits related utilities. +-- +-- Lots of this could be avoided by adding @singletons@ as dependency. +-- +-- Uses @symbols@ library for its ToList type family. +-- +-- Currently this is spread out in different modules +-- +-- * "Data.TypedEncoding.Common.Class.Util" +-- * "Data.TypedEncoding.Common.Types.SomeAnnotation" +-- +-- (TODO) these will need to get consolidated. +module Data.TypedEncoding.Common.Util.TypeLits where + +import GHC.TypeLits +import Data.Symbol.Ascii + + +-- $setup +-- >>> :set -XScopedTypeVariables -XTypeFamilies -XKindSignatures -XDataKinds + +type family AcceptEq (msg :: ErrorMessage) (c :: Ordering) :: Bool where + AcceptEq _ EQ = True + AcceptEq msg _ = TypeError msg + +type family And (b1 :: Bool) (b2 :: Bool) :: Bool where + And 'True 'True = 'True + And _ _ = 'False + +type family Or (b1 :: Bool) (b2 :: Bool) :: Bool where + Or 'False 'False = 'False + Or _ _ = 'True + +type family Repeat (n :: Nat) (s :: Symbol) :: Symbol where + Repeat 0 s = "" + Repeat n s = AppendSymbol s (Repeat (n - 1) s) + +type family Fst (s :: (k,h)) :: k where + Fst ('(,) a _) = a + +type family Dupl (s :: k) :: (k,k) where + Dupl a = '(,) a a + +-- | :kind! Concat (LDrop 6 (ToList "bool: \"r-ban:ff-ff\" | \"r-ban:ffff\"")) +type family Concat (s :: [Symbol]) :: Symbol where + Concat '[] = "" + Concat (x ': xs) = AppendSymbol x (Concat xs) + + +type family Drop (n :: Nat) (s :: Symbol) :: Symbol where + Drop n s = Concat (LDrop n (ToList s)) + +-- TODO create TypeList.List module ? + +-- | :kind! LDrop 6 (ToList "bool: \"r-ban:ff-ff\" | \"r-ban:ffff\"") +type family LDrop (n :: Nat) (s :: [k]) :: [k] where + LDrop 0 s = s + LDrop n '[] = '[] + LDrop n (x ': xs) = LDrop (n - 1) xs + + +-- type family DropVerify (n :: Nat) (s :: Symbol) (v :: Symbol) :: Symbol where +-- Drop n s v = Concat (LDrop n (ToList s)) + +-- type family DropVerify (n :: Nat) (s :: Symbol) (v :: Symbol) :: Symbol where +-- Drop n s v = Concat (LDrop n (ToList s)) + +-- | +-- :kind! Take 3 "123456" +type family Take (n :: Nat) (s :: Symbol) :: Symbol where + Take n s = Concat (LTake n (ToList s)) + +-- | :kind! LTake 3 (ToList "123456") +type family LTake (n :: Nat) (s :: [k]) :: [k] where + LTake 0 s = '[] + LTake n '[] = '[] + LTake n (x ': xs) = x ': LTake (n - 1) xs + +-- +-- :kind! TakeUntil "findme:blah" ":" +type family TakeUntil (s :: Symbol) (stop :: Symbol) :: Symbol where + TakeUntil s stop = Concat (LTakeUntil (ToList s) stop) + +type family LTakeUntil (s :: [Symbol]) (stop :: Symbol) :: [Symbol] where + LTakeUntil '[] _ = '[] + LTakeUntil (x ': xs) stop = LTakeUntilHelper (x ': LTakeUntil xs stop) (CmpSymbol x stop) + +type family LTakeUntilHelper (s :: [Symbol]) (o :: Ordering) :: [Symbol] where + LTakeUntilHelper '[] _ = '[] + LTakeUntilHelper (x ': xs) 'EQ = '[] + LTakeUntilHelper (x ': xs) _ = (x ': xs) + + +type family Length (s :: Symbol) :: Nat where + Length x = LLengh (ToList x) + +type family LLengh (s :: [k]) :: Nat where + LLengh '[] = 0 + LLengh (x ': xs) = 1 + LLengh xs + + +-- | +-- >>> :kind! LLast '["1","2","3"] +-- ... +-- = "3" +type family LLast (s :: [Symbol]) :: Symbol where + LLast '[] = TypeError ('Text "Empty Symbol list not allowed") + LLast '[x] = x + LLast (_ ': xs) = LLast xs + + +-- | +-- Concat (Snoc '["1","2","3"] "4") +-- ... +-- = "1234" +type family Snoc (s :: [k]) (t :: k) :: [k] where + Snoc '[] x = '[x] + Snoc (x ': xs) y = x ': Snoc xs y + + +-- | +-- :kind! UnSnoc '["1","2","3"] +type family UnSnoc (s :: [k]) :: ([k], k) where + UnSnoc '[] = TypeError ('Text "Empty list, no last element") + UnSnoc '[x] = '(,) '[] x + UnSnoc (x ': xs) = UnSnocHelper x (UnSnoc xs) + + +type family UnSnocHelper (s :: k) (t :: ([k], k)) :: ([k], k) where + UnSnocHelper y ('(,) xs x) = '(,) (y ': xs) x diff --git a/src/Data/TypedEncoding/Conv/ByteString/Char8.hs b/src/Data/TypedEncoding/Conv/ByteString/Char8.hs --- a/src/Data/TypedEncoding/Conv/ByteString/Char8.hs +++ b/src/Data/TypedEncoding/Conv/ByteString/Char8.hs @@ -9,9 +9,8 @@ module Data.TypedEncoding.Conv.ByteString.Char8 where import qualified Data.ByteString.Char8 as B8 -import Data.TypedEncoding.Internal.Types.Enc (Enc, unsafeChangePayload) -import qualified Data.TypedEncoding.Internal.Util.TypeLits as Knds -import Data.TypedEncoding +import qualified Data.TypedEncoding.Common.Util.TypeLits as Knds +import Data.TypedEncoding.Instances.Support -- $setup -- >>> :set -XDataKinds -XTypeApplications -XOverloadedStrings @@ -31,7 +30,7 @@ -- ... -- -- >>> displ $ pack (unsafeSetPayload () "Hello" :: Enc '["r-bar", "r-ASCII"] () String) --- "MkEnc '[r-bar,r-ASCII] () (ByteString Hello)" +-- "Enc '[r-bar,r-ASCII] () (ByteString Hello)" pack :: (Knds.LLast xs ~ t, IsSuperset "r-ASCII" t ~ 'True) => Enc xs c String -> Enc xs c B8.ByteString pack = unsafeChangePayload B8.pack diff --git a/src/Data/TypedEncoding/Conv/ByteString/Lazy/Char8.hs b/src/Data/TypedEncoding/Conv/ByteString/Lazy/Char8.hs --- a/src/Data/TypedEncoding/Conv/ByteString/Lazy/Char8.hs +++ b/src/Data/TypedEncoding/Conv/ByteString/Lazy/Char8.hs @@ -9,9 +9,8 @@ module Data.TypedEncoding.Conv.ByteString.Lazy.Char8 where import qualified Data.ByteString.Lazy.Char8 as BL8 -import Data.TypedEncoding.Internal.Types.Enc (Enc, unsafeChangePayload) -import qualified Data.TypedEncoding.Internal.Util.TypeLits as Knds -import Data.TypedEncoding +import qualified Data.TypedEncoding.Common.Util.TypeLits as Knds +import Data.TypedEncoding.Instances.Support -- $setup -- >>> :set -XDataKinds -XTypeApplications -XOverloadedStrings diff --git a/src/Data/TypedEncoding/Conv/Text.hs b/src/Data/TypedEncoding/Conv/Text.hs --- a/src/Data/TypedEncoding/Conv/Text.hs +++ b/src/Data/TypedEncoding/Conv/Text.hs @@ -22,16 +22,23 @@ unpack :: Enc xs c T.Text -> Enc xs c String unpack = unsafeChangePayload T.unpack --- | Text is automatically @"r-UTF8"@ encoded +-- | +-- Text is automatically @"r-UTF8"@ encoded -- +-- Adding @"r-UTF8"@ annotation simply adds type level interpretion requirement that 'T.Text' is treated +-- as /UTF8/. The internals of 'T.Text' (currently /UTF-16/) are not relevant and @utf8Promote@ is implemented +-- as 'id'. This is not the same as encoding @Word8@ layouts into 'Char'-s. +-- This, in /typed-encoding/ terminology, would be @"enc-UTF8"@, not @"r-UTF8". +-- -- >>> displ $ utf8Promote $ toEncoding () ("text" :: T.Text) --- "MkEnc '[r-UTF8] () (Text text)" +-- "Enc '[r-UTF8] () (Text text)" utf8Promote :: Enc xs c T.Text -> Enc (Snoc xs "r-UTF8") c T.Text utf8Promote = withUnsafeCoerce id --- | For 'T.Text' @"r-UTF8"@ is redundant +-- | +-- For 'T.Text' @"r-UTF8"@ is redundant -- -- >>> displ . utf8Demote $ (unsafeSetPayload () "Hello" :: Enc '["r-UTF8"] () T.Text) --- "MkEnc '[] () (Text Hello)" +-- "Enc '[] () (Text Hello)" utf8Demote :: (UnSnoc xs ~ '(,) ys "r-UTF8") => Enc xs c T.Text -> Enc ys c T.Text utf8Demote = withUnsafeCoerce id diff --git a/src/Data/TypedEncoding/Conv/Text/Encoding.hs b/src/Data/TypedEncoding/Conv/Text/Encoding.hs --- a/src/Data/TypedEncoding/Conv/Text/Encoding.hs +++ b/src/Data/TypedEncoding/Conv/Text/Encoding.hs @@ -27,13 +27,14 @@ -- >>> import qualified Data.ByteString.Char8 as B8 -- >>> import Data.Char -- >>> import Data.Either +-- >>> import Data.TypedEncoding -- >>> import Data.TypedEncoding.Conv.Text -- >>> let emptyUTF8B = unsafeSetPayload () "" :: Enc '["r-UTF8"] () B.ByteString -- >>> :{ -- instance Arbitrary (Enc '["r-UTF8"] () B.ByteString) where -- arbitrary = fmap (fromRight emptyUTF8B) -- . flip suchThat isRight --- . fmap (encodeFAll @(Either EncodeEx) @'["r-UTF8"] @(). toEncoding ()) $ arbitrary +-- . fmap (encodeFAll @'["r-UTF8"] @(Either EncodeEx) @(). toEncoding ()) $ arbitrary -- instance Arbitrary (Enc '["r-UTF8"] () T.Text) where -- arbitrary = fmap (unsafeSetPayload ()) -- arbitrary @@ -52,12 +53,12 @@ -- With given constraints 'decodeUtf8' and 'encodeUtf8' can be used on subsets of @"r-UTF8"@ -- -- >>> displ . decodeUtf8 $ (unsafeSetPayload () "Hello" :: Enc '["r-ASCII"] () B.ByteString) --- "MkEnc '[r-ASCII] () (Text Hello)" +-- "Enc '[r-ASCII] () (Text Hello)" -- -- "r-UTF8" is redundant: -- -- >>> displ . utf8Demote . decodeUtf8 $ (unsafeSetPayload () "Hello" :: Enc '["r-UTF8"] () B.ByteString) --- "MkEnc '[] () (Text Hello)" +-- "Enc '[] () (Text Hello)" -- -- @decodeUtf8@ and @encodeUtf8@ form isomorphism -- @@ -74,6 +75,6 @@ -- | -- >>> displ $ encodeUtf8 $ utf8Promote $ toEncoding () ("text" :: T.Text) --- "MkEnc '[r-UTF8] () (ByteString text)" +-- "Enc '[r-UTF8] () (ByteString text)" encodeUtf8 :: forall xs c t. (LLast xs ~ t, IsSuperset "r-UTF8" t ~ 'True) => Enc xs c T.Text -> Enc xs c B.ByteString encodeUtf8 = withUnsafe (fmap TE.encodeUtf8) diff --git a/src/Data/TypedEncoding/Instances/Do/Sample.hs b/src/Data/TypedEncoding/Instances/Do/Sample.hs --- a/src/Data/TypedEncoding/Instances/Do/Sample.hs +++ b/src/Data/TypedEncoding/Instances/Do/Sample.hs @@ -16,43 +16,51 @@ 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 +import Data.TypedEncoding.Instances.Support.Unsafe +instance Applicative f => Encode f "do-UPPER" "do-UPPER" c T.Text where + encoding = _implEncodingP T.toUpper -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 -> +instance (RecreateErr f, Applicative f) => Validate f "do-UPPER" "do-UPPER" c T.Text where + validation = mkValidation $ + implTranF (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 => Encode f "do-UPPER" "do-UPPER" c TL.Text where + encoding = _implEncodingP TL.toUpper -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 + +instance Applicative f => Encode f "do-lower" "do-lower" c T.Text where + encoding = _implEncodingP T.toLower + +instance Applicative f => Encode f "do-lower" "do-lower" c TL.Text where + encoding = _implEncodingP TL.toLower + +instance Applicative f => Encode f "do-Title" "do-Title" c T.Text where + encoding = _implEncodingP T.toTitle + +instance Applicative f => Encode f "do-Title" "do-Title" c TL.Text where + encoding = _implEncodingP TL.toTitle + +instance Applicative f => Encode f "do-reverse" "do-reverse" c T.Text where + encoding = _implEncodingP T.reverse +instance Applicative f => Encode f "do-reverse" "do-reverse" c TL.Text where + encoding = _implEncodingP 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) +instance (HasA SizeLimit c, Applicative f) => Encode f "do-size-limit" "do-size-limit" c T.Text where + encoding = _implEncodingConfP (T.take . unSizeLimit . has @ SizeLimit) +instance (HasA SizeLimit c, Applicative f) => Encode f "do-size-limit" "do-size-limit" c B.ByteString where + encoding = _implEncodingConfP (B.take . unSizeLimit . has @ SizeLimit) diff --git a/src/Data/TypedEncoding/Instances/Enc/Base64.hs b/src/Data/TypedEncoding/Instances/Enc/Base64.hs --- a/src/Data/TypedEncoding/Instances/Enc/Base64.hs +++ b/src/Data/TypedEncoding/Instances/Enc/Base64.hs @@ -4,12 +4,14 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} -- | Defines /Base64/ encoding module Data.TypedEncoding.Instances.Enc.Base64 where import Data.TypedEncoding import Data.TypedEncoding.Instances.Support +import Data.TypedEncoding.Instances.Support.Unsafe import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL @@ -21,73 +23,18 @@ 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 +-- >>> :set -XOverloadedStrings -XScopedTypeVariables -XKindSignatures -XMultiParamTypeClasses -XDataKinds -XPolyKinds -XPartialTypeSignatures -XFlexibleInstances -XTypeApplications -- >>> import Test.QuickCheck -- >>> import Test.QuickCheck.Instances.Text() -- >>> import Test.QuickCheck.Instances.ByteString() ----------------- --- Conversions -- +-- * Conversions ----------------- --- | --- DEPRECATED use 'Data.TypedEncoding.Conv.Text.Encoding.decodeUtf8' --- and 'Data.TypedEncoding.Conv.Text.utf8Demote' --- --- Will be removed in 0.3.x.x --- --- See warning in 'Data.TypedEncoding.Instances.Restriction.ASCII.byteString2TextS' -byteString2TextS :: Enc ("enc-B64" ': "r-UTF8" ': ys) c B.ByteString -> Enc ("enc-B64" ': ys) c T.Text -byteString2TextS = withUnsafeCoerce TE.decodeUtf8 - --- | --- DEPRECATED use 'Data.TypedEncoding.Conv.Text.Lazy.Encoding.decodeUtf8' --- and 'Data.TypedEncoding.Conv.Text.utf8Demote' --- --- Will be removed in 0.3.x.x --- --- See warning in 'Data.TypedEncoding.Instances.Restriction.ASCII.byteString2TextS' -byteString2TextL :: Enc ("enc-B64" ': "r-UTF8" ': ys) c BL.ByteString -> Enc ("enc-B64" ': ys) c TL.Text -byteString2TextL = withUnsafeCoerce TEL.decodeUtf8 - --- DEPRECATED use 'Data.TypedEncoding.Conv.Text.Encoding.encodeUtf8' --- and 'Data.TypedEncoding.Conv.Text.utf8Promote' --- --- Will be removed in 0.3.x.x -text2ByteStringS :: Enc ("enc-B64" ': ys) c T.Text -> Enc ("enc-B64" ': "r-UTF8" ': ys) c B.ByteString -text2ByteStringS = withUnsafeCoerce TE.encodeUtf8 - --- DEPRECATED use 'Data.TypedEncoding.Conv.Text.Lazy.Encoding.encodeUtf8' --- and 'Data.TypedEncoding.Conv.Text.utf8Promote' --- --- Will be removed in 0.3.x.x -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 - --- DEPRECATED -byteString2TextL' :: Enc ("enc-B64" ': ys) c BL.ByteString -> Enc ("enc-B64-nontext" ': ys) c TL.Text -byteString2TextL' = withUnsafeCoerce TEL.decodeUtf8 - --- DEPRECATED -text2ByteStringS' :: Enc ("enc-B64-nontext" ': ys) c T.Text -> Enc ("enc-B64" ': ys) c B.ByteString -text2ByteStringS' = withUnsafeCoerce TE.encodeUtf8 - --- DEPRECATED -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) @@ -99,82 +46,110 @@ -- -- >>> let tstB64 = encodeAll . toEncoding () $ "Hello World" :: Enc '["enc-B64"] () B.ByteString -- >>> displ (flattenAs tstB64 :: Enc '["r-ASCII"] () B.ByteString) --- "MkEnc '[r-ASCII] () (ByteString SGVsbG8gV29ybGQ=)" +-- "Enc '[r-ASCII] () (ByteString SGVsbG8gV29ybGQ=)" instance FlattenAs "r-ASCII" "enc-B64-nontext" where instance FlattenAs "r-ASCII" "enc-B64" where --- DEPRECATED will be removed +-- | +-- This is not precise, actually /Base 64/ uses a subset of ASCII +-- and that would require a new definition @"r-B64"@. -- --- dangerous, with new approach. --- Supersets are for "r-" types only -instance Superset "r-ASCII" "enc-B64-nontext" where -instance Superset "r-ASCII" "enc-B64" where +-- This instance likely to be changed / corrected in the future if @"r-B64"@ is defined. +-- +-- >>> let tstB64 = encodeAll . toEncoding () $ "Hello World" :: Enc '["enc-B64"] () B.ByteString +-- >>> displ (_encodesInto @"r-ASCII" $ tstB64) +-- "Enc '[r-ASCII,enc-B64] () (ByteString SGVsbG8gV29ybGQ=)" +-- +-- >>> displ (_encodesInto @"r-UTF8" $ tstB64) +-- "Enc '[r-UTF8,enc-B64] () (ByteString SGVsbG8gV29ybGQ=)" +-- +-- @since 0.3.0.0 +instance EncodingSuperset "enc-B64" where + type EncSuperset "enc-B64" = "r-ASCII" ------------------ --- Encodings -- ------------------ +-- * Encoders -instance Encodings (Either EncodeEx) xs grps c B.ByteString => Encodings (Either EncodeEx) ("enc-B64" ': xs) ("enc-B64" ': grps) c B.ByteString where - encodings = encodeFEncoder @(Either EncodeEx) @"enc-B64" @"enc-B64" +instance Applicative f => Encode f "enc-B64" "enc-B64" c B.ByteString where + encoding = encB64B -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. +encB64B :: Applicative f => Encoding f "enc-B64" "enc-B64" c B.ByteString +encB64B = _implEncodingP B64.encode + +instance Applicative f => Encode f "enc-B64" "enc-B64" c BL.ByteString where + encoding = encB64BL + +encB64BL :: Applicative f => Encoding f "enc-B64" "enc-B64" c BL.ByteString +encB64BL = _implEncodingP BL64.encode + + +-- | This instance will likely be removed in future versions (performance concerns) +instance Applicative f => Encode f "enc-B64" "enc-B64" c T.Text where + encoding = endB64T + +-- | This function will likely be removed in future versions (performance concerns) +endB64T :: Applicative f => Encoding f "enc-B64" "enc-B64" c T.Text +endB64T = _implEncodingP (TE.decodeUtf8 . B64.encode . TE.encodeUtf8) + +-- * Decoders + +instance (UnexpectedDecodeErr f, Applicative f) => Decode f "enc-B64" "enc-B64" c B.ByteString where + decoding = decB64B + +-- | Effectful decoding 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) +decB64B :: (UnexpectedDecodeErr f, Applicative f) => Decoding f "enc-B64" "enc-B64" c B.ByteString +decB64B = _implDecodingF (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 (UnexpectedDecodeErr f, Applicative f) => Decode f "enc-B64" "enc-B64" c BL.ByteString where + decoding = decB64BL -instance Applicative f => RecreateF f (Enc xs c B.ByteString) (Enc ("enc-B64-len" ': xs) c B.ByteString) where - checkPrevF = implTranP id +decB64BL :: (UnexpectedDecodeErr f, Applicative f) => Decoding f "enc-B64" "enc-B64" c BL.ByteString +decB64BL = _implDecodingF (asUnexpected @"enc-B64" . BL64.decode) -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) +-- Kept for now but performance issues -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) +-- | WARNING (performance) +instance (UnexpectedDecodeErr f, Applicative f) => Decode f "enc-B64" "enc-B64" c T.Text where + decoding = decB64T -instance Applicative f => RecreateF f (Enc xs c BL.ByteString) (Enc ("enc-B64-len" ': xs) c BL.ByteString) where - checkPrevF = implTranP id +decB64T :: (UnexpectedDecodeErr f, Applicative f) => Decoding f "enc-B64" "enc-B64" c T.Text +decB64T = _implDecodingF (asUnexpected @"enc-B64" . fmap TE.decodeUtf8 . B64.decode . TE.encodeUtf8) +{-# WARNING decB64T "This method was not optimized for performance." #-} --- 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 +-- | WARNING (performance) +instance (UnexpectedDecodeErr f, Applicative f) => Decode f "enc-B64" "enc-B64" c TL.Text where + decoding = decB64TL --- 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 +decB64TL :: (UnexpectedDecodeErr f, Applicative f) => Decoding f "enc-B64" "enc-B64" c TL.Text +decB64TL = _implDecodingF (asUnexpected @"enc-B64" . fmap TEL.decodeUtf8 . BL64.decode . TEL.encodeUtf8) +{-# WARNING decB64TL "This method was not optimized for performance." #-} -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) +-- * Validation -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 (RecreateErr f, Applicative f) => Validate f "enc-B64" "enc-B64" c B.ByteString where + validation = validFromDec decB64B -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 (RecreateErr f, Applicative f) => Validate f "enc-B64" "enc-B64" c BL.ByteString where + validation = validFromDec decB64BL -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) => Validate f "enc-B64" "enc-B64" c T.Text where + validation = validFromDec decB64T -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) +instance (RecreateErr f, Applicative f) => Validate f "enc-B64" "enc-B64" c TL.Text where + validation = validFromDec decB64TL + +-- | Lenient decoding does not fail +instance Applicative f => Validate f "enc-B64-len" "enc-B64-len" c B.ByteString where + validation = mkValidation $ implTranP id + +-- | Lenient decoding does not fail +instance Applicative f => Validate f "enc-B64-len" "enc-B64-len" c BL.ByteString where + validation = mkValidation $ implTranP id + + + diff --git a/src/Data/TypedEncoding/Instances/Restriction/ASCII.hs b/src/Data/TypedEncoding/Instances/Restriction/ASCII.hs --- a/src/Data/TypedEncoding/Instances/Restriction/ASCII.hs +++ b/src/Data/TypedEncoding/Instances/Restriction/ASCII.hs @@ -15,36 +15,27 @@ -- -- >>> :set -XOverloadedStrings -XMultiParamTypeClasses -XDataKinds -- >>> encodeFAll . toEncoding () $ "Hello World" :: Either EncodeEx (Enc '["r-ASCII"] () T.Text) --- Right (MkEnc Proxy () "Hello World") +-- Right (UnsafeMkEnc 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.List as L - -import qualified Data.ByteString.Char8 as B8 -import qualified Data.ByteString.Lazy.Char8 as BL8 +import Data.TypedEncoding.Common.Class.Util.StringConstraints -import Data.Char import Data.TypedEncoding.Internal.Util (explainBool) -import Data.TypedEncoding.Unsafe (withUnsafe) -import Control.Arrow +import Data.Char + -- $setup -- >>> :set -XDataKinds -XTypeApplications +-- >>> import qualified Data.Text as T +-- >>> import qualified Data.ByteString as B +-- >>> import qualified Data.ByteString.Char8 as B8 -- >>> import Test.QuickCheck -- >>> import Test.QuickCheck.Instances.ByteString() +-- >>> import Data.TypedEncoding -- >>> :{ -- instance Arbitrary (Enc '["r-ASCII"] () B.ByteString) where -- arbitrary = fmap (unsafeSetPayload ()) @@ -55,138 +46,38 @@ ----------------- --- Conversions -- ------------------ - --- | --- DEPRECATED use 'Data.TypedEncoding.Conv.Text.Encoding.decodeUtf8' --- --- Will be removed in 0.3.x.x --- --- This is not type safe, for example, would allow converting --- --- @Enc `["r-ASCII", "enc-B64"] c B.ByteString@ containing B64 encoded binary --- to @Enc `["r-ASCII", "enc-B64"] c T.Text@ and which then could be decoded causing --- unexpected error. - -byteString2TextS :: Enc ("r-ASCII" ': ys) c B.ByteString -> Enc ("r-ASCII" ': ys) c T.Text -byteString2TextS = withUnsafe (fmap TE.decodeUtf8) - --- | --- DEPRECATED use 'Data.TypedEncoding.Conv.Text.Lazy.Encoding.decodeUtf8' --- --- Will be removed in 0.3.x.x --- --- see 'byteString2TextS' -byteString2TextL :: Enc ("r-ASCII" ': ys) c BL.ByteString -> Enc ("r-ASCII" ': ys) c TL.Text -byteString2TextL = withUnsafe (fmap TEL.decodeUtf8) - --- | --- DEPRECATED use 'Data.TypedEncoding.Conv.Text.Encoding.encodeUtf8' --- --- Will be removed in 0.3.x.x --- -text2ByteStringS :: Enc ("r-ASCII" ': ys) c T.Text -> Enc ("r-ASCII" ': ys) c B.ByteString -text2ByteStringS = withUnsafe (fmap TE.encodeUtf8) - --- | --- DEPRECATED use 'Data.TypedEncoding.Conv.Text.Lazy.Encoding.encodeUtf8' --- --- Will be removed in 0.3.x.x --- -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 --- --- UTF-8 is backward compatible on first 128 characters using just one byte to store it. --- --- Payload does not change when @ASCII@ only strings are encoded to @UTF8@ in types like @ByteString@. --- --- >>> 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 - --- type instance IsSuperset "r-UTF8" "r-ASCII" = True --- type instance IsSuperset "r-ASCII" "r-ASCII" = True - ------------------ -- Encodings -- ----------------- 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 Encodings (Either EncodeEx) xs grps c String => Encodings (Either EncodeEx) ("r-ASCII" ': xs) ("r-ASCII" ': grps) c String where - encodings = encodeFEncoder @(Either EncodeEx) @"r-ASCII" @"r-ASCII" - -instance EncodeF (Either EncodeEx) (Enc xs c String) (Enc ("r-ASCII" ': xs) c String) where - encodeF = implEncodeF_ prxyAscii (encodeImpl L.partition L.head L.null) -instance (RecreateErr f, Applicative f) => RecreateF f (Enc xs c String) (Enc ("r-ASCII" ': xs) c String) where - checkPrevF = implCheckPrevF (asRecreateErr @"r-ASCII" . encodeImpl L.partition L.head L.null) -instance Applicative f => DecodeF f (Enc ("r-ASCII" ': xs) c String) (Enc xs c String) where - decodeF = implTranP id - -instance Encodings (Either EncodeEx) xs grps c T.Text => Encodings (Either EncodeEx) ("r-ASCII" ': xs) ("r-ASCII" ': grps) c T.Text where - encodings = encodeFEncoder @(Either EncodeEx) @"r-ASCII" @"r-ASCII" - -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 +-- * Encoding -instance Encodings (Either EncodeEx) xs grps c TL.Text => Encodings (Either EncodeEx) ("r-ASCII" ': xs) ("r-ASCII" ': grps) c TL.Text where - encodings = encodeFEncoder @(Either EncodeEx) @"r-ASCII" @"r-ASCII" +instance Encode (Either EncodeEx) "r-ASCII" "r-ASCII" c Char where + encoding = encASCIIChar -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 Char8Find str => Encode (Either EncodeEx) "r-ASCII" "r-ASCII" c str where + encoding = encASCII -instance Encodings (Either EncodeEx) xs grps c B.ByteString => Encodings (Either EncodeEx) ("r-ASCII" ': xs) ("r-ASCII" ': grps) c B.ByteString where - encodings = encodeFEncoder @(Either EncodeEx) @"r-ASCII" @"r-ASCII" +encASCIIChar :: Encoding (Either EncodeEx) "r-ASCII" "r-ASCII" c Char +encASCIIChar = _implEncodingEx (\c -> explainBool NonAsciiChar (c, isAscii c)) -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 +encASCII :: Char8Find str => Encoding (Either EncodeEx) "r-ASCII" "r-ASCII" c str +encASCII = _implEncodingEx @"r-ASCII" encImpl -instance Encodings (Either EncodeEx) xs grps c BL.ByteString => Encodings (Either EncodeEx) ("r-ASCII" ': xs) ("r-ASCII" ': grps) c BL.ByteString where - encodings = encodeFEncoder @(Either EncodeEx) @"r-ASCII" @"r-ASCII" +encImpl :: Char8Find str => str -> Either NonAsciiChar str +encImpl str = case find (not . isAscii) str of + Nothing -> Right str + Just ch -> Left $ NonAsciiChar ch -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 +-- * Decoding +instance (Applicative f) => Decode f "r-ASCII" "r-ASCII" c str where + decoding = decAnyR + +instance (Char8Find str, RecreateErr f, Applicative f) => Validate f "r-ASCII" "r-ASCII" () str where + validation = validR encASCII -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) diff --git a/src/Data/TypedEncoding/Instances/Restriction/Bool.hs b/src/Data/TypedEncoding/Instances/Restriction/Bool.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypedEncoding/Instances/Restriction/Bool.hs @@ -0,0 +1,429 @@ + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | +-- Boolean algebra on encodings +-- +-- @since 0.2.1.0 +-- +-- /(Experimental, early alpha development stage)/ This module was not converted to v0.3 style yet. +-- +-- == Grammar +-- +-- Simple grammar requires boolean terms to be included in parentheses +-- +-- @ +-- bool[BinaryOp]:(leftTerm)(rightTerm) +-- bool[UnaryOp]:(term) +-- @ +-- +-- Expected behavior is described next to the corresponding combinator. + +module Data.TypedEncoding.Instances.Restriction.Bool where + + +import GHC.TypeLits +import Data.Proxy +import Data.Symbol.Ascii + +import Data.TypedEncoding +import Data.TypedEncoding.Instances.Support +import Data.TypedEncoding.Instances.Support.Unsafe + + + +-- $setup +-- >>> :set -XOverloadedStrings -XMultiParamTypeClasses -XDataKinds -XTypeApplications +-- >>> import qualified Data.Text as T +-- >>> import Data.TypedEncoding.Instances.Restriction.Misc() + + +-- | +-- See examples in 'encBoolOrRight'' +encBoolOrLeft :: forall f s t xs c str . ( + BoolOpIs s "or" ~ 'True + -- IsBoolOr s ~ 'True + , Functor f + , LeftTerm s ~ t + ) => (Enc xs c str -> f (Enc (t ': xs) c str)) -> Enc xs c str -> f (Enc (s ': xs) c str) +encBoolOrLeft = implChangeAnn + +-- | +-- See examples in 'encBoolOrRight'' +encBoolOrLeft' :: forall f s t xs c str . ( + BoolOpIs s "or" ~ 'True + -- IsBoolOr s ~ 'True + , Functor f + , LeftTerm s ~ t + , Encode f t t c str + ) => Enc xs c str -> f (Enc (s ': xs) c str) +encBoolOrLeft' = encBoolOrLeft'' @t + +encBoolOrLeft'' :: forall alg f s t xs c str . ( + BoolOpIs s "or" ~ 'True + -- IsBoolOr s ~ 'True + , Functor f + , LeftTerm s ~ t + , Encode f t alg c str + ) => Enc xs c str -> f (Enc (s ': xs) c str) +encBoolOrLeft'' = encBoolOrLeft (encodeF' @alg @t @xs @f) + +-- | +-- +encBoolOrRight :: forall f s t xs c str . ( + BoolOpIs s "or" ~ 'True + -- IsBoolOr s ~ 'True + , Functor f + , RightTerm s ~ t + ) => (Enc xs c str -> f (Enc (t ': xs) c str)) -> Enc xs c str -> f (Enc (s ': xs) c str) +encBoolOrRight = implChangeAnn + +-- | +-- >>> :{ +-- let tst1, tst2, tst3 :: Either EncodeEx (Enc '["boolOr:(r-Word8-decimal)(r-Int-decimal)"] () T.Text) +-- tst1 = encBoolOrLeft' . toEncoding () $ "212" +-- tst2 = encBoolOrRight' . toEncoding () $ "1000000" +-- tst3 = encBoolOrLeft' . toEncoding () $ "1000000" +-- :} +-- +-- >>> tst1 +-- Right (UnsafeMkEnc Proxy () "212") +-- +-- >>> tst2 +-- Right (UnsafeMkEnc Proxy () "1000000") +-- +-- >>> tst3 +-- Left (EncodeEx "r-Word8-decimal" ("Payload does not satisfy format Word8-decimal: 1000000")) +encBoolOrRight' :: forall f s t xs c str . ( + BoolOpIs s "or" ~ 'True + -- IsBoolOr s ~ 'True + , Functor f + , RightTerm s ~ t + , Encode f t t c str + ) => Enc xs c str -> f (Enc (s ': xs) c str) +encBoolOrRight' = encBoolOrRight'' @t + +encBoolOrRight'' :: forall alg f s t xs c str . ( + BoolOpIs s "or" ~ 'True + -- IsBoolOr s ~ 'True + , Functor f + , RightTerm s ~ t + , Encode f t alg c str + ) => Enc xs c str -> f (Enc (s ': xs) c str) +encBoolOrRight'' = encBoolOrRight (encodeF' @alg @t @xs @f) + +encBoolAnd :: forall f s t1 t2 xs c str . ( + BoolOpIs s "and" ~ 'True + , KnownSymbol s + -- IsBoolAnd s ~ 'True + , f ~ Either EncodeEx + , Eq str + , LeftTerm s ~ t1 + , RightTerm s ~ t2 + ) => + (Enc xs c str -> f (Enc (t1 ': xs) c str)) + -> (Enc xs c str -> f (Enc (t2 : xs) c str)) + -> Enc xs c str -> f (Enc (s ': xs) c str) +encBoolAnd fnl fnr en0 = + let + eent1 = fnl en0 + eent2 = fnr en0 + p = (Proxy :: Proxy s) + in + case (eent1, eent2) of + (Right ent1, Right ent2) -> + if getPayload ent1 == getPayload ent2 + then Right . withUnsafeCoerce id $ ent1 + else Left $ EncodeEx p "Left - right encoding do not match" + (_, _) -> mergeErrs (emptyEncErr p) (mergeEncodeEx p) eent1 eent2 + +-- | +-- @"boolOr:(enc1)(enc2)"@ contains strings that encode the same way under both encodings. +-- for example @"boolOr:(r-UPPER)(r-lower)"@ valid elements would include @"123-34"@ but not @"abc"@ +-- +-- >>> :{ +-- let tst1, tst2 :: Either EncodeEx (Enc '["boolAnd:(r-Word8-decimal)(r-Int-decimal)"] () T.Text) +-- tst1 = encBoolAnd' . toEncoding () $ "234" +-- tst2 = encBoolAnd' . toEncoding () $ "100000" +-- :} +-- +-- >>> tst1 +-- Right (UnsafeMkEnc Proxy () "234") +-- >>> tst2 +-- Left (EncodeEx "r-Word8-decimal" ("Payload does not satisfy format Word8-decimal: 100000")) +encBoolAnd' :: forall s t1 t2 xs c str . ( + BoolOpIs s "and" ~ 'True + , KnownSymbol s + -- IsBoolAnd s ~ 'True + , Eq str + , LeftTerm s ~ t1 + , RightTerm s ~ t2 + , Encode (Either EncodeEx) t1 t1 c str + , Encode (Either EncodeEx) t2 t2 c str + ) => Enc xs c str -> Either EncodeEx (Enc (s ': xs) c str) +encBoolAnd' = encBoolAnd'' @t1 @t2 + +encBoolAnd'' :: forall al1 al2 s t1 t2 xs c str . ( + BoolOpIs s "and" ~ 'True + , KnownSymbol s + -- IsBoolAnd s ~ 'True + , Eq str + , LeftTerm s ~ t1 + , RightTerm s ~ t2 + , Encode (Either EncodeEx) t1 al1 c str + , Encode (Either EncodeEx) t2 al2 c str + ) => Enc xs c str -> Either EncodeEx (Enc (s ': xs) c str) +encBoolAnd'' = encBoolAnd (encodeF' @al1 @t1 @xs) (encodeF' @al2 @t2 @xs) + + +-- tst1, tst2 :: Either EncodeEx (Enc '["boolNot:(r-Word8-decimal)"] () T.Text) +-- tst1 = encBoolNot' . toEncoding () $ "334" +-- tst2 = encBoolNot' . toEncoding () $ "127" + +encBoolNot :: forall s t xs c str . ( + BoolOpIs s "not" ~ 'True + , KnownSymbol s + , FirstTerm s ~ t + , Restriction t + ) => (Enc xs c str -> Either EncodeEx (Enc (t ': xs) c str)) -> Enc xs c str -> Either EncodeEx (Enc (s ': xs) c str) +encBoolNot fn en0 = + let + een = fn en0 + p = (Proxy :: Proxy s) + pt = (Proxy :: Proxy t) + in + case een of + Left _ -> Right . withUnsafeCoerce id $ en0 + Right _ -> Left $ EncodeEx p $ "Encoding " ++ symbolVal pt ++ " succeeded" + + +-- | +-- >>> :{ +-- let tst1, tst2 :: Either EncodeEx (Enc '["boolNot:(r-Word8-decimal)"] () T.Text) +-- tst1 = encBoolNot' . toEncoding () $ "334" +-- tst2 = encBoolNot' . toEncoding () $ "127" +-- :} +-- +-- >>> tst1 +-- Right (UnsafeMkEnc Proxy () "334") +-- >>> tst2 +-- Left (EncodeEx "boolNot:(r-Word8-decimal)" ("Encoding r-Word8-decimal succeeded")) +encBoolNot' :: forall s t xs c str . ( + BoolOpIs s "not" ~ 'True + , KnownSymbol s + , FirstTerm s ~ t + , KnownSymbol t + , Restriction t + , Encode (Either EncodeEx) t t c str + ) => Enc xs c str -> Either EncodeEx (Enc (s ': xs) c str) +encBoolNot' = encBoolNot'' @t + +encBoolNot'' :: forall alg s t xs c str . ( + BoolOpIs s "not" ~ 'True + , KnownSymbol s + , FirstTerm s ~ t + , Restriction t + , Encode (Either EncodeEx) t alg c str + ) => Enc xs c str -> Either EncodeEx (Enc (s ': xs) c str) +encBoolNot'' = encBoolNot (encodeF' @alg @t @xs) + +-- | +-- Decodes boolean expression if all leaves are @"r-"@ +decBoolR :: forall f xs t s c str . ( + NestedR s ~ 'True + , Applicative f + ) => Enc (s ': xs) c str -> f (Enc xs c str) + +decBoolR = implTranP id + + +recWithEncBoolR :: forall (s :: Symbol) xs c str . (NestedR s ~ 'True) + => (Enc xs c str -> Either EncodeEx (Enc (s ': xs) c str)) + -> Enc xs c str -> Either RecreateEx (Enc (s ': xs) c str) +recWithEncBoolR = unsafeRecWithEncR + +unsafeRecWithEncR :: forall (s :: Symbol) xs c str . + (Enc xs c str -> Either EncodeEx (Enc (s ': xs) c str)) + -> Enc xs c str -> Either RecreateEx (Enc (s ': xs) c str) +unsafeRecWithEncR fn = either (Left . encToRecrEx) Right . fn + +-- * Type family based parser + +-- | +-- >>> :kind! BoolOpIs "boolAnd:(someenc)(otherenc)" "and" +-- ... +-- = 'True +type family BoolOpIs (s :: Symbol) (op :: Symbol) :: Bool where + BoolOpIs s op = AcceptEq ('Text "Invalid bool encoding " ':<>: ShowType s ) (CmpSymbol (BoolOp s) op) + +-- | +-- This works fast with @!kind@ but is much slower in declaration +-- :kind! BoolOp "boolOr:()()" +type family BoolOp (s :: Symbol) :: Symbol where + BoolOp s = Fst (BoolOpHelper (Dupl s)) + -- ToLower (TakeUntil (Drop 4 s) ":") + +type family BoolOpHelper (x :: (Symbol, Symbol)) :: (Symbol, Bool) where + BoolOpHelper ('(,) s1 s2) = '(,) (ToLower (TakeUntil (Drop 4 s1) ":")) ( AcceptEq ('Text "Invalid bool encoding " ':<>: ShowType s2 ) (CmpSymbol "bool" (Take 4 s2))) + + +type family IsBool (s :: Symbol) :: Bool where + IsBool s = AcceptEq ('Text "Not boolean encoding " ':<>: ShowType s ) (CmpSymbol "bool" (Take 4 s)) + +-- | +-- +-- >>> :kind! NestedR "boolOr:(r-abc)(r-cd)" +-- ... +-- = 'True +-- +-- >>> :kind! NestedR "boolOr:(boolAnd:(r-ab)(r-ac))(boolNot:(r-cd))" +-- ... +-- = 'True +-- +-- >>> :kind! NestedR "boolOr:(boolAnd:(r-ab)(ac))(boolNot:(r-cd))" +-- ... +-- ... (TypeError ...) +-- ... +type family NestedR (s :: Symbol) :: Bool where + NestedR "" = 'True -- RightTerm, LeftTerm return "" on "r-" + NestedR s = Or (IsROrEmpty s) + (And (IsBool s) (And (NestedR (LeftTerm s)) (NestedR (RightTerm s)))) + +-- Value level check +-- +-- nestedR :: String -> Bool +-- nestedR s = isROrEmpty s || isBool s && (nestedR (leftTerm s) && nestedR (rightTerm s)) + +-- isBool ('b' :'o' : 'o' : _) = True +-- isBool _ = False + +-- isROrEmpty "" = True +-- isROrEmpty ('r' : '-' : _) = True +-- isROrEmpty _ = False + + +type family FirstTerm (s :: Symbol) :: Symbol where + FirstTerm s = LeftTerm s + +-- | +-- returns "" for unary operator +type family SecondTerm (s :: Symbol) :: Symbol where + SecondTerm s = RightTerm s + + +-- | +-- >>> :kind! LeftTerm "boolSomeOp:(agag)(222)" +-- ... +-- = "agag" +-- +-- >>> :kind! LeftTerm "r-Int-decimal" +-- ... +-- = "" +type family LeftTerm (s :: Symbol) :: Symbol where + LeftTerm s = Concat (LDropLast( LTakeFstParen (LParenCnt (ToList s)))) + +-- | +-- >>> :kind! RightTerm "boolSomeOp:(agag)(222)" +-- ... +-- = "222" +-- +-- >>> :kind! RightTerm "r-Int-decimal" +-- ... +-- = "" +type family RightTerm (s :: Symbol) :: Symbol where + RightTerm s = Concat (LDropLast (LTakeSndParen 0 (LParenCnt (ToList s)))) + + +type family LDropLast (s :: [Symbol]) :: [Symbol] where + LDropLast '[] = '[] + LDropLast '[x] = '[] + LDropLast (x ': xs) = x ': LDropLast xs + + +type family LParenCnt (s :: [Symbol]) :: [(Symbol, Nat)] where + LParenCnt '[] = '[] + LParenCnt ("(" ': xs) = LParenCntHelper ('(,) "(" 'Decr) (LParenCnt xs) -- '(,) "(" (LParenCntFstCnt (LParenCnt xs) - 1) ': LParenCnt xs + LParenCnt (")" ': xs) = LParenCntHelper ('(,) ")" 'Incr) (LParenCnt xs) + LParenCnt (x ': xs) = LParenCntHelper ('(,) x 'NoChng) (LParenCnt xs) + +data Adjust = Incr | Decr | NoChng + +type family AdjHelper (a :: Adjust) (n :: Nat) :: Nat where + AdjHelper 'Incr n = n + 1 + AdjHelper 'Decr 0 = 0 + AdjHelper 'Decr n = n - 1 + AdjHelper 'NoChng n = n + +type family LParenCntHelper (s :: (Symbol, Adjust)) (sx :: [(Symbol, Nat)]) :: [(Symbol, Nat)] where + LParenCntHelper ('(,) x k) '[] = '(,) x (AdjHelper k 0) ': '[] + LParenCntHelper ('(,) x k) ('(,) c i : xs) = '(,) x (AdjHelper k i) ': '(,) c i ': xs + + +type family LTakeFstParen (si :: [(Symbol, Nat)]) :: [Symbol] where + LTakeFstParen '[] = '[] + LTakeFstParen ('(,) _ 0 ': xs) = LTakeFstParen xs + LTakeFstParen ('(,) ")" 1 ': _) = '[")"] + LTakeFstParen ('(,) a p ': xs) = a ': LTakeFstParen xs + + +type family LTakeSndParen (n :: Nat) (si :: [(Symbol, Nat)]) :: [Symbol] where + LTakeSndParen _ '[] = '[] + LTakeSndParen 0 ('(,) ")" 1 ': xs) = LTakeSndParen 1 xs + LTakeSndParen 1 ('(,) _ 0 : xs) = LTakeSndParen 1 xs + LTakeSndParen 0 ('(,) _ _ ': xs) = LTakeSndParen 0 xs + LTakeSndParen 1 ('(,) a _ ': xs) = a : LTakeSndParen 1 xs + LTakeSndParen n _ = '[] + +-- -- * (Example) Value level equivalend of type family parsers + + +-- -- map snd . parenCnt $ "((AGA)(bcd))(123) " +-- -- dropLast . takeFstParen . parenCnt $ "((AGA)(bcd))(123)" +-- -- dropLast . takeSndParen 0 . parenCnt $ "((AGA)(bcd))(123)" + +-- leftTerm :: String -> String +-- leftTerm = dropLast . takeFstParen . parenCnt + +-- rightTerm :: String -> String +-- rightTerm = dropLast . takeSndParen 0 . parenCnt + +-- parenCnt :: String -> [(Char, Int)] +-- parenCnt [] = [] +-- parenCnt ('(' : xs) = parenCntHelper ('(', -1) (parenCnt xs) --('(', parenCntFstCnt (parenCnt xs) - 1) : parenCnt xs +-- parenCnt (')' : xs) = parenCntHelper (')', 1) (parenCnt xs) -- (')', parenCntFstCnt (parenCnt xs) + 1) : parenCnt xs +-- parenCnt (x : xs) = parenCntHelper (x, 0) (parenCnt xs) -- (x, parenCntFstCnt (parenCnt xs) ) : parenCnt xs + + +-- parenCntHelper :: (Char, Int) -> [(Char, Int)] -> [(Char, Int)] +-- parenCntHelper (x, k) [] = [(x,k)] +-- parenCntHelper (x, k) ((c,i) : xs) = (x, i + k): (c,i) : xs + + +-- takeFstParen :: [(Char, Int)] -> [Char] +-- takeFstParen [] = [] +-- takeFstParen ((_, 0) : xs) = takeFstParen xs +-- takeFstParen ((')', 1) : _) = [')'] +-- takeFstParen ((a, p) : xs) = a : takeFstParen xs + +-- takeSndParen :: Int -> [(Char, Int)] -> [Char] +-- takeSndParen _ [] = [] +-- takeSndParen 0 ((')', 1) : xs) = takeSndParen 1 xs +-- takeSndParen 1 ((_, 0) : xs) = takeSndParen 1 xs +-- takeSndParen 0 ((_, _) : xs) = takeSndParen 0 xs +-- takeSndParen 1 ((a, _) : xs) = a : takeSndParen 1 xs +-- takeSndParen _ _ = [] + +-- dropLast :: [Char] -> [Char] +-- dropLast [] = [] +-- dropLast [x] = [] +-- dropLast (x:xs) = x : dropLast xs + diff --git a/src/Data/TypedEncoding/Instances/Restriction/BoundedAlphaNums.hs b/src/Data/TypedEncoding/Instances/Restriction/BoundedAlphaNums.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypedEncoding/Instances/Restriction/BoundedAlphaNums.hs @@ -0,0 +1,122 @@ + +{-# LANGUAGE MultiParamTypeClasses #-} +-- {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +-- {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} + +-- | +-- Restrictions @"r-ban:"@ cover commonly used fixed (short) size strings with restricted +-- characters such as GUID, credit card numbers, etc. +-- +-- Alphanumeric chars are ordered: @0-9@ followed by @A-Z@, +-- followed by @a-z@. Annotation specifies upper character bound. +-- Any non alpha numeric characters are considered fixed delimiters +-- and need to be present exactly as specified. +-- For example @"r-ban:999-99-9999"@ could be used to describe SSN numbers, +-- @"r-ban:FFFF" would describe strings consisting of 4 hex digits. +-- +-- This is a simple implementation that converts to @String@, should be used +-- only with short length data. +-- +-- +-- @since 0.2.1.0 +module Data.TypedEncoding.Instances.Restriction.BoundedAlphaNums where + + +import GHC.TypeLits +import qualified Data.List as L +import Data.Char +import Data.Proxy +import Data.Either + +import Data.TypedEncoding.Common.Util.TypeLits +import Data.TypedEncoding.Common.Class.IsStringR +import Data.TypedEncoding.Instances.Support + +-- $setup +-- >>> :set -XOverloadedStrings -XMultiParamTypeClasses -XDataKinds -XTypeApplications +-- >>> import qualified Data.Text as T +-- >>> import Data.TypedEncoding + +-- better compilation errors? +type family IsBan (s :: Symbol) :: Bool where + IsBan s = AcceptEq ('Text "Not ban restriction encoding " ':<>: ShowType s ) (CmpSymbol (TakeUntil s ":") "r-ban") + +type Ban s = (KnownSymbol s, IsBan s ~ 'True) + +type instance IsSupersetOpen "r-ASCII" "r-ban" xs = 'True + + +instance (Ban s, Algorithm s "r-ban", IsStringR str) => Encode (Either EncodeEx) s "r-ban" c str where + encoding = encFBan + + +-- | +-- >>> runEncoding' encFBan . toEncoding () $ "C59F9FB7-4621-44D9-9020-CE37BF6E2BD1" :: Either EncodeEx (Enc '["r-ban:FFFFFFFF-FFFF-FFFF-FFFF-FFFFFFFFFFFF"] () T.Text) +-- Right (UnsafeMkEnc Proxy () "C59F9FB7-4621-44D9-9020-CE37BF6E2BD1") +-- +-- >>> recreateFAll' @'["r-ban"] . toEncoding () $ "211-22-9934" :: Either RecreateEx (Enc '["r-ban:999-99-9999"] () T.Text) +-- Right (UnsafeMkEnc Proxy () "211-22-9934") +encFBan :: forall s c str . + ( + IsStringR str + , Ban s + , Algorithm s "r-ban" + ) => + Encoding (Either EncodeEx) s "r-ban" c str +encFBan = _implEncodingEx @s (verifyBoundedAlphaNum (Proxy :: Proxy s)) + + + +-- * Decoding + +instance (KnownSymbol s, Restriction s, Algorithm s "r-ban", Applicative f) => Decode f s "r-ban" c str where + decoding = decAnyR_ + + +-- * Validation + +instance (KnownSymbol s , Ban s, Algorithm s "r-ban", IsStringR str, RecreateErr f, Applicative f) => Validate f s "r-ban" c str where + validation = validFromEnc' @"r-ban" encFBan + + +-- * Implementation + +-- | +-- >>> verifyBoundedAlphaNum (Proxy :: Proxy "r-ban:FF-FF") (T.pack "12-3E") +-- Right "12-3E" +-- >>> verifyBoundedAlphaNum (Proxy :: Proxy "r-ban:FF-FF") (T.pack "1G-3E") +-- Left "'G' not boulded by 'F'" +-- >>> verifyBoundedAlphaNum (Proxy :: Proxy "r-ban:FF-FF") (T.pack "13G3E") +-- Left "'G' not matching '-'" +-- >>> verifyBoundedAlphaNum (Proxy :: Proxy "r-ban:FF-FF") (T.pack "13-234") +-- Left "Input list has wrong size expecting 5 but length \"13-234\" == 6" +verifyBoundedAlphaNum :: forall s str . (KnownSymbol s, IsStringR str) => Proxy s -> str -> Either String str +verifyBoundedAlphaNum p str = + if pattl == inpl + then case lefts match of + (e: _) -> Left e + _ -> Right str + else Left $ "Input list has wrong size expecting " ++ show pattl ++ " but length " ++ show input ++ " == " ++ show inpl + where + patt = L.drop (L.length ("r-ban:" :: String)) . symbolVal $ p + input = toString str + pattl = L.length patt + inpl = L.length input + + match = L.zipWith fn input patt + + + fn ci cp = case (isAlphaNum ci, isAlphaNum cp, ci <= cp, ci == cp) of + (True, True, True, _) -> Right () + (_, _, _, True) -> Right () + (_, True, _, False) -> Left $ show ci ++ " not boulded by " ++ show cp + (_, False, _, False) -> Left $ show ci ++ " not matching " ++ show cp diff --git a/src/Data/TypedEncoding/Instances/Restriction/Common.hs b/src/Data/TypedEncoding/Instances/Restriction/Common.hs deleted file mode 100644 --- a/src/Data/TypedEncoding/Instances/Restriction/Common.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# 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 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) => 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, 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, Applicative f) => DecodeF f (Enc ("r-Word8-decimal" ': xs) c str) (Enc xs c str) where - decodeF = implTranP id - -instance (IsStringR str) => EncodeF (Either EncodeEx) (Enc xs c str) (Enc ("r-Int-decimal" ': xs) c str) where - encodeF = implEncodeF @"r-Int-decimal" (verifyWithRead @Int "Int-decimal") -instance (IsStringR str, RecreateErr f, Applicative f) => RecreateF f (Enc xs c str) (Enc ("r-Int-decimal" ': xs) c str) where - checkPrevF = implCheckPrevF (asRecreateErr @"r-Int-decimal" . verifyWithRead @Int "Int-decimal") -instance (IsStringR str, Applicative f) => DecodeF f (Enc ("r-Int-decimal" ': xs) c str) (Enc xs c str) where - decodeF = implTranP id - - --- tst :: T.Text --- tst = fromString $ show $ (fromString $ "123" :: T.Text) diff --git a/src/Data/TypedEncoding/Instances/Restriction/Misc.hs b/src/Data/TypedEncoding/Instances/Restriction/Misc.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypedEncoding/Instances/Restriction/Misc.hs @@ -0,0 +1,61 @@ +{-# 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.Misc where + +import Data.Word +import Data.Functor.Identity +import Data.String +import Data.Proxy +import Text.Read + +import Data.TypedEncoding.Common.Class.IsStringR +import Data.TypedEncoding.Instances.Support + +-- $setup +-- >>> import qualified Data.Text as T + +instance IsString str => ToEncString Identity "r-()" "r-()" () str where + toEncF _ = Identity $ UnsafeMkEnc Proxy () (fromString "()") + + +instance (IsStringR str) => Encode (Either EncodeEx) "r-Word8-decimal" "r-Word8-decimal" c str where + encoding = encWord8Dec +instance (Applicative f) => Decode f "r-Word8-decimal" "r-Word8-decimal" c str where + decoding = decAnyR +instance (IsStringR str) => Validate (Either RecreateEx) "r-Word8-decimal" "r-Word8-decimal" c str where + validation = validR encWord8Dec +instance IsString str => ToEncString Identity "r-Word8-decimal" "r-Word8-decimal" Word8 str where + toEncF i = Identity $ UnsafeMkEnc Proxy () (fromString . show $ i) +instance (IsStringR str, UnexpectedDecodeErr f, Applicative f) => FromEncString f "r-Word8-decimal" "r-Word8-decimal" Word8 str where + fromEncF = asUnexpected @ "r-Word8-decimal" . readEither . toString . getPayload + +encWord8Dec :: (IsStringR str) => Encoding (Either EncodeEx) "r-Word8-decimal" "r-Word8-decimal" c str +encWord8Dec = _implEncodingEx (verifyWithRead @Word8 "Word8-decimal") + + +instance (IsStringR str) => Encode (Either EncodeEx) "r-Int-decimal" "r-Int-decimal" c str where + encoding = encIntDec +instance (Applicative f) => Decode f "r-Int-decimal" "r-Int-decimal" c str where + decoding = decAnyR +instance (IsStringR str) => Validate (Either RecreateEx) "r-Int-decimal" "r-Int-decimal" c str where + validation = validR encIntDec +instance IsString str => ToEncString Identity "r-Int-decimal" "r-Int-decimal" Int str where + toEncF i = Identity $ UnsafeMkEnc Proxy () (fromString . show $ i) + +encIntDec :: (IsStringR str) => Encoding (Either EncodeEx) "r-Int-decimal" "r-Int-decimal" c str +encIntDec = _implEncodingEx (verifyWithRead @Int "Int-decimal") + + + + + +-- All instances of "r-Word8-decimal" are @Show@ / @Read@ based diff --git a/src/Data/TypedEncoding/Instances/Restriction/UTF8.hs b/src/Data/TypedEncoding/Instances/Restriction/UTF8.hs --- a/src/Data/TypedEncoding/Instances/Restriction/UTF8.hs +++ b/src/Data/TypedEncoding/Instances/Restriction/UTF8.hs @@ -16,95 +16,43 @@ 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 -- >>> import Data.TypedEncoding.Internal.Util (proxiedId) --- >>> :{ --- >>> instance Arbitrary (Enc '["r-UTF8"] () B.ByteString) where --- arbitrary = fmap (fromRight (emptyUTF8B ())) +-- >>> let emptyUTF8B = unsafeSetPayload () "" :: Enc '["r-UTF8"] () B.ByteString +-- >>> :{ +-- instance Arbitrary (Enc '["r-UTF8"] () B.ByteString) where +-- arbitrary = fmap (fromRight emptyUTF8B) -- . flip suchThat isRight --- . fmap (encodeFAll @(Either EncodeEx) @'["r-UTF8"] @(). toEncoding ()) $ arbitrary +-- . fmap (encodeFAll @'["r-UTF8"] @(Either EncodeEx) @(). toEncoding ()) $ arbitrary -- :} --- | DEPRECATED will be removed in 0.3 --- empty string is valid utf8 -emptyUTF8B :: c -> Enc '["r-UTF8"] c B.ByteString -emptyUTF8B c = unsafeSetPayload c "" ------------------ --- Conversions -- ------------------ --- | --- | DEPRECATED will be removed in 0.3 --- --- use 'Data.TypedEncoding.Conv.Text.Lazy.Encoding.encodeUtf8' --- and 'Data.TypedEncoding.Conv.Text.utf8Promote' -text2ByteStringS :: Enc ys c T.Text -> Enc ("r-UTF8" ': ys) c B.ByteString -text2ByteStringS = withUnsafeCoerce TE.encodeUtf8 - --- | --- DEPRECATED --- --- | DEPRECATED will be removed in 0.3 --- --- use 'Data.TypedEncoding.Conv.Text.Lazy.Encoding.decodeUtf8' --- and 'Data.TypedEncoding.Conv.Text.utf8Demote' --- --- See warning in 'Data.TypedEncoding.Instances.Restriction.ASCII.byteString2TextS' --- --- Type-safer version of Data.Text.Encoding.decodeUtf8 --- -byteString2TextS :: Enc ("r-UTF8" ': ys) c B.ByteString -> Enc ys c T.Text -byteString2TextS = withUnsafeCoerce TE.decodeUtf8 - --- | To be removed -txtBsSIdProp :: Proxy (ys :: [Symbol]) -> Enc ys c T.Text -> Enc ys c T.Text -txtBsSIdProp _ = byteString2TextS . text2ByteStringS - --- To be removed -bsTxtIdProp :: Proxy (ys :: [Symbol]) -> Enc ("r-UTF8" ': ys) c B.ByteString -> Enc ("r-UTF8" ': ys) c B.ByteString -bsTxtIdProp _ = text2ByteStringS . byteString2TextS - --- DEPRECATED see above -text2ByteStringL :: Enc ys c TL.Text -> Enc ("r-UTF8" ': ys) c BL.ByteString -text2ByteStringL = withUnsafeCoerce TEL.encodeUtf8 - --- DEPRECATED --- --- See warning in 'Data.TypedEncoding.Instances.Restriction.ASCII.byteString2TextS' -byteString2TextL :: Enc ("r-UTF8" ': ys) c BL.ByteString -> Enc ys c TL.Text -byteString2TextL = withUnsafeCoerce TEL.decodeUtf8 - ----------------- -- Encodings -- ----------------- prxyUtf8 = Proxy :: Proxy "r-UTF8" --- TODO these are quick and dirty +-- TODO these may need rethinking (performance) -- | 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") +-- Right (UnsafeMkEnc 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)) @@ -112,28 +60,32 @@ -- 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 Encode (Either EncodeEx) "r-UTF8" "r-UTF8" c B.ByteString where + encoding = encUTF8B -instance Encodings (Either EncodeEx) xs grps c B.ByteString => Encodings (Either EncodeEx) ("r-UTF8" ': xs) ("r-UTF8" ': grps) c B.ByteString where - encodings = encodeFEncoder @(Either EncodeEx) @"r-UTF8" @"r-UTF8" +instance Encode (Either EncodeEx) "r-UTF8" "r-UTF8" c BL.ByteString where + encoding = encUTF8BL :: Encoding (Either EncodeEx) "r-UTF8" "r-UTF8" c BL.ByteString +encUTF8B :: Encoding (Either EncodeEx) "r-UTF8" "r-UTF8" c B.ByteString +encUTF8B = _implEncodingEx (fmap TE.encodeUtf8 . TE.decodeUtf8') +{-# WARNING encUTF8B "This method was not optimized for performance." #-} -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 +encUTF8BL :: Encoding (Either EncodeEx) "r-UTF8" "r-UTF8" c BL.ByteString +encUTF8BL = _implEncodingEx (fmap TEL.encodeUtf8 . TEL.decodeUtf8') +{-# WARNING encUTF8BL "This method was not optimized for performance." #-} -instance Encodings (Either EncodeEx) xs grps c BL.ByteString => Encodings (Either EncodeEx) ("r-UTF8" ': xs) ("r-UTF8" ': grps) c BL.ByteString where - encodings = encodeFEncoder @(Either EncodeEx) @"r-UTF8" @"r-UTF8" +-- * Decoding -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 +instance (Applicative f) => Decode f "r-UTF8" "r-UTF8" c str where + decoding = decAnyR + +instance (RecreateErr f, Applicative f) => Validate f "r-UTF8" "r-UTF8" c B.ByteString where + validation = validR encUTF8B + +instance (RecreateErr f, Applicative f) => Validate f "r-UTF8" "r-UTF8" c BL.ByteString where + validation = validR encUTF8BL + --- Utilities --- diff --git a/src/Data/TypedEncoding/Instances/Support.hs b/src/Data/TypedEncoding/Instances/Support.hs --- a/src/Data/TypedEncoding/Instances/Support.hs +++ b/src/Data/TypedEncoding/Instances/Support.hs @@ -4,16 +4,29 @@ -- Contains typical things needed when implementing -- encoding, decoding, recreate, or type to string conversions. module Data.TypedEncoding.Instances.Support ( + module Data.TypedEncoding.Instances.Support -- * Types - module Data.TypedEncoding.Internal.Types + , module Data.TypedEncoding.Common.Types -- * Classes - , module Data.TypedEncoding.Internal.Class + , module Data.TypedEncoding.Common.Class -- * Combinators - , module Data.TypedEncoding.Internal.Instances.Combinators + , module Data.TypedEncoding.Instances.Support.Common + , module Data.TypedEncoding.Instances.Support.Helpers + , module Data.TypedEncoding.Instances.Support.Encode + , module Data.TypedEncoding.Instances.Support.Decode + , module Data.TypedEncoding.Instances.Support.Validate + , module Data.TypedEncoding.Combinators.Unsafe -- * Type level conveniences - , module Data.TypedEncoding.Internal.Util.TypeLits + , module Data.TypedEncoding.Common.Util.TypeLits ) where -import Data.TypedEncoding.Internal.Types -import Data.TypedEncoding.Internal.Class -import Data.TypedEncoding.Internal.Instances.Combinators -import Data.TypedEncoding.Internal.Util.TypeLits + +import Data.TypedEncoding.Instances.Support.Common +import Data.TypedEncoding.Instances.Support.Helpers +import Data.TypedEncoding.Instances.Support.Encode +import Data.TypedEncoding.Instances.Support.Decode +import Data.TypedEncoding.Instances.Support.Validate +import Data.TypedEncoding.Common.Types +import Data.TypedEncoding.Common.Class +import Data.TypedEncoding.Common.Util.TypeLits +import Data.TypedEncoding.Combinators.Unsafe + diff --git a/src/Data/TypedEncoding/Instances/Support/Common.hs b/src/Data/TypedEncoding/Instances/Support/Common.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypedEncoding/Instances/Support/Common.hs @@ -0,0 +1,36 @@ + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeApplications #-} + +-- | Exports for instance creation. +-- +-- Contains typical things needed when implementing +-- encoding, decoding, recreate, or type to string conversions. +module Data.TypedEncoding.Instances.Support.Common where + +import Data.TypedEncoding.Instances.Support.Unsafe +import Data.TypedEncoding.Common.Types +import Data.Proxy + +-- $setup +-- >>> :set -XOverloadedStrings -XMultiParamTypeClasses -XDataKinds -XTypeApplications + + +-- * Decoding + +-- | Universal decoding for all "r-" types +decAnyR :: forall r f c str . (Restriction r, Applicative f) => Decoding f r r c str +decAnyR = decAnyR' @r @r + +decAnyR' :: forall alg r f c str . (Restriction r, Applicative f) => Decoding f r alg c str +decAnyR' = UnsafeMkDecoding Proxy (implTranP id) + +decAnyR_ :: forall r f c str alg . (Restriction r, Algorithm r alg, Applicative f) => Decoding f r alg c str +decAnyR_ = mkDecoding $ implTranP id + diff --git a/src/Data/TypedEncoding/Instances/Support/Decode.hs b/src/Data/TypedEncoding/Instances/Support/Decode.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypedEncoding/Instances/Support/Decode.hs @@ -0,0 +1,39 @@ + +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} + +-- | v0.2 style decoding combinators +module Data.TypedEncoding.Instances.Support.Decode where + +import Data.TypedEncoding.Instances.Support.Unsafe +import Data.TypedEncoding.Common.Types.Decoding +import Data.Proxy +import Data.TypedEncoding.Common.Types + + + +-- * Compiler figure out algorithm, these appear fast enough + +_implDecodingF :: forall nm f c str . Functor f => (str -> f str) -> Decoding f nm (AlgNm nm) c str +_implDecodingF f = mkDecoding $ implTranF f + +_implDecodingConfF :: forall nm f c str . Functor f => (c -> str -> f str) -> Decoding f nm (AlgNm nm) c str +_implDecodingConfF f = mkDecoding $ implTranF' f + + +-- * Assume @alg ~ nm@ or explicit @alg@ + +implDecodingF :: forall nm f c str . Functor f => (str -> f str) -> Decoding f nm nm c str +implDecodingF = implDecodingF' @nm @nm + +implDecodingF' :: forall alg nm f c str . Functor f => (str -> f str) -> Decoding f nm alg c str +implDecodingF' f = UnsafeMkDecoding Proxy $ implTranF f + + + diff --git a/src/Data/TypedEncoding/Instances/Support/Encode.hs b/src/Data/TypedEncoding/Instances/Support/Encode.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypedEncoding/Instances/Support/Encode.hs @@ -0,0 +1,63 @@ + +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} + + +module Data.TypedEncoding.Instances.Support.Encode where + +import Data.TypedEncoding.Instances.Support.Unsafe +import Data.TypedEncoding.Common.Types.Enc +import Data.Proxy +import Data.TypedEncoding.Common.Types +import GHC.TypeLits + + +-- * Compiler figure out algorithm, these appear fast enough + +_implEncodingP :: forall nm f c str . Applicative f => (str -> str) -> Encoding f nm (AlgNm nm) c str +_implEncodingP f = _mkEncoding $ implTranF (pure . f) + +_implEncodingConfP :: forall nm f c str . Applicative f => (c -> str -> str) -> Encoding f nm (AlgNm nm) c str +_implEncodingConfP f = _mkEncoding $ implTranF' (\c -> pure . f c) + +_implEncodingEx :: forall nm err c str . (KnownSymbol nm, Show err) => (str -> Either err str) -> Encoding (Either EncodeEx) nm (AlgNm nm) c str +_implEncodingEx f = _mkEncoding $ implTranF (either (Left . EncodeEx p) Right . f) + where + p = Proxy :: Proxy nm + +_implEncodingEncodeEx :: forall nm c str . (KnownSymbol nm) => (str -> Either EncodeEx str) -> Encoding (Either EncodeEx) nm (AlgNm nm) c str +_implEncodingEncodeEx f = _mkEncoding $ implTranF f + + +_implEncodingConfEx :: forall nm err c str . (KnownSymbol nm, Show err) => (c -> str -> Either err str) -> Encoding (Either EncodeEx) nm (AlgNm nm) c str +_implEncodingConfEx f = _mkEncoding $ implTranF' (\c -> either (Left . EncodeEx p) Right . f c) + where + p = Proxy :: Proxy nm + + + +-- * Assume @alg ~ nm@ or explicit @alg@ + +implEncodingP :: forall nm f c str . Applicative f => (str -> str) -> Encoding f nm nm c str +implEncodingP f = UnsafeMkEncoding Proxy $ implTranF (pure . f) + +implEncodingEx :: forall nm err c str . (KnownSymbol nm, Show err) => (str -> Either err str) -> Encoding (Either EncodeEx) nm nm c str +implEncodingEx = implEncodingEx' @nm @nm + +implEncodingEx' :: forall alg nm err c str . (KnownSymbol nm, Show err) => (str -> Either err str) -> Encoding (Either EncodeEx) nm alg c str +implEncodingEx' f = UnsafeMkEncoding Proxy $ implTranF (either (Left . EncodeEx p) Right . f) + where + p = Proxy :: Proxy nm + +implEncodingEncodeEx' :: forall alg nm c str . (KnownSymbol nm) => (str -> Either EncodeEx str) -> Encoding (Either EncodeEx) nm alg c str +implEncodingEncodeEx' f = UnsafeMkEncoding Proxy $ implTranF f + where + p = Proxy :: Proxy nm + + diff --git a/src/Data/TypedEncoding/Instances/Support/Helpers.hs b/src/Data/TypedEncoding/Instances/Support/Helpers.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypedEncoding/Instances/Support/Helpers.hs @@ -0,0 +1,112 @@ + +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- {-# LANGUAGE AllowAmbiguousTypes #-} +-- {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} + +-- | Support for mostly creating instances ToEncString and FromEncString conversions + +module Data.TypedEncoding.Instances.Support.Helpers where + +import Data.String +import Data.Proxy +import Text.Read +import Data.TypedEncoding.Common.Types +import Data.TypedEncoding.Combinators.Unsafe +import Data.TypedEncoding.Common.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 (UnsafeMkEnc _ c s1) = map (UnsafeMkEnc 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 (UnsafeMkCheckedEnc ann1 c s1) = map (\(ann2, s2) -> UnsafeMkCheckedEnc 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, 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 + + +-- | Convenience function for checking if @str@ decodes without error +-- using @enc@ encoding markers and decoders that can pick decoder based +-- on that marker +verifyDynEnc :: forall s str err1 err2 enc a. (KnownSymbol s, Show err1, Show err2) => + Proxy s -- ^ proxy defining encoding annotation + -> (Proxy s -> Either err1 enc) -- ^ finds encoding marker @enc@ for given annotation or fails + -> (enc -> str -> Either err2 a) -- ^ decoder based on @enc@ marker + -> str -- ^ input + -> Either EncodeEx str +verifyDynEnc p findenc decoder str = + do + enc <- asEncodeEx p . findenc $ p + case decoder enc str of + Left err -> Left $ EncodeEx p err + Right r -> Right str + + diff --git a/src/Data/TypedEncoding/Instances/Support/Unsafe.hs b/src/Data/TypedEncoding/Instances/Support/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypedEncoding/Instances/Support/Unsafe.hs @@ -0,0 +1,35 @@ + +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- {-# LANGUAGE AllowAmbiguousTypes #-} +-- {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} + +-- | Direct use of these methods is discouraged. +-- Use "Data.TypedEncoding.Instances.Support.Encode" or "Data.TypedEncoding.Instances.Support.Decode" +module Data.TypedEncoding.Instances.Support.Unsafe where + +import Data.Proxy +import Data.TypedEncoding.Common.Types +import Data.TypedEncoding.Combinators.Unsafe + + + +implTranF :: Functor f => (str -> f str) -> Enc enc1 conf str -> f (Enc enc2 conf str) +implTranF f = implTranF' (const f) + +implTranF' :: Functor f => (conf -> str -> f str) -> Enc enc1 conf str -> f (Enc enc2 conf str) +implTranF' f (UnsafeMkEnc _ conf str) = UnsafeMkEnc Proxy conf <$> f conf str + +implTranP :: Applicative f => (str -> str) -> Enc enc1 conf str -> f (Enc enc2 conf str) +implTranP f = implTranF' (\c -> pure . f) + +implTranP' :: Applicative f => (conf -> str -> str) -> Enc enc1 conf str -> f (Enc enc2 conf str) +implTranP' f = implTranF' (\c -> pure . f c) + +implChangeAnn :: Functor f => (Enc enc1 conf str -> f (Enc enc2a conf str)) -> Enc enc1 conf str -> f (Enc enc2b conf str) +implChangeAnn fn = fmap (withUnsafeCoerce id) . fn + diff --git a/src/Data/TypedEncoding/Instances/Support/Validate.hs b/src/Data/TypedEncoding/Instances/Support/Validate.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypedEncoding/Instances/Support/Validate.hs @@ -0,0 +1,60 @@ + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeApplications #-} + +-- | Exports for instance creation. +-- +-- Contains typical things needed when implementing +-- encoding, decoding, recreate, or type to string conversions. +module Data.TypedEncoding.Instances.Support.Validate where +import Data.TypedEncoding.Common.Types +import Data.TypedEncoding.Common.Class + +import GHC.TypeLits +import Data.Proxy + +-- $setup +-- >>> :set -XOverloadedStrings -XMultiParamTypeClasses -XDataKinds -XTypeApplications + + +-- * Validation + +validFromDec :: forall nm f c str . (KnownSymbol nm, RecreateErr f, Applicative f) => Decoding (Either UnexpectedDecodeEx) nm nm c str -> Validation f nm nm c str +validFromDec = validFromDec' @nm @nm + +validFromDec' :: forall alg nm f c str . (KnownSymbol nm, RecreateErr f, Applicative f) => Decoding (Either UnexpectedDecodeEx) nm alg c str -> Validation f nm alg c str +validFromDec' (UnsafeMkDecoding p fn) = UnsafeMkValidation p (decAsRecreateErr . fn) + where + decAsRecreateErr :: Either UnexpectedDecodeEx a -> f a + decAsRecreateErr (Left (UnexpectedDecodeEx p err)) = recoveryErr $ RecreateEx p err + decAsRecreateErr (Right r) = pure r + + +validR :: forall nm f c str . (Restriction nm, KnownSymbol nm, RecreateErr f, Applicative f) => Encoding (Either EncodeEx) nm nm c str -> Validation f nm nm c str +validR = validFromEnc' @nm @nm + +-- | Can cause slow compilation if used +validR' :: forall nm f c str alg . (Restriction nm, Algorithm nm alg, KnownSymbol nm, RecreateErr f, Applicative f) => Encoding (Either EncodeEx) nm alg c str -> Validation f nm alg c str +validR' = validFromEnc' @alg @nm + + +validFromEnc' :: forall alg nm f c str . (KnownSymbol nm, RecreateErr f, Applicative f) => Encoding (Either EncodeEx) nm alg c str -> Validation f nm alg c str +validFromEnc' (UnsafeMkEncoding p fn) = UnsafeMkValidation p (encAsRecreateErr . rfn) + where + encAsRecreateErr :: Either EncodeEx a -> f a + encAsRecreateErr (Left (EncodeEx p err)) = recoveryErr $ RecreateEx p err + encAsRecreateErr (Right r) = pure r + rfn :: forall (xs :: [Symbol]) . Enc (nm ': xs) c str -> Either EncodeEx (Enc xs c str) + rfn (UnsafeMkEnc _ conf str) = + let re = fn $ UnsafeMkEnc Proxy conf str + in UnsafeMkEnc Proxy conf . getPayload <$> re + + + + diff --git a/src/Data/TypedEncoding/Instances/ToEncString/Common.hs b/src/Data/TypedEncoding/Instances/ToEncString/Common.hs deleted file mode 100644 --- a/src/Data/TypedEncoding/Instances/ToEncString/Common.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# 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) - --- All instances of "r-Word8-decimal" are @Show@ / @Read@ based -instance (IsStringR str, UnexpectedDecodeErr f, Applicative f) => FromEncString Word8 f str "r-Word8-decimal" where - fromEncStringF = asUnexpected @ "r-Word8-decimal" . readEither . toString . getPayload diff --git a/src/Data/TypedEncoding/Internal/Class.hs b/src/Data/TypedEncoding/Internal/Class.hs deleted file mode 100644 --- a/src/Data/TypedEncoding/Internal/Class.hs +++ /dev/null @@ -1,72 +0,0 @@ - -{-# 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 ( - 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 - , module Data.TypedEncoding.Internal.Class.Superset - -- * Encoder and Encoding replace EncodeFAll - , module Data.TypedEncoding.Internal.Class.Encoder - ) 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.Class.Superset -import Data.TypedEncoding.Internal.Class.Encoder - -import Data.TypedEncoding.Internal.Types (Enc(..) - , withUnsafeCoerce - -- , getPayload - ) -import Data.Functor.Identity -import GHC.TypeLits - - --- | --- 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) - -toEncString :: forall x str f a . (ToEncString x str Identity a) => a -> Enc '[x] () str -toEncString = runIdentity . toEncStringF - - --- | --- Reverse of 'ToEncString' decodes encoded string back to @a@ -class (KnownSymbol x) => FromEncString a f str x where - fromEncStringF :: Enc '[x] () str -> f a - -fromEncString :: forall a str x . (FromEncString a Identity str x) => Enc '[x] () str -> a -fromEncString = runIdentity . fromEncStringF - --- Other classes -- - --- | Flatten is more permissive than 'Superset' --- @ --- instance FlattenAs "r-ASCII" "enc-B64" where -- OK --- @ --- --- Now encoded data has form @Enc '["r-ASCII"] c str@ --- and there is no danger of it begin incorrectly decoded. - -class FlattenAs (y :: Symbol) (x :: Symbol) where - flattenAs :: Enc (x ': xs) c str -> Enc '[y] c str - flattenAs = withUnsafeCoerce id diff --git a/src/Data/TypedEncoding/Internal/Class/Decode.hs b/src/Data/TypedEncoding/Internal/Class/Decode.hs deleted file mode 100644 --- a/src/Data/TypedEncoding/Internal/Class/Decode.hs +++ /dev/null @@ -1,81 +0,0 @@ - -{-# 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 :: forall xs c str . 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) diff --git a/src/Data/TypedEncoding/Internal/Class/Encode.hs b/src/Data/TypedEncoding/Internal/Class/Encode.hs deleted file mode 100644 --- a/src/Data/TypedEncoding/Internal/Class/Encode.hs +++ /dev/null @@ -1,71 +0,0 @@ - -{-# 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 :: forall xs c str . 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) - diff --git a/src/Data/TypedEncoding/Internal/Class/Encoder.hs b/src/Data/TypedEncoding/Internal/Class/Encoder.hs deleted file mode 100644 --- a/src/Data/TypedEncoding/Internal/Class/Encoder.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE PartialTypeSignatures #-} --- {-# LANGUAGE RankNTypes #-} -{-# OPTIONS_GHC -Wno-partial-type-signatures #-} - --- | --- Internal definition of types --- --- Possible replacement for EncodeFAll class that works with open definitions such as "r-ban" - -module Data.TypedEncoding.Internal.Class.Encoder where - -import Data.TypedEncoding.Internal.Types.Enc --- import Data.TypedEncoding.Internal.Class.Util -import Data.TypedEncoding.Internal.Class.Encode -import Data.TypedEncoding.Internal.Util.TypeLits -import GHC.TypeLits --- import Data.Symbol.Ascii - - -data Encoder f (enc :: [Symbol]) (grps :: [Symbol]) 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 - ZeroEnc :: Encoder f '[] '[] conf str - AppendEnc :: (Enc xs conf str -> f (Enc (x ': xs) conf str)) -> Encoder f xs grps conf str -> Encoder f (x ': xs) ((TakeUntil x ":") ': grps) conf str - -runEncoder :: forall grps enc f c str . (Monad f) => Encoder f enc grps c str -> Enc ('[]::[Symbol]) c str -> f (Enc enc c str) -runEncoder ZeroEnc enc0 = pure enc0 -runEncoder (AppendEnc fn enc) enc0 = - let re :: f (Enc _ c str) = runEncoder enc enc0 - in re >>= fn - -encodeFEncoder :: forall f t tg xs gxs c str . (tg ~ TakeUntil t ":", Encodings f xs gxs c str, EncodeF f (Enc xs c str) (Enc (t ': xs) c str)) => Encoder f (t ': xs) (tg ': gxs) c str -encodeFEncoder = AppendEnc (encodeF @f @(Enc xs c str) @(Enc (t ': xs) c str)) encodings - -class Encodings f (enc :: [Symbol]) (grps :: [Symbol]) c str where - encodings :: Encoder f enc grps c str - -instance Encodings f '[] '[] c str where - encodings = ZeroEnc diff --git a/src/Data/TypedEncoding/Internal/Class/IsStringR.hs b/src/Data/TypedEncoding/Internal/Class/IsStringR.hs deleted file mode 100644 --- a/src/Data/TypedEncoding/Internal/Class/IsStringR.hs +++ /dev/null @@ -1,73 +0,0 @@ - - -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FlexibleInstances #-} - --- | This Module will be removed in 0.3.x.x in favor of --- "Data.TypedEncoding.Internal.Class.Util.StringConstraints" -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() - --- | This class will be removed in 0.3.x.x in favor of classes definined in --- "Data.TypedEncoding.Internal.Class.Util.StringConstraints" --- --- 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 - -instance IsStringR [Char] where - toString = id diff --git a/src/Data/TypedEncoding/Internal/Class/Recreate.hs b/src/Data/TypedEncoding/Internal/Class/Recreate.hs deleted file mode 100644 --- a/src/Data/TypedEncoding/Internal/Class/Recreate.hs +++ /dev/null @@ -1,90 +0,0 @@ - -{-# 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(..) - , getPayload - ) -import Data.TypedEncoding.Internal.Class.Util -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 - - --- | Useful for partially manual recreation -recreateFPart_ :: forall f xs xsf c str . (Functor f, RecreateFAll f xs c str) => Proxy xs -> Enc xsf c str -> f (Enc (Append xs xsf) c str) -recreateFPart_ p (MkEnc _ conf str) = - let re :: f (Enc xs c str) = recreateFAll $ MkEnc Proxy conf str - in MkEnc Proxy conf . getPayload <$> re - - -recreateFPart :: forall (xs :: [Symbol]) xsf f c str . (Functor f, RecreateFAll f xs c str) => Enc xsf c str -> f (Enc (Append xs xsf) c str) -recreateFPart = recreateFPart_ (Proxy :: Proxy xs) - - -recreatePart_ :: RecreateFAll Identity (xs :: [Symbol]) c str => - Proxy xs - -> Enc xsf c str - -> Enc (Append xs xsf) c str -recreatePart_ p = runIdentity . recreateFPart_ p - -recreatePart :: forall (xs :: [Symbol]) xsf c str . RecreateFAll Identity xs c str => - Enc xsf c str - -> Enc (Append xs xsf) c str -recreatePart = recreatePart_ (Proxy :: Proxy xs) - --- | 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) diff --git a/src/Data/TypedEncoding/Internal/Class/Superset.hs b/src/Data/TypedEncoding/Internal/Class/Superset.hs deleted file mode 100644 --- a/src/Data/TypedEncoding/Internal/Class/Superset.hs +++ /dev/null @@ -1,131 +0,0 @@ - -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} --- {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE AllowAmbiguousTypes #-} - -module Data.TypedEncoding.Internal.Class.Superset where - -import Data.TypedEncoding.Internal.Util.TypeLits ---import Data.TypedEncoding.Internal.Class.Util (displ) - -import Data.TypedEncoding.Internal.Types (Enc(..) - , withUnsafeCoerce - --, unsafeSetPayload - ) -import GHC.TypeLits -import Data.Symbol.Ascii --- import Data.Proxy - --- $setup --- >>> :set -XOverloadedStrings -XMultiParamTypeClasses -XDataKinds -XTypeApplications --- >>> import Data.TypedEncoding.Internal.Class.Util (displ) --- >>> import Data.TypedEncoding.Internal.Types (unsafeSetPayload) --- >>> import Data.Text as T - - --- | --- DEPRECATED see 'IsSuperset' --- --- Subsets are useful for restriction encodings --- like r-UFT8 but should not be used for other encodings. --- --- This would be dangerous, it would, for example, permit converting encoded binary --- @"Enc '["enc-"] c ByteString@ to @"Enc '["enc-"] c Text@, decoding which --- could result in runtime errors. --- --- The requirement is that that the decoding in the superset --- can replace the decoding from injected subset. --- --- @ --- instance Superset "r-ASCII" "enc-B64" where -- DANGEROUS --- @ --- --- 'inject' is identity on payloads --- --- @Superset bigger smaller@ reads as @bigger@ is a superset of @smaller@ -class Superset (y :: Symbol) (x :: Symbol) where - inject :: Enc (x ': xs) c str -> Enc (y ': xs) c str - inject = withUnsafeCoerce id - -instance Superset x x where - --- | more permissive than class -type family IsSuperset (y :: Symbol) (x :: Symbol) :: Bool where - IsSuperset "r-ASCII" "r-ASCII" = 'True - IsSuperset "r-UTF8" "r-ASCII" = 'True - IsSuperset "r-UTF8" "r-UTF8" = 'True - IsSuperset y x = IsSupersetOpen y (TakeUntil x ":") (ToList x) - -type family IsSupersetOpen (y :: Symbol) (x :: Symbol) (xs :: [Symbol]) :: Bool - -injectInto :: forall y x xs c str . (IsSuperset y x ~ 'True) => Enc (x ': xs) c str -> Enc (y ': xs) c str -injectInto = withUnsafeCoerce id - --- | remove redundant superset right after the top (at second last encoding position) --- --- >>> displ $ demoteFlattenTop (unsafeSetPayload () "" :: Enc '["r-ASCII", "r-UTF8", "r-boo"] () T.Text) --- "MkEnc '[r-ASCII,r-boo] () (Text )" -demoteFlattenTop :: forall y x xs c str . (IsSuperset y x ~ 'True) => Enc (x ': y ': xs) c str -> Enc (x ': xs) c str -demoteFlattenTop = withUnsafeCoerce id - --- | add redundant superset right after --- --- >>> displ $ promoteUnFlattenTop @"r-UTF8" (unsafeSetPayload () "" :: Enc '["r-ASCII", "r-boo"] () T.Text) --- "MkEnc '[r-ASCII,r-UTF8,r-boo] () (Text )" -promoteUnFlattenTop :: forall y x xs c str . (IsSuperset y x ~ 'True) => Enc (x ': xs) c str -> Enc (x ': y ': xs) c str -promoteUnFlattenTop = withUnsafeCoerce id - --- | remove redunant superset from the top (at last applied encoding position) --- --- >>> displ $ demoteRemoveTop (unsafeSetPayload () "" :: Enc '["r-UTF8", "r-ASCII", "r-boo"] () T.Text) --- "MkEnc '[r-ASCII,r-boo] () (Text )" -demoteRemoveTop :: forall y x xs c str . (IsSuperset y x ~ 'True) => Enc (y ': x ' : xs) c str -> Enc (x ': xs) c str -demoteRemoveTop = withUnsafeCoerce id - --- | add redundant superset at the top --- --- >>> displ $ promoteAddTop @"r-UTF8" (unsafeSetPayload () "" :: Enc '["r-ASCII", "r-boo"] () T.Text) --- "MkEnc '[r-UTF8,r-ASCII,r-boo] () (Text )" -promoteAddTop :: forall y x xs c str . (IsSuperset y x ~ 'True) => Enc (x ': xs) c str -> Enc (y ': x ' : xs) c str -promoteAddTop = withUnsafeCoerce id - --- | remove redundant superset at bottom (first encoding) position --- --- >>> displ $ demoteRemoveBot (unsafeSetPayload () "" :: Enc '["r-boo", "r-ASCII", "r-UTF8"] () T.Text) --- "MkEnc '[r-boo,r-ASCII] () (Text )" -demoteRemoveBot :: (UnSnoc xs ~ '(,) ys y, UnSnoc ys ~ '(,) zs x, IsSuperset y x ~ 'True) => Enc xs c str -> Enc ys c str -demoteRemoveBot = withUnsafeCoerce id - --- | add redundant superset at bottom (first encoding) position --- --- >>> displ $ promoteAddBot @"r-UTF8" (unsafeSetPayload () "" :: Enc '["r-boo", "r-ASCII"] () T.Text) --- "MkEnc '[r-boo,r-ASCII,r-UTF8] () (Text )" -promoteAddBot :: forall y x xs c str ys . (UnSnoc xs ~ '(,) ys x, IsSuperset y x ~ 'True) => Enc xs c str -> Enc (Snoc xs y) c str -promoteAddBot = withUnsafeCoerce id - --- | remove redundant superset at second bottom (second encoding) position --- --- >>> displ $ demoteFlattenBot (unsafeSetPayload () "" :: Enc '["r-boo", "r-UTF8", "r-ASCII"] () T.Text) --- "MkEnc '[r-boo,r-ASCII] () (Text )" -demoteFlattenBot :: (UnSnoc xs ~ '(,) ys x, UnSnoc ys ~ '(,) zs y, IsSuperset y x ~ 'True) => Enc xs c str -> Enc (Snoc zs x) c str -demoteFlattenBot = withUnsafeCoerce id - --- | add redundant superset at second bottom (second encoding) position --- --- >>> displ $ promoteUnFlattenBot @"r-UTF8" (unsafeSetPayload () "" :: Enc '["r-boo", "r-ASCII"] () T.Text) --- "MkEnc '[r-boo,r-UTF8,r-ASCII] () (Text )" -promoteUnFlattenBot :: forall y x xs c str ys . (UnSnoc xs ~ '(,) ys x, IsSuperset y x ~ 'True) => Enc xs c str -> Enc (Snoc (Snoc ys y) x) c str -promoteUnFlattenBot = withUnsafeCoerce id - --- prop_Superset :: forall y x xs c str . (Superset y x, Eq str) => Enc (x ': xs) c str -> Bool --- prop_Superset x = getPayload x == (getPayload . inject @y @x $ x) - diff --git a/src/Data/TypedEncoding/Internal/Class/Util.hs b/src/Data/TypedEncoding/Internal/Class/Util.hs deleted file mode 100644 --- a/src/Data/TypedEncoding/Internal/Class/Util.hs +++ /dev/null @@ -1,94 +0,0 @@ - -{-# 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 - --- | TODO 0.3 TO BE REMOVED -instance Displ EncAnn where - displ = id - -instance Displ [EncAnn] where - displ x = "[" ++ L.intercalate "," 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 ++ ")" - --- TODO 0.3 replaces: instance Displ EncAnn --- instance Displ String where --- displ x = "(String " ++ 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 () diff --git a/src/Data/TypedEncoding/Internal/Class/Util/StringConstraints.hs b/src/Data/TypedEncoding/Internal/Class/Util/StringConstraints.hs deleted file mode 100644 --- a/src/Data/TypedEncoding/Internal/Class/Util/StringConstraints.hs +++ /dev/null @@ -1,134 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE AllowAmbiguousTypes #-} - --- | Future replacement for "Data.TypedEncoding.Internal.Class.IsStringR" -module Data.TypedEncoding.Internal.Class.Util.StringConstraints () where - -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import Data.String -import Data.Proxy -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Char8 as B8 -import qualified Data.ByteString.Lazy.Char8 as BL8 - --- $setup --- >>> :set -XScopedTypeVariables -XTypeApplications -XAllowAmbiguousTypes --- >>> import Test.QuickCheck --- >>> import Test.QuickCheck.Instances.Text() --- >>> import Test.QuickCheck.Instances.ByteString() - - --- * IsString reversal - --- | Reverses 'Data.String.IsString' --- --- law for types that are also @IsString@: --- --- @ --- toString . fromString == id --- @ --- --- Note: ByteString is not a valid instance, ByteString "r-ASCII", or "r-UTF8" would --- be needed. --- @B8.unpack $ B8.pack "\160688" == "\176"@ --- --- This class is separated from @ToStrIso@ to allow instances from /smaller/ types --- the can inject into the 'String' type. -class ToStrInj str from where - toString :: from -> str - -prop_toStringFromString :: forall s . (IsString s, ToStrInj String s) => Proxy s -> String -> Bool -prop_toStringFromString _ x = x == (toString @String @s . fromString $ x) - - --- | --- prop> prop_toStringFromString (Proxy :: Proxy T.Text) -instance ToStrInj String T.Text where - toString = T.unpack - --- | --- prop> prop_toStringFromString (Proxy :: Proxy TL.Text) -instance ToStrInj String TL.Text where - toString = TL.unpack - - -instance ToStrInj String String where - toString = id - --- will not work! --- prop> prop_toStringFromString (Proxy :: Proxy B.ByteString) --- instance ToStrInj String B.ByteString where --- toString = B8.unpack - --- will not work! --- prop> prop_toStringFromString (Proxy :: Proxy BL.ByteString) --- instance ToStrInj String BL.ByteString where --- toString = BL8.unpack - - --- | Same as @ToStrInj@ but with additional --- --- law for types that are also @IsString@: --- @ --- fromString . toString == id --- @ -class ToStrInj str from => ToStrIso str from where - -prop_fromStringToString :: forall s . (IsString s, ToStrIso String s, Eq s) => s -> Bool -prop_fromStringToString x = x == (fromString @s . toString $ x) - --- | --- prop> prop_fromStringToString @T.Text -instance ToStrIso String T.Text where - --- | --- prop> prop_fromStringToString @TL.Text -instance ToStrIso String TL.Text where - -instance ToStrIso String String where - --- | --- Used to find exceptions that violated "r-" encoding --- Expected to be used to check encoding of ASCII-7 so Text and ByteString are compatible. -class Char7Find str where - find :: (Char -> Bool) -> str -> Maybe Char - - -instance Char7Find T.Text where - find = T.find - -instance Char7Find TL.Text where - find = TL.find - --- | --- B8.pack is basically a convenient way to get Word8 elements into ByteString. --- --- During B8.pack conversion charters are downsized to the 0-255 range (become a Word8). --- The length is preserved. --- --- >>> B8.pack "\160582" --- "F" --- --- >>> B.length $ B8.pack "\160582" --- 1 --- --- This instance allows to check elements of ByteString interpreting them as Char. --- --- This may or may not work with UTF8 conversions. --- Safe if restricting to 7bit code points.s -instance Char7Find B.ByteString where - find = B8.find - -instance Char7Find BL.ByteString where - find = BL8.find diff --git a/src/Data/TypedEncoding/Internal/Combinators.hs b/src/Data/TypedEncoding/Internal/Combinators.hs deleted file mode 100644 --- a/src/Data/TypedEncoding/Internal/Combinators.hs +++ /dev/null @@ -1,54 +0,0 @@ - -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE DataKinds #-} --- {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FlexibleContexts #-} - --- | Combinators reexported in Data.TypedEncoding -module Data.TypedEncoding.Internal.Combinators where - -import Data.TypedEncoding.Internal.Types -import Data.TypedEncoding.Internal.Class.Recreate -import Data.TypedEncoding.Internal.Class.Util (SymbolList) -import GHC.TypeLits --- import Data.Proxy - --- $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 - - diff --git a/src/Data/TypedEncoding/Internal/Instances/Combinators.hs b/src/Data/TypedEncoding/Internal/Instances/Combinators.hs deleted file mode 100644 --- a/src/Data/TypedEncoding/Internal/Instances/Combinators.hs +++ /dev/null @@ -1,107 +0,0 @@ - -{-# 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, 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 - - --- | Convenience function for checking if @str@ decodes properly --- using @enc@ encoding markers and decoders that can pick decoder based --- on that marker -verifyDynEnc :: forall s str err1 err2 enc a. (KnownSymbol s, Show err1, Show err2) => - Proxy s -- ^ proxy defining encoding annotation - -> (Proxy s -> Either err1 enc) -- ^ finds encoding marker @enc@ for given annotation or fails - -> (enc -> str -> Either err2 a) -- ^ decoder based on @enc@ marker - -> str -- ^ input - -> Either EncodeEx str -verifyDynEnc p findenc decoder str = - do - enc <- asEncodeEx p . findenc $ p - case decoder enc str of - Left err -> Left $ EncodeEx p err - Right r -> Right str diff --git a/src/Data/TypedEncoding/Internal/Types.hs b/src/Data/TypedEncoding/Internal/Types.hs deleted file mode 100644 --- a/src/Data/TypedEncoding/Internal/Types.hs +++ /dev/null @@ -1,109 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE AllowAmbiguousTypes #-} --- {-# LANGUAGE RankNTypes #-} - --- | --- Internal definition of types - -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 - -import Data.TypedEncoding.Internal.Types.Enc -import Data.TypedEncoding.Internal.Types.CheckedEnc -import Data.TypedEncoding.Internal.Types.UncheckedEnc -import Data.TypedEncoding.Internal.Types.Common - -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 - 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 - -instance Show EncodeEx where - show (EncodeEx prxy a) = "(EncodeEx \"" ++ symbolVal prxy ++ "\" (" ++ show a ++ "))" - -asEncodeEx :: (Show a, KnownSymbol x) => Proxy x -> Either a b -> Either EncodeEx b -asEncodeEx p = either (Left . EncodeEx p) Right - - --- | Useful when manually recreating using recovery -encToRecrEx :: EncodeEx -> RecreateEx -encToRecrEx (EncodeEx p a) = RecreateEx p a - -mergeEncodeEx :: KnownSymbol x => Proxy x -> EncodeEx -> Maybe EncodeEx -> EncodeEx -mergeEncodeEx _ ex Nothing = ex -mergeEncodeEx p (EncodeEx _ a) (Just (EncodeEx _ b)) = EncodeEx p $ "Errors: " ++ show (a,b) - -emptyEncErr :: KnownSymbol x => Proxy x -> EncodeEx -emptyEncErr p = EncodeEx p ("unexpected" :: String) - --- | Type safety over encodings makes decoding process safe. --- However failures are still possible due to bugs or unsafe payload modifications. --- UnexpectedDecodeEx represents such errors. -data UnexpectedDecodeEx where - UnexpectedDecodeEx :: (Show a, KnownSymbol x) => Proxy x -> a -> UnexpectedDecodeEx - -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) - - -mergeErrs :: err -> (err -> Maybe err -> err) -> Either err a -> Either err b -> Either err c -mergeErrs _ fn (Left er1) (Left er2) = Left (fn er1 $ Just er2) -mergeErrs _ fn (Left er1) _ = Left (fn er1 Nothing) -mergeErrs _ fn _ (Left er2) = Left (fn er2 Nothing) -mergeErrs de fn (Right r) (Right y) = Left de diff --git a/src/Data/TypedEncoding/Internal/Types/CheckedEnc.hs b/src/Data/TypedEncoding/Internal/Types/CheckedEnc.hs deleted file mode 100644 --- a/src/Data/TypedEncoding/Internal/Types/CheckedEnc.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# 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 - diff --git a/src/Data/TypedEncoding/Internal/Types/Common.hs b/src/Data/TypedEncoding/Internal/Types/Common.hs deleted file mode 100644 --- a/src/Data/TypedEncoding/Internal/Types/Common.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Data.TypedEncoding.Internal.Types.Common where - --- | Represents value level (single) annotation. -type EncAnn = String diff --git a/src/Data/TypedEncoding/Internal/Types/Enc.hs b/src/Data/TypedEncoding/Internal/Types/Enc.hs deleted file mode 100644 --- a/src/Data/TypedEncoding/Internal/Types/Enc.hs +++ /dev/null @@ -1,97 +0,0 @@ -{-# 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' - -implChangeAnn :: Functor f => (Enc enc1 conf str -> f (Enc enc2a conf str)) -> Enc enc1 conf str -> f (Enc enc2b conf str) -implChangeAnn fn = fmap (withUnsafeCoerce id) . fn - - - -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) diff --git a/src/Data/TypedEncoding/Internal/Types/SomeAnnotation.hs b/src/Data/TypedEncoding/Internal/Types/SomeAnnotation.hs deleted file mode 100644 --- a/src/Data/TypedEncoding/Internal/Types/SomeAnnotation.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# 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 diff --git a/src/Data/TypedEncoding/Internal/Types/SomeEnc.hs b/src/Data/TypedEncoding/Internal/Types/SomeEnc.hs deleted file mode 100644 --- a/src/Data/TypedEncoding/Internal/Types/SomeEnc.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# 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 ++ ")" diff --git a/src/Data/TypedEncoding/Internal/Types/UncheckedEnc.hs b/src/Data/TypedEncoding/Internal/Types/UncheckedEnc.hs deleted file mode 100644 --- a/src/Data/TypedEncoding/Internal/Types/UncheckedEnc.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# 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 diff --git a/src/Data/TypedEncoding/Internal/Types/Unsafe.hs b/src/Data/TypedEncoding/Internal/Types/Unsafe.hs deleted file mode 100644 --- a/src/Data/TypedEncoding/Internal/Types/Unsafe.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# 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 - diff --git a/src/Data/TypedEncoding/Internal/Util/TypeLits.hs b/src/Data/TypedEncoding/Internal/Util/TypeLits.hs deleted file mode 100644 --- a/src/Data/TypedEncoding/Internal/Util/TypeLits.hs +++ /dev/null @@ -1,146 +0,0 @@ - - -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE AllowAmbiguousTypes #-} - - --- | TypeLits related utilities. --- --- Lots of this could be avoided by adding @singletons@ as dependency. --- --- Uses @symbols@ library for its ToList type family. --- --- Currently this is spread out in different modules --- --- * "Data.TypedEncoding.Internal.Class.Util" --- * "Data.TypedEncoding.Internal.Types.SomeAnnotation" --- --- (TODO) these will need to get consolidated. -module Data.TypedEncoding.Internal.Util.TypeLits where - -import GHC.TypeLits --- import Data.Symbol.Utils -import Data.Symbol.Ascii --- import Data.Proxy - --- $setup --- >>> :set -XScopedTypeVariables -XTypeFamilies -XKindSignatures -XDataKinds - -type family AcceptEq (msg :: ErrorMessage) (c :: Ordering) :: Bool where - AcceptEq _ EQ = True - AcceptEq msg _ = TypeError msg - -type family And (b1 :: Bool) (b2 :: Bool) :: Bool where - And 'True 'True = 'True - And _ _ = 'False - -type family Or (b1 :: Bool) (b2 :: Bool) :: Bool where - Or 'False 'False = 'False - Or _ _ = 'True - -type family Repeat (n :: Nat) (s :: Symbol) :: Symbol where - Repeat 0 s = "" - Repeat n s = AppendSymbol s (Repeat (n - 1) s) - -type family Fst (s :: (k,h)) :: k where - Fst ('(,) a _) = a - -type family Dupl (s :: k) :: (k,k) where - Dupl a = '(,) a a - --- | :kind! Concat (LDrop 6 (ToList "bool: \"r-ban:ff-ff\" | \"r-ban:ffff\"")) -type family Concat (s :: [Symbol]) :: Symbol where - Concat '[] = "" - Concat (x ': xs) = AppendSymbol x (Concat xs) - - -type family Drop (n :: Nat) (s :: Symbol) :: Symbol where - Drop n s = Concat (LDrop n (ToList s)) - --- TODO create TypeList.List module ? - --- | :kind! LDrop 6 (ToList "bool: \"r-ban:ff-ff\" | \"r-ban:ffff\"") -type family LDrop (n :: Nat) (s :: [k]) :: [k] where - LDrop 0 s = s - LDrop n '[] = '[] - LDrop n (x ': xs) = LDrop (n - 1) xs - - --- type family DropVerify (n :: Nat) (s :: Symbol) (v :: Symbol) :: Symbol where --- Drop n s v = Concat (LDrop n (ToList s)) - --- type family DropVerify (n :: Nat) (s :: Symbol) (v :: Symbol) :: Symbol where --- Drop n s v = Concat (LDrop n (ToList s)) - --- | --- :kind! Take 3 "123456" -type family Take (n :: Nat) (s :: Symbol) :: Symbol where - Take n s = Concat (LTake n (ToList s)) - --- | :kind! LTake 3 (ToList "123456") -type family LTake (n :: Nat) (s :: [k]) :: [k] where - LTake 0 s = '[] - LTake n '[] = '[] - LTake n (x ': xs) = x ': LTake (n - 1) xs - --- --- :kind! TakeUntil "findme:blah" ":" -type family TakeUntil (s :: Symbol) (stop :: Symbol) :: Symbol where - TakeUntil s stop = Concat (LTakeUntil (ToList s) stop) - -type family LTakeUntil (s :: [Symbol]) (stop :: Symbol) :: [Symbol] where - LTakeUntil '[] _ = '[] - LTakeUntil (x ': xs) stop = LTakeUntilHelper (x ': LTakeUntil xs stop) (CmpSymbol x stop) - -type family LTakeUntilHelper (s :: [Symbol]) (o :: Ordering) :: [Symbol] where - LTakeUntilHelper '[] _ = '[] - LTakeUntilHelper (x ': xs) 'EQ = '[] - LTakeUntilHelper (x ': xs) _ = (x ': xs) - - -type family Length (s :: Symbol) :: Nat where - Length x = LLengh (ToList x) - -type family LLengh (s :: [k]) :: Nat where - LLengh '[] = 0 - LLengh (x ': xs) = 1 + LLengh xs - - --- | --- >>> :kind! LLast '["1","2","3"] --- ... --- = "3" -type family LLast (s :: [Symbol]) :: Symbol where - LLast '[] = TypeError ('Text "Empty Symbol list not allowed") - LLast '[x] = x - LLast (_ ': xs) = LLast xs - - --- | --- Concat (Snoc '["1","2","3"] "4") --- ... --- = "1234" -type family Snoc (s :: [k]) (t :: k) :: [k] where - Snoc '[] x = '[x] - Snoc (x ': xs) y = x ': Snoc xs y - - --- | --- :kind! UnSnoc '["1","2","3"] -type family UnSnoc (s :: [k]) :: ([k], k) where - UnSnoc '[] = TypeError ('Text "Empty list, no last element") - UnSnoc '[x] = '(,) '[] x - UnSnoc (x ': xs) = UnSnocHelper x (UnSnoc xs) - - -type family UnSnocHelper (s :: k) (t :: ([k], k)) :: ([k], k) where - UnSnocHelper y ('(,) xs x) = '(,) (y ': xs) x diff --git a/src/Data/TypedEncoding/Unsafe.hs b/src/Data/TypedEncoding/Unsafe.hs --- a/src/Data/TypedEncoding/Unsafe.hs +++ b/src/Data/TypedEncoding/Unsafe.hs @@ -5,8 +5,8 @@ {-# LANGUAGE FlexibleInstances #-} module Data.TypedEncoding.Unsafe ( - module Data.TypedEncoding.Internal.Types.Unsafe + module Data.TypedEncoding.Common.Types.Unsafe ) where -import Data.TypedEncoding.Internal.Types.Unsafe +import Data.TypedEncoding.Common.Types.Unsafe diff --git a/src/Examples/TypedEncoding/Conversions.hs b/src/Examples/TypedEncoding/Conversions.hs --- a/src/Examples/TypedEncoding/Conversions.hs +++ b/src/Examples/TypedEncoding/Conversions.hs @@ -38,7 +38,7 @@ -- EncodeF SomeErr (Enc xs () Text) (Enc ("enc-B64" ': xs) () Text) -- @ -- --- Then @typed-encoding@ expects @pack@ @encodeF@ to commute: +-- Then @typed-encoding@ expects @pack@ @encodeF@ to commute (if encoding instances exist): -- -- @ -- str -- EncT.pack --> txt @@ -70,7 +70,7 @@ import GHC.TypeLits import qualified Data.TypedEncoding.Conv.ByteString.Char8 as EncB8 -import Data.TypedEncoding.Combinators.Restriction.BoundedAlphaNums () +import Data.TypedEncoding.Instances.Restriction.BoundedAlphaNums () -- $setup -- >>> :set -XDataKinds -XMultiParamTypeClasses -XKindSignatures -XFlexibleInstances -XFlexibleContexts -XOverloadedStrings -XTypeApplications -XScopedTypeVariables @@ -93,7 +93,7 @@ -- ^ Example value to play with -- -- >>> encodeFAll . toEncoding () $ "HeLlo world" :: Either EncodeEx (Enc '["r-ASCII"] () B.ByteString) --- Right (MkEnc Proxy () "HeLlo world") +-- Right (UnsafeMkEnc Proxy () "HeLlo world") Right helloAsciiB = eHelloAsciiB -- ^ above with either removed @@ -101,13 +101,13 @@ helloAsciiT :: Enc '["r-ASCII"] () T.Text helloAsciiT = EncTe.decodeUtf8 helloAsciiB -- ^ --- We use a tween function to the popular 'Data.Text.Encoding.decodeUtf8' +-- We use a tween function of the popular 'Data.Text.Encoding.decodeUtf8' -- from the @test@ package. -- -- Notice the encoding annotation is preserved. -- -- >>> displ $ EncTe.decodeUtf8 helloAsciiB --- "MkEnc '[r-ASCII] () (Text HeLlo world)" +-- "Enc '[r-ASCII] () (Text HeLlo world)" -- * pack and unpack @@ -117,7 +117,7 @@ -- ^ Consider 0-encoding of a 'String', to move it to @Enc '[] () String@ one could try: -- -- >>> displ . EncT.pack $ helloZero --- "MkEnc '[] () (Text Hello)" +-- "Enc '[] () (Text Hello)" -- -- this works, but: -- @@ -133,19 +133,19 @@ -- -- @EncB8.pack@ will not compile unless the encoding is ASCII restricted, this works: -- --- >>> fmap (displ . EncB8.pack) . encodeFAll @(Either EncodeEx) @'["r-ASCII"] $ helloZero --- Right "MkEnc '[r-ASCII] () (ByteString Hello)" +-- >>> fmap (displ . EncB8.pack) . encodeFAll @'["r-ASCII"] @(Either EncodeEx) $ helloZero +-- Right "Enc '[r-ASCII] () (ByteString Hello)" -- -- And the result is a @ByteString@ with bonus annotation describing its content. helloRestricted :: Either EncodeEx (Enc '["r-ban:zzzzz"] () B.ByteString) -helloRestricted = fmap EncB8.pack . runEncoder @'["r-ban"] encodings $ toEncoding () "Hello" --- ^ more interstingly @EncB8.pack@ works fine on "r-" encodings that are subsets of "r-ASCII" --- this example @"r-ban:zzzzz"@ restricts to 5 alapha-numeric charters all < @'z'@ +helloRestricted = fmap EncB8.pack . _runEncodings encodings $ toEncoding () "Hello" +-- ^ more interestingly @EncB8.pack@ works fine on "r-" encodings that are subsets of "r-ASCII" +-- this example @"r-ban:zzzzz"@ restricts to 5 alpha-numeric charters all < @\'z\'@ -- -- >>> displ <$> helloRestricted --- Right "MkEnc '[r-ban:zzzzz] () (ByteString Hello)" +-- Right "Enc '[r-ban:zzzzz] () (ByteString Hello)" -- -- Adding @"r-ASCII"@ annotation on this ByteString would have been redundant since @"r-ban:zzzzz"@ is more -- restrictive (see Supersets below). @@ -153,54 +153,30 @@ -- @unpack@, as expected will put us back in a String keeping the annotation -- -- >>> fmap (displ . EncB8.unpack) helloRestricted --- Right "MkEnc '[r-ban:zzzzz] () Hello" +-- Right "Enc '[r-ban:zzzzz] () (String Hello)" -- --- * Supersets - -helloUtf8B :: Enc '["r-UTF8"] () B.ByteString -helloUtf8B = injectInto helloAsciiB --- ^ To get UTF8 annotation, instead of doing this: --- --- >>> encodeFAll . toEncoding () $ "HeLlo world" :: Either EncodeEx (Enc '["r-UTF8"] () B.ByteString) --- Right (MkEnc Proxy () "HeLlo world") --- --- We should be able to convert the ASCII version we already have. --- --- This is done using 'Superset' typeclass. --- --- @injectInto@ method accepts proxy to specify superset to use. --- --- >>> displ $ injectInto @ "r-UTF8" helloAsciiB --- "MkEnc '[r-UTF8] () (ByteString HeLlo world)" --- --- Superset is intended for @"r-"@ annotations only, should not be used --- with general encodings like @"enc-B64"@, it assumes that decoding in the superset --- can replace the decoding from injected subset. - - - -- * More complex rules helloUtf8B64B :: Enc '["enc-B64", "r-UTF8"] () B.ByteString helloUtf8B64B = encodePart @'["enc-B64"] helloUtf8B --- ^ We put Base64 on a ByteString which adheres to UTF8 layout +-- ^ We Base64 encode a ByteString which adheres to UTF8 layout -- --- >>> displ $ encodePart_ (Proxy :: Proxy '["enc-B64"]) helloUtf8B --- "MkEnc '[enc-B64,r-UTF8] () (ByteString SGVMbG8gd29ybGQ=)" +-- >>> displ $ encodePart @'["enc-B64"] helloUtf8B +-- "Enc '[enc-B64,r-UTF8] () (ByteString SGVMbG8gd29ybGQ=)" helloUtf8B64T :: Enc '["enc-B64"] () T.Text helloUtf8B64T = EncT.utf8Demote . EncTe.decodeUtf8 $ helloUtf8B64B -- ^ .. and copy it over to Text. -- -- >>> displ $ EncTe.decodeUtf8 helloUtf8B64B --- "MkEnc '[enc-B64,r-UTF8] () (Text SGVMbG8gd29ybGQ=)" +-- "Enc '[enc-B64,r-UTF8] () (Text SGVMbG8gd29ybGQ=)" -- -- but UTF8 would be redundant in Text so the "r-UTF8" can be dropped: -- -- >>> displ . EncT.utf8Demote . EncTe.decodeUtf8 $ helloUtf8B64B --- "MkEnc '[enc-B64] () (Text SGVMbG8gd29ybGQ=)" +-- "Enc '[enc-B64] () (Text SGVMbG8gd29ybGQ=)" -- -- Conversely moving back to ByteString we need to recover the annotation -- @@ -213,7 +189,7 @@ -- This is not allowed! We need to add the redundant "r-UTF8" back: -- -- >>> displ . EncTe.encodeUtf8 . EncT.utf8Promote $ helloUtf8B64T --- "MkEnc '[enc-B64,r-UTF8] () (ByteString SGVMbG8gd29ybGQ=)" +-- "Enc '[enc-B64,r-UTF8] () (ByteString SGVMbG8gd29ybGQ=)" -- -- To achieve type safety, our @encodeUtf8@ and @decodeUtf8@ require "r-UTF8" annotation. -- But since @Text@ values can always emit @UTF8@ layout, we can simply add and remove @@ -224,7 +200,7 @@ -- ^ 'notTextB' a binary, one that does not even represent a valid UTF8. -- -- >>> encodeAll . toEncoding () $ "\195\177" :: Enc '["enc-B64"] () B.ByteString --- MkEnc Proxy () "w7E=" +-- UnsafeMkEnc Proxy () "w7E=" -- -- Decoding it to Text is prevented by the compiler -- @@ -242,13 +218,60 @@ -- This can be done, for example, using flattening (see below). +-- * Supersets + +helloUtf8B :: Enc '["r-UTF8"] () B.ByteString +helloUtf8B = injectInto helloAsciiB +-- ^ To claim UTF8 on @helloAsciiB@, instead encoding again: +-- +-- >>> encodeFAll . toEncoding () $ "HeLlo world" :: Either EncodeEx (Enc '["r-UTF8"] () B.ByteString) +-- Right (UnsafeMkEnc Proxy () "HeLlo world") +-- +-- We should be able to convert the ASCII annotation directly. +-- +-- This is done using 'IsSuperset' type family. +-- +-- @injectInto@ method accepts proxy to specify superset to use. +-- +-- >>> displ $ injectInto @ "r-UTF8" helloAsciiB +-- "Enc '[r-UTF8] () (ByteString HeLlo world)" +-- +-- Superset is intended for @"r-"@ annotations only, should not be used +-- with general encodings like @"enc-B64"@, it assumes that decoding in the superset +-- can replace the decoding from injected subset. + + +notTextBB64Ascii :: Enc '["r-ASCII", "enc-B64"] () B.ByteString +notTextBB64Ascii = _encodesInto notTextB +-- ^ /Base64/ encoding represents binary data in an ASCII string format. +-- +-- In Haskell, we should be able to express this in types. +-- +-- 'EncodingSuperset' class is what specifies this. +-- +-- We can use it with '_encodesInto' combinator. +-- 'EncodingSuperset' should not be used directly at the calling site. +-- +-- >>> displ (_encodesInto @"r-ASCII" $ notTextB) +-- "Enc '[r-ASCII,enc-B64] () (ByteString w7E=)" +-- +-- '_encodesInto' can be used with a superset of the encoding +-- character set as well making it more backward compatible +-- (the definition of @EncodingSuperset "enc-B64" could be made more precise without breaking the code). +-- +-- >>> displ (_encodesInto @"r-UTF8" $ notTextB) +-- "Enc '[r-UTF8,enc-B64] () (ByteString w7E=)" +-- + + + -- * Lenient recovery lenientSomething :: Enc '["enc-B64-len"] () B.ByteString lenientSomething = recreateAll . toEncoding () $ "abc==CB" -- ^ -- >>> recreateAll . toEncoding () $ "abc==CB" :: Enc '["enc-B64-len"] () B.ByteString --- MkEnc Proxy () "abc==CB" +-- UnsafeMkEnc Proxy () "abc==CB" -- -- The rest of Haskell does lenient decoding, type safety allows this library to use it for recovery. -- lenient algorithms are not partial and automatically fix invalid input: @@ -261,17 +284,17 @@ -- 'EnB64.acceptLenientS' allows to convert "enc-B64-len" to "enc-B64" -- -- >>> displ $ EnB64.acceptLenientS lenientSomething --- "MkEnc '[enc-B64] () (ByteString abc=)" +-- "Enc '[enc-B64] () (ByteString abc=)" -- -- This is now properly encoded data -- -- >>> recreateFAll . toEncoding () $ "abc=" :: Either RecreateEx (Enc '["enc-B64"] () B.ByteString) --- Right (MkEnc Proxy () "abc=") +-- Right (UnsafeMkEnc Proxy () "abc=") -- -- Except the content could be surprising -- -- >>> decodeAll $ EnB64.acceptLenientS lenientSomething --- MkEnc Proxy () "i\183" +-- UnsafeMkEnc Proxy () "i\183" -- * Flattening diff --git a/src/Examples/TypedEncoding/DiySignEncoding.hs b/src/Examples/TypedEncoding/DiySignEncoding.hs --- a/src/Examples/TypedEncoding/DiySignEncoding.hs +++ b/src/Examples/TypedEncoding/DiySignEncoding.hs @@ -19,7 +19,7 @@ -- Decoding cannot fail unless somehow underlying data has been corrupted. -- -- Such integrity of data should be enforced at boundaries --- (JSON instances, DB retrievals, etc). This can be accomplished using provided 'RecreateF' typeclass. +-- (JSON instances, DB retrievals, etc). This can be accomplished using provided support for /Validation/ or using 'Data.TypedEncoding.Common.Types.UncheckedEnc.UncheckedEnc'. -- -- This still is user decision, the errors during decoding process are considered unexpected 'UnexpectedDecodeErr'. -- In particular user can decide to use unsafe operations with the encoded type. See 'Examples.TypedEncoding.Unsafe'. @@ -66,7 +66,7 @@ -- | Encoded hello world example. -- -- >>> helloSigned --- MkEnc Proxy () "11:Hello World" +-- UnsafeMkEnc Proxy () "11:Hello World" -- -- >>> fromEncoding . decodeAll $ helloSigned -- "Hello World" @@ -99,23 +99,27 @@ -- Left (RecreateEx "my-sign" ("Corrupted Signature")) -- -- >>> recreateFAll . toEncoding () $ payload :: Either RecreateEx (Enc '["my-sign"] () T.Text) --- Right (MkEnc Proxy () "11:Hello World") +-- Right (UnsafeMkEnc Proxy () "11:Hello World") -- | Because encoding function is pure we can create instance of EncodeF -- that is polymorphic in effect @f@. This is done using 'EnT.implTranP' combinator. -instance Applicative f => EncodeF f (Enc xs c T.Text) (Enc ("my-sign" ': xs) c T.Text) where - encodeF = EnT.implEncodeP encodeSign +instance Applicative f => Encode f "my-sign" "my-sign" c T.Text where + encoding = EnT._implEncodingP encodeSign -- | Decoding allows effectful @f@ to allow for troubleshooting and unsafe payload changes. -- --- Implementation simply uses 'EnT.implDecodeF' combinator on the 'asUnexpected' composed with decoding function. +-- Implementation simply uses 'EnT.implDecodingF' combinator on the 'asUnexpected' composed with decoding function. -- '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 @"my-sign" . decodeSign) +instance (UnexpectedDecodeErr f, Applicative f) => Decode f "my-sign" "my-sign" c T.Text where + decoding = decMySign +decMySign :: (UnexpectedDecodeErr f, Applicative f) => Decoding f "my-sign" "my-sign" c T.Text +decMySign = EnT.implDecodingF (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 @"my-sign" . decodeSign) +-- Implementation simply uses 'EnT.validFromDec' combinator on the recovery function. +instance (RecreateErr f, Applicative f) => Validate f "my-sign" "my-sign" c T.Text where + validation = EnT.validFromDec decMySign + diff --git a/src/Examples/TypedEncoding/Overview.hs b/src/Examples/TypedEncoding/Overview.hs --- a/src/Examples/TypedEncoding/Overview.hs +++ b/src/Examples/TypedEncoding/Overview.hs @@ -32,6 +32,7 @@ -- $setup -- >>> :set -XOverloadedStrings -XMultiParamTypeClasses -XDataKinds -XTypeApplications +-- >>> import Data.Functor.Identity -- -- This module contains some ghci friendly values to play with. -- @@ -43,23 +44,38 @@ -- | "Hello World" encoded as Base64 -- -- >>> helloB64 --- MkEnc Proxy () "SGVsbG8gV29ybGQ=" +-- UnsafeMkEnc Proxy () "SGVsbG8gV29ybGQ=" -- -- >>> displ helloB64 --- "MkEnc '[enc-B64] () (ByteString SGVsbG8gV29ybGQ=)" +-- "Enc '[enc-B64] () (ByteString SGVsbG8gV29ybGQ=)" -- -- >>> encodeAll . toEncoding () $ "Hello World" :: Enc '["enc-B64"] () B.ByteString --- MkEnc Proxy () "SGVsbG8gV29ybGQ=" --- --- There is currently an alternative polymorphic way (prototype) to create encodings by /running/ 'Encoder' on 'encodings'. --- This approach works better with more open / dynamic encoding setup it also provides first class @Encoder@. --- In future versions encodeAll will either be improved to provide similar flexibility or will be deprecated and removed. --- --- >>> displ <$> (runEncoder @'["enc-B64"] encodings $ toEncoding () "Hello" :: Either EncodeEx (Enc '["enc-B64"] () B.ByteString)) --- Right "MkEnc '[enc-B64] () (ByteString SGVsbG8=)" +-- UnsafeMkEnc Proxy () "SGVsbG8gV29ybGQ=" helloB64 :: Enc '["enc-B64"] () B.ByteString helloB64 = encodeAll . toEncoding () $ "Hello World" +-- | "Hello World" double-Base64 encoded. +-- Notice the same code used as in single encoding, the game is played at type level. +-- +-- >>> encodeAll . toEncoding () $ "Hello World" :: Enc '["enc-B64","enc-B64"] () B.ByteString +-- UnsafeMkEnc Proxy () "U0dWc2JHOGdWMjl5YkdRPQ==" +-- +-- >>> displ helloB64B64 +-- "Enc '[enc-B64,enc-B64] () (ByteString U0dWc2JHOGdWMjl5YkdRPQ==)" +-- +-- An alternative version of the above code is this: +-- +-- >>> fmap displ . runEncodings' @'["enc-B64","enc-B64"] @'["enc-B64","enc-B64"] @Identity encodings . toEncoding () $ ("Hello World" :: B.ByteString) +-- Identity "Enc '[enc-B64,enc-B64] () (ByteString U0dWc2JHOGdWMjl5YkdRPQ==)" +-- +-- This is how @typed-encoding@ works, the "Data.TypedEncoding.Common.Class.Encode.EncodeAll" +-- constraint can be used to get access to list to encodings required by the symbol annotation. +-- 'runEncodings'' executes all the necessary transformations. +-- +-- Similar story is true for /decoding/ and /validation/. In these examples we will use shortcut combinators. +helloB64B64 :: Enc '["enc-B64","enc-B64"] () B.ByteString +helloB64B64 = encodeAll . toEncoding () $ "Hello World" + -- | Previous text decoded from Base64 -- -- >>> fromEncoding . decodeAll $ helloB64 @@ -71,7 +87,7 @@ -- It makes sure that the content satisfies specified encodings. -- -- >>> recreateFAll . toEncoding () $ "SGVsbG8gV29ybGQ=" :: Either RecreateEx (Enc '["enc-B64"] () B.ByteString) --- Right (MkEnc Proxy () "SGVsbG8gV29ybGQ=") +-- Right (UnsafeMkEnc Proxy () "SGVsbG8gV29ybGQ=") -- -- >>> recreateFAll . toEncoding () $ "SGVsbG8gV29ybGQ" :: Either RecreateEx (Enc '["enc-B64"] () B.ByteString) -- Left (RecreateEx "enc-B64" ("invalid padding")) @@ -86,29 +102,24 @@ -- 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=")) +-- >>> check @'["enc-B64"] @(Either RecreateEx) unchecked +-- Just (Right (UnsafeMkEnc Proxy () "SGVsbG8gV29ybGQ=")) helloB64Recovered :: Either RecreateEx (Enc '["enc-B64"] () B.ByteString) helloB64Recovered = recreateFAll . toEncoding () $ "SGVsbG8gV29ybGQ=" --- | "Hello World" double-Base64 encoded. --- Notice the same code used as in single encoding, the game is played at type level. --- --- >>> encodeAll . toEncoding () $ "Hello World" :: Enc '["enc-B64","enc-B64"] () B.ByteString --- MkEnc Proxy () "U0dWc2JHOGdWMjl5YkdRPQ==" --- --- >>> displ helloB64B64 --- "MkEnc '[enc-B64,enc-B64] () (ByteString U0dWc2JHOGdWMjl5YkdRPQ==)" -helloB64B64 :: Enc '["enc-B64","enc-B64"] () B.ByteString -helloB64B64 = encodeAll . toEncoding () $ "Hello World" -- | Double Base64 encoded "Hello World" with one layer of encoding removed -- -- >>> decodePart @'["enc-B64"] $ helloB64B64 :: Enc '["enc-B64"] () B.ByteString --- MkEnc Proxy () "SGVsbG8gV29ybGQ=" +-- UnsafeMkEnc Proxy () "SGVsbG8gV29ybGQ=" -- -- >>> helloB64B64PartDecode == helloB64 -- True +-- +-- @decodePart@ is a convenience function that simply replies decoding 'above' first "enc-B64" +-- +-- >>> above @'["enc-B64"] @'["enc-B64"] @'[] decodeAll $ helloB64B64 +-- UnsafeMkEnc Proxy () "SGVsbG8gV29ybGQ=" helloB64B64PartDecode :: Enc '["enc-B64"] () B.ByteString helloB64B64PartDecode = decodePart @'["enc-B64"] helloB64B64 @@ -148,14 +159,14 @@ -- The same code is used as in "enc-" examples to encode (now transform). -- -- >>> encodeAll . toEncoding () $ "Hello World" :: Enc '["do-UPPER"] () T.Text --- MkEnc Proxy () "HELLO WORLD" +-- UnsafeMkEnc Proxy () "HELLO WORLD" helloUPP :: Enc '["do-UPPER"] () T.Text helloUPP = encodeAll . toEncoding () $ "Hello World" -- | Sample compound transformation -- -- >>> encodeAll . toEncoding () $ "HeLLo world" :: Enc '["do-reverse", "do-Title"] () T.Text --- MkEnc Proxy () "dlroW olleH" +-- UnsafeMkEnc Proxy () "dlroW olleH" helloTitleRev :: Enc '["do-reverse", "do-Title"] () T.Text helloTitleRev = encodeAll . toEncoding () $ "HeLLo world" @@ -184,27 +195,32 @@ -- configuration we can also do this: -- -- >>> encodeAll . toEncoding exampleConf $ "HeLLo world" :: Enc '["do-reverse", "do-Title"] Config T.Text --- MkEnc Proxy (Config {sizeLimit = SizeLimit {unSizeLimit = 8}}) "dlroW olleH" +-- UnsafeMkEnc Proxy (Config {sizeLimit = SizeLimit {unSizeLimit = 8}}) "dlroW olleH" -- -- >>> encodeAll . toEncoding exampleConf $ "HeLlo world" :: Enc '["do-size-limit", "do-reverse", "do-Title"] Config T.Text --- MkEnc Proxy (Config {sizeLimit = SizeLimit {unSizeLimit = 8}}) "dlroW ol" +-- UnsafeMkEnc Proxy (Config {sizeLimit = SizeLimit {unSizeLimit = 8}}) "dlroW ol" -- -- Instead, encode previously defined 'helloTitle' by reversing it and adding size limit -- -- >>> 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" +-- UnsafeMkEnc Proxy (Config {sizeLimit = SizeLimit {unSizeLimit = 8}}) "dlroW ol" +-- +-- @encodePart@ is simply encodeAll played above "do-Title" encoding: +-- +-- >>> above @'["do-Title"] @'[] @'["do-size-limit", "do-reverse"] encodeAll helloTitle +-- UnsafeMkEnc Proxy (Config {sizeLimit = SizeLimit {unSizeLimit = 8}}) "dlroW ol" helloRevLimit :: Enc '["do-size-limit", "do-reverse", "do-Title"] Config T.Text 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=" +-- UnsafeMkEnc Proxy (Config {sizeLimit = SizeLimit {unSizeLimit = 8}}) "SGVMbG8gd28=" helloLimitB64 :: Enc '["enc-B64", "do-size-limit"] Config B.ByteString helloLimitB64 = encodeAll . toEncoding exampleConf $ "HeLlo world" -- | ... and we unwrap the B64 part only -- -- >>> decodePart @'["enc-B64"] $ helloLimitB64 --- MkEnc Proxy (Config {sizeLimit = SizeLimit {unSizeLimit = 8}}) "HeLlo wo" +-- UnsafeMkEnc Proxy (Config {sizeLimit = SizeLimit {unSizeLimit = 8}}) "HeLlo wo" helloRevLimitParDec :: Enc '["do-size-limit"] Config B.ByteString helloRevLimitParDec = decodePart @'["enc-B64"] helloLimitB64 @@ -224,7 +240,7 @@ -- Note naming thing: "r-" is partial identity ("r-" is from restriction). -- -- >>> encodeFAll . toEncoding () $ "HeLlo world" :: Either EncodeEx (Enc '["r-ASCII"] () B.ByteString) --- Right (MkEnc Proxy () "HeLlo world") +-- Right (UnsafeMkEnc Proxy () "HeLlo world") helloAscii :: Either EncodeEx (Enc '["r-ASCII"] () B.ByteString) helloAscii = encodeFAll . toEncoding () $ "HeLlo world" @@ -232,12 +248,12 @@ -- a better version is here: -- -- >>> encodeFAll . toEncoding () $ "Hello World" :: Either EncodeEx (Enc '["enc-B64", "r-ASCII"] () B.ByteString) --- Right (MkEnc Proxy () "SGVsbG8gV29ybGQ=") +-- Right (UnsafeMkEnc Proxy () "SGVsbG8gV29ybGQ=") helloAsciiB64 :: Either EncodeEx (Enc '["enc-B64", "r-ASCII"] () B.ByteString) helloAsciiB64 = encodeFAll . toEncoding () $ "Hello World" -- | -- >>> decodePart @'["enc-B64"] <$> helloAsciiB64 --- Right (MkEnc Proxy () "Hello World") +-- Right (UnsafeMkEnc Proxy () "Hello World") helloAsciiB64PartDec :: Either EncodeEx (Enc '["r-ASCII"] () B.ByteString) helloAsciiB64PartDec = decodePart @'["enc-B64"] <$> helloAsciiB64 diff --git a/src/Examples/TypedEncoding/ToEncString.hs b/src/Examples/TypedEncoding/ToEncString.hs --- a/src/Examples/TypedEncoding/ToEncString.hs +++ b/src/Examples/TypedEncoding/ToEncString.hs @@ -36,8 +36,7 @@ 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.Restriction.Misc () import Data.TypedEncoding.Instances.Enc.Base64 () import Data.TypedEncoding.Instances.Restriction.ASCII () import Data.TypedEncoding.Instances.Restriction.UTF8 () @@ -81,10 +80,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" +-- in "Data.TypedEncoding.Instances.Restriction.Misc" -- --- >>> toEncString @"r-IPv4" @T.Text tstIp --- MkEnc Proxy () "128.1.1.10" +-- >>> toEncString @"r-IPv4" @IpV4 @T.Text tstIp +-- UnsafeMkEnc Proxy () "128.1.1.10" -- -- Implementation is a classic map reduce where reduce is done with help of -- 'EnT.foldEncStr' @@ -92,7 +91,7 @@ -- >>> 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" +-- "Enc '[r-IPv4] () (String 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. @@ -107,8 +106,8 @@ -- @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 +instance ToEncString Identity "r-IPv4" "r-IPv4" IpV4 T.Text where + toEncF = Identity . reduce . map where map :: IpV4F Word8 -> IpV4F (Enc '["r-Word8-decimal"] () T.Text) map = fmap toEncString @@ -117,23 +116,23 @@ -- | -- --- >>> let enc = toEncString @"r-IPv4" @T.Text tstIp --- >>> fromEncString @IpV4 enc +-- >>> let enc = toEncString @"r-IPv4" @IpV4 @T.Text tstIp +-- >>> fromEncString @"r-IPv4" @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"] +-- [UnsafeMkEnc Proxy () "128",UnsafeMkEnc Proxy () "1",UnsafeMkEnc Proxy () "1",UnsafeMkEnc 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 +instance (UnexpectedDecodeErr f, Applicative f) => FromEncString f "r-IPv4" "r-IPv4" IpV4 T.Text where + fromEncF = 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 ".") @@ -205,10 +204,10 @@ -- -- We can play 'Alternative' ('<|>') game (we acually use @Maybe@) with final option being a 'RecreateEx' error: -- --- >>> verifyUncheckedEnc' @'["enc-B64","r-ASCII"] $ unchecked +-- >>> check @'["enc-B64","r-ASCII"] @(Either RecreateEx) $ unchecked -- Nothing --- >>> verifyUncheckedEnc' @'["enc-B64","r-UTF8"] $ unchecked --- Just (Right (MkEnc Proxy () "U29tZSBVVEY4IFRleHQ=")) +-- >>> check @'["enc-B64","r-UTF8"] @(Either RecreateEx) $ unchecked +-- Just (Right (UnsafeMkEnc Proxy () "U29tZSBVVEY4IFRleHQ=")) -- -- Since the data is heterogeneous (each piece has a different encoding annotation), we need wrap the result in another plain ADT: 'CheckedEnc'. -- @@ -236,11 +235,11 @@ 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 + try1 = fmap (fmap toCheckedEnc) . check @'["enc-B64","r-UTF8"] . unchecked + try2 = fmap (fmap toCheckedEnc) . check @'["enc-B64","r-ASCII"] . unchecked + try3 = fmap (fmap toCheckedEnc) . check @'["r-ASCII"] . unchecked + try4 = fmap (fmap toCheckedEnc) . check @'["r-UTF8"] . unchecked + try5 = fmap (fmap toCheckedEnc) . check @'["enc-B64"] . unchecked def = Left $ recreateErrUnknown ("Invalid Header " ++ show parth) @@ -251,7 +250,7 @@ -- (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"]}) +-- Right (SimplifiedEmailF {emailHeader = "Some Header", parts = [UnsafeMkCheckedEnc ["enc-B64"] () "U29tZSBBU0NJSSBUZXh0",UnsafeMkCheckedEnc ["r-ASCII"] () "Some ASCII Text",UnsafeMkCheckedEnc ["r-UTF8"] () "Some UTF8 Text",UnsafeMkCheckedEnc ["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. @@ -262,7 +261,7 @@ -- -- >>> let piece = unsafeCheckedEnc ["enc-B64","r-ASCII"] () ("U29tZSBBU0NJSSBUZXh0" :: B.ByteString) -- >>> displ piece --- "MkCheckedEnc [enc-B64,r-ASCII] () (ByteString U29tZSBBU0NJSSBUZXh0)" +-- "UnsafeMkCheckedEnc [enc-B64,r-ASCII] () (ByteString U29tZSBBU0NJSSBUZXh0)" -- -- This code will not pick it up: -- @@ -272,12 +271,12 @@ -- But this one will: -- -- >>> fromCheckedEnc @ '["enc-B64", "r-ASCII"] $ piece --- Just (MkEnc Proxy () "U29tZSBBU0NJSSBUZXh0") +-- Just (UnsafeMkEnc 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") +-- Just (UnsafeMkCheckedEnc ["r-ASCII"] () "Some ASCII Text") decodeB64ForTextOnly :: SimplifiedEmailEncB -> SimplifiedEmailEncB decodeB64ForTextOnly = fmap (runAlternatives fromMaybe [tryUtf8, tryAscii]) diff --git a/src/Examples/TypedEncoding/Unsafe.hs b/src/Examples/TypedEncoding/Unsafe.hs --- a/src/Examples/TypedEncoding/Unsafe.hs +++ b/src/Examples/TypedEncoding/Unsafe.hs @@ -41,7 +41,7 @@ -- >>> let payload = getPayload exAsciiT -- >>> let newPayload = payload <> " some extra stuff" -- >>> recreateFAll . toEncoding () $ newPayload :: Either RecreateEx (Enc '["r-ASCII"] () T.Text) --- Right (MkEnc Proxy () "HELLO some extra stuff") +-- Right (UnsafeMkEnc Proxy () "HELLO some extra stuff") -- -- Alternatively, 'UncheckedEnc' type can be used in recreation, see 'Examples.TypedEncoding.Overview' -- @@ -58,9 +58,9 @@ -- the internal payload. -- -- >>> exAsciiTE --- Right (MkEnc Proxy () "HELLO") +-- Right (UnsafeMkEnc Proxy () "HELLO") -- >>> exAsciiTE >>= pure . Unsafe.withUnsafe (fmap T.toLower) --- Right (MkEnc Proxy () "hello") +-- Right (UnsafeMkEnc Proxy () "hello") -- -- Example uses of 'T.toLower' within encoded data -- this operation is safe for ASCII restriction @@ -75,7 +75,7 @@ -- >>> let Right hELLO = exAsciiTE -- >>> let Right hello = toLowerAscii -- >>> displ $ Unsafe.runUnsafe ((<>) <$> Unsafe.Unsafe hELLO <*> Unsafe.Unsafe hello) --- "MkEnc '[r-ASCII] () (Text HELLOhello)" +-- "Enc '[r-ASCII] () (Text HELLOhello)" appendAscii :: Either EncodeEx (Enc '["r-ASCII"] () T.Text) appendAscii = do hELLO <- exAsciiTE diff --git a/test/Test/Bc/ASCIISpec.hs b/test/Test/Bc/ASCIISpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Bc/ASCIISpec.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fwarn-unused-imports #-} + +-- | Verified backward compatibility of ASCII encoder changes in v0.3 +module Test.Bc.ASCIISpec where + +import qualified Data.TypedEncoding.Instances.Restriction.ASCII as ASCII +import Data.TypedEncoding.Common.Class.Util.StringConstraints + +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.List as L + +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy.Char8 as BL8 + +import Data.Char +import Control.Arrow + +import Test.QuickCheck.Instances.ByteString () +import Test.QuickCheck.Instances.Text () +import Test.QuickCheck +import Test.QuickCheck.Property +import Test.Hspec + + +equivalProperty :: Eq str => (str -> Either NonAsciiChar str) -> (str -> Either NonAsciiChar str) -> str -> Property +equivalProperty alg1 alg2 str = property $ liftBool (alg1 str == alg2 str) + +forwardCompatible :: (Char8Find str, Eq str) => (str -> Either NonAsciiChar str) -> str -> Property +forwardCompatible = equivalProperty newImpl + + +type NonAsciiChar = ASCII.NonAsciiChar + + +oldImplS = oldEncodeImpl L.partition L.head L.null +oldImplT = oldEncodeImpl T.partition T.head T.null +oldImplTL = oldEncodeImpl TL.partition TL.head TL.null +oldImplB = oldEncodeImpl (\p -> B8.filter p &&& B8.filter (not . p)) B8.head B8.null +oldImplBL = oldEncodeImpl (\p -> BL8.filter p &&& BL8.filter (not . p)) BL8.head BL8.null + + +newImpl :: Char8Find str => str -> Either NonAsciiChar str +newImpl = ASCII.encImpl + +oldEncodeImpl :: + ((Char -> Bool) -> a -> (a, a)) + -> (a -> Char) + -> (a -> Bool) + -> a + -> Either NonAsciiChar a +oldEncodeImpl partitionf headf nullf t = + let (tascii, nonascii) = partitionf isAscii t + in if nullf nonascii + then Right tascii + else Left . ASCII.NonAsciiChar $ headf nonascii + +spec :: Spec +spec = + describe "ASCII backward compapatibilty check" $ do + it "String" $ property $ forwardCompatible oldImplS + it "Text" $ property $ forwardCompatible oldImplT + it "Lazy.Text" $ property $ forwardCompatible oldImplTL + it "ByteString" $ property $ forwardCompatible oldImplB + it "Lazy.ByteString" $ property $ forwardCompatible oldImplBL + +runSpec :: IO () +runSpec = hspec spec diff --git a/test/Test/Bc/IsStringRSpec.hs b/test/Test/Bc/IsStringRSpec.hs --- a/test/Test/Bc/IsStringRSpec.hs +++ b/test/Test/Bc/IsStringRSpec.hs @@ -29,9 +29,8 @@ import Data.Word import Data.Either import Data.TypedEncoding -import Data.TypedEncoding.Internal.Class.IsStringR -import Data.TypedEncoding.Instances.Restriction.Common () -import Data.TypedEncoding.Instances.ToEncString.Common () +import Data.TypedEncoding.Common.Class.IsStringR +import Data.TypedEncoding.Instances.Restriction.Misc () newtype MyStr = MyStr String deriving (Eq, Show) @@ -63,13 +62,13 @@ it "Word8 fromEncString err works" $ fromEncStringTestErr `shouldSatisfy` isLeft it "EncodeF works" $ - (encodeFAll @(Either EncodeEx) @'["r-Word8-decimal"] . toEncoding () $ tstWord8) `shouldSatisfy` isRight + (encodeFAll @'["r-Word8-decimal"] @(Either EncodeEx) . toEncoding () $ tstWord8) `shouldSatisfy` isRight it "EncodeF err works" $ - (encodeFAll @(Either EncodeEx) @'["r-Word8-decimal"] . toEncoding () $ tstNotWord8') `shouldSatisfy` isLeft + (encodeFAll @'["r-Word8-decimal"] @(Either EncodeEx). toEncoding () $ tstNotWord8') `shouldSatisfy` isLeft it "RecreateF works" $ - (recreateFAll @(Either RecreateEx) @'["r-Word8-decimal"] . toEncoding () $ tstWord8) `shouldSatisfy` isRight + (recreateFAll @'["r-Word8-decimal"] @(Either RecreateEx) . toEncoding () $ tstWord8) `shouldSatisfy` isRight it "RecreateF err works" $ - (recreateFAll @(Either RecreateEx) @'["r-Word8-decimal"] . toEncoding () $ tstNotWord8) `shouldSatisfy` isLeft + (recreateFAll @'["r-Word8-decimal"] @(Either RecreateEx) . toEncoding () $ tstNotWord8) `shouldSatisfy` isLeft it "DecodeF works" $ (fromEncoding . decodeAll $ tstWord8Enc) `shouldBe` tstWord8 diff --git a/typed-encoding.cabal b/typed-encoding.cabal --- a/typed-encoding.cabal +++ b/typed-encoding.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 2bc32a22f6f7e7c49333ee187e608cb1c101c6711ae2fa7e0ee92c5d524e97ed +-- hash: f053eb403362652b43e8d0680f5e3a36c5eff26bb2f32fe383f0ab4612ba3c0f name: typed-encoding -version: 0.2.2.0 +version: 0.3.0.0 synopsis: Type safe string transformations description: See README.md in the project github repository. category: Data, Text @@ -30,9 +30,34 @@ library exposed-modules: Data.TypedEncoding - Data.TypedEncoding.Combinators.Restriction.Bool - Data.TypedEncoding.Combinators.Restriction.BoundedAlphaNums - Data.TypedEncoding.Combinators.Restriction.Common + Data.TypedEncoding.Combinators.Common + Data.TypedEncoding.Combinators.Decode + Data.TypedEncoding.Combinators.Encode + Data.TypedEncoding.Combinators.Encode.Experimental + Data.TypedEncoding.Combinators.Promotion + Data.TypedEncoding.Combinators.ToEncStr + Data.TypedEncoding.Combinators.Unsafe + Data.TypedEncoding.Combinators.Validate + Data.TypedEncoding.Common.Class + Data.TypedEncoding.Common.Class.Decode + Data.TypedEncoding.Common.Class.Encode + Data.TypedEncoding.Common.Class.IsStringR + Data.TypedEncoding.Common.Class.Superset + Data.TypedEncoding.Common.Class.Util + Data.TypedEncoding.Common.Class.Util.StringConstraints + Data.TypedEncoding.Common.Class.Validate + Data.TypedEncoding.Common.Types + Data.TypedEncoding.Common.Types.CheckedEnc + Data.TypedEncoding.Common.Types.Common + Data.TypedEncoding.Common.Types.Decoding + Data.TypedEncoding.Common.Types.Enc + Data.TypedEncoding.Common.Types.Exceptions + Data.TypedEncoding.Common.Types.SomeAnnotation + Data.TypedEncoding.Common.Types.SomeEnc + Data.TypedEncoding.Common.Types.UncheckedEnc + Data.TypedEncoding.Common.Types.Unsafe + Data.TypedEncoding.Common.Types.Validation + Data.TypedEncoding.Common.Util.TypeLits Data.TypedEncoding.Conv.ByteString.Char8 Data.TypedEncoding.Conv.ByteString.Lazy.Char8 Data.TypedEncoding.Conv.Text @@ -42,31 +67,18 @@ Data.TypedEncoding.Instances.Do.Sample Data.TypedEncoding.Instances.Enc.Base64 Data.TypedEncoding.Instances.Restriction.ASCII - Data.TypedEncoding.Instances.Restriction.Common + Data.TypedEncoding.Instances.Restriction.Bool + Data.TypedEncoding.Instances.Restriction.BoundedAlphaNums + Data.TypedEncoding.Instances.Restriction.Misc Data.TypedEncoding.Instances.Restriction.UTF8 Data.TypedEncoding.Instances.Support - Data.TypedEncoding.Instances.ToEncString.Common - Data.TypedEncoding.Internal.Class - Data.TypedEncoding.Internal.Class.Decode - Data.TypedEncoding.Internal.Class.Encode - Data.TypedEncoding.Internal.Class.Encoder - Data.TypedEncoding.Internal.Class.IsStringR - Data.TypedEncoding.Internal.Class.Recreate - Data.TypedEncoding.Internal.Class.Superset - Data.TypedEncoding.Internal.Class.Util - Data.TypedEncoding.Internal.Class.Util.StringConstraints - Data.TypedEncoding.Internal.Combinators - Data.TypedEncoding.Internal.Instances.Combinators - Data.TypedEncoding.Internal.Types - 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.Instances.Support.Common + Data.TypedEncoding.Instances.Support.Decode + Data.TypedEncoding.Instances.Support.Encode + Data.TypedEncoding.Instances.Support.Helpers + Data.TypedEncoding.Instances.Support.Unsafe + Data.TypedEncoding.Instances.Support.Validate Data.TypedEncoding.Internal.Util - Data.TypedEncoding.Internal.Util.TypeLits Data.TypedEncoding.Unsafe Examples.TypedEncoding Examples.TypedEncoding.Conversions @@ -113,6 +125,7 @@ main-is: Spec.hs other-modules: Test.Bc.IsStringRSpec + Test.Bc.ASCIISpec hs-source-dirs: test ghc-options: -threaded -rtsopts -with-rtsopts=-N