{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedLists #-}

module Codec.QRCode.Mode.Alphanumeric
  ( alphanumeric
  , alphanumericB
  , alphanumericMap
  ) where

import           Codec.QRCode.Base

import qualified Data.Map.Strict                      as M

import qualified Codec.QRCode.Data.ByteStreamBuilder  as BSB
import           Codec.QRCode.Data.QRSegment.Internal
import           Codec.QRCode.Data.Result
import           Codec.QRCode.Data.ToInput

-- | Generate a segment representing the specified text string encoded in alphanumeric mode.
--
--    The alphanumeric encoding contains this characters: "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ $%*+-./:".
--
--    When the input is case insensitive the chars are converted to uppercase since this alphabet contains only uppercase characters.
--    This can be archived by applying `Data.CaseInsensitive.mk` to the input.
alphanumeric :: ToText a => a -> Result QRSegment
alphanumeric :: a -> Result QRSegment
alphanumeric a
s =
  case a -> [Char]
forall a. ToText a => a -> [Char]
toString a
s of
    [] -> QRSegment -> Result QRSegment
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteStreamBuilder -> QRSegment
constStream ByteStreamBuilder
forall a. Monoid a => a
mempty)
    [Char]
s' -> ((Int -> Int -> QRSegment
encodeBits Int
4 Int
0b0010 QRSegment -> QRSegment -> QRSegment
forall a. Semigroup a => a -> a -> a
<> (Int, Int, Int) -> Int -> QRSegment
lengthSegment (Int
9, Int
11, Int
13) ([Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
s')) QRSegment -> QRSegment -> QRSegment
forall a. Semigroup a => a -> a -> a
<>) (QRSegment -> QRSegment)
-> (ByteStreamBuilder -> QRSegment)
-> ByteStreamBuilder
-> QRSegment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteStreamBuilder -> QRSegment
constStream
          (ByteStreamBuilder -> QRSegment)
-> Result ByteStreamBuilder -> Result QRSegment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> [Char] -> Result ByteStreamBuilder
alphanumericB (a -> Bool
forall a. ToText a => a -> Bool
isCI a
s) [Char]
s'

alphanumericB :: Bool -> [Char] -> Result BSB.ByteStreamBuilder
alphanumericB :: Bool -> [Char] -> Result ByteStreamBuilder
alphanumericB Bool
ci [Char]
s = [Int] -> ByteStreamBuilder
go ([Int] -> ByteStreamBuilder)
-> Result [Int] -> Result ByteStreamBuilder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Result Int) -> [Char] -> Result [Int]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Maybe Int -> Result Int
forall a. Maybe a -> Result a
Result (Maybe Int -> Result Int)
-> (Char -> Maybe Int) -> Char -> Result Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Map Char Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Bool -> Map Char Int
alphanumericMap Bool
ci)) [Char]
s
  where
    go :: [Int] -> BSB.ByteStreamBuilder
    go :: [Int] -> ByteStreamBuilder
go (Int
a:Int
b:[Int]
cs) = Int -> Int -> ByteStreamBuilder
BSB.encodeBits Int
11 (Int
a Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
45 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
b) ByteStreamBuilder -> ByteStreamBuilder -> ByteStreamBuilder
forall a. Semigroup a => a -> a -> a
<> [Int] -> ByteStreamBuilder
go [Int]
cs
    go [Item [Int]
a]      = Int -> Int -> ByteStreamBuilder
BSB.encodeBits  Int
6 Int
Item [Int]
a
    go []       = ByteStreamBuilder
forall a. Monoid a => a
mempty
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 800
    go _        = error "This is just to get rid of the Warning."
#endif

alphanumericMap :: Bool -> M.Map Char Int
alphanumericMap :: Bool -> Map Char Int
alphanumericMap Bool
False =
  [ (Char
'0',  Int
0)
  , (Char
'1',  Int
1)
  , (Char
'2',  Int
2)
  , (Char
'3',  Int
3)
  , (Char
'4',  Int
4)
  , (Char
'5',  Int
5)
  , (Char
'6',  Int
6)
  , (Char
'7',  Int
7)
  , (Char
'8',  Int
8)
  , (Char
'9',  Int
9)
  , (Char
'A', Int
10)
  , (Char
'B', Int
11)
  , (Char
'C', Int
12)
  , (Char
'D', Int
13)
  , (Char
'E', Int
14)
  , (Char
'F', Int
15)
  , (Char
'G', Int
16)
  , (Char
'H', Int
17)
  , (Char
'I', Int
18)
  , (Char
'J', Int
19)
  , (Char
'K', Int
20)
  , (Char
'L', Int
21)
  , (Char
'M', Int
22)
  , (Char
'N', Int
23)
  , (Char
'O', Int
24)
  , (Char
'P', Int
25)
  , (Char
'Q', Int
26)
  , (Char
'R', Int
27)
  , (Char
'S', Int
28)
  , (Char
'T', Int
29)
  , (Char
'U', Int
30)
  , (Char
'V', Int
31)
  , (Char
'W', Int
32)
  , (Char
'X', Int
33)
  , (Char
'Y', Int
34)
  , (Char
'Z', Int
35)
  , (Char
' ', Int
36)
  , (Char
'$', Int
37)
  , (Char
'%', Int
38)
  , (Char
'*', Int
39)
  , (Char
'+', Int
40)
  , (Char
'-', Int
41)
  , (Char
'.', Int
42)
  , (Char
'/', Int
43)
  , (Char
':', Int
44)
  ]
alphanumericMap Bool
True =
  [ (Char
'0',  Int
0)
  , (Char
'1',  Int
1)
  , (Char
'2',  Int
2)
  , (Char
'3',  Int
3)
  , (Char
'4',  Int
4)
  , (Char
'5',  Int
5)
  , (Char
'6',  Int
6)
  , (Char
'7',  Int
7)
  , (Char
'8',  Int
8)
  , (Char
'9',  Int
9)
  , (Char
'A', Int
10)
  , (Char
'a', Int
10)
  , (Char
'B', Int
11)
  , (Char
'b', Int
11)
  , (Char
'C', Int
12)
  , (Char
'c', Int
12)
  , (Char
'D', Int
13)
  , (Char
'd', Int
13)
  , (Char
'E', Int
14)
  , (Char
'e', Int
14)
  , (Char
'F', Int
15)
  , (Char
'f', Int
15)
  , (Char
'G', Int
16)
  , (Char
'g', Int
16)
  , (Char
'H', Int
17)
  , (Char
'h', Int
17)
  , (Char
'I', Int
18)
  , (Char
'i', Int
18)
  , (Char
'J', Int
19)
  , (Char
'j', Int
19)
  , (Char
'K', Int
20)
  , (Char
'k', Int
20)
  , (Char
'L', Int
21)
  , (Char
'l', Int
21)
  , (Char
'M', Int
22)
  , (Char
'm', Int
22)
  , (Char
'N', Int
23)
  , (Char
'n', Int
23)
  , (Char
'O', Int
24)
  , (Char
'o', Int
24)
  , (Char
'P', Int
25)
  , (Char
'p', Int
25)
  , (Char
'Q', Int
26)
  , (Char
'q', Int
26)
  , (Char
'R', Int
27)
  , (Char
'r', Int
27)
  , (Char
'S', Int
28)
  , (Char
's', Int
28)
  , (Char
'T', Int
29)
  , (Char
't', Int
29)
  , (Char
'U', Int
30)
  , (Char
'u', Int
30)
  , (Char
'V', Int
31)
  , (Char
'v', Int
31)
  , (Char
'W', Int
32)
  , (Char
'w', Int
32)
  , (Char
'X', Int
33)
  , (Char
'x', Int
33)
  , (Char
'Y', Int
34)
  , (Char
'y', Int
34)
  , (Char
'Z', Int
35)
  , (Char
'z', Int
35)
  , (Char
' ', Int
36)
  , (Char
'$', Int
37)
  , (Char
'%', Int
38)
  , (Char
'*', Int
39)
  , (Char
'+', Int
40)
  , (Char
'-', Int
41)
  , (Char
'.', Int
42)
  , (Char
'/', Int
43)
  , (Char
':', Int
44)
  ]