Introduce guard syntax

src/napkin_core.ml

@@ -84,6 +84,7 @@ let jsxAttr = (Location.mknoloc "JSX", Parsetree.PStr [])
 let uncurryAttr = (Location.mknoloc "bs", Parsetree.PStr [])
 let ternaryAttr = (Location.mknoloc "ns.ternary", Parsetree.PStr [])
 let ifLetAttr = (Location.mknoloc "ns.iflet", Parsetree.PStr [])
+let guardAttr = (Location.mknoloc "ns.guard", Parsetree.PStr [])
 let suppressFragileMatchWarningAttr = (Location.mknoloc "warning", Parsetree.PStr [Ast_helper.Str.eval (Ast_helper.Exp.constant (Pconst_string ("-4", None)))])
 let makeBracesAttr loc = (Location.mkloc "ns.braces" loc, Parsetree.PStr [])
 
@@ -2003,6 +2004,8 @@ and parseOperandExpr ~context p =
     parseTryExpression p
   | If ->
     parseIfOrIfLetExpression p
+  | Guard ->
+    parseGuardExpression p
   | For ->
     parseForExpression p
   | While ->
@@ -3092,6 +3095,69 @@ and parseIfOrIfLetExpression p =
   Parser.eatBreadcrumb p;
   expr;
 
+and parseGuardLetExpr startPos p =
+   let pattern = parsePattern p in
+  Parser.expect Equal p;
+  let conditionExpr = parseIfCondition p in
+  let elseExpr = match p.Parser.token with
+  | Else ->
+    Parser.endRegion p;
+    Parser.leaveBreadcrumb p Grammar.ElseBranch;
+    Parser.next p;
+    Parser.beginRegion p;
+    let elseExpr = parseElseBranch p in
+    Parser.eatBreadcrumb p;
+    Parser.endRegion p;
+    elseExpr
+  | _ ->
+    Parser.endRegion p;
+    let startPos = p.Parser.startPos in
+    let loc = mkLoc startPos p.prevEndPos in
+    Ast_helper.Exp.construct ~loc (Location.mkloc (Longident.Lident "()") loc) None
+  in
+  let thenExpr = parseExprBlock p in
+  let loc = mkLoc startPos p.prevEndPos in
+  Ast_helper.Exp.match_ ~attrs:[guardAttr] ~loc conditionExpr [
+    Ast_helper.Exp.case pattern thenExpr;
+    Ast_helper.Exp.case (Ast_helper.Pat.any ()) elseExpr;
+  ]
+
+and parseGuardExpr startPos p =
+  let conditionExpr = parseIfCondition p in
+  let elseExpr = match p.Parser.token with
+  | Else ->
+    Parser.endRegion p;
+    Parser.leaveBreadcrumb p Grammar.ElseBranch;
+    Parser.next p;
+    Parser.beginRegion p;
+    let elseExpr = parseElseBranch p in
+    Parser.eatBreadcrumb p;
+    Parser.endRegion p;
+    Some elseExpr
+  | _ ->
+    Parser.endRegion p;
+    None
+  in
+  let thenExpr = parseExprBlock p in
+  let loc = mkLoc startPos p.prevEndPos in
+  Ast_helper.Exp.ifthenelse ~loc ~attrs:[guardAttr] conditionExpr thenExpr elseExpr
+
+and parseGuardExpression p =
+  Parser.beginRegion p;
+  Parser.leaveBreadcrumb p Grammar.ExprGuard;
+  let startPos = p.Parser.startPos in
+  Parser.expect Guard p;
+  let expr = match p.Parser.token with
+    | Let ->
+      Parser.next p;
+      parseGuardLetExpr startPos p
+    | _ ->
+      parseGuardExpr startPos p
+  in
+  Parser.eatBreadcrumb p;
+  expr;
+
+
 and parseForRest hasOpeningParen pattern startPos p =
   Parser.expect In p;
   let e1 = parseExpr p in

src/napkin_diagnostics.ml

@@ -95,6 +95,8 @@ let explain t =
         begin match breadcrumbs, t with
         | (ExprBlock, _) :: _, Rbrace ->
           "It seems that this expression block is empty"
+        | (ExprBlock, _) :: _, Eof ->
+          "It seems that this expression block is incomplete"
         | (ExprBlock, _) :: _, Bar -> (* Pattern matching *)
           "Looks like there might be an expression missing here"
         | (ExprSetField, _) :: _, _ ->
@@ -191,4 +193,4 @@ let unclosedString = UnclosedString
 let unclosedComment = UnclosedComment
 let unclosedTemplate = UnclosedTemplate
 let unknownUchar code = UnknownUchar code
-let message txt = Message txt
+let message txt = Message txt

src/napkin_grammar.ml

@@ -17,6 +17,7 @@ type t =
   | ExprArrayAccess
   | ExprArrayMutation
   | ExprIf
+  | ExprGuard
   | IfCondition | IfBranch | ElseBranch
   | TypeExpression
   | External
@@ -69,6 +70,7 @@ let toString = function
   | ExprUnary -> "a unary expression"
   | ExprBinaryAfterOp op -> "an expression after the operator \"" ^ Token.toString op  ^ "\""
   | ExprIf -> "an if expression"
+  | ExprGuard -> "a guard expression"
   | IfCondition -> "the condition of an if expression"
   | IfBranch -> "the true-branch of an if expression"
   | ElseBranch -> "the else-branch of an if expression"
@@ -169,7 +171,7 @@ let isExprStart = function
   | LessThan
   | Minus | MinusDot | Plus | PlusDot | Bang
   | Percent | At
-  | If | Switch | While | For | Assert | Lazy | Try -> true
+  | If | Guard | Switch | While | For | Assert | Lazy | Try -> true
   | _ -> false
 
 let isJsxAttributeStart = function
@@ -300,7 +302,7 @@ let isBlockExprStart = function
   | Token.At | Hash | Percent | Minus | MinusDot | Plus | PlusDot | Bang
   | True | False | Float _ | Int _ | String _ | Character _ | Lident _ | Uident _
   | Lparen | List | Lbracket | Lbrace | Forwardslash | Assert
-  | Lazy | If | For | While | Switch | Open | Module | Exception | Let
+  | Lazy | If | Guard | For | While | Switch | Open | Module | Exception | Let
   | LessThan | Backtick | Try | Underscore -> true
   | _ -> false
 

src/napkin_parsetree_viewer.ml

@@ -153,7 +153,7 @@ let processBracesAttr expr =
 let filterParsingAttrs attrs =
   List.filter (fun attr ->
     match attr with
-    | ({Location.txt = ("ns.ternary" | "ns.braces" | "bs" | "ns.iflet" | "ns.namedArgLoc")}, _) -> false
+    | ({Location.txt = ("ns.ternary" | "ns.braces" | "bs" | "ns.iflet" | "ns.guard" | "ns.namedArgLoc")}, _) -> false
     | _ -> true
   ) attrs
 
@@ -268,9 +268,22 @@ let isIfLetExpr expr = match expr with
     } when hasIfLetAttribute attrs -> true
   | _ -> false
 
+let rec hasGuardAttribute attrs =
+  match attrs with
+  | [] -> false
+  | ({Location.txt="ns.guard"},_)::_ -> true
+  | _::attrs -> hasGuardAttribute attrs
+
+let isGuardExpr expr = match expr with
+  | {
+      pexp_attributes = attrs;
+      pexp_desc = Pexp_match _ | Pexp_ifthenelse _
+    } when hasGuardAttribute attrs -> true
+  | _ -> false
+
 let hasAttributes attrs =
   List.exists (fun attr -> match attr with
-    | ({Location.txt = "bs" | "ns.ternary" | "ns.braces" | "ns.iflet"}, _) -> false
+    | ({Location.txt = "bs" | "ns.ternary" | "ns.braces" | "ns.iflet" | "ns.guard"}, _) -> false
     (* Remove the fragile pattern warning for iflet expressions *)
     | ({Location.txt="warning"}, PStr [{
       pstr_desc = Pstr_eval ({
@@ -426,13 +439,13 @@ let shouldInlineRhsBinaryExpr rhs = match rhs.pexp_desc with
 
 let filterPrinteableAttributes attrs =
   List.filter (fun attr -> match attr with
-    | ({Location.txt="bs" | "ns.ternary" | "ns.iflet"}, _) -> false
+    | ({Location.txt="bs" | "ns.ternary" | "ns.iflet" | "ns.guard"}, _) -> false
     | _ -> true
   ) attrs
 
 let partitionPrinteableAttributes attrs =
   List.partition (fun attr -> match attr with
-    | ({Location.txt="bs" | "ns.ternary" | "ns.iflet"}, _) -> false
+    | ({Location.txt="bs" | "ns.ternary" | "ns.iflet" | "ns.guard"}, _) -> false
     | _ -> true
   ) attrs
 

src/napkin_parsetree_viewer.mli

@@ -67,6 +67,7 @@ val hasAttributes: Parsetree.attributes -> bool
 val isArrayAccess: Parsetree.expression -> bool
 val isTernaryExpr: Parsetree.expression -> bool
 val isIfLetExpr: Parsetree.expression -> bool
+val isGuardExpr: Parsetree.expression -> bool
 
 val collectTernaryParts: Parsetree.expression -> ((Parsetree.expression * Parsetree.expression) list * Parsetree.expression)
 

src/napkin_printer.ml

@@ -2759,6 +2759,32 @@ and printExpression (e : Parsetree.expression) cmtTbl =
     ]
   | Pexp_setfield (expr1, longidentLoc, expr2) ->
     printSetFieldExpr e.pexp_attributes expr1 longidentLoc expr2 e.pexp_loc cmtTbl
+  | Pexp_ifthenelse (ifExpr, thenExpr, elseExpr) when ParsetreeViewer.isGuardExpr e ->
+    let condition = if ParsetreeViewer.isBlockExpr ifExpr then
+      printExpressionBlock ~braces:true ifExpr cmtTbl
+    else
+      let doc = printExpressionWithComments ifExpr cmtTbl in
+      match Parens.expr ifExpr with
+      | Parens.Parenthesized -> addParens doc
+      | Braced braces  -> printBraces doc ifExpr braces
+      | Nothing -> doc
+    in
+    let elseDoc = match elseExpr with
+      | None -> Doc.nil
+      | Some expr -> Doc.concat [
+        Doc.text "else ";
+        printExpressionBlock ~braces:true expr cmtTbl;
+      ]
+    in
+    Doc.concat [
+      printAttributes e.pexp_attributes cmtTbl;
+      Doc.text "guard ";
+      condition;
+      Doc.space;
+      elseDoc;
+      Doc.line;
+      printExpressionBlock ~braces:false thenExpr cmtTbl;
+    ]
   | Pexp_ifthenelse (_ifExpr, _thenExpr, _elseExpr) when ParsetreeViewer.isTernaryExpr e ->
     let (parts, alternate) = ParsetreeViewer.collectTernaryParts e in
     let ternaryDoc = match parts with
@@ -3030,6 +3056,32 @@ and printExpression (e : Parsetree.expression) cmtTbl =
       Doc.text " catch ";
       printCases cases cmtTbl;
     ]
+  | Pexp_match (conditionExpr, [{
+      pc_lhs = pattern;
+      pc_guard = None;
+      pc_rhs = thenExpr;
+    }; {
+      pc_rhs = elseExpr
+    }]) when ParsetreeViewer.isGuardExpr e ->
+    let patternDoc = printPattern pattern cmtTbl in
+    let conditionDoc = printExpressionWithComments conditionExpr cmtTbl in
+    let elseDocs = match elseExpr with
+      | {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)} -> Doc.nil
+      | _ -> Doc.concat [
+        Doc.text " else ";
+        printExpressionBlock ~braces:true elseExpr cmtTbl
+      ]
+    in
+    Doc.concat [
+      printAttributes e.pexp_attributes cmtTbl;
+      Doc.text "guard let ";
+      patternDoc;
+      Doc.text " = ";
+      conditionDoc;
+      elseDocs;
+      Doc.line;
+      printExpressionBlock ~braces:false thenExpr cmtTbl;
+    ]
   | Pexp_match (_, [_;_]) when ParsetreeViewer.isIfLetExpr e ->
     let (ifs, elseExpr) = ParsetreeViewer.collectIfExpressions e in
     printIfChain e.pexp_attributes ifs elseExpr cmtTbl

src/napkin_token.ml

@@ -46,7 +46,7 @@ type t =
   | Lazy
   | Tilde
   | Question
-  | If | Else | For | In | To | Downto | While | Switch
+  | If | Else | For | In | To | Downto | While | Switch | Guard
   | When
   | EqualGreater | MinusGreater
   | External
@@ -130,6 +130,7 @@ let toString = function
   | Tilde -> "tilde"
   | Question -> "?"
   | If -> "if"
+  | Guard -> "guard"
   | Else -> "else"
   | For -> "for"
   | In -> "in"
@@ -177,6 +178,7 @@ let keywordTable = function
 | "assert" -> Assert
 | "lazy" -> Lazy
 | "if" -> If
+| "guard" -> Guard
 | "else" -> Else
 | "for" -> For
 | "in" -> In
@@ -204,7 +206,7 @@ let keywordTable = function
 
 let isKeyword = function
   | True | False | Open | Let | Rec | And | As
-  | Exception | Assert | Lazy | If | Else | For | In | To
+  | Exception | Assert | Lazy | If | Guard | Else | For | In | To
   | Downto | While | Switch | When | External | Typ | Private
   | Mutable | Constraint | Include | Module | Of
   | Land | Lor | List | With
@@ -220,4 +222,4 @@ let lookupKeyword str =
 
 let isKeywordTxt str =
   try let _ = keywordTable str in true with
-  | Not_found -> false
+  | Not_found -> false

tests/parsing/errors/expressions/__snapshots__/parse.spec.js.snap

@@ -258,6 +258,41 @@ Missing expression
 
 
 
+========================================================"
+`;
+
+exports[`guard.js 1`] = `
+"=====Parsetree==========================================
+;;((if a
+    then (((if c then [%napkinscript.exprhole ] else ()))[@ns.guard ])
+    else ((if b then [%napkinscript.exprhole ] else ())[@ns.guard ]))
+  [@ns.guard ])
+=====Errors=============================================
+
+File \\"/syntax/tests/parsing/errors/expressions/guard.js\\", line 4, characters 5-32:
+
+
+2 │      guard b else {
+3 │          ()
+4 │      }
+5 │      // }, missing a body
+6 │  }
+
+It seems that this expression block is empty
+
+
+File \\"/syntax/tests/parsing/errors/expressions/guard.js\\", line 10, characters 1-25:
+
+
+8 │  guard c else {
+9 │      ()
+10 │  }
+11 │  // eof, missing a body
+
+It seems that this expression block is incomplete
+
+
+
 ========================================================"
 `;
 

tests/parsing/errors/expressions/guard.js

@@ -0,0 +1,11 @@
+guard a else {
+    guard b else {
+        ()
+    }
+    // }, missing a body
+}
+
+guard c else {
+    ()
+}
+// eof, missing a body