{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

module ROC.ID
  ( Identity (..)
  , identityChecksum
  , parseIdentity
  , ParseError (..)
  , randomIdentity
  ) where

import Control.Monad.Random.Class
    ( MonadRandom (..) )
import Data.Proxy
    ( Proxy (..) )
import Data.Text
    ( Text )
import Data.Tuple.Only
    ( Only (..) )
import Data.Vector.Sized
    ( Vector )
import GHC.Generics
    ( Generic )

import ROC.ID.Digit
import ROC.ID.Gender
import ROC.ID.Location
import ROC.ID.Serial
import ROC.ID.Utilities

import qualified Data.Text as T
import qualified Data.Vector.Sized as V

-- Types:

-- | Represents a __valid__ 10-digit ROC national identification number
-- (中華民國身份證號碼) of the form __@A123456789@__.
--
-- By construction, invalid values are __not representable__ by this type.
--
-- An identification number encodes a person's 'Gender', the 'Location' in
-- which they first registered for an identification card, and a unique 'Serial'
-- number.
--
data Identity = Identity
  { Identity -> Gender
identityGender   :: Gender
  -- ^ The gender of the person to whom this ID number belongs.
  , Identity -> Location
identityLocation :: Location
  -- ^ The location in which the person first registered for an ID card.
  , Identity -> Serial
identitySerial   :: Serial
  -- ^ The serial number portion of this ID number.
  } deriving (Identity -> Identity -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Identity -> Identity -> Bool
$c/= :: Identity -> Identity -> Bool
== :: Identity -> Identity -> Bool
$c== :: Identity -> Identity -> Bool
Eq, forall x. Rep Identity x -> Identity
forall x. Identity -> Rep Identity x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Identity x -> Identity
$cfrom :: forall x. Identity -> Rep Identity x
Generic, Eq Identity
Identity -> Identity -> Bool
Identity -> Identity -> Ordering
Identity -> Identity -> Identity
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Identity -> Identity -> Identity
$cmin :: Identity -> Identity -> Identity
max :: Identity -> Identity -> Identity
$cmax :: Identity -> Identity -> Identity
>= :: Identity -> Identity -> Bool
$c>= :: Identity -> Identity -> Bool
> :: Identity -> Identity -> Bool
$c> :: Identity -> Identity -> Bool
<= :: Identity -> Identity -> Bool
$c<= :: Identity -> Identity -> Bool
< :: Identity -> Identity -> Bool
$c< :: Identity -> Identity -> Bool
compare :: Identity -> Identity -> Ordering
$ccompare :: Identity -> Identity -> Ordering
Ord)

instance Show Identity where
  show :: Identity -> String
show i :: Identity
i@Identity {Location
Gender
Serial
identitySerial :: Serial
identityLocation :: Location
identityGender :: Gender
identitySerial :: Identity -> Serial
identityLocation :: Identity -> Location
identityGender :: Identity -> Gender
..} = String
""
    forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Location
identityLocation
    forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a. Show a => a -> String
show (forall t (n :: Nat). ToDigits t n => t -> Vector n Digit
toDigits Gender
identityGender)
    forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a. Show a => a -> String
show (forall t (n :: Nat). ToDigits t n => t -> Vector n Digit
toDigits Serial
identitySerial)
    forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (Identity -> Digit
identityChecksum Identity
i)

-- | Calculate the checksum of the specified 'Identity'.
--
identityChecksum :: Identity -> Digit
identityChecksum :: Identity -> Digit
identityChecksum Identity {Location
Gender
Serial
identitySerial :: Serial
identityLocation :: Location
identityGender :: Gender
identitySerial :: Identity -> Serial
identityLocation :: Identity -> Location
identityGender :: Identity -> Gender
..} = forall a. Enum a => Int -> a
toEnum forall a b. (a -> b) -> a -> b
$ forall a. Num a => a -> a
negate Int
total forall a. Integral a => a -> a -> a
`mod` Int
10
  where
    total :: Int
total = Int
1 forall a. Num a => a -> a -> a
* Finite 2 -> Int
p Finite 2
0 forall a. Num a => a -> a -> a
+ Int
9 forall a. Num a => a -> a -> a
* Finite 2 -> Int
p Finite 2
1 forall a. Num a => a -> a -> a
+ Int
8 forall a. Num a => a -> a -> a
* Finite 1 -> Int
g Finite 1
0 forall a. Num a => a -> a -> a
+ Int
7 forall a. Num a => a -> a -> a
* Finite 7 -> Int
s Finite 7
0 forall a. Num a => a -> a -> a
+ Int
6 forall a. Num a => a -> a -> a
* Finite 7 -> Int
s Finite 7
1
          forall a. Num a => a -> a -> a
+ Int
5 forall a. Num a => a -> a -> a
* Finite 7 -> Int
s Finite 7
2 forall a. Num a => a -> a -> a
+ Int
4 forall a. Num a => a -> a -> a
* Finite 7 -> Int
s Finite 7
3 forall a. Num a => a -> a -> a
+ Int
3 forall a. Num a => a -> a -> a
* Finite 7 -> Int
s Finite 7
4 forall a. Num a => a -> a -> a
+ Int
2 forall a. Num a => a -> a -> a
* Finite 7 -> Int
s Finite 7
5 forall a. Num a => a -> a -> a
+ Int
1 forall a. Num a => a -> a -> a
* Finite 7 -> Int
s Finite 7
6
    g :: Finite 1 -> Int
g = forall {p} {n :: Nat}. ToDigits p n => p -> Finite n -> Int
index Gender
identityGender
    p :: Finite 2 -> Int
p = forall {p} {n :: Nat}. ToDigits p n => p -> Finite n -> Int
index Location
identityLocation
    s :: Finite 7 -> Int
s = forall {p} {n :: Nat}. ToDigits p n => p -> Finite n -> Int
index Serial
identitySerial
    index :: p -> Finite n -> Int
index p
x = forall a. Enum a => a -> Int
fromEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (n :: Nat) a. Vector n a -> Finite n -> a
V.index Vector n Digit
e
      where
        e :: Vector n Digit
e = forall t (n :: Nat). ToDigits t n => t -> Vector n Digit
toDigits p
x

class ToDigits t n | t -> n where
  toDigits :: t -> Vector n Digit

instance ToDigits Gender 1 where
  toDigits :: Gender -> Vector 1 Digit
toDigits = forall input (length :: Nat) ty.
(IndexedListLiterals input length ty, KnownNat length) =>
input -> Vector length ty
V.fromTuple forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Only a
Only forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
    Gender
Male   -> Digit
D1
    Gender
Female -> Digit
D2

instance ToDigits Location 2 where
  toDigits :: Location -> Vector 2 Digit
toDigits = forall input (length :: Nat) ty.
(IndexedListLiterals input length ty, KnownNat length) =>
input -> Vector length ty
V.fromTuple forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
    Location
A -> (Digit
D1, Digit
D0); Location
N -> (Digit
D2, Digit
D2)
    Location
B -> (Digit
D1, Digit
D1); Location
O -> (Digit
D3, Digit
D5)
    Location
C -> (Digit
D1, Digit
D2); Location
P -> (Digit
D2, Digit
D3)
    Location
D -> (Digit
D1, Digit
D3); Location
Q -> (Digit
D2, Digit
D4)
    Location
E -> (Digit
D1, Digit
D4); Location
R -> (Digit
D2, Digit
D5)
    Location
F -> (Digit
D1, Digit
D5); Location
S -> (Digit
D2, Digit
D6)
    Location
G -> (Digit
D1, Digit
D6); Location
T -> (Digit
D2, Digit
D7)
    Location
H -> (Digit
D1, Digit
D7); Location
U -> (Digit
D2, Digit
D8)
    Location
I -> (Digit
D3, Digit
D4); Location
V -> (Digit
D2, Digit
D9)
    Location
J -> (Digit
D1, Digit
D8); Location
W -> (Digit
D3, Digit
D2)
    Location
K -> (Digit
D1, Digit
D9); Location
X -> (Digit
D3, Digit
D0)
    Location
L -> (Digit
D2, Digit
D0); Location
Y -> (Digit
D3, Digit
D1)
    Location
M -> (Digit
D2, Digit
D1); Location
Z -> (Digit
D3, Digit
D3)

instance ToDigits Serial 7 where
  toDigits :: Serial -> Vector 7 Digit
toDigits (Serial Vector 7 Digit
c) = Vector 7 Digit
c

-- | Attempt to parse an 'Identity' using the specified 'Text' as input.
--
-- The input must be of the form __@A123456789@__.
--
parseIdentity :: Text -> Either ParseError Identity
parseIdentity :: Text -> Either ParseError Identity
parseIdentity Text
t = do
    Vector 10 Char
v <-              forall x y. x -> Maybe y -> Either x y
guard ParseError
InvalidLength   (Text -> Maybe (Vector 10 Char)
parseRaw                     Text
t)
    Identity
i <- Gender -> Location -> Serial -> Identity
Identity forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall x y. x -> Maybe y -> Either x y
guard ParseError
InvalidGender   (Char -> Maybe Gender
parseGender   forall a b. (a -> b) -> a -> b
$ forall {c}. Vector 10 c -> c
readGender   Vector 10 Char
v)
                  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall x y. x -> Maybe y -> Either x y
guard ParseError
InvalidLocation (Char -> Maybe Location
parseLocation forall a b. (a -> b) -> a -> b
$ forall {c}. Vector 10 c -> c
readLocation Vector 10 Char
v)
                  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall x y. x -> Maybe y -> Either x y
guard ParseError
InvalidSerial   (Vector 7 Char -> Maybe Serial
parseSerial   forall a b. (a -> b) -> a -> b
$ forall {m :: Nat} {a}. Vector ((2 + 7) + m) a -> Vector 7 a
readSerial   Vector 10 Char
v)
    Digit
c <-              forall x y. x -> Maybe y -> Either x y
guard ParseError
InvalidChecksum (Char -> Maybe Digit
parseDigit    forall a b. (a -> b) -> a -> b
$ forall {c}. Vector 10 c -> c
readChecksum Vector 10 Char
v)
    if Digit
c forall a. Eq a => a -> a -> Bool
== Identity -> Digit
identityChecksum Identity
i then forall (f :: * -> *) a. Applicative f => a -> f a
pure Identity
i else forall a b. a -> Either a b
Left ParseError
InvalidChecksum
  where
    readSerial :: Vector ((2 + 7) + m) a -> Vector 7 a
readSerial   = forall (i :: Nat) (n :: Nat) (m :: Nat) a (p :: Nat -> *).
(KnownNat i, KnownNat n) =>
p i -> Vector ((i + n) + m) a -> Vector n a
V.slice (forall {k} (t :: k). Proxy t
Proxy :: Proxy 2)
    readLocation :: Vector 10 c -> c
readLocation = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (n :: Nat) a. Vector n a -> Finite n -> a
V.index Finite 10
0
    readGender :: Vector 10 c -> c
readGender   = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (n :: Nat) a. Vector n a -> Finite n -> a
V.index Finite 10
1
    readChecksum :: Vector 10 c -> c
readChecksum = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (n :: Nat) a. Vector n a -> Finite n -> a
V.index Finite 10
9

-- | An error produced when parsing an 'Identity' with the 'parseIdentity'
--   function.
--
data ParseError
  = InvalidLength
    -- ^ The input was either too short or too long.
  | InvalidGender
    -- ^ The gender portion of the input was invalid.
  | InvalidLocation
    -- ^ The location portion of the input included non-alphabetic characters.
  | InvalidSerial
    -- ^ The serial number portion of the input included non-numeric characters.
  | InvalidChecksum
    -- ^ The computed checksum did not match the checksum portion of the input.
  deriving (ParseError -> ParseError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ParseError -> ParseError -> Bool
$c/= :: ParseError -> ParseError -> Bool
== :: ParseError -> ParseError -> Bool
$c== :: ParseError -> ParseError -> Bool
Eq, Int -> ParseError -> ShowS
[ParseError] -> ShowS
ParseError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ParseError] -> ShowS
$cshowList :: [ParseError] -> ShowS
show :: ParseError -> String
$cshow :: ParseError -> String
showsPrec :: Int -> ParseError -> ShowS
$cshowsPrec :: Int -> ParseError -> ShowS
Show)

parseRaw :: Text -> Maybe (Vector 10 Char)
parseRaw :: Text -> Maybe (Vector 10 Char)
parseRaw  = forall (n :: Nat) a. KnownNat n => [a] -> Maybe (Vector n a)
V.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack

parseGender :: Char -> Maybe Gender
parseGender :: Char -> Maybe Gender
parseGender = \case
  Char
'1' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Gender
Male
  Char
'2' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Gender
Female
  Char
_   -> forall a. Maybe a
Nothing

parseSerial :: Vector 7 Char -> Maybe Serial
parseSerial :: Vector 7 Char -> Maybe Serial
parseSerial Vector 7 Char
a = Vector 7 Digit -> Serial
Serial forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Char -> Maybe Digit
parseDigit Vector 7 Char
a

-- | Generate a random 'Identity'.
--
randomIdentity :: MonadRandom m => m Identity
randomIdentity :: forall (m :: * -> *). MonadRandom m => m Identity
randomIdentity = Gender -> Location -> Serial -> Identity
Identity forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadRandom m => m Gender
randomGender
                          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *). MonadRandom m => m Location
randomLocation
                          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *). MonadRandom m => m Serial
randomSerial