%{ (* -*- tuareg -*- *)

  open HopixAST

%}

%token EOF LET TYPE WILDCARD ARROW COLON EXTERN FUN COMMA AND EQUAL LPAREN
%token RPAREN LBRACK RBRACK LBRACE RBRACE INFERIOR SUPERIOR DO ELSE FOR
%token FROM IF MATCH PIPE REF THEN TO UNTIL WHILE AND_KW DOT SEMICOLON BACKSLASH
%token ASSIGN EXCLA
%token PLUS MINUS STAR SLASH D_AND D_OR EQUAL_OP INF_EQUAL_OP SUP_EQUAL_OP INF_OP SUP_OP

%token<Mint.t> INT
%token<string> ID TID CID STRING
%token<char> CHAR


%start<HopixAST.t> program

%left LPAREN

%left STRING
%left INT CID CHAR
%left ID
%right ARROW
%right SEMICOLON
%left ASSIGN
%left LBRACE

%left EXCLA COLON

/* Priorités binop */
%left D_OR
%left D_AND
%left EQUAL_OP INF_EQUAL_OP INF_OP SUP_EQUAL_OP SUP_OP
%left PLUS MINUS
%left SLASH STAR

%left local_def1
%left fun1
%left app1


%%


/********************************** PROGRAM ***********************************/
program:
/* Programme */
| definition=located(definition)* EOF {
    definition
  }
/* Attrapes les erreurs de syntaxe */
| e=located(error) {
    Error.error "parsing" (Position.position e) "Syntax error."
  }


definition:
/* Définition de types */
| TYPE tc=located(type_constructor) tvl=optionlist(definition_typevariablelist)
  EQUAL td=tdefinition {
    DefineType (tc, tvl, td)
  }
// La tdefinition peut être optionnel, dans ce cas on utilise c'est abstrait
| TYPE tc=located(type_constructor) tvl=optionlist(definition_typevariablelist) {
    DefineType (tc, tvl, Abstract)
  }
/* Valeurs externes */
| EXTERN id=located(var_identifier) COLON ts=located(type_scheme) {
    DeclareExtern(id, ts)
  }
/* Définition de valeurs */
| v=vdefinition {
    DefineValue v
  }

definition_typevariablelist:
| INFERIOR l=separated_nonempty_list(COMMA, located(type_variable)) SUPERIOR {
    l
  }


tdefinition:
/* Type sommes */
/* la définition étant assez compliqué,
 * on va utilisé d'autre terme pour réduire la taille */
| option(PIPE)
  l=separated_nonempty_list(PIPE, list_constructor_and_their_ty) {
    DefineSumType(l)
  }
/* Type produit étiqueté */
| LBRACE lt=separated_nonempty_list(COMMA, label_with_type) RBRACE {
    DefineRecordType(lt)
  }

list_constructor_and_their_ty:
| c=located(constructor) t=optionlist(list_ty) {
    (c, t)
  }

list_ty:
| LPAREN l=separated_nonempty_list(COMMA, located(ty)) RPAREN {
    l
  }

label_with_type:
| l=located(label_identifier) COLON t=located(ty) {
    l, t
  }

/* vdefinition et vdefinition_local font sensiblement la même chose,
 * seulement l'ordre de priorité est différent */
vdefinition:
/* Valeur simple */
| LET i=located(var_identifier) ts=option(colon_type_scheme)
  EQUAL e=located(expression) {
    SimpleValue(i, ts, e)
  }
/* Fonction(s) */
| FUN fl=separated_nonempty_list(AND_KW, fundef) {
    RecFunctions(fl)
  }

vdefinition_local:
/* Valeur simple */
| LET i=located(var_identifier) ts=option(colon_type_scheme)
  EQUAL e=located(expression) %prec local_def1 {
    SimpleValue(i, ts, e)
  }
/* Fonction(s) */
| FUN fl=separated_nonempty_list(AND_KW, fundef) {
    RecFunctions(fl)
  }


fundef:
| t=option(colon_type_scheme) i=located(var_identifier) p=located(pattern)
  EQUAL e=located(expression) %prec fun1 {
    i, t, FunctionDefinition(p, e)
  }


/********************************** PATTERN ***********************************/
branches:
| option(PIPE) b=separated_nonempty_list(PIPE, located(branch)) {
    b
  }

branch:
| p=located(pattern) ARROW e=located(expression) {
    Branch(p, e)
  }


simple_pattern:
/* Motif universel liant */
| i=located(var_identifier) {
    PVariable i
  }
/* Motif universel non liant */
| WILDCARD {
    PWildcard
  }
/* Parenthésage */
| LPAREN RPAREN {
    PTuple([])
  }
/* N-uplets */
| l=pattern_list {
    match l with | [alone] -> Position.value alone | _ -> PTuple(l)
  }
/* Annotation de type */
| p=located(simple_pattern) COLON ty=located(ty) {
    PTypeAnnotation(p, ty)
  }
/* Entier / Caractère / String */
| l=located(literal) {
    PLiteral l
  }
/* Valeurs étiquetées */
| const=located(constructor) tl=option(type_list) pl=optionlist(pattern_list) {
    PTaggedValue(const, tl, pl)
  }
/* Enregistrement */
| LBRACE l=separated_nonempty_list(
    COMMA,
    separated_pair(located(label_identifier), EQUAL, located(pattern))
  ) RBRACE tl=option(type_list) {
    PRecord(l, tl)
  }

pattern:
| p1=simple_pattern {
    p1
  }
/* Disjonction */
| p1=located(simple_pattern)
  PIPE p_list=separated_nonempty_list(PIPE, located(simple_pattern)) {
    POr(p1 :: p_list)
  }
/* Conjonction */
| p1=located(simple_pattern)
  AND p_list=separated_nonempty_list(AND, located(simple_pattern)) {
    PAnd(p1 :: p_list)
  }

pattern_list:
| LPAREN el=separated_nonempty_list(COMMA, located(pattern)) RPAREN {
    el
  }


/********************************* DATA TYPE **********************************/
/* Pour résoudre un conflit, on a du split ty en 2 règles
 *
 * separated_nonempty_list(STAR, located(ty)) -> ty STAR separated_nonempty_list(STAR, located(ty))
 * [ ty ] -> ty * [ ty ]
 * ET
 * ty -> ty STAR separated_nonempty_list(STAR, located(ty))
 * ty -> ty * [ ty ]
 */

simple_ty:
/* Application d'un constructeur de type */
| tc=type_constructor {
    TyCon(tc, [])
  }
/* 'liste_ty' doit etre optionnel => gérer par le cas au dessus */
| tc=type_constructor
  INFERIOR liste_ty=separated_nonempty_list(COMMA, located(ty)) SUPERIOR {
    TyCon(tc, liste_ty)
  }

/* Variables de type */
| type_var=type_variable {
    TyVar(type_var)
  }
/* Type entre parenthèses */
| LPAREN ty1=ty RPAREN {
    ty1
  }


ty:
/* Un type peut être un simple_type */
| t=simple_ty {
    t
  }
/* Fonctions */
| ty1=located(ty) ARROW ty2=located(ty) {
    TyArrow(ty1, ty2)
  }
/* N-uplets (N > 1) */
| th=located(simple_ty)
  STAR tt=separated_nonempty_list(STAR, located(simple_ty)) {
    TyTuple(th :: tt)
  }


type_scheme:
| LBRACK liste_typevar=separated_list(COMMA, located(type_variable))
  RBRACK ty=located(ty) {
    ForallTy(liste_typevar, ty)
  }
| ty=located(ty) {
    ForallTy([], ty)
  }

colon_type_scheme:
| COLON ts=located(type_scheme) {
    ts
  }


/********************************* EXPRESSION *********************************/
simple_expression:
/* Simple litteral */
| l=located(literal) {
    Literal l
  }
/* Variable */
| i=located(var_identifier) tl=option(type_list) {
    Variable(i, tl)
  }
/* Tuple n > 1 - Construction d'un n-uplet (n > 1) */
| el=expr_list {
    (* S'il y a qu'1 élément, alors c'est juste une expression *)
    match el with | [alone] -> Position.value alone | _ -> Tuple(el)
  }

mid_expression:
| e=simple_expression {
    e
  }
/* Tagged Value - Construction d'une donnée
 * TODO: Conflict shift/reduce sur le expr_list */
| const=located(constructor) tl=option(type_list) el=optionlist(expr_list) {
    Tagged(const, tl, el)
  }
/* Application */
| e1=located(mid_expression) e2=located(mid_expression) %prec app1 {
    Apply(e1, e2)
  }
/* Lecture de variable
 * !expr */
| EXCLA e=located(simple_expression) {
    Read(e)
  }
/* Record - Construction d'un enregistrement */
| LBRACE l=separated_nonempty_list(
    COMMA,
    separated_pair(located(label_identifier), EQUAL, located(expression))
  ) RBRACE tl=option(type_list) {
    Record(l, tl)
  }

expression:
| e=mid_expression {
    e
  }
/* Annotation de type
 * ( expr : type ) */
| LPAREN e=located(expression) COLON t=located(ty) RPAREN {
    TypeAnnotation(e, t)
  }
/* Tuple n = 0 - Construction d'un 0-uplet */
| LPAREN RPAREN {
    Tuple([])
  }
/* Sequence - Séquencement */
| e=located(expression) SEMICOLON e2=located(expression) {
    Sequence([e; e2])
  }
/* Definition locale */
| vd=vdefinition_local SEMICOLON e=located(expression) {
    Define(vd, e)
  }
/* Fonction anonyme */
| BACKSLASH p=located(pattern) ARROW e=located(expression) {
    Fun(FunctionDefinition(p, e))
  }
/* Operateurs binaires - Application infixe */
| e1=located(expression) b=binop e2=located(expression) {
    Apply(
      Position.unknown_pos (Apply(
        Position.unknown_pos (
          Variable (
            Position.unknown_pos (Id b),
            None
          )
        ),
        e1
      )),
      e2
    )
  }
/* Analyse de motifs
 * match (exp) {| ...| ... | ...} */
| MATCH LPAREN e=located(expression) RPAREN LBRACE b=branches RBRACE {
    Case(e, b)
  }
/* Conditionnelle (1)
 * if ( expr ) then { expr } */
| IF LPAREN e1=located(expression) RPAREN
  THEN LBRACE e2=located(expression) RBRACE {
    (*                else { () }  aka le 0-uplet *)
    IfThenElse(e1, e2, Position.unknown_pos (Tuple []))
  }
/* Conditionnelle (2)
 * if ( expr ) then { expr } else { expr } */
| IF LPAREN e1=located(expression) RPAREN
  THEN LBRACE e2=located(expression) RBRACE
  ELSE LBRACE e3=located(expression) RBRACE {
    IfThenElse(e1, e2, e3)
  }
/* Affectation
 * expr := expr */
| e1=located(expression) ASSIGN e2=located(expression) {
    Assign(e1, e2)
  }
/* While - Boucle non bornée
 * while ( expr ) { expr } */
| WHILE LPAREN e1=located(expression) RPAREN
  LBRACE e2=located(expression) RBRACE {
    While(e1, e2)
  }
/* Do while - Boucle non bornée et non vide
 * do { expr } until ( expr ) */
| DO LBRACE e1=located(expression) RBRACE
  UNTIL LPAREN e2=located(expression) RPAREN {
    Sequence([e1 ; Position.unknown_pos (While(e2, e1))])
  }
/* Boucle for - Boucle bornée
 * for x in (e1 to e2) { expr } */
| FOR var=located(var_identifier)
  FROM LPAREN e1=located(expression) RPAREN
  TO LPAREN e2=located(expression) RPAREN
  LBRACE e3=located(expression) RBRACE {
    For(var, e1, e2, e3)
  }
/* Allocation
 * ref expr */
| REF e=located(mid_expression) {
    Ref(e)
  }
/* Field record */
| e=located(mid_expression) DOT l=located(label_identifier) tl=option(type_list) {
    Field(e, l, tl)
  }

type_list:
| INFERIOR tl=separated_list(COMMA, located(ty)) SUPERIOR {
    tl
  }

expr_list:
| LPAREN el=separated_nonempty_list(COMMA, located(expression)) RPAREN {
    el
  }


/******************************** BASIC TYPES *********************************/
var_identifier:
| var_id=ID {
    Id var_id
  }

type_variable:
| tid=TID {
    TId tid
  }

constructor:
| constr_id=CID {
    KId constr_id
  }

type_constructor:
| type_con=ID {
    TCon type_con
  }

label_identifier:
| label=ID {
    LId label
  }

literal:
/* Entier positif */
| i=INT {
    LInt i
  }
/* Caractère */
| c=CHAR {
    LChar c
  }
/* Chaîne de caractères */
| s=STRING {
    LString s
  }


/****************************** INLINE FUNCTIONS ******************************/
%inline binop:
| PLUS         { "`+`"   }
| MINUS        { "`-`"   }
| STAR         { "`*`"   }
| SLASH        { "`/`"   }
| D_AND        { "`&&`"  }
| D_OR         { "`||`"  }
| EQUAL_OP     { "`=?`"  }
| INF_EQUAL_OP { "`<=?`" }
| SUP_EQUAL_OP { "`>=?`" }
| INF_OP       { "`<?`"  }
| SUP_OP       { "`>?`"  }

%inline located(X): x=X {
  Position.with_poss $startpos $endpos x
}

%inline optionlist(X): x=option(X) {
  match x with | Some l -> l | None -> []
}