{-# 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
(Identity -> Identity -> Bool)
-> (Identity -> Identity -> Bool) -> Eq Identity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Identity -> Identity -> Bool
== :: Identity -> Identity -> Bool
$c/= :: Identity -> Identity -> Bool
/= :: Identity -> Identity -> Bool
Eq, (forall x. Identity -> Rep Identity x)
-> (forall x. Rep Identity x -> Identity) -> Generic Identity
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
$cfrom :: forall x. Identity -> Rep Identity x
from :: forall x. Identity -> Rep Identity x
$cto :: forall x. Rep Identity x -> Identity
to :: forall x. Rep Identity x -> Identity
Generic, Eq Identity
Eq Identity =>
(Identity -> Identity -> Ordering)
-> (Identity -> Identity -> Bool)
-> (Identity -> Identity -> Bool)
-> (Identity -> Identity -> Bool)
-> (Identity -> Identity -> Bool)
-> (Identity -> Identity -> Identity)
-> (Identity -> Identity -> Identity)
-> Ord 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
$ccompare :: Identity -> Identity -> Ordering
compare :: Identity -> Identity -> Ordering
$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
>= :: Identity -> Identity -> Bool
$cmax :: Identity -> Identity -> Identity
max :: Identity -> Identity -> Identity
$cmin :: Identity -> Identity -> Identity
min :: Identity -> Identity -> Identity
Ord)

instance Show Identity where
  show :: Identity -> String
show i :: Identity
i@Identity {Location
Gender
Serial
identityGender :: Identity -> Gender
identityLocation :: Identity -> Location
identitySerial :: Identity -> Serial
identityGender :: Gender
identityLocation :: Location
identitySerial :: Serial
..} = String
""
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Location -> String
forall a. Show a => a -> String
show Location
identityLocation
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Digit -> String) -> Vector Vector 1 Digit -> String
forall m a. Monoid m => (a -> m) -> Vector Vector 1 a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Digit -> String
forall a. Show a => a -> String
show (Gender -> Vector Vector 1 Digit
forall t (n :: Nat). ToDigits t n => t -> Vector n Digit
toDigits Gender
identityGender)
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Digit -> String) -> Vector Vector 7 Digit -> String
forall m a. Monoid m => (a -> m) -> Vector Vector 7 a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Digit -> String
forall a. Show a => a -> String
show (Serial -> Vector Vector 7 Digit
forall t (n :: Nat). ToDigits t n => t -> Vector n Digit
toDigits Serial
identitySerial)
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Digit -> String
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
identityGender :: Identity -> Gender
identityLocation :: Identity -> Location
identitySerial :: Identity -> Serial
identityGender :: Gender
identityLocation :: Location
identitySerial :: Serial
..} = Int -> Digit
forall a. Enum a => Int -> a
toEnum (Int -> Digit) -> Int -> Digit
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a. Num a => a -> a
negate Int
total Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
10
  where
    total :: Int
total = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Finite 2 -> Int
p Finite 2
0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
9 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Finite 2 -> Int
p Finite 2
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Finite 1 -> Int
g Finite 1
0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
7 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Finite 7 -> Int
s Finite 7
0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
6 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Finite 7 -> Int
s Finite 7
1
          Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
5 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Finite 7 -> Int
s Finite 7
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Finite 7 -> Int
s Finite 7
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Finite 7 -> Int
s Finite 7
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Finite 7 -> Int
s Finite 7
5 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Finite 7 -> Int
s Finite 7
6
    g :: Finite 1 -> Int
g = Gender -> Finite 1 -> Int
forall {p} {n :: Nat}. ToDigits p n => p -> Finite n -> Int
index Gender
identityGender
    p :: Finite 2 -> Int
p = Location -> Finite 2 -> Int
forall {p} {n :: Nat}. ToDigits p n => p -> Finite n -> Int
index Location
identityLocation
    s :: Finite 7 -> Int
s = Serial -> Finite 7 -> Int
forall {p} {n :: Nat}. ToDigits p n => p -> Finite n -> Int
index Serial
identitySerial
    index :: p -> Finite n -> Int
index p
x = Digit -> Int
forall a. Enum a => a -> Int
fromEnum (Digit -> Int) -> (Finite n -> Digit) -> Finite n -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector n Digit -> Finite n -> Digit
forall (n :: Nat) a. Vector n a -> Finite n -> a
V.index Vector n Digit
e
      where
        e :: Vector n Digit
e = p -> Vector n Digit
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 Vector 1 Digit
toDigits = Only Digit -> Vector Vector 1 Digit
forall input (length :: Nat) ty.
(IndexedListLiterals input length ty, KnownNat length) =>
input -> Vector length ty
V.fromTuple (Only Digit -> Vector Vector 1 Digit)
-> (Gender -> Only Digit) -> Gender -> Vector Vector 1 Digit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Digit -> Only Digit
forall a. a -> Only a
Only (Digit -> Only Digit) -> (Gender -> Digit) -> Gender -> Only Digit
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 = (Digit, Digit) -> Vector 2 Digit
forall input (length :: Nat) ty.
(IndexedListLiterals input length ty, KnownNat length) =>
input -> Vector length ty
V.fromTuple ((Digit, Digit) -> Vector 2 Digit)
-> (Location -> (Digit, Digit)) -> Location -> Vector 2 Digit
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 Vector 7 Digit
toDigits (Serial Vector Vector 7 Digit
c) = Vector 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 <-              ParseError
-> Maybe (Vector 10 Char) -> Either ParseError (Vector 10 Char)
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 (Gender -> Location -> Serial -> Identity)
-> Either ParseError Gender
-> Either ParseError (Location -> Serial -> Identity)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParseError -> Maybe Gender -> Either ParseError Gender
forall x y. x -> Maybe y -> Either x y
guard ParseError
InvalidGender   (Char -> Maybe Gender
parseGender   (Char -> Maybe Gender) -> Char -> Maybe Gender
forall a b. (a -> b) -> a -> b
$ Vector 10 Char -> Char
forall {c}. Vector 10 c -> c
readGender   Vector 10 Char
v)
                  Either ParseError (Location -> Serial -> Identity)
-> Either ParseError Location
-> Either ParseError (Serial -> Identity)
forall a b.
Either ParseError (a -> b)
-> Either ParseError a -> Either ParseError b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParseError -> Maybe Location -> Either ParseError Location
forall x y. x -> Maybe y -> Either x y
guard ParseError
InvalidLocation (Char -> Maybe Location
parseLocation (Char -> Maybe Location) -> Char -> Maybe Location
forall a b. (a -> b) -> a -> b
$ Vector 10 Char -> Char
forall {c}. Vector 10 c -> c
readLocation Vector 10 Char
v)
                  Either ParseError (Serial -> Identity)
-> Either ParseError Serial -> Either ParseError Identity
forall a b.
Either ParseError (a -> b)
-> Either ParseError a -> Either ParseError b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParseError -> Maybe Serial -> Either ParseError Serial
forall x y. x -> Maybe y -> Either x y
guard ParseError
InvalidSerial   (Vector 7 Char -> Maybe Serial
parseSerial   (Vector 7 Char -> Maybe Serial) -> Vector 7 Char -> Maybe Serial
forall a b. (a -> b) -> a -> b
$ Vector ((2 + 7) + 1) Char -> Vector 7 Char
forall {m :: Nat} {a}. Vector ((2 + 7) + m) a -> Vector 7 a
readSerial   Vector 10 Char
Vector ((2 + 7) + 1) Char
v)
    Digit
c <-              ParseError -> Maybe Digit -> Either ParseError Digit
forall x y. x -> Maybe y -> Either x y
guard ParseError
InvalidChecksum (Char -> Maybe Digit
parseDigit    (Char -> Maybe Digit) -> Char -> Maybe Digit
forall a b. (a -> b) -> a -> b
$ Vector 10 Char -> Char
forall {c}. Vector 10 c -> c
readChecksum Vector 10 Char
v)
    if Digit
c Digit -> Digit -> Bool
forall a. Eq a => a -> a -> Bool
== Identity -> Digit
identityChecksum Identity
i then Identity -> Either ParseError Identity
forall a. a -> Either ParseError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Identity
i else ParseError -> Either ParseError Identity
forall a b. a -> Either a b
Left ParseError
InvalidChecksum
  where
    readSerial :: Vector ((2 + 7) + m) a -> Vector 7 a
readSerial   = Proxy 2 -> Vector ((2 + 7) + m) a -> Vector 7 a
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 (Proxy 2
forall {k} (t :: k). Proxy t
Proxy :: Proxy 2)
    readLocation :: Vector 10 c -> c
readLocation = (Vector 10 c -> Finite 10 -> c) -> Finite 10 -> Vector 10 c -> c
forall a b c. (a -> b -> c) -> b -> a -> c
flip Vector 10 c -> Finite 10 -> c
forall (n :: Nat) a. Vector n a -> Finite n -> a
V.index Finite 10
0
    readGender :: Vector 10 c -> c
readGender   = (Vector 10 c -> Finite 10 -> c) -> Finite 10 -> Vector 10 c -> c
forall a b c. (a -> b -> c) -> b -> a -> c
flip Vector 10 c -> Finite 10 -> c
forall (n :: Nat) a. Vector n a -> Finite n -> a
V.index Finite 10
1
    readChecksum :: Vector 10 c -> c
readChecksum = (Vector 10 c -> Finite 10 -> c) -> Finite 10 -> Vector 10 c -> c
forall a b c. (a -> b -> c) -> b -> a -> c
flip Vector 10 c -> Finite 10 -> c
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
(ParseError -> ParseError -> Bool)
-> (ParseError -> ParseError -> Bool) -> Eq ParseError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ParseError -> ParseError -> Bool
== :: ParseError -> ParseError -> Bool
$c/= :: ParseError -> ParseError -> Bool
/= :: ParseError -> ParseError -> Bool
Eq, Int -> ParseError -> ShowS
[ParseError] -> ShowS
ParseError -> String
(Int -> ParseError -> ShowS)
-> (ParseError -> String)
-> ([ParseError] -> ShowS)
-> Show ParseError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ParseError -> ShowS
showsPrec :: Int -> ParseError -> ShowS
$cshow :: ParseError -> String
show :: ParseError -> String
$cshowList :: [ParseError] -> ShowS
showList :: [ParseError] -> ShowS
Show)

parseRaw :: Text -> Maybe (Vector 10 Char)
parseRaw :: Text -> Maybe (Vector 10 Char)
parseRaw  = String -> Maybe (Vector 10 Char)
forall (n :: Nat) a. KnownNat n => [a] -> Maybe (Vector n a)
V.fromList (String -> Maybe (Vector 10 Char))
-> (Text -> String) -> Text -> Maybe (Vector 10 Char)
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' -> Gender -> Maybe Gender
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Gender
Male
  Char
'2' -> Gender -> Maybe Gender
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Gender
Female
  Char
_   -> Maybe Gender
forall a. Maybe a
Nothing

parseSerial :: Vector 7 Char -> Maybe Serial
parseSerial :: Vector 7 Char -> Maybe Serial
parseSerial Vector 7 Char
a = Vector Vector 7 Digit -> Serial
Serial (Vector Vector 7 Digit -> Serial)
-> Maybe (Vector Vector 7 Digit) -> Maybe Serial
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Maybe Digit)
-> Vector 7 Char -> Maybe (Vector Vector 7 Digit)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Vector Vector 7 a -> f (Vector Vector 7 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 (Gender -> Location -> Serial -> Identity)
-> m Gender -> m (Location -> Serial -> Identity)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Gender
forall (m :: * -> *). MonadRandom m => m Gender
randomGender
                          m (Location -> Serial -> Identity)
-> m Location -> m (Serial -> Identity)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m Location
forall (m :: * -> *). MonadRandom m => m Location
randomLocation
                          m (Serial -> Identity) -> m Serial -> m Identity
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m Serial
forall (m :: * -> *). MonadRandom m => m Serial
randomSerial