feat(parser): add recursive-descent parser for expressions and patterns
This commit is contained in:
dualfroz committed
1 parent
e13d734741
commit
896f222c0a
1 file changed
+378
@@ -0,0 +1,378 @@
|
||||
module Fml.Core.Parser
|
||||
|
||||
open System
|
||||
open Fml.Core.Ast
|
||||
open Fml.Core.Lexer
|
||||
|
||||
exception ParseError of string
|
||||
|
||||
let private isUpper (s: string) = s.Length > 0 && Char.IsUpper s.[0]
|
||||
|
||||
let parse (tokenList: Token list) : Phrase list =
|
||||
let toks = Array.ofList tokenList
|
||||
let mutable pos = 0
|
||||
let peek () = toks.[pos]
|
||||
let advance () =
|
||||
let t = toks.[pos]
|
||||
pos <- pos + 1
|
||||
t
|
||||
let expect tok =
|
||||
if toks.[pos] = tok then pos <- pos + 1
|
||||
else raise (ParseError(sprintf "expected %A but found %A" tok toks.[pos]))
|
||||
let expectIdent () =
|
||||
match advance () with
|
||||
| TkIdent s -> s
|
||||
| t -> raise (ParseError(sprintf "expected an identifier but found %A" t))
|
||||
let startsAtom () =
|
||||
match peek () with
|
||||
| TkInt _ | TkBool _ | TkStr _ | TkIdent _ | TkUnderscore | TkLParen | TkLBracket | TkLBrace -> true
|
||||
| _ -> false
|
||||
|
||||
let desugarParams ps body =
|
||||
List.foldBack (fun p acc -> Lambda(p, acc)) ps body
|
||||
|
||||
let flattenArg (e: Expr) : Expr list =
|
||||
match e with
|
||||
| Tuple items -> items
|
||||
| _ -> [ e ]
|
||||
|
||||
let makeLet isRec (bindings: (string * Expr) list) body =
|
||||
match bindings with
|
||||
| [ (name, rhs) ] -> Let(isRec, name, rhs, body)
|
||||
| _ -> LetGroup(isRec, bindings, body)
|
||||
|
||||
let rec parseExpr () =
|
||||
match peek () with
|
||||
| TkLet -> parseLetExpr ()
|
||||
| TkFun -> parseFun ()
|
||||
| TkIf -> parseIf ()
|
||||
| TkMatch -> parseMatch ()
|
||||
| _ -> parseOr ()
|
||||
|
||||
and parseParams () =
|
||||
let ps = ResizeArray<string>()
|
||||
let mutable go = true
|
||||
while go do
|
||||
match peek () with
|
||||
| TkIdent s -> advance () |> ignore; ps.Add s
|
||||
| TkUnderscore -> advance () |> ignore; ps.Add "_"
|
||||
| _ -> go <- false
|
||||
List.ofSeq ps
|
||||
|
||||
and parseBinding () =
|
||||
let name = expectIdent ()
|
||||
let ps = parseParams ()
|
||||
expect TkEquals
|
||||
let rhs = parseExpr ()
|
||||
name, desugarParams ps rhs
|
||||
|
||||
and parseBindings () =
|
||||
let bindings = ResizeArray<string * Expr>()
|
||||
bindings.Add(parseBinding ())
|
||||
while peek () = TkKwAnd do
|
||||
advance () |> ignore
|
||||
bindings.Add(parseBinding ())
|
||||
List.ofSeq bindings
|
||||
|
||||
and parseLetExpr () =
|
||||
expect TkLet
|
||||
let isRec = if peek () = TkRec then (advance () |> ignore; true) else false
|
||||
let bindings = parseBindings ()
|
||||
expect TkIn
|
||||
let body = parseExpr ()
|
||||
makeLet isRec bindings body
|
||||
|
||||
and parseFun () =
|
||||
expect TkFun
|
||||
let ps = parseParams ()
|
||||
if List.isEmpty ps then raise (ParseError "fun requires at least one parameter")
|
||||
expect TkArrow
|
||||
let body = parseExpr ()
|
||||
desugarParams ps body
|
||||
|
||||
and parseIf () =
|
||||
expect TkIf
|
||||
let c = parseExpr ()
|
||||
expect TkThen
|
||||
let t = parseExpr ()
|
||||
expect TkElse
|
||||
let e = parseExpr ()
|
||||
If(c, t, e)
|
||||
|
||||
and parseMatch () =
|
||||
expect TkMatch
|
||||
let scrut = parseExpr ()
|
||||
expect TkWith
|
||||
if peek () = TkBar then advance () |> ignore
|
||||
let cases = ResizeArray<Pattern * Expr>()
|
||||
let firstPat = parsePattern ()
|
||||
expect TkArrow
|
||||
let firstBody = parseExpr ()
|
||||
cases.Add(firstPat, firstBody)
|
||||
while peek () = TkBar do
|
||||
advance () |> ignore
|
||||
let p = parsePattern ()
|
||||
expect TkArrow
|
||||
let b = parseExpr ()
|
||||
cases.Add(p, b)
|
||||
Match(scrut, List.ofSeq cases)
|
||||
|
||||
and parseOr () =
|
||||
let mutable left = parseAnd ()
|
||||
while peek () = TkOr do
|
||||
advance () |> ignore
|
||||
left <- BinOp("||", left, parseAnd ())
|
||||
left
|
||||
|
||||
and parseAnd () =
|
||||
let mutable left = parseCompare ()
|
||||
while peek () = TkAnd do
|
||||
advance () |> ignore
|
||||
left <- BinOp("&&", left, parseCompare ())
|
||||
left
|
||||
|
||||
and parseCompare () =
|
||||
let mutable left = parseCons ()
|
||||
let isCmp () =
|
||||
match peek () with
|
||||
| TkEquals | TkNotEq | TkLt | TkLe | TkGt | TkGe -> true
|
||||
| _ -> false
|
||||
while isCmp () do
|
||||
let op =
|
||||
match advance () with
|
||||
| TkEquals -> "="
|
||||
| TkNotEq -> "<>"
|
||||
| TkLt -> "<"
|
||||
| TkLe -> "<="
|
||||
| TkGt -> ">"
|
||||
| TkGe -> ">="
|
||||
| _ -> ""
|
||||
left <- BinOp(op, left, parseCons ())
|
||||
left
|
||||
|
||||
and parseCons () =
|
||||
let left = parseAdd ()
|
||||
if peek () = TkCons then
|
||||
advance () |> ignore
|
||||
Cons(left, parseCons ())
|
||||
else left
|
||||
|
||||
and parseAdd () =
|
||||
let mutable left = parseMul ()
|
||||
let isOp () =
|
||||
match peek () with
|
||||
| TkPlus | TkMinus | TkCaret -> true
|
||||
| _ -> false
|
||||
while isOp () do
|
||||
let op =
|
||||
match advance () with
|
||||
| TkPlus -> "+"
|
||||
| TkMinus -> "-"
|
||||
| TkCaret -> "^"
|
||||
| _ -> ""
|
||||
left <- BinOp(op, left, parseMul ())
|
||||
left
|
||||
|
||||
and parseMul () =
|
||||
let mutable left = parseUnary ()
|
||||
let isOp () =
|
||||
match peek () with
|
||||
| TkStar | TkSlash | TkMod -> true
|
||||
| _ -> false
|
||||
while isOp () do
|
||||
let op =
|
||||
match advance () with
|
||||
| TkStar -> "*"
|
||||
| TkSlash -> "/"
|
||||
| TkMod -> "mod"
|
||||
| _ -> ""
|
||||
left <- BinOp(op, left, parseUnary ())
|
||||
left
|
||||
|
||||
and parseUnary () =
|
||||
if peek () = TkMinus then
|
||||
advance () |> ignore
|
||||
Neg(parseUnary ())
|
||||
else
|
||||
parseApp ()
|
||||
|
||||
and parseApp () =
|
||||
let head = parsePostfix ()
|
||||
match head with
|
||||
| Construct(name, []) when isUpper name ->
|
||||
if startsAtom () then Construct(name, flattenArg (parsePostfix ()))
|
||||
else head
|
||||
| _ ->
|
||||
let mutable f = head
|
||||
while startsAtom () do
|
||||
f <- App(f, parsePostfix ())
|
||||
f
|
||||
|
||||
and parsePostfix () =
|
||||
let mutable base' = parseAtom ()
|
||||
while peek () = TkDot do
|
||||
advance () |> ignore
|
||||
let name = expectIdent ()
|
||||
base' <-
|
||||
match base' with
|
||||
| Construct(modName, []) when isUpper modName -> Var(modName + "." + name)
|
||||
| _ -> Field(base', name)
|
||||
base'
|
||||
|
||||
and parseAtom () =
|
||||
match advance () with
|
||||
| TkInt n -> IntLit n
|
||||
| TkBool b -> BoolLit b
|
||||
| TkStr s -> StringLit s
|
||||
| TkIdent s -> if isUpper s then Construct(s, []) else Var s
|
||||
| TkUnderscore -> Var "_"
|
||||
| TkLBrace -> parseRecordLiteral ()
|
||||
| TkLParen ->
|
||||
if peek () = TkRParen then
|
||||
advance () |> ignore
|
||||
UnitLit
|
||||
else
|
||||
let first = parseExpr ()
|
||||
if peek () = TkComma then
|
||||
let items = ResizeArray<Expr>()
|
||||
items.Add first
|
||||
while peek () = TkComma do
|
||||
advance () |> ignore
|
||||
items.Add(parseExpr ())
|
||||
expect TkRParen
|
||||
Tuple(List.ofSeq items)
|
||||
else
|
||||
expect TkRParen
|
||||
first
|
||||
| TkLBracket ->
|
||||
if peek () = TkRBracket then
|
||||
advance () |> ignore
|
||||
Nil
|
||||
else
|
||||
let items = ResizeArray<Expr>()
|
||||
items.Add(parseExpr ())
|
||||
while peek () = TkSemi do
|
||||
advance () |> ignore
|
||||
items.Add(parseExpr ())
|
||||
expect TkRBracket
|
||||
List.foldBack (fun e acc -> Cons(e, acc)) (List.ofSeq items) Nil
|
||||
| t -> raise (ParseError(sprintf "unexpected token %A" t))
|
||||
|
||||
and parseRecordLiteral () =
|
||||
let fields = ResizeArray<string * Expr>()
|
||||
let parseField () =
|
||||
let name = expectIdent ()
|
||||
expect TkEquals
|
||||
let value = parseExpr ()
|
||||
fields.Add(name, value)
|
||||
parseField ()
|
||||
while peek () = TkSemi do
|
||||
advance () |> ignore
|
||||
if peek () <> TkRBrace then parseField ()
|
||||
expect TkRBrace
|
||||
Record(List.ofSeq fields)
|
||||
|
||||
and parsePattern () = parsePatCons ()
|
||||
|
||||
and parsePatCons () =
|
||||
let left = parsePatApp ()
|
||||
if peek () = TkCons then
|
||||
advance () |> ignore
|
||||
PCons(left, parsePatCons ())
|
||||
else left
|
||||
|
||||
and startsPatAtom () =
|
||||
match peek () with
|
||||
| TkInt _ | TkBool _ | TkStr _ | TkIdent _ | TkUnderscore | TkLParen | TkLBracket | TkLBrace -> true
|
||||
| _ -> false
|
||||
|
||||
and parsePatApp () =
|
||||
match peek () with
|
||||
| TkIdent s when isUpper s ->
|
||||
advance () |> ignore
|
||||
if startsPatAtom () then
|
||||
let arg = parsePatAtom ()
|
||||
let args =
|
||||
match arg with
|
||||
| PTuple ps -> ps
|
||||
| _ -> [ arg ]
|
||||
PConstruct(s, args)
|
||||
else PConstruct(s, [])
|
||||
| _ -> parsePatAtom ()
|
||||
|
||||
and parsePatAtom () =
|
||||
match advance () with
|
||||
| TkInt n -> PInt n
|
||||
| TkBool b -> PBool b
|
||||
| TkStr s -> PString s
|
||||
| TkUnderscore -> PWildcard
|
||||
| TkIdent s -> if isUpper s then PConstruct(s, []) else PVar s
|
||||
| TkLBrace -> parseRecordPattern ()
|
||||
| TkLParen ->
|
||||
if peek () = TkRParen then
|
||||
advance () |> ignore
|
||||
PUnit
|
||||
else
|
||||
let first = parsePattern ()
|
||||
if peek () = TkComma then
|
||||
let items = ResizeArray<Pattern>()
|
||||
items.Add first
|
||||
while peek () = TkComma do
|
||||
advance () |> ignore
|
||||
items.Add(parsePattern ())
|
||||
expect TkRParen
|
||||
PTuple(List.ofSeq items)
|
||||
else
|
||||
expect TkRParen
|
||||
first
|
||||
| TkLBracket ->
|
||||
if peek () = TkRBracket then
|
||||
advance () |> ignore
|
||||
PNil
|
||||
else
|
||||
let items = ResizeArray<Pattern>()
|
||||
items.Add(parsePattern ())
|
||||
while peek () = TkSemi do
|
||||
advance () |> ignore
|
||||
items.Add(parsePattern ())
|
||||
expect TkRBracket
|
||||
List.foldBack (fun p acc -> PCons(p, acc)) (List.ofSeq items) PNil
|
||||
| t -> raise (ParseError(sprintf "unexpected token in pattern %A" t))
|
||||
|
||||
and parseRecordPattern () =
|
||||
let fields = ResizeArray<string * Pattern>()
|
||||
let parseField () =
|
||||
let name = expectIdent ()
|
||||
expect TkEquals
|
||||
let p = parsePattern ()
|
||||
fields.Add(name, p)
|
||||
parseField ()
|
||||
while peek () = TkSemi do
|
||||
advance () |> ignore
|
||||
if peek () <> TkRBrace then parseField ()
|
||||
expect TkRBrace
|
||||
PRecord(List.ofSeq fields)
|
||||
|
||||
let parsePhrase () =
|
||||
match peek () with
|
||||
| TkLet ->
|
||||
expect TkLet
|
||||
let isRec = if peek () = TkRec then (advance () |> ignore; true) else false
|
||||
let bindings = parseBindings ()
|
||||
if peek () = TkIn then
|
||||
advance () |> ignore
|
||||
let body = parseExpr ()
|
||||
PhraseExpr(makeLet isRec bindings body)
|
||||
else
|
||||
PhraseLet(isRec, bindings)
|
||||
| _ -> PhraseExpr(parseExpr ())
|
||||
|
||||
let phrases = ResizeArray<Phrase>()
|
||||
if peek () <> TkEOF then
|
||||
phrases.Add(parsePhrase ())
|
||||
while peek () = TkDoubleSemi do
|
||||
advance () |> ignore
|
||||
if peek () <> TkEOF then phrases.Add(parsePhrase ())
|
||||
if peek () <> TkEOF then
|
||||
raise (ParseError(sprintf "unexpected token %A after phrase" (peek ())))
|
||||
List.ofSeq phrases
|
||||
Reference in new issue
Block a user