-----------------------------------------------------------------------------
$Id: ErlParser.ly,v 1.2 1997/09/24 10:11:23 simonm Exp $

Syntactic analyser for Erlang

Copyright : (c) 1996 Ellemtel Telecommunications Systems Laborotories, Sweden
Author    : Simon Marlow <simonm@dcs.gla.ac.uk>
-----------------------------------------------------------------------------

> {
> module Parser (parse) where
> import GenUtils
> import Lexer
> import AbsSyn
> import Types
> import ParseMonad
> }

> %token
> 	atom		{ T_Atom $$ }
> 	var		{ T_Var $$ }
>	int		{ T_Int $$ }
>	float		{ T_Float $$ }
>	string		{ T_String $$ }

> 	'bor'		{ T_Bor }
> 	'bxor'		{ T_Bxor }
>	'bsl'		{ T_Bsl }
>	'bsr'		{ T_Bsr }
>	'div'		{ T_Div }
>	'rem'		{ T_Rem }
>	'band'		{ T_Band }
>	'bnot'		{ T_Bnot }
>	'begin'    	{ T_Begin }
>	'end'    	{ T_End }
>	'catch'    	{ T_Catch }
>	'case'    	{ T_Case }
>	'of'    	{ T_Of }
>	'if'    	{ T_If }
>	'receive'    	{ T_Receive }
>	'after'    	{ T_After }
>	'when'    	{ T_When }
>	'fun'		{ T_Fun }
>	'true'    	{ T_True }
>	'deftype'	{ T_DefType }
>	'type'		{ T_Type }

> 	'+'		{ T_Plus }
> 	'-'		{ T_Minus }
> 	'*'		{ T_Mult }
> 	'/'		{ T_Divide }
> 	'=='		{ T_Eq }
> 	'/='		{ T_Neq }
> 	'=<'		{ T_Leq }
> 	'<'		{ T_Lt }
> 	'>='		{ T_Geq }
> 	'>'		{ T_Gt }
> 	'=:='		{ T_ExactEq }
> 	'=/='		{ T_ExactNeq } 

> 	'!'		{ T_Pling }
> 	'='		{ T_Equals }
> 	'['		{ T_LSquare }
> 	']'		{ T_RSquare }
> 	'('		{ T_LParen }
> 	')'		{ T_RParen }
> 	'{'		{ T_LCurly }
> 	'}'		{ T_RCurly }
> 	','		{ T_Comma }
> 	';'		{ T_SemiColon }
> 	'|'		{ T_Bar }
> 	':'		{ T_Colon }
> 	'->'		{ T_Arrow }
> 	'.'		{ T_Dot }
>	'\\'		{ T_BackSlash }

>	header_prog	{ T_Prog }
>	header_iface	{ T_Interface }

> %monad { P } { thenP } { returnP }
> %lexer { lexer } { T_EOF }
> %name parse
> %tokentype	{ Token }

> %%

> parse :: { ProgOrInterface }
> 	: header_prog program		{ It's_a_prog   $2 }
> 	| header_iface interface	{ It's_an_iface $2 }

> program :: { [Form] }
> 	: 				{ [] }
>	| form program			{ $1 : $2 }

> add_op :: { BinOp }
> 	: '+'				{ O_Add }
>	| '-'				{ O_Subtract }
>	| 'bor'				{ O_Bor }
>	| 'bxor'			{ O_Bxor }
>	| 'bsl'				{ O_Bsl }
>	| 'bsr'				{ O_Bsr }

> comp_op :: { CompOp }
> 	: '=='				{ O_Eq }
>	| '/='				{ O_Neq }
>	| '=<'				{ O_Leq }
>	| '<'				{ O_Lt }
>	| '>='				{ O_Geq }
>	| '>'				{ O_Gt }
>	| '=:='				{ O_ExactEq }
>	| '=/='				{ O_ExactNeq }

> mult_op :: { BinOp }
> 	: '*'				{ O_Multiply }
>	| '/'				{ O_Divide }
>	| 'div'				{ O_Div }
>	| 'rem'				{ O_Rem }
>	| 'band'			{ O_Band }

> prefix_op :: { UnOp }
> 	: '+'				{ O_Plus }
>	| '-'				{ O_Negate }
>	| 'bnot'			{ O_Bnot }

> basic_type :: { Expr }
> 	: atm				{ E_Atom $1 }
>	| int				{ E_Int $1 }
>	| float				{ E_Float $1 }
>	| string		{ foldr E_Cons E_Nil (map (E_Int . ord) $1) }
>	| var				{ E_Var $1 }

> pattern :: { Expr }
> 	: basic_type			{ $1 }
>	| '[' ']'			{ E_Nil }
>	| '[' pattern pat_tail ']'	{ E_Cons $2 $3 }
>	| '{' '}'			{ E_Tuple [] }
>	| '{' patterns '}'		{ E_Tuple $2 }
>	| atm '{' patterns '}'		{ E_Struct $1 $3 }

> pat_tail :: { Expr }
> 	: '|' pattern			{ $2 }
>	| ',' pattern pat_tail		{ E_Cons $2 $3 }
>	|				{ E_Nil }

> patterns :: { [ Expr ] }
> 	: pattern			{ [ $1 ] }
>	| pattern ',' patterns		{ $1 : $3 }

> expr :: { Expr }
>	: 'catch' expr			{ E_Catch $2 }
>	| 'fun' '(' formal_param_list ')' '->' expr 'end' { E_Fun $3 $6 }
>	| 'fun' var '/' int		{ E_FunName (LocFun $2 $4) }
>	| 'fun' var ':' var '/' int	{ E_FunName (ExtFun $2 $4 $6) }
>	| expr200			{ $1 }

> expr200 :: { Expr }
>	: expr300 '=' expr		{ E_Match $1 $3 }
>	| expr300 '!' expr		{ E_Send $1 $3 }
>	| expr300			{ $1 }

> expr300 :: { Expr }
> 	: expr300 add_op expr400	{ E_BinOp $2 $1 $3 }
>	| expr400			{ $1 }

> expr400 :: { Expr }
> 	: expr400 mult_op expr500	{ E_BinOp $2 $1 $3 }
>	| expr500			{ $1 }

> expr500 :: { Expr }
> 	: prefix_op expr0		{ E_UnOp $1 $2 }
>	| expr0				{ $1 }

> expr0 :: { Expr }
> 	: basic_type				{ $1 }
> 	| '[' ']'				{ E_Nil }
>	| '[' expr expr_tail ']'		{ E_Cons $2 $3 }
>	| '{' maybeexprs '}'			{ E_Tuple $2 }
>	| atm '{' maybeexprs '}'		{ E_Struct $1 $3 }
> 	| atm '(' maybeexprs ')'  { E_Call (LocFun $1 (length $3)) $3 }
>	| atm ':' atm '(' maybeexprs ')' 
>				  { E_Call (ExtFun $1 $3 (length $5)) $5 }
>	| '(' expr ')'				{ $2 }
>	| 'begin' exprs 'end'			{ E_Block $2 }
>	| 'case' expr 'of' cr_clauses 'end'  	{ E_Case $2 $4 }
>	| 'if' if_clauses 'end'			{ E_If $2 }
> 	| 'receive' 'after' expr '->' exprs 'end'
>					{ E_Receive [] (Just ($3,$5)) }
>	| 'receive' cr_clauses 'end'	{ E_Receive $2 Nothing }
>	| 'receive' cr_clauses 'after' expr '->' exprs 'end'
>					{ E_Receive $2 (Just ($4,$6)) }

> expr_tail :: { Expr }
> 	: '|' expr			{ $2 }
>	| ',' expr expr_tail		{ E_Cons $2 $3 }
>	| 				{ E_Nil }

> cr_clause :: { CaseClause }
> 	: expr clause_guard '->' exprs 	{ ($1,$2,$4) }

> clause_guard :: { [ GuardTest ] }
> 	: 'when' guard			{ $2 }
>	|				{ [] }

> cr_clauses :: { [ CaseClause ] }
> 	: cr_clause			{ [ $1 ] }
>	| cr_clause ';' cr_clauses	{ $1 : $3 }

> if_clause :: { IfClause }
> 	: guard '->' exprs		{ ($1,$3) }

> if_clauses :: { [ IfClause ] }
> 	: if_clause			{ [ $1 ] }
>	| if_clause ';' if_clauses	{ $1 : $3 }

> maybeexprs :: { [ Expr ] }
>	: exprs				{ $1 }
>	|				{ [] }

> exprs :: { [ Expr ] }
> 	: expr				{ [ $1 ] }
>	| expr ',' exprs		{ $1 : $3 }

> guard_test :: { GuardTest }
> 	: atm '(' maybeexprs ')' 	{ G_Bif $1 $3 }
>	| expr300 comp_op expr300       { G_Cmp $2 $1 $3 }

> guard_tests :: { [ GuardTest ] }
> 	: guard_test			{ [ $1 ] }
>	| guard_test ',' guard_tests	{ $1 : $3 }

> guard :: { [ GuardTest ] }
> 	: 'true'			{ [] }
>	| guard_tests			{ $1 }

> function_clause :: { FunctionClause }
> 	: atm '(' formal_param_list ')' clause_guard '->' exprs
>					{ (LocFun $1 (length $3),$3,$5,$7) }

> formal_param_list :: { [ Expr ] }
>	:				{ [] }
> 	| patterns			{ $1 }

> function :: { Function }
> 	: function_clause		{ [ $1 ] }
>	| function_clause ';' function	{ $1 : $3 }

> attribute :: { Attribute }
> 	: pattern			{ A_Pat $1 }
>	| '[' farity_list ']'		{ A_Funs $2 }
>	| atm ',' '[' maybe_farity_list ']'	{ A_AtomAndFuns $1 $4 }

> maybe_farity_list :: { [ Fun ] }
> 	: farity_list			{ $1 }
>	| 				{ [] }

> farity_list :: { [ Fun ] }
> 	: farity			{ [ $1 ] }
>	| farity ',' farity_list	{ $1 : $3 }

> farity :: { Fun }
> 	: atm '/' int			{ LocFun $1 $3 }

> form :: { Form }
> 	: '-' atm '(' attribute ')' '.'  { F_Directive $2 $4 }
>	| '-' 'type' sigdef '.'		 { $3 }
>	| '-' 'deftype' deftype '.'	 { $3 }
>	| function '.'			 { F_Function $1 }

> abstype :: { Form }
>	: atm '(' maybetyvars ')' maybeconstraints	
>		{ F_AbsTypeDef (Tycon $1 (length $3)) $3 (snd $5) }

> deftype :: { Form }
> 	: atm '(' maybetyvars ')' '=' utype maybeconstraints
>		{ F_TypeDef (Tycon $1 (length $3)) $3 $6 (fst $7) (snd $7) }

> sigdef :: { Form }
> 	: atm '(' maybeutypes ')' '->' utype maybeconstraints
>		{ F_TypeSig  ($1,length $3) $3 $6 (fst $7) (snd $7) }

> header :: { (String,Int,[UType]) }
>	 : atm '(' maybeutypes ')'		{ ($1, length $3, $3) }

> tycon_args :: { [ TyVar ] }
>	: tycon_args ',' var			{ STyVar $3 : $1 }
> 	| var					{ [ STyVar $1 ] }

-----------------------------------------------------------------------------
Interfaces & Types

> interface :: { (Module, [ Form ]) }
> 	: '-' atm '(' atm ')' '.' signatures
>					{ ($4, $7) }

> signatures :: { [ Form ] }
> 	: signatures typedef '.'	{ $2 : $1 }
>	|				{ [] }

> typedef :: { Form }
> typedef
>	: '-' 'deftype' deftype		{ $3 }
>	| '-' 'deftype' abstype		{ $3 }
>	| sigdef			{ $1 }

> maybeconstraints :: { ([Constraint], [VarConstraint]) }
> 	: 'when' constraints 		{ splitConstraints $2 }
>	|				{ ([],[]) }

> constraints :: { [ VarOrTypeCon ] }
> 	: constraints ';' constraint	{ $1 ++ $3 }
>	| constraint			{ $1 }

> constraint :: { [ VarOrTypeCon ] }
> 	: utype '<' '=' utype		{ [TypeCon ($1,$4)] }
>	| utype '=' utype		{ [TypeCon ($1,$3),TypeCon($3,$1)] }
>	| var '\\' tags			{ [VarCon (STyVar $1,(canonTags $3))] }

> maybeutypes :: { [ UType ] }
>	: utypes			{ reverse $1 }
>	|				{ [] }

> utypes :: { [ UType ] }
> 	: utypes ',' utype		{ $3 : $1 }
>	| utype				{ [$1] }

> maybetyvars :: { [ TyVar ] }
>	: tyvars			{ reverse $1 }
>	|				{ [] }

> tyvars :: { [ TyVar ] }
>	: tyvars ',' var		{ STyVar $3 : $1 }
>	| var				{ [ STyVar $1 ] }

> utype :: { UType }
> 	: ptypes			{ U (reverse $1) [] }
>	| ptypes '|' tyvar		{ U (reverse $1) [$3] }
>	| tyvar				{ U [] [$1] }
>	| '(' utype ')'			{ $2 }
>	| '(' ')'			{ U [] [] }

> tyvar :: { TaggedTyVar }
> 	: var				{ TyVar [] (STyVar $1) }
>	| int				{ if $1 /= 1 then
>						error "Illegal type variable"
>					  else universalTyVar }
>	| int '\\' tags			{ if $1 /= 1 then
>						error "Illegal type variable"
>					  else partialUniversalTyVar $3 }

> ptypes :: { [ PType ] }
> 	: ptypes '|' ptype		{ $3 : $1 }
> 	| ptype				{ [$1] }

> ptype :: { PType }
> 	: atm '(' ')'			{ conToType $1 [] }
>	| atm '(' utypes ')'		{ conToType $1 (reverse $3) }
> 	| atm				{ TyAtom $1 }
>	| '{' utypes '}'		{ tytuple (reverse $2) }
>	| atm '{' maybeutypes '}'	{ TyStruct $1 $3 }
>	| '[' utype ']'			{ tylist $2 }

> taglist :: { [ Tag ] }
> 	: taglist ',' tag		{ $3 : $1 }
> 	| tag				{ [ $1 ] }

> tags  :: { [ Tag ] }
>	: tag				{ [ $1 ] }
>	| '(' taglist ')'		{ $2 }

> tag	:: { Tag }
>  	: atm '(' ')'			{ conToTag $1 }
> 	| atm				{ TagAtom $1 }
>	| atm '/' int			{ TagStruct $1 $3 }
>	| '{' int '}'			{ tagtuple $2 }
>	| '[' ']'			{ taglist }

Horrible - keywords that can be atoms too.

> atm	:: { String }
> 	: atom				{ $1 }
> 	| 'true'			{ "true" }
>	| 'deftype'			{ "deftype" }
>	| 'type'			{ "type" }

> {
> utypeToVar (U [] [TyVar [] x]) = x
> utypeToVar _ = error "Type constructor arguments must be variables\n"

> happyError :: P a
> happyError s line = failP (show line ++ ": Parse error\n") s line
> }