diff --git a/src/Fml.Core/Parser.fs b/src/Fml.Core/Parser.fs new file mode 100644 index 0000000..4b36a0f --- /dev/null +++ b/src/Fml.Core/Parser.fs @@ -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() + 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() + 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() + 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() + 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() + 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() + 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() + 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() + 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() + 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() + 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