Merge pull request #12 from tomgasson/iflet

Add `if let` syntax

Author: IwanKaramazow

src/napkin_core.ml

@@ -83,6 +83,8 @@ end
 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 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 [])
 
 type typDefOrExt =
@@ -2000,7 +2002,7 @@ and parseOperandExpr ~context p =
   | Try ->
     parseTryExpression p
   | If ->
-    parseIfExpression p
+    parseIfOrIfLetExpression p
   | For ->
     parseForExpression p
   | While ->
@@ -2996,20 +2998,30 @@ and parseTryExpression p =
   let loc = mkLoc startPos p.prevEndPos in
   Ast_helper.Exp.try_ ~loc expr cases
 
-and parseIfExpression p =
-  Parser.beginRegion p;
-  Parser.leaveBreadcrumb p Grammar.ExprIf;
-  let startPos = p.Parser.startPos in
-  Parser.expect If p;
+and parseIfCondition p =
   Parser.leaveBreadcrumb p Grammar.IfCondition;
   (* doesn't make sense to try es6 arrow here? *)
   let conditionExpr = parseExpr ~context:WhenExpr p in
   Parser.eatBreadcrumb p;
+  conditionExpr
+
+and parseThenBranch p =
   Parser.leaveBreadcrumb p IfBranch;
   Parser.expect Lbrace p;
   let thenExpr = parseExprBlock p in
   Parser.expect Rbrace p;
   Parser.eatBreadcrumb p;
+  thenExpr
+
+and parseElseBranch p =
+  Parser.expect Lbrace p;
+  let blockExpr = parseExprBlock p in
+  Parser.expect Rbrace p;
+  blockExpr;
+
+and parseIfExpr startPos p =
+  let conditionExpr = parseIfCondition p in
+  let thenExpr = parseThenBranch p in
   let elseExpr = match p.Parser.token with
   | Else ->
     Parser.endRegion p;
@@ -3018,12 +3030,9 @@ and parseIfExpression p =
     Parser.beginRegion p;
     let elseExpr = match p.token with
     | If ->
-      parseIfExpression p
+      parseIfOrIfLetExpression p
     | _ ->
-      Parser.expect  Lbrace p;
-      let blockExpr = parseExprBlock p in
-      Parser.expect Rbrace p;
-      blockExpr
+      parseElseBranch p
     in
     Parser.eatBreadcrumb p;
     Parser.endRegion p;
@@ -3033,9 +3042,55 @@ and parseIfExpression p =
     None
   in
   let loc = mkLoc startPos p.prevEndPos in
-  Parser.eatBreadcrumb p;
   Ast_helper.Exp.ifthenelse ~loc conditionExpr thenExpr elseExpr
 
+and parseIfLetExpr startPos p =
+  let pattern = parsePattern p in
+  Parser.expect Equal p;
+  let conditionExpr = parseIfCondition p in
+  let thenExpr = parseThenBranch 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 = match p.token with
+    | If ->
+      parseIfOrIfLetExpression p
+    | _ ->
+      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 loc = mkLoc startPos p.prevEndPos in
+  Ast_helper.Exp.match_ ~attrs:[ifLetAttr; suppressFragileMatchWarningAttr] ~loc conditionExpr [
+    Ast_helper.Exp.case pattern thenExpr;
+    Ast_helper.Exp.case (Ast_helper.Pat.any ()) elseExpr;
+  ]
+
+and parseIfOrIfLetExpression p =
+  Parser.beginRegion p;
+  Parser.leaveBreadcrumb p Grammar.ExprIf;
+  let startPos = p.Parser.startPos in
+  Parser.expect If p;
+  let expr = match p.Parser.token with
+    | Let ->
+      Parser.next p;
+      parseIfLetExpr startPos p
+    | _ ->
+      parseIfExpr startPos p
+  in
+  Parser.eatBreadcrumb p;
+  expr;
+
 and parseForRest hasOpeningParen pattern startPos p =
   Parser.expect In p;
   let e1 = parseExpr p in
@@ -3098,20 +3153,22 @@ and parseWhileExpression p =
   let loc = mkLoc startPos p.prevEndPos in
   Ast_helper.Exp.while_ ~loc expr1 expr2
 
+and parsePatternGuard p =
+  match p.Parser.token with
+    | When ->
+      Parser.next p;
+      Some (parseExpr ~context:WhenExpr p)
+    | _ ->
+      None
+
 and parsePatternMatchCase p =
   Parser.beginRegion p;
   Parser.leaveBreadcrumb p Grammar.PatternMatchCase;
   match p.Parser.token with
   | Token.Bar ->
     Parser.next p;
     let lhs = parsePattern p in
-    let guard = match p.Parser.token with
-    | When ->
-      Parser.next p;
-      Some (parseExpr ~context:WhenExpr p)
-    | _ ->
-      None
-    in
+    let guard = parsePatternGuard p in
     let () = match p.token with
     | EqualGreater -> Parser.next p
     | _ -> Recover.recoverEqualGreater p

src/napkin_parsetree_viewer.ml

@@ -42,18 +42,6 @@ open Parsetree
     in
     process false [] attrs
 
-  let collectIfExpressions expr =
-    let rec collect acc expr = match expr.pexp_desc with
-    | Pexp_ifthenelse (ifExpr, thenExpr, Some elseExpr) ->
-      collect ((ifExpr, thenExpr)::acc) elseExpr
-    | Pexp_ifthenelse (ifExpr, thenExpr, (None as elseExpr)) ->
-      let ifs = List.rev ((ifExpr, thenExpr)::acc) in
-      (ifs, elseExpr)
-    | _ ->
-      (List.rev acc, Some expr)
-    in
-    collect [] expr
-
   let collectListExpressions expr =
     let rec collect acc expr = match expr.pexp_desc with
     | Pexp_construct ({txt = Longident.Lident "[]"}, _) ->
@@ -165,7 +153,7 @@ open Parsetree
   let filterParsingAttrs attrs =
     List.filter (fun attr ->
       match attr with
-      | ({Location.txt = ("ns.ternary" | "ns.braces" | "bs" | "ns.namedArgLoc")}, _) -> false
+      | ({Location.txt = ("ns.ternary" | "ns.braces" | "bs" | "ns.iflet" | "ns.namedArgLoc")}, _) -> false
       | _ -> true
     ) attrs
 
@@ -267,9 +255,30 @@ open Parsetree
     else
       false
 
+  let rec hasIfLetAttribute attrs =
+    match attrs with
+    | [] -> false
+    | ({Location.txt="ns.iflet"},_)::_ -> true
+    | _::attrs -> hasIfLetAttribute attrs
+
+  let isIfLetExpr expr = match expr with
+    | {
+        pexp_attributes = attrs;
+        pexp_desc = Pexp_match _
+      } when hasIfLetAttribute attrs -> true
+    | _ -> false
+
   let hasAttributes attrs =
     List.exists (fun attr -> match attr with
-      | ({Location.txt = "bs" | "ns.ternary" | "ns.braces"}, _) -> false
+      | ({Location.txt = "bs" | "ns.ternary" | "ns.braces" | "ns.iflet"}, _) -> false
+      (* Remove the fragile pattern warning for iflet expressions *)
+      | ({Location.txt="warning"}, PStr [{
+        pstr_desc = Pstr_eval ({
+          pexp_desc = Pexp_constant (
+            Pconst_string ("-4", None)
+          )
+        }, _)
+      }]) -> not (hasIfLetAttribute attrs)
       | _ -> true
     ) attrs
 
@@ -280,6 +289,40 @@ open Parsetree
       ) -> true
     | _ -> false
 
+
+  type ifConditionKind =
+  | If of Parsetree.expression
+  | IfLet of Parsetree.pattern * Parsetree.expression
+
+  let collectIfExpressions expr =
+    let rec collect acc expr = match expr.pexp_desc with
+    | Pexp_ifthenelse (ifExpr, thenExpr, Some elseExpr) ->
+      collect ((If(ifExpr), thenExpr)::acc) elseExpr
+    | Pexp_ifthenelse (ifExpr, thenExpr, (None as elseExpr)) ->
+      let ifs = List.rev ((If(ifExpr), thenExpr)::acc) in
+      (ifs, elseExpr)
+        | Pexp_match (condition, [{
+      pc_lhs = pattern;
+      pc_guard = None;
+      pc_rhs = thenExpr;
+    }; {
+      pc_rhs = {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)}
+    }]) when isIfLetExpr expr ->
+      let ifs = List.rev ((IfLet(pattern, condition), thenExpr)::acc) in
+      (ifs, None)
+    | Pexp_match (condition, [{
+      pc_lhs = pattern;
+      pc_guard = None;
+      pc_rhs = thenExpr;
+    }; {
+      pc_rhs = elseExpr;
+    }]) when isIfLetExpr expr ->
+      collect ((IfLet(pattern, condition), thenExpr)::acc) elseExpr
+    | _ ->
+      (List.rev acc, Some expr)
+    in
+    collect [] expr
+
   let rec hasTernaryAttribute attrs =
     match attrs with
     | [] -> false
@@ -318,6 +361,18 @@ open Parsetree
       | _ -> true
     ) attrs
 
+  let filterFragileMatchAttributes attrs =
+    List.filter (fun attr -> match attr with
+      | ({Location.txt="warning"}, PStr [{
+        pstr_desc = Pstr_eval ({
+          pexp_desc = Pexp_constant (
+            Pconst_string ("-4", _)
+          )
+        }, _)
+      }]) -> false
+      | _ -> true
+    ) attrs
+
   let isJsxExpression expr =
     let rec loop attrs =
       match attrs with
@@ -371,13 +426,13 @@ open Parsetree
 
   let filterPrinteableAttributes attrs =
     List.filter (fun attr -> match attr with
-      | ({Location.txt="bs" | "ns.ternary"}, _) -> false
+      | ({Location.txt="bs" | "ns.ternary" | "ns.iflet"}, _) -> false
       | _ -> true
     ) attrs
 
   let partitionPrinteableAttributes attrs =
     List.partition (fun attr -> match attr with
-      | ({Location.txt="bs" | "ns.ternary"}, _) -> false
+      | ({Location.txt="bs" | "ns.ternary" | "ns.iflet"}, _) -> false
       | _ -> true
     ) attrs
 
@@ -513,4 +568,4 @@ open Parsetree
         {ppat_desc = Ppat_var {txt="__x"}},
         {pexp_desc = Pexp_apply _}
       ) -> true
-    | _ -> false
+    | _ -> false

src/napkin_parsetree_viewer.mli

@@ -13,12 +13,16 @@ val functorType: Parsetree.module_type ->
 (* filters @bs out of the provided attributes *)
 val processUncurriedAttribute: Parsetree.attributes -> bool * Parsetree.attributes
 
+type ifConditionKind =
+  | If of Parsetree.expression
+  | IfLet of Parsetree.pattern * Parsetree.expression
+
 (* if ... else if ... else ... is represented as nested expressions: if ... else { if ... }
 * The purpose of this function is to flatten nested ifs into one sequence.
 * Basically compute: ([if, else if, else if, else if], else) *)
 val collectIfExpressions:
  Parsetree.expression ->
-   (Parsetree.expression * Parsetree.expression) list * Parsetree.expression option
+   (ifConditionKind * Parsetree.expression) list * Parsetree.expression option
 
 val collectListExpressions:
  Parsetree.expression -> (Parsetree.expression list * Parsetree.expression option)
@@ -62,13 +66,15 @@ val hasAttributes: Parsetree.attributes -> bool
 
 val isArrayAccess: Parsetree.expression -> bool
 val isTernaryExpr: Parsetree.expression -> bool
+val isIfLetExpr: Parsetree.expression -> bool
 
 val collectTernaryParts: Parsetree.expression -> ((Parsetree.expression * Parsetree.expression) list * Parsetree.expression)
 
 val parametersShouldHug:
  funParamKind list -> bool
 
 val filterTernaryAttributes: Parsetree.attributes -> Parsetree.attributes
+val filterFragileMatchAttributes: Parsetree.attributes -> Parsetree.attributes
 
 val isJsxExpression: Parsetree.expression -> bool
 val hasJsxAttribute: Parsetree.attributes -> bool
@@ -90,7 +96,7 @@ val modExprApply : Parsetree.module_expr -> (
  * Example: given a ptyp_arrow type, what are its arguments and what is the
  * returnType? *)
 
- 
+
 val modExprFunctor : Parsetree.module_expr -> (
  (Parsetree.attributes * string Asttypes.loc * Parsetree.module_type option) list *
  Parsetree.module_expr
@@ -130,4 +136,4 @@ val classifyJsImport: Parsetree.value_description -> jsImportScope
 val rewriteUnderscoreApply: Parsetree.expression -> Parsetree.expression
 
 (* (__x) => f(a, __x, c) -----> f(a, _, c)  *)
-val isUnderscoreApplySugar: Parsetree.expression -> bool
+val isUnderscoreApplySugar: Parsetree.expression -> bool