An over engineered way to parse monmial

DumbParse.hs

import Data.Char
import Control.Applicative
import Data.Either
import Data.Tuple.Extra

type Position      = (Int, Int)
type ParserInput   = (Position, String)
type ParseError    = (Position, [String])
type Parsed a      = (Position, String, a)
type ParseResult a = Either ParseError (Parsed a)

runBase :: Parser a -> String -> ParseResult a
runBase p s = run p ((0, 0), s)

newtype Parser a = Parser {
  run :: ParserInput -> ParseResult a
}

instance Functor Parser where
  fmap f (Parser p) =
    Parser $ \val -> do
      (position, rest, parsed) <- p val
      Right (position, rest, f parsed)

instance Applicative Parser where
  pure x = Parser $ \(pos, tokens) -> Right (pos, tokens, x)
  (Parser p1) <*> (Parser p2) =
    Parser $ \(pos, tokens) -> do
      (pos',  tokens',  f) <- p1 (pos,  tokens)
      (pos'', tokens'', v) <- p2 (pos', tokens')
      Right (pos'', tokens'', f v)

instance Alternative Parser where
  empty = Parser $ const $ Left ((0, 0), [])
  (Parser p1) <|> (Parser p2) =
    Parser $ \val -> f (p1 val) (p2 val)
    where
      f r@(Right _)      _                = r
      f _                r@(Right _)      = r
      f (Left (p, exp1)) (Left (_, exp2)) = Left (p, exp1 ++ exp2)

char :: Char -> Parser Char
char expected = match (== expected) [expected]

string :: String -> Parser String
string expected = traverse toMatch expected
  where toMatch :: Char -> Parser Char
        toMatch c = match (== c) expected

while :: (Char -> Bool) -> Parser String
while f =
  Parser $ \((line, char), val) ->
    let (parsed, tokens') = span f val
        newLines = length $ filter ('\n' ==) parsed
        char' = length $ takeWhile ('\n' /=) (reverse parsed)
        pos = if newLines > 0 then (newLines, char') else (line, char + char')
     in Right (pos, tokens', parsed)

match :: (Char -> Bool) -> String -> Parser Char
match condition message = Parser parse
  where
    parse ((line, char), found:rest)
      | condition found = Right (pos,          rest, found)
      | otherwise =         Left  ((line, char), [message])
        where pos = if found == '\n' then (line + 1, 0) else (line, char + 1)
    parse ((line, char), []) = Left ((line, char), [message])

whitespace :: Parser String
whitespace = while isSpace

-- TODO: support escaped chars
stringLiteral :: Parser String
stringLiteral = Parser $ \inp -> do
  (pos,   tokens, _)    <- run (char '\"') inp
  (pos',  tokens', str) <- run (while (/= '\"')) (pos, tokens)
  (pos'', tokens'', _)  <- run (char '\"') (pos', tokens')
  Right (pos'', tokens'', str)

charLiteral :: Parser Char
charLiteral = Parser $ \inp -> do
  (pos,   tokens, _)    <- run (char '\'') inp
  (pos',  tokens', chr) <- run (match (const True) "Character") (pos, tokens)
  (pos'', tokens'', _)  <- run (char '\'') (pos', tokens')
  Right (pos'', tokens'', chr)

separatedBy :: Parser a -> Parser b -> Parser [a]
separatedBy element separator = (:) <$> element <*> many (separator *> element) <|> pure []

sign :: Parser String
sign = string "+" <|> string "-" <|> string ""

digit :: Parser Char
digit = match isDigit "Digit"

integer :: Parser Integer
integer = Parser $ \inp -> do
  (pos,  tokens, sign)    <- run sign inp
  (pos', tokens', digits) <- run (some digit) (pos, tokens)
  Right (pos', tokens', read $ if sign == "-" then sign ++ digits
                                              else digits)

float :: Parser Float
float = Parser $ \inp -> do
  (pos,  tokens, sign)       <- run sign inp
  (pos', tokens', digits)    <- run (some digit) (pos, tokens)
  (pos'', tokens'', dot)     <- run (string "." <|> string "") (pos', tokens')
  (pos''', tokens''', float) <- run (if dot == "." then some digit else string "") (pos'', tokens'')
  let  rest = digits ++ dot ++ float in
    Right (pos''', tokens''', read $ if sign == "-" then sign ++ rest
                                                    else rest)
data Monomial = Monomial Float Char Float
    deriving (Show)

monomial :: Parser Monomial
monomial = Parser $ \inp -> do
    (p, rest, mul) <- run float inp
    (p, rest, _)   <- run whitespace (p, rest)
    (p, rest, var) <- run (match isAlpha "Variable") (p, rest)
    (p, rest, _)   <- run whitespace (p, rest)
    (p, rest, _)   <- run (match (== '^') "Exp") (p, rest)
    (p, rest, _)   <- run whitespace (p, rest)
    (p, rest, exp) <- run float (p, rest)
    Right (p, rest, Monomial mul var exp)

parseMonomial inp = fmap thd3 $ runBase monomial inp

main = print $ parseMonomial "-123.231231    z ^ -21312.69"