{-
-----------------------------------------------------------------------------
-$Id: Parser.y,v 1.1 1999/06/01 16:40:48 simonmar Exp $
+$Id: Parser.y,v 1.16 1999/11/25 10:34:53 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 }
'label' { ITlabel }
'dynamic' { ITdynamic }
'unsafe' { ITunsafe }
+ 'stdcall' { ITstdcallconv }
+ 'ccall' { ITccallconv }
'_ccall_' { ITccall (False, False, False) }
'_ccall_GC_' { ITccall (False, False, True) }
'_casm_' { ITccall (False, True, False) }
'__litlit' { ITlit_lit }
'__string' { ITstring_lit }
'__ccall' { ITccall $$ }
- '__scc' { ITscc }
+ '__scc' { IT__scc }
'__sccC' { ITsccAllCafs }
'__A' { ITarity }
| srcloc 'foreign' 'import' callconv ext_name
unsafe_flag varid_no_unsafe '::' sigtype
- { RdrHsDecl (ForD (ForeignDecl $7 (FoImport $6) $9 $5 $4 $1)) }
+ { RdrHsDecl (ForD (ForeignDecl $7 (FoImport $6) $9 (mkExtName $5 $7) $4 $1)) }
| srcloc 'foreign' 'export' callconv ext_name varid '::' sigtype
- { RdrHsDecl (ForD (ForeignDecl $6 FoExport $8 $5 $4 $1)) }
+ { RdrHsDecl (ForD (ForeignDecl $6 FoExport $8 (mkExtName $5 $6) $4 $1)) }
| srcloc 'foreign' 'label' ext_name varid '::' sigtype
- { RdrHsDecl (ForD (ForeignDecl $5 FoLabel $7 $4
+ { RdrHsDecl (ForD (ForeignDecl $5 FoLabel $7 (mkExtName $4 $5)
defaultCallConv $1)) }
| decl { $1 }
: signdecl { $1 }
| fixdecl { $1 }
| valdef { RdrValBinding $1 }
- | '{-# INLINE' srcloc qvar '#-}' { RdrSig (InlineSig $3 $2) }
- | '{-# NOINLINE' srcloc qvar '#-}' { RdrSig (NoInlineSig $3 $2) }
+ | '{-# INLINE' srcloc opt_phase qvar '#-}' { RdrSig (InlineSig $4 $3 $2) }
+ | '{-# NOINLINE' srcloc opt_phase qvar '#-}' { RdrSig (NoInlineSig $4 $3 $2) }
| '{-# SPECIALISE' srcloc qvar '::' sigtypes '#-}'
{ foldr1 RdrAndBindings
(map (\t -> RdrSig (SpecSig $3 t $2)) $5) }
{ RdrSig (SpecInstSig $4 $2) }
| '{-# RULES' rules '#-}' { $2 }
+opt_phase :: { Maybe Int }
+ : INTEGER { Just (fromInteger $1) }
+ | {- empty -} { Nothing }
+
sigtypes :: { [RdrNameHsType] }
: sigtype { [ $1 ] }
| sigtypes ',' sigtype { $3 : $1 }
[ 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
rule :: { RdrBinding }
: STRING rule_forall fexp '=' srcloc exp
- { RdrHsDecl (RuleD (RuleDecl $1 (error "rule tyvars")
- $2 $3 $6 $5)) }
+ { RdrHsDecl (RuleD (RuleDecl $1 [] $2 $3 $6 $5)) }
rule_forall :: { [RdrNameRuleBndr] }
: 'forall' rule_var_list '.' { $2 }
rule_var_list :: { [RdrNameRuleBndr] }
: rule_var { [$1] }
- | rule_var ',' rule_var_list { $1 : $3 }
+ | rule_var rule_var_list { $1 : $2 }
rule_var :: { RdrNameRuleBndr }
: varid { RuleBndr $1 }
- | varid '::' ctype { RuleBndrSig $1 $3 }
+ | '(' varid '::' ctype ')' { RuleBndrSig $2 $4 }
-----------------------------------------------------------------------------
-- Foreign import/export
callconv :: { Int }
- : VARID {% checkCallConv $1 }
+ : 'stdcall' { stdCallConv }
+ | 'ccall' { cCallConv }
| {- empty -} { defaultCallConv }
unsafe_flag :: { Bool }
: 'unsafe' { True }
| {- empty -} { False }
-ext_name :: { ExtName }
- : 'dynamic' { Dynamic }
- | STRING { ExtName $1 Nothing }
- | STRING STRING { ExtName $2 (Just $1) }
+ext_name :: { Maybe ExtName }
+ : 'dynamic' { Just Dynamic }
+ | STRING { Just (ExtName $1 Nothing) }
+ | STRING STRING { Just (ExtName $2 (Just $1)) }
+ | {- empty -} { Nothing }
-----------------------------------------------------------------------------
-- Types
-{- ToDo: forall stuff -}
+-- A ctype is a for-all type
+ctype :: { RdrNameHsType }
+ : 'forall' tyvars '.' ctype { mkHsForAllTy (Just $2) [] $4 }
+ | context type { mkHsForAllTy Nothing $1 $2 }
+ -- A type of form (context => type) is an *implicit* HsForAllTy
+ | type { $1 }
type :: { RdrNameHsType }
: btype '->' type { MonoFunTy $1 $3 }
inst_type :: { RdrNameHsType }
: 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) }
- | type { $1 }
-
types0 :: { [RdrNameHsType] }
: types { $1 }
| {- empty -} { [] }
: 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 }
: vars '::' stype { (reverse $1, $3) }
stype :: { RdrNameBangType }
- : type { Unbanged $1 }
+ : ctype { Unbanged $1 }
| '!' atype { Banged $2 }
deriving :: { Maybe [RdrName] }
| '_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 '}' { reverse $2 }
+ | layout_on_for_do stmts close { reverse $2 }
+
+-- Stmt list should really end in an expression, but it's not
+-- convenient to enforce this here, so we throw out erroneous
+-- statement sequences in the renamer instead.
stmts :: { [RdrNameStmt] }
- : stmts ';' stmt { $3 : $1 }
- | stmts ';' { $1 }
+ : ';' stmts1 { $2 }
+ | stmts1 { $1 }
+
+stmts1 :: { [RdrNameStmt] }
+ : stmts1 ';' stmt { $3 : $1 }
+ | stmts1 ';' { $1 }
| stmt { [$1] }
- | {- empty -} { [] }
stmt :: { RdrNameStmt }
: srcloc infixexp '<-' exp {% checkPattern $2 `thenP` \p ->
| 'label' { label_var_RDR }
| 'dynamic' { dynamic_var_RDR }
| 'unsafe' { unsafe_var_RDR }
+ | 'stdcall' { stdcall_var_RDR }
+ | 'ccall' { ccall_var_RDR }
varid_no_unsafe :: { RdrName }
: VARID { mkSrcUnqual varName $1 }
| 'export' { export_var_RDR }
| 'label' { label_var_RDR }
| 'dynamic' { dynamic_var_RDR }
+ | 'stdcall' { stdcall_var_RDR }
+ | 'ccall' { ccall_var_RDR }
-----------------------------------------------------------------------------
-- ConIds
: vccurly { () } -- context popped in lexer.
| error {% popContext }
-layout_on :: { () } : {% layoutOn }
+layout_on :: { () } : {% layoutOn True{-strict-} }
+layout_on_for_do :: { () } : {% layoutOn False }
-----------------------------------------------------------------------------
-- Miscellaneous (mostly renamings)
| 'as' { as_tyvar_RDR }
| 'qualified' { qualified_tyvar_RDR }
| 'hiding' { hiding_tyvar_RDR }
- | 'export' { export_var_RDR }
- | 'label' { label_var_RDR }
- | 'dynamic' { dynamic_var_RDR }
- | 'unsafe' { unsafe_var_RDR }
+ | 'export' { export_tyvar_RDR }
+ | 'label' { label_tyvar_RDR }
+ | 'dynamic' { dynamic_tyvar_RDR }
+ | 'unsafe' { unsafe_tyvar_RDR }
+ | 'stdcall' { stdcall_tyvar_RDR }
+ | 'ccall' { ccall_tyvar_RDR }
-- NOTE: no 'forall'
-----------------------------------------------------------------------------
projects / ghc-hetmet.git / blobdiff