implementation module yard import StdTuple import StdClass import StdString import StdList import StdInt from Data.List import intersperse from Text import instance Text String, class Text(concat) import Data.Functor import Data.Either import Control.Monad import Control.Applicative from Data.Func import $ import Data.Void instance toString Error where toString ParseError = "General parse error" toString (LexError e) = "Lexer error: " +++ e toString (Unexpected e pos) = "Unexpected " +++ e +++ " at position " +++ (toString pos) runParser :: (Parser a b) [a] -> (Either Error b, [a]) runParser (Parser f) i = f i instance + Error where (+) ParseError r = r (+) r ParseError = r (+) r _ = r instance Functor (Parser a) where fmap f m = liftM f m instance Applicative (Parser a) where pure a = Parser \i -> (Right a, i) (<*>) sf p = ap sf p instance Monad (Parser a) where bind p f = Parser \i -> case runParser p i of (Right r, rest) = runParser (f r) rest (Left e, _) = (Left e, i) instance Alternative (Parser a) where empty = Parser \i -> (Left ParseError, i) (<|>) p1 p2 = Parser \i -> case runParser p1 i of (Right r, rest) = (Right r, rest) (Left e1, rest) = case runParser p2 i of (Left e2, rest) = (Left $ e1+e2, i) (Right r, rest) = (Right r, rest) //Try the parser, if it fails decorate the error with Expected of the given String and position () :: (Parser a b) (String, Int) -> Parser a b () p (e,pos) = Parser \i -> case runParser p i of (Left e1, rest) = (Left $ e1 + Unexpected e pos, rest) (Right r, rest) = (Right r, rest) fail :: Parser a b fail = empty top :: Parser a a top = Parser \i -> case i of [] = (Left ParseError, []) [x:xs] = (Right x, xs) peek :: Parser a a peek = Parser \i -> case i of [] = (Left ParseError, []) [x:xs] = (Right x, [x:xs]) //runs the left parser until the right parser succeeds. Returns the result of the left parser //Note: if the right parser consumes input then this input is lost! //If the left parser fails before the right parser succeeds the whole parser fails until :: (Parser a b) (Parser a c) -> Parser a [b] until p guard = try $ until` p guard [] where until` :: (Parser a b) (Parser a c) [b] -> Parser a [b] until` p guard acc = Parser \i -> case runParser guard i of (Right _, rest) = (Right acc, rest) (Left _, _) = case runParser p i of (Right r, rest) = runParser (until` p guard [r:acc]) rest (Left e, _) = (Left e, i) try :: (Parser a b) -> Parser a b try p = Parser \i -> case runParser p i of (Left e, _) = (Left e, i) (Right r, rest) = (Right r, rest) eof :: Parser a Void eof = Parser \i -> case i of [] = (Right Void, []) _ = (Left ParseError, i) satisfy :: (a -> Bool) -> Parser a a satisfy f = top >>= \r -> if (f r) (return r) fail check :: (a -> Bool) -> Parser a a check f = peek >>= \r -> if (f r) (return r) fail item :: a -> Parser a a | Eq a item a = satisfy ((==)a) list :: [a] -> Parser a [a] | Eq a list as = mapM item as