Writing Integers in English

{-# LANGUAGE ParallelListComp #-}

module IntegerIsString where

import Control.Monad (mplus, guard, ap)
import Data.Char (toLower)
import Data.Maybe (fromMaybe)
import Data.String
import Text.ParserCombinators.Parsec

-- We're interested in making an IsString instance for Integers that
-- lets us write the Strings in English.  For example, we want to
-- write ("twenty-three" + "five") and get 28.

instance IsString Integer where
    fromString s = fromMaybe invalid (readEnglishInteger s)
        where invalid = error "IntegerIsString.fromString: invalid string"

-- Our implementation of fromString assumes that 'readEnglishInteger'
-- has the type, String -> Maybe Integer.  It is now up to us to
-- implement that function.

-- So we're interested in making a function that parses a string to
-- read an integer.  In other words, a function that takes in "one
-- thousand twenty-nine" and returns (Just 1029).  We'll use a Parsec
-- parser to cleanly do the dirty work; we'll just call the parser and
-- pass on the result.

readEnglishInteger :: String -> Maybe Integer
readEnglishInteger s = case parse number "" s of
                         Left err -> Nothing
                         Right x  -> Just x



number :: Parser Integer
number = try zero <|> nonzero

zero :: Parser Integer
zero = do word "zero"
          noMoreWords
          return 0

noMoreWords :: Parser ()
noMoreWords = do optional spaces
                 eof

word :: String -> Parser ()
word s = try $ do optional spaces
                  string s
                  lookAheadEndOfWord

lookAheadEndOfWord :: Parser ()
lookAheadEndOfWord = lookAhead $ (eof <|> do { space ; return () })




nonzero :: Parser Integer
nonzero = maybeNegate `ap` positiveNumber

maybeNegate :: Parser (Integer -> Integer)
maybeNegate = option id $ do { word "negative" ; return negate }


positiveNumber :: Parser Integer
positiveNumber = decliningPeriods 0 (1 + maxPeriod)

somePeriod :: Parser (Integer, Integer)
somePeriod = do h <- hundredsPlace
                t <- twoDigit
                guard (h > 0  ||  t > 0)
                p <- periodName
                return ((h * 100 + t) * (1000 ^ p), p)

-- Periods must come in decreasing order.  You can't say "three
-- million two billion five".
decliningPeriods :: Integer -> Integer -> Parser Integer
decliningPeriods sum periodNum = finished <|> notFinished
    where finished   = try $ do noMoreWords
                                guard (sum /= 0) -- avoids empty strings
                                return sum
          notFinished = do (n, smallerPeriodNum) <- somePeriod
                           guard (smallerPeriodNum < periodNum)
                           decliningPeriods (n + sum) smallerPeriodNum

hundredsPlace :: Parser Integer
hundredsPlace = option 0 (try $ do d <- digitName
                                   word "hundred"
                                   return d)

twoDigit :: Parser Integer
twoDigit = lessThanNineteen <|> moreThanNineteen

lessThanNineteen = tryAll names [1..19]
    where names = digits ++ [ "ten", "eleven", "twelve", "thirteen"
                            , "fourteen", "fifteen", "sixteen"
                            , "seventeen", "eighteen", "nineteen"
                            ]

moreThanNineteen = do optional spaces
                      t <- tightTensDigit
                      u <- option 0 tensDigitTail
                      return (10 * t + u)
    where tightTensDigit = choice [ do try (string s)
                                       return n
                                    | s <- tens
                                    | n <- [2..9]
                                  ]
          tens = [ "twenty", "thirty", "forty", "fifty"
                 , "sixty", "seventy", "eighty", "ninety"
                 ]
          tensDigitTail = (do lookAheadEndOfWord
                              return 0)
                          <|>
                          (do char '-'
                              notFollowedBy space
                              digitName)

-- This combinator tries a bunch of words and returns the value in the
-- parallel list matching the word it finds
tryAll :: [String] -> [a] -> Parser a
tryAll strs ns = try $ choice [ do word s
                                   return n
                                | s <- strs
                                | n <- ns
                              ]


digitName = tryAll digits [1..9]

digits = [ "one", "two", "three", "four", "five"
         , "six", "seven", "eight", "nine"
         ]

periodName = tryAll periods [1..]
             <|>
             (do noMoreWords
                 return 0)

periods = [ "thousand", "million", "billion", "trillion", "quadrillion"
          , "quintillion", "sextillion", "septillion", "octillion"
          , "nonillion", "decillion", "undecillion"
          ]

maxPeriod = toInteger (length periods)