nanoparsec.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}

module Main where

import Control.Applicative
import Text.Printf

class ParserStream s a | s -> a where
  uncons :: s -> Maybe (a, s)

instance ParserStream [a] a where
  uncons [] = Nothing
  uncons (x:xs) = Just (x, xs)

-- parse :: stream -> (either error result, consumed, restOfStream)
newtype Parser s r = Parser { parse :: s -> (Either String r, Int, s) }

instance Functor (Parser s) where
  fmap f p = Parser $ \inp -> let (res, off, rem) = parse p inp
                              in (f <$> res, off, rem)

addToOffset :: Int -> (a, Int, b) -> (a, Int, b)
addToOffset n (x, off, y) = (x, off + n, y)

instance Applicative (Parser s) where
  pure x = Parser $ \inp -> (Right x, 0, inp)
  f <*> x = Parser $ \inp ->
    let (res, off, rem) = parse f inp
    in case res of
      Right f' -> addToOffset off $ parse (f' <$> x) rem
      Left e   -> (Left e, off, rem)

instance Monad (Parser s) where
  return x = Parser $ \inp -> (Right x, 0, inp)
  x >>= f = Parser $ \inp ->
    let (res, off, rem) = parse x inp
    in case res of
      Right x' -> addToOffset off $ parse (f x') rem
      Left e   -> (Left e, off, rem)

instance Alternative (Parser s) where
  empty = Parser $ \inp -> (Left "(unknown error)", 0, inp)
  x <|> y = Parser $ \inp ->
    let (res1, off1, rem1) = parse x inp
        (res2, off2, rem2) = parse y inp
    in case res1 of
      Right x -> (Right x, off1, rem1)
      Left e1 ->
        if off1 > 0
        then (Left e1, off1, rem1)
        else case res2 of
          Right x -> (Right x, off2, rem2)
          Left e2 ->
            if off2 > 0
            then (Left e2, off2, rem2)
            else let e = e1 ++ " or " ++ e2
                 in (Left e, 0, inp)

try :: Parser s r -> Parser s r
try p = Parser $ \inp ->
  let (res, off, rem) = parse p inp
  in case res of
    Right x -> (Right x, off, rem)
    Left e  -> (Left e, 0, inp)

char :: (ParserStream s Char) => Char -> Parser s Char
char x = Parser $ \inp ->
  case uncons inp of
    Nothing       -> (err, 0, inp)
    Just (c, rem) -> if c == x
                     then (Right c, 1, rem)
                     else (err, 0, rem)

  where err = Left $ printf "'%c'" x

string :: (ParserStream s Char) => String -> Parser s String
string str = Parser $ \inp ->
  let (success, off, rem) = f str inp
  in if success then (Right str, off, rem)
     else (Left $ printf "\"%s\"" str, off, rem)
  where f [] inp = (True, 0, inp)
        f (x:xs) inp =
          case uncons inp of
            Nothing      -> (False, 0, inp)
            Just (y, ys) -> if x /= y
                             then (False, 0, inp)
                             else let (res, n, rem) = f xs ys
                                  in (res, n+1, rem)

eof :: (ParserStream s c) => Parser s ()
eof = Parser $ \inp ->
  case uncons inp of
    Nothing -> (Right (), 0, inp)
    Just x  -> (Left "eof", 0, inp)

runParser :: (ParserStream s Char) => Parser s r -> s -> Either String r
runParser p inp = case parse p inp of
  (Right r, _, rem)  -> case uncons rem of
                          Nothing -> Right r
                          Just _  -> Left "failed to consume all input"
  (Left exp, n, rem) -> let unexp = case uncons rem of
                                      Just (x, xs) -> printf "'%c'" x
                                      Nothing      -> "eof"
                        in Left $ printf "unexpected %s at character %d; expected %s" unexp n exp

testParser = do string "foo"
                string "bar" <|> string "car"
                eof

main :: IO ()
main = getLine >>= putStrLn . either ("Failure:\n"++) (const "Success!") . runParser testParser