diff options
| -rw-r--r-- | Parser.hs | 111 |
1 files changed, 99 insertions, 12 deletions
@@ -3,7 +3,7 @@ module Parser where import Control.Applicative -import Data.Char (isSpace) +import Data.Char (isLower, isUpper, isLetter, isDigit, isSpace, toUpper, toLower) import Control.Monad.Chronicle import Control.Monad.Reader import Control.Monad.State.Strict @@ -51,13 +51,71 @@ pProgram = do return prog pFunDef :: Parser (FunDef ()) -pFunDef = _ +pFunDef = do + skipWhiteComment + assertAtCol 0 Fatal "Expected top-level definition, found indented stuff" + withRefCol 0 $ do + _ + +data Case = Uppercase | Lowercase + deriving (Show) + +-- | Consumes an identifier (word or parenthesised operator) at the current +-- position. +pIdentifier0 :: Case -> Parser Name +pIdentifier0 cs = pAlphaName0 cs <|> pParens0 (pSymbol0 cs) + +-- | Consumes a word-like name at the current position with the given case. +pAlphaName0 :: Case -> Parser Name +pAlphaName0 cs = do + (_, s) <- readInline (\case True -> \case Just c | isInitNameChar c -> Just (Right False) + _ -> Nothing + False -> \case Just c | isNameContChar c -> Just (Right False) + _ -> Just (Left ())) + True + case cs of + Uppercase | isLower (head s) -> do + raise Error "Unexpected uppercase word at this position, assuming typo" + return (Name (toUpper (head s) : tail s)) + Lowercase | isUpper (head s) -> do + raise Error "Unexpected lowercase word at this position, assuming typo" + return (Name (toLower (head s) : tail s)) + _ -> return (Name s) + where + isInitNameChar, isNameContChar :: Char -> Bool + isInitNameChar c = isLetter c || c == '_' + isNameContChar c = isInitNameChar c || isDigit c || c == '\'' + +pSymbol0 :: Case -> Parser Name +pSymbol0 cs = do + _ + +-- | Parser between parens, with the opening paren at the current position. +-- Enforces that all components are within the current indented block. +pParens0 :: Parser a -> Parser a +pParens0 p = do + string "(" + skipWhiteComment + res <- p + skipWhiteComment + string ")" + return res +-- | Run a parser under a modified psRefCol. The current psRefCol is reinstated +-- after completion of this parser. +withRefCol :: Int -> Parser a -> Parser a +withRefCol refcol p = do + old <- gets psRefCol + modify (\ps -> ps { psRefCol = refcol }) + res <- p + modify (\ps -> ps { psRefCol = old }) + return res data Fatality = Error | Fatal deriving (Show) +-- | Raise an error with the given fatality and description. raise :: Fatality -> String -> Parser () raise fat msg = do fp <- asks ctxFile @@ -67,30 +125,49 @@ raise fat msg = do Fatal -> confess . pure fun (ErrMsg fp (psLine ps) (psCol ps) msg) +-- | Raises an error if we're not currently at the given column. +assertAtCol :: Int -> Fatality -> String -> Parser () +assertAtCol col fat msg = gets psCol >>= \col' -> + when (col' /= col) $ raise fat msg + +-- | Raises an error if psCol is not greater than psRefCol. +assertWithinBlock :: Fatality -> String -> Parser () +assertWithinBlock fat msg = get >>= \ps -> + when (psCol ps <= psRefCol ps) $ raise fat msg + +-- | Raises an error if we're not currently at EOF. assertEOF :: Fatality -> Parser () assertEOF fat = gets psRest >>= \case [] -> return () _ -> raise fat "Unexpected stuff" -data ReadResult a = Token a | Truncated a - deriving (Show, Functor) - -readInline :: (s -> Char -> Maybe s) -> s -> Parser (ReadResult String) +-- | Consumes an inline token at the current position, asserting that psCol > +-- psRefCol at the start. The token is defined by a pure stateful parser. +-- If encountering a newline or EOF, the parser is run on this character +-- ('Nothing' for EOF); if this produces a result, the result is returned; +-- otherwise, the parser fails. +readInline :: (s -> Maybe Char -> Maybe (Either r s)) -> s -> Parser (r, String) readInline f s0 = do ps0 <- get when (psCol ps0 <= psRefCol ps0) $ raise Fatal "Expected stuff, but found end of indented expression" - let loop :: (s -> Char -> Maybe s) -> s -> Parser (ReadResult String) + let loop :: (s -> Maybe Char -> Maybe (Either r s)) -> s -> Parser (r, String) loop f' st = do ps <- get case psRest ps of - c : cs | Just st' <- f' st c -> do - put (ps { psCol = psCol ps + 1, psRest = cs }) - fmap (c :) <$> loop f' st' - | otherwise -> return (Token "") - [] -> return (Truncated "") + [] | Just (Left res) <- f' st Nothing -> return (res, "") + | otherwise -> empty + '\n' : _ | Just (Left res) <- f' st (Just '\n') -> return (res, "") + c : cs -> case f' st (Just c) of + Nothing -> empty + Just (Left res) -> return (res, "") + Just (Right st') -> do + put (ps { psCol = psCol ps + 1, psRest = cs }) + fmap (c :) <$> loop f' st' loop f s0 +-- | Consumes all whitespace and comments (including newlines). Note: this may +-- leave psCol < psRefCol. skipWhiteComment :: Parser () skipWhiteComment = do inlineWhite @@ -98,9 +175,12 @@ skipWhiteComment = do _ <- optional lineComment (consumeNewline >> skipWhiteComment) <|> return () where + -- | Consumes some inline whitespace. inlineWhite :: Parser () inlineWhite = readWhileInline isSpace + -- | Consumes an inline comment including both end markers. Note: this may + -- leave psCol < psRefCol. inlineComment :: Parser () inlineComment = do string "{-" @@ -111,15 +191,20 @@ skipWhiteComment = do ,consumeNewline >> loop] loop + -- | Consumes a line comment marker and the rest of the line, excluding + -- newline. lineComment :: Parser () lineComment = string "--" >> readWhileInline (const True) + -- | Consumes characters while the predicate holds or until (and excluding) + -- a newline, whichever comes first. readWhileInline :: (Char -> Bool) -> Parser () readWhileInline p = do (taken, rest) <- span (\c -> p c && c /= '\n') <$> gets psRest modify (\ps -> ps { psCol = psCol ps + length taken , psRest = rest }) +-- | Consumes exactly one newline at the current position. consumeNewline :: Parser () consumeNewline = gets psRest >>= \case '\n' : rest -> modify (\ps -> ps { psLine = psLine ps + 1 @@ -127,6 +212,8 @@ consumeNewline = gets psRest >>= \case , psRest = rest }) _ -> empty +-- | Consumes exactly this string at the current position. The string must not +-- contain a newline. string :: String -> Parser () string s | any (== '\n') s = error "Newline in 'string' argument" string s = do |