taiwan-id 0.1.0.0 → 0.1.1.0

raw patch · 38 files changed

+3069/−1873 lines, 38 filesdep +directorydep +doctest-paralleldep +filepathdep −doctestdep ~MonadRandomdep ~QuickCheckdep ~hspecsetup-changednew-component:exe:taiwan-idPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: directory, doctest-parallel, filepath, optparse-applicative, random, tasty, tasty-hunit

Dependencies removed: doctest

Dependency ranges changed: MonadRandom, QuickCheck, hspec, text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +16/−0
• README.md +4/−2
• Setup.hs +0/−5
• components/exe/taiwan-id/Main.hs +30/−0
• components/lib/taiwan-id-cli/Taiwan/ID/CLI.hs +437/−0
• components/lib/taiwan-id-test-common/Taiwan/ID/Test.hs +218/−0
• components/lib/taiwan-id/Taiwan/ID.hs +366/−0
• components/lib/taiwan-id/Taiwan/ID/CharIndex.hs +13/−0
• components/lib/taiwan-id/Taiwan/ID/CharSet.hs +18/−0
• components/lib/taiwan-id/Taiwan/ID/Digit.hs +119/−0
• components/lib/taiwan-id/Taiwan/ID/Digit1289.hs +94/−0
• components/lib/taiwan-id/Taiwan/ID/Gender.hs +52/−0
• components/lib/taiwan-id/Taiwan/ID/Issuer.hs +59/−0
• components/lib/taiwan-id/Taiwan/ID/Language.hs +7/−0
• components/lib/taiwan-id/Taiwan/ID/Letter.hs +69/−0
• components/lib/taiwan-id/Taiwan/ID/Region.hs +223/−0
• components/lib/taiwan-id/Taiwan/ID/Unchecked.hs +315/−0
• components/lib/taiwan-id/Taiwan/ID/Utilities.hs +90/−0
• components/taiwan-id-test-docs/Main.hs +0/−9
• components/taiwan-id-test/Spec.hs +0/−340
• components/taiwan-id-test/Test/QuickCheck/Classes/Hspec.hs +0/−72
• components/taiwan-id/Taiwan/ID.hs +0/−366
• components/taiwan-id/Taiwan/ID/CharIndex.hs +0/−13
• components/taiwan-id/Taiwan/ID/CharSet.hs +0/−18
• components/taiwan-id/Taiwan/ID/Digit.hs +0/−119
• components/taiwan-id/Taiwan/ID/Digit1289.hs +0/−94
• components/taiwan-id/Taiwan/ID/Gender.hs +0/−52
• components/taiwan-id/Taiwan/ID/Issuer.hs +0/−59
• components/taiwan-id/Taiwan/ID/Language.hs +0/−5
• components/taiwan-id/Taiwan/ID/Letter.hs +0/−69
• components/taiwan-id/Taiwan/ID/Region.hs +0/−223
• components/taiwan-id/Taiwan/ID/Unchecked.hs +0/−315
• components/taiwan-id/Taiwan/ID/Utilities.hs +0/−90
• components/test/taiwan-id-cli-test/Main.hs +403/−0
• components/test/taiwan-id-doc-test/Main.hs +6/−0
• components/test/taiwan-id-test/Main.hs +343/−0
• components/test/taiwan-id-test/Test/QuickCheck/Classes/Hspec.hs +72/−0
• taiwan-id.cabal +115/−22

@@ -1,3 +1,19 @@+# 0.1.1.0++- Added a `taiwan-id` command-line tool with three commands:+  - `decode`+    decodes the attributes of an identification number+  - `generate`+    generates one or more valid identification numbers+  - `validate`+    checks whether an identification number is valid++- Switched the documentation testing infrastructure from `doctest` ++  `cabal-doctest` (with a custom `Setup.hs`) to `doctest-parallel`.++- Added an internal `taiwan-id-test-common` library to share common testing+  functionality across test suites.+ # 0.1.0.0  - Replaced the `Location` type with a new `Region` type, reflecting the fact

@@ -21,11 +21,13 @@  Example: `A123456789` -This package offers functions for validating, decoding, and encoding these-numbers.+This package offers a library with functions for validating, decoding, and+encoding these numbers, as well as a command-line tool for working with them+interactively.  For more details, see:  * https://zh.wikipedia.org/wiki/中華民國國民身分證+* https://zh.wikipedia.org/wiki/中華民國居留證 * https://en.wikipedia.org/wiki/National_identification_card_(Taiwan) * https://en.wikipedia.org/wiki/Resident_certificate

@@ -1,5 +0,0 @@-import Distribution.Extra.Doctest-  ( defaultMainWithDoctests )--main :: IO ()-main = defaultMainWithDoctests "taiwan-id-test-docs"

@@ -0,0 +1,30 @@+module Main (main) where++import Control.Monad.Random+  ( evalRandIO+  )+import System.Environment+  ( getArgs+  )+import System.Exit+  ( exitFailure+  , exitSuccess+  )+import System.IO+  ( stderr+  , stdout+  )+import Taiwan.ID.CLI+  ( CommandLineResult (CommandLineFailure, CommandLineSuccess)+  )++import qualified Data.Text.IO as TIO+import qualified Taiwan.ID.CLI as CLI++main :: IO ()+main = do+  args <- getArgs+  result <- evalRandIO (CLI.run args)+  case result of+    CommandLineSuccess ls -> mapM_ (TIO.hPutStrLn stdout) ls >> exitSuccess+    CommandLineFailure ls -> mapM_ (TIO.hPutStrLn stderr) ls >> exitFailure

@@ -0,0 +1,437 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{- HLINT ignore "Use newtype instead of data" -}++module Taiwan.ID.CLI where++import Control.Monad+  ( replicateM+  )+import Control.Monad.Random+  ( MonadRandom+  , evalRand+  , getRandom+  )+import Data.Functor.Identity+  ( Identity (Identity)+  , runIdentity+  )+import Data.Kind+  ( Type+  )+import Data.Maybe+  ( fromMaybe+  )+import Data.Text+  ( Text+  )+import Data.Version+  ( showVersion+  )+import Options.Applicative+  ( CommandFields+  , Mod+  , Parser+  , ParserInfo+  , ParserResult (CompletionInvoked, Failure, Success)+  , argument+  , auto+  , command+  , eitherReader+  , execParserPure+  , fullDesc+  , header+  , help+  , hidden+  , hsubparser+  , info+  , long+  , metavar+  , option+  , optional+  , prefs+  , progDesc+  , renderFailure+  , showHelpOnEmpty+  , simpleVersioner+  , str+  , (<**>)+  )+import Options.Applicative.Extra+  ( helperWith+  )+import Paths_taiwan_id+  ( version+  )+import System.Random+  ( mkStdGen+  )+import Taiwan.ID+  ( ID+  )+import Taiwan.ID.CharIndex+  ( CharIndex (CharIndex)+  )+import Taiwan.ID.CharSet+  ( CharSet (CharRange, CharSet)+  )+import Taiwan.ID.Language+  ( Language (Chinese, English)+  )++import qualified Data.Foldable as Foldable+import qualified Data.Text as T+import qualified Data.Text as Text+import qualified Taiwan.ID as ID+import qualified Taiwan.ID.Gender as Gender+import qualified Taiwan.ID.Issuer as Issuer+import qualified Taiwan.ID.Region as Region++--------------------------------------------------------------------------------+-- Commands+--------------------------------------------------------------------------------++data Stage = Raw | Resolved++type family Optional (s :: Stage) :: Type -> Type where+  Optional Raw = Maybe+  Optional Resolved = Identity++type family Required (s :: Stage) :: Type -> Type where+  Required Raw = Identity+  Required Resolved = Identity++data Command (s :: Stage)+  = Decode (DecodeCommand s)+  | Generate (GenerateCommand s)+  | Validate (ValidateCommand s)++deriving instance Eq (Command Raw)+deriving instance Show (Command Raw)++type CommandDescription = Mod CommandFields (Command Raw)+type CommandParser args = Parser (args Raw)+type CommandResolver m args = args Raw -> m (args Resolved)+type CommandRunner args = args Resolved -> CommandLineResult++--------------------------------------------------------------------------------+-- Results+--------------------------------------------------------------------------------++data CommandLineResult+  = -- | Lines to be printed to stdout, with exit code 0.+    CommandLineSuccess [Text]+  | -- | Lines to be printed to stderr, with exit code 1.+    CommandLineFailure [Text]++--------------------------------------------------------------------------------+-- Main+--------------------------------------------------------------------------------++run :: MonadRandom m => [String] -> m CommandLineResult+run args =+  case execParserPure (prefs showHelpOnEmpty) topLevelParser args of+    Failure failure ->+      pure $+        CommandLineFailure+          (T.lines $ T.pack $ fst $ renderFailure failure "taiwan-id")+    CompletionInvoked _ ->+      pure $ CommandLineSuccess []+    Success unresolvedCommand -> do+      resolved <- commandResolver unresolvedCommand+      pure $ case resolved of+        Decode resolvedCommand -> decodeCommandRunner resolvedCommand+        Generate resolvedCommand -> generateCommandRunner resolvedCommand+        Validate resolvedCommand -> validateCommandRunner resolvedCommand++topLevelParser :: ParserInfo (Command Raw)+topLevelParser =+  info+    (commandParser <**> helpOption <**> versionOption)+    $ mconcat+      [ fullDesc+      , progDesc "Tools for working with Taiwan uniform identification numbers"+      , header "taiwan-id - Taiwan uniform identification number tools"+      ]+  where+    helpOption =+      helperWith $+        mconcat+          [ long "help"+          , help "Show this help text"+          , hidden+          ]+    versionOption =+      simpleVersioner (showVersion version)++commandParser :: CommandParser Command+commandParser =+  hsubparser $+    mconcat+      [ generateCommandDescription+      , validateCommandDescription+      , decodeCommandDescription+      ]++commandResolver :: MonadRandom m => CommandResolver m Command+commandResolver = \case+  Decode args -> Decode <$> decodeCommandResolver args+  Generate args -> Generate <$> generateCommandResolver args+  Validate args -> Validate <$> validateCommandResolver args++--------------------------------------------------------------------------------+-- Decode+--------------------------------------------------------------------------------++decodeCommandDescription :: CommandDescription+decodeCommandDescription =+  command+    "decode"+    ( info+        (Decode <$> decodeCommandParser)+        (progDesc "Decode an identification number")+    )++data DecodeCommand (s :: Stage) = DecodeCommand+  { idText :: Required s Text+  , language :: Optional s Language+  }++deriving instance Eq (DecodeCommand Raw)+deriving instance Show (DecodeCommand Raw)++decodeCommandParser :: CommandParser DecodeCommand+decodeCommandParser =+  DecodeCommand+    <$> argument str (metavar "ID")+    <*> languageOption+  where+    languageOption :: Parser (Maybe Language)+    languageOption =+      optional $+        option+          (eitherReader parseLanguage)+          ( long "language"+              <> metavar "LANG"+              <> help "Output language: English or Chinese (default: English)"+          )+    parseLanguage :: String -> Either String Language+    parseLanguage = \case+      "English" -> Right English+      "Chinese" -> Right Chinese+      s ->+        Left $+          "Unknown language '"+            <> s+            <> "': expected 'English' or 'Chinese'"++decodeCommandResolver :: Applicative m => CommandResolver m DecodeCommand+decodeCommandResolver DecodeCommand {idText, language} =+  pure+    DecodeCommand+      { idText+      , language = Identity (fromMaybe defaultLanguage language)+      }+  where+    defaultLanguage :: Language+    defaultLanguage = English++decodeCommandRunner :: CommandRunner DecodeCommand+decodeCommandRunner DecodeCommand {idText, language} =+  case ID.fromText (resolve idText) of+    Left err ->+      CommandLineFailure $+        renderIdFromTextError (resolve idText) err+    Right i ->+      CommandLineSuccess $+        T.lines $+          formatFields (resolve language) i++formatFields :: Language -> ID -> Text+formatFields language i =+  T.unlines (map (formatField maxWidth language) fields)+  where+    maxWidth = maximum (map (T.length . fst) fields)+    fields =+      [ (issuerKey language, Issuer.toText language (ID.getIssuer i))+      , (genderKey language, Gender.toText language (ID.getGender i))+      , (regionKey language, Region.toText language (ID.getRegion i))+      ]+    issuerKey = \case+      English -> "Issuer"+      Chinese -> "核發機關"+    genderKey = \case+      English -> "Gender"+      Chinese -> "性別"+    regionKey = \case+      English -> "Region"+      Chinese -> "地區"++formatField :: Int -> Language -> (Text, Text) -> Text+formatField maxWidth language (k, v) =+  T.concat+    [ k+    , padding language+    , separator language+    , v+    ]+  where+    padding =+      T.replicate (maxWidth - T.length k) . \case+        English -> " "+        Chinese -> "\x3000"+    separator = \case+      English -> ": "+      Chinese -> "："++--------------------------------------------------------------------------------+-- Generate+--------------------------------------------------------------------------------++generateCommandDescription :: CommandDescription+generateCommandDescription =+  command+    "generate"+    ( info+        (Generate <$> generateCommandParser)+        (progDesc "Generate one or more random identification numbers")+    )++data GenerateCommand (s :: Stage) = GenerateCommand+  { count :: Optional s Int+  , seed :: Optional s Int+  }++deriving instance Eq (GenerateCommand Raw)+deriving instance Show (GenerateCommand Raw)++generateCommandParser :: CommandParser GenerateCommand+generateCommandParser =+  GenerateCommand+    <$> optional+      ( option+          auto+          ( long "count"+              <> metavar "N"+              <> help+                "Number of identification numbers to generate (default: 1)"+          )+      )+    <*> optional+      ( option+          auto+          ( long "seed"+              <> metavar "N"+              <> help "Random seed for reproducible generation"+          )+      )++generateCommandResolver :: MonadRandom m => CommandResolver m GenerateCommand+generateCommandResolver GenerateCommand {count, seed} = do+  resolvedSeed <- maybe getRandom pure seed+  pure+    GenerateCommand+      { count = Identity (fromMaybe defaultCount count)+      , seed = Identity resolvedSeed+      }+  where+    defaultCount :: Int+    defaultCount = 1++generateCommandRunner :: CommandRunner GenerateCommand+generateCommandRunner GenerateCommand {count, seed}+  | count < 1 =+      CommandLineFailure+        ["Count argument should be a non-zero natural number."]+  | otherwise =+      CommandLineSuccess $+        map ID.toText $+          evalRand+            (replicateM (resolve count) ID.generate)+            (mkStdGen (resolve seed))++--------------------------------------------------------------------------------+-- Validate+--------------------------------------------------------------------------------++validateCommandDescription :: CommandDescription+validateCommandDescription =+  command+    "validate"+    ( info+        (Validate <$> validateCommandParser)+        (progDesc "Validate an identification number")+    )++data ValidateCommand (s :: Stage) = ValidateCommand+  { idText :: Required s Text+  }++deriving instance Eq (ValidateCommand Raw)+deriving instance Show (ValidateCommand Raw)++validateCommandParser :: CommandParser ValidateCommand+validateCommandParser = ValidateCommand <$> argument str (metavar "ID")++validateCommandResolver :: Applicative m => CommandResolver m ValidateCommand+validateCommandResolver ValidateCommand {idText} = pure ValidateCommand {idText}++validateCommandRunner :: CommandRunner ValidateCommand+validateCommandRunner ValidateCommand {idText} =+  case ID.fromText (resolve idText) of+    Right _ ->+      CommandLineSuccess []+    Left err ->+      CommandLineFailure $+        renderIdFromTextError (resolve idText) err++--------------------------------------------------------------------------------+-- Common+--------------------------------------------------------------------------------++renderIdFromTextError :: Text -> ID.FromTextError -> [Text]+renderIdFromTextError input =+  \case+    ID.InvalidChecksum ->+      [ "Invalid checksum."+      ]+    ID.InvalidLength ->+      [ "Invalid length."+      , "An identification number must be exactly 10 characters in length."+      ]+    ID.InvalidChar (CharIndex i) charSet ->+      [ "Invalid character:"+      , input+      , Text.replicate i (Text.singleton ' ') <> "^"+      , "Character at this position must be " <> describeCharSet charSet <> "."+      ]++describeCharSet :: CharSet -> Text+describeCharSet = \case+  CharRange lo hi ->+    "a character in the range "+      <> "["+      <> Text.singleton lo+      <> " .. "+      <> Text.singleton hi+      <> "]"+  CharSet neSet ->+    "a character from the set "+      <> "{"+      <> Text.intercalate ", " (Text.singleton <$> Foldable.toList neSet)+      <> "}"++resolve :: Identity a -> a+resolve = runIdentity

@@ -0,0 +1,218 @@+{-# LANGUAGE NamedFieldPuns #-}++module Taiwan.ID.Test where++import Control.Monad+  ( replicateM+  )+import Data.Function+  ( (&)+  )+import Data.Text+  ( Text+  )+import GHC.Stack+  ( HasCallStack+  )+import Taiwan.ID+  ( ID (ID, c0, c1, c2, c3, c4, c5, c6, c7, c8)+  )+import Taiwan.ID.Digit+  ( Digit+  )+import Taiwan.ID.Digit1289+  ( Digit1289+  )+import Taiwan.ID.Gender+  ( Gender+  )+import Taiwan.ID.Issuer+  ( Issuer+  )+import Taiwan.ID.Language+  ( Language+  )+import Taiwan.ID.Letter+  ( Letter+  )+import Taiwan.ID.Region+  ( Region+  )+import Test.QuickCheck+  ( Gen+  , arbitraryBoundedEnum+  , choose+  , elements+  , oneof+  , shrinkBoundedEnum+  )++import qualified Data.Text as Text+import qualified Taiwan.ID as ID+import qualified Taiwan.ID.Digit as Digit++--------------------------------------------------------------------------------+-- General-purpose generators and shrinkers+--------------------------------------------------------------------------------++genDigit :: Gen Digit+genDigit = arbitraryBoundedEnum++shrinkDigit :: Digit -> [Digit]+shrinkDigit = shrinkBoundedEnum++genDigit1289 :: Gen Digit1289+genDigit1289 = arbitraryBoundedEnum++shrinkDigit1289 :: Digit1289 -> [Digit1289]+shrinkDigit1289 = shrinkBoundedEnum++genGender :: Gen Gender+genGender = arbitraryBoundedEnum++shrinkGender :: Gender -> [Gender]+shrinkGender = shrinkBoundedEnum++genID :: Gen ID+genID =+  ID+    <$> genLetter+    <*> genDigit1289+    <*> genDigit+    <*> genDigit+    <*> genDigit+    <*> genDigit+    <*> genDigit+    <*> genDigit+    <*> genDigit++shrinkID :: ID -> [ID]+shrinkID i@ID {c0, c1, c2, c3, c4, c5, c6, c7, c8} =+  mconcat+    [ [i {c0 = c0'} | c0' <- c0 & shrinkLetter]+    , [i {c1 = c1'} | c1' <- c1 & shrinkDigit1289]+    , [i {c2 = c2'} | c2' <- c2 & shrinkDigit]+    , [i {c3 = c3'} | c3' <- c3 & shrinkDigit]+    , [i {c4 = c4'} | c4' <- c4 & shrinkDigit]+    , [i {c5 = c5'} | c5' <- c5 & shrinkDigit]+    , [i {c6 = c6'} | c6' <- c6 & shrinkDigit]+    , [i {c7 = c7'} | c7' <- c7 & shrinkDigit]+    , [i {c8 = c8'} | c8' <- c8 & shrinkDigit]+    ]++genIssuer :: Gen Issuer+genIssuer = arbitraryBoundedEnum++shrinkIssuer :: Issuer -> [Issuer]+shrinkIssuer = shrinkBoundedEnum++genLanguage :: Gen Language+genLanguage = arbitraryBoundedEnum++shrinkLanguage :: Language -> [Language]+shrinkLanguage = shrinkBoundedEnum++genLetter :: Gen Letter+genLetter = arbitraryBoundedEnum++shrinkLetter :: Letter -> [Letter]+shrinkLetter = shrinkBoundedEnum++genRegion :: Gen Region+genRegion = arbitraryBoundedEnum++shrinkRegion :: Region -> [Region]+shrinkRegion = shrinkBoundedEnum++--------------------------------------------------------------------------------+-- Specialised generators+--------------------------------------------------------------------------------++genInvalidChar :: Gen Char+genInvalidChar = elements "+!@#$%^&*()"++genIDText :: Gen Text+genIDText =+  oneof+    [ genIDTextValid+    , genIDTextInvalid+    ]++genIDTextValid :: Gen Text+genIDTextValid = ID.toText <$> genID++genIDTextInvalid :: Gen Text+genIDTextInvalid =+  oneof+    [ genIDTextInvalidChar+    , genIDTextInvalidChecksum+    , genIDTextInvalidLength+    ]++genIDTextInvalidChar :: Gen Text+genIDTextInvalidChar =+  genIDTextInvalidCharAtIndex =<< choose (0, 9)++genIDTextInvalidCharAtIndex :: Int -> Gen Text+genIDTextInvalidCharAtIndex index =+  unsafePokeChar index <$> genIDTextValid <*> genInvalidChar++genIDTextInvalidChecksum :: Gen Text+genIDTextInvalidChecksum = do+  idTextValid <- genIDTextValid+  let charOld = unsafePeekChar checksumCharIndex idTextValid+  let charNew = Digit.toChar (unsafeDigitFromChar charOld + 1)+  pure $ unsafePokeChar checksumCharIndex idTextValid charNew+  where+    checksumCharIndex = 9++genIDTextInvalidLength :: Gen Text+genIDTextInvalidLength =+  oneof+    [ genIDTextInvalidLengthTooLong+    , genIDTextInvalidLengthTooShort+    ]++genIDTextInvalidLengthTooShort :: Gen Text+genIDTextInvalidLengthTooShort = do+  idTextValid <- genIDTextValid+  invalidLength <- choose (0, 9)+  pure (Text.take invalidLength idTextValid)++genIDTextInvalidLengthTooLong :: Gen Text+genIDTextInvalidLengthTooLong = do+  idTextValid <- genIDTextValid+  extraCharCount <- choose (1, 4)+  extraChars <- Text.pack <$> replicateM extraCharCount genChar+  pure (idTextValid <> extraChars)+  where+    genChar = choose ('0', '9')++--------------------------------------------------------------------------------+-- Utilities+--------------------------------------------------------------------------------++unsafeDigitFromChar :: HasCallStack => Char -> Digit+unsafeDigitFromChar c = case Digit.fromChar c of+  Nothing -> error "unsafeDigitFromChar"+  Just d -> d++unsafePeekChar :: HasCallStack => Int -> Text -> Char+unsafePeekChar i t+  | i < indexMin = outOfBoundsError+  | i > indexMax = outOfBoundsError+  | otherwise = Text.index t i+  where+    indexMin = 0+    indexMax = Text.length t - 1+    outOfBoundsError = error "unsafePeekChar: index out of bounds"++unsafePokeChar :: HasCallStack => Int -> Text -> Char -> Text+unsafePokeChar i t c+  | i < indexMin = outOfBoundsError+  | i > indexMax = outOfBoundsError+  | otherwise = Text.take i t <> Text.singleton c <> Text.drop (i + 1) t+  where+    indexMin = 0+    indexMax = Text.length t - 1+    outOfBoundsError = error "unsafePokeChar: index out of bounds"

@@ -0,0 +1,366 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module Taiwan.ID+  (+  -- * Type+    ID (..)++  -- * Construction+  , fromSymbol+  , fromText+  , FromTextError (..)++  -- * Conversion+  , toText++  -- * Validity+  , checksum++  -- * Generation+  , generate++  -- * Inspection+  , getGender+  , getIssuer+  , getRegion++  -- * Modification+  , setGender+  , setIssuer+  , setRegion+  )+  where++import Control.Monad.Random.Class+  ( MonadRandom )+import Data.Bifunctor+  ( Bifunctor (first) )+import Data.Finitary+  ( Finitary )+import Data.Proxy+  ( Proxy (Proxy) )+import Data.Text+  ( Text )+import GHC.Generics+  ( Generic )+import GHC.TypeLits+  ( Symbol, symbolVal )+import Taiwan.ID.CharIndex+  ( CharIndex (..) )+import Taiwan.ID.CharSet+  ( CharSet (..) )+import Taiwan.ID.Digit+  ( Digit (..) )+import Taiwan.ID.Digit1289+  ( Digit1289 (..) )+import Taiwan.ID.Gender+  ( Gender (..) )+import Taiwan.ID.Issuer+  ( Issuer (..) )+import Taiwan.ID.Letter+  ( Letter (..) )+import Taiwan.ID.Region+  ( Region )+import Taiwan.ID.Unchecked+  ( UncheckedID (UncheckedID), ValidID )+import Taiwan.ID.Utilities+  ( guard, randomFinitary )+import Text.Read+  ( Lexeme (Ident, Symbol, Punc), Read (readPrec), lexP, parens, prec )++import qualified Data.Text as T+import qualified Taiwan.ID.Region as Region+import qualified Taiwan.ID.Unchecked as U++-- |+-- $setup+-- >>> :set -XDataKinds+-- >>> :set -XOverloadedStrings+-- >>> :set -XTypeApplications+-- >>> import Taiwan.ID+-- >>> import qualified Taiwan.ID as ID++--------------------------------------------------------------------------------+-- Type+--------------------------------------------------------------------------------++-- | Represents a __valid__ 10-digit uniform identification number of the form+-- __@A123456789@__.+--+-- By construction, invalid identification numbers are __not representable__ by+-- this data type.+--+-- To guarantee correctness, an 'ID' value does __not__ store the terminal+-- checksum digit of the identification number it represents.+--+-- To compute the checksum digit, use 'checksum'.+--+data ID = ID+  { c0 :: !Letter+  , c1 :: !Digit1289+  , c2 :: !Digit+  , c3 :: !Digit+  , c4 :: !Digit+  , c5 :: !Digit+  , c6 :: !Digit+  , c7 :: !Digit+  , c8 :: !Digit+  }+  deriving stock (Eq, Ord, Generic)+  deriving anyclass Finitary++instance Read ID where+  readPrec = parens $ prec 10 $ do+    Ident  "ID"         <- lexP+    Symbol "."          <- lexP+    Ident  "fromSymbol" <- lexP+    Punc   "@"          <- lexP+    unsafeFromText <$> readPrec++instance Show ID where+  showsPrec d s =+    showParen (d > 10) $+      showString "ID.fromSymbol @" . shows (toText s)++--------------------------------------------------------------------------------+-- Construction+--------------------------------------------------------------------------------++-- | Constructs an 'ID' from a type-level textual symbol.+--+-- The symbol must be exactly 10 characters in length and of the form+-- __@A123456789@__:+--+-- >>> ID.fromSymbol @"A123456789"+-- ID.fromSymbol @"A123456789"+--+-- More precisely:+--+--  - the symbol must match the regular expression __@^[A-Z][1289][0-9]{8}$@__+--  - the resultant ID must have a valid checksum.+--+-- Failure to satisfy these constraints will result in one of the following+-- __type errors__:+--+-- === Invalid lengths+--+-- >>> ID.fromSymbol @"A12345678"+-- ...+-- ... An ID must have exactly 10 characters.+-- ...+--+-- === Invalid checksums+--+-- >>> ID.fromSymbol @"A123456780"+-- ...+-- ... ID has invalid checksum.+-- ...+--+-- === Invalid characters+--+-- On detection of an invalid character, the resulting type error reports+-- both the position of the character and the set of characters permitted+-- at that position.+--+-- >>> ID.fromSymbol @"_123456789"+-- ...+--     • "_123456789"+--        ^+--       Character at this position must be an uppercase letter.+-- ...+--+-- >>> ID.fromSymbol @"A_23456789"+-- ...+--     • "A_23456789"+--         ^+--       Character at this position must be a digit from the set {1, 2, 8, 9}.+-- ...+--+-- >>> ID.fromSymbol @"A1_3456789"+-- ...+--     • "A1_3456789"+--          ^+--       Character at this position must be a digit in the range [0 .. 9].+-- ...+--+-- === Missing or empty symbols+--+-- >>> ID.fromSymbol+-- ...+-- ... Expected a type-level symbol of the form "A123456789".+-- ...+--+-- >>> ID.fromSymbol @""+-- ...+-- ... Expected a type-level symbol of the form "A123456789".+-- ...+--+fromSymbol :: forall (s :: Symbol). ValidID s => ID+fromSymbol = unsafeFromText $ T.pack $ symbolVal $ Proxy @s++-- | Attempts to construct an 'ID' from 'Text'.+--+-- The input must be exactly 10 characters in length and of the form+-- __@A123456789@__:+--+-- >>> ID.fromText "A123456789"+-- Right (ID.fromSymbol @"A123456789")+--+-- More precisely, the input must match the regular expression+-- __@^[A-Z][1289][0-9]{8}$@__, and the resultant ID must have a valid+-- checksum.+--+-- This function satisfies the following law:+--+-- @+-- 'fromText' ('toText' i) '==' 'Right' i+-- @+--+fromText :: Text -> Either FromTextError ID+fromText text = do+    unchecked <- first fromUncheckedError $ U.fromText text+    guard InvalidChecksum $ fromUnchecked unchecked+  where+    fromUncheckedError :: U.FromTextError -> FromTextError+    fromUncheckedError = \case+      U.InvalidChar i r ->+        InvalidChar i r+      U.InvalidLength ->+        InvalidLength++unsafeFromText :: Text -> ID+unsafeFromText t =+  case fromText t of+    Left _ -> error "unsafeFromText"+    Right i -> i++-- | Indicates an error that occurred while constructing an 'ID' from 'Text'.+--+data FromTextError++  = InvalidChar CharIndex CharSet+  -- ^ Indicates that the input text contains a character that is not allowed.+  --+  --   - `CharIndex` specifies the position of the invalid character.+  --   - `CharSet` specifies the set of characters allowed at that position.++  | InvalidChecksum+  -- ^ Indicates that the parsed identification number has an invalid checksum.++  | InvalidLength+  -- ^ Indicates that the input text has an invalid length.++  deriving stock (Eq, Ord, Show)++--------------------------------------------------------------------------------+-- Conversion+--------------------------------------------------------------------------------++-- | Converts an 'ID' to 'Text'.+--+-- The output is of the form __@A123456789@__.+--+-- This function satisfies the following law:+--+-- @+-- 'fromText' ('toText' i) '==' 'Right' i+-- @+--+toText :: ID -> Text+toText = U.toText . toUnchecked++--------------------------------------------------------------------------------+-- Validity+--------------------------------------------------------------------------------++-- | Computes the terminal checksum digit of an 'ID'.+--+checksum :: ID -> Digit+checksum (ID u0 u1 u2 u3 u4 u5 u6 u7 u8) =+  negate $ U.checksum (UncheckedID u0 u1 u2 u3 u4 u5 u6 u7 u8 0)++--------------------------------------------------------------------------------+-- Generation+--------------------------------------------------------------------------------++-- | Generates a random 'ID'.+--+generate :: MonadRandom m => m ID+generate = randomFinitary++--------------------------------------------------------------------------------+-- Inspection+--------------------------------------------------------------------------------++-- | Decodes the 'Gender' component of an 'ID'.+--+getGender :: ID -> Gender+getGender ID {c1} = fst $ decodeC1 c1++-- | Decodes the 'Issuer' component of an 'ID'.+--+getIssuer :: ID -> Issuer+getIssuer ID {c1} = snd $ decodeC1 c1++-- | Decodes the 'Region' component of an 'ID'.+--+getRegion :: ID -> Region+getRegion ID {c0} = Region.fromLetter c0++--------------------------------------------------------------------------------+-- Modification+--------------------------------------------------------------------------------++-- | Updates the 'Gender' component of an 'ID'.+--+setGender :: Gender -> ID -> ID+setGender gender i = i {c1 = encodeC1 (gender, getIssuer i)}++-- | Updates the 'Issuer' component of an 'ID'.+--+setIssuer :: Issuer -> ID -> ID+setIssuer issuer i = i {c1 = encodeC1 (getGender i, issuer)}++-- | Updates the 'Region' component of an 'ID'.+--+setRegion :: Region -> ID -> ID+setRegion region i = i {c0 = Region.toLetter region}++--------------------------------------------------------------------------------+-- Internal+--------------------------------------------------------------------------------++decodeC1 :: Digit1289 -> (Gender, Issuer)+decodeC1 = \case+  D1289_1 -> (  Male, HouseholdRegistrationOffice)+  D1289_2 -> (Female, HouseholdRegistrationOffice)+  D1289_8 -> (  Male,   NationalImmigrationAgency)+  D1289_9 -> (Female,   NationalImmigrationAgency)++encodeC1 :: (Gender, Issuer) -> Digit1289+encodeC1 = \case+  (  Male, HouseholdRegistrationOffice) -> D1289_1+  (Female, HouseholdRegistrationOffice) -> D1289_2+  (  Male,   NationalImmigrationAgency) -> D1289_8+  (Female,   NationalImmigrationAgency) -> D1289_9++fromUnchecked :: UncheckedID -> Maybe ID+fromUnchecked u@(UncheckedID u0 u1 u2 u3 u4 u5 u6 u7 u8 _) =+    case U.checksumValidity u of+      U.ChecksumValid   -> Just i+      U.ChecksumInvalid -> Nothing+  where+    i = ID u0 u1 u2 u3 u4 u5 u6 u7 u8++toUnchecked :: ID -> UncheckedID+toUnchecked i@(ID u0 u1 u2 u3 u4 u5 u6 u7 u8) =+  UncheckedID u0 u1 u2 u3 u4 u5 u6 u7 u8 (checksum i)

@@ -0,0 +1,13 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Taiwan.ID.CharIndex+  ( CharIndex (..)+  )+  where++-- | Specifies the zero-based position of a character within a string.+--+newtype CharIndex = CharIndex Int+  deriving stock (Read, Show)+  deriving newtype (Enum, Eq, Num, Ord)

@@ -0,0 +1,18 @@+{-# LANGUAGE DerivingStrategies #-}++module Taiwan.ID.CharSet+  ( CharSet (..)+  )+  where++import Data.Set.NonEmpty+  ( NESet )++-- | Specifies a set of characters.+--+data CharSet+  = CharSet (NESet Char)+  -- ^ An explicit set of characters.+  | CharRange Char Char+  -- ^ An inclusive range of characters.+  deriving stock (Eq, Ord, Read, Show)

@@ -0,0 +1,119 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Taiwan.ID.Digit+  ( Digit (..)+  , fromChar+  , toChar+  , generate+  , FromChar+  , FromNat+  , ToNat+  ) where++import Control.Monad.Random+  ( MonadRandom )+import Data.Finitary+  ( Finitary )+import GHC.Generics+  ( Generic )+import GHC.TypeNats+  ( Nat )+import Taiwan.ID.Utilities+  ( maybeFinitary, randomFinitary )+import Text.Read+  ( Read (readPrec), readMaybe )++import Prelude hiding+  ( fromIntegral )++import qualified Prelude++-- | Represents a single decimal digit in the range @0@ to @9@.+--+data Digit+  = D0 | D1 | D2 | D3 | D4 | D5 | D6 | D7 | D8 | D9+  deriving stock (Bounded, Enum, Eq, Generic, Ord)+  deriving anyclass Finitary++-- | Arithmetic modulo 10.+--+instance Num Digit where+  a + b = fromIntegral (fromEnum a + fromEnum b)+  a * b = fromIntegral (fromEnum a * fromEnum b)+  a - b = fromIntegral (fromEnum a - fromEnum b)+  abs a = a+  fromInteger = fromIntegral+  signum D0 = D0+  signum __ = D1++instance Read Digit where readPrec = fromInteger <$> readPrec++instance Show Digit where show = show . fromEnum++-- | Attempts to parse a 'Digit' from a character.+--+-- The 'Char' must be a decimal digit in the range @0@ to @9@.+--+fromChar :: Char -> Maybe Digit+fromChar c = readMaybe [c] >>= maybeFinitary++-- | Converts a 'Digit' to a decimal digit character.+--+toChar :: Digit -> Char+toChar digit = case show digit of+  [c] -> c+  _ -> error "toChar"++-- | Creates a 'Digit' from an integral number (modulo 10).+--+fromIntegral :: Integral i => i -> Digit+fromIntegral i = toEnum (Prelude.fromIntegral (i `mod` 10))++-- | Generates a random digit.+--+generate :: MonadRandom m => m Digit+generate = randomFinitary++type family FromChar (c :: Char) :: Maybe Digit where+  FromChar '0' = Just D0+  FromChar '1' = Just D1+  FromChar '2' = Just D2+  FromChar '3' = Just D3+  FromChar '4' = Just D4+  FromChar '5' = Just D5+  FromChar '6' = Just D6+  FromChar '7' = Just D7+  FromChar '8' = Just D8+  FromChar '9' = Just D9+  FromChar _   = Nothing++type family FromNat (n :: Nat) :: Maybe Digit where+  FromNat 0 = Just D0+  FromNat 1 = Just D1+  FromNat 2 = Just D2+  FromNat 3 = Just D3+  FromNat 4 = Just D4+  FromNat 5 = Just D5+  FromNat 6 = Just D6+  FromNat 7 = Just D7+  FromNat 8 = Just D8+  FromNat 9 = Just D9+  FromNat _ = Nothing++type family ToNat (d :: Digit) :: Nat where+  ToNat D0 = 0+  ToNat D1 = 1+  ToNat D2 = 2+  ToNat D3 = 3+  ToNat D4 = 4+  ToNat D5 = 5+  ToNat D6 = 6+  ToNat D7 = 7+  ToNat D8 = 8+  ToNat D9 = 9

@@ -0,0 +1,94 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Taiwan.ID.Digit1289+  ( Digit1289 (..)+  , fromChar+  , toChar+  , toDigit+  , generate+  , FromChar+  , FromNat+  , ToNat+  ) where++import Control.Monad.Random+  ( MonadRandom )+import Data.Finitary+  ( Finitary )+import GHC.Generics+  ( Generic )+import GHC.TypeNats+  ( Nat )+import Taiwan.ID.Digit+  ( Digit (..) )+import Taiwan.ID.Utilities+  ( randomFinitary )++-- | Represents a single decimal digit from the set {@1@, @2@, @8@, @9@}.+--+data Digit1289+  = D1289_1 | D1289_2 | D1289_8 | D1289_9+  deriving stock (Bounded, Enum, Eq, Generic, Ord, Read, Show)+  deriving anyclass Finitary++-- | Attempts to parse a 'Digit1289' from a character.+--+-- Only the characters @'1'@, @'2'@, @'8'@, and @'9'@ are accepted.+--+fromChar :: Char -> Maybe Digit1289+fromChar = \case+  '1' -> Just D1289_1+  '2' -> Just D1289_2+  '8' -> Just D1289_8+  '9' -> Just D1289_9+  _   -> Nothing++-- | Converts a 'Digit1289' to a decimal digit character.+--+toChar :: Digit1289 -> Char+toChar = \case+  D1289_1 -> '1'+  D1289_2 -> '2'+  D1289_8 -> '8'+  D1289_9 -> '9'++-- | Converts a 'Digit1289' to an ordinary 'Digit'.+--+toDigit :: Digit1289 -> Digit+toDigit = \case+  D1289_1 -> D1+  D1289_2 -> D2+  D1289_8 -> D8+  D1289_9 -> D9++-- | Generates a random 'Digit1289'.+--+generate :: MonadRandom m => m Digit1289+generate = randomFinitary++type family FromChar (c :: Char) :: Maybe Digit1289 where+  FromChar '1' = Just D1289_1+  FromChar '2' = Just D1289_2+  FromChar '8' = Just D1289_8+  FromChar '9' = Just D1289_9+  FromChar _   = Nothing++type family FromNat (n :: Nat) :: Maybe Digit1289 where+  FromNat 1 = Just D1289_1+  FromNat 2 = Just D1289_2+  FromNat 8 = Just D1289_8+  FromNat 9 = Just D1289_9+  FromNat _ = Nothing++type family ToNat (d :: Digit1289) :: Nat where+  ToNat D1289_1 = 1+  ToNat D1289_2 = 2+  ToNat D1289_8 = 8+  ToNat D1289_9 = 9

@@ -0,0 +1,52 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Taiwan.ID.Gender+  ( Gender (..)+  , toText+  , generate+  ) where++import Control.Monad.Random.Class+  ( MonadRandom (..) )+import Data.Finitary+  ( Finitary )+import Data.Text+  ( Text )+import GHC.Generics+  ( Generic )+import Taiwan.ID.Language+  ( Language (..) )+import Taiwan.ID.Utilities+  ( randomFinitary )++-- | A person's gender.+--+data Gender = Male | Female+  deriving stock (Bounded, Enum, Eq, Generic, Ord, Read, Show)+  deriving anyclass Finitary++-- | Prints the specified 'Gender'.+--+toText :: Language -> Gender -> Text+toText = \case+  English -> toTextEnglish+  Chinese -> toTextChinese++toTextEnglish :: Gender -> Text+toTextEnglish = \case+  Male   -> "Male"+  Female -> "Female"++toTextChinese :: Gender -> Text+toTextChinese = \case+  Male   -> "男性"+  Female -> "女性"++-- | Generates a random 'Gender'.+--+generate :: MonadRandom m => m Gender+generate = randomFinitary

@@ -0,0 +1,59 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Taiwan.ID.Issuer+  ( Issuer (..)+  , toText+  , generate+  )+  where++import Control.Monad.Random.Class+  ( MonadRandom (..) )+import Data.Finitary+  ( Finitary )+import Data.Text+  ( Text )+import GHC.Generics+  ( Generic )+import Taiwan.ID.Language+  ( Language (English, Chinese) )+import Taiwan.ID.Utilities+  ( randomFinitary )++-- | A government authority that issues identification numbers.+--+data Issuer+  = HouseholdRegistrationOffice+  | NationalImmigrationAgency+  deriving stock (Bounded, Enum, Eq, Ord, Generic, Read, Show)+  deriving anyclass Finitary++-- | Generates a random 'Issuer'.+--+generate :: MonadRandom m => m Issuer+generate = randomFinitary++-- | Prints the specified 'Issuer'.+--+toText :: Language -> Issuer -> Text+toText = \case+  English -> toTextEnglish+  Chinese -> toTextChinese++toTextChinese :: Issuer -> Text+toTextChinese = \case+  HouseholdRegistrationOffice ->+    "戶政事務所"+  NationalImmigrationAgency ->+    "移民署"++toTextEnglish :: Issuer -> Text+toTextEnglish = \case+  HouseholdRegistrationOffice ->+    "Household Registration Office"+  NationalImmigrationAgency ->+    "National Immigration Agency"

@@ -0,0 +1,7 @@+{-# LANGUAGE DerivingStrategies #-}++module Taiwan.ID.Language where++-- | A language into which values can be localized when pretty printing.+data Language = English | Chinese+  deriving stock (Bounded, Enum, Eq, Ord, Read, Show)

@@ -0,0 +1,69 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Taiwan.ID.Letter+  ( Letter (..)+  , fromChar+  , toChar+  , generate+  , FromChar+  ) where++import Control.Monad.Random.Class+  ( MonadRandom (..) )+import Data.Finitary+  ( Finitary )+import GHC.Generics+  ( Generic )+import Taiwan.ID.Utilities+  ( randomFinitary )+import Text.Read+  ( readMaybe )++-- | Represents a letter in the latin alphabet.+--+data Letter+  = A | B | C | D | E | F | G | H | I | J | K | L | M+  | N | O | P | Q | R | S | T | U | V | W | X | Y | Z+  deriving stock (Bounded, Enum, Eq, Generic, Ord, Read, Show)+  deriving anyclass Finitary++-- | Attempts to parse a 'Letter' from a character.+--+-- Returns 'Nothing' if the specified character is not an uppercase alphabetic+-- character.+--+fromChar :: Char -> Maybe Letter+fromChar c = readMaybe [c]++-- | Converts the specified 'Letter' to a character.+--+toChar :: Letter -> Char+toChar letter = case show letter of+  [c] -> c+  _ -> error "toChar"++-- | Generates a random 'Letter'.+--+generate :: MonadRandom m => m Letter+generate = randomFinitary++type family FromChar (c :: Char) :: Maybe Letter where+  FromChar 'A' = Just A; FromChar 'N' = Just N+  FromChar 'B' = Just B; FromChar 'O' = Just O+  FromChar 'C' = Just C; FromChar 'P' = Just P+  FromChar 'D' = Just D; FromChar 'Q' = Just Q+  FromChar 'E' = Just E; FromChar 'R' = Just R+  FromChar 'F' = Just F; FromChar 'S' = Just S+  FromChar 'G' = Just G; FromChar 'T' = Just T+  FromChar 'H' = Just H; FromChar 'U' = Just U+  FromChar 'I' = Just I; FromChar 'V' = Just V+  FromChar 'J' = Just J; FromChar 'W' = Just W+  FromChar 'K' = Just K; FromChar 'X' = Just X+  FromChar 'L' = Just L; FromChar 'Y' = Just Y+  FromChar 'M' = Just M; FromChar 'Z' = Just Z+  FromChar _ = Nothing

@@ -0,0 +1,223 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Taiwan.ID.Region+  ( Region+  , fromChar+  , fromLetter+  , toChar+  , toLetter+  , toText+  , generate+  ) where++import Control.Monad.Random.Class+  ( MonadRandom (..) )+import Data.Finitary+  ( Finitary )+import Data.Text+  ( Text )+import GHC.Generics+  ( Generic )+import Taiwan.ID.Language+  ( Language (..) )+import Taiwan.ID.Letter+  ( Letter (..) )+import Taiwan.ID.Utilities+  ( randomFinitary )+import Text.Read+  ( Lexeme (Ident, Symbol), Read (readPrec), lexP, parens, prec )++import qualified Taiwan.ID.Letter as Letter++-- |+-- $setup+-- >>> import qualified Taiwan.ID.Region as Region++-- | Represents a geographical region.+--+-- == Region codes+--+-- Every region has a unique letter code:+--+-- +------+---------+-------------------++-- | Code | Chinese | English           |+-- +======+=========+===================++-- | @A@  | 臺北市     | Taipei City       |+-- +------+---------+-------------------++-- | @B@  | 臺中市     | Taichung City     |+-- +------+---------+-------------------++-- | @C@  | 基隆市     | Keelung City      |+-- +------+---------+-------------------++-- | @D@  | 臺南市     | Tainan City       |+-- +------+---------+-------------------++-- | @E@  | 高雄市     | Kaohsiung City    |+-- +------+---------+-------------------++-- | @F@  | 新北市     | New Taipei City   |+-- +------+---------+-------------------++-- | @G@  | 宜蘭縣     | Yilan County      |+-- +------+---------+-------------------++-- | @H@  | 桃園市     | Taoyuan City      |+-- +------+---------+-------------------++-- | @I@  | 嘉義市     | Chiayi City       |+-- +------+---------+-------------------++-- | @J@  | 新竹縣     | Hsinchu County    |+-- +------+---------+-------------------++-- | @K@  | 苗栗縣     | Miaoli County     |+-- +------+---------+-------------------++-- | @L@  | 臺中縣     | Taichung County   |+-- +------+---------+-------------------++-- | @M@  | 南投縣     | Nantou County     |+-- +------+---------+-------------------++-- | @N@  | 彰化縣     | Changhua County   |+-- +------+---------+-------------------++-- | @O@  | 新竹市     | Hsinchu City      |+-- +------+---------+-------------------++-- | @P@  | 雲林縣     | Yunlin County     |+-- +------+---------+-------------------++-- | @Q@  | 嘉義縣     | Chiayi County     |+-- +------+---------+-------------------++-- | @R@  | 臺南縣     | Tainan County     |+-- +------+---------+-------------------++-- | @S@  | 高雄縣     | Kaohsiung County  |+-- +------+---------+-------------------++-- | @T@  | 屏東縣     | Pingtung County   |+-- +------+---------+-------------------++-- | @U@  | 花蓮縣     | Hualien County    |+-- +------+---------+-------------------++-- | @V@  | 臺東縣     | Taitung County    |+-- +------+---------+-------------------++-- | @W@  | 金門縣     | Kinmen County     |+-- +------+---------+-------------------++-- | @X@  | 澎湖縣     | Penghu County     |+-- +------+---------+-------------------++-- | @Y@  | 陽明山     | Yangmingshan      |+-- +------+---------+-------------------++-- | @Z@  | 連江縣     | Lienchiang County |+-- +------+---------+-------------------++--+-- == Usage+--+-- To construct a 'Region' from its letter code, use the 'fromLetter'+-- function.+--+-- To print the full name of a 'Region', use the 'toText' function.+--+-- To generate a random 'Region', use the 'generate' function.+--+newtype Region = Region Letter+  deriving stock (Eq, Generic, Ord)+  deriving newtype (Bounded, Enum)+  deriving anyclass Finitary++instance Read Region where+  readPrec = parens $ prec 10 $ do+    Ident "Region"     <- lexP+    Symbol "."         <- lexP+    Ident "fromLetter" <- lexP+    fromLetter <$> readPrec++instance Show Region where+  showsPrec d s =+    showParen (d > 10) $+      showString "Region.fromLetter " . shows (toLetter s)++-- | Attempts to construct a 'Region' from its corresponding letter code as a+-- 'Char'.+--+-- >>> Region.fromChar 'A'+-- Just (Region.fromLetter A)+--+-- >>> Region.fromChar '?'+-- Nothing+--+fromChar :: Char -> Maybe Region+fromChar = fmap fromLetter . Letter.fromChar++-- | Constructs a 'Region' from its corresponding letter code.+--+fromLetter :: Letter -> Region+fromLetter = Region++-- | Converts a 'Region' to its corresponding letter code as a 'Char'.+--+toChar :: Region -> Char+toChar = Letter.toChar . toLetter++-- | Converts a 'Region' to its corresponding letter code.+--+toLetter :: Region -> Letter+toLetter (Region letter) = letter++-- | Prints the specified 'Region'.+toText :: Language -> Region -> Text+toText = \case+  English -> toTextEnglish+  Chinese -> toTextChinese++toTextChinese :: Region -> Text+toTextChinese (Region letter) = case letter of+  A -> "臺北市"+  B -> "臺中市"+  C -> "基隆市"+  D -> "臺南市"+  E -> "高雄市"+  F -> "新北市"+  G -> "宜蘭縣"+  H -> "桃園市"+  I -> "嘉義市"+  J -> "新竹縣"+  K -> "苗栗縣"+  L -> "臺中縣"+  M -> "南投縣"+  N -> "彰化縣"+  O -> "新竹市"+  P -> "雲林縣"+  Q -> "嘉義縣"+  R -> "臺南縣"+  S -> "高雄縣"+  T -> "屏東縣"+  U -> "花蓮縣"+  V -> "臺東縣"+  W -> "金門縣"+  X -> "澎湖縣"+  Y -> "陽明山"+  Z -> "連江縣"++toTextEnglish :: Region -> Text+toTextEnglish (Region letter) = case letter of+  A -> "Taipei City"+  B -> "Taichung City"+  C -> "Keelung City"+  D -> "Tainan City"+  E -> "Kaohsiung City"+  F -> "New Taipei City"+  G -> "Yilan County"+  H -> "Taoyuan City"+  I -> "Chiayi City"+  J -> "Hsinchu County"+  K -> "Miaoli County"+  L -> "Taichung County"+  M -> "Nantou County"+  N -> "Changhua County"+  O -> "Hsinchu City"+  P -> "Yunlin County"+  Q -> "Chiayi County"+  R -> "Tainan County"+  S -> "Kaohsiung County"+  T -> "Pingtung County"+  U -> "Hualien County"+  V -> "Taitung County"+  W -> "Kinmen County"+  X -> "Penghu County"+  Y -> "Yangmingshan"+  Z -> "Lienchiang County"++-- | Generates a random 'Region'.+--+generate :: MonadRandom m => m Region+generate = randomFinitary

@@ -0,0 +1,315 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}++module Taiwan.ID.Unchecked+  ( UncheckedID (..)+  , UncheckedIDTuple+  , FromTextError (..)+  , fromText+  , toText+  , checksum+  , checksumValidity+  , ChecksumValidity (..)+  , ValidID+  )+  where++import Control.Monad+  ( when )+import Data.Kind+  ( Constraint )+import Data.List.NonEmpty+  ( NonEmpty ((:|)) )+import Data.Text+  ( Text )+import Data.Type.Bool+  ( If )+import Data.Type.Equality+  ( type (==) )+import GHC.TypeError+  ( Assert, TypeError )+import GHC.TypeLits+  ( AppendSymbol, KnownSymbol, Symbol )+import GHC.TypeNats+  ( CmpNat, Mod, Nat, type (+) )+import Taiwan.ID.CharIndex+  ( CharIndex (..) )+import Taiwan.ID.CharSet+  ( CharSet (..) )+import Taiwan.ID.Digit+  ( Digit (..) )+import Taiwan.ID.Digit1289+  ( Digit1289 (..) )+import Taiwan.ID.Letter+  ( Letter (..) )+import Taiwan.ID.Utilities+  ( FromJust, Fst, ReplicateChar, Snd, SymbolLength, SymbolToCharList, guard )++import qualified Data.Set.NonEmpty as NESet+import qualified Data.Text as T+import qualified GHC.TypeError as TypeError+import qualified GHC.TypeNats as N+import qualified Taiwan.ID.Digit as Digit+import qualified Taiwan.ID.Digit1289 as Digit1289+import qualified Taiwan.ID.Letter as Letter++data UncheckedID = UncheckedID+  { c0 :: !Letter+  , c1 :: !Digit1289+  , c2 :: !Digit+  , c3 :: !Digit+  , c4 :: !Digit+  , c5 :: !Digit+  , c6 :: !Digit+  , c7 :: !Digit+  , c8 :: !Digit+  , c9 :: !Digit+  }+  deriving stock (Eq, Ord, Show)++type UncheckedIDTuple =+  ( Letter+  , Digit1289+  , Digit+  , Digit+  , Digit+  , Digit+  , Digit+  , Digit+  , Digit+  , Digit+  )++data FromTextError+  = InvalidChar CharIndex CharSet+  | InvalidLength+  deriving stock (Eq, Ord, Read, Show)++type Parser a = Text -> Either FromTextError (Text, a)++fromText :: Text -> Either FromTextError UncheckedID+fromText text0 = do+    when (T.length text0 > 10) $ Left InvalidLength+    (text1,  c0                             ) <- parseLetter    text0+    (text2,  c1                             ) <- parseDigit1289 text1+    (_____, (c2, c3, c4, c5, c6, c7, c8, c9)) <- parseDigits    text2+    pure UncheckedID {c0, c1, c2, c3, c4, c5, c6, c7, c8, c9}+  where+    parseLetter :: Parser Letter+    parseLetter text = do+      (char, remainder) <- guard InvalidLength $ T.uncons text+      letter <- guard (InvalidChar 0 (CharRange 'A' 'Z')) (Letter.fromChar char)+      pure (remainder, letter)++    parseDigit1289 :: Parser Digit1289+    parseDigit1289 text = do+      (char, remainder) <- guard InvalidLength $ T.uncons text+      digit1289 <- guard+        (InvalidChar 1 (CharSet $ NESet.fromList $ '1' :| ['2', '8', '9']))+        (Digit1289.fromChar char)+      pure (remainder, digit1289)++    parseDigits :: d ~ Digit => Parser (d, d, d, d, d, d, d, d)+    parseDigits text = do+        let (chars, remainder) = T.splitAt 8 text+        digitList <- traverse parseIndexedDigit (zip [2 ..] $ T.unpack chars)+        digitTuple <- guard InvalidLength (listToTuple8 digitList)+        pure (remainder, digitTuple)+      where+        parseIndexedDigit (i, c) =+          guard (InvalidChar i (CharRange '0' '9')) (Digit.fromChar c)++toText :: UncheckedID -> Text+toText UncheckedID {c0, c1, c2, c3, c4, c5, c6, c7, c8, c9} =+  T.pack+    ( Letter.toChar c0+    : Digit1289.toChar c1+    : fmap Digit.toChar [c2, c3, c4, c5, c6, c7, c8, c9]+    )++checksum :: UncheckedID -> Digit+checksum (UncheckedID u0 (Digit1289.toDigit -> u1) u2 u3 u4 u5 u6 u7 u8 u9) =+  sum $ zipWith (*)+    [ 1,  9,  8,  7,  6,  5,  4,  3,  2,  1,  1]+    [a0, a1, u1, u2, u3, u4, u5, u6, u7, u8, u9]+  where+    (a0, a1) = checksumLetterToDigitPair u0++checksumLetterToDigitPair :: Letter -> (Digit, Digit)+checksumLetterToDigitPair = \case+  A -> (1, 0); N -> (2, 2)+  B -> (1, 1); O -> (3, 5)+  C -> (1, 2); P -> (2, 3)+  D -> (1, 3); Q -> (2, 4)+  E -> (1, 4); R -> (2, 5)+  F -> (1, 5); S -> (2, 6)+  G -> (1, 6); T -> (2, 7)+  H -> (1, 7); U -> (2, 8)+  I -> (3, 4); V -> (2, 9)+  J -> (1, 8); W -> (3, 2)+  K -> (1, 9); X -> (3, 0)+  L -> (2, 0); Y -> (3, 1)+  M -> (2, 1); Z -> (3, 3)++data ChecksumValidity+  = ChecksumValid+  | ChecksumInvalid+  deriving stock (Eq, Show)++checksumValidity :: UncheckedID -> ChecksumValidity+checksumValidity u =+  case checksum u of+    0 -> ChecksumValid+    _ -> ChecksumInvalid++listToTuple8 :: [a] -> Maybe (a, a, a, a, a, a, a, a)+listToTuple8 = \case+  [a0, a1, a2, a3, a4, a5, a6, a7] ->+    Just (a0, a1, a2, a3, a4, a5, a6, a7)+  _ ->+    Nothing++type family ChecksumValid (id :: UncheckedIDTuple) :: Constraint where+  ChecksumValid id =+    Assert+      (ChecksumDigit id == D0)+      (TypeError (TypeError.Text "ID has invalid checksum."))++type family ChecksumDigit (id :: UncheckedIDTuple) :: Digit where+  ChecksumDigit id = ChecksumDigitFromNat (Mod (Checksum id) 10)++type family ChecksumDigitFromNat (n :: Nat) :: Digit where+  ChecksumDigitFromNat n =+    FromJust+      (Digit.FromNat n)+      (TypeError (TypeError.Text "Expected natural number between 0 and 9."))++type family Checksum (id :: UncheckedIDTuple) :: Nat where+  Checksum '(c0, c1, c2, c3, c4, c5, c6, c7, c8, c9) =+    (     (ChecksumLetterToNat0 c0 N.* 1)+      N.+ (ChecksumLetterToNat1 c0 N.* 9)+      N.+ (Digit1289.ToNat      c1 N.* 8)+      N.+ (Digit.ToNat          c2 N.* 7)+      N.+ (Digit.ToNat          c3 N.* 6)+      N.+ (Digit.ToNat          c4 N.* 5)+      N.+ (Digit.ToNat          c5 N.* 4)+      N.+ (Digit.ToNat          c6 N.* 3)+      N.+ (Digit.ToNat          c7 N.* 2)+      N.+ (Digit.ToNat          c8 N.* 1)+      N.+ (Digit.ToNat          c9 N.* 1)+    )++type family ChecksumLetterToNat0 (letter :: Letter) :: Nat where+  ChecksumLetterToNat0 x = Fst (ChecksumLetterToNatPair x)++type family ChecksumLetterToNat1 (letter :: Letter) :: Nat where+  ChecksumLetterToNat1 x = Snd (ChecksumLetterToNatPair x)++type family ChecksumLetterToNatPair (l :: Letter) :: (Nat, Nat) where+  ChecksumLetterToNatPair A = '(1, 0); ChecksumLetterToNatPair B = '(1, 1)+  ChecksumLetterToNatPair C = '(1, 2); ChecksumLetterToNatPair D = '(1, 3)+  ChecksumLetterToNatPair E = '(1, 4); ChecksumLetterToNatPair F = '(1, 5)+  ChecksumLetterToNatPair G = '(1, 6); ChecksumLetterToNatPair H = '(1, 7)+  ChecksumLetterToNatPair I = '(3, 4); ChecksumLetterToNatPair J = '(1, 8)+  ChecksumLetterToNatPair K = '(1, 9); ChecksumLetterToNatPair L = '(2, 0)+  ChecksumLetterToNatPair M = '(2, 1); ChecksumLetterToNatPair N = '(2, 2)+  ChecksumLetterToNatPair O = '(3, 5); ChecksumLetterToNatPair P = '(2, 3)+  ChecksumLetterToNatPair Q = '(2, 4); ChecksumLetterToNatPair R = '(2, 5)+  ChecksumLetterToNatPair S = '(2, 6); ChecksumLetterToNatPair T = '(2, 7)+  ChecksumLetterToNatPair U = '(2, 8); ChecksumLetterToNatPair V = '(2, 9)+  ChecksumLetterToNatPair W = '(3, 2); ChecksumLetterToNatPair X = '(3, 0)+  ChecksumLetterToNatPair Y = '(3, 1); ChecksumLetterToNatPair Z = '(3, 3)++type family SymbolToId (s :: Symbol) :: UncheckedIDTuple where+  SymbolToId s =+    IdFromCharList s (SymbolToCharList s)++type family+    IdFromCharList (id :: Symbol) (xs :: [Char]) :: UncheckedIDTuple+  where+    IdFromCharList id '[c0, c1, c2, c3, c4, c5, c6, c7, c8, c9] =+      '( LetterFromChar    id 0 c0+       , Digit1289FromChar id 1 c1+       , DigitFromChar     id 2 c2+       , DigitFromChar     id 3 c3+       , DigitFromChar     id 4 c4+       , DigitFromChar     id 5 c5+       , DigitFromChar     id 6 c6+       , DigitFromChar     id 7 c7+       , DigitFromChar     id 8 c8+       , DigitFromChar     id 9 c9+       )+    IdFromCharList _ _ =+      TypeError (TypeError.Text "An ID must have exactly 10 characters.")++type family+    DigitFromChar (id :: Symbol) (index :: Nat) (c :: Char) :: Digit+  where+    DigitFromChar id index c =+      FromJust+        (Digit.FromChar c)+        (InvalidCharError id index DigitTypeError)++type family+    Digit1289FromChar (id :: Symbol) (index :: Nat) (c :: Char) :: Digit1289+  where+    Digit1289FromChar id index c =+      FromJust+        (Digit1289.FromChar c)+        (InvalidCharError id index Digit1289TypeError)++type family+    LetterFromChar (id :: Symbol) (index :: Nat) (c :: Char) :: Letter+  where+    LetterFromChar id index c =+      FromJust+        (Letter.FromChar c)+        (InvalidCharError id index LetterTypeError)++type DigitTypeError =+  "Character at this position must be a digit in the range [0 .. 9]."++type Digit1289TypeError =+  "Character at this position must be a digit from the set {1, 2, 8, 9}."++type LetterTypeError =+  "Character at this position must be an uppercase letter."++type family InvalidCharError+    (invalidId :: Symbol) (charIndex :: Nat) (message :: Symbol)+  where+    InvalidCharError invalidId charIndex message =+      TypeError+        ( TypeError.ShowType invalidId+          TypeError.:$$:+          TypeError.Text (ReplicateChar (charIndex + 1) ' ' `AppendSymbol` "^")+          TypeError.:$$:+          TypeError.Text message+        )++type ValidID s =+  ( KnownSymbol s+  , ChecksumValid (SymbolToId (ConcreteSymbol s))+  ) :: Constraint++-- | Ensures the existence of a concrete symbol, or else raises a type error.+--+type family ConcreteSymbol (s :: Symbol) :: Symbol where+  -- If we can compute the symbol's length, then we have a concrete symbol.+  ConcreteSymbol s =+    If+      (CmpNat (SymbolLength s) 0 == GT)+      s+      (TypeError (TypeError.Text ConcreteSymbolError))++type ConcreteSymbolError =+  "Expected a type-level symbol of the form \"A123456789\"."

@@ -0,0 +1,90 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Taiwan.ID.Utilities where++import Control.Monad.Random.Class+  ( MonadRandom (..) )+import Data.Finitary+  ( Finitary (fromFinite), Cardinality )+import Data.Finite+  ( packFinite )+import Data.Maybe+  ( fromMaybe )+import Data.Proxy+  ( Proxy (Proxy) )+import GHC.TypeLits+  ( Symbol, UnconsSymbol, ConsSymbol, type (<=), type (+) )+import GHC.TypeNats+  ( Nat, type (-), natVal )+import Numeric.Natural+  ( Natural )++cardinality :: forall a. Finitary a => Natural+cardinality = natVal $ Proxy @(Cardinality a)++guard :: x -> Maybe y -> Either x y+guard x = maybe (Left x) Right++maybeFinitary :: forall a. Finitary a => Natural -> Maybe a+maybeFinitary = fmap fromFinite . packFinite . fromIntegral @Natural @Integer++randomFinitary+  :: forall m a. (MonadRandom m, Finitary a, 1 <= Cardinality a) => m a+randomFinitary =+    fromMaybe failure . maybeFinitary <$> randomNatural (0, cardinality @a - 1)+  where+    failure = error "randomFinitary: unexpected out-of-bounds value"++randomNatural :: MonadRandom m => (Natural, Natural) -> m Natural+randomNatural (lo, hi) =+  fromIntegral @Integer @Natural <$>+    getRandomR+      ( fromIntegral @Natural @Integer lo+      , fromIntegral @Natural @Integer hi+      )++type family FromJust (m :: Maybe a) e where+  FromJust Nothing e = e+  FromJust (Just a) _ = a++type family Fst (t :: (a, a)) :: a where+  Fst '(x, _) = x++type family Snd (t :: (a, a)) :: a where+  Snd '(_, y) = y++type family ListLength (as :: [a]) :: Nat where+  ListLength as = ListLengthInner 0 as++type family ListLengthInner (n :: Nat) (as :: [a]) :: Nat where+  ListLengthInner n '[] = n+  ListLengthInner n (a : as) = ListLengthInner (n + 1) as++type family SymbolLength (s :: Symbol) :: Nat where+  SymbolLength s = ListLength (SymbolToCharList s)++type family+    SymbolToCharList (s :: Symbol) :: [Char]+  where+    SymbolToCharList s = MaybeCharSymbolToCharList (UnconsSymbol s)++type family+  MaybeCharSymbolToCharList+    (m :: Maybe (Char, Symbol)) :: [Char]+  where+    MaybeCharSymbolToCharList ('Just '(c, rest)) = c ': SymbolToCharList rest+    MaybeCharSymbolToCharList 'Nothing = '[]++type family ReplicateChar (n :: Nat) (c :: Char) :: Symbol where+  ReplicateChar n c = ReplicateChar' "" n c++type family ReplicateChar' (s :: Symbol) (n :: Nat) (c :: Char) :: Symbol where+  ReplicateChar' s 0 _ = s+  ReplicateChar' s n c = ReplicateChar' (ConsSymbol c s) (n - 1) c

@@ -1,9 +0,0 @@-module Main where--import Build_doctests-  ( flags, pkgs, module_sources )-import Test.DocTest-  ( doctest )--main :: IO ()-main = doctest (flags ++ pkgs ++ module_sources)

@@ -1,340 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeOperators #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-{- HLINT ignore "Redundant bracket" -}--module Main where--import Data.Bifunctor-  ( Bifunctor (second) )-import Data.Char-  ( intToDigit )-import Data.List.NonEmpty-  ( NonEmpty ((:|)) )-import Data.Text-  ( Text )-import Lens.Micro-  ( Lens', lens, set )-import Lens.Micro.Extras-  ( view )-import Taiwan.ID-  ( ID (..) )-import Taiwan.ID.CharIndex-  ( CharIndex (CharIndex) )-import Taiwan.ID.CharSet-  ( CharSet (..) )-import Taiwan.ID.Digit-  ( Digit (..) )-import Taiwan.ID.Digit1289-  ( Digit1289 (..) )-import Taiwan.ID.Gender-  ( Gender (..) )-import Taiwan.ID.Issuer-  ( Issuer (..) )-import Taiwan.ID.Letter-  ( Letter (..) )-import Taiwan.ID.Region-  ( Region )-import Test.Hspec-  ( Spec, describe, hspec, it, shouldBe, shouldSatisfy )-import Test.QuickCheck-  ( Arbitrary (..)-  , NonEmptyList (..)-  , Property-  , arbitraryBoundedEnum-  , choose-  , elements-  , forAll-  , property-  , shrinkBoundedEnum-  , shrinkMap-  , (===)-  )-import Test.QuickCheck.Classes-  ( boundedEnumLaws, eqLaws, numLaws, ordLaws, showLaws, showReadLaws )-import Test.QuickCheck.Classes.Hspec-  ( testLawsMany )--import qualified Data.Finitary as Finitary-import qualified Data.Set.NonEmpty as NESet-import qualified Data.Text as T-import qualified Taiwan.ID as ID--instance Arbitrary Digit where-  arbitrary = arbitraryBoundedEnum-  shrink = shrinkBoundedEnum--instance Arbitrary Digit1289 where-  arbitrary = arbitraryBoundedEnum-  shrink = shrinkBoundedEnum--instance Arbitrary Gender where-  arbitrary = arbitraryBoundedEnum-  shrink = shrinkBoundedEnum--instance Arbitrary ID where-  arbitrary = idFromTuple <$> arbitrary-  shrink = shrinkMap idFromTuple idToTuple--instance Arbitrary Issuer where-  arbitrary = arbitraryBoundedEnum-  shrink = shrinkBoundedEnum--instance Arbitrary Letter where-  arbitrary = arbitraryBoundedEnum-  shrink = shrinkBoundedEnum--instance Arbitrary Region where-  arbitrary = arbitraryBoundedEnum-  shrink = shrinkBoundedEnum--main :: IO ()-main = hspec $ do--  describe "Class laws" $ do--    testLawsMany @Digit-        [ boundedEnumLaws-        , eqLaws-        , numLaws-        , ordLaws-        , showLaws-        , showReadLaws-        ]--    testLawsMany @Gender-        [ boundedEnumLaws-        , eqLaws-        , ordLaws-        , showLaws-        , showReadLaws-        ]--    testLawsMany @ID-        [ eqLaws-        , ordLaws-        , showLaws-        , showReadLaws-        ]--    testLawsMany @Issuer-        [ boundedEnumLaws-        , eqLaws-        , ordLaws-        , showLaws-        , showReadLaws-        ]--    testLawsMany @Region-        [ boundedEnumLaws-        , eqLaws-        , ordLaws-        , showLaws-        , showReadLaws-        ]--  describe "Finitary instances" $ do--    describe "ID" $ do--      let start    = Finitary.start    @ID-          end      = Finitary.end      @ID-          previous = Finitary.previous @ID-          next     = Finitary.next     @ID--      it "previous start" $-          previous start-            `shouldBe` Nothing--      it "start" $-          start-            `shouldBe` ID.fromSymbol @"A100000001"--      it "next start" $-          next start-            `shouldBe` Just (ID.fromSymbol @"A100000010")--      it "previous end" $-          previous end-            `shouldBe` Just (ID.fromSymbol @"Z999999987")--      it "end" $-          end-            `shouldBe` ID.fromSymbol @"Z999999996"--      it "next end" $-          next end-            `shouldBe` Nothing--  describe "ID attribute getters and setters" $ do--    describe "Gender" $-      checkLensLaws gender-    describe "Issuer" $-      checkLensLaws issuer-    describe "Region" $-      checkLensLaws region--  describe "ID.fromText" $ do--    it "successfully parses known-valid identification numbers" $-      forAll (elements knownValidIDs) $ \i ->-        ID.fromText (ID.toText i) `shouldBe` Right i--    it "successfully parses valid identification numbers" $-      property $ \(i :: ID) ->-        ID.fromText (ID.toText i) `shouldBe` Right i--    it "does not parse identification numbers that are too short" $-      property $ \(i :: ID) n -> do-        let newLength = n `mod` 10-        let invalidID = T.take newLength $ ID.toText i-        ID.fromText invalidID `shouldBe` Left ID.InvalidLength--    it "does not parse identification numbers that are too long" $-      property $ \(i :: ID) (NonEmpty s) -> do-        let invalidID = ID.toText i <> T.pack s-        ID.fromText invalidID `shouldBe` Left ID.InvalidLength--    it "does not parse identification numbers with invalid region codes" $-      property $ \(i :: ID) (c :: Int) -> do-        let invalidRegionCode = intToDigit $ c `mod` 10-        let invalidID = replaceCharAt 0 invalidRegionCode $ ID.toText i-        ID.fromText invalidID `shouldBe`-          Left (ID.InvalidChar 0 (CharRange 'A' 'Z'))--    it "does not parse identification numbers with invalid initial digits" $-      property $ \(i :: ID) ->-        forAll (elements ['0', '3', '4', '5', '6', '7']) $ \initialDigit -> do-          let invalidID = replaceCharAt 1 initialDigit (ID.toText i)-          let expectedError =-                ID.InvalidChar 1-                  (CharSet $ NESet.fromList $ '1' :| ['2', '8', '9'])-          ID.fromText invalidID `shouldBe` Left expectedError--    it "does not parse identification numbers with invalid checksums" $-      property $ \(i :: ID) (c :: Int) -> do-        let invalidChecksumDigit = intToDigit $-              ((c `mod` 9) + fromEnum (ID.checksum i) + 1) `mod` 10-        let invalidID =-              T.take 9 (ID.toText i) <> T.pack [invalidChecksumDigit]-        ID.fromText invalidID `shouldBe` Left ID.InvalidChecksum--    it "reports invalid characters even when input is too short" $-      property $ \(i :: ID) ->-      forAll (choose (1, 9)) $ \truncatedLength ->-      forAll (choose (0, truncatedLength - 1)) $ \invalidCharIndex -> do-        let textTruncated = T.take truncatedLength (ID.toText i)-        let textInvalid = replaceCharAt invalidCharIndex 'x' textTruncated-        ID.fromText textInvalid `shouldSatisfy` \case-          Left (ID.InvalidChar (CharIndex index) _)-            | index == invalidCharIndex -> True-          _ -> False--    it "does not report invalid characters if input is too long" $-      property $ \(i :: ID) (NonEmpty trailingExcess) ->-      forAll (choose (0, 9)) $ \invalidCharIndex -> do-        let textInvalid =-              replaceCharAt invalidCharIndex 'x' (ID.toText i)-              <>-              T.pack trailingExcess-        ID.fromText textInvalid `shouldBe` Left ID.InvalidLength--checkLensLaws-  :: forall i v. (Arbitrary i, Arbitrary v, Eq i, Eq v, Show i, Show v)-  => Lens' i v-  -> Spec-checkLensLaws l =-  do-    it "Finality"-      $ property lensLawFinality-    it "Idempotence"-      $ property lensLawIdempotence-    it "Invertibility"-      $ property lensLawInvertibility-    it "Reversibility"-      $ property lensLawReversibility-    it "Stability"-      $ property lensLawStability-  where-    lensLawFinality :: i -> v -> v -> Property-    lensLawFinality i v1 v2 = set l v2 (set l v1 i) === set l v2 i--    lensLawIdempotence :: i -> v -> Property-    lensLawIdempotence i v = set l v (set l v i) === set l v i--    lensLawInvertibility :: i -> v -> Property-    lensLawInvertibility i v = view l (set l v i) === v--    lensLawReversibility :: i -> v -> Property-    lensLawReversibility i v = set l (view l i) (set l v i) === i--    lensLawStability :: i -> Property-    lensLawStability i = set l (view l i) i === i--gender :: Lens' ID Gender-gender = lens ID.getGender (flip ID.setGender)--issuer :: Lens' ID Issuer-issuer = lens ID.getIssuer (flip ID.setIssuer)--region :: Lens' ID Region-region = lens ID.getRegion (flip ID.setRegion)---- | Replaces a character at a specific position.----replaceCharAt :: Int -> Char -> Text -> Text-replaceCharAt i c t-    | i < 0 || i >= T.length t = error "replaceCharAt: invalid index"-    | otherwise = prefix <> T.singleton c <> suffix-  where-    (prefix, suffix) = second (T.drop 1) (T.splitAt i t)---- | A set of known-valid ID numbers.------ Generated with 身分證字號產生器.------ See: https://www.csie.ntu.edu.tw/~b90057/use/ROCid.html----knownValidIDs :: [ID]-knownValidIDs =-  [ ID.fromSymbol @"A123961383"-  , ID.fromSymbol @"B210742224"-  , ID.fromSymbol @"C120930548"-  , ID.fromSymbol @"D257991149"-  , ID.fromSymbol @"E127379116"-  , ID.fromSymbol @"F235628112"-  , ID.fromSymbol @"G105851924"-  , ID.fromSymbol @"H247910878"-  , ID.fromSymbol @"I118949082"-  , ID.fromSymbol @"J218475156"-  , ID.fromSymbol @"K150252170"-  , ID.fromSymbol @"L298479266"-  , ID.fromSymbol @"M114415878"-  , ID.fromSymbol @"N242846162"-  , ID.fromSymbol @"O184333688"-  , ID.fromSymbol @"P257366789"-  , ID.fromSymbol @"Q163999855"-  , ID.fromSymbol @"R275744925"-  , ID.fromSymbol @"S158047168"-  , ID.fromSymbol @"T296696104"-  , ID.fromSymbol @"U108929984"-  , ID.fromSymbol @"V245356279"-  , ID.fromSymbol @"W127612989"-  , ID.fromSymbol @"X234128072"-  , ID.fromSymbol @"Y140531128"-  , ID.fromSymbol @"Z250358466"-  ]--idFromTuple :: Digit ~ d => (Letter, Digit1289, d, d, d, d, d, d, d) -> ID-idFromTuple (x0, x1, x2, x3, x4, x5, x6, x7, x8) =-  ID x0 x1 x2 x3 x4 x5 x6 x7 x8--idToTuple :: Digit ~ d => ID -> (Letter, Digit1289, d, d, d, d, d, d, d)-idToTuple (ID x0 x1 x2 x3 x4 x5 x6 x7 x8) =-  (x0, x1, x2, x3, x4, x5, x6, x7, x8)

@@ -1,72 +0,0 @@-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}---- | Provides testing functions to check that type class instances obey laws.-module Test.QuickCheck.Classes.Hspec-    ( testLaws-    , testLawsMany-    ) where--import Prelude--import Control.Monad-    ( forM_-    )-import Data.Proxy-    ( Proxy (..)-    )-import Data.Typeable-    ( Typeable-    , typeRep-    )-import Test.Hspec-    ( Spec-    , describe-    , it-    , parallel-    )-import Test.QuickCheck.Classes-    ( Laws (..)-    )---- | Constructs a test to check that the given type class instance obeys the---   given set of laws.------ Example usage:------ >>> testLaws @Natural ordLaws--- >>> testLaws @(Map Int) functorLaws-testLaws-    :: forall a-     . Typeable a-    => (Proxy a -> Laws)-    -> Spec-testLaws getLaws =-    parallel-        $ describe description-        $ forM_ (lawsProperties laws)-        $ uncurry it-    where-        description =-            mconcat-                [ "Testing "-                , lawsTypeclass laws-                , " laws for type "-                , show (typeRep $ Proxy @a)-                ]-        laws = getLaws $ Proxy @a---- | Calls `testLaws` with multiple sets of laws.------ Example usage:------ >>> testLawsMany @Natural [eqLaws, ordLaws]--- >>> testLawsMany @(Map Int) [foldableLaws, functorLaws]-testLawsMany-    :: forall a-     . Typeable a-    => [Proxy a -> Laws]-    -> Spec-testLawsMany getLawsMany =-    testLaws @a `mapM_` getLawsMany

@@ -1,366 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}--module Taiwan.ID-  (-  -- * Type-    ID (..)--  -- * Construction-  , fromSymbol-  , fromText-  , FromTextError (..)--  -- * Conversion-  , toText--  -- * Validity-  , checksum--  -- * Generation-  , generate--  -- * Inspection-  , getGender-  , getIssuer-  , getRegion--  -- * Modification-  , setGender-  , setIssuer-  , setRegion-  )-  where--import Control.Monad.Random.Class-  ( MonadRandom )-import Data.Bifunctor-  ( Bifunctor (first) )-import Data.Finitary-  ( Finitary )-import Data.Proxy-  ( Proxy (Proxy) )-import Data.Text-  ( Text )-import GHC.Generics-  ( Generic )-import GHC.TypeLits-  ( Symbol, symbolVal )-import Taiwan.ID.CharIndex-  ( CharIndex (..) )-import Taiwan.ID.CharSet-  ( CharSet (..) )-import Taiwan.ID.Digit-  ( Digit (..) )-import Taiwan.ID.Digit1289-  ( Digit1289 (..) )-import Taiwan.ID.Gender-  ( Gender (..) )-import Taiwan.ID.Issuer-  ( Issuer (..) )-import Taiwan.ID.Letter-  ( Letter (..) )-import Taiwan.ID.Region-  ( Region )-import Taiwan.ID.Unchecked-  ( UncheckedID (UncheckedID), ValidID )-import Taiwan.ID.Utilities-  ( guard, randomFinitary )-import Text.Read-  ( Lexeme (Ident, Symbol, Punc), Read (readPrec), lexP, parens, prec )--import qualified Data.Text as T-import qualified Taiwan.ID.Region as Region-import qualified Taiwan.ID.Unchecked as U---- |--- $setup--- >>> :set -XDataKinds--- >>> :set -XOverloadedStrings--- >>> :set -XTypeApplications--- >>> import Taiwan.ID--- >>> import qualified Taiwan.ID as ID------------------------------------------------------------------------------------- Type------------------------------------------------------------------------------------- | Represents a __valid__ 10-digit uniform identification number of the form--- __@A123456789@__.------ By construction, invalid identification numbers are __not representable__ by--- this data type.------ To guarantee correctness, an 'ID' value does __not__ store the terminal--- checksum digit of the identification number it represents.------ To compute the checksum digit, use 'checksum'.----data ID = ID-  { c0 :: !Letter-  , c1 :: !Digit1289-  , c2 :: !Digit-  , c3 :: !Digit-  , c4 :: !Digit-  , c5 :: !Digit-  , c6 :: !Digit-  , c7 :: !Digit-  , c8 :: !Digit-  }-  deriving stock (Eq, Ord, Generic)-  deriving anyclass Finitary--instance Read ID where-  readPrec = parens $ prec 10 $ do-    Ident  "ID"         <- lexP-    Symbol "."          <- lexP-    Ident  "fromSymbol" <- lexP-    Punc   "@"          <- lexP-    unsafeFromText <$> readPrec--instance Show ID where-  showsPrec d s =-    showParen (d > 10) $-      showString "ID.fromSymbol @" . shows (toText s)------------------------------------------------------------------------------------- Construction------------------------------------------------------------------------------------- | Constructs an 'ID' from a type-level textual symbol.------ The symbol must be exactly 10 characters in length and of the form--- __@A123456789@__:------ >>> ID.fromSymbol @"A123456789"--- ID.fromSymbol @"A123456789"------ More precisely:------  - the symbol must match the regular expression __@^[A-Z][1289][0-9]{8}$@__---  - the resultant ID must have a valid checksum.------ Failure to satisfy these constraints will result in one of the following--- __type errors__:------ === Invalid lengths------ >>> ID.fromSymbol @"A12345678"--- ...--- ... An ID must have exactly 10 characters.--- ...------ === Invalid checksums------ >>> ID.fromSymbol @"A123456780"--- ...--- ... ID has invalid checksum.--- ...------ === Invalid characters------ On detection of an invalid character, the resulting type error reports--- both the position of the character and the set of characters permitted--- at that position.------ >>> ID.fromSymbol @"_123456789"--- ...---     • "_123456789"---        ^---       Character at this position must be an uppercase letter.--- ...------ >>> ID.fromSymbol @"A_23456789"--- ...---     • "A_23456789"---         ^---       Character at this position must be a digit from the set {1, 2, 8, 9}.--- ...------ >>> ID.fromSymbol @"A1_3456789"--- ...---     • "A1_3456789"---          ^---       Character at this position must be a digit in the range [0 .. 9].--- ...------ === Missing or empty symbols------ >>> ID.fromSymbol--- ...--- ... Expected a type-level symbol of the form "A123456789".--- ...------ >>> ID.fromSymbol @""--- ...--- ... Expected a type-level symbol of the form "A123456789".--- ...----fromSymbol :: forall (s :: Symbol). ValidID s => ID-fromSymbol = unsafeFromText $ T.pack $ symbolVal $ Proxy @s---- | Attempts to construct an 'ID' from 'Text'.------ The input must be exactly 10 characters in length and of the form--- __@A123456789@__:------ >>> ID.fromText "A123456789"--- Right (ID.fromSymbol @"A123456789")------ More precisely, the input must match the regular expression--- __@^[A-Z][1289][0-9]{8}$@__, and the resultant ID must have a valid--- checksum.------ This function satisfies the following law:------ @--- 'fromText' ('toText' i) '==' 'Right' i--- @----fromText :: Text -> Either FromTextError ID-fromText text = do-    unchecked <- first fromUncheckedError $ U.fromText text-    guard InvalidChecksum $ fromUnchecked unchecked-  where-    fromUncheckedError :: U.FromTextError -> FromTextError-    fromUncheckedError = \case-      U.InvalidChar i r ->-        InvalidChar i r-      U.InvalidLength ->-        InvalidLength--unsafeFromText :: Text -> ID-unsafeFromText t =-  case fromText t of-    Left _ -> error "unsafeFromText"-    Right i -> i---- | Indicates an error that occurred while constructing an 'ID' from 'Text'.----data FromTextError--  = InvalidChar CharIndex CharSet-  -- ^ Indicates that the input text contains a character that is not allowed.-  ---  --   - `CharIndex` specifies the position of the invalid character.-  --   - `CharSet` specifies the set of characters allowed at that position.--  | InvalidChecksum-  -- ^ Indicates that the parsed identification number has an invalid checksum.--  | InvalidLength-  -- ^ Indicates that the input text has an invalid length.--  deriving stock (Eq, Ord, Show)------------------------------------------------------------------------------------- Conversion------------------------------------------------------------------------------------- | Converts an 'ID' to 'Text'.------ The output is of the form __@A123456789@__.------ This function satisfies the following law:------ @--- 'fromText' ('toText' i) '==' 'Right' i--- @----toText :: ID -> Text-toText = U.toText . toUnchecked------------------------------------------------------------------------------------- Validity------------------------------------------------------------------------------------- | Computes the terminal checksum digit of an 'ID'.----checksum :: ID -> Digit-checksum (ID u0 u1 u2 u3 u4 u5 u6 u7 u8) =-  negate $ U.checksum (UncheckedID u0 u1 u2 u3 u4 u5 u6 u7 u8 0)------------------------------------------------------------------------------------- Generation------------------------------------------------------------------------------------- | Generates a random 'ID'.----generate :: MonadRandom m => m ID-generate = randomFinitary------------------------------------------------------------------------------------- Inspection------------------------------------------------------------------------------------- | Decodes the 'Gender' component of an 'ID'.----getGender :: ID -> Gender-getGender ID {c1} = fst $ decodeC1 c1---- | Decodes the 'Issuer' component of an 'ID'.----getIssuer :: ID -> Issuer-getIssuer ID {c1} = snd $ decodeC1 c1---- | Decodes the 'Region' component of an 'ID'.----getRegion :: ID -> Region-getRegion ID {c0} = Region.fromLetter c0------------------------------------------------------------------------------------- Modification------------------------------------------------------------------------------------- | Updates the 'Gender' component of an 'ID'.----setGender :: Gender -> ID -> ID-setGender gender i = i {c1 = encodeC1 (gender, getIssuer i)}---- | Updates the 'Issuer' component of an 'ID'.----setIssuer :: Issuer -> ID -> ID-setIssuer issuer i = i {c1 = encodeC1 (getGender i, issuer)}---- | Updates the 'Region' component of an 'ID'.----setRegion :: Region -> ID -> ID-setRegion region i = i {c0 = Region.toLetter region}------------------------------------------------------------------------------------- Internal-----------------------------------------------------------------------------------decodeC1 :: Digit1289 -> (Gender, Issuer)-decodeC1 = \case-  D1289_1 -> (  Male, HouseholdRegistrationOffice)-  D1289_2 -> (Female, HouseholdRegistrationOffice)-  D1289_8 -> (  Male,   NationalImmigrationAgency)-  D1289_9 -> (Female,   NationalImmigrationAgency)--encodeC1 :: (Gender, Issuer) -> Digit1289-encodeC1 = \case-  (  Male, HouseholdRegistrationOffice) -> D1289_1-  (Female, HouseholdRegistrationOffice) -> D1289_2-  (  Male,   NationalImmigrationAgency) -> D1289_8-  (Female,   NationalImmigrationAgency) -> D1289_9--fromUnchecked :: UncheckedID -> Maybe ID-fromUnchecked u@(UncheckedID u0 u1 u2 u3 u4 u5 u6 u7 u8 _) =-    case U.checksumValidity u of-      U.ChecksumValid   -> Just i-      U.ChecksumInvalid -> Nothing-  where-    i = ID u0 u1 u2 u3 u4 u5 u6 u7 u8--toUnchecked :: ID -> UncheckedID-toUnchecked i@(ID u0 u1 u2 u3 u4 u5 u6 u7 u8) =-  UncheckedID u0 u1 u2 u3 u4 u5 u6 u7 u8 (checksum i)

@@ -1,13 +0,0 @@-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--module Taiwan.ID.CharIndex-  ( CharIndex (..)-  )-  where---- | Specifies the zero-based position of a character within a string.----newtype CharIndex = CharIndex Int-  deriving stock (Read, Show)-  deriving newtype (Enum, Eq, Num, Ord)

@@ -1,18 +0,0 @@-{-# LANGUAGE DerivingStrategies #-}--module Taiwan.ID.CharSet-  ( CharSet (..)-  )-  where--import Data.Set.NonEmpty-  ( NESet )---- | Specifies a set of characters.----data CharSet-  = CharSet (NESet Char)-  -- ^ An explicit set of characters.-  | CharRange Char Char-  -- ^ An inclusive range of characters.-  deriving stock (Eq, Ord, Read, Show)

@@ -1,119 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}--module Taiwan.ID.Digit-  ( Digit (..)-  , fromChar-  , toChar-  , generate-  , FromChar-  , FromNat-  , ToNat-  ) where--import Control.Monad.Random-  ( MonadRandom )-import Data.Finitary-  ( Finitary )-import GHC.Generics-  ( Generic )-import GHC.TypeNats-  ( Nat )-import Taiwan.ID.Utilities-  ( maybeFinitary, randomFinitary )-import Text.Read-  ( Read (readPrec), readMaybe )--import Prelude hiding-  ( fromIntegral )--import qualified Prelude---- | Represents a single decimal digit in the range @0@ to @9@.----data Digit-  = D0 | D1 | D2 | D3 | D4 | D5 | D6 | D7 | D8 | D9-  deriving stock (Bounded, Enum, Eq, Generic, Ord)-  deriving anyclass Finitary---- | Arithmetic modulo 10.----instance Num Digit where-  a + b = fromIntegral (fromEnum a + fromEnum b)-  a * b = fromIntegral (fromEnum a * fromEnum b)-  a - b = fromIntegral (fromEnum a - fromEnum b)-  abs a = a-  fromInteger = fromIntegral-  signum D0 = D0-  signum __ = D1--instance Read Digit where readPrec = fromInteger <$> readPrec--instance Show Digit where show = show . fromEnum---- | Attempts to parse a 'Digit' from a character.------ The 'Char' must be a decimal digit in the range @0@ to @9@.----fromChar :: Char -> Maybe Digit-fromChar c = readMaybe [c] >>= maybeFinitary---- | Converts a 'Digit' to a decimal digit character.----toChar :: Digit -> Char-toChar digit = case show digit of-  [c] -> c-  _ -> error "toChar"---- | Creates a 'Digit' from an integral number (modulo 10).----fromIntegral :: Integral i => i -> Digit-fromIntegral i = toEnum (Prelude.fromIntegral (i `mod` 10))---- | Generates a random digit.----generate :: MonadRandom m => m Digit-generate = randomFinitary--type family FromChar (c :: Char) :: Maybe Digit where-  FromChar '0' = Just D0-  FromChar '1' = Just D1-  FromChar '2' = Just D2-  FromChar '3' = Just D3-  FromChar '4' = Just D4-  FromChar '5' = Just D5-  FromChar '6' = Just D6-  FromChar '7' = Just D7-  FromChar '8' = Just D8-  FromChar '9' = Just D9-  FromChar _   = Nothing--type family FromNat (n :: Nat) :: Maybe Digit where-  FromNat 0 = Just D0-  FromNat 1 = Just D1-  FromNat 2 = Just D2-  FromNat 3 = Just D3-  FromNat 4 = Just D4-  FromNat 5 = Just D5-  FromNat 6 = Just D6-  FromNat 7 = Just D7-  FromNat 8 = Just D8-  FromNat 9 = Just D9-  FromNat _ = Nothing--type family ToNat (d :: Digit) :: Nat where-  ToNat D0 = 0-  ToNat D1 = 1-  ToNat D2 = 2-  ToNat D3 = 3-  ToNat D4 = 4-  ToNat D5 = 5-  ToNat D6 = 6-  ToNat D7 = 7-  ToNat D8 = 8-  ToNat D9 = 9

@@ -1,94 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}--module Taiwan.ID.Digit1289-  ( Digit1289 (..)-  , fromChar-  , toChar-  , toDigit-  , generate-  , FromChar-  , FromNat-  , ToNat-  ) where--import Control.Monad.Random-  ( MonadRandom )-import Data.Finitary-  ( Finitary )-import GHC.Generics-  ( Generic )-import GHC.TypeNats-  ( Nat )-import Taiwan.ID.Digit-  ( Digit (..) )-import Taiwan.ID.Utilities-  ( randomFinitary )---- | Represents a single decimal digit from the set {@1@, @2@, @8@, @9@}.----data Digit1289-  = D1289_1 | D1289_2 | D1289_8 | D1289_9-  deriving stock (Bounded, Enum, Eq, Generic, Ord, Read, Show)-  deriving anyclass Finitary---- | Attempts to parse a 'Digit1289' from a character.------ Only the characters @'1'@, @'2'@, @'8'@, and @'9'@ are accepted.----fromChar :: Char -> Maybe Digit1289-fromChar = \case-  '1' -> Just D1289_1-  '2' -> Just D1289_2-  '8' -> Just D1289_8-  '9' -> Just D1289_9-  _   -> Nothing---- | Converts a 'Digit1289' to a decimal digit character.----toChar :: Digit1289 -> Char-toChar = \case-  D1289_1 -> '1'-  D1289_2 -> '2'-  D1289_8 -> '8'-  D1289_9 -> '9'---- | Converts a 'Digit1289' to an ordinary 'Digit'.----toDigit :: Digit1289 -> Digit-toDigit = \case-  D1289_1 -> D1-  D1289_2 -> D2-  D1289_8 -> D8-  D1289_9 -> D9---- | Generates a random 'Digit1289'.----generate :: MonadRandom m => m Digit1289-generate = randomFinitary--type family FromChar (c :: Char) :: Maybe Digit1289 where-  FromChar '1' = Just D1289_1-  FromChar '2' = Just D1289_2-  FromChar '8' = Just D1289_8-  FromChar '9' = Just D1289_9-  FromChar _   = Nothing--type family FromNat (n :: Nat) :: Maybe Digit1289 where-  FromNat 1 = Just D1289_1-  FromNat 2 = Just D1289_2-  FromNat 8 = Just D1289_8-  FromNat 9 = Just D1289_9-  FromNat _ = Nothing--type family ToNat (d :: Digit1289) :: Nat where-  ToNat D1289_1 = 1-  ToNat D1289_2 = 2-  ToNat D1289_8 = 8-  ToNat D1289_9 = 9

@@ -1,52 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}--module Taiwan.ID.Gender-  ( Gender (..)-  , toText-  , generate-  ) where--import Control.Monad.Random.Class-  ( MonadRandom (..) )-import Data.Finitary-  ( Finitary )-import Data.Text-  ( Text )-import GHC.Generics-  ( Generic )-import Taiwan.ID.Language-  ( Language (..) )-import Taiwan.ID.Utilities-  ( randomFinitary )---- | A person's gender.----data Gender = Male | Female-  deriving stock (Bounded, Enum, Eq, Generic, Ord, Read, Show)-  deriving anyclass Finitary---- | Prints the specified 'Gender'.----toText :: Language -> Gender -> Text-toText = \case-  English -> toTextEnglish-  Chinese -> toTextChinese--toTextEnglish :: Gender -> Text-toTextEnglish = \case-  Male   -> "Male"-  Female -> "Female"--toTextChinese :: Gender -> Text-toTextChinese = \case-  Male   -> "男性"-  Female -> "女性"---- | Generates a random 'Gender'.----generate :: MonadRandom m => m Gender-generate = randomFinitary

@@ -1,59 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}--module Taiwan.ID.Issuer-  ( Issuer (..)-  , toText-  , generate-  )-  where--import Control.Monad.Random.Class-  ( MonadRandom (..) )-import Data.Finitary-  ( Finitary )-import Data.Text-  ( Text )-import GHC.Generics-  ( Generic )-import Taiwan.ID.Language-  ( Language (English, Chinese) )-import Taiwan.ID.Utilities-  ( randomFinitary )---- | A government authority that issues identification numbers.----data Issuer-  = HouseholdRegistrationOffice-  | NationalImmigrationAgency-  deriving stock (Bounded, Enum, Eq, Ord, Generic, Read, Show)-  deriving anyclass Finitary---- | Generates a random 'Issuer'.----generate :: MonadRandom m => m Issuer-generate = randomFinitary---- | Prints the specified 'Issuer'.----toText :: Language -> Issuer -> Text-toText = \case-  English -> toTextEnglish-  Chinese -> toTextChinese--toTextChinese :: Issuer -> Text-toTextChinese = \case-  HouseholdRegistrationOffice ->-    "戶政事務所"-  NationalImmigrationAgency ->-    "移民署"--toTextEnglish :: Issuer -> Text-toTextEnglish = \case-  HouseholdRegistrationOffice ->-    "Household Registration Office"-  NationalImmigrationAgency ->-    "National Immigration Agency"

@@ -1,5 +0,0 @@-module Taiwan.ID.Language where---- | A language into which values can be localized when pretty printing.----data Language = English | Chinese

@@ -1,69 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}--module Taiwan.ID.Letter-  ( Letter (..)-  , fromChar-  , toChar-  , generate-  , FromChar-  ) where--import Control.Monad.Random.Class-  ( MonadRandom (..) )-import Data.Finitary-  ( Finitary )-import GHC.Generics-  ( Generic )-import Taiwan.ID.Utilities-  ( randomFinitary )-import Text.Read-  ( readMaybe )---- | Represents a letter in the latin alphabet.----data Letter-  = A | B | C | D | E | F | G | H | I | J | K | L | M-  | N | O | P | Q | R | S | T | U | V | W | X | Y | Z-  deriving stock (Bounded, Enum, Eq, Generic, Ord, Read, Show)-  deriving anyclass Finitary---- | Attempts to parse a 'Letter' from a character.------ Returns 'Nothing' if the specified character is not an uppercase alphabetic--- character.----fromChar :: Char -> Maybe Letter-fromChar c = readMaybe [c]---- | Converts the specified 'Letter' to a character.----toChar :: Letter -> Char-toChar letter = case show letter of-  [c] -> c-  _ -> error "toChar"---- | Generates a random 'Letter'.----generate :: MonadRandom m => m Letter-generate = randomFinitary--type family FromChar (c :: Char) :: Maybe Letter where-  FromChar 'A' = Just A; FromChar 'N' = Just N-  FromChar 'B' = Just B; FromChar 'O' = Just O-  FromChar 'C' = Just C; FromChar 'P' = Just P-  FromChar 'D' = Just D; FromChar 'Q' = Just Q-  FromChar 'E' = Just E; FromChar 'R' = Just R-  FromChar 'F' = Just F; FromChar 'S' = Just S-  FromChar 'G' = Just G; FromChar 'T' = Just T-  FromChar 'H' = Just H; FromChar 'U' = Just U-  FromChar 'I' = Just I; FromChar 'V' = Just V-  FromChar 'J' = Just J; FromChar 'W' = Just W-  FromChar 'K' = Just K; FromChar 'X' = Just X-  FromChar 'L' = Just L; FromChar 'Y' = Just Y-  FromChar 'M' = Just M; FromChar 'Z' = Just Z-  FromChar _ = Nothing

@@ -1,223 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}--module Taiwan.ID.Region-  ( Region-  , fromChar-  , fromLetter-  , toChar-  , toLetter-  , toText-  , generate-  ) where--import Control.Monad.Random.Class-  ( MonadRandom (..) )-import Data.Finitary-  ( Finitary )-import Data.Text-  ( Text )-import GHC.Generics-  ( Generic )-import Taiwan.ID.Language-  ( Language (..) )-import Taiwan.ID.Letter-  ( Letter (..) )-import Taiwan.ID.Utilities-  ( randomFinitary )-import Text.Read-  ( Lexeme (Ident, Symbol), Read (readPrec), lexP, parens, prec )--import qualified Taiwan.ID.Letter as Letter---- |--- $setup--- >>> import qualified Taiwan.ID.Region as Region---- | Represents a geographical region.------ == Region codes------ Every region has a unique letter code:------ +------+---------+-------------------+--- | Code | Chinese | English           |--- +======+=========+===================+--- | @A@  | 臺北市     | Taipei City       |--- +------+---------+-------------------+--- | @B@  | 臺中市     | Taichung City     |--- +------+---------+-------------------+--- | @C@  | 基隆市     | Keelung City      |--- +------+---------+-------------------+--- | @D@  | 臺南市     | Tainan City       |--- +------+---------+-------------------+--- | @E@  | 高雄市     | Kaohsiung City    |--- +------+---------+-------------------+--- | @F@  | 新北市     | New Taipei City   |--- +------+---------+-------------------+--- | @G@  | 宜蘭縣     | Yilan County      |--- +------+---------+-------------------+--- | @H@  | 桃園市     | Taoyuan City      |--- +------+---------+-------------------+--- | @I@  | 嘉義市     | Chiayi City       |--- +------+---------+-------------------+--- | @J@  | 新竹縣     | Hsinchu County    |--- +------+---------+-------------------+--- | @K@  | 苗栗縣     | Miaoli County     |--- +------+---------+-------------------+--- | @L@  | 臺中縣     | Taichung County   |--- +------+---------+-------------------+--- | @M@  | 南投縣     | Nantou County     |--- +------+---------+-------------------+--- | @N@  | 彰化縣     | Changhua County   |--- +------+---------+-------------------+--- | @O@  | 新竹市     | Hsinchu City      |--- +------+---------+-------------------+--- | @P@  | 雲林縣     | Yunlin County     |--- +------+---------+-------------------+--- | @Q@  | 嘉義縣     | Chiayi County     |--- +------+---------+-------------------+--- | @R@  | 臺南縣     | Tainan County     |--- +------+---------+-------------------+--- | @S@  | 高雄縣     | Kaohsiung County  |--- +------+---------+-------------------+--- | @T@  | 屏東縣     | Pingtung County   |--- +------+---------+-------------------+--- | @U@  | 花蓮縣     | Hualien County    |--- +------+---------+-------------------+--- | @V@  | 臺東縣     | Taitung County    |--- +------+---------+-------------------+--- | @W@  | 金門縣     | Kinmen County     |--- +------+---------+-------------------+--- | @X@  | 澎湖縣     | Penghu County     |--- +------+---------+-------------------+--- | @Y@  | 陽明山     | Yangmingshan      |--- +------+---------+-------------------+--- | @Z@  | 連江縣     | Lienchiang County |--- +------+---------+-------------------+------ == Usage------ To construct a 'Region' from its letter code, use the 'fromLetter'--- function.------ To print the full name of a 'Region', use the 'toText' function.------ To generate a random 'Region', use the 'generate' function.----newtype Region = Region Letter-  deriving stock (Eq, Generic, Ord)-  deriving newtype (Bounded, Enum)-  deriving anyclass Finitary--instance Read Region where-  readPrec = parens $ prec 10 $ do-    Ident "Region"     <- lexP-    Symbol "."         <- lexP-    Ident "fromLetter" <- lexP-    fromLetter <$> readPrec--instance Show Region where-  showsPrec d s =-    showParen (d > 10) $-      showString "Region.fromLetter " . shows (toLetter s)---- | Attempts to construct a 'Region' from its corresponding letter code as a--- 'Char'.------ >>> Region.fromChar 'A'--- Just (Region.fromLetter A)------ >>> Region.fromChar '?'--- Nothing----fromChar :: Char -> Maybe Region-fromChar = fmap fromLetter . Letter.fromChar---- | Constructs a 'Region' from its corresponding letter code.----fromLetter :: Letter -> Region-fromLetter = Region---- | Converts a 'Region' to its corresponding letter code as a 'Char'.----toChar :: Region -> Char-toChar = Letter.toChar . toLetter---- | Converts a 'Region' to its corresponding letter code.----toLetter :: Region -> Letter-toLetter (Region letter) = letter---- | Prints the specified 'Region'.-toText :: Language -> Region -> Text-toText = \case-  English -> toTextEnglish-  Chinese -> toTextChinese--toTextChinese :: Region -> Text-toTextChinese (Region letter) = case letter of-  A -> "臺北市"-  B -> "臺中市"-  C -> "基隆市"-  D -> "臺南市"-  E -> "高雄市"-  F -> "新北市"-  G -> "宜蘭縣"-  H -> "桃園市"-  I -> "嘉義市"-  J -> "新竹縣"-  K -> "苗栗縣"-  L -> "臺中縣"-  M -> "南投縣"-  N -> "彰化縣"-  O -> "新竹市"-  P -> "雲林縣"-  Q -> "嘉義縣"-  R -> "臺南縣"-  S -> "高雄縣"-  T -> "屏東縣"-  U -> "花蓮縣"-  V -> "臺東縣"-  W -> "金門縣"-  X -> "澎湖縣"-  Y -> "陽明山"-  Z -> "連江縣"--toTextEnglish :: Region -> Text-toTextEnglish (Region letter) = case letter of-  A -> "Taipei City"-  B -> "Taichung City"-  C -> "Keelung City"-  D -> "Tainan City"-  E -> "Kaohsiung City"-  F -> "New Taipei City"-  G -> "Yilan County"-  H -> "Taoyuan City"-  I -> "Chiayi City"-  J -> "Hsinchu County"-  K -> "Miaoli County"-  L -> "Taichung County"-  M -> "Nantou County"-  N -> "Changhua County"-  O -> "Hsinchu City"-  P -> "Yunlin County"-  Q -> "Chiayi County"-  R -> "Tainan County"-  S -> "Kaohsiung County"-  T -> "Pingtung County"-  U -> "Hualien County"-  V -> "Taitung County"-  W -> "Kinmen County"-  X -> "Penghu County"-  Y -> "Yangmingshan"-  Z -> "Lienchiang County"---- | Generates a random 'Region'.----generate :: MonadRandom m => m Region-generate = randomFinitary

@@ -1,315 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ViewPatterns #-}--module Taiwan.ID.Unchecked-  ( UncheckedID (..)-  , UncheckedIDTuple-  , FromTextError (..)-  , fromText-  , toText-  , checksum-  , checksumValidity-  , ChecksumValidity (..)-  , ValidID-  )-  where--import Control.Monad-  ( when )-import Data.Kind-  ( Constraint )-import Data.List.NonEmpty-  ( NonEmpty ((:|)) )-import Data.Text-  ( Text )-import Data.Type.Bool-  ( If )-import Data.Type.Equality-  ( type (==) )-import GHC.TypeError-  ( Assert, TypeError )-import GHC.TypeLits-  ( AppendSymbol, KnownSymbol, Symbol )-import GHC.TypeNats-  ( CmpNat, Mod, Nat, type (+) )-import Taiwan.ID.CharIndex-  ( CharIndex (..) )-import Taiwan.ID.CharSet-  ( CharSet (..) )-import Taiwan.ID.Digit-  ( Digit (..) )-import Taiwan.ID.Digit1289-  ( Digit1289 (..) )-import Taiwan.ID.Letter-  ( Letter (..) )-import Taiwan.ID.Utilities-  ( FromJust, Fst, ReplicateChar, Snd, SymbolLength, SymbolToCharList, guard )--import qualified Data.Set.NonEmpty as NESet-import qualified Data.Text as T-import qualified GHC.TypeError as TypeError-import qualified GHC.TypeNats as N-import qualified Taiwan.ID.Digit as Digit-import qualified Taiwan.ID.Digit1289 as Digit1289-import qualified Taiwan.ID.Letter as Letter--data UncheckedID = UncheckedID-  { c0 :: !Letter-  , c1 :: !Digit1289-  , c2 :: !Digit-  , c3 :: !Digit-  , c4 :: !Digit-  , c5 :: !Digit-  , c6 :: !Digit-  , c7 :: !Digit-  , c8 :: !Digit-  , c9 :: !Digit-  }-  deriving stock (Eq, Ord, Show)--type UncheckedIDTuple =-  ( Letter-  , Digit1289-  , Digit-  , Digit-  , Digit-  , Digit-  , Digit-  , Digit-  , Digit-  , Digit-  )--data FromTextError-  = InvalidChar CharIndex CharSet-  | InvalidLength-  deriving stock (Eq, Ord, Read, Show)--type Parser a = Text -> Either FromTextError (Text, a)--fromText :: Text -> Either FromTextError UncheckedID-fromText text0 = do-    when (T.length text0 > 10) $ Left InvalidLength-    (text1,  c0                             ) <- parseLetter    text0-    (text2,  c1                             ) <- parseDigit1289 text1-    (_____, (c2, c3, c4, c5, c6, c7, c8, c9)) <- parseDigits    text2-    pure UncheckedID {c0, c1, c2, c3, c4, c5, c6, c7, c8, c9}-  where-    parseLetter :: Parser Letter-    parseLetter text = do-      (char, remainder) <- guard InvalidLength $ T.uncons text-      letter <- guard (InvalidChar 0 (CharRange 'A' 'Z')) (Letter.fromChar char)-      pure (remainder, letter)--    parseDigit1289 :: Parser Digit1289-    parseDigit1289 text = do-      (char, remainder) <- guard InvalidLength $ T.uncons text-      digit1289 <- guard-        (InvalidChar 1 (CharSet $ NESet.fromList $ '1' :| ['2', '8', '9']))-        (Digit1289.fromChar char)-      pure (remainder, digit1289)--    parseDigits :: d ~ Digit => Parser (d, d, d, d, d, d, d, d)-    parseDigits text = do-        let (chars, remainder) = T.splitAt 8 text-        digitList <- traverse parseIndexedDigit (zip [2 ..] $ T.unpack chars)-        digitTuple <- guard InvalidLength (listToTuple8 digitList)-        pure (remainder, digitTuple)-      where-        parseIndexedDigit (i, c) =-          guard (InvalidChar i (CharRange '0' '9')) (Digit.fromChar c)--toText :: UncheckedID -> Text-toText UncheckedID {c0, c1, c2, c3, c4, c5, c6, c7, c8, c9} =-  T.pack-    ( Letter.toChar c0-    : Digit1289.toChar c1-    : fmap Digit.toChar [c2, c3, c4, c5, c6, c7, c8, c9]-    )--checksum :: UncheckedID -> Digit-checksum (UncheckedID u0 (Digit1289.toDigit -> u1) u2 u3 u4 u5 u6 u7 u8 u9) =-  sum $ zipWith (*)-    [ 1,  9,  8,  7,  6,  5,  4,  3,  2,  1,  1]-    [a0, a1, u1, u2, u3, u4, u5, u6, u7, u8, u9]-  where-    (a0, a1) = checksumLetterToDigitPair u0--checksumLetterToDigitPair :: Letter -> (Digit, Digit)-checksumLetterToDigitPair = \case-  A -> (1, 0); N -> (2, 2)-  B -> (1, 1); O -> (3, 5)-  C -> (1, 2); P -> (2, 3)-  D -> (1, 3); Q -> (2, 4)-  E -> (1, 4); R -> (2, 5)-  F -> (1, 5); S -> (2, 6)-  G -> (1, 6); T -> (2, 7)-  H -> (1, 7); U -> (2, 8)-  I -> (3, 4); V -> (2, 9)-  J -> (1, 8); W -> (3, 2)-  K -> (1, 9); X -> (3, 0)-  L -> (2, 0); Y -> (3, 1)-  M -> (2, 1); Z -> (3, 3)--data ChecksumValidity-  = ChecksumValid-  | ChecksumInvalid-  deriving stock (Eq, Show)--checksumValidity :: UncheckedID -> ChecksumValidity-checksumValidity u =-  case checksum u of-    0 -> ChecksumValid-    _ -> ChecksumInvalid--listToTuple8 :: [a] -> Maybe (a, a, a, a, a, a, a, a)-listToTuple8 = \case-  [a0, a1, a2, a3, a4, a5, a6, a7] ->-    Just (a0, a1, a2, a3, a4, a5, a6, a7)-  _ ->-    Nothing--type family ChecksumValid (id :: UncheckedIDTuple) :: Constraint where-  ChecksumValid id =-    Assert-      (ChecksumDigit id == D0)-      (TypeError (TypeError.Text "ID has invalid checksum."))--type family ChecksumDigit (id :: UncheckedIDTuple) :: Digit where-  ChecksumDigit id = ChecksumDigitFromNat (Mod (Checksum id) 10)--type family ChecksumDigitFromNat (n :: Nat) :: Digit where-  ChecksumDigitFromNat n =-    FromJust-      (Digit.FromNat n)-      (TypeError (TypeError.Text "Expected natural number between 0 and 9."))--type family Checksum (id :: UncheckedIDTuple) :: Nat where-  Checksum '(c0, c1, c2, c3, c4, c5, c6, c7, c8, c9) =-    (     (ChecksumLetterToNat0 c0 N.* 1)-      N.+ (ChecksumLetterToNat1 c0 N.* 9)-      N.+ (Digit1289.ToNat      c1 N.* 8)-      N.+ (Digit.ToNat          c2 N.* 7)-      N.+ (Digit.ToNat          c3 N.* 6)-      N.+ (Digit.ToNat          c4 N.* 5)-      N.+ (Digit.ToNat          c5 N.* 4)-      N.+ (Digit.ToNat          c6 N.* 3)-      N.+ (Digit.ToNat          c7 N.* 2)-      N.+ (Digit.ToNat          c8 N.* 1)-      N.+ (Digit.ToNat          c9 N.* 1)-    )--type family ChecksumLetterToNat0 (letter :: Letter) :: Nat where-  ChecksumLetterToNat0 x = Fst (ChecksumLetterToNatPair x)--type family ChecksumLetterToNat1 (letter :: Letter) :: Nat where-  ChecksumLetterToNat1 x = Snd (ChecksumLetterToNatPair x)--type family ChecksumLetterToNatPair (l :: Letter) :: (Nat, Nat) where-  ChecksumLetterToNatPair A = '(1, 0); ChecksumLetterToNatPair B = '(1, 1)-  ChecksumLetterToNatPair C = '(1, 2); ChecksumLetterToNatPair D = '(1, 3)-  ChecksumLetterToNatPair E = '(1, 4); ChecksumLetterToNatPair F = '(1, 5)-  ChecksumLetterToNatPair G = '(1, 6); ChecksumLetterToNatPair H = '(1, 7)-  ChecksumLetterToNatPair I = '(3, 4); ChecksumLetterToNatPair J = '(1, 8)-  ChecksumLetterToNatPair K = '(1, 9); ChecksumLetterToNatPair L = '(2, 0)-  ChecksumLetterToNatPair M = '(2, 1); ChecksumLetterToNatPair N = '(2, 2)-  ChecksumLetterToNatPair O = '(3, 5); ChecksumLetterToNatPair P = '(2, 3)-  ChecksumLetterToNatPair Q = '(2, 4); ChecksumLetterToNatPair R = '(2, 5)-  ChecksumLetterToNatPair S = '(2, 6); ChecksumLetterToNatPair T = '(2, 7)-  ChecksumLetterToNatPair U = '(2, 8); ChecksumLetterToNatPair V = '(2, 9)-  ChecksumLetterToNatPair W = '(3, 2); ChecksumLetterToNatPair X = '(3, 0)-  ChecksumLetterToNatPair Y = '(3, 1); ChecksumLetterToNatPair Z = '(3, 3)--type family SymbolToId (s :: Symbol) :: UncheckedIDTuple where-  SymbolToId s =-    IdFromCharList s (SymbolToCharList s)--type family-    IdFromCharList (id :: Symbol) (xs :: [Char]) :: UncheckedIDTuple-  where-    IdFromCharList id '[c0, c1, c2, c3, c4, c5, c6, c7, c8, c9] =-      '( LetterFromChar    id 0 c0-       , Digit1289FromChar id 1 c1-       , DigitFromChar     id 2 c2-       , DigitFromChar     id 3 c3-       , DigitFromChar     id 4 c4-       , DigitFromChar     id 5 c5-       , DigitFromChar     id 6 c6-       , DigitFromChar     id 7 c7-       , DigitFromChar     id 8 c8-       , DigitFromChar     id 9 c9-       )-    IdFromCharList _ _ =-      TypeError (TypeError.Text "An ID must have exactly 10 characters.")--type family-    DigitFromChar (id :: Symbol) (index :: Nat) (c :: Char) :: Digit-  where-    DigitFromChar id index c =-      FromJust-        (Digit.FromChar c)-        (InvalidCharError id index DigitTypeError)--type family-    Digit1289FromChar (id :: Symbol) (index :: Nat) (c :: Char) :: Digit1289-  where-    Digit1289FromChar id index c =-      FromJust-        (Digit1289.FromChar c)-        (InvalidCharError id index Digit1289TypeError)--type family-    LetterFromChar (id :: Symbol) (index :: Nat) (c :: Char) :: Letter-  where-    LetterFromChar id index c =-      FromJust-        (Letter.FromChar c)-        (InvalidCharError id index LetterTypeError)--type DigitTypeError =-  "Character at this position must be a digit in the range [0 .. 9]."--type Digit1289TypeError =-  "Character at this position must be a digit from the set {1, 2, 8, 9}."--type LetterTypeError =-  "Character at this position must be an uppercase letter."--type family InvalidCharError-    (invalidId :: Symbol) (charIndex :: Nat) (message :: Symbol)-  where-    InvalidCharError invalidId charIndex message =-      TypeError-        ( TypeError.ShowType invalidId-          TypeError.:$$:-          TypeError.Text (ReplicateChar (charIndex + 1) ' ' `AppendSymbol` "^")-          TypeError.:$$:-          TypeError.Text message-        )--type ValidID s =-  ( KnownSymbol s-  , ChecksumValid (SymbolToId (ConcreteSymbol s))-  ) :: Constraint---- | Ensures the existence of a concrete symbol, or else raises a type error.----type family ConcreteSymbol (s :: Symbol) :: Symbol where-  -- If we can compute the symbol's length, then we have a concrete symbol.-  ConcreteSymbol s =-    If-      (CmpNat (SymbolLength s) 0 == GT)-      s-      (TypeError (TypeError.Text ConcreteSymbolError))--type ConcreteSymbolError =-  "Expected a type-level symbol of the form \"A123456789\"."

@@ -1,90 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}--module Taiwan.ID.Utilities where--import Control.Monad.Random.Class-  ( MonadRandom (..) )-import Data.Finitary-  ( Finitary (fromFinite), Cardinality )-import Data.Finite-  ( packFinite )-import Data.Maybe-  ( fromMaybe )-import Data.Proxy-  ( Proxy (Proxy) )-import GHC.TypeLits-  ( Symbol, UnconsSymbol, ConsSymbol, type (<=), type (+) )-import GHC.TypeNats-  ( Nat, type (-), natVal )-import Numeric.Natural-  ( Natural )--cardinality :: forall a. Finitary a => Natural-cardinality = natVal $ Proxy @(Cardinality a)--guard :: x -> Maybe y -> Either x y-guard x = maybe (Left x) Right--maybeFinitary :: forall a. Finitary a => Natural -> Maybe a-maybeFinitary = fmap fromFinite . packFinite . fromIntegral @Natural @Integer--randomFinitary-  :: forall m a. (MonadRandom m, Finitary a, 1 <= Cardinality a) => m a-randomFinitary =-    fromMaybe failure . maybeFinitary <$> randomNatural (0, cardinality @a - 1)-  where-    failure = error "randomFinitary: unexpected out-of-bounds value"--randomNatural :: MonadRandom m => (Natural, Natural) -> m Natural-randomNatural (lo, hi) =-  fromIntegral @Integer @Natural <$>-    getRandomR-      ( fromIntegral @Natural @Integer lo-      , fromIntegral @Natural @Integer hi-      )--type family FromJust (m :: Maybe a) e where-  FromJust Nothing e = e-  FromJust (Just a) _ = a--type family Fst (t :: (a, a)) :: a where-  Fst '(x, _) = x--type family Snd (t :: (a, a)) :: a where-  Snd '(_, y) = y--type family ListLength (as :: [a]) :: Nat where-  ListLength as = ListLengthInner 0 as--type family ListLengthInner (n :: Nat) (as :: [a]) :: Nat where-  ListLengthInner n '[] = n-  ListLengthInner n (a : as) = ListLengthInner (n + 1) as--type family SymbolLength (s :: Symbol) :: Nat where-  SymbolLength s = ListLength (SymbolToCharList s)--type family-    SymbolToCharList (s :: Symbol) :: [Char]-  where-    SymbolToCharList s = MaybeCharSymbolToCharList (UnconsSymbol s)--type family-  MaybeCharSymbolToCharList-    (m :: Maybe (Char, Symbol)) :: [Char]-  where-    MaybeCharSymbolToCharList ('Just '(c, rest)) = c ': SymbolToCharList rest-    MaybeCharSymbolToCharList 'Nothing = '[]--type family ReplicateChar (n :: Nat) (c :: Char) :: Symbol where-  ReplicateChar n c = ReplicateChar' "" n c--type family ReplicateChar' (s :: Symbol) (n :: Nat) (c :: Char) :: Symbol where-  ReplicateChar' s 0 _ = s-  ReplicateChar' s n c = ReplicateChar' (ConsSymbol c s) (n - 1) c

@@ -0,0 +1,403 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-orphans #-}++{- HLINT ignore "Functor law" -}++module Main (main) where++import Control.Monad+  ( unless+  )+import Control.Monad.Random+  ( evalRand+  )+import Data.Data+  ( Proxy (Proxy)+  )+import Data.Functor.Identity+  ( Identity (runIdentity)+  )+import Data.Text+  ( Text+  )+import GHC.Stack+  ( HasCallStack+  )+import System.Directory+  ( createDirectoryIfMissing+  , doesFileExist+  )+import System.FilePath+  ( (<.>)+  , (</>)+  )+import System.Random+  ( mkStdGen+  )+import Taiwan.ID.CLI+  ( Command+  , CommandLineResult (CommandLineFailure, CommandLineSuccess)+  , DecodeCommand (DecodeCommand, language)+  , GenerateCommand (GenerateCommand, count, seed)+  , Stage (Raw)+  , ValidateCommand (ValidateCommand, idText)+  )+import Test.QuickCheck+  ( Arbitrary1 (liftArbitrary)+  , Gen+  , arbitraryBoundedEnum+  , choose+  )+import Test.QuickCheck.Gen+  ( unGen+  )+import Test.QuickCheck.Random+  ( mkQCGen+  )+import Test.Tasty+  ( TestTree+  , askOption+  , defaultIngredients+  , defaultMainWithIngredients+  , includingOptions+  , testGroup+  )+import Test.Tasty.HUnit+  ( assertFailure+  , testCase+  )+import Test.Tasty.Options+  ( IsOption (..)+  , OptionDescription (Option)+  , mkOptionCLParser+  )+import Text.Printf+  ( printf+  )++import qualified Data.Text as Text+import qualified Data.Text.IO as TIO+import qualified Taiwan.ID.CLI as CLI+import qualified Taiwan.ID.CLI as Command+import qualified Taiwan.ID.Test as Test++--------------------------------------------------------------------------------+-- Constants+--------------------------------------------------------------------------------++testRootDirectory :: FilePath+testRootDirectory = "data" </> "taiwan-id-cli-test"++-- | Number of golden tests for each command type.+testsPerCommand :: Int+testsPerCommand = 1000++-- | Seed for random number generation when executing CLI commands in tests.+-- Ensures that commands without an explicit '--seed' parameter produce+-- deterministic output.+executionSeed :: Int+executionSeed = 0++-- | Seed for QuickCheck generators that produce test command invocations.+generatorSeed :: Int+generatorSeed = 0++-- | QuickCheck size parameter used by generators.+generatorSize :: Int+generatorSize = 10++--------------------------------------------------------------------------------+-- Modes+--------------------------------------------------------------------------------++-- | The mode in which the test suite runs.+--+-- The default mode (if none is specified) is 'Verify'.+data Mode+  = -- | Create golden files from randomly-generated command invocations.+    -- Existing golden files are never overwritten.+    Create+  | -- | Run each recorded command invocation and overwrite the golden file+    -- with the observed output if it differs from the expected output.+    Update+  | -- | Run each recorded command invocation and fail if the observed output+    -- differs from the expected output recorded in the golden file.+    Verify+  deriving stock (Bounded, Enum, Eq, Show)++instance IsOption Mode where+  defaultValue = Verify+  optionName = pure "mode"+  optionHelp = pure modeHelpText+  optionCLParser = mkOptionCLParser mempty+  parseValue = \case+    "create" -> Just Create+    "update" -> Just Update+    "verify" -> Just Verify+    _ -> Nothing++modeHelpText :: String+modeHelpText =+  "Test mode: create, update, or verify (default)"++--------------------------------------------------------------------------------+-- Main+--------------------------------------------------------------------------------++data CommandSpec = CommandSpec+  { commandName :: String+  , commandGen :: Gen (Command Raw)+  }++commandSpecs :: [CommandSpec]+commandSpecs =+  [ CommandSpec "decode" genCommandDecode+  , CommandSpec "generate" genCommandGenerate+  , CommandSpec "validate" genCommandValidate+  ]++main :: IO ()+main = defaultMainWithIngredients ingredients testTree+  where+    ingredients = includingOptions [Option (Proxy @Mode)] : defaultIngredients+    testTree =+      testGroup+        "CLI"+        [ testGroup commandName (testsFromDirectory commandSpec)+        | commandSpec@CommandSpec {commandName} <- commandSpecs+        ]++testsFromDirectory :: CommandSpec -> [TestTree]+testsFromDirectory spec =+  [ testFromIndex spec index+  | index <- take testsPerCommand [0 ..]+  ]++testFromIndex :: CommandSpec -> Int -> TestTree+testFromIndex CommandSpec {commandName, commandGen} index =+  askOption $ \mode ->+    testCase testFilePath $+      case mode of+        Create -> create+        Update -> update+        Verify -> verify+  where+    testDirectoryPath :: FilePath+    testDirectoryPath = testRootDirectory </> commandName++    testFilePath :: FilePath+    testFilePath = testDirectoryPath </> padIndex index <.> "golden"+      where+        padIndex :: Int -> FilePath+        padIndex = printf "%03d"++    create :: IO ()+    create = do+      exists <- doesFileExist testFilePath+      unless exists $ do+        createDirectoryIfMissing True testDirectoryPath+        writeCommandExpectationToFile testFilePath expectation+      where+        expectation :: CommandExpectation+        expectation = commandInvocationToExpectation invocation++        invocation :: CommandInvocation+        invocation =+          unGen+            (genCommandInvocation commandGen)+            (mkQCGen (generatorSeed + index))+            generatorSize++    update :: IO ()+    update = do+      expectation <- readCommandExpectationFromFile testFilePath+      let observedOutputLines =+            runCommandLine (inputCommandLineArgs expectation)+      unless (observedOutputLines == expectedOutputLines expectation) $+        writeCommandExpectationToFile+          testFilePath+          expectation {expectedOutputLines = observedOutputLines}++    verify :: IO ()+    verify = do+      CommandExpectation+        { inputCommandLineArgs+        , expectedOutputLines+        } <-+        readCommandExpectationFromFile testFilePath+      let observedOutputLines = runCommandLine inputCommandLineArgs+      unless (observedOutputLines == expectedOutputLines) $+        assertFailure $+          Text.unpack $+            Text.unlines+              [ "path:"+              , blockIndent [Text.pack testFilePath]+              , "input:"+              , blockIndent [renderPrompt inputCommandLineArgs]+              , "output expected:"+              , blockIndent expectedOutputLines+              , "output observed:"+              , blockIndent observedOutputLines+              ]+      where+        blockIndent :: [Text] -> Text+        blockIndent = Text.unlines . map ("  " <>)++--------------------------------------------------------------------------------+-- Command expectations+--------------------------------------------------------------------------------++-- | Bundles a command with the output we expect from running the command.+data CommandExpectation = CommandExpectation+  { inputCommandLineArgs :: [Text]+  , expectedOutputLines :: [Text]+  }++writeCommandExpectationToFile :: FilePath -> CommandExpectation -> IO ()+writeCommandExpectationToFile+  path+  CommandExpectation {inputCommandLineArgs, expectedOutputLines} =+    TIO.writeFile path $+      Text.unlines $+        renderPrompt inputCommandLineArgs : expectedOutputLines++readCommandExpectationFromFile+  :: HasCallStack => FilePath -> IO CommandExpectation+readCommandExpectationFromFile path = do+  contents <- TIO.readFile path+  case Text.lines contents of+    [] -> reportEmptyFile+    (prompt : expectedOutputLines) ->+      case parsePrompt prompt of+        Just inputCommandLineArgs ->+          pure CommandExpectation {inputCommandLineArgs, expectedOutputLines}+        Nothing ->+          reportInvalidPrompt+  where+    reportEmptyFile =+      assertFailure $+        unwords+          [ "readCommandExpectationFromFile: empty file:"+          , path+          ]+    reportInvalidPrompt =+      assertFailure $+        unwords+          [ "readCommandExpectationFromFile: invalid prompt line in:"+          , path+          ]++-- | The prefix used for prompt lines in golden files.+promptPrefix :: Text+promptPrefix = "$ taiwan-id "++-- | Parse the arguments from a prompt line of the form:+-- @$ taiwan-id <args...>@+-- Returns 'Nothing' if the line does not have the expected prefix.+parsePrompt :: Text -> Maybe [Text]+parsePrompt = fmap Text.words . Text.stripPrefix promptPrefix++-- | Render a list of arguments as a prompt line of the form:+-- @$ taiwan-id <args...>@+renderPrompt :: [Text] -> Text+renderPrompt args = promptPrefix <> Text.unwords args++--------------------------------------------------------------------------------+-- CLI execution+--------------------------------------------------------------------------------++runCommandLine :: [Text] -> [Text]+runCommandLine args =+  case result of+    CommandLineSuccess ls -> ls+    CommandLineFailure ls -> ls+  where+    result =+      evalRand+        (CLI.run (map Text.unpack args))+        (mkStdGen executionSeed)++commandInvocationToExpectation :: CommandInvocation -> CommandExpectation+commandInvocationToExpectation CommandInvocation {command, optionStyle} =+  CommandExpectation+    { inputCommandLineArgs+    , expectedOutputLines = runCommandLine inputCommandLineArgs+    }+  where+    inputCommandLineArgs = renderInvocationArgs optionStyle command++renderInvocationArgs :: OptionStyle -> Command Raw -> [Text]+renderInvocationArgs style =+  removeEmptyArgs . \case+    Command.Decode DecodeCommand {idText, language} ->+      ["decode", runIdentity idText]+        ++ renderOption style "language" language+    Command.Generate GenerateCommand {count, seed} ->+      ["generate"]+        ++ renderOption style "count" count+        ++ renderOption style "seed" seed+    Command.Validate ValidateCommand {idText} ->+      ["validate", runIdentity idText]+  where+    removeEmptyArgs :: [Text] -> [Text]+    removeEmptyArgs = filter (not . Text.null)++renderOption :: Show a => OptionStyle -> Text -> Maybe a -> [Text]+renderOption _ _ Nothing = []+renderOption style name (Just value) = case style of+  EqualSeparated -> ["--" <> name <> "=" <> Text.show value]+  SpaceSeparated -> ["--" <> name, Text.show value]++--------------------------------------------------------------------------------+-- Command invocations+--------------------------------------------------------------------------------++data CommandInvocation = CommandInvocation+  { command :: Command Raw+  , optionStyle :: OptionStyle+  }+  deriving stock (Eq, Show)++data OptionStyle+  = EqualSeparated+  | SpaceSeparated+  deriving stock (Bounded, Enum, Eq, Show)++--------------------------------------------------------------------------------+-- Generators+--------------------------------------------------------------------------------++genCommandInvocation :: Gen (Command Raw) -> Gen CommandInvocation+genCommandInvocation genCommand =+  CommandInvocation+    <$> genCommand+    <*> genOptionStyle++genCommandDecode :: Gen (Command Raw)+genCommandDecode = do+  idText <- liftArbitrary Test.genIDText+  language <- liftArbitrary Test.genLanguage+  pure $ Command.Decode $ DecodeCommand {idText, language}++genCommandGenerate :: Gen (Command Raw)+genCommandGenerate = do+  count <- liftArbitrary (choose (-1, 4))+  seed <- liftArbitrary (choose (1, 1_000_000))+  pure $ Command.Generate $ GenerateCommand {count, seed}++genCommandValidate :: Gen (Command Raw)+genCommandValidate = do+  idText <- liftArbitrary Test.genIDText+  pure $ Command.Validate $ ValidateCommand {idText}++genOptionStyle :: Gen OptionStyle+genOptionStyle = arbitraryBoundedEnum

@@ -0,0 +1,6 @@+module Main (main) where++import Test.DocTest (mainFromCabal)++main :: IO ()+main = mainFromCabal "taiwan-id" []

@@ -0,0 +1,343 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{- HLINT ignore "Redundant bracket" -}++module Main (main) where++import Lens.Micro+  ( Lens', lens, set )+import Lens.Micro.Extras+  ( view )+import Taiwan.ID+  ( ID (..) )+import Taiwan.ID.CharIndex+  ( CharIndex (CharIndex) )+import Taiwan.ID.CharSet+  ( CharSet (..) )+import Taiwan.ID.Digit+  ( Digit (..) )+import Taiwan.ID.Digit1289+  ( Digit1289 (..) )+import Taiwan.ID.Gender+  ( Gender (..) )+import Taiwan.ID.Issuer+  ( Issuer (..) )+import Taiwan.ID.Language+  ( Language (..) )+import Taiwan.ID.Letter+  ( Letter (..) )+import Taiwan.ID.Region+  ( Region )+import Taiwan.ID.Test+  ( unsafePokeChar )+import Test.Hspec+  ( Spec, describe, hspec, it, shouldBe, shouldSatisfy )+import Test.QuickCheck+  ( Arbitrary (..)+  , NonEmptyList (..)+  , Property+  , choose+  , elements+  , forAll+  , property+  , (===)+  )+import Test.QuickCheck.Classes+  ( boundedEnumLaws, eqLaws, numLaws, ordLaws, showLaws, showReadLaws )+import Test.QuickCheck.Classes.Hspec+  ( testLawsMany )++import qualified Data.Finitary as Finitary+import qualified Data.Set.NonEmpty as NESet+import qualified Data.Text as T+import qualified Taiwan.ID as ID+import qualified Taiwan.ID.Test as Test++instance Arbitrary Digit where+  arbitrary = Test.genDigit+  shrink = Test.shrinkDigit++instance Arbitrary Digit1289 where+  arbitrary = Test.genDigit1289+  shrink = Test.shrinkDigit1289++instance Arbitrary Gender where+  arbitrary = Test.genGender+  shrink = Test.shrinkGender++instance Arbitrary ID where+  arbitrary = Test.genID+  shrink = Test.shrinkID++instance Arbitrary Issuer where+  arbitrary = Test.genIssuer+  shrink = Test.shrinkIssuer++instance Arbitrary Language where+  arbitrary = Test.genLanguage+  shrink = Test.shrinkLanguage++instance Arbitrary Letter where+  arbitrary = Test.genLetter+  shrink = Test.shrinkLetter++instance Arbitrary Region where+  arbitrary = Test.genRegion+  shrink = Test.shrinkRegion++main :: IO ()+main = hspec $ do++  describe "Class laws" $ do++    testLawsMany @Digit+        [ boundedEnumLaws+        , eqLaws+        , numLaws+        , ordLaws+        , showLaws+        , showReadLaws+        ]++    testLawsMany @Digit1289+        [ boundedEnumLaws+        , eqLaws+        , ordLaws+        , showLaws+        , showReadLaws+        ]++    testLawsMany @Gender+        [ boundedEnumLaws+        , eqLaws+        , ordLaws+        , showLaws+        , showReadLaws+        ]++    testLawsMany @ID+        [ eqLaws+        , ordLaws+        , showLaws+        , showReadLaws+        ]++    testLawsMany @Issuer+        [ boundedEnumLaws+        , eqLaws+        , ordLaws+        , showLaws+        , showReadLaws+        ]++    testLawsMany @Language+        [ boundedEnumLaws+        , eqLaws+        , ordLaws+        , showLaws+        , showReadLaws+        ]++    testLawsMany @Letter+        [ boundedEnumLaws+        , eqLaws+        , ordLaws+        , showLaws+        , showReadLaws+        ]++    testLawsMany @Region+        [ boundedEnumLaws+        , eqLaws+        , ordLaws+        , showLaws+        , showReadLaws+        ]++  describe "Finitary instances" $ do++    describe "ID" $ do++      let start    = Finitary.start    @ID+          end      = Finitary.end      @ID+          previous = Finitary.previous @ID+          next     = Finitary.next     @ID++      it "previous start" $+          previous start+            `shouldBe` Nothing++      it "start" $+          start+            `shouldBe` ID.fromSymbol @"A100000001"++      it "next start" $+          next start+            `shouldBe` Just (ID.fromSymbol @"A100000010")++      it "previous end" $+          previous end+            `shouldBe` Just (ID.fromSymbol @"Z999999987")++      it "end" $+          end+            `shouldBe` ID.fromSymbol @"Z999999996"++      it "next end" $+          next end+            `shouldBe` Nothing++  describe "ID attribute getters and setters" $ do++    describe "Gender" $+      checkLensLaws gender+    describe "Issuer" $+      checkLensLaws issuer+    describe "Region" $+      checkLensLaws region++  describe "ID.fromText" $ do++    it "successfully parses known-valid identification numbers" $+      forAll (elements knownValidIDs) $ \i ->+      ID.fromText (ID.toText i) `shouldBe` Right i++    it "successfully parses valid identification numbers" $+      property $+      forAll Test.genID $ \validID ->+      ID.fromText (ID.toText validID) `shouldBe` Right validID++    it "does not parse identification numbers that are too short" $+      property $+      forAll Test.genIDTextInvalidLengthTooShort $ \invalidID ->+      ID.fromText invalidID `shouldBe` Left ID.InvalidLength++    it "does not parse identification numbers that are too long" $+      property $+      forAll Test.genIDTextInvalidLengthTooLong $ \invalidID ->+      ID.fromText invalidID `shouldBe` Left ID.InvalidLength++    it "does not parse identification numbers with invalid region codes" $+      property $+      forAll (Test.genIDTextInvalidCharAtIndex 0) $ \invalidID ->+      ID.fromText invalidID `shouldBe` Left+        (ID.InvalidChar 0 (CharRange 'A' 'Z'))++    it "does not parse identification numbers with invalid initial digits" $+      property $+      forAll (Test.genIDTextInvalidCharAtIndex 1) $ \invalidID ->+      ID.fromText invalidID `shouldBe` Left+        (ID.InvalidChar 1 (CharSet $ NESet.fromList ['1', '2', '8', '9']))++    it "does not parse identification numbers with invalid serial digits" $+      property $+      forAll (choose (2, 9)) $ \invalidCharIndex ->+      forAll (Test.genIDTextInvalidCharAtIndex invalidCharIndex) $ \invalidID ->+      ID.fromText invalidID `shouldBe` Left+        (ID.InvalidChar (CharIndex invalidCharIndex) (CharRange '0' '9'))++    it "does not parse identification numbers with invalid checksums" $+      property $+      forAll Test.genIDTextInvalidChecksum $ \invalidID ->+      ID.fromText invalidID `shouldBe` Left ID.InvalidChecksum++    it "reports invalid characters even when input is too short" $+      property $ \(i :: ID) ->+      forAll Test.genInvalidChar $ \invalidChar ->+      forAll (choose (1, 9)) $ \truncatedLength ->+      forAll (choose (0, truncatedLength - 1)) $ \invalidCharIndex -> do+      let truncatedID = T.take truncatedLength (ID.toText i)+      let invalidID = unsafePokeChar invalidCharIndex truncatedID invalidChar+      ID.fromText invalidID `shouldSatisfy` \case+        Left (ID.InvalidChar (CharIndex index) _)+          | index == invalidCharIndex -> True+        _ -> False++    it "does not report invalid characters if input is too long" $+      property $ \(NonEmpty trailingExcess) ->+      forAll Test.genIDTextInvalidChar $ \invalidID ->+      ID.fromText (invalidID <> T.pack trailingExcess) `shouldBe`+        Left ID.InvalidLength++checkLensLaws+  :: forall i v. (Arbitrary i, Arbitrary v, Eq i, Eq v, Show i, Show v)+  => Lens' i v+  -> Spec+checkLensLaws l =+  do+    it "Finality"+      $ property lensLawFinality+    it "Idempotence"+      $ property lensLawIdempotence+    it "Invertibility"+      $ property lensLawInvertibility+    it "Reversibility"+      $ property lensLawReversibility+    it "Stability"+      $ property lensLawStability+  where+    lensLawFinality :: i -> v -> v -> Property+    lensLawFinality i v1 v2 = set l v2 (set l v1 i) === set l v2 i++    lensLawIdempotence :: i -> v -> Property+    lensLawIdempotence i v = set l v (set l v i) === set l v i++    lensLawInvertibility :: i -> v -> Property+    lensLawInvertibility i v = view l (set l v i) === v++    lensLawReversibility :: i -> v -> Property+    lensLawReversibility i v = set l (view l i) (set l v i) === i++    lensLawStability :: i -> Property+    lensLawStability i = set l (view l i) i === i++gender :: Lens' ID Gender+gender = lens ID.getGender (flip ID.setGender)++issuer :: Lens' ID Issuer+issuer = lens ID.getIssuer (flip ID.setIssuer)++region :: Lens' ID Region+region = lens ID.getRegion (flip ID.setRegion)++-- | A set of known-valid ID numbers.+--+-- Generated with 身分證字號產生器.+--+-- See: https://www.csie.ntu.edu.tw/~b90057/use/ROCid.html+--+knownValidIDs :: [ID]+knownValidIDs =+  [ ID.fromSymbol @"A123961383"+  , ID.fromSymbol @"B210742224"+  , ID.fromSymbol @"C120930548"+  , ID.fromSymbol @"D257991149"+  , ID.fromSymbol @"E127379116"+  , ID.fromSymbol @"F235628112"+  , ID.fromSymbol @"G105851924"+  , ID.fromSymbol @"H247910878"+  , ID.fromSymbol @"I118949082"+  , ID.fromSymbol @"J218475156"+  , ID.fromSymbol @"K150252170"+  , ID.fromSymbol @"L298479266"+  , ID.fromSymbol @"M114415878"+  , ID.fromSymbol @"N242846162"+  , ID.fromSymbol @"O184333688"+  , ID.fromSymbol @"P257366789"+  , ID.fromSymbol @"Q163999855"+  , ID.fromSymbol @"R275744925"+  , ID.fromSymbol @"S158047168"+  , ID.fromSymbol @"T296696104"+  , ID.fromSymbol @"U108929984"+  , ID.fromSymbol @"V245356279"+  , ID.fromSymbol @"W127612989"+  , ID.fromSymbol @"X234128072"+  , ID.fromSymbol @"Y140531128"+  , ID.fromSymbol @"Z250358466"+  ]

@@ -0,0 +1,72 @@+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | Provides testing functions to check that type class instances obey laws.+module Test.QuickCheck.Classes.Hspec+    ( testLaws+    , testLawsMany+    ) where++import Prelude++import Control.Monad+    ( forM_+    )+import Data.Proxy+    ( Proxy (..)+    )+import Data.Typeable+    ( Typeable+    , typeRep+    )+import Test.Hspec+    ( Spec+    , describe+    , it+    , parallel+    )+import Test.QuickCheck.Classes+    ( Laws (..)+    )++-- | Constructs a test to check that the given type class instance obeys the+--   given set of laws.+--+-- Example usage:+--+-- >>> testLaws @Natural ordLaws+-- >>> testLaws @(Map Int) functorLaws+testLaws+    :: forall a+     . Typeable a+    => (Proxy a -> Laws)+    -> Spec+testLaws getLaws =+    parallel+        $ describe description+        $ forM_ (lawsProperties laws)+        $ uncurry it+    where+        description =+            mconcat+                [ "Testing "+                , lawsTypeclass laws+                , " laws for type "+                , show (typeRep $ Proxy @a)+                ]+        laws = getLaws $ Proxy @a++-- | Calls `testLaws` with multiple sets of laws.+--+-- Example usage:+--+-- >>> testLawsMany @Natural [eqLaws, ordLaws]+-- >>> testLawsMany @(Map Int) [foldableLaws, functorLaws]+testLawsMany+    :: forall a+     . Typeable a+    => [Proxy a -> Laws]+    -> Spec+testLawsMany getLawsMany =+    testLaws @a `mapM_` getLawsMany

@@ -1,6 +1,6 @@ cabal-version:  3.0 name:           taiwan-id-version:        0.1.0.0+version:        0.1.1.0 synopsis:       Implementation of Taiwan's uniform ID number format. category:       Identification homepage:       https://github.com/jonathanknowles/taiwan-id#readme@@ -10,7 +10,7 @@ copyright:      Jonathan Knowles license:        BSD-3-Clause license-file:   LICENSE-build-type:     Custom+build-type:     Simple  description: @@ -28,14 +28,16 @@    Example: `A123456789` -  This package offers functions for validating, decoding, and encoding these-  numbers.+  This package offers a library with functions for validating, decoding, and+  encoding these numbers, as well as a command-line tool for working with them+  interactively.    See the "Taiwan.ID" module to get started.    For more details, see:    * https://zh.wikipedia.org/wiki/中華民國國民身分證+  * https://zh.wikipedia.org/wiki/中華民國居留證   * https://en.wikipedia.org/wiki/National_identification_card_(Taiwan)   * https://en.wikipedia.org/wiki/Resident_certificate @@ -45,36 +47,51 @@  common dependency-base     build-depends:base                      >= 4.17.2.1     && < 4.22-common dependency-doctest-    build-depends:doctest                   >= 0.24.2       && < 0.25+common dependency-directory+    build-depends:directory                 >= 1.3.7.1      && < 1.4+common dependency-doctest-parallel+    build-depends:doctest-parallel          >= 0.4.1        && < 0.5+common dependency-filepath+    build-depends:filepath                  >= 1.4.2.2      && < 1.6 common dependency-finitary     build-depends:finitary                  >= 2.2.0.0      && < 2.3 common dependency-finite-typelits     build-depends:finite-typelits           >= 0.2.1.0      && < 0.3 common dependency-hspec-    build-depends:hspec                     >= 2.5.5        && < 2.12+    build-depends:hspec                     >= 2.11.17      && < 2.12 common dependency-microlens     build-depends:microlens                 >= 0.5.0.0      && < 0.6 common dependency-MonadRandom-    build-depends:MonadRandom               >= 0.5.1.1      && < 0.7+    build-depends:MonadRandom               >= 0.6.2.1      && < 0.7 common dependency-nonempty-containers     build-depends:nonempty-containers       >= 0.3.5.0      && < 0.4+common dependency-optparse-applicative+    build-depends:optparse-applicative      >= 0.19.0.0     && < 0.20 common dependency-QuickCheck-    build-depends:QuickCheck                >= 2.13.2       && < 2.18+    build-depends:QuickCheck                >= 2.16.0.0     && < 2.17 common dependency-quickcheck-classes     build-depends:quickcheck-classes        >= 0.6.5.0      && < 0.7+common dependency-random+    build-depends:random                    >= 1.3.1        && < 1.4+common dependency-tasty+    build-depends:tasty                     >= 1.5.3        && < 1.6+common dependency-tasty-hunit+    build-depends:tasty-hunit               >= 0.10.2       && < 0.11 common dependency-text-    build-depends:text                      >= 1.2.3.1      && < 2.2--custom-setup-  setup-depends:-    , base                                  >= 4.17.2.1     && < 4.22-    , cabal-doctest                         >= 1.0.12       && < 1.1+    build-depends:text                      >= 2.1.4        && < 2.2  source-repository head   type: git   location: https://github.com/jonathanknowles/taiwan-id +flag taiwan-id-doc-test+  description:+    Enables the `taiwan-id-doc-test` test suite.+    Requires that the package is built with:+    write-ghc-environment-files: always+  default:     False+  manual:      True+ library   import:     , dependency-base@@ -98,10 +115,60 @@       Taiwan.ID.Unchecked       Taiwan.ID.Utilities   hs-source-dirs:-      components/taiwan-id+      components/lib/taiwan-id   ghc-options: -Wall   default-language: Haskell2010 +library taiwan-id-cli+  import:+    , dependency-base+    , dependency-MonadRandom+    , dependency-nonempty-containers+    , dependency-optparse-applicative+    , dependency-random+    , dependency-text+  build-depends:+    , taiwan-id+  exposed-modules:+      Taiwan.ID.CLI+  other-modules:+      Paths_taiwan_id+  autogen-modules:+      Paths_taiwan_id+  hs-source-dirs:+      components/lib/taiwan-id-cli+  ghc-options: -Wall+  default-language: Haskell2010+  visibility: private++library taiwan-id-test-common+  import:+    , dependency-base+    , dependency-QuickCheck+    , dependency-text+  build-depends:+    , taiwan-id+  exposed-modules:+      Taiwan.ID.Test+  hs-source-dirs:+      components/lib/taiwan-id-test-common+  ghc-options: -Wall+  default-language: Haskell2010+  visibility: private++executable taiwan-id+  import:+    , dependency-base+    , dependency-MonadRandom+    , dependency-text+  build-depends:+    , taiwan-id-cli+  main-is: Main.hs+  hs-source-dirs:+      components/exe/taiwan-id+  ghc-options: -Wall+  default-language: Haskell2010+ test-suite taiwan-id-test   import:     , dependency-base@@ -114,26 +181,52 @@     , dependency-quickcheck-classes     , dependency-text   type: exitcode-stdio-1.0-  main-is: Spec.hs+  main-is: Main.hs   other-modules:       Test.QuickCheck.Classes.Hspec   hs-source-dirs:-      components/taiwan-id-test+      components/test/taiwan-id-test   ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N   build-depends:     , taiwan-id+    , taiwan-id-test-common   default-language: Haskell2010 -test-suite taiwan-id-test-docs+test-suite taiwan-id-cli-test   import:     , dependency-base-    , dependency-doctest+    , dependency-directory+    , dependency-filepath+    , dependency-MonadRandom+    , dependency-QuickCheck+    , dependency-quickcheck-classes+    , dependency-random+    , dependency-tasty+    , dependency-tasty-hunit+    , dependency-text+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+  hs-source-dirs:+      components/test/taiwan-id-cli-test+  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N   build-depends:     , taiwan-id-  x-doctest-options: --verbose+    , taiwan-id-cli+    , taiwan-id-test-common+  default-language: Haskell2010++test-suite taiwan-id-doc-test+  import:+    , dependency-base+    , dependency-doctest-parallel+  if !flag(taiwan-id-doc-test)+    buildable: False+  build-depends:+    , taiwan-id   type: exitcode-stdio-1.0   main-is: Main.hs   hs-source-dirs:-    components/taiwan-id-test-docs+    components/test/taiwan-id-doc-test   ghc-options: -threaded   default-language: Haskell2010