aboutsummaryrefslogtreecommitdiff
path: root/src/parser/Core.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/parser/Core.hs')
-rw-r--r--src/parser/Core.hs170
1 files changed, 92 insertions, 78 deletions
diff --git a/src/parser/Core.hs b/src/parser/Core.hs
index b22bcf4..8deea2f 100644
--- a/src/parser/Core.hs
+++ b/src/parser/Core.hs
@@ -1,117 +1,131 @@
+{-# LANGUAGE FlexibleInstances #-}
+
module Parser.Core where
-import Control.Applicative
-import Control.Monad
-import Data.Char
+import Control.Applicative
+import Control.Monad
+import Data.Char
+
+newtype Parser a = Parser { runParser :: String -> Either String (a, String) }
-newtype Parser a = Parser { parse :: String -> Maybe (a, String) }
+runParserStrict :: Parser a -> String -> Either String a
+runParserStrict p input = case runParser p input of
+ Right (a, "") -> Right a
+ Right (_, rest) -> Left $ "Unconsumed input: \"" ++ rest ++ "\""
+ Left err -> Left err
-parseStrict :: Parser a -> String -> Maybe a
-parseStrict p input = case parse p input of Just (a, "") -> Just a
- _ -> Nothing
+
+-------------------------------------------------------------------------------
+-- Parser instances
+-------------------------------------------------------------------------------
instance Functor Parser where
-- fmap :: (a -> b) -> Parser a -> Parser b
- fmap f (Parser p) = Parser new_p
- where new_p s = do
- (x, s') <- p s
- return (f x, s')
+ fmap f (Parser p) = Parser $
+ \s -> do (x, s') <- p s
+ return (f x, s')
instance Applicative Parser where
-- pure :: a -> Parser a
- pure x = Parser (\s -> Just (x, s))
+ pure x = Parser (\s -> Right (x, s))
-- (<*>) :: Parser (a -> b) -> Parser a -> Parser b
- (Parser p1) <*> (Parser p2) = Parser new_p
- where new_p s = do
- (f, s') <- p1 s
- (x, s'') <- p2 s'
- return (f x, s'')
-
-instance Alternative Parser where
- -- empty :: Parser a
- empty = Parser (\_ -> Nothing)
- -- (<|>) :: Parser a -> Parser a -> Parser a
- (Parser p1) <|> (Parser p2) = Parser new_p
- where new_p s = p1 s <|> p2 s
+ (Parser pf) <*> (Parser p) = Parser $
+ \s -> do (f, s') <- pf s
+ (x, s'') <- p s'
+ return (f x, s'')
instance Monad Parser where
-- return :: a -> Parser a
return x = pure x
-- (>>=) :: Parser a -> (a -> Parser b) -> Parser b
- (Parser p1) >>= f = Parser new_p
- where new_p s = do
- (x, s') <- p1 s
- parse (f x) s'
+ (Parser p1) >>= f = Parser $
+ \s -> do (x, s') <- p1 s
+ runParser (f x) s'
+
+-- instance for Either String so that it can be used in the Alternative for Parser
+instance Alternative (Either String) where
+ -- empty :: Either String a
+ empty = Left ""
+ -- (<|>) :: Either String a -> Either String a -> Either String a
+ Left _ <|> x2 = x2
+ x1 <|> _ = x1
+instance Alternative Parser where
+ -- empty :: Parser a
+ empty = Parser (\_ -> Left "Empty")
+ -- (<|>) :: Parser a -> Parser a -> Parser a
+ (Parser p1) <|> (Parser p2) = Parser $ \s -> p1 s <|> p2 s
+
+
+-------------------------------------------------------------------------------
+-- Parser creation helper
+-------------------------------------------------------------------------------
+-- Create a parser of one character which must respect a predicate
satisfyChar :: (Char -> Bool) -> Parser Char
-satisfyChar f = Parser p
- where p [] = Nothing
- p (c:cs) = if f c then Just (c, cs)
- else Nothing
+satisfyChar predicate = Parser p
+ where p [] = Left "Expected input"
+ p (c:cs) = if predicate c then Right (c, cs)
+ else Left "Expected char"
-sepBy :: Parser b -> Parser a -> Parser [a]
-sepBy sep x = (:) <$> x <*> (many (sep *> x))
+char :: Char -> Parser Char
+char c = satisfyChar (c ==)
+
+string :: String -> Parser String
+string s = sequenceA $ char <$> s
+
+sepBy :: Parser a -> Parser b -> Parser [a]
+sepBy x sepatator = (:) <$> x <*> (many (sepatator *> x))
-- sepByMap :: (b -> a -> a) -> Parser b -> Parser a -> Parser [a]
-- sepByMap f sep x = (:) <$> x <*> (many (f <$> sep <*> x))
-chainl :: Parser a -> Parser (a -> a -> a) -> a -> Parser a
-chainl p op a = chainl1 p op <|> pure a
+-- chainl :: Parser a -> Parser (a -> a -> a) -> a -> Parser a
+-- chainl p op a = chainl1 p op <|> pure a
+-- Parse one or more occurences of p separated by op
+-- Apply op in a left associative maner on each value in p
chainl1 :: Parser a -> Parser (a -> a -> a) -> Parser a
chainl1 p op = p >>= rest
where rest prev = do f <- op
- e <- p
- rest (f prev e)
+ operand <- p
+ rest (f prev operand)
<|> return prev
-signed :: Num a => Parser a -> Parser a
-signed p = do char '-'
- x <- p
- return (-x)
- <|> p
-
-readParser :: Read a => Parser String -> Parser a
-readParser p = read <$> p
-
infixOp :: String -> (a -> a -> a) -> Parser (a -> a -> a)
-infixOp opStr f = string opStr *> pure f
-
-parenthesize :: Parser a -> Parser a
-parenthesize p = char '(' *> p <* char ')'
+infixOp operatorStr f = string operatorStr *> pure f
-char :: Char -> Parser Char
-char c = satisfyChar (c ==)
+-- Surround parser with opening and closing string
+between :: String -> String -> Parser a -> Parser a
+between open close p = string open *> p <* string close
-string :: String -> Parser String
-string s = sequenceA $ char <$> s
+parenthesis :: Parser a -> Parser a
+parenthesis p = between "(" ")" p
-alphaP :: Parser Char
-alphaP = satisfyChar isAlpha
+-- try to apply parsers returns the first one that succeeds
+choice :: [Parser a] -> Parser a
+choice [] = empty
+choice (p:ps) = p <|> choice ps
alphaStringP :: Parser String
-alphaStringP = some alphaP
-
-digitsP :: Parser String
-digitsP = some (satisfyChar isDigit) -- at least one digit to avoid read exception
-
-spacesP :: Parser String
-spacesP = many (satisfyChar isSpace)
-
-unsignedIntP :: Parser Int
-unsignedIntP = readParser digitsP
-
-intP :: Parser Int
-intP = signed unsignedIntP
+alphaStringP = some (satisfyChar isAlpha)
-unsignedFloatP :: Parser Float
-unsignedFloatP = readParser p
- where p = do pos <- digitsP
- char '.'
- dec <- digitsP
- return (pos ++ "." ++ dec)
- <|> digitsP
floatP :: Parser Float
-floatP = signed unsignedFloatP
+floatP = signed unsignedP
+ where
+ unsignedP :: Parser Float
+ unsignedP = read <$> p
+ where p = do pos <- digitsP
+ char '.'
+ dec <- digitsP
+ return (pos ++ "." ++ dec)
+ <|> digitsP
+
+ digitsP = some $ satisfyChar isDigit -- at least one digit to avoid read exception
+
+ signed :: Num a => Parser a -> Parser a
+ signed p = do char '-'
+ x <- p
+ return (-x)
+ <|> p
generated by cgit (git 2.34.1) at 2026-05-16 02:09:13 +0000