Suppress fragile match warning for iflet

Author: tomgasson

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 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 =
@@ -3070,7 +3071,7 @@ and parseIfLetExpr startPos p =
     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] ~loc conditionExpr [
+  Ast_helper.Exp.match_ ~attrs:[ifLetAttr; suppressFragileMatchWarningAttr] ~loc conditionExpr [
     Ast_helper.Exp.case pattern thenExpr;
     Ast_helper.Exp.case (Ast_helper.Pat.any ()) elseExpr;
   ]

src/napkin_parsetree_viewer.ml

@@ -255,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" | "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
 
@@ -268,18 +289,6 @@ open Parsetree
       ) -> true
     | _ -> 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
 
   type ifConditionKind =
   | If of Parsetree.expression
@@ -352,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

src/napkin_parsetree_viewer.mli

@@ -74,6 +74,7 @@ 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

src/napkin_printer.ml

@@ -2411,8 +2411,9 @@ and printIfChain pexp_attributes ifs elseExpr cmtTbl =
       printExpressionBlock ~braces:true expr cmtTbl;
     ]
   in
+  let attrs = ParsetreeViewer.filterFragileMatchAttributes pexp_attributes in
   Doc.concat [
-    printAttributes pexp_attributes cmtTbl;
+    printAttributes attrs cmtTbl;
     ifDocs;
     elseDoc;
   ]
@@ -3072,6 +3073,7 @@ and printExpression (e : Parsetree.expression) cmtTbl =
   | Pexp_newtype _
   | Pexp_setfield _
   | Pexp_ifthenelse _ -> true
+  | Pexp_match _ when ParsetreeViewer.isIfLetExpr e -> true
   | Pexp_construct _ when ParsetreeViewer.hasJsxAttribute e.pexp_attributes -> true
   | _ -> false
   in

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

@@ -504,62 +504,64 @@ let ifElseIfThen =
   then f ()
   else if foo = bar2 then f1 () else if foo = bar3 then f2 () else f3 ()
 let x = (if true then 1 else 2) + (if false then 2 else 3)
-;;((match foo () with | Some x -> doSomethingWithX x | _ -> ())[@ns.iflet ])
+;;((match foo () with | Some x -> doSomethingWithX x | _ -> ())
+  [@ns.iflet ][@warning \\"-4\\"])
 ;;((match foo () with
     | Some x -> doSomethingWithX x
-    | _ -> doSomethingElse ())[@ns.iflet ])
+    | _ -> doSomethingElse ())[@ns.iflet ][@warning \\"-4\\"])
 ;;((match foo () with
     | Some x -> doSomethingWithX x
     | _ ->
         (((match bar () with
            | Some y -> doSomethingWithY y
            | _ -> doSomethingElse ()))
-        [@ns.iflet ]))[@ns.iflet ])
+        [@ns.iflet ][@warning \\"-4\\"]))[@ns.iflet ][@warning \\"-4\\"])
 ;;((match foo () with
     | Some x -> doSomethingWithX x
     | _ -> if n > 10 then doSomethingWithForN () else doSomethingElse ())
-  [@ns.iflet ])
+  [@ns.iflet ][@warning \\"-4\\"])
 ;;if n > 10
   then doSomethingWithForN ()
   else
     (((match foo () with
        | Some x -> doSomethingWithX x
        | _ -> doSomethingElse ()))
-    [@ns.iflet ])
+    [@ns.iflet ][@warning \\"-4\\"])
 ;;if n > 10
   then ((doSomethingWithForN ())[@aa ])
   else
     (((match ((foo ())[@dd ]) with
        | ((Some ((x)[@cc ]))[@bb ]) -> ((doSomethingWithY x)[@ee ])
        | _ -> ((doSomethingElse ())[@ff ])))
-    [@ns.iflet ])
+    [@ns.iflet ][@warning \\"-4\\"])
 ;;((match foo () with
     | Some x -> doSomethingWithX x
     | _ ->
         (((match bar () with
            | Some y -> doSomethingWithY y
            | _ ->
                (((match baz () with | Some z -> doSomethingWithZ z | _ -> ()))
-               [@ns.iflet ])))
-        [@ns.iflet ]))[@ns.iflet ])
+               [@ns.iflet ][@warning \\"-4\\"])))
+        [@ns.iflet ][@warning \\"-4\\"]))[@ns.iflet ][@warning \\"-4\\"])
 ;;((match foo () with
     | Some (Thing (With { many = Internal [|Components;q|] })) as p ->
         doSomethingWithE e
-    | _ -> ())[@ns.iflet ])
-let a = ((match foo () with | Some x -> x | _ -> 123)[@ns.iflet ])
+    | _ -> ())[@ns.iflet ][@warning \\"-4\\"])
+let a = ((match foo () with | Some x -> x | _ -> 123)
+  [@ns.iflet ][@warning \\"-4\\"])
 let getZ nested =
   ((match nested.origin with
     | Some point -> (((match point.z with | Some z -> z | _ -> 0))
-        [@ns.iflet ])
+        [@ns.iflet ][@warning \\"-4\\"])
     | _ -> 0)
-  [@ns.iflet ])
+  [@ns.iflet ][@warning \\"-4\\"])
 ;;((match foo () with
     | Some (Thing (With { many = Internal [|Components;q|] })) as p ->
         ((((match foo () with
             | Other (Thing (With { many = Internal [|Components;q|] })) as p
                 -> doSomethingElse e
             | _ -> ()))
-         [@ns.iflet ]);
+         [@ns.iflet ][@warning \\"-4\\"]);
          doSomethingWithE e)
     | _ ->
         (((match foo () with
@@ -570,10 +572,13 @@ let getZ nested =
                   | Some (Thing (With { many = Internal [|Components;q|] }))
                       as p -> doSomethingWithE e
                   | _ -> ()))
-               [@ns.iflet ])))
-        [@ns.iflet ]))[@ns.iflet ])
+               [@ns.iflet ][@warning \\"-4\\"])))
+        [@ns.iflet ][@warning \\"-4\\"]))[@ns.iflet ][@warning \\"-4\\"])
 let a =
-  ((if b then ((match foo () with | Some x -> 1 | _ -> 2)[@ns.iflet ]) else 3)
+  ((if b
+    then ((match foo () with | Some x -> 1 | _ -> 2)
+      [@ns.iflet ][@warning \\"-4\\"])
+    else 3)
   [@ns.ternary ])"
 `;