diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,3 +1,34 @@ # mello No-fuss syntax with s-expressions + +## Parsing Diagnostics + +`Mello.Parse` exposes two parsing entry points: + +- `parseSexp :: Text -> Either (Err Void) LocSexp` preserves the original Looksee error API. +- `parseSexpDetailed :: Text -> Either ParseErr LocSexp` adds Mello-domain diagnostics before falling back to Looksee errors. + +`ParseErr` classifies delimiter failures with source locations: + +- `ParseErrUnclosedList Brace LocSpan` +- `ParseErrUnexpectedClose Brace LocSpan` +- `ParseErrMismatchedBrace Brace LocSpan Brace LocSpan` +- `ParseErrLooksee LocSpan (Err Void)` + +`ParseErrLooksee` intentionally keeps the raw `Looksee.Err` while also carrying its span converted to `LocSpan`. This lets clients either render with Looksee or use Mello line/column locations without traversing Looksee internals. + +For interactive use, `parseSexpI` prints Looksee parse errors and `parseSexpDetailedI` prints detailed delimiter errors or the underlying Looksee parse error. + +## Delimiter Recognition + +`Mello.Recognize` provides a lightweight delimiter recognizer used by `parseSexpDetailed`: + +- `recognizeSexpText :: Text -> Either RecogErr ()` +- `sexpRecognizer :: Fold Char (Either RecogErr ())` + +The recognizer checks delimiter balance while respecting strings, chars, comments, and escapes. It does not parse s-expressions; it only reports offset-based delimiter errors: + +- `RecogErrUnclosedList Brace openOffset eofOffset` +- `RecogErrUnexpectedClose Brace closeOffset` +- `RecogErrMismatchedBrace expected openOffset actual closeOffset` diff --git a/mello.cabal b/mello.cabal --- a/mello.cabal +++ b/mello.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: mello -version: 0.6.0 +version: 0.7.0 synopsis: No-fuss syntax with s-expressions description: Please see the README on GitHub at category: Parsing diff --git a/src/Mello.hs b/src/Mello.hs --- a/src/Mello.hs +++ b/src/Mello.hs @@ -1,6 +1,7 @@ module Mello ( module Mello.Match , module Mello.Parse + , module Mello.Recognize , module Mello.Syntax , module Mello.Print , module Mello.Text @@ -10,5 +11,6 @@ import Mello.Match import Mello.Parse import Mello.Print +import Mello.Recognize import Mello.Syntax import Mello.Text (Brace (..)) diff --git a/src/Mello/Parse.hs b/src/Mello/Parse.hs --- a/src/Mello/Parse.hs +++ b/src/Mello/Parse.hs @@ -7,14 +7,19 @@ , Loc (..) , LocSpan , LocSexp + , ParseErr (..) , sexpParser - , parseSexp - , parseSexpI - ) + , parseSexp + , parseSexpDetailed + , parseSexpI + , parseSexpDetailedI + ) where import Bowtie (Memo, pattern MemoP) +import Control.Exception (Exception (..)) import Control.Monad (guard, unless, void) +import Data.Bifunctor (first) import Data.Char (isDigit, isSpace) import Data.Hashable (Hashable) import Data.Sequence (Seq (..)) @@ -22,9 +27,10 @@ import Data.Text qualified as T import Data.Void (Void) import GHC.Generics (Generic) -import Looksee (Err, ParserT, Span (..)) +import Looksee (Err, ParserT, Span (..), errSpan) import Looksee qualified as L import Mello.Syntax (Atom (..), Doc (..), SexpF (..), Sym (..)) +import Mello.Recognize (RecogErr (..), recognizeSexpText) import Mello.Text ( Brace , closeBraceChar @@ -73,6 +79,27 @@ type LocSexp = Memo SexpF LocSpan +data ParseErr + = -- | An opening delimiter was not closed before EOF. + ParseErrUnclosedList !Brace !LocSpan + | -- | A closing delimiter appeared with no matching opener. + ParseErrUnexpectedClose !Brace !LocSpan + | -- | A closing delimiter did not match the most recent opener. + ParseErrMismatchedBrace !Brace !LocSpan !Brace !LocSpan + | -- | A generic Looksee parse error, paired with its span converted to + -- Mello locations. This constructor intentionally exposes both values: + -- clients can render or inspect the original 'Err' while using 'LocSpan' + -- directly for Mello-style source annotations. + ParseErrLooksee !LocSpan !(Err Void) + deriving stock (Show) + +instance Exception ParseErr where + displayException = \case + ParseErrUnclosedList brace _ -> "unclosed list; expected '" <> [closeBraceChar brace] <> "' before end of input" + ParseErrUnexpectedClose brace _ -> "unexpected closing delimiter '" <> [closeBraceChar brace] <> "'" + ParseErrMismatchedBrace expected _ actual _ -> "mismatched closing delimiter; expected '" <> [closeBraceChar expected] <> "' but got '" <> [closeBraceChar actual] <> "'" + ParseErrLooksee _ err -> displayException err + -- Specific parsers docStartP :: (Monad m) => ParserT e m () @@ -182,10 +209,47 @@ mkLoc o = let (l, c) = L.lookupLineCol o v in Loc l c o pure (fmap (fmap mkLoc) sexp) +-- | Parse an s-expression with Mello-domain diagnostics. +-- +-- Delimiter errors are classified before running the full parser. Generic +-- parser failures keep the original Looksee error and include a converted +-- Mello location span via 'ParseErrLooksee'. +parseSexpDetailed :: Text -> Either ParseErr LocSexp +parseSexpDetailed txt = do + first (parseErrRecognize txt) (recognizeSexpText txt) + first (parseErrLooksee txt) (parseSexp txt) + +parseErrLooksee :: Text -> Err Void -> ParseErr +parseErrLooksee txt err = ParseErrLooksee (fmap (locAt txt) (errSpan err)) err + +parseErrRecognize :: Text -> RecogErr -> ParseErr +parseErrRecognize txt = \case + RecogErrUnclosedList brace openOffset eofOffset -> ParseErrUnclosedList brace (Span (locAt txt openOffset) (locAt txt eofOffset)) + RecogErrUnexpectedClose brace closeOffset -> ParseErrUnexpectedClose brace (offsetSpan txt closeOffset) + RecogErrMismatchedBrace expected openOffset actual closeOffset -> ParseErrMismatchedBrace expected (offsetSpan txt openOffset) actual (offsetSpan txt closeOffset) + +offsetSpan :: Text -> Int -> LocSpan +offsetSpan txt offset = Span (locAt txt offset) (locAt txt (offset + 1)) + +locAt :: Text -> Int -> Loc +locAt txt offset = + let lookupTable = L.calculateLineCol txt + (line, col) = L.lookupLineCol offset lookupTable + in Loc line col offset + parseSexpI :: Text -> IO (Either (Err Void) LocSexp) parseSexpI txt = do let ea = parseSexp txt case ea of Left e -> L.printE "" txt e + Right _ -> pure () + pure ea + +parseSexpDetailedI :: Text -> IO (Either ParseErr LocSexp) +parseSexpDetailedI txt = do + let ea = parseSexpDetailed txt + case ea of + Left (ParseErrLooksee _ err) -> L.printE "" txt err + Left err -> putStrLn (displayException err) Right _ -> pure () pure ea diff --git a/src/Mello/Recognize.hs b/src/Mello/Recognize.hs --- a/src/Mello/Recognize.hs +++ b/src/Mello/Recognize.hs @@ -1,12 +1,21 @@ --- TODO finish this +-- | Lightweight lexical delimiter recognition for Mello s-expressions. +-- +-- This module does not parse s-expressions. It only checks delimiter balance +-- while respecting strings, chars, comments, and escapes. Offsets are returned +-- directly so callers can convert them to their preferred source-location type. module Mello.Recognize - ( + ( RecogErr (..) + , sexpRecognizer + , recognizeSexpText ) where import Control.Foldl (Fold (..)) +import Control.Foldl qualified as Foldl import Control.Monad.Except (ExceptT (..), MonadError (..), runExceptT) import Control.Monad.State.Strict (State, gets, modify', runState) +import Data.Text (Text) +import Data.Text qualified as T import Mello.Text (Brace, readCloseBrace, readOpenBrace) data X e s = X !(Maybe e) !s @@ -25,31 +34,38 @@ initial' = X Nothing initial extract' (X me s) = extract me s -data RecogElem - = RecogElemString - | RecogElemChar - | RecogElemComment - | RecogElemSlashEsc - | RecogElemQuote - | RecogElemUnquote - | RecogElemBrace !Brace - deriving stock (Eq, Ord, Show) - -newtype RecogErr - = RecogErrMismatch Brace +data RecogErr + = -- | An opener was not closed before EOF: brace, opener offset, EOF offset. + RecogErrUnclosedList !Brace !Int !Int + | -- | A closer appeared without a matching opener: actual brace, closer offset. + RecogErrUnexpectedClose !Brace !Int + | -- | A closer did not match the most recent opener: expected brace, opener offset, actual brace, closer offset. + RecogErrMismatchedBrace !Brace !Int !Brace !Int deriving stock (Eq, Ord, Show) data RecogState = RecogState { rsOffset :: !Int - , rsStack :: ![RecogElem] + , rsMode :: !RecogMode + , rsStack :: ![OpenList] } deriving stock (Eq, Ord, Show) initRecogState :: RecogState -initRecogState = RecogState 0 [] +initRecogState = RecogState 0 RecogModeDefault [] type RecogM = ExceptT RecogErr (State RecogState) +data RecogMode + = RecogModeDefault + | RecogModeString + | RecogModeChar + | RecogModeComment + | RecogModeEscape !RecogMode + deriving stock (Eq, Ord, Show) + +data OpenList = OpenList !Brace !Int + deriving stock (Eq, Ord, Show) + data CharCase = CharCaseNewline | CharCaseDoubleQuote @@ -76,59 +92,63 @@ Nothing -> Nothing stepR :: Char -> RecogM () -stepR c = goRet +stepR c = go <* incOffset where - goRet = goStart <* incOffset - goStart = do - mh <- peekStack - case mh of - Just RecogElemString -> goString - Just RecogElemChar -> goChar - Just RecogElemComment -> goComment - Just RecogElemSlashEsc -> goSlashEsc - Just RecogElemQuote -> goQuote - Just RecogElemUnquote -> goUnquote - Just (RecogElemBrace b) -> goDefault (Just b) - Nothing -> goDefault Nothing + go = do + mode <- gets rsMode + case mode of + RecogModeDefault -> goDefault + RecogModeString -> goString + RecogModeChar -> goChar + RecogModeComment -> goComment + RecogModeEscape mode' -> setMode mode' goString = case readCharCase c of - Just CharCaseDoubleQuote -> popStack - Just CharCaseSlashEsc -> pushStack RecogElemSlashEsc + Just CharCaseDoubleQuote -> setMode RecogModeDefault + Just CharCaseSlashEsc -> setMode (RecogModeEscape RecogModeString) _ -> pure () goChar = case readCharCase c of - Just CharCaseSingleQuote -> popStack - Just CharCaseSlashEsc -> pushStack RecogElemSlashEsc + Just CharCaseSingleQuote -> setMode RecogModeDefault + Just CharCaseSlashEsc -> setMode (RecogModeEscape RecogModeChar) _ -> pure () goComment = case readCharCase c of - Just CharCaseNewline -> popStack + Just CharCaseNewline -> setMode RecogModeDefault _ -> pure () - goSlashEsc = popStack -- just ignore input and leave slash esc mode - goQuote = error "TODO" - goUnquote = error "TODO" - goDefault mb = case readCharCase c of - Just CharCaseDoubleQuote -> pushStack RecogElemString - Just CharCaseSingleQuote -> pushStack RecogElemChar - Just CharCaseOpenComment -> pushStack RecogElemComment - Just (CharCaseOpenBrace b) -> pushStack (RecogElemBrace b) + goDefault = case readCharCase c of + Just CharCaseDoubleQuote -> setMode RecogModeString + Just CharCaseSingleQuote -> setMode RecogModeChar + Just CharCaseOpenComment -> setMode RecogModeComment + Just (CharCaseOpenBrace b) -> pushOpen b Just (CharCaseCloseBrace b) -> - case mb of - Just b0 | b == b0 -> popStack - _ -> throwError (RecogErrMismatch b) + peekOpen >>= \case + Just (OpenList b0 _) | b == b0 -> popOpen + Just (OpenList b0 offset) -> throwAt (RecogErrMismatchedBrace b0 offset b) + Nothing -> throwAt (RecogErrUnexpectedClose b) _ -> pure () incOffset = modify' (\s -> s {rsOffset = rsOffset s + 1}) - pushStack h = modify' (\s -> s {rsStack = h : rsStack s}) - popStack = modify' $ \s -> + setMode mode = modify' (\s -> s {rsMode = mode}) + pushOpen b = do + offset <- gets rsOffset + modify' (\s -> s {rsStack = OpenList b offset : rsStack s}) + popOpen = modify' $ \s -> case rsStack s of [] -> s _ : t -> s {rsStack = t} - peekStack = gets $ \s -> + peekOpen = gets $ \s -> case rsStack s of [] -> Nothing h : _ -> Just h + throwAt f = gets rsOffset >>= throwError . f -extractR :: Maybe RecogErr -> RecogState -> Either RecogErr Bool -extractR me s = maybe (Right (null (rsStack s))) Left me +extractR :: Maybe RecogErr -> RecogState -> Either RecogErr () +extractR me s = case me of + Just err -> Left err + Nothing -> case rsStack s of + [] -> Right () + OpenList brace openOffset : _ -> Left (RecogErrUnclosedList brace openOffset (rsOffset s)) --- TODO expose this when quote/unquote recognition is implemented --- and it's all tested -sexpRecognizer :: Fold Char (Either RecogErr Bool) +sexpRecognizer :: Fold Char (Either RecogErr ()) sexpRecognizer = foldUntilErr stepR initRecogState extractR + +-- | Recognize delimiter balance in a complete text value. +recognizeSexpText :: Text -> Either RecogErr () +recognizeSexpText = Foldl.fold sexpRecognizer . T.unpack diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -9,8 +9,10 @@ import Data.List (isInfixOf) import Data.Text (Text) import Data.Void (Void) +import Looksee (Span (..)) import Mello.Match (MatchM, altM, anyIntM, anySymM, elemM, expectAnyInt, expectAnySym, listM, runMatchM, symM) -import Mello.Parse (LocSpan, parseSexp, sexpParser) +import Mello.Parse (Loc (..), LocSpan, ParseErr (..), parseSexp, parseSexpDetailed, sexpParser) +import Mello.Recognize (RecogErr (..), recognizeSexpText) import Mello.Syntax ( Atom (..) , Brace (..) @@ -22,7 +24,10 @@ , pattern SexpQuote , pattern SexpUnquote ) -import PropUnit (MonadTest, TestName, TestTree, testGroup, testUnit) +import PropUnit (Gen, MonadTest, TestLimit, TestName, TestTree, testGroup, testUnit) +import PropUnit qualified as PU +import PropUnit.Hedgehog.Gen qualified as Gen +import PropUnit.Hedgehog.Range qualified as Range import Test.Daytripper (daytripperMain, mkUnitRT, testRT) import Test.Looksee.Trip (ExpectP, cmpEq, expectParsePretty, expectRendered) @@ -57,6 +62,122 @@ , parseCaseAs "atom sym special 6" ":x" (SexpAtom (AtomSym ":x")) ] +testParseSexpDetailed :: TestTree +testParseSexpDetailed = + testGroup + "parseSexpDetailed" + [ testUnit "success" $ do + case parseSexpDetailed "(1 2)" of + Left err -> fail ("expected parse success, got: " <> displayException err) + Right _ -> pure () + , testUnit "ignores delimiters in strings" $ do + case parseSexpDetailed "(\"[}\" 1)" of + Left err -> fail ("expected parse success, got: " <> displayException err) + Right _ -> pure () + , testUnit "ignores delimiters in chars" $ do + case parseSexpDetailed "(']' 1)" of + Left err -> fail ("expected parse success, got: " <> displayException err) + Right _ -> pure () + , testUnit "ignores delimiters in comments" $ do + case parseSexpDetailed "(; ]\n 1)" of + Left err -> fail ("expected parse success, got: " <> displayException err) + Right _ -> pure () + , testUnit "ignores delimiters in docs" $ do + case parseSexpDetailed ";| ]\n; }\n(1)" of + Left err -> fail ("expected parse success, got: " <> displayException err) + Right _ -> pure () + , testUnit "unclosed list" $ do + case parseSexpDetailed "(1 2" of + Left (ParseErrUnclosedList BraceParen (Span (Loc 0 0 0) (Loc 0 3 4))) -> pure () + other -> fail ("unexpected result: " <> show other) + , testUnit "multiline unclosed list" $ do + case parseSexpDetailed "(1\n 2" of + Left (ParseErrUnclosedList BraceParen (Span (Loc 0 0 0) (Loc 1 1 5))) -> pure () + other -> fail ("unexpected result: " <> show other) + , testUnit "unexpected close" $ do + case parseSexpDetailed ")" of + Left (ParseErrUnexpectedClose BraceParen (Span (Loc 0 0 0) (Loc 0 0 1))) -> pure () + other -> fail ("unexpected result: " <> show other) + , testUnit "mismatched brace" $ do + case parseSexpDetailed "[1)" of + Left (ParseErrMismatchedBrace BraceSquare (Span (Loc 0 0 0) (Loc 0 1 1)) BraceParen (Span (Loc 0 2 2) (Loc 0 2 3))) -> pure () + other -> fail ("unexpected result: " <> show other) + , testUnit "multiline mismatched brace" $ do + case parseSexpDetailed "[1\n )" of + Left (ParseErrMismatchedBrace BraceSquare (Span (Loc 0 0 0) (Loc 0 1 1)) BraceParen (Span (Loc 1 1 4) (Loc 1 1 5))) -> pure () + other -> fail ("unexpected result: " <> show other) + , testUnit "generic parse errors carry source span" $ do + case parseSexpDetailed "" of + Left (ParseErrLooksee (Span (Loc 0 0 0) _) _) -> pure () + other -> fail ("unexpected result: " <> show other) + ] + +testRecognize :: TestLimit -> TestTree +testRecognize lim = + testGroup + "recognize" + [ testUnit "success" $ do + case recognizeSexpText "(1 [2] {3})" of + Right () -> pure () + other -> fail ("unexpected result: " <> show other) + , testUnit "quote does not crash" $ do + case recognizeSexpText "`[1]" of + Right () -> pure () + other -> fail ("unexpected result: " <> show other) + , testUnit "unquote does not crash" $ do + case recognizeSexpText ",[1]" of + Right () -> pure () + other -> fail ("unexpected result: " <> show other) + , testUnit "unclosed list" $ do + case recognizeSexpText "(1\n 2" of + Left (RecogErrUnclosedList BraceParen 0 5) -> pure () + other -> fail ("unexpected result: " <> show other) + , testUnit "unexpected close" $ do + case recognizeSexpText ")" of + Left (RecogErrUnexpectedClose BraceParen 0) -> pure () + other -> fail ("unexpected result: " <> show other) + , testUnit "mismatched brace" $ do + case recognizeSexpText "`[1)" of + Left (RecogErrMismatchedBrace BraceSquare 1 BraceParen 3) -> pure () + other -> fail ("unexpected result: " <> show other) + , testUnit "ignores delimiters in strings chars and comments" $ do + case recognizeSexpText "(\"[}\" ']' ; )\n 1)" of + Right () -> pure () + other -> fail ("unexpected result: " <> show other) + , PU.testProp "agrees with parser on generated balanced inputs" lim $ do + input <- PU.forAll genBalancedInput + case parseSexp input of + Left err -> fail ("expected parse success for " <> show input <> ", got: " <> displayException err) + Right _ -> pure () + case recognizeSexpText input of + Left err -> fail ("expected recognize success for " <> show input <> ", got: " <> show err) + Right () -> pure () + ] + +genBalancedInput :: Gen Text +genBalancedInput = Gen.recursive Gen.choice [genAtom] [genList, genPrefix, genDoc] + where + genAtom = + Gen.element + ([ "1" + , "abc" + , "\"[not a delimiter]\"" + , "\"escaped \\\" ]\"" + , "']'" + , "'x'" + ] :: [Text]) + genList = do + (open, close) <- Gen.element ([ ("(", ")"), ("[", "]"), ("{", "}") ] :: [(Text, Text)]) + body <- Gen.list (Range.constant 0 4) genBalancedInput + pure (open <> foldMap (" " <>) body <> close) + genPrefix = do + prefix <- Gen.element (["`", ","] :: [Text]) + input <- genBalancedInput + pure (prefix <> input) + genDoc = do + input <- genBalancedInput + pure (";| doc ]\n; more }\n" <> input) + -- Match error display tests trySexp :: MatchM Void LocSpan a -> Text -> Either String a @@ -100,9 +221,11 @@ main :: IO () main = - daytripperMain $ \_ -> + daytripperMain $ \lim -> testGroup "mello" [ testParsing + , testParseSexpDetailed + , testRecognize lim , testDisplayException ]