packages feed

caml-parser (empty) → 0.1.0.0

raw patch · 23 files changed

+2250/−0 lines, 23 filesdep +basedep +caml-parserdep +containers

Dependencies added: base, caml-parser, containers, megaparsec, mtl, tasty, tasty-hunit

Files

+ CHANGELOG.md view
@@ -0,0 +1,18 @@+# Changelog++## 0.1.0.0 -- 2025-04-21++* Initial release.+* Full Caml-Light lexer with support for integers (decimal, hex, octal, binary),+  floats, strings, characters with escapes, nested comments, and extensible+  keyword tables.+* Precedence-climbing expression parser covering `let`, `if`, `match`,+  `function`, `fun`, `try`, sequences, assignments, and all infix levels.+* Pattern parser supporting wildcards, variables, constructors, tuples, lists,+  cons, or-patterns, aliases, and record patterns.+* Type parser for arrows, tuples, constructors, and variables.+* Declaration parser for `let`, `let rec`, `type`, `exception`, and directives.+* Plugin architecture via `CamlParserPlugin` for registering keywords and+  injecting custom parsers.+* Example MLQE plugin validating quantum gate definitions (`qdef`).+* Comprehensive test suite (88 tests).
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2025 overshiki++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,166 @@+# caml-parser++An extensible parser-combinator library for **Caml-Light**, written in Haskell, with a plugin architecture for embedding domain-specific languages such as the quantum DSL **MLQE**.++---++## Background++Caml-Light is the minimal yet complete core of the ML family—expressions, pattern matching, algebraic data types, and call-by-value evaluation. It has been a pedagogical and research vehicle since 1990. This project treats Caml-Light not as a closed language, but as an **extensible platform**: the core syntax is parsed by a combinator library, while EDSL authors can register new keywords, inject grammar productions, and extend the AST without modifying the core source code.++The immediate motivation is [**MLQE**](https://github.com/overshiki/mlqe/blob/master/doc/proposal.md), a proposed quantum programming extension that adds qubits, gates, channels, and pulse-level constructs on top of Caml-Light. Because "all valid Caml-Light programs remain valid MLQE programs," the parser must accept the full Caml-Light grammar and allow MLQE to plug in seamlessly.++---++## Design++### Three-Layer Architecture++```+┌─────────────────────────────────────────────┐+│  Layer 3: EDSL Plugins (MLQE, etc.)         │+│  - Register keywords                        │+│  - Inject grammar productions               │+│  - Extend AST via declarative hooks         │+├─────────────────────────────────────────────┤+│  Layer 2: Core Parser Combinators           │+│  - Precedence-climbing expression parser    │+│  - Pattern, type, and declaration parsers   │+│  - Built on Megaparsec                      │+├─────────────────────────────────────────────┤+│  Layer 1: Lexer & Token Stream              │+│  - Extensible keyword table                 │+│  - Source-location tracking                 │+│  - Full Caml-Light lexical structure        │+└─────────────────────────────────────────────┘+```++### Key Modules++| Module | Responsibility |+|--------|----------------|+| `CamlParser.Lexer.Lexer` | Tokenizes source text; merges core + plugin keywords |+| `CamlParser.Syntax.Expr` / `Pattern` / `Decl` | Core AST with `EExt` / `DExt` extension hooks |+| `CamlParser.Parser.Expr` | Full precedence ladder: `let` → `;` → `:=` → `if` → `,` → `\|\|` → `&&` → `not` → comparisons → `@` → `::` → `+` → `*` → `**` → unary `-` → application → projections → atoms |+| `CamlParser.Plugin.Interface` | `CamlParserPlugin` record: name, keywords, optional expr atom parser, optional declaration parser |+| `CamlParser.Parser.Assembly` | Combines lexer + plugins + parser into a runnable pipeline |+| `MLQE.Plugin` | Example plugin implementing `qdef` declarations and quantum expression syntax |++### Plugin Interface++A plugin is a simple record:++```haskell+data CamlParserPlugin = CamlParserPlugin+  { pluginName     :: String+  , pluginKeywords :: Map String Token+  , pluginExprAtom :: Maybe (Parser Expr)+  , pluginDecl     :: Maybe (Parser (Decl Expr Pattern))+  }+```++Registering a plugin extends the lexer keyword table and the toplevel declaration parser automatically:++```haskell+let reg = registerPlugin mlqePlugin emptyRegistry+    toks = runLexer reg "qdef bell = hadamard @ cnot;;"+    ast  = toks >>= parseToplevelTokens reg+```++### AST Extensibility++The core AST provides typed extension points:++```haskell+-- Expression extension: tag + sub-expressions+data ExprF r = … | EExt String [r] | …++-- Declaration extension: tag + opaque payload+data Decl expr pat = … | DExt String (DeclExt expr pat) | …+```++MLQE uses `DExt "mlqe"` to embed `qdef` declarations without changing core types.++---++## Usage++### Building++```bash+cabal build+```++### Running Tests++```bash+# Full suite (88 tests)+cabal test++# Single test (tasty awk patterns)+cabal test --test-options="-p 'qdef abstract'"+```++### Interactive Exploration++```bash+cabal repl+```++Example REPL session:++```haskell+> import CamlParser.Parser.Assembly+> import CamlParser.Plugin.Registry+> import MLQE.Plugin+>+> let reg = registerPlugin mlqePlugin emptyRegistry+> runLexer reg "let x = 1 + 2;;"+Right [Located TokLet ..., Located (TokIdent "x") ..., Located TokEqual ...,+       Located (TokInt 1) ..., Located (TokInfix 2 "+") ..., Located (TokInt 2) ...,+       Located TokSemiSemi ...]+>+> runLexer reg "qdef hadamard : 1 gate;;" >>= parseToplevelTokens reg+Right (TImpl (DExt "mlqe" (DeclExt {declExtName = "mlqe", declExtValue = QDefAbstract "hadamard" (Just (TConstr "gate" [TConstr "1" []]))})))+```++### Writing a Plugin++1. Define your keywords as a `Map String Token` using `TokKeywordExt`.+2. Implement any new declaration parsers.+3. Package them into a `CamlParserPlugin` record.+4. Register it with `registerPlugin` before lexing/parsing.++See [`src/MLQE/Plugin.hs`](./src/MLQE/Plugin.hs) for a complete working example.++---++## Test Suite++The test suite lives in [`test/Main.hs`](./test/Main.hs) and covers the full Caml-Light grammar plus plugin extensibility:++| Group | Count | Coverage |+|-------|-------|----------|+| **Lexer** | 15 | Integers (decimal, hex, octal, binary), floats (including `5.` and exponent notation), identifiers with accents/underscores, keyword boundaries, multi-character symbols (`->`, `::`, `:=`, `.[`, etc.), string/char escapes, nested comments, plugin keyword registration |+| **Expression Parser** | 28 | Literals, `let/in` (nested, multiple bindings, `rec`, mutual, `where`), `if/then/else` (dangling else), `fun`, `function`, `match`, `try`, sequences, assignments, full precedence/associativity (left for `+`/`-`/`*`/`@`; right for `::`/`**`/`@`), unary `-` / `-.`, curried application, tuples, list literals, vector/string projections |+| **Pattern Parser** | 10 | Wildcard, variables, constants, tuples, constructor application, cons (`::`) right-associative, list sugar, or-patterns (`\|`), aliases, record patterns |+| **Type Parser** | 6 | Variables, arrows (right-assoc), tuples (`*`), constructors (including multi-param `(int, string) either`), abbreviations |+| **Declaration Parser** | 11 | `let`/`let rec`, `type` (variant, record, abbreviation, parameterized), `exception` (with/without args), multiple `and`-separated decls, directives (`#open`), tuple patterns in bindings |+| **Projections & Assignments** | 5 | Record access (`r.field`), vector index (`v.(i)`), string index (`s.[i]`), reference assign (`:=`), record field update (`<-`) |+| **Plugin Integration** | 7 | Non-interference (same AST with/without plugin), keyword presence/absence, abstract/concrete/parameterized `qdef`, multiple plugins |+| **Negative Tests** | 6 | Unclosed strings/comments, unmatched parens, missing `in`, trailing `else`, missing operand |++Run all tests:++```bash+$ cabal test+…+All 88 tests passed (0.02s)+Test suite caml-parser-test: PASS+```++---++## License++MIT
+ caml-parser.cabal view
@@ -0,0 +1,74 @@+cabal-version:      3.0+name:               caml-parser+version:            0.1.0.0+synopsis:           An extensible parser-combinator library for Caml-Light+description:+  A Megaparsec-based parser combinator library for the Caml-Light language,+  featuring a plugin architecture for embedding domain-specific languages.+  .+  The core parser covers the full Caml-Light grammar — expressions, patterns,+  types, declarations, and toplevel phrases — while the plugin system allows+  EDSL authors to register new keywords, inject grammar productions, and+  extend the AST without modifying the core source code.+  .+  An included example plugin implements the MLQE quantum programming+  extension, validating @qdef@ declarations for quantum gates and channels.+license:            MIT+license-file:       LICENSE+copyright:          (c) 2025 overshiki+author:             overshiki+maintainer:         le.niu@hotmail.com+category:           Parsing, Language+build-type:         Simple+extra-doc-files:    README.md+                    CHANGELOG.md+homepage:           https://github.com/overshiki/caml-parser+bug-reports:        https://github.com/overshiki/caml-parser/issues+tested-with:        GHC == 9.6.7++source-repository head+  type:     git+  location: https://github.com/overshiki/caml-parser.git++library+  exposed-modules:+    CamlParser.Lexer.Token+    CamlParser.Lexer.Lexer+    CamlParser.Syntax.Location+    CamlParser.Syntax.Constant+    CamlParser.Syntax.Type+    CamlParser.Syntax.Pattern+    CamlParser.Syntax.Expr+    CamlParser.Syntax.Decl+    CamlParser.Parser.Combinators+    CamlParser.Parser.Expr+    CamlParser.Parser.Pattern+    CamlParser.Parser.Type+    CamlParser.Parser.Toplevel+    CamlParser.Parser.Assembly+    CamlParser.Plugin.Interface+    CamlParser.Plugin.Registry+    MLQE.Syntax+    MLQE.Plugin+  hs-source-dirs:     src+  build-depends:+      base              >= 4.18    && < 5+    , containers        >= 0.6     && < 0.8+    , megaparsec        >= 9.2     && < 10+    , mtl               >= 2.2     && < 2.4+  default-language:   Haskell2010+  ghc-options:        -Wall -Wcompat++test-suite caml-parser-test+  type:               exitcode-stdio-1.0+  main-is:            Main.hs+  hs-source-dirs:     test+  build-depends:+      base              >= 4.18    && < 5+    , caml-parser+    , containers        >= 0.6     && < 0.8+    , megaparsec        >= 9.2     && < 10+    , tasty             >= 1.4     && < 1.6+    , tasty-hunit       >= 0.10    && < 0.11+  default-language:   Haskell2010+  ghc-options:        -Wall -threaded -rtsopts
+ src/CamlParser/Lexer/Lexer.hs view
@@ -0,0 +1,184 @@+module CamlParser.Lexer.Lexer where++import Control.Monad (void)+import Data.Char (chr, isLetter, isDigit, digitToInt)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (fromMaybe)+import Data.Void (Void)+import Text.Megaparsec hiding (Token, token)+import Text.Megaparsec.Char+import qualified Text.Megaparsec.Char.Lexer as L+import CamlParser.Lexer.Token+import CamlParser.Syntax.Location++type Lexer = Parsec Void String++spaceConsumer :: Lexer ()+spaceConsumer = L.space+  (void (some (oneOf " \t\n\r\f\v")))+  (L.skipLineComment "--" <|> L.skipBlockCommentNested "(*" "*)")+  empty++lexeme :: Lexer a -> Lexer a+lexeme = L.lexeme spaceConsumer++symbol :: String -> Lexer String+symbol = L.symbol spaceConsumer++keywordTableCore :: Map String Token+keywordTableCore = Map.fromList+  [ ("and", TokAnd), ("as", TokAs), ("begin", TokBegin)+  , ("do", TokDo), ("done", TokDone), ("downto", TokDownto)+  , ("else", TokElse), ("end", TokEnd), ("exception", TokException)+  , ("for", TokFor), ("fun", TokFun), ("function", TokFunction)+  , ("if", TokIf), ("in", TokIn), ("let", TokLet)+  , ("match", TokMatch), ("mutable", TokMutable), ("not", TokNot)+  , ("of", TokOf), ("or", TokOr), ("prefix", TokPref)+  , ("rec", TokRec), ("then", TokThen), ("to", TokTo)+  , ("try", TokTry), ("type", TokType), ("value", TokValue)+  , ("when", TokWhen), ("where", TokWhere), ("while", TokWhile)+  , ("with", TokWith)+  , ("mod", TokInfix 3 "mod"), ("quo", TokInfix 3 "quo")+  , ("land", TokInfix 3 "land"), ("lor", TokInfix 2 "lor")+  , ("lxor", TokInfix 2 "lxor"), ("lsl", TokInfix 4 "lsl")+  , ("lsr", TokInfix 4 "lsr"), ("asr", TokInfix 4 "asr")+  ]++tokenP :: Map String Token -> Lexer (Located Token)+tokenP kwTable = located $ choice+  [ stringLiteral+  , charLiteral+  , try floatLiteral+  , intLiteral+  , operatorOrSymbol+  , identifier kwTable+  ]++located :: Lexer a -> Lexer (Located a)+located p = do+  pos1 <- getSourcePos+  v <- p+  pos2 <- getSourcePos+  return $ Located v (Location pos1 pos2)++identifier :: Map String Token -> Lexer Token+identifier kwTable = lexeme $ try $ do+  c <- letterChar <|> char '_'+  cs <- many (alphaNumChar <|> char '_' <|> char '\'')+  let s = c:cs+  return $ fromMaybe (TokIdent s) (Map.lookup s kwTable)++intLiteral :: Lexer Token+intLiteral = lexeme $ TokInt <$> choice+  [ try $ string "0x" *> L.hexadecimal+  , try $ string "0o" *> L.octal+  , try $ string "0b" *> L.binary+  , L.decimal+  ]++floatLiteral :: Lexer Token+floatLiteral = lexeme $ TokFloat <$> choice+  [ try L.float+  , do n <- L.decimal+       _ <- char '.'+       frac <- many digitChar+       exp <- optional $ try $ do+         _ <- oneOf "eE"+         sign <- optional (oneOf "+-")+         e <- L.decimal+         return $ case sign of+           Just '-' -> negate (fromIntegral e)+           _        -> fromIntegral e+       let base = fromIntegral n + readFrac frac+           mult = case exp of+             Just e  -> 10 ** e+             Nothing -> 1.0+       return $ base * mult+  ]+  where+    readFrac "" = 0.0+    readFrac ds = read ('0':'.':ds) / 10 ^^ length ds++stringLiteral :: Lexer Token+stringLiteral = lexeme $ TokString <$> (char '"' *> many stringChar <* char '"')+  where+    stringChar = escapeSeq <|> satisfy (/= '"')+    escapeSeq = char '\\' *> choice+      [ '\n' <$ char 'n', '\r' <$ char 'r', '\t' <$ char 't'+      , '\b' <$ char 'b', '\\' <$ char '\\', '"' <$ char '"'+      , chr . read <$> count 3 digitChar+      ]++charLiteral :: Lexer Token+charLiteral = lexeme $ TokChar <$> between (char '`') (char '`') (escapeSeq <|> anySingleBut '`')+  where+    escapeSeq = char '\\' *> choice+      [ '\n' <$ char 'n', '\r' <$ char 'r', '\t' <$ char 't'+      , '\b' <$ char 'b', '\\' <$ char '\\', '`' <$ char '`'+      , chr . read <$> count 3 digitChar+      ]++operatorOrSymbol :: Lexer Token+operatorOrSymbol = lexeme $ choice $ map try+  [ TokMinusGreater <$ string "->"+  , TokDotDot <$ string ".."+  , TokDotLParen <$ string ".("+  , TokDotLBracket <$ string ".["+  , TokColonColon <$ string "::"+  , TokColonEqual <$ string ":="+  , TokSemiSemi <$ string ";;"+  , TokLessMinus <$ string "<-"+  , TokEqualEqual <$ string "=="+  , TokUnderUnder <$ string "__"+  , TokBarRBracket <$ string "|]"+  , TokLBracketBar <$ string "[|"+  , TokLBracketLess <$ string "[<"+  , TokGreaterRBracket <$ string ">]"+  , TokAmpersandAmpersand <$ string "&&"+  , TokBarBar <$ string "||"+  , TokEqual <$ string "="+  , TokSharp <$ string "#"+  , TokAmpersand <$ string "&"+  , TokQuote <$ string "'"+  , TokLParen <$ string "("+  , TokRParen <$ string ")"+  , TokStar <$ try (string "*" <* notFollowedBy camlSymbolChar)+  , TokComma <$ string ","+  , TokDot <$ string "."+  , TokColon <$ string ":"+  , TokSemi <$ string ";"+  , TokLBracket <$ string "["+  , TokRBracket <$ string "]"+  , TokUnderscore <$ try (string "_" <* notFollowedBy (alphaNumChar <|> char '_' <|> char '\''))+  , TokLBrace <$ string "{"+  , TokBar <$ string "|"+  , TokRBrace <$ string "}"+  , subtractiveOp+  , prefixOp+  , infixOp+  ]++subtractiveOp :: Lexer Token+subtractiveOp = choice [ TokSubtractive "-." <$ string "-.", TokSubtractive "-" <$ string "-" ]++prefixOp :: Lexer Token+prefixOp = TokPrefix <$> ((:) <$> oneOf "!?" <*> many camlSymbolChar)++infixOp :: Lexer Token+infixOp = choice+  [ TokInfix 0 <$> ((:) <$> oneOf "=<>|&~$" <*> many camlSymbolChar)+  , TokInfix 1 <$> ((:) <$> oneOf "@^" <*> many camlSymbolChar)+  , TokInfix 2 <$> ((:) <$> oneOf "+-" <*> many camlSymbolChar)+  , TokInfix 4 <$> (string "**" <> many camlSymbolChar)+  , TokInfix 3 <$> ((:) <$> oneOf "*/%" <*> many camlSymbolChar)+  ]++camlSymbolChar :: Lexer Char+camlSymbolChar = oneOf "!$%&*+-./:<=>?@^|~"++lexer :: Map String Token -> Lexer [Located Token]+lexer kwTable = spaceConsumer *> many (tokenP kwTable) <* eof++mkKeywordTable :: [(String, String)] -> Map String Token+mkKeywordTable pairs = Map.union keywordTableCore (Map.fromList [(kw, TokKeywordExt pid kw) | (pid, kw) <- pairs])
+ src/CamlParser/Lexer/Token.hs view
@@ -0,0 +1,37 @@+module CamlParser.Lexer.Token where++data Token+  = TokIdent String+  | TokPrefix String+  | TokInfix Int String+  | TokSubtractive String+  | TokInt Integer+  | TokChar Char+  | TokFloat Double+  | TokString String+  | TokEOF+  -- Special symbols+  | TokEqual | TokEqualEqual | TokSharp+  | TokAmpersand | TokQuote | TokLParen | TokRParen+  | TokStar | TokComma | TokMinusGreater | TokDot+  | TokDotDot | TokDotLParen | TokDotLBracket+  | TokColon | TokColonColon | TokColonEqual+  | TokSemi | TokSemiSemi | TokLBracket | TokLBracketBar+  | TokLBracketLess | TokLessMinus | TokRBracket+  | TokUnderscore | TokUnderUnder | TokLBrace+  | TokBar | TokBarRBracket | TokGreaterRBracket | TokRBrace+  | TokAmpersandAmpersand | TokBarBar+  -- Keywords+  | TokAnd | TokAs | TokBegin | TokDo | TokDone | TokDownto+  | TokElse | TokEnd | TokException | TokFor | TokFun+  | TokFunction | TokIf | TokIn | TokLet | TokMatch+  | TokMutable | TokNot | TokOf | TokOr | TokPref | TokRec+  | TokThen | TokTo | TokTry | TokType | TokValue | TokWhen+  | TokWhere | TokWhile | TokWith+  -- Plugin-extensible tokens+  | TokKeywordExt String String+  deriving (Eq, Ord, Show)++isIdentToken :: Token -> Maybe String+isIdentToken (TokIdent s) = Just s+isIdentToken _ = Nothing
+ src/CamlParser/Parser/Assembly.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE OverloadedStrings #-}+module CamlParser.Parser.Assembly where++import Data.Map (Map)+import qualified Data.Map as Map+import Text.Megaparsec hiding (Token)+import CamlParser.Lexer.Token+import CamlParser.Lexer.Lexer+import CamlParser.Syntax.Expr+import CamlParser.Syntax.Pattern+import CamlParser.Syntax.Decl+import CamlParser.Syntax.Location+import CamlParser.Parser.Combinators+import CamlParser.Parser.Toplevel+import CamlParser.Plugin.Interface+import CamlParser.Plugin.Registry++assembleKeywordTable :: PluginRegistry -> Map String Token+assembleKeywordTable reg = Map.union (registryKeywords reg) keywordTableCore++runLexer :: PluginRegistry -> String -> Either String [Located Token]+runLexer reg input =+  case runParser (lexer kwTable) "" input of+    Left err -> Left (show err)+    Right toks -> Right toks+  where+    kwTable = assembleKeywordTable reg++runParserOnTokens :: Parser a -> [Located Token] -> Either String a+runParserOnTokens p toks =+  case runParser p "" toks of+    Left err -> Left (show err)+    Right x -> Right x++-- Assemble a toplevel parser that includes plugin declarations+assembleToplevelParser :: PluginRegistry -> Parser (Toplevel Expr Pattern)+assembleToplevelParser reg = do+  let declParsers = concatMap mkDecl (registryPlugins reg)+  if null declParsers+    then parseToplevel+    else choice (map (fmap TImpl) declParsers ++ [parseToplevel])+  where+    mkDecl p = case pluginDecl p of+      Nothing -> []+      Just d  -> [d]
+ src/CamlParser/Parser/Combinators.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE OverloadedStrings #-}+module CamlParser.Parser.Combinators where++import Control.Monad (void)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Void (Void)+import Text.Megaparsec hiding (Token)+import Text.Megaparsec.Char+import CamlParser.Lexer.Token+import CamlParser.Syntax.Location+import CamlParser.Syntax.Expr+import CamlParser.Syntax.Pattern++type Parser = Parsec Void [Located Token]++tok :: Token -> Parser Token+tok t = token testTok Set.empty+  where+    testTok (Located t' _)+      | t == t'   = Just t'+      | otherwise = Nothing++matchTok :: (Token -> Maybe a) -> Parser a+matchTok f = token (\(Located t' _) -> f t') Set.empty++identP :: Parser String+identP = matchTok isIdentToken <?> "identifier"+  where+    isIdentToken (TokIdent s) = Just s+    isIdentToken (TokKeywordExt _ s) = Just s+    isIdentToken _ = Nothing++intP :: Parser Integer+intP = matchTok isInt <?> "integer"+  where+    isInt (TokInt n) = Just n+    isInt _ = Nothing++floatP :: Parser Double+floatP = matchTok isFloat <?> "float"+  where+    isFloat (TokFloat f) = Just f+    isFloat _ = Nothing++stringP :: Parser String+stringP = matchTok isStr <?> "string"+  where+    isStr (TokString s) = Just s+    isStr _ = Nothing++charP :: Parser Char+charP = matchTok isCh <?> "char"+  where+    isCh (TokChar c) = Just c+    isCh _ = Nothing++keyword :: String -> Parser String+keyword kw = matchTok test <?> ("keyword " ++ kw)+  where+    test (TokKeywordExt _ s) | s == kw = Just s+    test _ = Nothing++located :: Parser a -> Parser (Located a)+located p = do+  Located _ loc1 <- lookAhead anySingle+  v <- p+  Located _ loc2 <- lookAhead anySingle+  return $ Located v (loc1 <> loc2)++parens :: Parser a -> Parser a+parens = between (tok TokLParen) (tok TokRParen)++brackets :: Parser a -> Parser a+brackets = between (tok TokLBracket) (tok TokRBracket)++braces :: Parser a -> Parser a+braces = between (tok TokLBrace) (tok TokRBrace)++semi, comma, dot, colon, equal, minusGreater :: Parser ()+semi = void (tok TokSemi)+comma = void (tok TokComma)+dot = void (tok TokDot)+colon = void (tok TokColon)+equal = void (tok TokEqual)+minusGreater = void (tok TokMinusGreater)++bar :: Parser ()+bar = void (tok TokBar)++andP :: Parser ()+andP = void (tok TokAnd)++infixOpP :: Int -> Parser String+infixOpP level = matchTok test <?> ("infix operator level " ++ show level)+  where+    test (TokInfix l s) | l == level = Just s+    test (TokStar)      | level == 3 = Just "*"+    test (TokSubtractive s) | level == 2 = Just s+    test TokEqual       | level == 0 = Just "="+    test TokEqualEqual  | level == 0 = Just "=="+    test _ = Nothing++prefixOpP :: Parser String+prefixOpP = matchTok test <?> "prefix operator"+  where+    test (TokPrefix s) = Just s+    test _ = Nothing++subtractiveP :: Parser String+subtractiveP = matchTok test <?> "subtractive operator"+  where+    test (TokSubtractive s) = Just s+    test _ = Nothing++consP :: Parser ()+consP = void (tok TokColonColon)++assignP :: Parser ()+assignP = void (tok TokColonEqual)++lessMinusP :: Parser ()+lessMinusP = void (tok TokLessMinus)++optionalBar :: Parser ()+optionalBar = optional (tok TokBar) >> return ()
+ src/CamlParser/Parser/Expr.hs view
@@ -0,0 +1,406 @@+{-# LANGUAGE OverloadedStrings #-}+module CamlParser.Parser.Expr where++import Control.Monad (void)+import Data.Functor (($>))+import Data.List (foldl')+import Text.Megaparsec hiding (Token)+import CamlParser.Lexer.Token+import CamlParser.Syntax.Location+import CamlParser.Syntax.Constant+import CamlParser.Syntax.Type+import CamlParser.Syntax.Pattern+import CamlParser.Syntax.Expr+import CamlParser.Parser.Combinators+import CamlParser.Parser.Pattern (parsePattern, parseAtomicPattern)+import CamlParser.Parser.Type (parseType)++parseExpr :: Parser Expr+parseExpr = parseLetExpr++locatedExpr :: Parser (ExprF Expr) -> Parser Expr+locatedExpr p = do+  Located _ loc1 <- lookAhead anySingle+  e <- p+  Located _ loc2 <- lookAhead anySingle+  return $ Expr e (loc1 <> loc2)++parseLetExpr :: Parser Expr+parseLetExpr = choice+  [ parseLetIn+  , parseFun+  , parseFunction+  , parseMatch+  , parseTry+  , parseIfExpr+  , parseWhile+  , parseFor+  , parseWhere+  , parseSeqExpr+  ]++parseLetIn :: Parser Expr+parseLetIn = locatedExpr $ do+  tok TokLet+  rec <- option False (tok TokRec $> True)+  binds <- parseBindingList+  tok TokIn+  body <- parseExpr+  return $ ELet rec binds body++parseBindingList :: Parser [(Pattern, Expr)]+parseBindingList = sepBy1 parseBinding (tok TokAnd)++parseBinding :: Parser (Pattern, Expr)+parseBinding = do+  pat <- parsePattern+  void equal+  e <- parseExpr+  return (pat, e)++parseFun :: Parser Expr+parseFun = locatedExpr $ do+  tok TokFun+  optionalBar+  cases <- parseFunCases+  return $ EFunction cases++parseFunction :: Parser Expr+parseFunction = locatedExpr $ do+  tok TokFunction+  optionalBar+  cases <- parseFunctionCases+  return $ EFunction (map (\(p, e) -> ([p], e)) cases)++parseMatch :: Parser Expr+parseMatch = locatedExpr $ do+  tok TokMatch+  e <- parseExpr+  tok TokWith+  optionalBar+  cases <- parseFunctionCases+  return $ EMatch e (map (\(p, e) -> (p, e)) cases)++parseTry :: Parser Expr+parseTry = locatedExpr $ do+  tok TokTry+  e <- parseExpr+  tok TokWith+  optionalBar+  cases <- parseTryCases+  return $ ETry e cases++parseFunCases :: Parser [([Pattern], Expr)]+parseFunCases = sepBy1 parseFunCase bar+  where+    parseFunCase = do+      pats <- some parseAtomicPattern+      void minusGreater+      e <- parseExpr+      return (pats, e)++parseFunctionCases :: Parser [(Pattern, Expr)]+parseFunctionCases = sepBy1 parseFunctionCase bar+  where+    parseFunctionCase = do+      pat <- parsePattern+      void minusGreater+      e <- parseExpr+      return (pat, e)++parseTryCases :: Parser [(Pattern, Expr)]+parseTryCases = sepBy1 parseTryCase bar+  where+    parseTryCase = do+      pat <- parsePattern+      void minusGreater+      e <- parseExpr+      return (pat, e)++parseIfExpr :: Parser Expr+parseIfExpr = locatedExpr $ do+  tok TokIf+  cond <- parseExpr+  tok TokThen+  then_ <- parseExpr+  (do tok TokElse+      else_ <- parseExpr+      return $ EIf cond then_ else_+   ) <|> return (EIf cond then_ (Expr (EConstruct0 "()") emptyLoc))++parseWhile :: Parser Expr+parseWhile = locatedExpr $ do+  tok TokWhile+  cond <- parseExpr+  tok TokDo+  body <- parseOptExpr+  tok TokDone+  return $ EWhile cond body++parseFor :: Parser Expr+parseFor = locatedExpr $ do+  tok TokFor+  i <- identP+  void equal+  start <- parseExpr+  up <- (tok TokTo $> True) <|> (tok TokDownto $> False)+  end <- parseExpr+  tok TokDo+  body <- parseOptExpr+  tok TokDone+  return $ EFor (Local i) start end up body++parseWhere :: Parser Expr+parseWhere = do+  e <- parseSeqExpr+  (do tok TokWhere+      rec <- option False (tok TokRec $> True)+      binds <- parseBindingList+      return $ Expr (ELet rec binds e) (exprLoc e)+   ) <|> return e++parseSeqExpr :: Parser Expr+parseSeqExpr = do+  e <- parseAssignExpr+  (do semi+      e2 <- parseSeqExpr+      return $ Expr (ESeq e e2) (exprLoc e <> exprLoc e2)+   ) <|> return e++parseAssignExpr :: Parser Expr+parseAssignExpr = do+  e <- parseCommaExpr+  choice+    [ do assignP+         r <- parseAssignExpr+         return $ Expr (EAssign (extractId e) r) (exprLoc e)+    , do lessMinusP+         r <- parseAssignExpr+         return $ Expr (EApply (Expr (EIdent (Local "<-")) emptyLoc) [e, r]) (exprLoc e)+    , return e+    ]+  where+    extractId (Expr (EIdent (Local s)) _) = s+    extractId _ = ""++parseCommaExpr :: Parser Expr+parseCommaExpr = do+  es <- sepBy1 parseOrExpr comma+  case es of+    [e] -> return e+    _   -> return $ Expr (ETuple es) (foldl1 (<>) (map exprLoc es))++parseOrExpr :: Parser Expr+parseOrExpr = parseLeftAssoc [TokOr, TokBarBar] parseAndExpr mkBinop+  where+    mkBinop e1 e2 = Expr (EApply (Expr (EIdent (Local "or")) emptyLoc) [e1, e2]) (exprLoc e1 <> exprLoc e2)++parseAndExpr :: Parser Expr+parseAndExpr = parseLeftAssoc [TokAmpersand, TokAmpersandAmpersand] parseNotExpr mkBinop+  where+    mkBinop e1 e2 = Expr (EApply (Expr (EIdent (Local "&&")) emptyLoc) [e1, e2]) (exprLoc e1 <> exprLoc e2)++parseNotExpr :: Parser Expr+parseNotExpr = choice+  [ do tok TokNot+       e <- parseNotExpr+       return $ Expr (EApply (Expr (EIdent (Local "not")) emptyLoc) [e]) (exprLoc e)+  , parseCmpExpr+  ]++parseCmpExpr :: Parser Expr+parseCmpExpr = do+  e1 <- parseAppendExpr+  rest <- many $ choice+    [ do tok TokEqual; e2 <- parseAppendExpr; return ("=", e2)+    , do tok TokEqualEqual; e2 <- parseAppendExpr; return ("==", e2)+    , do op <- infixOpP 0; e2 <- parseAppendExpr; return (op, e2)+    ]+  return $ foldl' (\e (op, e2) -> mk op e e2) e1 rest+  where+    mk op e1 e2 = Expr (EApply (Expr (EIdent (Local op)) emptyLoc) [e1, e2]) (exprLoc e1 <> exprLoc e2)++parseAppendExpr :: Parser Expr+parseAppendExpr = parseRightAssocOp [1] parseConsExpr mkBinop+  where+    mkBinop op e1 e2 = Expr (EApply (Expr (EIdent (Local op)) emptyLoc) [e1, e2]) (exprLoc e1 <> exprLoc e2)++parseConsExpr :: Parser Expr+parseConsExpr = do+  e1 <- parseAddExpr+  (do consP+      e2 <- parseConsExpr+      return $ Expr (EApply (Expr (EIdent (Local "::")) emptyLoc) [e1, e2]) (exprLoc e1 <> exprLoc e2)+   ) <|> return e1++parseAddExpr :: Parser Expr+parseAddExpr = do+  e1 <- parseMulExpr+  rest <- many $ choice+    [ do s <- subtractiveP; e2 <- parseMulExpr; return (s, e2)+    , do op <- infixOpP 2; e2 <- parseMulExpr; return (op, e2)+    ]+  return $ foldl' (\e (op, e2) -> mk op e e2) e1 rest+  where+    mk op e1 e2 = Expr (EApply (Expr (EIdent (Local op)) emptyLoc) [e1, e2]) (exprLoc e1 <> exprLoc e2)++parseMulExpr :: Parser Expr+parseMulExpr = parseLeftAssocOp [3] parsePowExpr mkBinop+  where+    mkBinop op e1 e2 = Expr (EApply (Expr (EIdent (Local op)) emptyLoc) [e1, e2]) (exprLoc e1 <> exprLoc e2)++parsePowExpr :: Parser Expr+parsePowExpr = parseRightAssocOp [4] parseNegExpr mkBinop+  where+    mkBinop op e1 e2 = Expr (EApply (Expr (EIdent (Local op)) emptyLoc) [e1, e2]) (exprLoc e1 <> exprLoc e2)++parseNegExpr :: Parser Expr+parseNegExpr = choice+  [ do s <- subtractiveP+       e <- parseNegExpr+       case s of+         "-"  -> return $ Expr (EApply (Expr (EIdent (Local "-")) emptyLoc) [e]) (exprLoc e)+         "-." -> return $ Expr (EApply (Expr (EIdent (Local "-.")) emptyLoc) [e]) (exprLoc e)+         _    -> fail "unknown subtractive"+  , parseAppExpr+  ]++parseAppExpr :: Parser Expr+parseAppExpr = do+  e <- parseProjExpr+  args <- many parseProjExpr+  case args of+    [] -> return e+    _  -> return $ Expr (EApply e args) (exprLoc e <> foldl1 (<>) (map exprLoc args))++parseProjExpr :: Parser Expr+parseProjExpr = do+  e <- parsePrefixExpr+  projections e+  where+    projections e = choice+      [ do dot+           f <- identP+           projections (Expr (ERecordAccess e f) (exprLoc e))+      , do tok TokDotLParen+           i <- parseExpr+           tok TokRParen+           projections (Expr (EApply (Expr (EIdent (Local "vect_item")) emptyLoc) [e, i]) (exprLoc e))+      , do tok TokDotLBracket+           i <- parseExpr+           tok TokRBracket+           projections (Expr (EApply (Expr (EIdent (Local "nth_char")) emptyLoc) [e, i]) (exprLoc e))+      , return e+      ]++parsePrefixExpr :: Parser Expr+parsePrefixExpr = choice+  [ do op <- prefixOpP+       e <- parsePrefixExpr+       return $ Expr (EApply (Expr (EIdent (Local op)) emptyLoc) [e]) (exprLoc e)+  , parseAtomicExpr+  ]++parseAtomicExpr :: Parser Expr+parseAtomicExpr = locatedExpr $ choice+  [ EConstant <$> parseConstant+  , EIdent <$> parseIdent+  , parseListExpr+  , parseVectorExpr+  , parseStreamExpr+  , parseRecordExpr+  , parseUnit+  , do tok TokLParen+       e <- parseExpr+       tok TokRParen+       return $ unExpr e+  , do tok TokLParen+       e <- parseExpr+       tok TokColon+       t <- parseType+       tok TokRParen+       return $ EConstraint e t+  , parseBeginEnd+  ]++parseUnit :: Parser (ExprF Expr)+parseUnit = EConstruct0 "()" <$ try (tok TokLParen >> tok TokRParen)++parseBeginEnd :: Parser (ExprF Expr)+parseBeginEnd = tok TokBegin >> EConstruct0 "()" <$ tok TokEnd  -- TODO: proper begin..end++parseIdent :: Parser Ident+parseIdent = do+  s <- identP+  (do tok TokUnderUnder+      m <- identP+      return $ Global s m+   ) <|> return (Local s)++parseConstant :: Parser Constant+parseConstant = choice+  [ CInt <$> intP+  , CFloat <$> floatP+  , CString <$> stringP+  , CChar <$> charP+  ]++parseListExpr :: Parser (ExprF Expr)+parseListExpr = do+  es <- brackets (sepBy parseExpr semi)+  return $ foldr (\x r -> EApply (Expr (EIdent (Local "::")) emptyLoc) [x, Expr r emptyLoc]) (EConstruct0 "[]") es++parseVectorExpr :: Parser (ExprF Expr)+parseVectorExpr = do+  tok TokLBracketBar+  es <- sepBy parseExpr semi+  tok TokBarRBracket+  return $ EVector es++parseRecordExpr :: Parser (ExprF Expr)+parseRecordExpr = do+  fields <- braces (sepBy fieldP semi)+  return $ ERecord fields+  where+    fieldP = do+      f <- identP+      void equal+      e <- parseExpr+      return (f, e)++parseStreamExpr :: Parser (ExprF Expr)+parseStreamExpr = do+  tok TokLBracketLess+  comps <- sepBy parseStreamComponent semi+  tok TokGreaterRBracket+  return $ EStream comps++parseStreamComponent :: Parser (StreamComponent Expr)+parseStreamComponent = choice+  [ tok TokQuote >> STerm <$> parseExpr+  , SNonterm <$> parseExpr+  ]++parseOptExpr :: Parser Expr+parseOptExpr = parseExpr <|> return (Expr (EConstruct0 "()") emptyLoc)++parseLeftAssoc :: [Token] -> Parser Expr -> (Expr -> Expr -> Expr) -> Parser Expr+parseLeftAssoc toks next mk = do+  e1 <- next+  rest <- many ((choice (map tok toks)) >> next)+  return $ foldl' mk e1 rest++parseLeftAssocOp :: [Int] -> Parser Expr -> (String -> Expr -> Expr -> Expr) -> Parser Expr+parseLeftAssocOp levels next mk = do+  e1 <- next+  rest <- many ((do op <- choice (map infixOpP levels)+                    return op) >>= \op -> next >>= \e2 -> return (op, e2))+  return $ foldl' (\e (op, e2) -> mk op e e2) e1 rest++parseRightAssocOp :: [Int] -> Parser Expr -> (String -> Expr -> Expr -> Expr) -> Parser Expr+parseRightAssocOp levels next mk = do+  e1 <- next+  (do op <- choice (map infixOpP levels)+      e2 <- parseRightAssocOp levels next mk+      return $ mk op e1 e2+   ) <|> return e1
+ src/CamlParser/Parser/Pattern.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE OverloadedStrings #-}+module CamlParser.Parser.Pattern where++import Control.Monad (void)+import Data.Maybe (fromMaybe)+import Text.Megaparsec hiding (Token)+import CamlParser.Lexer.Token+import CamlParser.Syntax.Location+import CamlParser.Syntax.Constant+import CamlParser.Syntax.Pattern+import CamlParser.Syntax.Type+import CamlParser.Parser.Combinators+import CamlParser.Parser.Type (parseType)++parsePattern :: Parser Pattern+parsePattern = parseOrPattern++locatedPattern :: Parser (PatternF Pattern) -> Parser Pattern+locatedPattern p = do+  Located _ loc1 <- lookAhead anySingle+  pf <- p+  mbLoc <- optional (locatedLoc <$> lookAhead anySingle)+  return $ Pattern pf (loc1 <> fromMaybe loc1 mbLoc)++parseOrPattern :: Parser Pattern+parseOrPattern = do+  p <- parseConsPattern+  rest <- many (bar >> parseConsPattern)+  return $ foldr1 mkOr (p : rest)+  where+    mkOr a b = Pattern (POr a b) (patLoc a <> patLoc b)++parseConsPattern :: Parser Pattern+parseConsPattern = do+  p <- parseCtorAppOrAtomic+  (do tok TokColonColon+      q <- parseConsPattern+      return $ Pattern (PConstr1 "::" (Pattern (PTuple [p, q]) (patLoc p <> patLoc q))) (patLoc p <> patLoc q)+   ) <|> return p++parseCtorAppOrAtomic :: Parser Pattern+parseCtorAppOrAtomic = choice+  [ try parseCtorApp+  , parseAtomicPattern+  ]++parseCtorApp :: Parser Pattern+parseCtorApp = do+  c <- identP+  args <- some parseAtomicPattern+  return $ Pattern (PConstr1 c (mkTuplePat args)) emptyLoc++mkTuplePat :: [Pattern] -> Pattern+mkTuplePat [p] = p+mkTuplePat ps  = Pattern (PTuple ps) emptyLoc++parseAtomicPattern :: Parser Pattern+parseAtomicPattern = locatedPattern $ choice+  [ PWild <$ tok TokUnderscore+  , parseConstPattern+  , PVar <$> identP+  , PTuple <$> parens (sepBy1 parsePattern comma)+  , parseListPattern+  , parseRecordPattern+  , PConstraint <$> parens parsePattern <*> (colon >> parseType)+  ]++parseConstPattern :: Parser (PatternF Pattern)+parseConstPattern = choice+  [ PConstant . CInt <$> intP+  , PConstant . CFloat <$> floatP+  , PConstant . CString <$> stringP+  , PConstant . CChar <$> charP+  , do s <- subtractiveP+       case s of+         "-" -> PConstant . CInt . negate <$> intP+         "-." -> PConstant . CFloat . negate <$> floatP+         _ -> empty+  ]++parseListPattern :: Parser (PatternF Pattern)+parseListPattern = do+  ps <- brackets (sepBy parsePattern semi)+  return $ foldr (\x r -> PConstr1 "::" (Pattern (PTuple [x, Pattern r emptyLoc]) emptyLoc)) (PConstr0 "[]") ps++parseRecordPattern :: Parser (PatternF Pattern)+parseRecordPattern = do+  fields <- braces (sepBy fieldP semi)+  return $ PRecord fields+  where+    fieldP = do+      f <- identP+      void equal+      p <- parsePattern+      return (f, p)
+ src/CamlParser/Parser/Toplevel.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE OverloadedStrings #-}+module CamlParser.Parser.Toplevel where++import Control.Monad (void)+import Data.Functor (($>))+import Text.Megaparsec hiding (Token)+import CamlParser.Lexer.Token+import CamlParser.Syntax.Location+import CamlParser.Syntax.Expr+import CamlParser.Syntax.Pattern+import CamlParser.Syntax.Type+import CamlParser.Syntax.Decl+import CamlParser.Parser.Combinators+import CamlParser.Parser.Expr (parseExpr)+import CamlParser.Parser.Pattern (parsePattern)+import CamlParser.Parser.Type (parseType)++parseToplevel :: Parser (Toplevel Expr Pattern)+parseToplevel = choice+  [ parseImpl+  , parseIntf+  ]++parseImpl :: Parser (Toplevel Expr Pattern)+parseImpl = TImpl <$> parseImplPhrase++parseIntf :: Parser (Toplevel Expr Pattern)+parseIntf = TIntf <$> parseIntfPhrase++parseImplPhrase :: Parser (Decl Expr Pattern)+parseImplPhrase = choice+  [ try parseExprDef+  , try parseLetDef+  , try parseTypeDef+  , try parseExcDef+  , try parseDirective+  ]++parseExprDef :: Parser (Decl Expr Pattern)+parseExprDef = do+  e <- parseExpr+  void (tok TokSemiSemi)+  return $ DExpr e++parseLetDef :: Parser (Decl Expr Pattern)+parseLetDef = do+  tok TokLet+  rec <- option False (tok TokRec $> True)+  binds <- parseBindingList+  void (tok TokSemiSemi)+  return $ DLet rec binds++parseBindingList :: Parser [(Pattern, Expr)]+parseBindingList = sepBy1 parseBinding (tok TokAnd)++parseBinding :: Parser (Pattern, Expr)+parseBinding = do+  pat <- parsePattern+  void equal+  e <- parseExpr+  return (pat, e)++parseTypeDef :: Parser (Decl Expr Pattern)+parseTypeDef = do+  tok TokType+  decls <- sepBy1 parseTypeDecl (tok TokAnd)+  void (tok TokSemiSemi)+  return $ DType decls++parseTypeDecl :: Parser (String, [String], TypeDecl)+parseTypeDecl = do+  params <- parseTypeParams+  name <- identP+  def <- parseTypeDefBody+  return (name, params, def)++parseTypeParams :: Parser [String]+parseTypeParams = choice+  [ parens (sepBy1 parseTypeVar comma)+  , fmap return parseTypeVar+  , return []+  ]++parseTypeVar :: Parser String+parseTypeVar = tok TokQuote >> identP++parseTypeDefBody :: Parser TypeDecl+parseTypeDefBody = choice+  [ try $ do equal+             optionalBar+             TDVariant <$> sepBy1 parseConstrDecl bar+  , try $ do equal+             TDRecord <$> braces (sepBy1 parseLabelDecl semi)+  , try $ do tok TokEqualEqual+             TDAbbrev <$> parseType+  , return TDAbstract+  ]++parseConstrDecl :: Parser ConstrDecl+parseConstrDecl = choice+  [ try $ do name <- identP+             tok TokOf+             ty <- parseType+             return $ CD1 name ty False+  , CD0 <$> identP+  ]++parseLabelDecl :: Parser (String, TypeExpr, Bool)+parseLabelDecl = do+  mut <- option False (tok TokMutable $> True)+  name <- identP+  colon+  ty <- parseType+  return (name, ty, mut)++parseExcDef :: Parser (Decl Expr Pattern)+parseExcDef = do+  tok TokException+  decls <- sepBy1 parseConstrDecl (tok TokAnd)+  void (tok TokSemiSemi)+  return $ DExc decls++parseDirective :: Parser (Decl Expr Pattern)+parseDirective = do+  tok TokSharp+  dir <- identP+  arg <- option "" stringP+  void (tok TokSemiSemi)+  return $ DDirective dir arg++parseIntfPhrase :: Parser (IntfDecl Expr Pattern)+parseIntfPhrase = choice+  [ parseValueDecl+  , parseIntfTypeDef+  , parseIntfExcDef+  , parseIntfDirective+  ]++parseValueDecl :: Parser (IntfDecl Expr Pattern)+parseValueDecl = do+  tok TokValue+  decls <- sepBy1 parseValue1Decl (tok TokAnd)+  void (tok TokSemiSemi)+  return $ IValue decls++parseValue1Decl :: Parser (String, TypeExpr, PrimDesc)+parseValue1Decl = do+  name <- identP+  colon+  ty <- parseType+  desc <- option NotPrim (equal >> parsePrimDecl)+  return (name, ty, desc)++parsePrimDecl :: Parser PrimDesc+parsePrimDecl = do+  n <- intP+  s <- stringP+  return $ Prim (fromIntegral n) s++parseIntfTypeDef :: Parser (IntfDecl Expr Pattern)+parseIntfTypeDef = do+  tok TokType+  decls <- sepBy1 parseTypeDecl (tok TokAnd)+  void (tok TokSemiSemi)+  return $ IType decls++parseIntfExcDef :: Parser (IntfDecl Expr Pattern)+parseIntfExcDef = do+  tok TokException+  decls <- sepBy1 parseConstrDecl (tok TokAnd)+  void (tok TokSemiSemi)+  return $ IExc decls++parseIntfDirective :: Parser (IntfDecl Expr Pattern)+parseIntfDirective = do+  tok TokSharp+  dir <- identP+  arg <- option "" stringP+  void (tok TokSemiSemi)+  return $ IDirective dir arg
+ src/CamlParser/Parser/Type.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE OverloadedStrings #-}+module CamlParser.Parser.Type where++import Text.Megaparsec hiding (Token)+import CamlParser.Lexer.Token+import CamlParser.Syntax.Type+import CamlParser.Parser.Combinators++parseType :: Parser TypeExpr+parseType = parseArrowType++parseArrowType :: Parser TypeExpr+parseArrowType = do+  t <- parseTupleType+  (do tok TokMinusGreater+      r <- parseArrowType+      return $ TArrow t r+   ) <|> return t++parseTupleType :: Parser TypeExpr+parseTupleType = do+  ts <- sepBy1 parseAppType (tok TokStar)+  case ts of+    [t] -> return t+    _   -> return $ TTuple ts++parseAppType :: Parser TypeExpr+parseAppType = do+  ts <- some parseAtomicType+  case ts of+    [t] -> return t+    _   -> return $ foldl1 (\acc t2 -> case t2 of+        TConstr s _ -> TConstr s [acc]+        TVar s -> TConstr s [acc]+        _ -> error "invalid type constructor in application") ts++parseAtomicType :: Parser TypeExpr+parseAtomicType = choice+  [ TVar <$> (tok TokQuote >> identP)+  , TConstr <$> identP <*> return []+  , TConstr . show <$> intP <*> return []+  , do tok TokLParen+       t <- parseType+       (do comma+           ts <- sepBy1 parseType comma+           tok TokRParen+           c <- identP+           return $ TConstr c (t : ts)+        ) <|> (tok TokRParen >> return t)+  ]
+ src/CamlParser/Plugin/Interface.hs view
@@ -0,0 +1,19 @@+module CamlParser.Plugin.Interface where++import Data.Map (Map)+import CamlParser.Lexer.Token+import CamlParser.Syntax.Expr+import CamlParser.Syntax.Pattern+import CamlParser.Syntax.Decl+import CamlParser.Parser.Combinators++-- | A plugin can extend the lexer, expression parser, and declaration parser.+data CamlParserPlugin = CamlParserPlugin+  { pluginName :: String+  , pluginKeywords :: Map String Token+  , pluginExprAtom :: Maybe (Parser Expr)+  , pluginDecl :: Maybe (Parser (Decl Expr Pattern))+  }++nullPlugin :: String -> CamlParserPlugin+nullPlugin name = CamlParserPlugin name mempty Nothing Nothing
+ src/CamlParser/Plugin/Registry.hs view
@@ -0,0 +1,19 @@+module CamlParser.Plugin.Registry where++import Data.Map (Map)+import qualified Data.Map as Map+import CamlParser.Lexer.Token+import CamlParser.Plugin.Interface++newtype PluginRegistry = PluginRegistry+  { registryPlugins :: [CamlParserPlugin]+  }++emptyRegistry :: PluginRegistry+emptyRegistry = PluginRegistry []++registerPlugin :: CamlParserPlugin -> PluginRegistry -> PluginRegistry+registerPlugin p (PluginRegistry ps) = PluginRegistry (p : ps)++registryKeywords :: PluginRegistry -> Map String Token+registryKeywords (PluginRegistry ps) = Map.unions (map pluginKeywords ps)
+ src/CamlParser/Syntax/Constant.hs view
@@ -0,0 +1,8 @@+module CamlParser.Syntax.Constant where++data Constant+  = CInt Integer+  | CFloat Double+  | CString String+  | CChar Char+  deriving (Eq, Show)
+ src/CamlParser/Syntax/Decl.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE ExistentialQuantification #-}+module CamlParser.Syntax.Decl where++import CamlParser.Syntax.Location+import CamlParser.Syntax.Type+import CamlParser.Syntax.Pattern+import CamlParser.Syntax.Expr++data ConstrDecl+  = CD0 String+  | CD1 String TypeExpr Bool+  deriving (Eq, Show)++data TypeDecl+  = TDAbstract+  | TDVariant [ConstrDecl]+  | TDRecord [(String, TypeExpr, Bool)]+  | TDAbbrev TypeExpr+  deriving (Eq, Show)++data PrimDesc = NotPrim | Prim Int String+  deriving (Eq, Show)++data Decl expr pat+  = DLet Bool [(pat, expr)]+  | DType [(String, [String], TypeDecl)]+  | DExc [ConstrDecl]+  | DExpr expr+  | DDirective String String+  | forall ext. DExt String (DeclExt expr pat ext)++data DeclExt expr pat ext = DeclExt+  { declExtName :: String+  , declExtValue :: ext+  }++data Toplevel expr pat+  = TImpl (Decl expr pat)+  | TIntf (IntfDecl expr pat)+  deriving (Eq, Show)++data IntfDecl expr pat+  = IValue [(String, TypeExpr, PrimDesc)]+  | IType [(String, [String], TypeDecl)]+  | IExc [ConstrDecl]+  | IDirective String String+  deriving (Eq, Show)++instance (Eq expr, Eq pat) => Eq (Decl expr pat) where+  DLet b1 xs1 == DLet b2 xs2 = b1 == b2 && xs1 == xs2+  DType xs1 == DType xs2 = xs1 == xs2+  DExc xs1 == DExc xs2 = xs1 == xs2+  DExpr e1 == DExpr e2 = e1 == e2+  DDirective a1 b1 == DDirective a2 b2 = a1 == a2 && b1 == b2+  DExt n1 _ == DExt n2 _ = n1 == n2+  _ == _ = False++instance (Show expr, Show pat) => Show (Decl expr pat) where+  show (DLet b xs) = "DLet " ++ show b ++ " " ++ show xs+  show (DType xs) = "DType " ++ show xs+  show (DExc xs) = "DExc " ++ show xs+  show (DExpr e) = "DExpr " ++ show e+  show (DDirective a b) = "DDirective " ++ show a ++ " " ++ show b+  show (DExt n _) = "DExt " ++ show n ++ " <ext>"
+ src/CamlParser/Syntax/Expr.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+module CamlParser.Syntax.Expr where++import CamlParser.Syntax.Location+import CamlParser.Syntax.Constant+import CamlParser.Syntax.Type+import CamlParser.Syntax.Pattern++data Ident+  = Local String+  | Global String String+  deriving (Eq, Show)++data StreamComponent r+  = STerm r+  | SNonterm r+  deriving (Eq, Show, Functor, Foldable, Traversable)++data StreamPattern+  = SPTerm Pattern+  | SPNonterm Expr Pattern+  | SPStream String+  deriving (Eq, Show)++data ExprF r+  = EIdent Ident+  | EConstant Constant+  | ETuple [r]+  | EConstruct0 String+  | EConstruct1 String r+  | EApply r [r]+  | ELet Bool [(Pattern, r)] r+  | EFunction [( [Pattern], r)]+  | EMatch r [(Pattern, r)]+  | ETry r [(Pattern, r)]+  | ESeq r r+  | EIf r r r+  | EWhile r r+  | EFor Ident r r Bool r+  | EConstraint r TypeExpr+  | EVector [r]+  | EAssign String r+  | ERecord [(String, r)]+  | ERecordAccess r String+  | ERecordUpdate r String r+  | EStream [StreamComponent r]+  | EParser [(StreamPattern, r)]+  | EWhen r r+  | EExt String [r]+  deriving (Eq, Show, Functor, Foldable, Traversable)++data Expr = Expr+  { unExpr  :: ExprF Expr+  , exprLoc :: Location+  } deriving (Eq, Show)
+ src/CamlParser/Syntax/Location.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE DeriveFunctor #-}+module CamlParser.Syntax.Location where++import Text.Megaparsec (SourcePos)++data Location = Location+  { locStart :: SourcePos+  , locEnd   :: SourcePos+  } deriving (Eq, Ord, Show)++data Located a = Located+  { locatedValue :: a+  , locatedLoc   :: Location+  } deriving (Eq, Ord, Show, Functor)++instance Semigroup Location where+  Location s1 _ <> Location _ e2 = Location s1 e2++emptyLoc :: Location+emptyLoc = Location undefined undefined
+ src/CamlParser/Syntax/Pattern.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+module CamlParser.Syntax.Pattern where++import CamlParser.Syntax.Location+import CamlParser.Syntax.Constant+import CamlParser.Syntax.Type++data PatternF r+  = PWild+  | PVar String+  | PAlias r String+  | PConstant Constant+  | PTuple [r]+  | PConstr0 String+  | PConstr1 String r+  | POr r r+  | PConstraint r TypeExpr+  | PRecord [(String, r)]+  | PExt String [r]+  deriving (Eq, Show, Functor, Foldable, Traversable)++data Pattern = Pattern+  { unPattern :: PatternF Pattern+  , patLoc    :: Location+  } deriving (Eq, Show)
+ src/CamlParser/Syntax/Type.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE DeriveFunctor #-}+module CamlParser.Syntax.Type where++data TypeExpr+  = TVar String+  | TArrow TypeExpr TypeExpr+  | TTuple [TypeExpr]+  | TConstr String [TypeExpr]+  deriving (Eq, Show)
+ src/MLQE/Plugin.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE OverloadedStrings #-}+module MLQE.Plugin where++import Control.Monad (void)+import Data.Map (Map)+import qualified Data.Map as Map+import Text.Megaparsec hiding (Token)+import CamlParser.Lexer.Token+import CamlParser.Syntax.Expr+import CamlParser.Syntax.Pattern+import CamlParser.Syntax.Type+import CamlParser.Syntax.Decl+import CamlParser.Syntax.Location+import CamlParser.Parser.Combinators+import CamlParser.Parser.Expr (parseExpr)+import CamlParser.Parser.Type (parseType)+import CamlParser.Plugin.Interface+import MLQE.Syntax++mlqeKeywords :: Map String Token+mlqeKeywords = Map.fromList+  [ ("qubit",    TokKeywordExt mlqeTag "qubit")+  , ("qdef",     TokKeywordExt mlqeTag "qdef")+  , ("qalloc",   TokKeywordExt mlqeTag "qalloc")+  , ("qlift",    TokKeywordExt mlqeTag "qlift")+  , ("measure",  TokKeywordExt mlqeTag "measure")+  , ("unitary",  TokKeywordExt mlqeTag "unitary")+  , ("kraus",    TokKeywordExt mlqeTag "kraus")+  , ("gate",     TokKeywordExt mlqeTag "gate")+  , ("channel",  TokKeywordExt mlqeTag "channel")+  , ("pulse",    TokKeywordExt mlqeTag "pulse")+  , ("complex",  TokKeywordExt mlqeTag "complex")+  , ("matrix",   TokKeywordExt mlqeTag "matrix")+  ]++mlqePlugin :: CamlParserPlugin+mlqePlugin = CamlParserPlugin+  { pluginName = "mlqe"+  , pluginKeywords = mlqeKeywords+  , pluginExprAtom = Nothing  -- qalloc, qlift, measure parse as ordinary applications+  , pluginDecl = Just mlqeDeclParser+  }++mlqeDeclParser :: Parser (Decl Expr Pattern)+mlqeDeclParser = do+  keyword "qdef"+  name <- identP+  choice+    [ parseQDefConcrete name+    , parseQDefParamAbstract name+    , parseQDefAbstract name+    ]++parseQDefAbstract :: String -> Parser (Decl Expr Pattern)+parseQDefAbstract name = do+  tok TokColon+  ty <- parseType+  void (tok TokSemiSemi)+  return $ DExt mlqeTag (DeclExt mlqeTag (QDefAbstract name (Just ty)))++parseQDefParamAbstract :: String -> Parser (Decl Expr Pattern)+parseQDefParamAbstract name = do+  tok TokOf+  pty <- parseType+  tok TokColon+  ty <- parseType+  void (tok TokSemiSemi)+  return $ DExt mlqeTag (DeclExt mlqeTag (QDefParamAbstract name pty ty))++parseQDefConcrete :: String -> Parser (Decl Expr Pattern)+parseQDefConcrete name = do+  tok TokEqual+  qe <- parseQExpr+  void (tok TokSemiSemi)+  return $ DExt mlqeTag (DeclExt mlqeTag (QDefConcrete name qe))++parseQExpr :: Parser QExpr+parseQExpr = parseQTensor++parseQTensor :: Parser QExpr+parseQTensor = do+  e1 <- parseQSeq+  (do tok TokStar+      e2 <- parseQTensor+      return $ QTensor e1 e2+   ) <|> return e1++parseQSeq :: Parser QExpr+parseQSeq = do+  e1 <- parseQAtom+  (do tok (TokInfix 1 "@")+      e2 <- parseQSeq+      return $ QSeq e1 e2+   ) <|> return e1++parseQAtom :: Parser QExpr+parseQAtom = choice+  [ do n <- identP+       (do e <- parens parseExpr+           return $ QParam n e+        ) <|> return (QVar n)+  , QId <$ keyword "id"+  ]
+ src/MLQE/Syntax.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}+module MLQE.Syntax where++import CamlParser.Syntax.Expr+import CamlParser.Syntax.Pattern+import CamlParser.Syntax.Type+import CamlParser.Syntax.Decl++-- | MLQE-specific declaration extension+data MLQEDecl+  = QDefAbstract String (Maybe TypeExpr)      -- name, optional type+  | QDefConcrete String QExpr                 -- name, quantum expression+  | QDefParamAbstract String TypeExpr TypeExpr -- name, param type, result type+  deriving (Eq, Show)++-- | Quantum expression+data QExpr+  = QVar String+  | QSeq QExpr QExpr      -- @+  | QTensor QExpr QExpr   -- *+  | QId+  | QParam String Expr    -- name(classical_expr)+  deriving (Eq, Show)++-- We encode MLQE declarations in the generic extension mechanism+-- by storing them as DExt with a tag.+mlqeTag :: String+mlqeTag = "mlqe"
+ test/Main.hs view
@@ -0,0 +1,498 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Test.Tasty+import Test.Tasty.HUnit+import Data.Map (Map)+import qualified Data.Map as Map++import CamlParser.Lexer.Token+import CamlParser.Lexer.Lexer+import CamlParser.Syntax.Expr+import CamlParser.Syntax.Pattern+import CamlParser.Syntax.Decl+import CamlParser.Syntax.Type+import CamlParser.Syntax.Constant+import CamlParser.Syntax.Location+import CamlParser.Parser.Assembly+import CamlParser.Parser.Combinators (keyword, identP, tok)+import CamlParser.Parser.Expr (parseExpr)+import CamlParser.Parser.Pattern (parsePattern)+import CamlParser.Parser.Type (parseType)+import CamlParser.Plugin.Registry+import CamlParser.Plugin.Interface+import MLQE.Plugin (mlqePlugin)+import Control.Monad (void)++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "caml-parser Tests"+  [ lexerTests+  , exprTests+  , patternTests+  , typeTests+  , declTests+  , projTests+  , pluginTests+  , negativeTests+  ]++-- =====================================================================+-- Helpers+-- =====================================================================++lexString :: String -> Either String [Located Token]+lexString = runLexer emptyRegistry++parseExprTokens :: [Located Token] -> Either String Expr+parseExprTokens = runParserOnTokens parseExpr++parseToplevelTokens :: PluginRegistry -> [Located Token] -> Either String (Toplevel Expr Pattern)+parseToplevelTokens reg = runParserOnTokens (assembleToplevelParser reg)++parseExprStr :: String -> Either String Expr+parseExprStr s = lexString s >>= parseExprTokens++parseToplevelStr :: PluginRegistry -> String -> Either String (Toplevel Expr Pattern)+parseToplevelStr reg s = runLexer reg s >>= parseToplevelTokens reg++-- Shape helpers for precedence tests+exprShape :: Expr -> String+exprShape (Expr (EApply (Expr (EIdent (Local op)) _) args) _) = "(" ++ op ++ " " ++ unwords (map exprShape args) ++ ")"+exprShape (Expr (EConstant (CInt n)) _) = show n+exprShape (Expr (EConstant (CFloat f)) _) = show f+exprShape (Expr (EIdent (Local i)) _) = i+exprShape (Expr (ETuple es) _) = "(" ++ unwords (map exprShape es) ++ ")"+exprShape (Expr (EConstruct0 c) _) = c+exprShape (Expr (ESeq e1 e2) _) = "(; " ++ exprShape e1 ++ " " ++ exprShape e2 ++ ")"+exprShape (Expr (ELet _ _ _) _) = "let"+exprShape (Expr (EIf _ _ _) _) = "if"+exprShape (Expr (EFunction _) _) = "fun"+exprShape (Expr (ERecordAccess e f) _) = "(. " ++ exprShape e ++ " " ++ f ++ ")"+exprShape _ = "?"++patShape :: Pattern -> String+patShape (Pattern (PVar v) _) = v+patShape (Pattern PWild _) = "_"+patShape (Pattern (PConstant (CInt n)) _) = show n+patShape (Pattern (PConstr0 c) _) = c+patShape (Pattern (PConstr1 c p) _) = "(" ++ c ++ " " ++ patShape p ++ ")"+patShape (Pattern (PTuple ps) _) = "(" ++ unwords (map patShape ps) ++ ")"+patShape (Pattern (POr p1 p2) _) = "(| " ++ patShape p1 ++ " " ++ patShape p2 ++ ")"+patShape _ = "?pat"++typeShape :: TypeExpr -> String+typeShape (TVar v) = v+typeShape (TConstr c []) = c+typeShape (TConstr c [a]) = "(" ++ c ++ " " ++ typeShape a ++ ")"+typeShape (TConstr c as) = "(" ++ c ++ " " ++ unwords (map typeShape as) ++ ")"+typeShape (TTuple ts) = "(* " ++ unwords (map typeShape ts) ++ ")"+typeShape (TArrow a b) = "(-> " ++ typeShape a ++ " " ++ typeShape b ++ ")"++assertParseExpr :: String -> String -> Assertion+assertParseExpr src expected = case parseExprStr src of+  Right e -> assertEqual "expression shape" expected (exprShape e)+  Left err -> assertFailure $ "parse failed: " ++ err++assertParsePattern :: String -> String -> Assertion+assertParsePattern src expected = case lexString src >>= parsePatternTokens of+  Right p -> assertEqual "pattern shape" expected (patShape p)+  Left err -> assertFailure $ "parse failed: " ++ err+  where+    parsePatternTokens = runParserOnTokens parsePattern++assertParseType :: String -> String -> Assertion+assertParseType src expected = case lexString src >>= parseTypeTokens of+  Right t -> assertEqual "type shape" expected (typeShape t)+  Left err -> assertFailure $ "parse failed: " ++ err+  where+    parseTypeTokens = runParserOnTokens parseType++assertParseFails :: String -> Assertion+assertParseFails src = case parseExprStr src of+  Left _ -> return ()+  Right e -> assertFailure $ "expected parse failure, got: " ++ show e++assertLexFails :: String -> Assertion+assertLexFails src = case lexString src of+  Left _ -> return ()+  Right toks -> assertFailure $ "expected lex failure, got: " ++ show toks++-- =====================================================================+-- A. Lexer Edge Cases+-- =====================================================================++lexerTests :: TestTree+lexerTests = testGroup "Lexer"+  [ testCase "integer" $ do+      let toks = lexString "42"+      case toks of+        Right [Located (TokInt 42) _] -> return ()+        _ -> assertFailure $ "unexpected: " ++ show toks+  , testCase "identifier" $ do+      let toks = lexString "foo"+      case toks of+        Right [Located (TokIdent "foo") _] -> return ()+        _ -> assertFailure $ "unexpected: " ++ show toks+  , testCase "keyword let" $ do+      let toks = lexString "let"+      case toks of+        Right [Located TokLet _] -> return ()+        _ -> assertFailure $ "unexpected: " ++ show toks+  , testCase "operator" $ do+      let toks = lexString "+"+      case toks of+        Right [Located (TokInfix 2 "+") _] -> return ()+        _ -> assertFailure $ "unexpected: " ++ show toks+  , testCase "string literal" $ do+      let toks = lexString "\"hello\""+      case toks of+        Right [Located (TokString "hello") _] -> return ()+        _ -> assertFailure $ "unexpected: " ++ show toks+  , testCase "comment" $ do+      let toks = lexString "(* this is a comment *) 42"+      case toks of+        Right [Located (TokInt 42) _] -> return ()+        _ -> assertFailure $ "unexpected: " ++ show toks+  , testCase "mlqe keyword with plugin" $ do+      let toks = runLexer (registerPlugin mlqePlugin emptyRegistry) "qdef"+      case toks of+        Right [Located (TokKeywordExt "mlqe" "qdef") _] -> return ()+        _ -> assertFailure $ "unexpected: " ++ show toks+  -- New lexer tests+  , testCase "nested comments" $ do+      let toks = lexString "(* (* inner *) *) 42"+      case toks of+        Right [Located (TokInt 42) _] -> return ()+        _ -> assertFailure $ "unexpected: " ++ show toks+  , testCase "string escapes" $ do+      let toks = lexString "\"hello\\n\\t\\\\\\\"\""+      case toks of+        Right [Located (TokString "hello\n\t\\\"") _] -> return ()+        _ -> assertFailure $ "unexpected: " ++ show toks+  , testCase "char escapes" $ do+      let toks = lexString "`\\n` `\\t`"+      case toks of+        Right [Located (TokChar '\n') _, Located (TokChar '\t') _] -> return ()+        _ -> assertFailure $ "unexpected: " ++ show toks+  , testCase "float exponent" $ do+      let toks = lexString "1.5e-3"+      case toks of+        Right [Located (TokFloat 1.5e-3) _] -> return ()+        _ -> assertFailure $ "unexpected: " ++ show toks+  , testCase "alternative int bases" $ do+      let toks = lexString "0xFF 0o77 0b1010"+      case toks of+        Right [Located (TokInt 255) _, Located (TokInt 63) _, Located (TokInt 10) _] -> return ()+        _ -> assertFailure $ "unexpected: " ++ show toks+  , testCase "keyword boundary" $ do+      let toks = lexString "letrec"+      case toks of+        Right [Located (TokIdent "letrec") _] -> return ()+        _ -> assertFailure $ "unexpected: " ++ show toks+  , testCase "multi-char symbols" $ do+      let toks = lexString "-> :: := -. .("+      case toks of+        Right [Located TokMinusGreater _, Located TokColonColon _, Located TokColonEqual _,+               Located (TokSubtractive "-.") _, Located TokDotLParen _] -> return ()+        _ -> assertFailure $ "unexpected: " ++ show toks+  , testCase "accent/underscore idents" $ do+      let toks = lexString "foo' _foo foo_bar"+      case toks of+        Right [Located (TokIdent "foo'") _, Located (TokIdent "_foo") _, Located (TokIdent "foo_bar") _] -> return ()+        _ -> assertFailure $ "unexpected: " ++ show toks+  ]++-- =====================================================================+-- B. Expression Precedence & Associativity+-- =====================================================================++exprTests :: TestTree+exprTests = testGroup "Expression Parser"+  [ testCase "integer literal" $+      assertParseExpr "42;;" "42"+  , testCase "let in" $+      assertParseExpr "let x = 1 in x;;" "let"+  , testCase "if then else" $+      assertParseExpr "if true then 1 else 2;;" "if"+  , testCase "function application" $+      assertParseExpr "f x y;;" "(f x y)"+  , testCase "tuple" $+      assertParseExpr "(1, 2);;" "(1 2)"+  , testCase "binary operator" $+      assertParseExpr "1 + 2;;" "(+ 1 2)"+  , testCase "list literal" $ do+      let result = parseExprStr "[1; 2];;"+      case result of+        Right e -> case unExpr e of+          EApply _ [_, _] -> return ()+          _ -> assertFailure $ "unexpected list shape: " ++ show e+        Left err -> assertFailure err+  -- New expression tests+  , testCase "prec: mul over add" $+      assertParseExpr "1 + 2 * 3;;" "(+ 1 (* 2 3))"+  , testCase "assoc: left sub" $+      assertParseExpr "1 - 2 - 3;;" "(- (- 1 2) 3)"+  , testCase "assoc: right pow" $+      assertParseExpr "2 ** 3 ** 2;;" "(** 2 (** 3 2))"+  , testCase "assoc: right cons" $+      assertParseExpr "1 :: 2 :: [];;" "(:: 1 (:: 2 []))"+  , testCase "assoc: right append" $+      assertParseExpr "a @ b @ c;;" "(@ a (@ b c))"+  , testCase "prec: not over and" $+      assertParseExpr "not a && b;;" "(&& (not a) b)"+  , testCase "unary minus" $+      assertParseExpr "- 5;;" "(- 5)"+  , testCase "unary minus float" $+      assertParseExpr "-. 5.;;" "(-. 5.0)"+  , testCase "curried application" $+      assertParseExpr "f a b c;;" "(f a b c)"+  , testCase "mixed precedence" $+      assertParseExpr "a + b * c - d;;" "(- (+ a (* b c)) d)"+  , testCase "comparison chain" $+      assertParseExpr "a = b == c;;" "(== (= a b) c)"+  , testCase "nested let" $+      assertParseExpr "let x = 1 in let y = 2 in x + y;;" "let"+  , testCase "multiple bindings" $+      assertParseExpr "let x = 1 and y = 2 in x + y;;" "let"+  , testCase "fun multiple args" $+      assertParseExpr "fun x y z -> x + y + z;;" "fun"+  , testCase "function cases" $ do+      let result = parseExprStr "function | [] -> 0 | x::xs -> 1;;"+      case result of+        Right (Expr (EFunction _) _) -> return ()+        _ -> assertFailure $ "unexpected: " ++ show result+  , testCase "match cases" $ do+      let result = parseExprStr "match e with | A -> 1 | B -> 2 | _ -> 3;;"+      case result of+        Right (Expr (EMatch _ _) _) -> return ()+        _ -> assertFailure $ "unexpected: " ++ show result+  , testCase "try with" $ do+      let result = parseExprStr "try f x with | Failure _ -> 0;;"+      case result of+        Right (Expr (ETry _ _) _) -> return ()+        _ -> assertFailure $ "unexpected: " ++ show result+  , testCase "dangling else" $+      assertParseExpr "if a then if b then c else d;;" "if"+  , testCase "sequence" $+      assertParseExpr "a; b; c;;" "(; a (; b c))"+  , testCase "let rec mutual" $ do+      let result = parseExprStr "let rec f x = g x and g x = f x in f 1;;"+      case result of+        Right (Expr (ELet True _ _) _) -> return ()+        _ -> assertFailure $ "unexpected: " ++ show result+  , testCase "where clause" $+      assertParseExpr "x where x = 1;;" "let"+  ]++-- =====================================================================+-- C. Pattern Matching+-- =====================================================================++patternTests :: TestTree+patternTests = testGroup "Pattern Parser"+  [ testCase "wildcard" $+      assertParsePattern "_" "_"+  , testCase "variable" $+      assertParsePattern "x" "x"+  , testCase "constant" $+      assertParsePattern "42" "42"+  , testCase "tuple" $+      assertParsePattern "(x, y, z)" "(x y z)"+  , testCase "cons" $+      assertParsePattern "x :: xs" "(:: (x xs))"+  , testCase "list" $+      assertParsePattern "[a; b; c]" "(:: (a (:: (b (:: (c []))))))"+  , testCase "or pattern" $+      assertParsePattern "A | B" "(| A B)"+  , testCase "nested cons" $+      assertParsePattern "x :: y :: zs" "(:: (x (:: (y zs))))"+  , testCase "nested pattern" $+      assertParsePattern "(x, y) :: zs" "(:: ((x y) zs))"+  , testCase "record pattern" $ do+      let result = lexString "{a = x; b = y}" >>= runParserOnTokens parsePattern+      case result of+        Right (Pattern (PRecord _) _) -> return ()+        _ -> assertFailure $ "unexpected: " ++ show result+  ]++-- =====================================================================+-- D. Type Expressions+-- =====================================================================++typeTests :: TestTree+typeTests = testGroup "Type Parser"+  [ testCase "type variable" $+      assertParseType "'a" "a"+  , testCase "arrow right-assoc" $+      assertParseType "'a -> 'b -> 'c" "(-> a (-> b c))"+  , testCase "tuple type" $+      assertParseType "int * string * bool" "(* int string bool)"+  , testCase "constructor chain" $+      assertParseType "int list list" "(list (list int))"+  , testCase "multi-param ctor" $+      assertParseType "(int, string) either" "(either int string)"+  , testCase "mixed arrow tuple" $+      assertParseType "'a -> 'b * 'c -> 'd" "(-> a (-> (* b c) d))"+  ]++-- =====================================================================+-- E. Declarations+-- =====================================================================++declTests :: TestTree+declTests = testGroup "Declaration Parser"+  [ testCase "let def" $ do+      let result = parseToplevelStr emptyRegistry "let x = 1;;"+      case result of+        Right (TImpl (DLet False _)) -> return ()+        _ -> assertFailure $ "unexpected: " ++ show result+  , testCase "let rec def" $ do+      let result = parseToplevelStr emptyRegistry "let rec f x = x;;"+      case result of+        Right (TImpl (DLet True _)) -> return ()+        _ -> assertFailure $ "unexpected: " ++ show result+  , testCase "type def variant" $ do+      let result = parseToplevelStr emptyRegistry "type foo = A | B;;"+      case result of+        Right (TImpl (DType [("foo", _, TDVariant [CD0 "A", CD0 "B"])])) -> return ()+        _ -> assertFailure $ "unexpected: " ++ show result+  , testCase "exception def" $ do+      let result = parseToplevelStr emptyRegistry "exception Error;;"+      case result of+        Right (TImpl (DExc [CD0 "Error"])) -> return ()+        _ -> assertFailure $ "unexpected: " ++ show result+  -- New declaration tests+  , testCase "parameterized variant" $ do+      let result = parseToplevelStr emptyRegistry "type 'a option = None | Some of 'a;;"+      case result of+        Right (TImpl (DType [("option", ["a"], TDVariant [CD0 "None", CD1 "Some" (TVar "a") False])])) -> return ()+        _ -> assertFailure $ "unexpected: " ++ show result+  , testCase "type abbreviation" $ do+      let result = parseToplevelStr emptyRegistry "type 'a pair == 'a * 'a;;"+      case result of+        Right (TImpl (DType [("pair", ["a"], TDAbbrev (TTuple [TVar "a", TVar "a"]))])) -> return ()+        _ -> assertFailure $ "unexpected: " ++ show result+  , testCase "record type" $ do+      let result = parseToplevelStr emptyRegistry "type point = {x : int; y : int};;"+      case result of+        Right (TImpl (DType [("point", _, TDRecord [("x", TConstr "int" [], False), ("y", TConstr "int" [], False)])])) -> return ()+        _ -> assertFailure $ "unexpected: " ++ show result+  , testCase "exception with arg" $ do+      let result = parseToplevelStr emptyRegistry "exception Error of string;;"+      case result of+        Right (TImpl (DExc [CD1 "Error" (TConstr "string" []) False])) -> return ()+        _ -> assertFailure $ "unexpected: " ++ show result+  , testCase "multiple type decls" $ do+      let result = parseToplevelStr emptyRegistry "type a = A and b = B;;"+      case result of+        Right (TImpl (DType [("a", _, _), ("b", _, _)])) -> return ()+        _ -> assertFailure $ "unexpected: " ++ show result+  , testCase "directive" $ do+      let result = parseToplevelStr emptyRegistry "#open \"foo\";;"+      case result of+        Right (TImpl (DDirective "open" "foo")) -> return ()+        _ -> assertFailure $ "unexpected: " ++ show result+  , testCase "let tuple pat" $ do+      let result = parseToplevelStr emptyRegistry "let f (x, y) = x + y;;"+      case result of+        Right (TImpl (DLet False _)) -> return ()+        _ -> assertFailure $ "unexpected: " ++ show result+  ]++-- =====================================================================+-- F. Projections & Assignments+-- =====================================================================++projTests :: TestTree+projTests = testGroup "Projections & Assignments"+  [ testCase "record access" $+      assertParseExpr "r.field;;" "(. r field)"+  , testCase "vector access" $+      assertParseExpr "v.(i);;" "(vect_item v i)"+  , testCase "string access" $+      assertParseExpr "s.[i];;" "(nth_char s i)"+  , testCase "reference assign" $ do+      let result = parseExprStr "x := 1;;"+      case result of+        Right (Expr (EAssign "x" (Expr (EConstant (CInt 1)) _)) _) -> return ()+        _ -> assertFailure $ "unexpected: " ++ show result+  , testCase "record field update" $+      assertParseExpr "r.field <- e;;" "(<- (. r field) e)"+  ]++-- =====================================================================+-- G. Plugin Integration+-- =====================================================================++pluginTests :: TestTree+pluginTests = testGroup "Plugin Integration"+  [ testCase "plugin non-interference" $ do+      let core = parseToplevelStr emptyRegistry "let x = 1 in x + 2;;"+      let withMlqe = parseToplevelStr (registerPlugin mlqePlugin emptyRegistry) "let x = 1 in x + 2;;"+      case (core, withMlqe) of+        (Right (TImpl (DExpr ce)), Right (TImpl (DExpr me)))+          | exprShape ce == exprShape me -> return ()+        _ -> assertFailure "AST differs with/without plugin"+  , testCase "keyword absent without plugin" $ do+      let toks = lexString "gate"+      case toks of+        Right [Located (TokIdent "gate") _] -> return ()+        _ -> assertFailure $ "unexpected: " ++ show toks+  , testCase "keyword present with plugin" $ do+      let toks = runLexer (registerPlugin mlqePlugin emptyRegistry) "gate"+      case toks of+        Right [Located (TokKeywordExt "mlqe" "gate") _] -> return ()+        _ -> assertFailure $ "unexpected: " ++ show toks+  , testCase "qdef abstract" $ do+      let reg = registerPlugin mlqePlugin emptyRegistry+      let result = parseToplevelStr reg "qdef hadamard : 1 gate;;"+      case result of+        Right (TImpl (DExt "mlqe" _)) -> return ()+        _ -> assertFailure $ "unexpected: " ++ show result+  , testCase "qdef concrete" $ do+      let reg = registerPlugin mlqePlugin emptyRegistry+      let result = parseToplevelStr reg "qdef bell = hadamard @ cnot;;"+      case result of+        Right (TImpl (DExt "mlqe" _)) -> return ()+        _ -> assertFailure $ "unexpected: " ++ show result+  , testCase "qdef parameterized" $ do+      let reg = registerPlugin mlqePlugin emptyRegistry+      let result = parseToplevelStr reg "qdef phase of float : 1 gate;;"+      case result of+        Right (TImpl (DExt "mlqe" _)) -> return ()+        _ -> assertFailure $ "unexpected: " ++ show result+  , testCase "multiple plugins" $ do+      let mock1 = CamlParserPlugin "mock1"+            (Map.fromList [("foo", TokKeywordExt "mock1" "foo")])+            Nothing+            (Just $ do keyword "foo"; n <- identP; void (tok TokSemiSemi)+                       return $ DExt "mock1" (DeclExt "mock1" ("foo:" ++ n)))+      let mock2 = CamlParserPlugin "mock2"+            (Map.fromList [("bar", TokKeywordExt "mock2" "bar")])+            Nothing+            (Just $ do keyword "bar"; n <- identP; void (tok TokSemiSemi)+                       return $ DExt "mock2" (DeclExt "mock2" ("bar:" ++ n)))+      let reg = registerPlugin mock2 (registerPlugin mock1 emptyRegistry)+      let r1 = parseToplevelStr reg "foo x;;"+      let r2 = parseToplevelStr reg "bar y;;"+      case (r1, r2) of+        (Right (TImpl (DExt "mock1" _)), Right (TImpl (DExt "mock2" _))) -> return ()+        _ -> assertFailure $ "unexpected: " ++ show (r1, r2)+  ]++-- =====================================================================+-- H. Negative Tests+-- =====================================================================++negativeTests :: TestTree+negativeTests = testGroup "Negative Tests"+  [ testCase "unclosed string" $ assertLexFails "\"hello"+  , testCase "unclosed comment" $ assertLexFails "(* hello"+  , testCase "unmatched paren" $ assertParseFails "(1 + 2;;"+  , testCase "missing in after let" $ assertParseFails "let x = 1 x + 2;;"+  , testCase "trailing else" $ assertParseFails "if true then 1 else;;"+  , testCase "missing operand" $ assertParseFails "1 + * 2;;"+  ]