Skip to content

Commit ecadfd6

Browse files
pchalametpchalamet
committed
feat(language): improve map pattern matching semantics
1 parent d20411c commit ecadfd6

File tree

11 files changed

+226
-67
lines changed

11 files changed

+226
-67
lines changed

‎docs/syntax-and-indentation.md‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -36,6 +36,11 @@ This document describes the concrete syntax accepted by the interpreter and the
3636
- `match expr with | ...`
3737
- case guards: `| pattern when condition -> expr`
3838
- record patterns in cases: `{ Field = pattern; ... }`
39+
- map patterns in cases support keyed lookup and extraction:
40+
- keyed lookup: `{ ["key"] = v }`
41+
- multiple keys: `{ ["a"] = x; ["b"] = y }`
42+
- optional tail capture: `{ ["a"] = x; ..tail }`
43+
- dynamic extraction (preserved): `{ [k] = v; ..tail }`
3944
- union case patterns in cases: `Case` and `Case pattern`
4045
- Records:
4146
- literal `{ Name = "a"; Age = 1 }`

‎samples/map-matching.fss‎

Lines changed: 20 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,20 @@
1+
2+
let values =
3+
{ ["alpha"] = 10
4+
["beta"] = 20
5+
["gamma"] = 30 }
6+
7+
match values with
8+
| { ["alpha"] = v1; ..tail } ->
9+
print $"alpha={v1}; tail={tail}"
10+
| _ -> print "no literal-key match"
11+
12+
match values with
13+
| { ["alpha"] = v1; ["beta"] = v2 } ->
14+
print $"alpha={v1} beta={v2}"
15+
| _ -> print "no two-key match"
16+
17+
match values with
18+
| { [k] = v; ..tail } ->
19+
print $"dynamic extraction: {k} = {v}, tail={tail}"
20+
| _ -> print "no dynamic match"

‎src/FScript.Language/Ast.fs‎

Lines changed: 2 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -33,8 +33,7 @@ and Pattern =
3333
| PCons of Pattern * Pattern * Span
3434
| PTuple of Pattern list * Span
3535
| PRecord of (string * Pattern) list * Span
36-
| PMapEmpty of Span
37-
| PMapCons of Pattern * Pattern * Pattern * Span
36+
| PMap of (Pattern * Pattern) list * Pattern option * Span
3837
| PSome of Pattern * Span
3938
| PNone of Span
4039
| PUnionCase of string option * string * Pattern option * Span
@@ -97,8 +96,7 @@ module Ast =
9796
| PCons (_, _, s) -> s
9897
| PTuple (_, s) -> s
9998
| PRecord (_, s) -> s
100-
| PMapEmpty s -> s
101-
| PMapCons (_, _, _, s) -> s
99+
| PMap (_, _, s) -> s
102100
| PSome (_, s) -> s
103101
| PNone s -> s
104102
| PUnionCase (_, _, _, s) -> s

‎src/FScript.Language/Eval.fs‎

Lines changed: 74 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -82,6 +82,78 @@ module Eval =
8282
| _ -> false
8383

8484
let rec private patternMatch (pat: Pattern) (value: Value) : Env option =
85+
let mergeBindings (left: Env) (right: Env) : Env option =
86+
let mutable ok = true
87+
let mutable merged = left
88+
for KeyValue(k, v) in right do
89+
match merged.TryFind k with
90+
| Some existing when not (valueEquals existing v) ->
91+
ok <- false
92+
| Some _ -> ()
93+
| None -> merged <- Map.add k v merged
94+
if ok then Some merged else None
95+
96+
let rec matchMapClauses (hasExplicitClauses: bool) (clauses: (Pattern * Pattern) list) (tailPattern: Pattern option) (remaining: Map<string, Value>) (envAcc: Env) : Env option =
97+
let applyTail () =
98+
match tailPattern with
99+
| Some tail ->
100+
match patternMatch tail (VStringMap remaining) with
101+
| Some tailEnv -> mergeBindings envAcc tailEnv
102+
| None -> None
103+
| None ->
104+
if hasExplicitClauses || remaining.IsEmpty then Some envAcc else None
105+
106+
match clauses with
107+
| [] -> applyTail ()
108+
| (keyPattern, valuePattern) :: rest ->
109+
match keyPattern with
110+
| PVar (name, _) when not (envAcc.ContainsKey name) ->
111+
if remaining.IsEmpty then None
112+
else
113+
let head = remaining |> Seq.head
114+
let key = head.Key
115+
let value = head.Value
116+
let nextRemaining = remaining.Remove key
117+
match patternMatch keyPattern (VString key), patternMatch valuePattern value with
118+
| Some keyEnv, Some valueEnv ->
119+
match mergeBindings envAcc keyEnv with
120+
| Some merged1 ->
121+
match mergeBindings merged1 valueEnv with
122+
| Some merged2 -> matchMapClauses hasExplicitClauses rest tailPattern nextRemaining merged2
123+
| None -> None
124+
| None -> None
125+
| _ -> None
126+
| PVar (name, _) ->
127+
match envAcc.TryFind name with
128+
| Some (VString targetKey) when remaining.ContainsKey targetKey ->
129+
let value = remaining.[targetKey]
130+
match patternMatch valuePattern value with
131+
| Some valueEnv ->
132+
match mergeBindings envAcc valueEnv with
133+
| Some merged -> matchMapClauses hasExplicitClauses rest tailPattern (remaining.Remove targetKey) merged
134+
| None -> None
135+
| None -> None
136+
| _ -> None
137+
| _ ->
138+
let tryKey (kv: System.Collections.Generic.KeyValuePair<string, Value>) : (string * Env) option =
139+
match patternMatch keyPattern (VString kv.Key) with
140+
| Some keyEnv ->
141+
match mergeBindings envAcc keyEnv with
142+
| Some merged1 ->
143+
match patternMatch valuePattern kv.Value with
144+
| Some valueEnv ->
145+
match mergeBindings merged1 valueEnv with
146+
| Some merged2 -> Some (kv.Key, merged2)
147+
| None -> None
148+
| None -> None
149+
| None -> None
150+
| None -> None
151+
152+
remaining
153+
|> Seq.tryPick tryKey
154+
|> Option.bind (fun (matchedKey, mergedEnv) ->
155+
matchMapClauses hasExplicitClauses rest tailPattern (remaining.Remove matchedKey) mergedEnv)
156+
85157
match pat, value with
86158
| PWildcard _, _ -> Some Map.empty
87159
| PVar (name, _), v -> Some (Map.ofList [ name, v ])
@@ -109,22 +181,8 @@ module Eval =
109181
| Some next -> Some (Map.fold (fun state k v -> Map.add k v state) acc next)
110182
| None -> None
111183
| _ -> None)
112-
| PMapEmpty _, VStringMap values when values.IsEmpty ->
113-
Some Map.empty
114-
| PMapCons (keyPattern, valuePattern, tailPattern, _), VStringMap values when not values.IsEmpty ->
115-
let key, value =
116-
values
117-
|> Seq.head
118-
|> fun kv -> kv.Key, kv.Value
119-
let tail = VStringMap (values.Remove key)
120-
match patternMatch keyPattern (VString key), patternMatch valuePattern value, patternMatch tailPattern tail with
121-
| Some keyEnv, Some valueEnv, Some tailEnv ->
122-
Some
123-
(Map.empty
124-
|> Map.fold (fun acc k v -> Map.add k v acc) keyEnv
125-
|> Map.fold (fun acc k v -> Map.add k v acc) valueEnv
126-
|> Map.fold (fun acc k v -> Map.add k v acc) tailEnv)
127-
| _ -> None
184+
| PMap (clauses, tailPattern, _), VStringMap values ->
185+
matchMapClauses (not clauses.IsEmpty) clauses tailPattern values Map.empty
128186
| PSome (p, _), VOption (Some v) ->
129187
patternMatch p v
130188
| PNone _, VOption None -> Some Map.empty

‎src/FScript.Language/IncludeResolver.fs‎

Lines changed: 7 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -49,9 +49,13 @@ module IncludeResolver =
4949
| PCons (head, tail, _) -> loop (loop acc head) tail
5050
| PTuple (patterns, _) -> patterns |> List.fold loop acc
5151
| PRecord (fields, _) -> fields |> List.fold (fun s (_, p) -> loop s p) acc
52-
| PMapEmpty _ -> acc
53-
| PMapCons (keyPattern, valuePattern, tailPattern, _) ->
54-
loop (loop (loop acc keyPattern) valuePattern) tailPattern
52+
| PMap (clauses, tailPattern, _) ->
53+
let withClauses =
54+
clauses
55+
|> List.fold (fun s (keyPattern, valuePattern) -> loop (loop s keyPattern) valuePattern) acc
56+
match tailPattern with
57+
| Some tail -> loop withClauses tail
58+
| None -> withClauses
5559
| PSome (inner, _) -> loop acc inner
5660
| PUnionCase (_, _, payload, _) ->
5761
match payload with

‎src/FScript.Language/Parser.fs‎

Lines changed: 43 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -477,23 +477,52 @@ module Parser =
477477
let lb = stream.Next()
478478
stream.SkipNewlines()
479479
if stream.Match(RBrace) then
480-
PMapEmpty (mkSpanFrom lb.Span lb.Span)
480+
PMap([], None, mkSpanFrom lb.Span lb.Span)
481481
elif stream.Peek().Kind = LBracket then
482-
stream.Next() |> ignore // '['
483-
let keyPattern = parsePatternCons()
484-
stream.Expect(RBracket, "Expected ']' in map pattern") |> ignore
485-
stream.SkipNewlines()
486-
stream.Expect(Equals, "Expected '=' after map key pattern") |> ignore
487-
let valuePattern = parsePatternCons()
488-
stream.SkipNewlines()
489-
if not (stream.Match(Semicolon)) then
490-
raise (ParseException { Message = "Expected ';' before '..' in map pattern"; Span = stream.Peek().Span })
491-
stream.SkipNewlines()
492-
stream.Expect(RangeDots, "Expected '..' in map pattern tail") |> ignore
493-
let tailPattern = parsePatternCons()
482+
let clauses = ResizeArray<Pattern * Pattern>()
483+
let parseClause () =
484+
stream.Expect(LBracket, "Expected '[' in map pattern key") |> ignore
485+
let keyPattern = parsePatternCons()
486+
stream.Expect(RBracket, "Expected ']' in map pattern key") |> ignore
487+
stream.SkipNewlines()
488+
stream.Expect(Equals, "Expected '=' after map key pattern") |> ignore
489+
let valuePattern = parsePatternCons()
490+
clauses.Add(keyPattern, valuePattern)
491+
492+
parseClause()
494493
stream.SkipNewlines()
494+
495+
let mutable tailPattern : Pattern option = None
496+
let mutable donePattern = false
497+
498+
while not donePattern do
499+
if stream.Match(Semicolon) then
500+
stream.SkipNewlines()
501+
if stream.Peek().Kind = RangeDots then
502+
stream.Next() |> ignore
503+
tailPattern <- Some (parsePatternCons())
504+
stream.SkipNewlines()
505+
donePattern <- true
506+
elif stream.Peek().Kind = LBracket then
507+
parseClause()
508+
stream.SkipNewlines()
509+
elif stream.Peek().Kind = RBrace then
510+
donePattern <- true
511+
else
512+
raise (ParseException { Message = "Expected map pattern clause or '..tail'"; Span = stream.Peek().Span })
513+
elif stream.Peek().Kind = RangeDots then
514+
stream.Next() |> ignore
515+
tailPattern <- Some (parsePatternCons())
516+
stream.SkipNewlines()
517+
donePattern <- true
518+
elif stream.Peek().Kind = LBracket then
519+
parseClause()
520+
stream.SkipNewlines()
521+
else
522+
donePattern <- true
523+
495524
let rb = stream.Expect(RBrace, "Expected '}' in map pattern")
496-
PMapCons(keyPattern, valuePattern, tailPattern, mkSpanFrom lb.Span rb.Span)
525+
PMap(clauses |> Seq.toList, tailPattern, mkSpanFrom lb.Span rb.Span)
497526
else
498527
let fields = ResizeArray<string * Pattern>()
499528
let seen = System.Collections.Generic.HashSet<string>()

‎src/FScript.Language/Stdlib/Map.fss‎

Lines changed: 10 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -13,11 +13,10 @@ let containsKey key values =
1313
let rec add key value values =
1414
match values with
1515
| {} -> { [key] = value }
16+
| { [currentKey] = _; ..tail } when currentKey = key ->
17+
{ [key] = value; ..tail }
1618
| { [currentKey] = currentValue; ..tail } ->
17-
if currentKey = key then
18-
{ [key] = value; ..tail }
19-
else
20-
{ [currentKey] = currentValue; ..(add key value tail) }
19+
{ [currentKey] = currentValue; ..(add key value tail) }
2120

2221
let ofList pairs =
2322
let rec loop remaining acc =
@@ -64,10 +63,10 @@ let iter iterator values =
6463
()
6564
fold folder () values
6665

67-
let remove key values =
68-
let folder acc currentKey value =
69-
if currentKey = key then
70-
acc
71-
else
72-
add currentKey value acc
73-
fold folder {} values
66+
let rec remove key values =
67+
match values with
68+
| {} -> {}
69+
| { [currentKey] = _; ..tail } when currentKey = key ->
70+
tail
71+
| { [currentKey] = currentValue; ..tail } ->
72+
{ [currentKey] = currentValue; ..(remove key tail) }

‎src/FScript.Language/TypeInfer.fs‎

Lines changed: 32 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -215,23 +215,38 @@ module TypeInfer =
215215
let merged = Map.fold (fun acc k v -> Map.add k v acc) envAcc envPart
216216
merged, Map.add name tPart fieldAcc) (Map.empty, Map.empty)
217217
env, TRecord fieldTypes
218-
| PMapEmpty _ ->
219-
let tv = Types.freshVar()
220-
Map.empty, TStringMap tv
221-
| PMapCons (keyPattern, valuePattern, tailPattern, span) ->
222-
let keyEnv, keyType = inferPattern typeDefs constructors keyPattern
223-
let valueEnv, valueType = inferPattern typeDefs constructors valuePattern
224-
let tailEnv, tailType = inferPattern typeDefs constructors tailPattern
225-
let keySubst = unify typeDefs keyType TString span
226-
let tailExpected = TStringMap (applyType keySubst valueType)
227-
let tailSubst = unify typeDefs (applyType keySubst tailType) tailExpected span
228-
let s = compose tailSubst keySubst
229-
let mergedEnv =
230-
keyEnv
231-
|> Map.fold (fun acc k v -> Map.add k v acc) valueEnv
232-
|> Map.fold (fun acc k v -> Map.add k v acc) tailEnv
233-
|> Map.map (fun _ t -> applyType s t)
234-
mergedEnv, applyType s tailExpected
218+
| PMap (clauses, tailPattern, span) ->
219+
let valueType = Types.freshVar()
220+
let mutable sAcc = emptySubst
221+
let mutable envAcc : Map<string, Type> = Map.empty
222+
223+
for (keyPattern, valuePattern) in clauses do
224+
let keyEnv, keyType = inferPattern typeDefs constructors keyPattern
225+
let valueEnv, currentValueType = inferPattern typeDefs constructors valuePattern
226+
227+
let sKey = unify typeDefs (applyType sAcc keyType) TString span
228+
sAcc <- compose sKey sAcc
229+
230+
let sValue = unify typeDefs (applyType sAcc currentValueType) (applyType sAcc valueType) span
231+
sAcc <- compose sValue sAcc
232+
233+
let mergedClauseEnv =
234+
keyEnv
235+
|> Map.fold (fun acc k v -> Map.add k v acc) valueEnv
236+
|> Map.map (fun _ t -> applyType sAcc t)
237+
238+
envAcc <- mergedClauseEnv |> Map.fold (fun acc k v -> Map.add k v acc) envAcc
239+
240+
match tailPattern with
241+
| Some tail ->
242+
let tailEnv, tailType = inferPattern typeDefs constructors tail
243+
let expectedTailType = TStringMap (applyType sAcc valueType)
244+
let sTail = unify typeDefs (applyType sAcc tailType) expectedTailType span
245+
sAcc <- compose sTail sAcc
246+
envAcc <- tailEnv |> Map.map (fun _ t -> applyType sAcc t) |> Map.fold (fun acc k v -> Map.add k v acc) envAcc
247+
| None -> ()
248+
249+
envAcc |> Map.map (fun _ t -> applyType sAcc t), TStringMap (applyType sAcc valueType)
235250
| PSome (p, _) ->
236251
let env, t = inferPattern typeDefs constructors p
237252
env, TOption t

‎tests/FScript.Language.Tests/EvalTests.fs‎

Lines changed: 15 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -191,6 +191,21 @@ type EvalTests () =
191191
tail.ContainsKey "b" |> should equal true
192192
| _ -> Assert.Fail("Expected map cons pattern to expose head and tail")
193193

194+
[<Test>]
195+
member _.``Evaluates match on map literal key with tail`` () =
196+
let src = "let values = { [\"toto\"] = 42; [\"titi\"] = 666; [\"tata\"] = 123 }\nmatch values with\n| { [\"toto\"] = v1; ..tail } -> v1\n| _ -> 0"
197+
Helpers.eval src |> assertInt 42L
198+
199+
[<Test>]
200+
member _.``Evaluates match on map two literal keys with tail`` () =
201+
let src = "let values = { [\"toto\"] = 42; [\"titi\"] = 666; [\"tata\"] = 123 }\nmatch values with\n| { [\"toto\"] = v1; [\"titi\"] = v2; ..tail } -> v1 + v2\n| _ -> 0"
202+
Helpers.eval src |> assertInt 708L
203+
204+
[<Test>]
205+
member _.``Evaluates match on map two literal keys without tail`` () =
206+
let src = "let values = { [\"toto\"] = 42; [\"titi\"] = 666; [\"tata\"] = 123 }\nmatch values with\n| { [\"toto\"] = v1; [\"titi\"] = v2 } -> v1 + v2\n| _ -> 0"
207+
Helpers.eval src |> assertInt 708L
208+
194209
[<Test>]
195210
member _.``Evaluates match with map guard for removal`` () =
196211
let src =

‎tests/FScript.Language.Tests/ParserTests.fs‎

Lines changed: 9 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -330,16 +330,23 @@ type ParserTests () =
330330
member _.``Parses match with empty map pattern`` () =
331331
let p = Helpers.parse "match {} with\n | {} -> 0\n | _ -> 1"
332332
match p.[0] with
333-
| SExpr (EMatch (_, (PMapEmpty _, _, _, _) :: _, _)) -> ()
333+
| SExpr (EMatch (_, (PMap ([], None, _), _, _, _) :: _, _)) -> ()
334334
| _ -> Assert.Fail("Expected empty map pattern")
335335

336336
[<Test>]
337337
member _.``Parses match with map cons pattern`` () =
338338
let p = Helpers.parse "match { [\"a\"] = 1 } with\n | { [k] = v; ..tail } -> v\n | {} -> 0"
339339
match p.[0] with
340-
| SExpr (EMatch (_, (PMapCons (_, _, _, _), _, _, _) :: _, _)) -> ()
340+
| SExpr (EMatch (_, (PMap ([_], Some _, _), _, _, _) :: _, _)) -> ()
341341
| _ -> Assert.Fail("Expected map cons pattern")
342342

343+
[<Test>]
344+
member _.``Parses match with map multi-key pattern without tail`` () =
345+
let p = Helpers.parse "match { [\"a\"] = 1; [\"b\"] = 2 } with\n | { [\"a\"] = x; [\"b\"] = y } -> x\n | _ -> 0"
346+
match p.[0] with
347+
| SExpr (EMatch (_, (PMap ([_; _], None, _), _, _, _) :: _, _)) -> ()
348+
| _ -> Assert.Fail("Expected two-key map pattern without tail")
349+
343350
[<Test>]
344351
member _.``Parses match case guard`` () =
345352
let p = Helpers.parse "match [1] with\n | x::xs when x > 0 -> x\n | _ -> 0"

0 commit comments

Comments
 (0)