{-# 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" 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


-- |
-- >>> 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 :: 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))              



-- * Decoding

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_


-- * 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 :: 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


-- * 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 bounded 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 "Not ASCII char in annotation '\\1103'"
-- 
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