Test_Validation.hs

{-# LINE 24 "Validation.lhs" #-}
{-#  OPTIONS -Wall -fno-warn-type-defaults  #-}

module Tests.Src.Test_Validation where

import Data.Char
import Data.List
{-# LINE 148 "Validation.lhs" #-}
-- @@ Export
toDigitsRev :: Integer -> [Integer]
{-# LINE 154 "Validation.lhs" #-}
-- @@ Export
toDigits :: Integer -> [Integer]
{-# LINE 158 "Validation.lhs" #-}
-- @@ Export
toDigitsRev = reverse . toDigits
{-# LINE 176 "Validation.lhs" #-}
-- @@ Export
doubleSecond :: [Integer] -> [Integer]
{-# LINE 192 "Validation.lhs" #-}
-- @@ Export
sumDigits :: [Integer] -> Integer
{-# LINE 207 "Validation.lhs" #-}
-- @@ Export
validate :: Integer -> Bool
{-# LINE 237 "Validation.lhs" #-}
-- @@ Export
readCC :: String -> Integer
{-# LINE 254 "Validation.lhs" #-}
-- @@ Export
showCC :: Integer -> String
{-# LINE 291 "Validation.lhs" #-}
-- @@ Export
lookupIssuer :: String -> Integer -> IO String
{-# LINE 328 "Validation.lhs" #-}
-- @@ Export
checkCC :: String -> IO ()
{-# LINE 370 "Validation.lhs" #-}
-- @@ Export
toDigitsRevG :: Integer -> Integer -> [Integer]
{-# LINE 396 "Validation.lhs" #-}
toDigitsRev' :: Integer -> [Integer]
toDigitsRev' 0    = [0]
toDigitsRev' num  = go (abs num)
  where
    go 0  = []
    go n  = r : go q
      where (q, r) = quotRem n 10

toDigits = reverse . toDigitsRev'

--  Tricky cases:
--  * base too small
--  * num == minBound
toDigitsRevG base num
  | base < 2                        = []
  | abs num >= 0 && abs num < base  = abs num : []
  | num < 0                         = let (q, r) = quotRem num base in negate r : go (negate q) 
  | otherwise                       = let (q, r) = quotRem num base in r : go q
  where
    go n
      | n < base   = n : []
      | otherwise  = let (q, r) = quotRem n base in r : go q

toDigitsRevG' :: (Integral a) => a -> a -> [a]
toDigitsRevG' base num
  | base < 2                        = []
  | num == 0                        = [0]
  | otherwise                       = map fromInteger . go . abs $ toInteger num
  where
    go 0  = []
    go n  = r : go q
      where (q, r) = quotRem n (toInteger base)

doubleSecond = go1
  where
    d x = x + x
    go1 []      = []
    go1 (x:xs)  = x   : go2 xs
    go2 []      = []
    go2 (x:xs)  = d x : go1 xs

sumDigits = sum . concatMap toDigitsRev

validate n = s `mod` 10 == 0
  where
    d1 = toDigitsRev n
    d2 = doubleSecond d1
    s  = sumDigits d2

ds :: String -> String
ds = dropWhile isSpace

readCC s = read s3 * (10 ^ 12) + read s2 * 10 ^ 8 + read s1 * 10 ^ 4 + read s0
  where
    (s3, s210) = splitAt 4 (ds s)
    (s2, s10)  = splitAt 4 (ds s210)
    (s1, s0r)  = splitAt 4 (ds s10)
    s0         = ds s0r

readCC' :: String -> Integer
readCC' s = n3 * (10 ^ 12) + n2 * 10 ^ 8 + n1 * 10 ^ 4 + n0
  where
    (n3, s210):_ = reads (ds s)
    (n2, s10):_  = reads (ds s210)
    (n1, s0r):_  = reads (ds s10)
    (n0, _):_    = reads (ds s0r)

showCC n = s3 ++ " " ++ s2 ++ " " ++ s1 ++ " " ++ s0
  where
    ns = show n
    zs = replicate (16 - length ns) '0'
    s = zs ++ ns
    (s3, s210) = splitAt 4 s
    (s2, s10)  = splitAt 4 s210
    (s1, s0)   = splitAt 4 s10

lookupIssuer file num = do

  --  Read the file in as String
  text <- readFile file

  --  Transform string lines into triples
  let entries = toEntries text

  --  Account for longer prefixes that override shorter ones by doing a
  --  reverse lexicographical sort on the prefix digits.
  let sorted = reverse $ sort $ entries

  --  Get the possible issuer by searching the sorted entries until we arrive at
  --  one that matches the prefix of the number and matches the length.
  let issuer = toIssuer sorted num

  --  Account for unknown issuer
  case issuer of
    []     -> return "Unknown"
    name:_ -> return name

--  Format entries as [(<prefix digits>, <length>, <issuer>)]
toEntries :: String -> [([Integer], Int, String)]
toEntries text = do
  ln <- lines text
  (prefix, rest) <- reads ln
  let prefixDigits = toDigits prefix
  (expectedLength, _:issuer) <- reads rest
  return (prefixDigits, expectedLength, issuer)

toIssuer :: [([Integer], Int, String)] -> Integer -> [String]
toIssuer entries num = do
  (prefixDigits, expectedLength, issuer) <- entries
  if prefixMatch prefixDigits numDigits && expectedLength == numLength
    then return issuer
    else []
  where
    prefixMatch xs ys = and $ zipWith (==) xs ys
    numDigits = toDigits num
    numLength = length numDigits


checkCC file = do
  putStr "Enter credit card number: "
  numText <- getLine
  let numIn = readCC numText
  issuer <- lookupIssuer file numIn
  let s1 = "The number " ++ showCC numIn ++ " is "
  let s2 = if validate numIn
             then ("valid and the type is " ++ issuer ++ ".")
             else ("not a valid credit card number.")
  putStrLn (s1 ++ s2)
  checkCC file