packages feed

mello 0.6.0 → 0.7.0

raw patch · 6 files changed

+301/−61 lines, 6 files

Files

README.md view
@@ -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`
mello.cabal view
@@ -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 <https://github.com/ejconlon/mello#readme> category:       Parsing
src/Mello.hs view
@@ -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 (..))
src/Mello/Parse.hs view
@@ -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 "<interactive>" 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 "<interactive>" txt err+    Left err -> putStrLn (displayException err)     Right _ -> pure ()   pure ea
src/Mello/Recognize.hs view
@@ -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
test/Main.hs view
@@ -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       ]