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

$use Access Apply StdIO Stream;
$use Lexer;

$func Main = e;
Main =
  <Lexer <Expr_Open
  'dec merge: List*List -> List;'
  'var n: Node;'
  '    l1, l2: List;'
  'def merge (n, l2) = n[]","[]l2 ;'
  '    merge (n[]","[]l1, l2) = scat(n, ",", merge(l1, l2)) ;'
  >> :: e.tokens,
  <WriteLn e.tokens>,
  <WriteLn <Program e.tokens>>;

$func Parse (e.tokens) e.expr = e.ast (e.tokens);
Parse {
  (e.tokens) /*empty*/ = (e.tokens);
  (e.tokens) t.term e.expr = <WriteLn <L 0 e.tokens> PPP 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";
(e1) e2 = <WriteLn Eee (e1) e2>, $fail;};

$public $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 &ExpWithWhere) (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 = (STRING 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 = (STRING e.str) <ExpConcat e.tokens_rest>;
  e.tokens : (UNDEFINED e) e.tokens_rest = (UNDEFINED) <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 = (STRING e.str) <ExpConcatOrWhere e.tokens_rest>;
  e.tokens : (UNDEFINED e) e.tokens_rest = (UNDEFINED) <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 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; (UNDEFINED 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 = (WHERE <VarassignList e.tokens_rest>);
  <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">;
};