{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ConstraintKinds #-}
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
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" x "r-ban" xs = 'True
instance (Ban s, Algorithm s "r-ban", IsStringR str) => Encode (Either EncodeEx) s "r-ban" c str where
encoding :: Encoding (Either EncodeEx) s "r-ban" c str
encoding = Encoding (Either EncodeEx) s "r-ban" c str
forall (s :: Symbol) c str.
(IsStringR str, Ban s, Algorithm s "r-ban") =>
Encoding (Either EncodeEx) s "r-ban" c str
encFBan
encFBan :: forall s c str .
(
IsStringR str
, Ban s
, Algorithm s "r-ban"
) =>
Encoding (Either EncodeEx) s "r-ban" c str
encFBan :: Encoding (Either EncodeEx) s "r-ban" c str
encFBan = (str -> Either String str)
-> Encoding (Either EncodeEx) s (AlgNm s) c str
forall (nm :: Symbol) err c str.
(KnownSymbol nm, Show err) =>
(str -> Either err str)
-> Encoding (Either EncodeEx) nm (AlgNm nm) c str
_implEncodingEx @s (Proxy @Symbol s -> str -> Either String str
forall (s :: Symbol) str.
(KnownSymbol s, IsStringR str) =>
Proxy @Symbol s -> str -> Either String str
verifyBoundedAlphaNum (Proxy @Symbol s
forall k (t :: k). Proxy @k t
Proxy :: Proxy s))
instance (KnownSymbol s, Restriction s, Algorithm s "r-ban", Applicative f) => Decode f s "r-ban" c str where
decoding :: Decoding f s "r-ban" c str
decoding = Decoding f s "r-ban" c str
forall (r :: Symbol) (f :: * -> *) c str (alg :: Symbol).
(Restriction r, Algorithm r alg, Applicative f) =>
Decoding f r alg c str
decAnyR_
instance (KnownSymbol s , Ban s, Algorithm s "r-ban", IsStringR str, RecreateErr f, Applicative f) => Validate f s "r-ban" c str where
validation :: Validation f s "r-ban" c str
validation = Encoding (Either EncodeEx) s "r-ban" c str
-> Validation f s "r-ban" c str
forall (alg :: Symbol) (nm :: Symbol) (f :: * -> *) c str.
(KnownSymbol nm, RecreateErr @* f, Applicative f) =>
Encoding (Either EncodeEx) nm alg c str
-> Validation f nm alg c str
validRFromEnc' @"r-ban" Encoding (Either EncodeEx) s "r-ban" c str
forall (s :: Symbol) c str.
(IsStringR str, Ban s, Algorithm s "r-ban") =>
Encoding (Either EncodeEx) s "r-ban" c str
encFBan
verifyBoundedAlphaNum :: forall s str . (KnownSymbol s, IsStringR str) => Proxy s -> str -> Either String str
verifyBoundedAlphaNum :: Proxy @Symbol s -> str -> Either String str
verifyBoundedAlphaNum Proxy @Symbol s
p str
str =
case ([Either String ()] -> [String]
forall a b. [Either a b] -> [a]
lefts [Either String ()]
match, Maybe Char
notAscii, Int
pattl Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
inpl) of
([String]
_, Just Char
ch, Bool
_) -> String -> Either String str
forall a b. a -> Either a b
Left (String -> Either String str) -> String -> Either String str
forall a b. (a -> b) -> a -> b
$ String
"Not ASCII char in annotation " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. Show a => a -> String
show Char
ch
([String]
_, Maybe Char
_, Bool
False) -> String -> Either String str
forall a b. a -> Either a b
Left (String -> Either String str) -> String -> Either String str
forall a b. (a -> b) -> a -> b
$ String
"Input list has wrong size expecting " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
pattl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" but length " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
input String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" == " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
inpl
(String
e: [String]
_, Maybe Char
_, Bool
_) -> String -> Either String str
forall a b. a -> Either a b
Left String
e
([String], Maybe Char, Bool)
_ -> str -> Either String str
forall a b. b -> Either a b
Right str
str
where
patt :: String
patt = Int -> String -> String
forall a. Int -> [a] -> [a]
L.drop (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
L.length (String
"r-ban:" :: String)) (String -> String)
-> (Proxy @Symbol s -> String) -> Proxy @Symbol s -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy @Symbol s -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy @Symbol s -> String) -> Proxy @Symbol s -> String
forall a b. (a -> b) -> a -> b
$ Proxy @Symbol s
p
input :: String
input = str -> String
forall a. IsStringR a => a -> String
toString str
str
pattl :: Int
pattl = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
L.length String
patt
inpl :: Int
inpl = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
L.length String
input
match :: [Either String ()]
match = (Char -> Char -> Either String ())
-> String -> String -> [Either String ()]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
L.zipWith Char -> Char -> Either String ()
fn String
input String
patt
notAscii :: Maybe Char
notAscii = (Char -> Bool) -> String -> Maybe Char
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isAscii) String
patt
fn :: Char -> Char -> Either String ()
fn Char
ci Char
cp = case (Char -> Bool
isAlphaNum Char
ci, Char -> Bool
isAlphaNum Char
cp, Char
ci Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
cp, Char
ci Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
cp) of
(Bool
True, Bool
True, Bool
True, Bool
_) -> () -> Either String ()
forall a b. b -> Either a b
Right ()
(Bool
_, Bool
_, Bool
_, Bool
True) -> () -> Either String ()
forall a b. b -> Either a b
Right ()
(Bool
_, Bool
True, Bool
_, Bool
False) -> String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ Char -> String
forall a. Show a => a -> String
show Char
ci String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not bounded by " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. Show a => a -> String
show Char
cp
(Bool
_, Bool
False, Bool
_, Bool
False) -> String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ Char -> String
forall a. Show a => a -> String
show Char
ci String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not matching " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. Show a => a -> String
show Char
cp