diff options
| -rw-r--r-- | AST.hs | 2 | ||||
| -rw-r--r-- | Parser.hs | 184 | ||||
| -rw-r--r-- | hs-visinter.cabal | 2 |
3 files changed, 121 insertions, 67 deletions
@@ -8,7 +8,7 @@ data FunDef t = FunDef Name (Maybe Type) [FunEq t] deriving (Show) newtype Name = Name String - deriving (Show) + deriving (Show, Eq) data Type = TApp Type [Type] @@ -10,7 +10,6 @@ import Control.Monad.Reader import Control.Monad.State.Lazy import Data.Bifunctor (first) import Data.Char -import Data.Foldable (asum) import Data.These import Data.Tuple (swap) @@ -19,15 +18,22 @@ import Debug.Trace import AST --- Positions are zero-based in both dimensions +-- Positions are zero-based in both dimensions. +-- See 'isInsideBlock' and 'isAtBlockLeft' for the two relevant "inside the +-- block" conditions. data PS = PS - { psRefCol :: Int - , psLine :: Int - , psCol :: Int - , psRest :: String } + { psBlkLine :: Int -- ^ Start line of current layout block + , psBlkCol :: Int -- ^ Start column of current layout block + , psLine :: Int -- ^ Current line + , psCol :: Int -- ^ Current column + , psRest :: String -- ^ Rest of the input + } deriving (Show) -data Context = Context { ctxFile :: FilePath } +data Context = Context + { ctxFile :: FilePath + , ctxStack :: [String] -- ^ Stack of syntax scopes, for error reporting + } deriving (Show) -- ReaderT Context (ChronicleT [ErrMsg] (State PS) a) @@ -89,16 +95,19 @@ instance MonadChronicle [ErrMsg] Parser where -- Positions are zero-based in both dimensions data ErrMsg = ErrMsg { errFile :: FilePath + , errStk :: [String] , errLine :: Int , errCol :: Int , errMsg :: String } deriving (Show) printErrMsg :: ErrMsg -> String -printErrMsg (ErrMsg fp y x s) = fp ++ ":" ++ show (y + 1) ++ ":" ++ show (x + 1) ++ ": " ++ s +printErrMsg (ErrMsg fp stk y x s) = + unlines (map (\descr -> "In " ++ descr ++ ":") (reverse stk)) ++ + fp ++ ":" ++ show (y + 1) ++ ":" ++ show (x + 1) ++ ": " ++ s parse :: FilePath -> String -> These [ErrMsg] (Program ()) -parse fp source = fmap snd $ runParser pProgram (Context fp) (PS 0 0 0 source) +parse fp source = fmap snd $ runParser pProgram (Context fp []) (PS 0 0 0 0 source) pProgram :: Parser (Program ()) pProgram = do @@ -111,15 +120,39 @@ pFunDef :: Parser (FunDef ()) pFunDef = do skipWhiteComment mtypesig <- optional pStandaloneTypesig0 + let mname = fst <$> mtypesig + mtype = snd <$> mtypesig + (clauses, name) <- someClauses mname + return (FunDef name mtype clauses) + where + someClauses :: Maybe Name -> Parser ([FunEq ()], Name) + someClauses Nothing = do + clause@(FunEq name _ _) <- pFunEq Nothing + (,name) . (clause:) <$> many (pFunEq (Just name)) + someClauses (Just name) = (,name) <$> some (pFunEq (Just name)) + +-- | Given the name of the type signature, if any. +pFunEq :: Maybe Name -> Parser (FunEq ()) +pFunEq mCheckName = do + skipWhiteComment + assertAtBlockLeft Fatal "Expected function clause, found indented stuff" + + name <- pIdentifier0 Lowercase + case mCheckName of + Just checkName | name /= checkName -> + raise Fatal "Name of function clause does not correspond with type signature" + _ -> return () + + pats <- many pPattern _ pStandaloneTypesig0 :: Parser (Name, Type) pStandaloneTypesig0 = do - assertAtCol 0 Fatal "Expected top-level definition, found indented stuff" - withRefCol 0 $ do - name <- pIdentifier0 Lowercase - inlineWhite - string "::" + assertAtBlockLeft Fatal "Expected top-level definition, found indented stuff" + name@(Name namestr) <- pIdentifier0 Lowercase + inlineWhite + string "::" + pushContext ("type signature for '" ++ namestr ++ "'") $ do ty <- pType return (name, ty) @@ -236,23 +269,25 @@ pParens0 :: Parser a -> Parser a pParens0 p = do string "(" skipWhiteComment - assertWithinBlock Error "Unexpected dedent after opening parenthesis" + assertInsideBlock Error "Unexpected dedent after opening parenthesis" res <- p - assertWithinBlock Error "Unexpected dedent in parenthesised expression" + assertInsideBlock Error "Unexpected dedent in parenthesised expression" skipWhiteComment - assertWithinBlock Error "Unexpected dedent in parenthesised expression" + assertInsideBlock Error "Unexpected dedent in parenthesised expression" 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 }) +-- | Start a new layout block at the current position. The old layout block is +-- restored after completion of this subparser. +startLayoutBlock :: Parser a -> Parser a +startLayoutBlock p = do + ps0 <- get + put (ps0 { psBlkLine = psLine ps0 + , psBlkCol = psCol ps0 }) res <- p - modify (\ps -> ps { psRefCol = old }) + modify (\ps -> ps { psBlkLine = psBlkLine ps0 + , psBlkCol = psBlkCol ps0 }) return res data Fatality = Error | Fatal @@ -261,39 +296,25 @@ data Fatality = Error | Fatal -- | Raise an error with the given fatality and description. raise :: Fatality -> String -> Parser () raise fat msg = do - fp <- asks ctxFile - ps <- get + Context { ctxFile = fp , ctxStack = stk } <- ask + PS { psLine = line, psCol = col } <- get let fun = case fat of Error -> dictate . pure 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 + fun (ErrMsg fp stk line col 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 +-- | Registers a scope description on the stack for error reporting. +pushContext :: String -> Parser a -> Parser a +pushContext descr = local (\c -> c { ctxStack = descr : ctxStack c }) --- | Raises an error if we're not currently at EOF. -assertEOF :: Fatality -> Parser () -assertEOF fat = gets psRest >>= \case - [] -> return () - _ -> raise fat "Unexpected stuff" - --- | 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. +-- | Consumes an inline token at the current position, asserting that we are +-- within the current block 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. The newline is not consumed. 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" + assertInsideBlock Fatal "Expected stuff, but found end of indented expression" let loop :: (s -> Maybe Char -> Maybe (Either r s)) -> s -> Parser (r, String) loop f' st = do ps <- get @@ -310,37 +331,35 @@ readInline f s0 = do loop f s0 -- | Consumes all whitespace and comments (including newlines), but only if --- this then leaves psCol > psRefCol. If not, this fails. +-- this then leaves the parser inside the current block. If not, this fails. inlineWhite :: Parser () inlineWhite = do skipWhiteComment - ps <- get - TODO this check (and other similar checks) need to allow equality if the _line_ is also the reference starting line - when (psCol ps <= psRefCol ps) empty + whenM (not <$> isInsideBlock) empty -- | Consumes all whitespace and comments (including newlines). Note: this may --- leave psCol <= psRefCol. +-- end outside the current block. skipWhiteComment :: Parser () skipWhiteComment = do inlineSpaces - _ <- many (inlineComment >> inlineSpaces) - _ <- optional lineComment - (consumeNewline >> skipWhiteComment) <|> return () + _ <- many (blockComment >> inlineSpaces) + optional_ lineComment + optional_ (consumeNewline >> skipWhiteComment) --- | Consumes some inline whitespace. +-- | Consumes some inline whitespace. Stops before newlines. inlineSpaces :: Parser () inlineSpaces = readWhileInline isSpace --- | Consumes an inline comment including both end markers. Note: this may --- leave psCol < psRefCol. -inlineComment :: Parser () -inlineComment = do +-- | Consumes an delimited comment including both end markers. Note: this may +-- end outside the current block. +blockComment :: Parser () +blockComment = do string "{-" let loop = do - readWhileInline (`notElem` "{-") + readWhileInline (`notElem` "{-") -- "-}" also starts with '-' asum [string "-}" ,eof >> raise Error "Unfinished {- -} comment at end of file" - ,inlineComment >> loop + ,blockComment >> loop ,consumeNewline >> loop] loop @@ -349,6 +368,35 @@ inlineComment = do lineComment :: Parser () lineComment = string "--" >> readWhileInline (const True) +-- | Raises an error if we're not currently at the given column. +assertAtBlockLeft :: Fatality -> String -> Parser () +assertAtBlockLeft fat msg = whenM (not <$> isAtBlockLeft) $ raise fat msg + +-- | Raises an error if psCol is not greater than psRefCol. +assertInsideBlock :: Fatality -> String -> Parser () +assertInsideBlock fat msg = whenM (not <$> isInsideBlock) $ 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" + +-- | Returns whether the current position is _within_ the current block, for +-- soft-wrapping content. This means that col > blkCol. +isInsideBlock :: Parser Bool +isInsideBlock = do + ps <- get + return $ psLine ps >= psBlkLine ps && psCol ps > psBlkCol ps + +-- | Returns whether the current position is at the left border of the block; +-- this is for list content such as function definitions or let bindings. This +-- means that col == blkCol. +isAtBlockLeft :: Parser Bool +isAtBlockLeft = do + ps <- get + return $ psLine ps >= psBlkLine ps && psCol ps == psBlkCol ps + -- | Consumes characters while the predicate holds or until (and excluding) -- a newline, whichever comes first. readWhileInline :: (Char -> Bool) -> Parser () @@ -396,3 +444,9 @@ string s = do eof :: Parser () eof = gets psRest >>= \case [] -> return () _ -> empty + +whenM :: (Monad m, Monoid a) => m Bool -> m a -> m a +whenM mb mx = mb >>= \b -> if b then mx else return mempty + +optional_ :: Alternative f => f a -> f () +optional_ a = (() <$ a) <|> pure () diff --git a/hs-visinter.cabal b/hs-visinter.cabal index ba035ab..9c5e18d 100644 --- a/hs-visinter.cabal +++ b/hs-visinter.cabal @@ -13,7 +13,7 @@ executable hs-visinter AST Parser build-depends: - base >= 4.13 && < 4.15, + base >= 4.16 && < 4.17, containers >= 0.6.3.1 && < 0.7, parsec >= 3.1.14.0 && < 3.2, mtl, |