ID.hs

{-# 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
  { identityGender   :: Gender
  -- ^ The gender of the person to whom this ID number belongs.
  , identityLocation :: Location
  -- ^ The location in which the person first registered for an ID card.
  , identitySerial   :: Serial
  -- ^ The serial number portion of this ID number.
  } deriving (Eq, Generic, Ord)

instance Show Identity where
  show i@Identity {..} = ""
    <> show identityLocation
    <> foldMap show (toDigits identityGender)
    <> foldMap show (toDigits identitySerial)
    <> show (identityChecksum i)

-- | Calculate the checksum of the specified 'Identity'.
--
identityChecksum :: Identity -> Digit
identityChecksum Identity {..} = toEnum $ negate total `mod` 10
  where
    total = 1 * p 0 + 9 * p 1 + 8 * g 0 + 7 * s 0 + 6 * s 1
          + 5 * s 2 + 4 * s 3 + 3 * s 4 + 2 * s 5 + 1 * s 6
    g = index identityGender
    p = index identityLocation
    s = index identitySerial
    index x = fromEnum . V.index e
      where
        e = toDigits x

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

instance ToDigits Gender 1 where
  toDigits = V.fromTuple . Only . \case
    Male   -> D1
    Female -> D2

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

instance ToDigits Serial 7 where
  toDigits (Serial c) = 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 t = do
    v <-              guard InvalidLength   (parseRaw                     t)
    i <- Identity <$> guard InvalidGender   (parseGender   $ readGender   v)
                  <*> guard InvalidLocation (parseLocation $ readLocation v)
                  <*> guard InvalidSerial   (parseSerial   $ readSerial   v)
    c <-              guard InvalidChecksum (parseDigit    $ readChecksum v)
    if c == identityChecksum i then pure i else Left InvalidChecksum
  where
    readSerial   = V.slice (Proxy :: Proxy 2)
    readLocation = flip V.index 0
    readGender   = flip V.index 1
    readChecksum = flip V.index 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 (Eq, Show)

parseRaw :: Text -> Maybe (Vector 10 Char)
parseRaw  = V.fromList . T.unpack

parseGender :: Char -> Maybe Gender
parseGender = \case
  '1' -> pure Male
  '2' -> pure Female
  _   -> Nothing

parseSerial :: Vector 7 Char -> Maybe Serial
parseSerial a = Serial <$> traverse parseDigit a

-- | Generate a random 'Identity'.
--
randomIdentity :: MonadRandom m => m Identity
randomIdentity = Identity <$> randomGender
                          <*> randomLocation
                          <*> randomSerial