{-
-----------------------------------------------------------------------------
-$Id: Parser.y,v 1.2 1999/06/02 14:42:43 simonmar Exp $
+$Id: Parser.y,v 1.12 1999/07/27 07:31:18 simonpj Exp $
Haskell grammar.
import SrcLoc ( SrcLoc )
import Module
import CallConv
+import CmdLineOpts ( opt_SccProfilingOn )
import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..) )
import Panic
{-
-----------------------------------------------------------------------------
-Conflicts: 13 shift/reduce
+Conflicts: 14 shift/reduce
8 for abiguity in 'if x then y else z + 1'
(shift parses as 'if x then y else (z + 1)', as per longest-parse rule)
This saves explicitly defining a grammar for the rule lhs that
doesn't include 'forall'.
+1 for ambiguity in 'x @ Rec{..}'.
+ Only sensible parse is 'x @ (Rec{..})', which is what resolving
+ to shift gives us.
+
-----------------------------------------------------------------------------
-}
'then' { ITthen }
'type' { ITtype }
'where' { ITwhere }
+ '_scc_' { ITscc }
'forall' { ITforall } -- GHC extension keywords
'foreign' { ITforeign }
'__litlit' { ITlit_lit }
'__string' { ITstring_lit }
'__ccall' { ITccall $$ }
- '__scc' { ITscc }
+ '__scc' { IT__scc }
'__sccC' { ITsccAllCafs }
'__A' { ITarity }
[ RdrSig (Sig n $4 $2) | n <- $1 ] }
sigtype :: { RdrNameHsType }
- : ctype { case $1 of
- HsForAllTy _ _ _ -> $1
- other -> HsForAllTy Nothing [] $1 }
+ : ctype { mkHsForAllTy Nothing [] $1 }
{-
ATTENTION: Dirty Hackery Ahead! If the second alternative of vars is var
: ctype {% checkInstType $1 }
ctype :: { RdrNameHsType }
- : 'forall' tyvars '.' btype '=>' type
- {% checkContext $4 `thenP` \c ->
- returnP (HsForAllTy (Just $2) c $6) }
- | 'forall' tyvars '.' type { HsForAllTy (Just $2) [] $4 }
- | btype '=>' type {% checkContext $1 `thenP` \c ->
- returnP (HsForAllTy Nothing c $3) }
+ : 'forall' tyvars '.' context type
+ { mkHsForAllTy (Just $2) $4 $5 }
+ | 'forall' tyvars '.' type { mkHsForAllTy (Just $2) [] $4 }
+ | context type { mkHsForAllTy Nothing $1 $2 }
+ -- A type of form (context => type) is an *implicit* HsForAllTy
| type { $1 }
types0 :: { [RdrNameHsType] }
: constrs '|' constr { $3 : $1 }
| constr { [$1] }
-{- ToDo: existential stuff -}
-
constr :: { RdrNameConDecl }
- : srcloc scontype
- { ConDecl (fst $2) [] [] (VanillaCon (snd $2)) $1 }
- | srcloc sbtype conop sbtype
- { ConDecl $3 [] [] (InfixCon $2 $4) $1 }
- | srcloc con '{' fielddecls '}'
- { ConDecl $2 [] [] (RecCon (reverse $4)) $1 }
+ : srcloc forall context constr_stuff
+ { ConDecl (fst $4) $2 $3 (snd $4) $1 }
+ | srcloc forall constr_stuff
+ { ConDecl (fst $3) $2 [] (snd $3) $1 }
+
+forall :: { [RdrNameHsTyVar] }
+ : 'forall' tyvars '.' { $2 }
+ | {- empty -} { [] }
+
+context :: { RdrNameContext }
+ : btype '=>' {% checkContext $1 }
+
+constr_stuff :: { (RdrName, RdrNameConDetails) }
+ : scontype { (fst $1, VanillaCon (snd $1)) }
+ | sbtype conop sbtype { ($2, InfixCon $1 $3) }
+ | con '{' fielddecls '}' { ($1, RecCon (reverse $3)) }
newconstr :: { RdrNameConDecl }
: srcloc conid atype { ConDecl $2 [] [] (NewCon $3 Nothing) $1 }
| '_casm_' CLITLIT aexps0 { CCall $2 $3 False True cbot }
| '_casm_GC_' CLITLIT aexps0 { CCall $2 $3 True True cbot }
+ | '_scc_' STRING exp { if opt_SccProfilingOn
+ then HsSCC $2 $3
+ else HsPar $3 }
+
| fexp { $1 }
ccallid :: { FAST_STRING }
| '[' list ']' { $2 }
| '(' infixexp qop ')' { SectionL $2 $3 }
| '(' qopm infixexp ')' { SectionR $2 $3 }
- | qvar '@' aexp1 { EAsPat $1 $3 }
+ | qvar '@' aexp { EAsPat $1 $3 }
| '_' { EWildPat }
| '~' aexp1 { ELazyPat $2 }
-- Statement sequences
stmtlist :: { [RdrNameStmt] }
- : '{' stmts '}' { reverse $2 }
- | layout_on stmts close { reverse $2 }
+ : '{' stmts '}' { $2 }
+ | layout_on_for_do stmts close { $2 }
+-- Stmt list must end in an expression
+-- thought the H98 report doesn't currently say so in the syntax
stmts :: { [RdrNameStmt] }
- : stmts ';' stmt { $3 : $1 }
- | stmts ';' { $1 }
- | stmt { [$1] }
- | {- empty -} { [] }
+ : stmts1 srcloc exp { reverse (ExprStmt $3 $2 : $1) }
+
+-- A list of zero or more stmts, ending in semicolon
+-- Returned in *reverse* order
+stmts1 :: { [RdrNameStmt] }
+ : stmts1 stmt ';' { $2 : $1 }
+ | stmts1 ';' { $1 }
+ | { [] }
stmt :: { RdrNameStmt }
: srcloc infixexp '<-' exp {% checkPattern $2 `thenP` \p ->
: vccurly { () } -- context popped in lexer.
| error {% popContext }
-layout_on :: { () } : {% layoutOn }
+layout_on :: { () } : {% layoutOn True{-strict-} }
+layout_on_for_do :: { () } : {% layoutOn False }
-----------------------------------------------------------------------------
-- Miscellaneous (mostly renamings)