source: applications/trunk/LFC/parser/Parser.rf @ 3893

$use Access Apply StdIO Stream;
$use Lexer;

$func Main = e;
Main = <WriteLn <ParseFile "samples.lfc">>;

$public $func ParseFile e.fname = e.ast;
ParseFile e.fname =
  <Lexer <File_Open e.fname>> :: e.tokens,
  //<WriteLn e.tokens>,
  <GetRAST <Program e.tokens>>;

$public $func GetRAST e.ast = e.ast;
GetRAST {
  /*empty*/ = /*empty*/;
  t.term e.ast = t.term : {
    (IDENT t.name VAR) = (VAR t.name);
    (IDENT t.name CALL e.args) = (CALL t.name <GetRAST e.args>);
    (SENTENCE t.name (e.patterns) e.exp (WHERE e.assigns)) = (SENTENCE t.name (e.patterns) (LET (<GetRAST e.assigns>) <GetRAST e.exp>));
    (PAREN e.exp (WHERE e.assigns)) = (PAREN (LET (<GetRAST e.assigns>) <GetRAST e.exp>));
    (e.exp) = (<GetRAST e.exp>);
    s.sym = s.sym;
  } :: t.term,
    t.term <GetRAST e.ast>;
};

$func Parse (e.tokens) e.expr = e.ast (e.tokens);
Parse {
  (e.tokens) /*empty*/ = (e.tokens);
  (e.tokens) t.term e.expr = t.term : {
    (Get s.func) =
      <Apply s.func e.tokens> : e.ast (e.tokens_rest),
      e.ast <Parse (e.tokens_rest) e.expr>;
    (Skip s.tk) =
      {
        e.tokens : (s.tk t.pos) e.tokens_rest = <Parse (e.tokens_rest) e.expr>;
        <Error (e.tokens) "expected " s.tk>;
      }; 
    (e.expr2) =
      <Parse (e.tokens) e.expr2> :: e.ast (e.tokens),
      (e.ast) <Parse (e.tokens) e.expr>;
    s.symbol = s.symbol <Parse (e.tokens) e.expr>;
  };
}; 

$func Error (e.tokens) e.message = (e.tokens);
Error ((e.tk (e.pos)) e) e.message =
  <Write e.pos> <Print ' --- 'e.message' while ('> <Write e.tk> <PrintLn ') have been got'>,
  $error "Can't parse the program";

$func Program e.tokens = e.ast (e.tokens);
Program e.tokens = {
  e.tokens : (DEC e) e = <Parse (e.tokens) (FUNC (Get &FunctionDec) (Get &VarDecAndFuncDef)) (Get &ProgramRest)>;
  <Error (e.tokens) "program should consist of a number of function definitions">;
};

$func ProgramRest e.tokens = e.ast (e.tokens);
ProgramRest e.tokens = {
  e.tokens : (EOF e) = ();
  e.tokens : (DEC e) e = <Program e.tokens>;
  <Error (e.tokens) "expected function declaration">;
};

$func FunctionDec e.tokens = e.ast (e.tokens);
FunctionDec (DEC e) e.tokens =
  <Parse (e.tokens) (Get &Identifier) (Skip COLON) ((Get &FunctionType)) (Skip SC)>;

$func VarDecAndFuncDef e.tokens = e.ast (e.tokens);
VarDecAndFuncDef e.tokens = {
  e.tokens : (VAR e) e = <Parse (e.tokens) ((Get &VariableDec)) (Get &Definition)>;
  e.tokens : (DEF e) e = <Parse (e.tokens) () (Get &Definition)>;
  <Error (e.tokens) "expected variable declarations or a function definition">;
};

$func VariableDec e.tokens = e.ast (e.tokens);
VariableDec (VAR e) e.tokens =
  <Parse (e.tokens) ((Get &VarsDecl)) (Get &VariableDecRest)>;

$func VarsDecl e.tokens = e.ast (e.tokens);
VarsDecl e.tokens = {
  e.tokens : (IDENTIFIER e) e = <Parse (e.tokens) (Get &VariableList) (Skip COLON) (TYPE (Get &Identifier)) (Skip SC)>;
  <Error (e.tokens) "expected the name of a variable to be declared">;
};

$func VariableDecRest e.tokens = e.ast (e.tokens);
VariableDecRest e.tokens = {
  e.tokens : (DEF e) e = (e.tokens);
  e.tokens : (IDENTIFIER e) e = <Parse (e.tokens) ((Get &VarsDecl)) (Get &VariableDecRest)>;
  <Error (e.tokens) "expected the name of a variable to be declared or 'def' and a function definition">;
};

$func VariableList e.tokens = e.ast (e.tokens);
VariableList e.tokens = {
  e.tokens : (IDENTIFIER e) e = <Parse (e.tokens) (VAR (Get &Identifier)) (Get &VariableListRest)>;
  <Error (e.tokens) "expected the name of a variable to be declared">;
};

$func VariableListRest e.tokens = e.ast (e.tokens);
VariableListRest e.tokens = {
  e.tokens : (COLON e) e = (e.tokens);
  e.tokens : (COMMA e) e.tokens_rest = <Parse (e.tokens_rest) (VAR (Get &Identifier)) (Get &VariableListRest)>;
  <Error (e.tokens) "expected the name of a variable to be declared or ':' and a concept name">;
};

$func Definition e.tokens = e.ast (e.tokens);
Definition e.tokens = {
  e.tokens : (DEF e) e.tokens_rest = <Parse (e.tokens_rest) (Get &Equation) (Get &EquationRest)>;
};

$func Equation e.tokens = e.ast (e.tokens);
Equation e.tokens = {
  e.tokens : (IDENTIFIER e) e =
    <Parse (e.tokens) (SENTENCE (Get &Identifier) (Skip LPAR) ((Get &PatternList)) (Skip RPAR) (Skip EQ) (Get &ExpWithWhereOrUndef) (Skip SC))>;
  <Error (e.tokens) "expected the name of a function">;
};

$func EquationRest e.tokens = e.ast (e.tokens);
EquationRest e.tokens = {
  e.tokens : \{ (EOF e) e; (DEC e) e; } = (e.tokens);
  e.tokens : (IDENTIFIER e) e = <Parse (e.tokens) (Get &Equation) (Get &EquationRest)>;
  <Error (e.tokens) "expected another equation or new function declaration">;
};

$func PatternList e.tokens = e.ast (e.tokens);
PatternList e.tokens = {
  e.tokens : \{ (IDENTIFIER e) e; (STRING e) e; } = <Parse (e.tokens) ((Get &Pattern)) (Get &PatternListRest)>;
  <Error (e.tokens) "expected a constant or a variable name">;
};

$func Pattern e.tokens = e.ast (e.tokens);
Pattern e.tokens = {
  e.tokens : (STRING e.str t.pos) e.tokens_rest = e.str <Parse (e.tokens_rest) (Get &PatConcat)>;
  e.tokens : (IDENTIFIER e) e = <Parse (e.tokens) (VAR (Get &Identifier)) (Get &PatConcat)>;
  <Error (e.tokens) "expected a constant or a variable name">;
};

$func PatConcat e.tokens = e.ast (e.tokens);
PatConcat e.tokens = {
  e.tokens : \{ (COMMA e) e; (RPAR e) e; } = (e.tokens);
  e.tokens : (CONCAT e) e.tokens_rest = <Pattern e.tokens_rest>;
  <Error (e.tokens) "expected '[]' or ',' or ')'">;
};

$func PatternListRest e.tokens = e.ast (e.tokens);
PatternListRest e.tokens = {
  e.tokens : (RPAR e) e = (e.tokens);
  e.tokens : (COMMA e) e.tokens_rest =  <Parse (e.tokens_rest) ((Get &Pattern)) (Get &PatternListRest)>;
  <Error (e.tokens) "expected ',' or ')'">;
};

$func FunctionType e.tokens = e.ast (e.tokens);
FunctionType e.tokens = {
  e.tokens : (IDENTIFIER e) e = <Parse (e.tokens) (TYPE (Get &Identifier)) (Get &ConceptListRest) (Skip TO) (TYPE (Get &Identifier))>;
  <Error (e.tokens) "expected a type of a function argument">;
};

$func ConceptListRest e.tokens = e.ast (e.tokens);
ConceptListRest e.tokens = {
  e.tokens : (TO e) e = (e.tokens);
  e.tokens : (ASTERISK e) e.tokens_rest = <Parse (e.tokens_rest) (TYPE (Get &Identifier)) (Get &ConceptListRest)>;
  <Error (e.tokens) "expected '*' or '->'">;
};

$func Exp e.tokens = e.ast (e.tokens);
Exp e.tokens = {
  e.tokens : (STRING e.str t.pos) e.tokens_rest = e.str <ExpConcat e.tokens_rest>;
  e.tokens : (IDENTIFIER e) e = <Parse (e.tokens) (IDENT (Get &Identifier) (Get &ExpVarOrFunc)) (Get &ExpConcat)>;
  e.tokens : (LPAR e) e.tokens_rest = <Parse (e.tokens_rest) (PAREN (Get &ExpWithWhere)) (Skip RPAR) (Get &ExpConcat)>;
  e.tokens : (IF e) e.tokens_rest = <Parse (e.tokens_rest) (IF ((Get &Exp)) (Skip THEN) ((Get &Exp)) (Skip ELSE) ((Get &Exp)))>;
  <Error (e.tokens) "expected a constant, or an identifier, or '(', or 'if', or 'undefined'">;
};

$func ExpWithWhere e.tokens = e.ast (e.tokens);
ExpWithWhere e.tokens = {
  e.tokens : (STRING e.str t.pos) e.tokens_rest = e.str <ExpConcatOrWhere e.tokens_rest>;
  e.tokens : (IDENTIFIER e) e = <Parse (e.tokens) (IDENT (Get &Identifier) (Get &ExpVarOrFunc)) (Get &ExpConcatOrWhere)>;
  e.tokens : (LPAR e) e.tokens_rest = <Parse (e.tokens_rest) (PAREN (Get &ExpWithWhere)) (Skip RPAR) (Get &ExpConcatOrWhere)>;
  e.tokens : (IF e) e.tokens_rest =
     <Parse (e.tokens_rest) (IF ((Get &ExpWithWhere)) (Skip THEN) ((Get &ExpWithWhere)) (Skip ELSE) ((Get &ExpWithWhere)))>;
  <Error (e.tokens) "expected a constant, or an identifier, or '(', or 'if', or 'undefined'">;
};

$func ExpWithWhereOrUndef e.tokens = e.ast (e.tokens);
ExpWithWhereOrUndef e.tokens = {
  e.tokens : (UNDEFINED e) = (UNDEFINED);
  e.tokens : \{ (IDENTIFIER e) e;  (IF e) e; (LPAR e) e; (STRING e) e; } = <ExpWithWhere e.tokens>;
};

$func ExpVarOrFunc e.tokens = e.ast (e.tokens);
ExpVarOrFunc e.tokens = {
  e.tokens : \{ (COMMA e) e; (CONCAT e) e; (ELSE e) e; (RPAR e) e; (SC e) e; (THEN e) e; (WHERE e) e; } = VAR (e.tokens);
  e.tokens : (LPAR e) e.tokens_rest = <Parse (e.tokens_rest) CALL (Get &ArgList) (Skip RPAR)>;
  <Error (e.tokens)>;
};

$func ArgList e.tokens = e.ast (e.tokens);
ArgList e.tokens = {
  e.tokens : (RPAR e) e = (e.tokens);
  e.tokens : \{ (IDENTIFIER e) e;  (IF e) e; (LPAR e) e; (STRING e) e; } =
    <Parse (e.tokens) ((Get &Exp)) (Get &ArgListRest)>;
  <Error (e.tokens) "expected a function argument or ')'">;
};

$func ArgListRest e.tokens = e.ast (e.tokens);
ArgListRest e.tokens = {
  e.tokens : (RPAR e) e = (e.tokens);
  e.tokens : (COMMA e) e.tokens_rest = <Parse (e.tokens_rest) ((Get &Exp)) (Get &ArgListRest)>;
  <Error (e.tokens) "expected ',' or ')'">;
};

$func ExpConcat e.tokens = e.ast (e.tokens);
ExpConcat e.tokens = {
  e.tokens : \{ (COMMA e) e; (ELSE e) e; (RPAR e) e; (SC e) e; (THEN e) e; } = (e.tokens);
  e.tokens : (CONCAT e) e.tokens_rest = <Exp e.tokens_rest>;
  <Error (e.tokens)>;
};

$func ExpConcatOrWhere e.tokens = e.ast (e.tokens);
ExpConcatOrWhere e.tokens = {
  e.tokens : \{ (ELSE e) e; (RPAR e) e; (SC e) e; (THEN e) e; } = (e.tokens);
  e.tokens : (CONCAT e) e.tokens_rest = <ExpWithWhere e.tokens_rest>;
  e.tokens : (WHERE e) e.tokens_rest = <Parse (e.tokens_rest) (WHERE (Get &VarassignList))>;
  <Error (e.tokens)>;
};

$func VarassignList e.tokens = e.ast (e.tokens);
VarassignList e.tokens = {
  e.tokens : (IDENTIFIER e) e = <Parse (e.tokens) ((VAR (Get &Identifier)) (Skip EQ) (Get &Exp)) (Get &VarassignRest)>;
  <Error (e.tokens) "expected a variable name">;  
};

$func VarassignRest e.tokens = e.ast (e.tokens);
VarassignRest e.tokens = {
  e.tokens : \{ (ELSE e) e; (RPAR e) e; (SC e) e; (THEN e) e; } = (e.tokens);
  e.tokens : (COMMA e) e.tokens_rest = <VarassignList e.tokens_rest>;
  <Error (e.tokens)>;
};

$func Identifier e.tokens = e.ast (e.tokens);
Identifier {
  (IDENTIFIER e.ident t.pos) e.tokens = (e.ident) (e.tokens);
  e.tokens = <Error (e.tokens) "expected an identifier">;
};