Support non-empty list patterns and robust multiline lambda application

Author: pchalamet

src/FScript.Language/Ast.fs

@@ -41,6 +41,7 @@ and Expr =
     | EUnit of Span
     | ELiteral of Literal * Span
     | EVar of string * Span
+    | EParen of Expr * Span
     | ELambda of Param * Expr * Span
     | EApply of Expr * Expr * Span
     | EIf of Expr * Expr * Expr * Span
@@ -96,6 +97,7 @@ module Ast =
         | EUnit s -> s
         | ELiteral (_, s) -> s
         | EVar (_, s) -> s
+        | EParen (_, s) -> s
         | ELambda (_, _, s) -> s
         | EApply (_, _, s) -> s
         | EIf (_, _, _, s) -> s

src/FScript.Language/Eval.fs

@@ -150,6 +150,8 @@ module Eval =
             match env |> Map.tryFind name with
             | Some v -> v
             | None -> raise (EvalException { Message = sprintf "Unbound variable '%s'" name; Span = span })
+        | EParen (inner, _) ->
+            evalExpr typeDefs env inner
         | ELambda (param, body, _) -> VClosure (param.Name, body, ref env)
         | EApply (fn, arg, span) ->
             let fVal = evalExpr typeDefs env fn

src/FScript.Language/Parser.fs

@@ -378,7 +378,17 @@ module Parser =
                 if stream.Match(RBracket) then
                     PNil (mkSpanFrom lb.Span lb.Span)
                 else
-                    raise (ParseException { Message = "Only empty list pattern [] supported"; Span = lb.Span })
+                    let first = parsePatternCons()
+                    let elements = ResizeArray<Pattern>()
+                    elements.Add(first)
+                    while stream.Match(Semicolon) do
+                        if stream.Peek().Kind <> RBracket then
+                            elements.Add(parsePatternCons())
+                    let rb = stream.Expect(RBracket, "Expected ']' in list pattern")
+                    let listPattern =
+                        (elements |> Seq.toList, PNil (mkSpanFrom rb.Span rb.Span))
+                        ||> List.foldBack (fun head tail -> PCons(head, tail, mkSpanFrom (Ast.spanOfPattern head) (Ast.spanOfPattern tail)))
+                    listPattern
             | LParen ->
                 let lp = stream.Next()
                 let first = parsePatternCons()
@@ -460,8 +470,8 @@ module Parser =
                         let rp = stream.Expect(RParen, "Expected ')' after tuple expression")
                         ETuple(elements |> Seq.toList, mkSpanFrom lp.Span rp.Span)
                     else
-                        stream.Expect(RParen, "Expected ')' after expression") |> ignore
-                        first
+                        let rp = stream.Expect(RParen, "Expected ')' after expression")
+                        EParen(first, mkSpanFrom lp.Span rp.Span)
             | LBracket ->
                 let lb = stream.Next()
                 if stream.Match(RBracket) then
@@ -935,6 +945,10 @@ module Parser =
                 | Dedent ->
                     stream.Next() |> ignore
                     doneBlock <- true
+                | RParen
+                | RBracket
+                | RBrace ->
+                    doneBlock <- true
                 | EOF -> doneBlock <- true
                 | Let ->
                     statements.Add(parseStmt())
@@ -1042,7 +1056,7 @@ module Parser =
         while not stream.AtEnd do
             match stream.Peek().Kind with
             | EOF -> stream.Next() |> ignore
-            | Dedent -> raise (ParseException { Message = "Unexpected dedent at top level"; Span = stream.Peek().Span })
+            | Dedent -> stream.Next() |> ignore
             | _ ->
                 let stmt = parseStmt()
                 program.Add(stmt)

src/FScript.Language/TypeInfer.fs

@@ -256,6 +256,9 @@ module TypeInfer =
                 let t = instantiate scheme
                 emptySubst, t, asTyped expr t
             | None -> raise (TypeException { Message = sprintf "Unbound variable '%s'" name; Span = span })
+        | EParen (inner, _) ->
+            let s, t, _ = inferExpr typeDefs constructors env inner
+            s, t, asTyped expr t
         | ETypeOf (name, span) ->
             if typeDefs.ContainsKey name then
                 emptySubst, TTypeToken, asTyped expr TTypeToken

tests/FScript.Language.Tests/EvalTests.fs

@@ -96,6 +96,29 @@ type EvalTests () =
         let src = "match [1;2] with\n    | x::xs -> x\n    | [] -> 0"
         Helpers.eval src |> assertInt 1L
 
+    [<Test>]
+    member _.``Evaluates match on non-empty list literal pattern`` () =
+        let src = "match [1] with\n    | [x] -> x\n    | _ -> 0"
+        Helpers.eval src |> assertInt 1L
+
+    [<Test>]
+    member _.``Evaluates match on Some with non-empty list literal pattern`` () =
+        let src = "match Some [1] with\n    | Some [x] -> x\n    | _ -> 0"
+        Helpers.eval src |> assertInt 1L
+
+    [<Test>]
+    member _.``Evaluates multiline map fold with match and cons`` () =
+        let src =
+            "let apply f x = f x\n" +
+            "let f value = apply (fun item ->\n" +
+            "    match item with\n" +
+            "    | \"workspace:*\" -> value :: []\n" +
+            "    | _ -> []) value\n" +
+            "f \"workspace:*\""
+        match Helpers.eval src with
+        | VList [ VString "workspace:*" ] -> ()
+        | _ -> Assert.Fail("Expected [\"workspace:*\"]")
+
     [<Test>]
     member _.``Evaluates option values`` () =
         match Helpers.eval "Some 4" with

tests/FScript.Language.Tests/ParserTests.fs

@@ -131,7 +131,7 @@ type ParserTests () =
     member _.``Parses let expression without in`` () =
         let p = Helpers.parse "let x = (let y = 1\n    y + 1\n)"
         match p.[0] with
-        | SLet (_, _, ELet ("y", _, _, _, _), _, _, _) -> ()
+        | SLet (_, _, EParen (ELet ("y", _, _, _, _), _), _, _, _) -> ()
         | _ -> Assert.Fail("Expected nested let expression")
 
     [<Test>]
@@ -249,6 +249,22 @@ type ParserTests () =
         | SExpr (EMatch (_, cases, _)) -> cases.Length |> should equal 2
         | _ -> Assert.Fail("Expected match")
 
+    [<Test>]
+    member _.``Parses match with non-empty list literal pattern`` () =
+        let src = "match [1] with\n| [x] -> x\n| _ -> 0"
+        let program = Helpers.parse src
+        match program.[0] with
+        | SExpr (EMatch (_, (PCons (_, PNil _, _), _, _) :: _, _)) -> ()
+        | _ -> Assert.Fail("Expected non-empty list pattern")
+
+    [<Test>]
+    member _.``Parses Some with non-empty list literal pattern`` () =
+        let src = "match Some [1] with\n| Some [x] -> x\n| _ -> 0"
+        let program = Helpers.parse src
+        match program.[0] with
+        | SExpr (EMatch (_, (PSome (PCons (_, PNil _, _), _), _, _) :: _, _)) -> ()
+        | _ -> Assert.Fail("Expected Some with non-empty list pattern")
+
     [<Test>]
     member _.``Parses match with option patterns`` () =
         let src = "match Some 1 with\n    | Some x -> x\n    | None -> 0"
@@ -313,6 +329,14 @@ type ParserTests () =
         | SLet ("f", [_], ELet _, false, _, _) -> ()
         | _ -> Assert.Fail("Expected block-desugared let")
 
+    [<Test>]
+    member _.``Parses multiline lambda argument closed by parenthesis on same line`` () =
+        let src = "Map.fold (fun acc key value ->\n    match value with\n    | \"workspace:*\" -> key :: acc\n    | _ -> acc) [] #{ \"a\" = \"workspace:*\" }"
+        let p = Helpers.parse src
+        match p.[0] with
+        | SExpr (EApply (EApply (EApply (EFieldGet (EVar ("Map", _), "fold", _), _, _), _, _), _, _)) -> ()
+        | _ -> Assert.Fail("Expected multiline lambda argument application")
+
     [<Test>]
     member _.``Parses exported top-level let binding`` () =
         let p = Helpers.parse "export let cosine x = x"
@@ -346,7 +370,7 @@ type ParserTests () =
         let src = "(let rec even n = if n = 0 then true else odd (n - 1)\nand odd n = if n = 0 then false else even (n - 1)\neven 4\n)"
         let p = Helpers.parse src
         match p.[0] with
-        | SExpr (ELetRecGroup (bindings, _, _)) -> bindings.Length |> should equal 2
+        | SExpr (EParen (ELetRecGroup (bindings, _, _), _)) -> bindings.Length |> should equal 2
         | _ -> Assert.Fail("Expected recursive let-expression group")
 
     [<Test>]

tests/FScript.Language.Tests/TypeInferenceTests.fs

@@ -230,6 +230,20 @@ type TypeInferenceTests () =
         | TypeInfer.TSExpr te -> te.Type |> should equal TInt
         | _ -> Assert.Fail("Expected expression")
 
+    [<Test>]
+    member _.``Infers match on non-empty list literal pattern`` () =
+        let typed = Helpers.infer "match [1] with\n    | [x] -> x\n    | _ -> 0"
+        match typed |> List.last with
+        | TypeInfer.TSExpr te -> te.Type |> should equal TInt
+        | _ -> Assert.Fail("Expected expression")
+
+    [<Test>]
+    member _.``Infers match on Some with non-empty list literal pattern`` () =
+        let typed = Helpers.infer "match Some [1] with\n    | Some [x] -> x\n    | _ -> 0"
+        match typed |> List.last with
+        | TypeInfer.TSExpr te -> te.Type |> should equal TInt
+        | _ -> Assert.Fail("Expected expression")
+
     [<Test>]
     member _.``Infers match on tuple`` () =
         let typed = Helpers.infer "match (1, true) with\n    | (x, true) -> x\n    | _ -> 0"
@@ -330,6 +344,27 @@ type TypeInferenceTests () =
         let act () = Helpers.infer "let f (x: int) = x + true" |> ignore
         act |> should throw typeof<TypeException>
 
+    [<Test>]
+    member _.``Infers multiline map fold with match and cons`` () =
+        let typed =
+            Helpers.infer
+                "let apply f x = f x\nlet f value = apply (fun item ->\n    match item with\n    | \"workspace:*\" -> value :: []\n    | _ -> []) value\nf"
+        match typed |> List.last with
+        | TypeInfer.TSExpr te ->
+            match te.Type with
+            | TFun (TString, TList TString) -> ()
+            | _ -> Assert.Fail($"Expected string -> string list, got {Types.typeToString te.Type}")
+        | _ -> Assert.Fail("Expected expression")
+
+    [<Test>]
+    member _.``Infers annotated lambda field access inside Option.map`` () =
+        let typed =
+            Helpers.infer
+                "type Package = { name: string }\nlet get_name = fun (value: Package) -> value.name\nget_name"
+        match typed |> List.last with
+        | TypeInfer.TSExpr te -> te.Type |> should equal (TFun (TRecord (Map.ofList [ "name", TString ]), TString))
+        | _ -> Assert.Fail("Expected expression")
+
     [<Test>]
     member _.``Infers typeof as type token`` () =
         let typed = Helpers.infer "type Package = { Name: string }\ntypeof Package"