Parser for Roman Numerals

romNumParser.hs

import Text.ParserCombinators.Parsec (char, many1, string, choice, try, parse)
import Text.Parsec.Prim (parserReturn, parserFail, ParsecT)
import Data.Functor
import Data.Functor.Identity
import Data.Either
import Test.Hspec

sat :: String -> (a -> Bool) -> ParsecT s u m a -> ParsecT s u m a
sat msg predicate parser = parser >>= (\x -> if predicate x then parserReturn x else parserFail msg)

strictDecr :: Ord a => ParsecT s u m [a] -> ParsecT s u m [a]
strictDecr =
  sat msg (\xs -> and (zipWith (>) xs (drop 1 xs)))
    where msg = "unexpected order of values\nexpected strictly decreasing values"

romPrimCombiVal :: ParsecT [Char] u Identity Integer
romPrimCombiVal = 
  choice [
    (\_ -> 4) <$> (try $ string "IV"),
    (\_ -> 9) <$> (try $ string "IX"),
    (\_ -> 40) <$> (try $ string "XL"),
    (\_ -> 90) <$> (try $ string "XC"),
    (\_ -> 400) <$> (try $ string "CD"),
    (\_ -> 900) <$> (try $ string "CM"),
    sat "unexpected repetitions of symbol `I`\nexpected symbol to appear 3 times at most" (<= 3) $ sum <$> many1 ((\_ -> 1) <$> (char 'I')),
    sat "unexpected repetitions of symbol `X`\nexpected symbol to appear 3 times at most" (<= 30) $ sum <$> many1 ((\_ -> 10) <$> (char 'X')),
    sat "unexpected repetitions of symbol `C`\nexpected symbol to appear 3 times at most" (<= 300) $ sum <$> many1 ((\_ -> 100) <$> (char 'C')),
    sum <$> many1 ((\_ -> 1000) <$> (char 'M')),
    (\_ -> 5) <$> (char 'V'),
    (\_ -> 50) <$> (char 'L'),
    (\_ -> 500) <$> (char 'D')]

romNum :: ParsecT [Char] u Identity Integer
romNum = do 
  ns <- strictDecr $ many1 romPrimCombiVal
  return $ sum ns

main :: IO()
main = hspec $ do

  it "romNum parsers should succeed" $ do
    parse romNum "" "I" `shouldBe` Right (1)
    parse romNum "" "II" `shouldBe` Right (2)
    parse romNum "" "III" `shouldBe` Right (3)
    parse romNum "" "IX" `shouldBe` Right (9)
    parse romNum "" "MLXVI" `shouldBe` Right (1066)
    parse romNum "" "MCMLXXXIX" `shouldBe` Right (1989)
    parse romNum "" "MMMMMMM" `shouldBe` Right (7000)

  it "romNum parsers should fail" $ do
    isLeft (parse romNum "" "IIII") `shouldBe` True
    isLeft (parse romNum "" "VX") `shouldBe` True
    isLeft (parse romNum "" "IVX") `shouldBe` True
    isLeft (parse romNum "" "MDLVX") `shouldBe` True
    isLeft (parse romNum "" "foo") `shouldBe` True
    isLeft (parse romNum "" "") `shouldBe` True