Implement a stricter parser that rejects invalid sequences of RomanChars and provide total functions to parse and validate RomanNums

src/Data/RomanNum.hs

@@ -1,14 +1,18 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 module Data.RomanNum (
       RomanNum(..)
     , nullus
+    , parse
     , plus
     , r
+    , validate
   ) where
 
 import Data.Map (Map, (!))
 import qualified Data.Map as Map (fromList)
+import Text.Read (readMaybe)
 
-newtype RomanNum = RomanNum Int
+newtype RomanNum = RomanNum Int deriving (Eq, Ord, Enum)
 
 data RomanChar = I | V | X | L | C | D | M deriving (Bounded, Eq, Ord, Enum, Show, Read)
 
@@ -45,14 +49,53 @@ instance Show RomanNum where
     times count letter = take count $ repeat letter
 
 r :: String -> RomanNum
-r "" = nullus
-r "nullus" = nullus
-r n@[_] = RomanNum (values ! (read n))
-r (digit:nextDigit:otherDigits) =
-  let (rChar, nextRChar) = (read [digit], read [nextDigit]) in
-  if rChar < nextRChar
-  then RomanNum (values ! nextRChar - values ! rChar) `plus` r otherDigits
-  else RomanNum (values ! rChar) `plus` r(nextDigit:otherDigits)
+r = either error id . parse
+
+validate :: String -> Bool
+validate = either (\_ -> False) (\_ -> True) . parse
+
+readDigit :: Char -> Either String Int
+readDigit c = maybe errMsg (Right . (values !)) $ readMaybe [c]
+  where
+    errMsg = Left $ "Not a roman digit: «" ++ c:"»"
+
+log10 :: Int -> Int
+log10 n = length (show n) - 1
+
+parse :: String -> Either String RomanNum
+parse "" = Right nullus
+parse "nullus" = Right nullus
+parse s = RomanNum <$>
+  (mapM readDigit s >>= mapM analyzeBlock . romanGroups >>= romanSum)
+  where
+    romanGroups [] = []
+    romanGroups (x:xs) =
+      let groups = romanGroups xs in
+      case groups of
+        (group@(y:_):otherGroups)
+          | x <= y -> (x:group):otherGroups
+        _ -> [x]:groups
+
+    analyzeBlock [n] = Right (log10 n, n)
+    analyzeBlock l@(n1:n2:ns)
+      | n1 == 10 ^ p =
+        if n1 < n2 && 10*n1 >= n2 && null ns
+        then Right (p, n2 - n1)
+        else if n1 == n2 && all (== n1) ns && length ns < 2
+        then Right (p, (length ns +2)*n1)
+        else invalidSequence l
+      where
+        p = log10 n1
+    analyzeBlock l = invalidSequence l
+
+    romanSum [] = Right 0
+    romanSum [(_, n)] = Right n
+    romanSum ((p1, n1):blocks@((p2, n2):otherBlocks))
+      | p1 > p2 = (n1+) <$> romanSum blocks
+      | p1 == p2 && n1 == 5*10^p1 && n2 < n1 = (n1+n2+) <$> romanSum otherBlocks
+      | otherwise = invalidSequence [n1, n2]
+    invalidSequence l =
+      Left $ "Invalid sequence : " ++ concat (show . RomanNum <$> l)
 
 nullus :: RomanNum
 nullus = RomanNum 0