Calcola il codice fiscale con Haskell! Usa lo stesso DB del progetto https://github.com/DavideCanton/PyCodiceFiscale

CF.hs

{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}

 
module CF.CF where
 
import           Control.Arrow
import           Control.Monad
import           Control.Monad.Error
import           Data.Char
import           Data.List
import           Data.List.Split
import           Data.Time
import           Database.HDBC
import           Database.HDBC.Sqlite3
import           System.Environment
import           System.Exit
import           System.IO
 
default(Int)
 
data PersonData = PersonData String String Char Day String deriving Show
 
 
mkPersonData :: String -> String -> Char -> Day -> String -> PersonData
mkPersonData nameS surnameS sexS = PersonData (mToUpper nameS) (mToUpper surnameS) (toUpper sexS)
    where mToUpper = map toUpper
 
 
capitalize :: String -> String
capitalize [] = []
capitalize (x:xs) = toUpper x : map toLower xs
 
 
findComune :: String -> ErrorT String IO String
findComune name = do
    conn <- lift $ connectSqlite3 "src/CF/comuni.db"
    stmt <- lift $ prepare conn "select code from comuni where name = ?"
    _    <- lift $ execute stmt [toSql name]
    res  <- lift $ fetchRow stmt
    case res of
        Nothing       -> throwError "Comune non valido!"
        (Just values) -> return $ (fromSql . head) values

 
toDate :: String -> Either String Day
toDate s = do
    let pieces = splitOn "/" s
    when (length pieces /= 3) (throwError "Data non valida!")
    let [d, m, y] = map read pieces
    case fromGregorianValid (fromIntegral y) m d of
        Nothing     -> throwError "Data non valida!"
        (Just date) -> return date
 
 
concatenateCF :: String -> String -> Bool -> String
concatenateCF consonants vowels isSurname
    | length consonants > 3 && not isSurname = skip2nd consonants ++ vowels -- skip 2nd consonant
    | otherwise                              = consonants ++ vowels
    where skip2nd (x:xs) = x:tail xs
          skip2nd []     = []
 
 
formatName :: Bool -> String -> String
formatName isSurname name = take 3 $ concatenateCF consonants vowels isSurname ++ "XXX"
    where (vowels, consonants) = partition (`elem` "AEIOU") filtered
          filtered = filter isLetter $ map toUpper name          
 
 
oddTable :: [Int]
oddTable = [1, 0, 5, 7, 9, 13, 15, 17, 19, 21, 2, 4, 18, 20, 11, 3, 6, 8, 12, 14, 16, 10, 22, 25, 24, 23]
 
 
pad02 :: (Integral a, Show a) => a -> String
pad02 n
    | n < 10    = '0' : show n
    | otherwise = show n
 
 
formatDate :: Day -> Char -> String
formatDate date sex = pad02 (year `mod` 100) ++ [codeM month] ++ pad02 (day + offset sex)
    where (year, month, day) = toGregorian date
          codeM m = "ABCDEHLMPRST" !! (m - 1)
          offset 'M' = 0
          offset 'F' = 40
 
 
computeCtrl :: String -> Char
computeCtrl code = chr $ ord 'A' + (acc_o + acc_e) `mod` 26
    where (odds, evens) = (map snd *** map snd) . partition (odd . fst) . zip [1..] $ code
          acc_o = sumMap oddIndex odds
          acc_e = sumMap evenIndex evens
          sumMap f = foldl' (\a e -> a + f e) 0
          index el = ord el - ord (if isDigit el then '0' else 'A')
          evenIndex = index
          oddIndex el = oddTable !! index el
 
 
computeCF :: PersonData -> String
computeCF (PersonData name surname sex date comune) = code ++ [computeCtrl code]
    where code = formatName True surname ++ formatName False name ++ formatDate date sex ++ comune
 
 
getData :: String -> String -> String -> String -> String -> ErrorT String IO PersonData
getData nameS surnameS sexS dateS comuneS = do
    when (null nameS) (throwError "Nome vuoto!")
    when (null surnameS) (throwError "Cognome vuoto!")
    when (null sexS || length sexS /= 1 || head sexS `notElem` "mMfF") (throwError "Sesso non valido!")
    date <- ErrorT . return . toDate $ dateS -- lift from Either monad to ErrorT monad transformer
    code <- findComune (map toUpper comuneS)
    return $ mkPersonData nameS surnameS (head sexS) date code
 
 
printErrMsg :: String -> IO a
printErrMsg msg = do
    hPutStrLn stderr msg
    exitFailure
 
 
output :: Either String PersonData -> IO ()
output (Left err) = printErrMsg err
output (Right personData@(PersonData name surname sex _ _)) = do
    putStr $ "Car" ++ (if sex == 'M' then "o" else "a") ++ " "
    putStr $ capitalize surname ++ " "
    putStr $ capitalize name ++ ", il tuo codice fiscale e': "
    putStrLn $ computeCF personData
 
 
main :: IO ()
main = (do
    [name, surname, sex, date, comune] <- getArgs      
    input_data <- runErrorT (getData name surname sex date comune)
    output input_data)
    `catchError` (\_ -> printErrMsg "Argomenti non validi!")