typed-encoding 0.2.0.0 → 0.2.1.0
raw patch · 22 files changed
+1046/−52 lines, 22 filesdep +hspecdep +symbolsdep ~QuickCheckdep ~basedep ~quickcheck-instances
Dependencies added: hspec, symbols
Dependency ranges changed: QuickCheck, base, quickcheck-instances
Files
- ChangeLog.md +36/−22
- README.md +19/−3
- src/Data/TypedEncoding.hs +23/−4
- src/Data/TypedEncoding/Combinators/Restriction/Bool.hs +395/−0
- src/Data/TypedEncoding/Combinators/Restriction/BoundedAlphaNums.hs +107/−0
- src/Data/TypedEncoding/Combinators/Restriction/Common.hs +60/−0
- src/Data/TypedEncoding/Instances/Restriction/Common.hs +9/−4
- src/Data/TypedEncoding/Instances/ToEncString/Common.hs +1/−0
- src/Data/TypedEncoding/Internal/Class.hs +0/−3
- src/Data/TypedEncoding/Internal/Class/Decode.hs +1/−1
- src/Data/TypedEncoding/Internal/Class/Encode.hs +1/−1
- src/Data/TypedEncoding/Internal/Class/IsStringR.hs +6/−1
- src/Data/TypedEncoding/Internal/Class/Recreate.hs +25/−0
- src/Data/TypedEncoding/Internal/Class/Util/StringConstraints.hs +129/−0
- src/Data/TypedEncoding/Internal/Combinators.hs +0/−1
- src/Data/TypedEncoding/Internal/Instances/Combinators.hs +1/−1
- src/Data/TypedEncoding/Internal/Types.hs +17/−0
- src/Data/TypedEncoding/Internal/Types/Enc.hs +4/−0
- src/Data/TypedEncoding/Internal/Util/TypeLits.hs +115/−0
- test/Spec.hs +3/−3
- test/Test/Bc/IsStringRSpec.hs +77/−0
- typed-encoding.cabal +17/−8
ChangeLog.md view
@@ -1,31 +1,45 @@ # Changelog for typed-encoding - ## Unreleased changes +## Anticipated future breaking changes++- `Data.TypedEncoding.Internal.Class.IsStringR` expected to be be changed / replaced++## 0.2.1.0++- new functionality:+ - bounded alpha-numeric restriction encodings (`r-ban`)+ - boolean algebra of encodings +- minor improvements+ - dropped IsString contraint from instances in `Data.TypedEncoding.Instances.Restriction.Common`+ - added forall annotation to ecodeAll and decodeAll+ ## 0.2.0.0- - breaking:- - Data.TypedEncoding.Instances modules reorganized- - Data.TypedEncoding.Internal.Class modules reorganized- - Data.TypedEncoding.Internal.Utils module renamed- - Several TypeAnnotations friendly changes:- * Removed polymorphic kinds in most places- * Changed typeclass name from `Subset` to `Superset`- * flipped type parameters on FlattenAs, HasA typeclass functions- * Removed Proxy parameters from several methods (few methods have a '_' backward compatible version which still has them)- - new functionality:- - `ToEncString` - class allowing to convert types to `Enc` encoded strings- - `FromEncString` - class reverses ToEncString- - `CheckedEnc` untyped version of `Enc` containing valid encoding- - `SomeEnc` existentially quantified version of `Enc` - - `UncheckedEnc` for working with not validated encoding- - `RecreateExUnkStep` constructor added to RecreateEx- - utility `IsStringR` - reverse to `IsString` class- - utility `SymbolList` class- - docs: - - ToEncString example +- breaking:+ - Data.TypedEncoding.Instances modules reorganized+ - Data.TypedEncoding.Internal.Class modules reorganized+ - Data.TypedEncoding.Internal.Utils module renamed+ - Several TypeAnnotations friendly changes:+ * Removed polymorphic kinds in most places+ * Changed typeclass name from `Subset` to `Superset`+ * flipped type parameters on FlattenAs, HasA typeclass functions+ * Removed Proxy parameters from several methods (few methods have a '_' backward compatible version which still has them)+- new functionality:+ - `ToEncString` - class allowing to convert types to `Enc` encoded strings+ - `FromEncString` - class reverses ToEncString+ - `CheckedEnc` untyped version of `Enc` containing valid encoding+ - `SomeEnc` existentially quantified version of `Enc` + - `UncheckedEnc` for working with not validated encoding+ - `RecreateExUnkStep` constructor added to RecreateEx+ - utility `IsStringR` - reverse to `IsString` class+ - utility `SymbolList` class+- docs: + - ToEncString example + ## 0.1.0.0- - initial release++- initial release
README.md view
@@ -18,7 +18,7 @@ It allows to define precise string content annotations like: ```Haskell-mydata :: Enc '["r-IpV4"] Text+ipaddr :: Enc '["r-IpV4"] Text ``` and provides ways for @@ -40,9 +40,24 @@ It becomes a type directed, declarative approach to string transformations. Transformations can be- - used with parameters.+ - used with parameters - applied or undone partially (if encoding is reversible)- ++One of more intersting uses of this library are encoding restrictions. +(Arbitrary) bounded alpha-numeric (`r-ban`) restrictions +and a simple annotation boolean algebra are both provided.++```Haskell+phone :: Enc '["r-ban:999-999-9999"] () T.Text+phone = ...++-- simple boolean algebra:+phone' :: Enc '["boolOr:(r-ban:999-999-9999)(r-ban:(999) 999-9999)"] () T.Text+phone' = ...+```+++ ## Examples Please see `Examples.TypedEncoding` it the module list.@@ -59,6 +74,7 @@ ## 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
src/Data/TypedEncoding.hs view
@@ -4,7 +4,7 @@ -- | -- = Overview ----- This library allows to specify and work with types like+-- This library uses 'GHC.TypeLits' symbols to specify and work with types like -- -- @ -- -- Base 64 encoded bytes (could represent binary files)@@ -24,7 +24,7 @@ -- upper = ... -- @ ----- or define precise types to use with 'toEncString' and 'fromEncString'+-- or to define precise types to use with 'toEncString' and 'fromEncString' -- -- @ -- date :: Enc '["r-date-%d/%b/%Y:%X %Z"] Text@@ -58,7 +58,7 @@ -- * /recreation/ is a partial identity (matching encoding) -- * /decoding/ is identity ----- Examples: @"r-UTF8"@, @"r-ASCII"@+-- Examples: @"r-UTF8"@, @"r-ASCII"@, upper alpha-numeric bound /r-ban/ restrictions like @"r-999-999-9999"@ -- -- == "do-" transformations --@@ -76,9 +76,21 @@ -- -- Examples: @"enc-B64"@ -- +-- == "bool[Op]:" encodings+--+-- Encodings that are defined in terms of other encodings using boolean algebra.+--+-- (early, beta version)+--+-- Examples: +--+-- @"boolOr:(r-ban:ffffffff-ffff-ffff-ffff-ffffffffffff)(r-ban:ffffffffffffffffffffffffffffffff)"@ +--+-- "@boolNot:(r-ASCII)"+-- -- = Usage ----- To use this library import this module and one or more /instance/ module.+-- 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 --@@ -95,6 +107,13 @@ -- To implement a new encoding import this module and -- -- * "Data.TypedEncoding.Instances.Support"+--+-- Defining annotations with combinators is an alternative to using typeclass instances +--+-- Included combinator modules:+--+-- * "Data.TypedEncoding.Combinators.Restriction.Bool"+-- * "Data.TypedEncoding.Combinators.Restriction.BoundedAlphaNums" -- -- = Examples --
+ src/Data/TypedEncoding/Combinators/Restriction/Bool.hs view
@@ -0,0 +1,395 @@++{-# 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+
+ src/Data/TypedEncoding/Combinators/Restriction/BoundedAlphaNums.hs view
@@ -0,0 +1,107 @@++{-# 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 "r-ban:" (Take 6 s))+++-- |+-- >>> 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)) ++++-- |+-- >>> 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
+ src/Data/TypedEncoding/Combinators/Restriction/Common.hs view
@@ -0,0 +1,60 @@++-- {-# 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 typical encode function to a recreate step+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
src/Data/TypedEncoding/Instances/Restriction/Common.hs view
@@ -12,7 +12,6 @@ module Data.TypedEncoding.Instances.Restriction.Common where import Data.Word-import Data.String -- import qualified Data.ByteString as B -- import qualified Data.ByteString.Lazy as BL@@ -27,13 +26,19 @@ -- >>> import qualified Data.Text as T -instance (IsStringR str, IsString str) => EncodeF (Either EncodeEx) (Enc xs c str) (Enc ("r-Word8-decimal" ': xs) c str) where+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, IsString str, RecreateErr f, Applicative f) => RecreateF f (Enc xs c str) (Enc ("r-Word8-decimal" ': xs) c str) where+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, IsString str, Applicative f) => DecodeF f (Enc ("r-Word8-decimal" ': xs) c str) (Enc xs c str) where+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
src/Data/TypedEncoding/Instances/ToEncString/Common.hs view
@@ -39,5 +39,6 @@ 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
src/Data/TypedEncoding/Internal/Class.hs view
@@ -30,9 +30,6 @@ import GHC.TypeLits --- TODO would be nice to have EncodeFAll1 and DecodeFAll1 that starts--- end stops at frist encoding. - -- | -- Generalized Java @toString@ or a type safe version of Haskell's 'Show'. --
src/Data/TypedEncoding/Internal/Class/Decode.hs view
@@ -37,7 +37,7 @@ let re :: f (Enc xs c str) = decodeF str in re >>= decodeFAll -decodeAll :: DecodeFAll Identity (xs :: [Symbol]) c str => +decodeAll :: forall xs c str . DecodeFAll Identity (xs :: [Symbol]) c str => Enc xs c str -> Enc '[] c str decodeAll = runIdentity . decodeFAll
src/Data/TypedEncoding/Internal/Class/Encode.hs view
@@ -39,7 +39,7 @@ in re >>= encodeF -encodeAll :: EncodeFAll Identity (xs :: [Symbol]) c str => +encodeAll :: forall xs c str . EncodeFAll Identity (xs :: [Symbol]) c str => Enc '[] c str -> Enc xs c str encodeAll = runIdentity . encodeFAll
src/Data/TypedEncoding/Internal/Class/IsStringR.hs view
@@ -4,6 +4,8 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE AllowAmbiguousTypes #-} +-- | 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@@ -21,7 +23,10 @@ -- >>> import Test.QuickCheck.Instances.Text() -- >>> import Test.QuickCheck.Instances.ByteString() --- | Reverses 'Data.String.IsString'+-- | 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: --
src/Data/TypedEncoding/Internal/Class/Recreate.hs view
@@ -17,7 +17,9 @@ , toEncoding , withUnsafeCoerce , RecreateEx(..)+ , getPayload )+import Data.TypedEncoding.Internal.Class.Util import Data.Proxy import Data.Functor.Identity import GHC.TypeLits@@ -48,6 +50,29 @@ Enc '[] c str -> Enc xs c str recreateAll = runIdentity . recreateFAll +++-- | Usefull 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) -- TODO using RecreateErr typeclass is overkill
+ src/Data/TypedEncoding/Internal/Class/Util/StringConstraints.hs view
@@ -0,0 +1,129 @@+{-# 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 +++-- 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 ++-- |+-- 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 elementes 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
src/Data/TypedEncoding/Internal/Combinators.hs view
@@ -10,7 +10,6 @@ module Data.TypedEncoding.Internal.Combinators where import Data.TypedEncoding.Internal.Types-import Data.TypedEncoding.Internal.Class.IsStringR () import Data.TypedEncoding.Internal.Class.Recreate import Data.TypedEncoding.Internal.Class.Util (SymbolList) import GHC.TypeLits
src/Data/TypedEncoding/Internal/Instances/Combinators.hs view
@@ -79,7 +79,7 @@ -- Left "Payload does not satisfy format Word8-decimal: 256" -- >>> verifyWithRead @Word8 "Word8-decimal" (T.pack "123") -- Right "123"-verifyWithRead :: forall a str . (IsStringR str, IsString str, Read a, Show a) => String -> str -> Either String str+verifyWithRead :: 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
src/Data/TypedEncoding/Internal/Types.hs view
@@ -63,7 +63,17 @@ instance Show EncodeEx where show (EncodeEx prxy a) = "(EncodeEx \"" ++ symbolVal prxy ++ "\" (" ++ show a ++ "))" +-- | usefull 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.@@ -87,3 +97,10 @@ 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
src/Data/TypedEncoding/Internal/Types/Enc.hs view
@@ -79,6 +79,10 @@ 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
+ src/Data/TypedEncoding/Internal/Util/TypeLits.hs view
@@ -0,0 +1,115 @@+++{-# 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 here+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+-- | :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))++-- TODO create TypeList.List+-- | :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
test/Spec.hs view
@@ -1,3 +1,3 @@--- {-# OPTIONS_GHC -F -pgmF doctest-discover #-}-main :: IO ()-main = putStrLn "Only doctest suite is implemented, no other tests"+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+-- main :: IO ()+-- main = putStrLn "Only doctest suite is implemented, no other tests"
+ test/Test/Bc/IsStringRSpec.hs view
@@ -0,0 +1,77 @@+++{-# LANGUAGE MultiParamTypeClasses #-}+-- {-# LANGUAGE PolyKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Checks for use of IsStringR which will be deprecated+--+-- it is used for "r-Word8-decimal" +--+-- * FromEncString +-- * EncodeF+-- * DecodeF+-- * RecreateF++module Test.Bc.IsStringRSpec where++import Test.Hspec++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 ()++newtype MyStr = MyStr String deriving (Eq, Show)++instance IsStringR MyStr+ where toString (MyStr str) = str++tstWord8 = MyStr "123"+tstNotWord8 = MyStr "hello"+tstNotWord8' = MyStr "256"++tstWord8Enc :: Enc '["r-Word8-decimal"] () MyStr+tstWord8Enc = unsafeSetPayload () tstWord8++tstWord8EncErr :: Enc '["r-Word8-decimal"] () MyStr+tstWord8EncErr = unsafeSetPayload () tstNotWord8++fromEncStringTest :: Word8+fromEncStringTest = fromEncString tstWord8Enc++fromEncStringTestErr :: Either UnexpectedDecodeEx Word8+fromEncStringTestErr = fromEncStringF tstWord8EncErr+++spec :: Spec +spec = + describe "IsStringR constr works" $ do+ it "Word8 fromEncString works" $ + fromEncStringTest `shouldBe` 123 + it "Word8 fromEncString err works" $ + fromEncStringTestErr `shouldSatisfy` isLeft+ it "EncodeF works" $+ (encodeFAll @(Either EncodeEx) @'["r-Word8-decimal"] . toEncoding () $ tstWord8) `shouldSatisfy` isRight + it "EncodeF err works" $+ (encodeFAll @(Either EncodeEx) @'["r-Word8-decimal"] . toEncoding () $ tstNotWord8') `shouldSatisfy` isLeft+ it "RecreateF works" $+ (recreateFAll @(Either RecreateEx) @'["r-Word8-decimal"] . toEncoding () $ tstWord8) `shouldSatisfy` isRight + it "RecreateF err works" $+ (recreateFAll @(Either RecreateEx) @'["r-Word8-decimal"] . toEncoding () $ tstNotWord8) `shouldSatisfy` isLeft+ it "DecodeF works" $+ (fromEncoding . decodeAll $ tstWord8Enc) `shouldBe` tstWord8 + +runSpec :: IO ()+runSpec = hspec spec
typed-encoding.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 1589fa6653cfa6d1278a74078d61a95a0fe2caa0df5157deafd3f3dc4644385d+-- hash: 229ee0dd2c77a44f82646983a5b80e9fd45ab517a25feec0482cc0b301b29ee6 name: typed-encoding-version: 0.2.0.0+version: 0.2.1.0 synopsis: Type safe string transformations description: See README.md in the project github repository. category: Data, Text@@ -30,6 +30,9 @@ library exposed-modules: Data.TypedEncoding+ Data.TypedEncoding.Combinators.Restriction.Bool+ Data.TypedEncoding.Combinators.Restriction.BoundedAlphaNums+ Data.TypedEncoding.Combinators.Restriction.Common Data.TypedEncoding.Instances.Do.Sample Data.TypedEncoding.Instances.Enc.Base64 Data.TypedEncoding.Instances.Restriction.ASCII@@ -43,6 +46,7 @@ Data.TypedEncoding.Internal.Class.IsStringR Data.TypedEncoding.Internal.Class.Recreate Data.TypedEncoding.Internal.Class.Util+ Data.TypedEncoding.Internal.Class.Util.StringConstraints Data.TypedEncoding.Internal.Combinators Data.TypedEncoding.Internal.Instances.Combinators Data.TypedEncoding.Internal.Types@@ -54,6 +58,7 @@ Data.TypedEncoding.Internal.Types.UncheckedEnc Data.TypedEncoding.Internal.Types.Unsafe Data.TypedEncoding.Internal.Util+ Data.TypedEncoding.Internal.Util.TypeLits Data.TypedEncoding.Unsafe Examples.TypedEncoding Examples.TypedEncoding.Conversions@@ -67,9 +72,10 @@ src ghc-options: -fwarn-unused-imports -fwarn-incomplete-patterns -fprint-explicit-kinds build-depends:- base >=4.7 && <5+ base >=4.10 && <5 , base64-bytestring >=1.0 && <1.1 , bytestring >=0.10 && <0.11+ , symbols >=0.3 && <0.3.1 , text >=1.2 && <1.3 default-language: Haskell2010 @@ -83,12 +89,13 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: QuickCheck >=2.13.1 && <2.14- , base >=4.7 && <5+ , base >=4.10 && <5 , base64-bytestring >=1.0 && <1.1 , bytestring >=0.10 && <0.11 , doctest >=0.16 && <0.17 , doctest-discover >=0.2 && <0.3 , quickcheck-instances >=0.3.20 && <0.4+ , symbols >=0.3 && <0.3.1 , text >=1.2 && <1.3 , typed-encoding default-language: Haskell2010@@ -97,16 +104,18 @@ type: exitcode-stdio-1.0 main-is: Spec.hs other-modules:- Paths_typed_encoding+ Test.Bc.IsStringRSpec hs-source-dirs: test ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends:- QuickCheck- , base >=4.7 && <5+ QuickCheck >=2.13.1 && <2.14+ , base >=4.10 && <5 , base64-bytestring >=1.0 && <1.1 , bytestring >=0.10 && <0.11- , quickcheck-instances+ , hspec+ , quickcheck-instances >=0.3.20 && <0.4+ , symbols >=0.3 && <0.3.1 , text >=1.2 && <1.3 , typed-encoding default-language: Haskell2010