opa_parser.trx

(*
    Copyright © 2011 MLstate

    This file is part of OPA.

    OPA is free software: you can redistribute it and/or modify it under the
    terms of the GNU Affero General Public License, version 3, as published by
    the Free Software Foundation.

    OPA is distributed in the hope that it will be useful, but WITHOUT ANY
    WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
    FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
    more details.

    You should have received a copy of the GNU Affero General Public License
    along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
(**
   The general OPA parser, with HMX.

   @TODO: Rule [deco] should return the correct line/char number,
   which requires either advanced TRX hackery or a preliminary phase
   to associate to each file a mapping from char number to line/column number.
*)

read opa_lexer.trx
read parser_path.trx
read string_expr.trx
read action.trx
read xml.trx
read css.trx
read trx.trx
read xml_parser.trx

%%imperative-errors = true
%%opt-errors = true

{{
   open SurfaceAst
   open Parser_utils

   module SA = SurfaceAst

   (* TO MOVE TO PARSER UTILS *)
   type ('a,'b) block_element = Bindings of bool * 'a list | Expr of 'b

}}

(**
   {6 Entry points}
*)
;main <- init declarations:d {{ d }}
;+main_eoi : {(SurfaceAst.nonuid, SurfaceAst.parsing_directive) SurfaceAst.code} <- init declarations:d !. {{ d }}
;+expr_eoi : {(SurfaceAst.nonuid, SurfaceAst.parsing_directive) SurfaceAst.expr} <- init expr:e spacing !. {{ e }}
;+ty_eoi : {SurfaceAst.nonuid SurfaceAst.ty} <- init typ:t spacing !. {{ t }}

(**
   {6 Initialization}
*)

init <- _succeed {{ Parser_utils.filename := _filename }}




(* ******************************************************************)
(* ******************************************************************)
(* ******************************************************************)
(**
   {6 Declarations}
*)

declarations <- spacing (=list0(declaration,semic?)):l semic? spacing
  {{ List.flatten l }}

/** Declaration **/
declaration <- (=deco(just_declaration)):p
  {{
    let (l,label) = p in
    List.map (fun x -> (x, copy_label label)) l
  }}

just_declaration <-
  / (_succeed {{ clear_hints () }}) _fail {{ assert false }}
  / declaration_package
  / declaration_database
  / declaration_type
  / declaration_binding
  / declaration_binding_rec
  / declaration_css
  / declaration_do
  / (&. {{ print_hints () }}) _fail {{ assert false }}

declaration_binding <-
  declaration_directives:dirs spacing
  (binding_pattern):b
  {{
    let bindings = [b] in
    let bindings = declaration_directive dirs bindings in
    [NewVal (bindings,false)]
  }}

declaration_binding_rec <-
  declaration_directives:dirs Opa_lexer.REC binding_pattern_simple_rec:b
  {{
    let bindings = declaration_directive dirs [b] in
    [NewVal (bindings,true)]
  }}

declaration_do <- expr:e
  {{
    let e = magic_do e in
    let p = (PatAny, nlabel e) in
    [NewVal ([(p,e)],false) ]
  }}

declaration_css <- Css.css:d {{ [d] }}




(* ******************************************************************)
(* ******************************************************************)
(* ******************************************************************)
(**
   {6 Package}
*)
/** Package declaration **/
declaration_package <-
  / (=Opa_lexer.exact_ident("package")) package_identifier:name
    {{ [Package (`declaration, name)] }}
  / (=Opa_lexer.exact_ident("import-plugin")) package_expr_list:s
    {{ [Package (`import_plugin, s)] }}
  / (=Opa_lexer.exact_ident("import")) package_expr_list:s
    {{ [Package (`import, s)] }}

/** package **/
package_identifier <- spacing ([a-zA-Z0-9_.\-]+ $_):s {{ s }}

/** package expression **/
package_expr <- spacing package_expr_no_spacing+:l
  {{ String.concat "" l }}

package_expr_no_spacing <-
  / [a-zA-Z0-9_.\-*]+ $_
  / "{" package_expr_list:s rbrace {{ s }}

package_expr_list <- (=list1(package_expr,comma)):l
  {{ Base.String.sconcat ~left:"{" ~right:"}" "," l }}




(* ******************************************************************)
(* ******************************************************************)
(* ******************************************************************)
(**
   {6 Types}
*)

(**
   {7 Types declaration}
*)
/** Type declaration **/
declaration_type <- type_directives:dirs Opa_lexer.TYPE (=list1((=deco(type_binding)),Opa_lexer.AND)):typedefs
  {{
      let ty_def_options, visibility_dirs = dirs in
       (* First, update the visibility of each individual defined type with the
          visibility directives that are global here for all types
          and-defined. *)
       let updated_typedefs =
         List.map
           (fun (ty_def, pos) ->
              (*
                merging the options between the global (before the type keyword)
                and the local options, in case of several definitions
              *)
              let ty_def_options =
                let global = ty_def_options in
                let local = ty_def.SurfaceAst.ty_def_options in
                Parser_utils.merge_type_def_options ~global ~local
              in
              let updated_visibility =
                Parser_utils.merge_type_def_visibility
                  (ty_def.SurfaceAst.ty_def_visibility :: visibility_dirs) pos
              in
              ({ ty_def with SurfaceAst.
                   ty_def_options ;
                   ty_def_visibility = updated_visibility ;
               },
               pos))
           typedefs in
       [NewType updated_typedefs]
  }}

/** Directive of type declaration **/
type_directives <-
  / ("@" !strict_spacing deco_ml_identifier_nosp:v spacing {{ undecorate v }})*:list
    {|
      Return.set_checkpoint_none (
        fun label ->
          let parse_error () = Return.return label () in
          let rec fold (ty_def_options, visibility_dirs) = function
            | "abstract" ->
                let visibility_dirs = SurfaceAst.TDV_abstract :: visibility_dirs in
                ty_def_options, visibility_dirs
            | "private" ->
                let visibility_dirs = SurfaceAst.TDV_private :: visibility_dirs in
                ty_def_options, visibility_dirs
            | "opacapi" ->
                let ty_def_options =
                  { ty_def_options with QmlAst.
                      opacapi = true ;
                  } in
                ty_def_options, visibility_dirs
            | _ -> parse_error ()
          in
          let ty_def_options = QmlAst.ty_def_options in
          List.fold_left fold (ty_def_options, []) list
      )
    |}

type_binding <-
  / type_const:s {{ error_redefinition_basic_type s }}
  / !external type_directives:dirs type_identifier:i (lpar (=list1(just_flatvar,comma)):l rpar {{l}})?:o assign typ:t
  {{
     let _,loc = t in
     let l = Option.default [] o in
     let ty_def_options, visibility_dirs = dirs in
     (* Record the visibility of the type definition. However, since the parser
        can't know yet which package it is processing, we delay the
        determination of the package to later. For the moment, it is just
        sufficient to know if the definition is public, private or abstract.
        Note that the visibility set in the definition is the one attached to
        the type individually defined at this point. If some directives are
        set outside for the bunch of types defined in the global type
        definition, they will be taken into account (and hence modify the
        visibility of the current type) afterwards. *)
     let visibility = Parser_utils.merge_type_def_visibility visibility_dirs loc in
     {
       SurfaceAst.ty_def_options ;
       SurfaceAst.ty_def_visibility = visibility ;
       SurfaceAst.ty_def_name = Typeident i ;
       SurfaceAst.ty_def_params = l ;
       SurfaceAst.ty_def_body = t ;
     } : string typedef_node
   }}

let type_maybe rule = (=backtrack(typ:t Opa_lexer.whitespace {{t}}, rule))

(**
   {7 Type constants}
*)

;/** type constant **/
type_const = deco just_type_const;
just_type_const <-  (=exact_ident("int"))    {{TypeConst TyInt}}
                  / (=exact_ident("float"))  {{TypeConst TyFloat}}
                  / (=exact_ident("string")) {{TypeConst TyString}}

(**
   {7 Type variables}
*)

;/** type variable **/
typevar = deco just_typevar;
just_typevar <- quote ml_identifier:i {{ (i:nonuid) }}
              / Opa_lexer.UNDERSCORE {{ fresh_variable () }}

(*
  Use production [implicit_row_variable] to parse variables which
  only appear as [...] in the concrete syntax.

  e.g. [ {hd:int;...} -> int] *)

;implicit_row_variable = deco just_implicit_row_variable;
just_implicit_row_variable <- (=exact_symbol("...")) {{ Rowvar (fresh_variable ()) }}
                            / just_rowvar:r {{ r }}
;rowvar = deco just_rowvar;
just_rowvar <- just_typevar:v {{ Rowvar v }}

;colvar = deco just_colvar;
just_colvar <- just_typevar:v {{ Colvar v }}

;flatvar= deco just_flatvar;
just_flatvar<- just_typevar:v {{ Flatvar v }}

(**
   {7 Record types}
   Including syntactic sugar for tuple types
   The syntax for tuple types is the same as the one for expressions and patterns
*)

;/** record type **/
type_record = deco just_type_record
just_type_record <-
     tilda:tilda lbrace just_fields:f just_final_row_variable?:rv spacing (comma spacing)? rbrace
     {{ TyRow (default_value_in_type_record tilda f, rv)}}
   / tilda lbrace just_implicit_row_variable?:rv spacing comma? rbrace {{TyRow ([],  rv)}}

;/** Module type **/
type_module_no_keyword <-
  "{" (=list0(module_field,separator)):l spacing (comma spacing)? "}"
  {{ TypeModule l }}

type_module <-
  / Opa_lexer.MODULE spacing type_module_no_keyword:t
    {{ t }}
  / Opa_lexer.MODULE spacing (=deco(type_arguments)):args spacing (=deco(type_module_no_keyword)):t
    {{
      let args, label = args in
      arrow args t label
    }}

;/** tuple type **/
type_tuple <- lpar (=list1(typ,comma)):types comma? rpar {{ TypeNamed (Typeident(tuple_string types),types) }}

(**
   {8 Regular records}
*)
/** record type fields **/
just_fields = list1(just_field,type_separator);

type_separator <- comma

module_field <-
  pos:p typ:ty spacing field_name:field
  (=deco_option(lpar list_types_comma:args rpar {{args}})):args
  {{
    (
      field,
      match args with
      | (None, _) -> ty
      | (Some args, label) -> (arrow args ty label, p)
    )
  }}
record_field <- typ:ty spacing field_name:f  {{ (f,ty) }}
just_field <- (module_field / record_field):v     {{ let (f,ty) = v in (f, `value ty) }}
            / tilda:tilda (=deco(field_name)):f  {{ let ty =
                                                      if tilda then
                                                        `value (typenamed (undecorate f) [] (label f))
                                                      else
                                                        `novalue (f) in
                                                    (undecorate f, ty) }}
field_name  <- ml_identifier

just_final_row_variable   <- comma? just_implicit_row_variable:rv {{ rv }}

(**
   {7 Type instances}
*)
/** type arguments **/
list_types_comma <- (=list0(typ,comma))

type_arguments <- Opa_lexer.lpar_nosp list_types_comma:l rpar {{l}}
                / !"(" {{ [] }}


;type_instance = deco just_type_instance;
just_type_instance <- !forall !external !just_type_const type_identifier_nosp:i type_arguments:t {{(Typeident i,t)}}

(**
   {7 General types}

   By order of decreasing priority, we have
   - arrow
   - sums
*)

/** type **/
typ = deco just_typ;
just_typ <-
  / (=deco((=list0(type_without_arrow,comma)))):p rarrow type_without_arrow:last
    {{
           let l,pos = p in
           arrow l last pos }}
  / type_without_arrow:t {{ undecorate t }}

type_without_arrow = deco(just_type_without_arrow)
just_type_without_arrow <- type_sum
                          / just_type_without_sum

type_sum <- (=infix(Opa_lexer.or))? (=list1(type_sum_element,(=infix(Opa_lexer.or)))):l end_of_type_sum:o
            {{ match l,o with
                 | [h], None ->
                     ( match undecorate h with
                         | SumRecord r -> TypeRecord r
                         | SumName t -> TypeNamed t
                         | _ -> assert false
                     )
                 | _,_ -> TypeSumSugar (l @ Option.to_list o)
             }}
/** sum type element **/
type_sum_element = deco just_type_sum_element;
just_type_sum_element <- just_type_record:r {{ SumRecord r }}
                       / just_type_instance:t  {{ SumName t }}
end_of_type_sum <- Opa_lexer.or? end_of_type_sum_var?:f {{ f }}
end_of_type_sum_var <- typevar:f {{ unc2 colvar f }}
                     / implicit_col_variable:f {{ unc2 colvar f }}
implicit_col_variable = deco just_implicit_col_variable;
just_implicit_col_variable <- (=exact_symbol("...")) {{ fresh_variable () }}

;type_without_sum = deco just_type_without_sum;
just_type_without_sum <- just_type_const:t {{ t }}
                       / just_flatvar:t {{ TypeVar t }}
                       / external {{ TypeExternal }}
                       / lpar just_typ:t rpar {{ t }}
                       / type_tuple
                       / forall (lpar (=list1(just_flatvar,comma)):l rpar {{l}}):typevars (=exact_symbol(".")) typ:t {{ TypeForall(typevars, t) }}
                       / type_module

external <- (=exact_ident("external"))
forall <- (=exact_ident("forall"))





(* ******************************************************************)
(* ******************************************************************)
(* ******************************************************************)
(**
  {6 Database}
*)
/** file path **/
database_file_path <- [ a-zA-Z0-9-._~]* '/' [ a-zA-Z0-9-._/~]* $_

/** network hostname (or IPv4 address) **/
database_network_hostname <- [a-zA-Z0-9-.]+ $_

/** colon and network server port **/
database_network_port <- Opa_lexer.colon_nosp Opa_lexer.int:p {{ p }}

/** database declaration **/
declaration_database <-
  / Opa_lexer.DATABASE database_pathdef:def
    {{ List.map (function e -> NewDbDef e) def }}
  / Opa_lexer.DATABASE spacing (ml_identifier:id spacing db_options?:opt {{id, opt}})?:decl
             spacing database_body:body
    {{
       let decl_ = match decl with
       | None -> []
       | Some (id, opt) ->
           let opt = match opt with
           | None -> []
           | Some opt -> opt in
           [Database (id, [], opt)]
       in
       let bodymap =
         let construct e = NewDbDef e in
         match decl with
         | None -> construct
         | Some (id, _) ->
             let prefix p = QmlAst.Db.Decl_fld id :: p in
             function e ->
               construct
                 (match e with
                    | QmlAst.Db.Db_TypeDecl (p, a) -> QmlAst.Db.Db_TypeDecl (prefix p, a)
                    | QmlAst.Db.Db_Default (p, a) -> QmlAst.Db.Db_Default (prefix p, a)
                    | QmlAst.Db.Db_Alias (p, a) -> QmlAst.Db.Db_Alias (prefix p, a)
                    | QmlAst.Db.Db_Constraint (p, a) -> QmlAst.Db.Db_Constraint (prefix p, a)
                    | QmlAst.Db.Db_Virtual (p, a) -> QmlAst.Db.Db_Virtual (prefix p, a)
                 )
       in
       decl_ @ List.map bodymap body
    }}

database_body <- database_block

database_block <- lbrace spacing (=list1(database_pathdef, separator)):l separator? spacing rbrace
  {{List.flatten l}}

/** database path declaration **/
database_pathdef <-
  / typ:t Parser_path.pathdef_type:l (assign expr:e{{e}})?:o
    {{
       let dec = [QmlAst.Db.Db_TypeDecl(l, t)] in
       match o with
       | None -> dec
       | Some e -> QmlAst.Db.Db_Default(l, e) :: dec
     }}
  / Parser_path.pathdef:l assign expr:e
    {{ [QmlAst.Db.Db_Default(l, e)] }}
  / (Parser_path.pathdef / (=exact_ident("/")) {{ [] }}):l (=exact_ident("alias")) Parser_path.pathdef:l2
    {{ [QmlAst.Db.Db_Alias(l, l2)] }}
  / Parser_path.pathdef:l db_constraint:c
    {{ [QmlAst.Db.Db_Constraint(l, c)] }}

/** database constraint **/
db_constraint <-
  / (=exact_ident("full")) {{ QmlAst.Db.C_Private }}

/** database virtual path **/
db_virtual <-
  / (=exact_ident(":=")) expr:e {{ e }}

/** database options **/
db_options <-
  / "@" "local" Opa_lexer.lpar_nosp spacing '"' database_file_path:s '"' rpar {{ [`engine (`db3 (Some s))] }}
  / "@" "local" {{ [`engine (`db3 None)] }}
  / "@" "light" Opa_lexer.lpar_nosp spacing '"' database_file_path:s '"' rpar {{ [`engine (`db3light (Some s))] }}
  / "@" "light" {{ [`engine (`db3light None)] }}
  / "@" "meta" {{ [`engine (`meta)] }}
  / "@" "shared" Opa_lexer.lpar_nosp spacing '"' database_network_hostname?:h database_network_port?:p '"' rpar {{ [`engine (`client (h, p))] }}
  / "@" "shared" {{ [`engine (`client (None, None))] }}




(* ******************************************************************)
(* ******************************************************************)
(* ******************************************************************)
(**
   {6 Bindings}
   Bindings or assimilated (like do)
*)
binding_pattern <-
  / binding_pattern_simple
  / binding_pattern_lambda
  / binding_pattern_module

binding_pattern_simple <-
  'var'? spacing pattern:p assign expr:e {{ (p,e) }}

binding_simple <-
  (=type_maybe(deco_ml_identifier:i assign expr:e
    {{ function t -> (i,may_coerce_expr e t) }}
  ))

binding_pattern_lambda <- binding_lambda:b {{binding_to_pattern_binding b }}

binding_lambda <- lambda_with_name:lwn {{ lwn }}

binding_pattern_module <- binding_module:b {{binding_to_pattern_binding b }}

binding_module <-
  (=type_maybe(Opa_lexer.MODULE spacing deco_ml_identifier_nosp:ident (=deco(module_no_keyword)):m
  {{ function t -> (ident, may_coerce_expr m t) }}))

binding_pattern_simple_rec <- binding_pattern_simple:b
  {{
    let (i, e) = b in
    (i, ((Directive (`recval, [e], [])), snd e))
  }}

binding_pattern_rec <-
  / binding_pattern_module
  / binding_pattern_simple_rec
  / binding_pattern_lambda

binding_ident <-
  / binding_lambda
  / binding_simple
  / binding_module

binding <-
  / Opa_lexer.REC spacing (=list1(binding_pattern_rec, Opa_lexer.AND)):binds expr:expr
    {{
      let binds = List.concat_map pat_in_to_simple_bindings binds in
      LetIn (true, binds, expr)
    }}
  / (=list1(binding_pattern, Opa_lexer.AND)):binds expr:expr
    {{
      let binds = List.concat_map pat_in_to_simple_bindings binds in
      LetIn (true, binds, expr)
    }}




(* ******************************************************************)
(* ******************************************************************)
(* ******************************************************************)
(**
   {6 Patterns}
*)

tilda <- (spacing "~")?:o {{ Option.is_some o }}

(**
  {7 Patterns}
  A pattern is a basic pattern, with optionally a 'as' and a coerce around it
*)
/** Pattern **/
pattern = deco just_pattern

just_pattern <-
  (=type_maybe((=deco(pattern_as)):p
  {{
    function
      | None -> undecorate p
      | Some t -> PatCoerce (p, t)
  }}))

pattern_as <- (=deco(pattern_simple)):p (Opa_lexer.AS ml_identifier:v {{ v }})?:a
  {{
    match a with
    | None -> undecorate p
    | Some a -> PatAs (p,{ident=a;directives=[]})
  }}

pattern_simple <-
  / pattern_any
  / pattern_var
  / pattern_const
  / pattern_record
  / pattern_tuple
  / pattern_list

pattern_any <-
  / Opa_lexer.UNDERSCORE {{ PatAny }}
  / Opa_lexer.DEFAULT {{ PatAny }}

pattern_var <- ml_identifier_nosp:i !"("
  {{ PatVar {ident=i;directives=[]} }}

pattern_const <- const:c
  {{ PatConst c }}

pattern_record <-
  / tilda lbrace rbrace
    {{ PatRecord ([], `closed) }}
  / tilda:tilda lbrace (=list0(pattern_field,(spacing comma))):fields comma? pattern_row?:row rbrace
    {{
       let l = default_value_in_pat_record tilda fields in
       match row with
       | None -> undecorate (record_pat l)
       | Some () -> PatRecord (encode_record l, `open_)
     }}

pattern_row <- (=exact_symbol("...")) {{ () }}

pattern_field <-
  (=type_maybe(
     tilda:tilda deco_ml_identifier:i (colon pattern:p {{ p }})?:p
     {{ function t ->
          let ident,label = i in
          let p =
            match p,tilda with
            | None,true -> `value (var_to_patvar i)
            | None,false -> `novalue i
            | Some p,true -> `value (PatAs (p,{ident=ident;directives=[]}),label)
          | Some p,false -> `value p in
          (ident, p, t)
     }}
  ))

(**
   {7 Tuples pattern}
   Tuple pattern
   (a,b,c,...)
   (a,) is a 1-uple, () doesn't exists
   it may contain [...] (like (a,...) but [(...)] and [(,...)] are not valid
 *)
/** tuple pattern or parenthized pattern **/
pattern_tuple <- lpar pattern_tuple_inside:p rpar {{ p }}

pattern_tuple_inside <- (=list1(pattern,comma)):l pattern_tuple_end:e
    {{ match l,e with
         | [p], `nothing -> undecorate p
         | _ , _ -> undecorate (coerce_name_pat (tuple_pat l) (tuple_string l))
     }}

pattern_tuple_end <- comma {{ `tuple1 }}
               / _succeed {{ `nothing }}

(**
   {7 List patterns}
*)
pattern_list <-
  / lbracket (=list0(pattern,comma)):l pos:p comma? (Opa_lexer.BAR pattern:p {{p}})?:tl rbracket
  {{ undecorate (list_pat_of_pat_list ?tl l p) }}





(* ******************************************************************)
(* ******************************************************************)
(* ******************************************************************)
(**
   {6 Block expression}
   A block expression is curly braces :
   - A list of bindings and expressions separated by ; or \n.
   - A final expression

   {
     (binding / expr)*
     expr
   }
*)
/** Block expression **/
block <- lbrace block_inner:e rbrace
  {{ e }}

block_inner <- (=list1((=deco(block_elmt)), block_separator)):l block_separator?
  {{
    (*TODO : Move into parser utils *)
    match List.rev l with
    | [] -> assert false
    |(expr,a)::binds_or_exprs ->
    let returned_expr = match expr with
      | Bindings _  -> Parser_utils.error_bad_compare (union_annot a a) (* TODO use a better error, not adapted to function def *)
      | Expr e -> (e,a)
    in
    undecorate(
    List.fold_left (fun (expr:(string, SurfaceAst.parsing_directive) SurfaceAst.expr) (elmt,a) ->
      let exprN = match elmt with
        | Expr e                       -> bind_in_to_expr_in []   ((PatAny,a),magic_do (e,a)) expr
        | Bindings(false,[dirs,pat,e]) -> bind_in_to_expr_in dirs (pat,e) expr
        | Bindings(true,_)-> assert false (*
          let l = List.concat_map pat_in_to_simple_bindings l in
          let l = declaration_directive dirs l in
          LetIn (true, l, e)
        *) (* TODO REMOVE LETIN WHEN DONE *)
        | Bindings(_,[]) -> assert false
        | Bindings(false,_) -> assert false
      in ((exprN,a):(string, SurfaceAst.parsing_directive) SurfaceAst.expr)
    ) returned_expr binds_or_exprs
   )
  }}

block_separator <- separator

block_elmt <- block_binding / block_result

/** Block result **/
block_result <- expr:e {{ Expr (undecorate e) }}

/** Block binding **/
block_binding <- binding_pattern:b
  {{
    let (pattern, expr) = b in
    Bindings(false, [[], pattern, expr])
  }}




(* ******************************************************************)
(* ******************************************************************)
(* ******************************************************************)
(**
   {6 Expressions}

   Expressions are divided into differents to take care of operators priorities
*)

/** expression **/
expr <- expr_op:e {{e}}


(* ******************************************************************)
(**
   {7 Operators }
*)
(* no spaces are parsed around operators on purpose
 * it is because spaces matters to see if the operators is actually infix
 * the infix rule takes care of them *)
let ident_careful_deco rule = (=careful_deco(rule)):t {{let (i,label) = t in (Ident i, label)}}
;OpCont <- !"/*" [.+\-^*/<>=@|&!]
(* Operatort beginning with ('|' [&!.]) are forbidden because parser syntax *)
;OpPipe = ident_careful_deco(!"||" "|" ![&!.] OpCont+ $_ / "@" OpCont* $_)
;OpOr   = ident_careful_deco("||" OpCont* $_ / "?" OpCont* $_)
;OpAnd  = ident_careful_deco("&" OpCont* $_)
;OpComp = ident_careful_deco(  ( "=" OpCont+ $_
                    / ( ">" / "<=" / ">=" /  "!=" / (!"<-" !Xml.xhtml "<":s {{s}}) ) OpCont* $_))
;OpAdd  = ident_careful_deco(!"->" [+\-^] OpCont*  $_)
;OpMul  = ident_careful_deco("*" OpCont* $_  / !"/*" !"//" "/" OpCont* $_)
;NegOp  = ident_careful_deco( "-." !OpCont {{ Opacapi.unary_minus_dot }}
                            / "-" !OpCont  {{ Opacapi.unary_minus }})

(* would probably be more efficient to have list1sleft and list1sright *)
expr_op <- expr_op1
/** expression `|' `@' **/
expr_op1 <- (=list1s(expr_op2,OpPipe)):v  {{ apply_operators `left  v }}
/** expression `||' `?' **/
expr_op2 <- (=list1s(expr_op3,OpOr  )):v  {{ apply_operators `right v }}
/** expression `&' **/
expr_op3 <- (=list1s(expr_op4,OpAnd )):v  {{ apply_operators `right v }}
/** expression `<' `=' **/
expr_op4 <- (=list1s(expr_op5,OpComp)):v  {{ apply_operators `left  v }}
/** expression `+' `-' **/
expr_op5 <- (=list1s(expr_op6,OpAdd )):v  {{ apply_operators `left  v }}
/** expression `*' `/' **/
expr_op6 <- (=list1s((=deco(expr_op7)),OpMul )):v  {{ apply_operators `left  v }}
/** expression unary '-' **/
expr_op7 <- NegOp?:i (=deco(expr_noop)): e
  {{ match i with
    | None -> undecorate e
    | Some i -> i &. [e]
  }}


(* ******************************************************************)
(**
   {7 Side effects expressions with special syntactic sugar}
   - Db write
   - Dom action
*)
side_effect_expr <-
  / pos:p Action.action:a
    {{
      let l = list_expr_of_expr_list [a] p in
      dom_transform l
    }}
  / "@"? (=deco(Parser_path.path_write)):path (=deco(larrow)) expr:e2
    {{
       let (path,pos) = path in
       let path = (DBPath (path, QmlAst.Db.Ref),pos) in
       db_write path e2
    }}


(* ******************************************************************)
(**
   {7 Simple expressions (without operators) }
*)
expr_noop <- expr_noop_subs

/** subsumption of sum types **/
expr_noop_subs <- (typ:t gtcolon {{ t }})?:t (=deco(expr_noop_coerced)):e
  {{ match t with
     | None -> undecorate e
     | Some t -> coerce (directive1 `opensums e, label e) t
  }}

/** coerced expression **/
expr_noop_coerced <- (=type_maybe((=deco(expr_noop_simple)):e
  {{
    function
    | None -> undecorate e
    | Some t -> coerce e t
  }}))

/** expression without operators **/
expr_noop_simple <-
  / side_effect_expr
  / function_call_dot (* also contains directives, ids and bypasses *)
  / match
  / lambda
  / module
  / record / block (* Becareful : Keep this order for keep single fields record *)
  / tuple_expr
  / binding
  / Parser_path.query:v {{ let (p, k) = v in DBPath (p, k) }}
  (* FIXME: useful? / paths_opa_expr / props_aux*)
  / Css.css_map:e {{ undecorate e }} (* useful when saying some_style = ... *)
  / Trx.ExpressionAsFunction:e {{ parser_ e }}
  / Xml.xhtml:v {{ undecorate v }}
  / ip
  / __position__
  / Opa_lexer.CSS lbrace Xml.css_properties:e rbrace {{ undecorate e }}
  / list
(*  / Opa_lexer.BEGIN expr:e Opa_lexer.END {{ undecorate e }} *)
  / ml_identifier_nosp:i hint_end_of_callable {{ Ident i }}
  / const:c {{ Const c }}
  / String_expr.string_with_opa:e {{ undecorate e }} (* need to come after const so that constant strings are just parsed as constants *)
  / Css.prop_value_expr_opa:e {{ undecorate e }} (* useful when constructing colors as #123456 *)


(* ******************************************************************)
(**
   {7 Pattern matching}
*)
/** pattern/if then else **/
match <- Opa_lexer.MATCH lpar expr:e rpar lbrace
           (=list0_strict(match_case, match_rule)):l
           match_rule_default?:default
         rbrace
         {{
           match default with
           | None -> Match (e, l)
           | Some d -> Match (e, l @ [d])
         }}
       / Opa_lexer.IF lpar expr:e1 rpar expr:e2 (Opa_lexer.ELSE expr:e {{ e }})?:o
        {{ if_then_else e1 e2 o }}

match_case <- (Opa_lexer.CASE / match_sep)

match_end_case <- (match_case $ / match_default_case $ / rbrace $)

match_prod <-  ( ((=deco(block_inner)):e &match_end_case {{e}}) / (expr:e &match_end_case {{e}}))

match_rule <- pattern:p colon match_prod:e
  {{(p, e)}}

match_default_case <- Opa_lexer.DEFAULT $

match_rule_default <- (=deco(match_default_case)):d colon match_prod:e
  {{(PatAny, snd d), e}}

match_sep  <- Opa_lexer.BAR

(* TODO REMOVE?*)
match_end <- (Opa_lexer.END $ / (=exact_ident("|_")) $)? (* use by xml_parser *)


(* ******************************************************************)
(**
   {7 Lambda}
*)
lambda_no_function <- lpar (=list0(pattern,comma)):args rpar (=deco(block)):e
  {{ function t -> Lambda (encode_args_as_record args, may_coerce_expr e t) }}

lambda_with_name <-
  Opa_lexer.FUNCTION spacing
    (=type_maybe(deco_ml_identifier_nosp:ident !Opa_lexer.whitespace (=careful_deco(lambda_no_function)):lambda
      {{function t -> (ident, ((fst lambda) t, snd lambda))}})
    ):coerced_lambda
  {{ coerced_lambda }}

lambda <- Opa_lexer.FUNCTION (=type_maybe(lambda_no_function:lambda {{lambda}})):coerced_lambda
  {{coerced_lambda}}


(* ******************************************************************)
(**
   {7 Lists}
   Either ml lists or action lists
 *)
/** List **/
list <-
  / lbracket (=list0(Action.action,comma)):l pos:p comma? (Opa_lexer.BAR expr:e {{e}})?:tl rbracket
  {{ undecorate (list_expr_of_expr_list_no_coerce ?tl l p) }}
  / lbracket (=list0(expr,         comma)):l pos:p comma? (Opa_lexer.BAR expr:e {{e}})?:tl rbracket
  {{ undecorate (list_expr_of_expr_list_no_coerce ?tl l p) }}


(* ******************************************************************)
(**
 {7 Tuples, or parenthesized expression}
  [()] is not in the syntax
  [(e)] is [e] parenthesized
  [(e,)] is the 1-uple made of [e]
  [(e,...,e)] or [(e,...,e,)] is a tuple
*)
/** Tuple expression **/
tuple_expr <- lpar tuple_expr_inside:t rpar {{ t }}
tuple_expr_inside <- (=list1(expr,comma)):l comma?:o
                  {{ match l,o with
                       | [], _ -> assert false
                       | [e],None -> undecorate e
                       | _,_ -> coerce_name (tuple l) (tuple_string l)
                   }}


(* ******************************************************************)
(**
   {7 Bypasses }
   may contain any character except %% ?
*)
/** bypass **/
bypass <- Opa_lexer.BYPASS ((!Opa_lexer.BYPASS .)* $_):content Opa_lexer.BYPASS
  {{ bypass content }}


(* ******************************************************************)
(**
   {7 Module expression}
*)
module_element <-
  declaration_directives:dirs spacing (binding_ident):b
  {{
    let ((ident, l1), (expr, l2)) = b in
    List.hd (declaration_directive dirs [(ident, (expr, (union_annot l1 l2)))])
  }}

module_simple_field <-
  (=type_maybe(deco_ml_identifier_nosp:i assign expr:e
    {{ function t -> (i,may_coerce_expr e t) }}
  ))

/** Module expression **/
module_no_keyword <-
  spacing module_functor_args?:func "{" spacing pos:pos (=deco((=list0pos(module_element,separator)))):r spacing "}"
  {{
    let (r,posl),label = r in
    push_hint (`same_indents (pos :: posl));
    match func with
    | None -> (module_ (Record r,label))
    | Some func -> func ((module_ (Record r,label)), copy_label label)
  }}

module_functor_args <- lpar (=list0(pattern,comma)):args rpar
  {{ function e -> Lambda (encode_args_as_record args, e) }}

module <- Opa_lexer.MODULE module_no_keyword:m
  {{m}}


(* ******************************************************************)
(**
   {7 Record expression}
*)
/** Record expression **/
record <-
  / record_simple
  / record_with

/** Simple record **/
record_simple <- tilda:tilda lbrace record_fields:f rbrace
  {{ Record (default_value_in_expr_record tilda f) }}

record_fields <- (=list0(record_element, record_fields_separator)):l record_fields_separator?
  {{ l }}

record_fields_separator <- spacing comma

record_element <-
   / (=type_maybe(field_identifier:i colon expr:e
       {{ function t -> `binding (i,may_coerce_expr e t) }}
     ))
   / (binding_lambda / binding_module):b
     {{ `binding (undecorate (fst b), snd b) }}
   / tilda:tilda deco_field_identifier:p
     {{ let rhs = if tilda then `value (var_to_exprvar p) else `novalue p in
        `noassign (undecorate p, rhs, None)
     }}

/** Extend record **/
record_with <- tilda:tilda lbrace expr:e Opa_lexer.WITH record_with_fields:f rbrace
  {{
    let long_bindings = default_value_in_expr_record tilda f in
    undecorate (rewrite_long_extend_record long_bindings e)
  }}

record_with_fields <-
  (=list0(record_with_element, record_fields_separator)):l record_fields_separator?
  {{ l }}

record_with_element <-
   / record_long_binding:b {{ `binding b }}
   / tilda:tilda (=deco(record_long_ident)):lp
     {{ let (l,pos) = lp in
        let p = (undecorate (List.last l), pos) in
        let rhs = if tilda then `value (var_to_exprvar p) else `novalue p in
        `noassign (l, rhs, None)
     }}
   / (binding_lambda / binding_module):b
     {{ `binding ([fst b], snd b) }}

record_long_ident_nosp <- deco_ml_identifier_nosp:i ('.' deco_field_identifier_nosp:i {{i}})*:l {{ i :: l }}
record_long_ident <- spacing record_long_ident_nosp:i {{i}}
record_long_binding <-
  / record_long_ident:i colon expr:e {{ (i, e) }}


(* ******************************************************************)
(**
   {7 Declaration directives}
   These directives are linked to the identifier (even if in the ast, they end up
   in an expression)
*)

declaration_directive0_keyword <-
  declaration_directive0_visibility
/ declaration_directive0_slicing

declaration_directive0_visibility <-
  / "@package" {{ `package }}
  / "private" {{ `private_ }}
  / "public" {{ `public }}

declaration_directive0_slicing <-
  / "both" {{ `side_annotation `both }}
  / "client" {{ `side_annotation `client }}
  / "server" {{ `side_annotation `server }}
  / "exposed" {{ `visibility_annotation (`public `sync) }}
  / "protected" {{ `visibility_annotation `private_ }}

declaration_directive_any <-
  / "specialize_strict" {{ `specialize `strict }}
  / "specialize" {{ `specialize `polymorphic }}

declaration_directive1 <-
  / "deprecated" {{ `deprecated }}

declaration_directive0 <-
  / "async" {{ `async }}
  / "opacapi" {{ `opacapi }}
  / "public_env" {{ `public_env }}
  / "expand" {{ `expand None }} (* not allowing anymore to give an integer to expand, could be put back *)
  / slicing_directive0

declaration_directive1_typ <-
  / "stringifier" {{ `stringifier }}
  / "comparator" {{ `comparator }}
  / "serializer" {{ `serializer }}
  / "xmlizer" {{ `xmlizer }}

/** toplevel directive **/
declaration_directives <- (=deco(declaration_directive))*
declaration_directive <-
  / declaration_directive0_keyword:d
    {{ (d, [], []) }}
  / "@" (=exact_ident(declaration_directive0)):d !"("
    {{ (d, [], []) }}
  / "@" (=exact_ident(declaration_directive1)):v Opa_lexer.lpar_nosp expr:e rpar
    {{ (v, [e], []) }}
  / "@" (=exact_ident(declaration_directive_any)):v Opa_lexer.lpar_nosp (=list0(expr,comma)):el rpar
    {{ (v, el, []) }}
  / "@" (=exact_ident(declaration_directive1_typ)):v Opa_lexer.lpar_nosp typ:t rpar
    {{ (v, [], [t]) }}

slicing_directive0 <-
  / "both_implem" {{ `side_annotation `both_implem }}
  / "prefer_both" {{ `side_annotation `prefer_both }}
  / "prefer_client" {{ `side_annotation `prefer_client }}
  / "prefer_server" {{ `side_annotation `prefer_server }}
  / "exposed_async" {{ `visibility_annotation (`public `async) }}
  / "no_client_calls" {{ `no_client_calls }}

closure_instrumentation_directive <- "public_env" {{ `public_env }}

local_binding_directive <-  "@" (=exact_ident(slicing_directive0
                                             /closure_instrumentation_directive)):v !"("
                           {{ (v, [], [])  }}
local_binding_directives <- (=deco(local_binding_directive:v))*

(**
   {7 Directives}
   Everything with @ident syntax
 *)
;
directive0 <-
  / "i18n_lang"  {{ `i18n_lang }}
  / "thread_context" {{ `thread_context }}
  / "todo" {{ `todo }}
  / "toplevel" {{ `toplevel }}

directive1 <-
  / closure_instrumentation_directive
  / "assert" {{ `assert_ }}
  / "atomic" {{ `atomic }}
  / "callcc" {{ `callcc }}
  / "i18n"   {{ `i18n }}
  / "js_ident" {{ `js_ident }}
  / "may_cps" {{ `may_cps }}
  / "nonexpansive" {{ `nonexpansive }}
  / "openrecord" {{ `openrecord }}
  / "opensums" {{ `opensums }}
  / "throw"  {{ `throw }}
  / "typeof" {{ `typeof }}
  / "unsafe_cast" {{ `unsafe_cast }}
  / "wait" {{ `wait }}

directive2 <-
  / "catch" {{ `catch }}
  / "deprecated" {{ `deprecated }}
  / "with_thread_context" {{ `with_thread_context }}

directive1str <-
  / ("static_source_content" / "static_binary_content") {{ fun x -> `static_content (x, true) }}
  / "compiletime" {{ fun x -> `compiletime x }}

directive1rec <-
  / "lazy_record" {{ `create_lazy_record }}
  / "spawn" {{ `spawn }}

directive1or2str <-
  / "static_content_directory" {{ (fun x -> `static_content_directory (x, false)) }}
  / "static_content" {{ (fun x -> `static_content (x, false)) }}
  / ("static_include_directory" / "static_resource_directory" ) {{ fun x -> `static_resource_directory x }}
  / "static_resource" {{ fun x -> `static_resource x }}

;/** directive **/
directive <-
  (* FIXME: could accept assert_message(,_e)(s)
   * instead of just assert_message(s,e) *)
  / "@xml(" spacing Xml.xmlns:xmlns rpar {{ undecorate xmlns }}
  / "@typeval(" typ:t rpar {{
      (* For convenience, directive [@typeval] is handled as thin syntactic sugar.
         Therefore [@typeval(t)] is parsed as [@typeof(@unsafe_cast("dummy_for_typeval"):t)]
      *)
      let expr_cast      = (directive1 `unsafe_cast (void (nlabel t)), nlabel t) in
      let expr_coerced   = coerce_expr expr_cast t                   in
      let just_typeof    = directive1 `typeof expr_coerced           in
      just_typeof
    }}
  / "@" (=exact_ident(directive0)):v !"("
    {{ Directive (v,[],[]) }}
  / "@" (=exact_ident(directive1)):v Opa_lexer.lpar_nosp expr:e rpar
    {{ Directive (v,[e],[]) }}
  / "@" (=exact_ident(directive1str)):v Opa_lexer.lpar_nosp string:str rpar
    {{ Directive (v str,[],[]) }}
  / "@" (=exact_ident(directive1rec)):v Opa_lexer.lpar_nosp (=deco(record)):e rpar
    {{ Directive (v,[e],[]) }}
  / "@" (=exact_ident(directive2)):v Opa_lexer.lpar_nosp expr:e1 comma expr:e2 rpar
    {{ Directive (v,[e1;e2],[]) }}
  / "@" (=exact_ident(directive1or2str)):v Opa_lexer.lpar_nosp string:str (comma expr:e {{ [e] }} / _succeed {{ [] }}):el rpar
    {{ Directive (v str,el,[]) }}
  / "@" !strict_spacing deco_ml_identifier_nosp:v (function_arguments_nosp / !"(" {{ [] }}):l
      {|
          (* the directives in here are the ones that inspect a little too much
           * their arguments, and so it is difficult to factorize them *)

          let s = undecorate v in
          match s with

          | "fail" ->
              (*
                Argument of directive @fail is optional.
                Add the empty string in case of no argument.
              *)
              Return.set_checkpoint_none (
                fun parse_error ->
                  let l =
                    match l with
                    | [] ->
                        let label = label v in
                        [ SA.Const (SA.CString ""), label ]
                    | [ _ ] -> l
                    | _ -> Return.return parse_error ()
                  in
                  SurfaceAst.Directive (`fail, l, [])
              )

          | "llarray" -> Some (SurfaceAst.Directive (`llarray, l, []))

          | "sliced_expr" ->
              let (client,server) =
                match l with
                | [(Record l,_)] ->
                    (match l with
                     | ["server", server; "client", client] -> (client,server)
                     | ["client", client; "server", server] -> (client,server)
                     | _ -> error_sliced_expr (snd v))
                | _ -> error_static_record v in
              Some (Directive (`sliced_expr, [client; server], []))

          | "track" -> (
              match l with
              | [(Const (CString s1), label); expr] ->
                  let pos = SurfaceAstHelper.Annot.to_string label in
                  let tracker = PassTracker.next (Printf.sprintf "%s : %s" s1 pos) in
                  Some (Directive (`tracker tracker, [ expr ],  []))
              | [expr] ->
                  let pos = SurfaceAstHelper.Annot.to_string' expr in
                  let tracker = PassTracker.next pos in
                  Some (Directive (`tracker tracker, [ expr ],  []))
              | _ -> error_directive_wrong_arguments_type v
            )

          | _ -> None
      |}


(* ******************************************************************)
(**
  {7 Position}
*)
;__position__ <-
       / (=deco((=exact_ident("__POSITION__")))):p
          {{ let pos = label p in
               Const (CString (FilePos.to_string pos.QmlLoc.pos))
           }}


(* ******************************************************************)
(**
  {6 Const }
*)
;/** constant **/
const      <- float:f {{ CFloat f }}
            / int:i {{ CInt (Big_int.big_int_of_int i) }}
            / string:s {{ CString s }}


(* ******************************************************************)
(**
  {7 Function call, field access and method call}
  Function call, field access and method call are left associative and with
  the same priority
  When taking care of holes, the whole list of application/field access/...
  is looked at: [f(_).x(_)] is transformed in [y,z -> f(z).x(z)]
  An underscore at the beginning of the series of calls is valid:
  [_(x)] means [f -> f(x)], [_.x] means [fun r -> r.x], etc.
*)
/** function calls, field access **/
function_call_dot <-
       / ident_call_dot
       / paren_expr_call_dot
       / (=careful_deco(Opa_lexer.underscore_nosp)):p function_arguments_dot_method_nosp+:params hint_end_of_callable
         {{ make_function2 letins double_dot (`hole (label p)) params }}
       / expr_before_possible_function_call:e ( function_arguments_dot_method_nosp+:params hint_end_of_callable
                                                  {{ fun e -> make_function2 letins double_dot (`expr e) params }}
                                              / _succeed
                                                  {{ fun e -> undecorate e }}):f {{ f e }}


(* Only certain kind of expression can be applied *)
let call_dot func = (=careful_deco(func)):e function_arguments_dot_method_nosp+:params hint_end_of_callable
         {{ make_function2 letins double_dot (`expr e) params }}
;expr_before_possible_function_call = careful_deco just_expr_before_possible_function_call

ident_call_dot <- (=call_dot(just_ident_before_mandatory_function_call))
paren_expr_call_dot <- (=call_dot(just_paren_expr_before_mandatory_function_call))

just_ident_before_mandatory_function_call <-
     / ml_identifier_nosp:i {{ Ident i }}

just_paren_expr_before_mandatory_function_call <-
     / lpar expr:e rpar {{ undecorate e }}



just_expr_before_possible_function_call <-
     / id
     / directive
     / bypass

(**
   {7 Id}
*)
id <-  (=careful_deco("#")):p deco_ml_identifier_nosp:s
         {{ undecorate ((Ident "$",label p) & [string2 s]) }}
     / (=careful_deco("#")):p opa_in_braces_nosp:e
         {{ undecorate ((Ident "$",label p) & [e]) }}
naked_id <-
       (=careful_deco("#")):p deco_ml_identifier_nosp:s
         {{ string2 s }}
     / (=careful_deco("#")):p opa_in_braces_nosp:e
         {{ e }}

(**
  {7 Ip address}
  The parsing only allows for integers between 0 and 255, so writing
  0.0.0.256 is a parse error
*)
;int3 <- Opa_lexer.int3:i {{ CInt (Big_int.big_int_of_string i) }}
;ip_item = deco just_ip_item
;just_ip_item <- int3:v {{ Const v }}
;just_ip <- ip_item:a [.] ip_item:b [.] ip_item:c [.] ip_item:d {{ Record (encode_record [("a",a);("b",b);("c",c);("d",d)]) }}
;/** ip address **/
ip <- (=deco(just_ip)):p {{ coerce_name p Opacapi.Types.ip }}







(**
   {7 Function arguments}
 *)

(* used for directives, where you have no holes (at least now) *)
;/** directive arguments **/
function_arguments <- function_arguments_nosp
;function_arguments_nosp <- (=careful_deco(just_function_arguments_nosp)):l {{ undecorate l }}
;just_function_arguments_nosp <- Opa_lexer.lpar_nosp (=list0(expr,comma)):l rpar {{ l }}




;function_arguments_nosp2 <- (=careful_deco(just_function_arguments_nosp2)):l {{ undecorate l }}
;just_function_arguments_nosp2 <- Opa_lexer.lpar_nosp (=list0(expr_underscore,comma)):l rpar {{ l }}
;expr_underscore = expr_or_hole expr

(* the UNDERSCORE rule needs to come after so that priorities are correct:
 * [2 + _ * 3] gets parsed like [2 + (_ * 3)]
 * and [f(_ + 2)] is parsed [f(fun x -> x + 2)] and not [f; (_ + 2)]
 *)
;let expr_or_hole expr = expr:e {{ `expr e }}
                       / deco_underscore:p {{ `hole p }}

(* used for everything assimilated to a function call: field access, method call, regular function call *)
;function_arguments_dot_method_nosp = careful_deco(just_function_arguments_dot_method_nosp)
;just_function_arguments_dot_method_nosp <-
  / function_arguments_nosp2:args {{ `function_call args }}
  / "." Opa_lexer.field_identifier_nosp:i {{ `dot i }}
  / ".." Opa_lexer.ml_identifier_nosp:i {{ `double_dot i }}

(**
  {7 Opa expression inside braces}
  Used for embedding opa in texts like string or xhtml
*)
/** embedded opa **/
opa_in_braces_nosp <- lbrace_nosp expr:e rbrace {{ e }}
/** embedded opa **/
opa_in_braces <- lbrace expr:e rbrace {{ e }}




(**
    Some decorations
 *)
;deco_ml_identifier_nosp = careful_deco ml_identifier_nosp
;deco_ml_identifier = deco ml_identifier
;deco_field_identifier_nosp = careful_deco field_identifier_nosp
;deco_field_identifier = deco field_identifier
;deco_underscore <- (=deco(Opa_lexer.UNDERSCORE)):p {{ label p }}
;deco_underscore_nosp <- (=careful_deco(Opa_lexer.UNDERSCORE)):p {{ label p }}
;let deco_option rule = (=deco(rule ?))
;let exact_symbol rule = (=Opa_lexer.exact_symbol(rule))
;let exact_ident rule = (=Opa_lexer.exact_ident(rule))
(* WARNING: _succeed always succeeds but careful_deco and deco fail if they start
 * at the end of the file. So don't use pos at a place where it might be the last rule
 * applied *)
;pos <- (=careful_deco(_succeed)):p {{ label p }}
;offset <- Opa_lexer.offset

(**
   {6 Convenience functions}
 *)

(** Always succeed

    @TODO Patch Teerex to make this a primitive.
*)
(* adds some "expects ... or any character" in error messages that are not nice *)
_succeed <- (&. $/ !. $)
_fail <- &. &(!.) . $


(**
  {7 Hint utils}
*)
;hint_end_of_callable <- (=careful_deco(& " (")):p {{ push_hint (`function_call (label p)); () }}
                       / !"(" $

separator <- Opa_lexer.maybe_whitespace (semic / Opa_lexer.newline / Opa_lexer.opacomment) pos:p {{ p }}

(**
   {7 Importing the lexer}
*)
string <- Opa_lexer.string
char   <- Opa_lexer.char
int <- Opa_lexer.int
float  <- Opa_lexer.float
spacing<- Opa_lexer.spacing
strict_spacing<- Opa_lexer.strict_spacing
ml_identifier <- spacing Opa_lexer.ml_identifier {{ __2 }}
ml_identifier_nosp <- spacing Opa_lexer.ml_identifier_nosp {{ __2 }}
field_identifier <- spacing Opa_lexer.field_identifier {{ __2 }}
field_identifier_nosp <- spacing Opa_lexer.field_identifier_nosp {{ __2 }}
type_identifier <- spacing Opa_lexer.type_identifier {{ __2 }}
type_identifier_nosp <- spacing Opa_lexer.type_identifier_nosp {{ __2 }}


larrow   <- Opa_lexer.larrow $
rarrow   <- Opa_lexer.rarrow  $
lbrace   <- Opa_lexer.lbrace  $
lbrace_nosp <- Opa_lexer.lbrace_nosp $
rbrace   <- Opa_lexer.rbrace  $
lbracket <- Opa_lexer.lbracket$
rbracket <- Opa_lexer.rbracket$
colon    <- Opa_lexer.colon   $
gtcolon  <- Opa_lexer.gtcolon $
comma    <- Opa_lexer.comma   $
semic    <- Opa_lexer.semic   $
slash    <- Opa_lexer.slash   $
lpar     <- Opa_lexer.lpar    $
rpar     <- Opa_lexer.rpar    $
bquote   <- Opa_lexer.bquote  $
quote    <- Opa_lexer.quote   $
ampersand <- Opa_lexer.ampersand $
underscore <- Opa_lexer.underscore $
alias <- Opa_lexer.alias $
dots <- Opa_lexer.dots $
assign <- Opa_lexer.assign $

(**
   {6 Meta-rules}
*)

let perhaps_map f r1 r2 =
  / r2:p2 {{ p2 }}
  / r1:p1 r2:p2 {{ f p1 p2 }}


(**
   {7 Separated lists}
*)

(** list where a the separator must occur *)
let list2 element separator = element:e (separator element:e {{e}})+:l
  {{ e :: l }}

let list0_strict separator element = (separator element:e {{e}})*:l {{l}}

(**Non-empty lists*)
let list1 element separator = element:e (separator element {{__2}})*:l
  {{ e :: l }};

let list1_strict separator element = (separator element:e {{e}})+:l {{l}}

(**Possibly empty lists*)
let list0 element separator = (=list1(element,separator))?:o
  {{ match o with
       | None -> []
       | Some l -> l
   }}

(** Non-empty lists where you get the separator and maybe holes instead of expressions
  * but it avoids parsing [_] as a list of one element *)
let list1s element operator =
  / element:e ((=infix(operator)):s (=expr_or_hole(element)):e {{ (s,e) }})*:l {{ (`expr e,l) }}
  / deco_underscore:p ((=infix(operator)):s (=expr_or_hole(element)):e {{ (s,e) }})+:l {{ (`hole p,l) }}


let list1pos element separator = element:e (separator:s element:e {{ (s,e) }})*:l {{ let sl,el = List.split l in e::el,sl }}
let list0pos element separator = (=list1pos(element,separator))?:o {{ Option.default ([],[]) o }}

(**
   {7 Rules for operators}
*)
;let infix operator = spacing offset:o1 operator:s offset:o2
   {| let c1 = _get_char (o1 - 1) in
      let c2 = _get_char o2 in
      (*Printf.printf "%d %d %C %C\n%!" (o1 - 1) o2 c1 c2;*)
      if Char.is_space c1 = Char.is_space c2 then Some s else None |}

(**
   {7 Labelling stuff with positions}
*)

let careful_deco rule = (=Opa_lexer.careful_deco(rule));
let deco rule = (=Opa_lexer.deco(rule));

let backtrack r0 r1 =
  / r0:p0 r1:p1 {{ p1 (Some p0) }}
  / r1:p1 {{ p1 None }}