-- A Cactus representation of the Haskell grammar from the Haskell 98 report,
-- starting with the Context-Free Syntax from appendix B.4, followed by
-- rules from Lexical Syntax from appendix B.2.
-- (Haskell layout rules are not represented.)

-- B.4 Context-Free Syntax -----------------------------------------------------

%start = modul

modul = Module.. ::= "module" modid exportspec? "where" body ;

body = ..      ::= '{' impdecls ';' topdecls '}'
     | (is,[]) ::= '{' impdecls:is '}'
     | ([],ts) ::= '{' topdecls:ts '}'
     ;

impdecls = $1:$2 ::= impdecl (';' impdecl)* ;

exportspec ::= '(' exports ')' ; -- should allow a trailing comma!

exports = []    ::= 
        | $1:$2 ::= export (',' export)*
        ;

export = ExportQVar..   ::= qvar
       | ExportType..   ::= qtycon exportdetails -- type or class
       | ExportModule.. ::= "module" modid
       ;

exportdetails ::= details ;

details :: Details
        = NoDetails         ::=
        | AllDetails        ::= '(' ".." ')'
        | SpecificDetails.. ::= '(' qcname* ')'
        ;

qcname :: Id ::= qvar | qcon ;

impdecl = Import.. ::= "import" "qualified"? modid ("as" modid)? impspec? ;

impspec ::= '(' imports ')' ; -- should allow a trailing comma!

imports = []    ::= 
        | $1:$2 ::= import (',' import)*
        ;

import = ImportVar..  ::= var
       | ImportType.. ::= tycon importdetails -- type or class
       ;

importdetails ::= details ; -- except that qualified names aren't allowed

-- cname ::= var | con ;

topdecls = $1:$2 ::= topdecl (';' topdecl)* ;

topdecl :: Decl
  = Type..     ::= "type"     simpletype '=' type
  | Data..     ::= "data"     optcontext simpletype '=' constrs deriving?
  | Newtype..  ::= "newtype"  optcontext simpletype '=' newconstr deriving?
  | Class..    ::= "class"    optscontext tycls tyvar ("where" cdecls)?
  | Instance.. ::= "instance" optscontext qtycls inst ("where" idecls)?
  | Default..  ::= "default" '(' defaults ')'
  | ..         ::= decl
  ;

optcontext = [] ::=
           | .. ::= context "=>"
           ;

optscontext = [] ::=
            | .. ::= scontext "=>"
            ;

defaults = []    ::=
         | $1:$2 ::= type (',' type)*
         ;

decls = []    ::= '{' '}'
      | $2:$3 ::= '{' decl (';' decl)* '}'
      ;

decl  = ..        ::= gendecl
      | FunDecl.. ::= funlhs rhs
      | PatDecl.. ::= pat0n rhs
      ;

cdecls = []    ::=
       | $1:$2 ::= cdecl (';' cdecl)*
       ;

cdecl  ::= decl ; -- except that pat0n is restricted to var

idecls = []    ::= '{' '}'
      | $2:$3 ::= '{' idecl (';' idecl)* '}'
      ;

idecl  = FunDecl.. ::= funlhs rhs
       | FunDecl.. ::= qfunlhs rhs
       | PatDecl.. ::= pvar rhs
       | PatDecl.. ::= pqvar rhs
       ;
pvar = VarPat.. ::= var ;
pqvar = VarPat.. ::= qvar ;

gendecl = TypeSig.. ::= vars "::" qualtype
        | Fixity..  ::= fixity integer? ops
        ;

qualtype = QualType.. ::= optcontext type ;

ops = $1:$2 ::= op (',' op)* ;
vars = $1:$2 ::= var (',' var)* ;

fixity = InfixL ::= "infixl"
       | InfixR ::= "infixr"
       | Infix  ::= "infix"
       ;

type  :: Type
      = FunType.. ::= btype "->" type
      | ..        ::= btype
      ;

btype = AppType.. ::= btype atype
      | ..        ::= atype
      ;

atype = ConType.. ::= gtycon
      | VarType.. ::= tyvar
      | TupleType (type1:type2:ts) ::= '(' type ',' type (',' type)*:ts ')'
      | ListType.. ::= '[' type ']'
      | ..         ::= '(' type ')'
      ;

gtycon = GTycon..  ::= qtycon
       | UnitTycon ::= '(' ')'
       | ListTycon ::= '[' ']'
       | FunTycon  ::= '(' "->" ')'
--     | TupleTycon.. ::= '(' ','+ ')'
       ;

-- %type Context = [Class]

context = [type] ::= type ; -- hmm
--context :: Context
--        = [$1]  ::= class
--        | []    ::= '(' ')'
--        | $2:$3 ::= '(' class (',' class)* ')'
--        ;

--class   :: Class
--        = ConClass.. ::= qtycls tyvar
--        | VarClass.. ::= qtycls '(' tyvar atype+ ')'
--       ;

scontext = [type] ::= type ;
--scontext = [$1]  ::= simpleclass
--         | []    ::= '(' ')'
--         | $2:$3 ::= '(' simpleclass (',' simpleclass)* ')'
--         ;

--simpleclass = ConClass.. ::= qtycls tyvar ;

simpletype = SimpleType.. ::= tycon tyvar* ;

constrs = $1:$2 ::= constr ('|' constr)* ;

constr = Constr.. ::= con (strictness atype)*
       | Constr(conop,[l,r]) ::= conoptype:l conop conoptype:r
       | ConstrFields.. ::= con '{' fielddecls '}'
       ;

strictness = Strict ::= '!'
           | Lazy   ::= 
           ;

conoptype = (Lazy,  btype) ::= btype
          | (Strict,atype) ::= '!' atype
          ;

fielddecls = [] ::=
           | $1:$2 ::= fielddecl (',' fielddecl)*
           ;

newconstr = NewConstr.. ::= con atype
          | NewConstrField.. ::= con '{' var "::" type '}'
          ;

fielddecl ::= vars "::" fieldtype ;

fieldtype = (Lazy,  type ) ::= type
          | (Strict,atype) ::= '!' atype
          ;

deriving ::= "deriving" dclasses ;

dclasses = [] ::=
         | [$1] ::= dclass
         | [] ::= '(' ')'
         | $2:$3 ::= '(' dclass (',' dclass)* ')'
         ;

dclass ::= qtycls ;

inst = ConInst($1,[]) ::= gtycon
     | ConInst..      ::= '(' gtycon tyvar* ')'
     | TupleInst(tyvar1:tyvar2:ts) ::= '(' tyvar ',' tyvar (',' tyvar)*:ts ')'
     | ListInst..     ::= '[' tyvar ']'
     | FunInst..      ::= '(' tyvar "->" tyvar ')'
     ;

funlhs = .. ::= var apat+
       | (varop,[l,r])  ::= pat0n:l varop pat0n:r
--     | (f,as++apat)   ::= '(' funlhs:(f,as) ')' apat+
       ;

qfunlhs = .. ::= qvar apat+
        | (qvarop,[l,r])                ::= pat0n:l qvarop pat0n:r
--      | (fst funlhs,snd funlhs++apat) ::= '(' qfunlhs ')' apat+
        ;

rhs = Rhs..   ::= '=' exp wheredecls
    | GdRhs.. ::= gdrhs wheredecls
    ;

wheredecls = [] ::=
           | .. ::= "where" decls
           ;

gdrhs ::= (gd '=' exp)+ ;

gd ::= '|' exp0n ;

exp :: Exp
    = TypedExp.. ::= exp0n "::" qualtype
    | ..         ::= exp0n
    ;

%left.6 = '-'
%left.1 = "::"
%left.0 = "in", "else", "->"

exp0n = OpExp..  ::= exp0n qop exp0n %prec '-'
      | NegExp.. ::= '-' exp0n
      | ..       ::= exp10n
      ;

exp10n = Lambda.. ::= '\\' pat+ "->" exp
       | Let..    ::= "let" decls "in" exp
       | If..     ::= "if" exp "then" exp "else" exp
       | Case..   ::= "case" exp "of" '{' alts '}'
       | Do..     ::= "do" '{' stmts '}'
       | ..       ::= fexp
       ;

fexp  = App..    ::= fexp aexp
      | ..       ::= aexp
      ;

aexp  = VarExp..                 ::= qvar
      | ConExp..                 ::= gcon
      | Lit..                    ::= literal
      | ParenExp..               ::= '(' exp ')'
      | TupleExp(exp1:exp2:es)   ::= '(' exp ',' exp (',' exp)*:es ')'
      | ListExp(exp1:es)         ::= '[' exp (',' exp)*:es ']'
      | Seq..                    ::= '[' exp (',' exp)? ".." exp? ']'
      | LSection..               ::= '(' exp0n qop ')'
      | RSection..               ::=  '(' qop exp0n ')'
      | FieldUpd..               ::= aexp '{' fbinds '}'
      ;

qual :: Qual
     = GenQual.. ::= exp "<-" exp
--   = GenQual.. ::= pat "<-" exp -- wanted...
     | LetQual.. ::= "let" decls
     | GdGual..  ::= exp
     ;

alts = []    ::= 
     | $1:$2 ::= alt (';' alt)*
     ;

alt  = Alt..   ::= pat "->" exp wheredecls
     | GdAlt.. ::= pat gdpat wheredecls
--   | Empty   ::=
     ;

gdpat ::= (gd "->" exp)+ ;

stmts ::= stmt* exp ';'?:_ ;

stmt ::= qual ';' ;

fbinds = []    ::=
       | $1:$2 ::= fbind (',' fbind)*
       ;

fbind ::= qvar '=' exp ;

pat :: Pat
    ::= pat0n ;
    -- n+k

pat0n = OpPat.. ::= pat0n qconop pat0n %prec '-'
     | NegPat.. ::= '-' pat0n
     | ..       ::= pat10n
     ;

pat10n = .. ::= apat
      | ConPat.. ::= gcon apat+
      ;

apat = VarPat..                 ::= var
     | As..                     ::= var '@' apat
     | ConPat(gcon,[])          ::= gcon
     | FieldPat..               ::= qcon '{' fpats '}'
     | LitPat..                 ::= literal
     | Wildcard                 ::= '_'
     | ParenPat..               ::= '(' pat ')'
     | TuplePat(pat1:pat2:ps)   ::= '(' pat ',' pat (',' pat)*:ps ')'
     | ListPat(pat1:ps)         ::= '[' pat (',' pat)*:ps ']'
     | IrrPat..                 ::= '~' apat
     ;

fpats = []    ::=
      | $1:$2 ::= fpat (',' fpat)*
      ;

fpat ::= qvar '=' pat ;

gcon = UnitCon ::= '(' ')'
     | NilCon  ::= '[' ']'
--   | TupleCon.. ::= '(' ','+ ')'
     | QCon.. ::= qcon
     ;

var    :: Id
       = Id..        ::= varid 
       | SymId..     ::= '(' varsym ')' ;
qvar   = QId..       ::= qvarid
       | QdSymId..   ::= '(' qvarsym ')' ;
con    :: Id
       = ConId..     ::= conid
       | ConsymId..  ::= '(' consym ')' ;
qcon   = QConId..    ::= qconid
       | QConsymId.. ::= '(' gconsym ')' ;
varop  = Op..        ::= varsym
       | IdOp..      ::= '`' varid '`' ;
qvarop = QOp..       ::= qvarsym
       | QIdOp..     ::= '`' qvarid '`' ;
conop  = ConOp..     ::= consym
       | ConIdOp..   ::='`' conid '`' ;
qconop = QConOp..    ::= gconsym
       | QConIdOp..  ::='`' qconid '`' ;
op     ::= varop | conop ;
qop :: Id ::= qvarop | qconop ;
gconsym ::= ":" | qconsym ;

------------------------------------------------------------------------------
modid  = ModId..  ::= conid ;
qtycon = QTycon.. ::= qconid ;
tycon  = Tycon..  ::= conid ;
tyvar  = Tyvar..  ::= varid ;
tycls  = Tycls..  ::= conid ;
qtycls :: QTycls
       = QTycls.. ::= qconid ;

literal ::= integer | float | char | string
-------------------------------------------------------------------------------

-- %type Id = String

.qconid = (Cid ".")? Cid
.conid = Cid
!Cid = Large (Small|Large|Digit|"'")*
.qvarid = (Cid ".")? Id
.varid = Id
!Id = Small (Small|Large|Digit|"'")*
.qvarsym = (Cid ".")? Varsy
.varsym = Varsy
!Varsy = Symbol (Symbol | ':')*
.qconsym = (Cid ".")? Consy
.consym = Consy
!Consy = ':'  (Symbol | ':')*
.integer = Decimal | "0"["oO"]Octal | "0"["xX"]Hexadecimal
!Octal =['0'..'7']+
!Hexadecimal = Hexit+
!Hexit = Digit|['A'..'F''a'..'f']
.float = Decimal "." Decimal(["eE"]["+-"]? Decimal)?

!Decimal = Digit+
!Large = AscLarge -- ...
!AscLarge = ['A'..'Z']
!Small = ['a'..'z']
!Digit = ['0'..'9']
!Symbol = ["!#$%&*+./<=>?@\\^|-~"]
!Special = ["(),;[]`{}"]
!Graphic = Small | Large | Symbol | Digit | Special | ':' | '"' | "'"

.char = "'" (Graphic-["'\\"] | Space | Escape) "'"
.string = '"' (Graphic-['"''\\'] | Space | Escape | Gap)* '"'
!Charesc = ["abfnrtv\\\"'&"]
!Whitechar = ["\n\r\v\f \t"]
!Space = ' '
!Ascii = '^'Cntrl | "NUL" | "SOH" | "STX" | "ETX" | "EOT" | "ENQ" | "ACK"
        | "BEL" | "BS" | "HT" | "LF" | "VT" | "FF" | "CR" | "SO" | "SI" | "DLE"
        | "DC1" | "DC2" | "DC3" | "DC4" | "NAK" | "SYN" | "ETB" | "CAN"
        | "EM" | "SUB" | "ESC" | "FS" | "GS" | "RS" | "US" | "SP" | "DEL"
!Escape = '\\' (Charesc | Ascii | Decimal | 'o' Octal | 'x' Hexadecimal)

!Cntrl = AscLarge | ["@[\\]^_"]
!Gap = '\\' Whitechar+ '\\'

.comment        = "--"('-'*)(((.)-Symbol)(.)*)?