feat: expressions parser

lib/parse/common.ml

@@ -23,6 +23,7 @@ let ws1 = skip Char.is_whitespace *> ws
 let ident s = string s >>| fun x -> Id x
 
 let parens p = char '(' *> ws *> p <* ws <* char ')'
+let spaced p = ws1 *> p <* ws1
 let opt p = option None (p >>| Option.some)
 
 (* ======= Identifiers ======= *)
@@ -48,9 +49,6 @@ let is_keyword = function
   | _ ->
       false
 
-(* XXX: operator keywords? *)
-(* let is_keyword_op _ = false *)
-
 let pident flag =
   let is_first =
     match flag with
@@ -68,18 +66,57 @@ let pident flag =
       | _ ->
           false )
   in
+
   let id = first ^ rest in
   if is_keyword id then fail "keyword" else return (Id id)
 
-let pvalue_id = pident `LowerCase
-
 let pconstr_id =
   let keywords =
     choice
       [ident "true"; ident "false"; ident "()"; ident "[]"; parens (ident "::")]
   in
   pident `Capitalized <|> keywords
 
+(* https://ocaml.org/manual/5.0/lex.html#sss:lex-ops-symbols *)
+
+let is_op_first_char = function
+  | '$' | '&' | '*' | '+' | '-' | '/' | '=' | '<' | '>' | '@' | '^' | '|' | '%'
+    ->
+      true
+  | _ ->
+      false
+
+let is_op_char = function
+  | ch when is_op_first_char ch ->
+      true
+  | '~' | '!' | '?' | ':' | '.' ->
+      true
+  | _ ->
+      false
+
+let is_keyword_op = function "|" | "->" -> true | _ -> false
+
+let pinfix_id ?starts () =
+  let* first =
+    Option.value_map starts ~f:string
+      ~default:(satisfy is_op_first_char >>| Char.to_string)
+  in
+  let* rest = take_while is_op_char in
+
+  let id = first ^ rest in
+  if is_keyword_op id then fail "keyword" else return (Id id)
+
+let pprefix_id =
+  let* first = string "!" in
+  let* rest = take_while is_op_char in
+
+  let id = first ^ rest in
+  if is_keyword_op id then fail "keyword" else return (Id id)
+
+let pvalue_id =
+  let pop_id = pinfix_id () <|> pprefix_id in
+  pident `LowerCase <|> parens pop_id
+
 (* ======= Constants ======= *)
 
 let pconst =
@@ -102,6 +139,36 @@ let pconst =
 
   choice [pint; pchar; pstring]
 
+(* ====== Value bindings ====== *)
+
+(**
+  [let [rec] P1 = E1 and P2 = E2 and ...]
+  [let [rec] ValId1 PArg1 = E1 and P1 = E2 and ...]
+*)
+let plet pexpr ppat =
+  let pbinding =
+    let pfun =
+      let* id = pvalue_id in
+      let* args = ws1 *> sep_by1 ws1 ppat in
+      let* expr = ws *> char '=' *> pexpr in
+      return {pat= PatVar id; expr= ExpFun (args, expr)}
+    in
+
+    let psimple =
+      let* pat = ppat in
+      let* expr = ws *> char '=' *> pexpr in
+      return {pat; expr}
+    in
+
+    pfun <|> psimple
+  in
+
+  let prec_flag =
+    spaced (string "rec") *> return Recursive <|> ws1 *> return Nonrecursive
+  in
+
+  string "let" *> both prec_flag (sep_by1 (spaced (string "and")) pbinding)
+
 (* ======= Operators ======= *)
 
 type ('op, 'oprnd) op_kind =
@@ -117,7 +184,8 @@ let poperators ~(table : 'oprnd op_parse_table) ~(poprnd : 'oprnd t) =
   (* Convert the table to lists of infix/prefix parsers
      with explicit priorities assigned *)
   let _, prefixs, infixs =
-    List.fold table ~init:(0, [], []) ~f:(fun (prio, prefixs, infixs) (Op op) ->
+    List.fold_right table ~init:(0, [], [])
+      ~f:(fun (Op op) (prio, prefixs, infixs) ->
         match op.kind with
         | Prefix {apply} ->
             let pop = op.pop >>| fun x -> (prio, apply x) in

lib/parse/common.mli

@@ -17,12 +17,19 @@ val ws1 : unit t
 val ident : string -> ident t
 
 val parens : 'a t -> 'a t
+val spaced : 'a t -> 'a t
 val opt : 'a t -> 'a option t
 
-(* ======= Identifiers & Constants ======= *)
-val pvalue_id : ident t
+(* ======= Identifiers ======= *)
 val pconstr_id : ident t
+val pvalue_id : ident t
+
+val pinfix_id : ?starts:string -> unit -> ident t
+val pprefix_id : ident t
+
+(* ===== Constants, value bindings ===== *)
 val pconst : constant t
+val plet : expression t -> pattern t -> (rec_flag * value_binding list) t
 
 (* ======= Operators ======= *)
 type ('op, 'oprnd) op_kind =

lib/parse/expr.ml

@@ -0,0 +1,167 @@
+[@@@ocaml.text "/*"]
+
+(** Copyright 2024, Andrei, PavlushaSource *)
+
+(** SPDX-License-Identifier: MIT *)
+
+[@@@ocaml.text "/*"]
+
+(* https://ocaml.org/manual/5.2/expr.html *)
+
+open! Base
+open Angstrom
+open LAst
+
+open Common
+open Pat
+
+let pident = pvalue_id >>| fun id -> ExpIdent id
+let pconst = pconst >>| fun const -> ExpConst const
+let pconstruct = pconstr_id >>| fun id -> ExpConstruct (id, None)
+
+(**
+  [let P1 = E1 and P2 = E2 and ... in E]
+  [let rec ValId1 PArg1 = E1 and P1 = E2 and ... in E]
+*)
+let plet pexpr =
+  let* rec_flag, bindings = plet pexpr ppat in
+  let* expr = spaced (string "in") *> pexpr in
+  return (ExpLet (rec_flag, bindings, expr))
+
+(** [fun P1 ... Pn -> E] *)
+let pfun pexpr =
+  let* args = string "fun" *> ws1 *> sep_by1 ws1 ppat in
+  let* expr = ws *> string "->" *> pexpr in
+  return (ExpFun (args, expr))
+
+let pcases_ pexpr =
+  let pcase =
+    let* left = ppat in
+    let* right = ws *> string "->" *> pexpr in
+    return {left; right}
+  in
+  let pipe (* optional | *) = ws <* char '|' <|> ws1 in
+  pipe *> sep_by1 (ws *> char '|') pcase
+
+(** [match E0 with P1 -> E1 | ... | Pn -> En] *)
+let pmatch pexpr =
+  let* expr = string "match" *> ws1 *> pexpr in
+  let* cases = ws1 *> string "with" *> pcases_ pexpr in
+  return (ExpMatch (expr, cases))
+
+(** [function P1 -> E1 | ... | Pn -> En] *)
+let pfunction pexpr =
+  string "function" *> pcases_ pexpr >>| fun cases -> ExpFunction cases
+
+(** [a; b; c] *)
+let plist pexpr =
+  let nil = ExpConstruct (Id "[]", None) in
+  let list hd tl = ExpConstruct (Id "::", Some (ExpTuple [hd; tl])) in
+
+  let rec to_construct = function
+    | ExpSeq (e1, e2) ->
+        list e1 (to_construct e2)
+    | e ->
+        list e nil
+  in
+  char '[' *> (pexpr >>| to_construct) <* ws <* opt (char ';') <* ws <* char ']'
+
+let poprnd pexpr =
+  ws
+  *> choice
+       [ pident
+       ; pconst
+       ; pconstruct
+       ; plet pexpr
+       ; pfun pexpr
+       ; pmatch pexpr
+       ; pfunction pexpr
+       ; plist pexpr
+       ; parens pexpr ]
+
+(* ======= Operators ======= *)
+
+let table pexpr =
+  let aseq _ lhs rhs = ExpSeq (lhs, rhs) in
+
+  let pif =
+    let* if_ = string "if" *> ws1 *> pexpr in
+    spaced (string "then") *> return if_
+  in
+  let aif if_ then_ = ExpIfThenElse (if_, then_, None) in
+
+  let pif_else =
+    let* if_ = string "if" *> ws1 *> pexpr in
+    let* then_ = spaced (string "then") *> pexpr in
+    spaced (string "else") *> return (if_, then_)
+  in
+  let aif_else (if_, then_) else_ = ExpIfThenElse (if_, then_, Some else_) in
+
+  let atuple _ lhs = function
+    | ExpTuple tl ->
+        ExpTuple (lhs :: tl)
+    | rhs ->
+        ExpTuple [lhs; rhs]
+  in
+
+  let ainfix op_id lhs rhs = ExpApply (ExpApply (ExpIdent op_id, lhs), rhs) in
+
+  let alist _ lhs rhs = ExpConstruct (Id "::", Some (ExpTuple [lhs; rhs])) in
+
+  let aprefix_minus _ rhs = ExpApply (ExpIdent (Id "~-"), rhs) in
+
+  let aapply _ lhs rhs =
+    match lhs with
+    | ExpConstruct (id, None) ->
+        (* constructor application *)
+        ExpConstruct (id, Some rhs)
+    | _ ->
+        (* function application *)
+        ExpApply (lhs, rhs)
+  in
+
+  let aprefix id rhs = ExpApply (ExpIdent id, rhs) in
+
+  [ Op {pop= string ";"; kind= Infix {assoc= `Right; apply= aseq}}
+    (* XXX: severe backtracking when else not found *)
+  ; Op {pop= pif_else; kind= Prefix {apply= aif_else}}
+  ; Op {pop= pif; kind= Prefix {apply= aif}}
+  ; Op {pop= string ","; kind= Infix {assoc= `Right; apply= atuple}}
+  ; Op {pop= ident "||"; kind= Infix {assoc= `Right; apply= ainfix}}
+  ; Op {pop= ident "&&"; kind= Infix {assoc= `Right; apply= ainfix}}
+  ; Op
+      { pop=
+          choice
+            [ pinfix_id ~starts:"=" ()
+            ; pinfix_id ~starts:"<" ()
+            ; pinfix_id ~starts:">" ()
+            ; pinfix_id ~starts:"|" ()
+            ; pinfix_id ~starts:"&" ()
+            ; pinfix_id ~starts:"$" ()
+            ; ident "!=" ]
+      ; kind= Infix {assoc= `Left; apply= ainfix} }
+  ; Op
+      { pop= pinfix_id ~starts:"@" () <|> pinfix_id ~starts:"^" ()
+      ; kind= Infix {assoc= `Right; apply= ainfix} }
+  ; Op {pop= string "::"; kind= Infix {assoc= `Right; apply= alist}}
+  ; Op
+      { pop= pinfix_id ~starts:"+" () <|> pinfix_id ~starts:"-" ()
+      ; kind= Infix {assoc= `Left; apply= ainfix} }
+  ; Op
+      { pop=
+          choice
+            [ pinfix_id ~starts:"*" ()
+            ; pinfix_id ~starts:"/" ()
+            ; pinfix_id ~starts:"%" () ]
+      ; kind= Infix {assoc= `Left; apply= ainfix} }
+  ; Op
+      { pop= pinfix_id ~starts:"**" ()
+      ; kind= Infix {assoc= `Right; apply= ainfix} }
+  ; Op {pop= string "-"; kind= Prefix {apply= aprefix_minus}}
+  ; Op {pop= unit; kind= Infix {assoc= `Left; apply= aapply}}
+  ; Op
+      { pop= pprefix_id <|> string "+" *> return (Id "~+")
+      ; kind= Prefix {apply= aprefix} } ]
+
+let pexpr =
+  fix (fun pexpr -> poperators ~table:(table pexpr) ~poprnd:(poprnd pexpr))