X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FParser.y.pp;h=0a423f45df6097eebd498a6b4987e9a04b37bc5d;hb=ac10f8408520a30e8437496d320b8b86afda2e8f;hp=4187789d08440fee92cb976561e226e98a7ac660;hpb=c1a7d1a618d86260360e8bde9429e357df95c2de;p=ghc-hetmet.git diff --git a/ghc/compiler/parser/Parser.y.pp b/ghc/compiler/parser/Parser.y.pp index 4187789..0a423f4 100644 --- a/ghc/compiler/parser/Parser.y.pp +++ b/ghc/compiler/parser/Parser.y.pp @@ -8,14 +8,15 @@ -- --------------------------------------------------------------------------- { -module Parser ( parseModule, parseStmt, parseIdentifier, parseIface, parseType ) where +module Parser ( parseModule, parseStmt, parseIdentifier, parseType, + parseHeader ) where #define INCLUDE #include INCLUDE "HsVersions.h" import HsSyn import RdrHsSyn -import HscTypes ( ModIface, IsBootInterface, DeprecTxt ) +import HscTypes ( IsBootInterface, DeprecTxt ) import Lexer import RdrName import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataCon, @@ -24,19 +25,17 @@ import Type ( funTyCon ) import ForeignCall ( Safety(..), CExportSpec(..), CLabelString, CCallConv(..), CCallTarget(..), defaultCCallConv ) -import OccName ( UserFS, varName, dataName, tcClsName, tvName ) +import OccName ( varName, dataName, tcClsName, tvName ) import DataCon ( DataCon, dataConName ) import SrcLoc ( Located(..), unLoc, getLoc, noLoc, combineSrcSpans, SrcSpan, combineLocs, srcLocFile, mkSrcLoc, mkSrcSpan ) import Module -import CmdLineOpts ( opt_SccProfilingOn ) +import StaticFlags ( opt_SccProfilingOn ) import Type ( Kind, mkArrowKind, liftedTypeKind ) import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..), - Activation(..) ) + Activation(..), defaultInlineSpec ) import OrdList -import Bag ( emptyBag ) -import Panic import FastString import Maybes ( orElse ) @@ -46,36 +45,49 @@ import GLAEXTS {- ----------------------------------------------------------------------------- -Conflicts: 33 shift/reduce, [SDM 19/9/2002] +Conflicts: 36 shift/reduce (1.25) -10 for abiguity in 'if x then y else z + 1' [State 136] +10 for abiguity in 'if x then y else z + 1' [State 178] (shift parses as 'if x then y else (z + 1)', as per longest-parse rule) 10 because op might be: : - ! * . `x` VARSYM CONSYM QVARSYM QCONSYM -1 for ambiguity in 'if x then y else z with ?x=3' [State 136] - (shift parses as 'if x then y else (z with ?x=3)' - -1 for ambiguity in 'if x then y else z :: T' [State 136] +1 for ambiguity in 'if x then y else z :: T' [State 178] (shift parses as 'if x then y else (z :: T)', as per longest-parse rule) -4 for ambiguity in 'if x then y else z -< e' +4 for ambiguity in 'if x then y else z -< e' [State 178] (shift parses as 'if x then y else (z -< T)', as per longest-parse rule) + There are four such operators: -<, >-, -<<, >>- + + +2 for ambiguity in 'case v of { x :: T -> T ... } ' [States 11, 253] + Which of these two is intended? + case v of + (x::T) -> T -- Rhs is T + or + case v of + (x::T -> T) -> .. -- Rhs is ... -8 for ambiguity in 'e :: a `b` c'. Does this mean [States 160,246] +10 for ambiguity in 'e :: a `b` c'. Does this mean [States 11, 253] (e::a) `b` c, or (e :: (a `b` c)) + As well as `b` we can have !, VARSYM, QCONSYM, and CONSYM, hence 5 cases + Same duplication between states 11 and 253 as the previous case -1 for ambiguity in 'let ?x ...' [State 268] +1 for ambiguity in 'let ?x ...' [State 329] the parser can't tell whether the ?x is the lhs of a normal binding or an implicit binding. Fortunately resolving as shift gives it the only sensible meaning, namely the lhs of an implicit binding. -1 for ambiguity in '{-# RULES "name" [ ... #-} [State 332] +1 for ambiguity in '{-# RULES "name" [ ... #-} [State 382] we don't know whether the '[' starts the activation or not: it might be the start of the declaration with the activation being empty. --SDM 1/4/2002 -1 for ambiguity in '{-# RULES "name" forall = ... #-}' [State 394] +6 for conflicts between `fdecl' and `fdeclDEPRECATED', [States 393,394] + which are resolved correctly, and moreover, + should go away when `fdeclDEPRECATED' is removed. + +1 for ambiguity in '{-# RULES "name" forall = ... #-}' [State 474] since 'forall' is a valid variable name, we don't know whether to treat a forall on the input as the beginning of a quantifier or the beginning of the rule itself. Resolving to shift means @@ -83,10 +95,6 @@ Conflicts: 33 shift/reduce, [SDM 19/9/2002] This saves explicitly defining a grammar for the rule lhs that doesn't include 'forall'. -6 for conflicts between `fdecl' and `fdeclDEPRECATED', [States 384,385] - which are resolved correctly, and moreover, - should go away when `fdeclDEPRECATED' is removed. - -- --------------------------------------------------------------------------- -- Adding location info @@ -175,10 +183,10 @@ incorrect. 'proc' { L _ ITproc } -- for arrow notation extension 'rec' { L _ ITrec } -- for arrow notation extension - '{-# SPECIALISE' { L _ ITspecialise_prag } + '{-# INLINE' { L _ (ITinline_prag _) } + '{-# SPECIALISE' { L _ ITspec_prag } + '{-# SPECIALISE_INLINE' { L _ (ITspec_inline_prag _) } '{-# SOURCE' { L _ ITsource_prag } - '{-# INLINE' { L _ ITinline_prag } - '{-# NOINLINE' { L _ ITnoinline_prag } '{-# RULES' { L _ ITrules_prag } '{-# CORE' { L _ ITcore_prag } -- hdaume: annotated core '{-# SCC' { L _ ITscc_prag } @@ -265,12 +273,20 @@ TH_TY_QUOTE { L _ ITtyQuote } -- ''T %name parseModule module %name parseStmt maybe_stmt %name parseIdentifier identifier -%name parseIface iface %name parseType ctype +%partial parseHeader header %tokentype { Located Token } %% ----------------------------------------------------------------------------- +-- Identifiers; one of the entry points +identifier :: { Located RdrName } + : qvar { $1 } + | qcon { $1 } + | qvarop { $1 } + | qconop { $1 } + +----------------------------------------------------------------------------- -- Module Header -- The place for module deprecation is really too restrictive, but if it @@ -283,9 +299,7 @@ TH_TY_QUOTE { L _ ITtyQuote } -- ''T module :: { Located (HsModule RdrName) } : 'module' modid maybemoddeprec maybeexports 'where' body {% fileSrcSpan >>= \ loc -> - return (L loc (HsModule (Just (L (getLoc $2) - (mkHomeModule (unLoc $2)))) - $4 (fst $6) (snd $6) $3)) } + return (L loc (HsModule (Just $2) $4 (fst $6) (snd $6) $3)) } | missing_module_keyword top close {% fileSrcSpan >>= \ loc -> return (L loc (HsModule Nothing Nothing @@ -311,36 +325,19 @@ cvtopdecls :: { [LHsDecl RdrName] } : topdecls { cvTopDecls $1 } ----------------------------------------------------------------------------- --- Interfaces (.hi-boot files) +-- Module declaration & imports only -iface :: { ModIface } - : 'module' modid 'where' ifacebody { mkBootIface (unLoc $2) $4 } - -ifacebody :: { [HsDecl RdrName] } - : '{' ifacedecls '}' { $2 } - | vocurly ifacedecls close { $2 } - -ifacedecls :: { [HsDecl RdrName] } - : ifacedecl ';' ifacedecls { $1 : $3 } - | ';' ifacedecls { $2 } - | ifacedecl { [$1] } - | {- empty -} { [] } +header :: { Located (HsModule RdrName) } + : 'module' modid maybemoddeprec maybeexports 'where' header_body + {% fileSrcSpan >>= \ loc -> + return (L loc (HsModule (Just $2) $4 $6 [] $3)) } + | missing_module_keyword importdecls + {% fileSrcSpan >>= \ loc -> + return (L loc (HsModule Nothing Nothing $2 [] Nothing)) } -ifacedecl :: { HsDecl RdrName } - : var '::' sigtype - { SigD (Sig $1 $3) } - | 'type' syn_hdr '=' ctype - { let (tc,tvs) = $2 in TyClD (TySynonym tc tvs $4) } - | 'data' tycl_hdr constrs -- No deriving in hi-boot - { TyClD (mkTyData DataType $2 Nothing (reverse (unLoc $3)) Nothing) } - | 'data' tycl_hdr 'where' gadt_constrlist - { TyClD (mkTyData DataType $2 Nothing (reverse (unLoc $4)) Nothing) } - | 'newtype' tycl_hdr -- Constructor is optional - { TyClD (mkTyData NewType $2 Nothing [] Nothing) } - | 'newtype' tycl_hdr '=' newconstr - { TyClD (mkTyData NewType $2 Nothing [$4] Nothing) } - | 'class' tycl_hdr fds - { TyClD (mkClassDecl (unLoc $2) (unLoc $3) [] emptyBag) } +header_body :: { [LImportDecl RdrName] } + : '{' importdecls { $2 } + | vocurly importdecls { $2 } ----------------------------------------------------------------------------- -- The Export List @@ -371,7 +368,7 @@ qcnames :: { [RdrName] } qcname :: { Located RdrName } -- Variable or data constructor : qvar { $1 } - | gcon { $1 } + | qcon { $1 } ----------------------------------------------------------------------------- -- Import Declarations @@ -397,7 +394,7 @@ optqualified :: { Bool } : 'qualified' { True } | {- empty -} { False } -maybeas :: { Located (Maybe ModuleName) } +maybeas :: { Located (Maybe Module) } : 'as' modid { LL (Just (unLoc $2)) } | {- empty -} { noLoc Nothing } @@ -446,24 +443,27 @@ topdecl :: { OrdList (LHsDecl RdrName) } | decl { unLoc $1 } tycl_decl :: { LTyClDecl RdrName } - : 'type' syn_hdr '=' ctype - -- Note ctype, not sigtype. + : 'type' type '=' ctype + -- Note type on the left of the '='; this allows + -- infix type constructors to be declared + -- + -- Note ctype, not sigtype, on the right -- We allow an explicit for-all but we don't insert one -- in type Foo a = (b,b) -- Instead we just say b is out of scope - { LL $ let (tc,tvs) = $2 in TySynonym tc tvs $4 } + {% do { (tc,tvs) <- checkSynHdr $2 + ; return (LL (TySynonym tc tvs $4)) } } - | 'data' tycl_hdr constrs deriving - { L (comb4 $1 $2 $3 $4) - (mkTyData DataType $2 Nothing (reverse (unLoc $3)) (unLoc $4)) } + | data_or_newtype tycl_hdr constrs deriving + { L (comb4 $1 $2 $3 $4) -- We need the location on tycl_hdr + -- in case constrs and deriving are both empty + (mkTyData (unLoc $1) (unLoc $2) Nothing (reverse (unLoc $3)) (unLoc $4)) } - | 'data' tycl_hdr opt_kind_sig 'where' gadt_constrlist -- No deriving for GADTs + | data_or_newtype tycl_hdr opt_kind_sig + 'where' gadt_constrlist + deriving { L (comb4 $1 $2 $4 $5) - (mkTyData DataType $2 $3 (reverse (unLoc $5)) Nothing) } - - | 'newtype' tycl_hdr '=' newconstr deriving - { L (comb3 $1 $4 $5) - (mkTyData NewType $2 Nothing [$4] (unLoc $5)) } + (mkTyData (unLoc $1) (unLoc $2) $3 (reverse (unLoc $5)) (unLoc $6)) } | 'class' tycl_hdr fds where { let @@ -472,16 +472,14 @@ tycl_decl :: { LTyClDecl RdrName } L (comb4 $1 $2 $3 $4) (mkClassDecl (unLoc $2) (unLoc $3) sigs binds) } +data_or_newtype :: { Located NewOrData } + : 'data' { L1 DataType } + | 'newtype' { L1 NewType } + opt_kind_sig :: { Maybe Kind } : { Nothing } | '::' kind { Just $2 } -syn_hdr :: { (Located RdrName, [LHsTyVarBndr RdrName]) } - -- We don't retain the syntax of an infix - -- type synonym declaration. Oh well. - : tycon tv_bndrs { ($1, $2) } - | tv_bndr tyconop tv_bndr { ($2, [$1,$3]) } - -- tycl_hdr parses the header of a type or class decl, -- which takes the form -- T a b @@ -489,7 +487,7 @@ syn_hdr :: { (Located RdrName, [LHsTyVarBndr RdrName]) } -- (Eq a, Ord b) => T a b -- Rather a lot of inlining here, else we get reduce/reduce errors tycl_hdr :: { Located (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName]) } - : context '=>' type {% checkTyClHdr $1 $3 >>= return.LL } + : context '=>' type {% checkTyClHdr $1 $3 >>= return.LL } | type {% checkTyClHdr (noLoc []) $1 >>= return.L1 } ----------------------------------------------------------------------------- @@ -511,14 +509,14 @@ where :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed : 'where' decllist { LL (unLoc $2) } | {- empty -} { noLoc nilOL } -binds :: { Located [HsBindGroup RdrName] } -- May have implicit parameters - : decllist { L1 [cvBindGroup (unLoc $1)] } - | '{' dbinds '}' { LL [HsIPBinds (unLoc $2)] } - | vocurly dbinds close { L (getLoc $2) [HsIPBinds (unLoc $2)] } +binds :: { Located (HsLocalBinds RdrName) } -- May have implicit parameters + : decllist { L1 (HsValBinds (cvBindGroup (unLoc $1))) } + | '{' dbinds '}' { LL (HsIPBinds (IPBinds (unLoc $2) emptyLHsBinds)) } + | vocurly dbinds close { L (getLoc $2) (HsIPBinds (IPBinds (unLoc $2) emptyLHsBinds)) } -wherebinds :: { Located [HsBindGroup RdrName] } -- May have implicit parameters +wherebinds :: { Located (HsLocalBinds RdrName) } -- May have implicit parameters : 'where' binds { LL (unLoc $2) } - | {- empty -} { noLoc [] } + | {- empty -} { noLoc emptyLocalBinds } ----------------------------------------------------------------------------- @@ -532,15 +530,13 @@ rules :: { OrdList (LHsDecl RdrName) } -- Reversed rule :: { LHsDecl RdrName } : STRING activation rule_forall infixexp '=' exp - { LL $ RuleD (HsRule (getSTRING $1) $2 $3 $4 $6) } - -activation :: { Activation } -- Omitted means AlwaysActive - : {- empty -} { AlwaysActive } - | explicit_activation { $1 } + { LL $ RuleD (HsRule (getSTRING $1) + ($2 `orElse` AlwaysActive) + $3 $4 $6) } -inverse_activation :: { Activation } -- Omitted means NeverActive - : {- empty -} { NeverActive } - | explicit_activation { $1 } +activation :: { Maybe Activation } + : {- empty -} { Nothing } + | explicit_activation { Just $1 } explicit_activation :: { Activation } -- In brackets : '[' INTEGER ']' { ActiveAfter (fromInteger (getINTEGER $2)) } @@ -777,8 +773,8 @@ type :: { LHsType RdrName } gentype :: { LHsType RdrName } : btype { $1 } | btype qtyconop gentype { LL $ HsOpTy $1 $2 $3 } - | btype '`' tyvar '`' gentype { LL $ HsOpTy $1 $3 $5 } - | btype '->' gentype { LL $ HsFunTy $1 $3 } + | btype tyvarop gentype { LL $ HsOpTy $1 $2 $3 } + | btype '->' ctype { LL $ HsFunTy $1 $3 } btype :: { LHsType RdrName } : btype atype { LL $ HsAppTy $1 $2 } @@ -788,10 +784,10 @@ atype :: { LHsType RdrName } : gtycon { L1 (HsTyVar (unLoc $1)) } | tyvar { L1 (HsTyVar (unLoc $1)) } | strict_mark atype { LL (HsBangTy (unLoc $1) $2) } - | '(' type ',' comma_types1 ')' { LL $ HsTupleTy Boxed ($2:$4) } + | '(' ctype ',' comma_types1 ')' { LL $ HsTupleTy Boxed ($2:$4) } | '(#' comma_types1 '#)' { LL $ HsTupleTy Unboxed $2 } - | '[' type ']' { LL $ HsListTy $2 } - | '[:' type ':]' { LL $ HsPArrTy $2 } + | '[' ctype ']' { LL $ HsListTy $2 } + | '[:' ctype ':]' { LL $ HsPArrTy $2 } | '(' ctype ')' { LL $ HsParTy $2 } | '(' ctype '::' kind ')' { LL $ HsKindSig $2 $4 } -- Generics @@ -813,8 +809,8 @@ comma_types0 :: { [LHsType RdrName] } | {- empty -} { [] } comma_types1 :: { [LHsType RdrName] } - : type { [$1] } - | type ',' comma_types1 { $1 : $3 } + : ctype { [$1] } + | ctype ',' comma_types1 { $1 : $3 } tv_bndrs :: { [LHsTyVarBndr RdrName] } : tv_bndr tv_bndrs { $1 : $2 } @@ -855,22 +851,39 @@ akind :: { Kind } ----------------------------------------------------------------------------- -- Datatype declarations -newconstr :: { LConDecl RdrName } - : conid atype { LL $ ConDecl $1 [] (noLoc []) (PrefixCon [$2]) } - | conid '{' var '::' ctype '}' - { LL $ ConDecl $1 [] (noLoc []) (RecCon [($3, $5)]) } - gadt_constrlist :: { Located [LConDecl RdrName] } : '{' gadt_constrs '}' { LL (unLoc $2) } | vocurly gadt_constrs close { $2 } gadt_constrs :: { Located [LConDecl RdrName] } : gadt_constrs ';' gadt_constr { LL ($3 : unLoc $1) } + | gadt_constrs ';' { $1 } | gadt_constr { L1 [$1] } +-- We allow the following forms: +-- C :: Eq a => a -> T a +-- C :: forall a. Eq a => !a -> T a +-- D { x,y :: a } :: T a +-- forall a. Eq a => D { x,y :: a } :: T a + gadt_constr :: { LConDecl RdrName } - : qcon '::' sigtype - { LL (GadtDecl $1 $3) } + : con '::' sigtype + { LL (mkGadtDecl $1 $3) } + -- Syntax: Maybe merge the record stuff with the single-case above? + -- (to kill the mostly harmless reduce/reduce error) + -- XXX revisit autrijus + | constr_stuff_record '::' sigtype + { let (con,details) = unLoc $1 in + LL (ConDecl con Implicit [] (noLoc []) details (ResTyGADT $3)) } +{- + | forall context '=>' constr_stuff_record '::' sigtype + { let (con,details) = unLoc $4 in + LL (ConDecl con Implicit (unLoc $1) $2 details (ResTyGADT $6)) } + | forall constr_stuff_record '::' sigtype + { let (con,details) = unLoc $2 in + LL (ConDecl con Implicit (unLoc $1) (noLoc []) details (ResTyGADT $4)) } +-} + constrs :: { Located [LConDecl RdrName] } : {- empty; a GHC extension -} { noLoc [] } @@ -883,10 +896,10 @@ constrs1 :: { Located [LConDecl RdrName] } constr :: { LConDecl RdrName } : forall context '=>' constr_stuff { let (con,details) = unLoc $4 in - LL (ConDecl con (unLoc $1) $2 details) } + LL (ConDecl con Explicit (unLoc $1) $2 details ResTyH98) } | forall constr_stuff { let (con,details) = unLoc $2 in - LL (ConDecl con (unLoc $1) (noLoc []) details) } + LL (ConDecl con Explicit (unLoc $1) (noLoc []) details ResTyH98) } forall :: { Located [LHsTyVarBndr RdrName] } : 'forall' tv_bndrs '.' { LL $2 } @@ -905,6 +918,10 @@ constr_stuff :: { Located (Located RdrName, HsConDetails RdrName (LBangType RdrN | oqtycon '{' fielddecls '}' {% mkRecCon $1 $3 >>= return.LL } | btype conop btype { LL ($2, InfixCon $1 $3) } +constr_stuff_record :: { Located (Located RdrName, HsConDetails RdrName (LBangType RdrName)) } + : oqtycon '{' '}' {% mkRecCon $1 [] >>= return.sL (comb2 $1 $>) } + | oqtycon '{' fielddecls '}' {% mkRecCon $1 $3 >>= return.sL (comb2 $1 $>) } + fielddecls :: { [([Located RdrName], LBangType RdrName)] } : fielddecl ',' fielddecls { unLoc $1 : $3 } | fielddecl { [unLoc $1] } @@ -963,8 +980,7 @@ gdrhs :: { Located [LGRHS RdrName] } | gdrh { L1 [$1] } gdrh :: { LGRHS RdrName } - : '|' quals '=' exp { LL $ GRHS (reverse (L (getLoc $4) (ResultStmt $4) : - unLoc $2)) } + : '|' quals '=' exp { sL (comb2 $1 $>) $ GRHS (reverse (unLoc $2)) $4 } sigdecl :: { Located (OrdList (LHsDecl RdrName)) } : infixexp '::' sigtype @@ -972,16 +988,17 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) } return (LL $ unitOL (LL $ SigD s)) } -- See the above notes for why we need infixexp here | var ',' sig_vars '::' sigtype - { LL $ toOL [ LL $ SigD (Sig n $5) | n <- $1 : unLoc $3 ] } + { LL $ toOL [ LL $ SigD (TypeSig n $5) | n <- $1 : unLoc $3 ] } | infix prec ops { LL $ toOL [ LL $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1)))) | n <- unLoc $3 ] } | '{-# INLINE' activation qvar '#-}' - { LL $ unitOL (LL $ SigD (InlineSig True $3 $2)) } - | '{-# NOINLINE' inverse_activation qvar '#-}' - { LL $ unitOL (LL $ SigD (InlineSig False $3 $2)) } + { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlineSpec $2 (getINLINE $1)))) } | '{-# SPECIALISE' qvar '::' sigtypes1 '#-}' - { LL $ toOL [ LL $ SigD (SpecSig $2 t) + { LL $ toOL [ LL $ SigD (SpecSig $2 t defaultInlineSpec) | t <- $4] } + | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}' + { LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlineSpec $2 (getSPEC_INLINE $1))) + | t <- $5] } | '{-# SPECIALISE' 'instance' inst_type '#-}' { LL $ unitOL (LL $ SigD (SpecInstSig $3)) } @@ -1004,7 +1021,7 @@ exp10 :: { LHsExpr RdrName } : '\\' aexp aexps opt_asig '->' exp {% checkPatterns ($2 : reverse $3) >>= \ ps -> return (LL $ HsLam (mkMatchGroup [LL $ Match ps $4 - (GRHSs (unguardedRHS $6) [] + (GRHSs (unguardedRHS $6) emptyLocalBinds )])) } | 'let' binds 'in' exp { LL $ HsLet (unLoc $2) $4 } | 'if' exp 'then' exp 'else' exp { LL $ HsIf $2 $4 $6 } @@ -1012,12 +1029,11 @@ exp10 :: { LHsExpr RdrName } | '-' fexp { LL $ mkHsNegApp $2 } | 'do' stmtlist {% let loc = comb2 $1 $2 in - checkDo loc (unLoc $2) >>= \ stmts -> - return (L loc (mkHsDo DoExpr stmts)) } + checkDo loc (unLoc $2) >>= \ (stmts,body) -> + return (L loc (mkHsDo DoExpr stmts body)) } | 'mdo' stmtlist {% let loc = comb2 $1 $2 in - checkMDo loc (unLoc $2) >>= \ stmts -> - return (L loc (mkHsDo MDoExpr stmts)) } - + checkDo loc (unLoc $2) >>= \ (stmts,body) -> + return (L loc (mkHsDo (MDoExpr noPostTcTable) stmts body)) } | scc_annot exp { LL $ if opt_SccProfilingOn then HsSCC (unLoc $1) $2 else HsPar $2 } @@ -1085,7 +1101,7 @@ aexp2 :: { LHsExpr RdrName } | '$(' exp ')' { LL $ HsSpliceE (mkHsSplice $2) } -- $( exp ) | TH_VAR_QUOTE qvar { LL $ HsBracket (VarBr (unLoc $2)) } - | TH_VAR_QUOTE gcon { LL $ HsBracket (VarBr (unLoc $2)) } + | TH_VAR_QUOTE qcon { LL $ HsBracket (VarBr (unLoc $2)) } | TH_TY_QUOTE tyvar { LL $ HsBracket (VarBr (unLoc $2)) } | TH_TY_QUOTE gtycon { LL $ HsBracket (VarBr (unLoc $2)) } | '[|' exp '|]' { LL $ HsBracket (ExpBr $2) } @@ -1126,13 +1142,11 @@ texps :: { [LHsExpr RdrName] } list :: { LHsExpr RdrName } : exp { L1 $ ExplicitList placeHolderType [$1] } | lexps { L1 $ ExplicitList placeHolderType (reverse (unLoc $1)) } - | exp '..' { LL $ ArithSeqIn (From $1) } - | exp ',' exp '..' { LL $ ArithSeqIn (FromThen $1 $3) } - | exp '..' exp { LL $ ArithSeqIn (FromTo $1 $3) } - | exp ',' exp '..' exp { LL $ ArithSeqIn (FromThenTo $1 $3 $5) } - | exp pquals { LL $ mkHsDo ListComp - (reverse (L (getLoc $1) (ResultStmt $1) : - unLoc $2)) } + | exp '..' { LL $ ArithSeq noPostTcExpr (From $1) } + | exp ',' exp '..' { LL $ ArithSeq noPostTcExpr (FromThen $1 $3) } + | exp '..' exp { LL $ ArithSeq noPostTcExpr (FromTo $1 $3) } + | exp ',' exp '..' exp { LL $ ArithSeq noPostTcExpr (FromThenTo $1 $3 $5) } + | exp pquals { sL (comb2 $1 $>) $ mkHsDo ListComp (reverse (unLoc $2)) $1 } lexps :: { Located [LHsExpr RdrName] } : lexps ',' exp { LL ($3 : unLoc $1) } @@ -1172,12 +1186,9 @@ parr :: { LHsExpr RdrName } | exp { L1 $ ExplicitPArr placeHolderType [$1] } | lexps { L1 $ ExplicitPArr placeHolderType (reverse (unLoc $1)) } - | exp '..' exp { LL $ PArrSeqIn (FromTo $1 $3) } - | exp ',' exp '..' exp { LL $ PArrSeqIn (FromThenTo $1 $3 $5) } - | exp pquals { LL $ mkHsDo PArrComp - (reverse (L (getLoc $1) (ResultStmt $1) : - unLoc $2)) - } + | exp '..' exp { LL $ PArrSeq noPostTcExpr (FromTo $1 $3) } + | exp ',' exp '..' exp { LL $ PArrSeq noPostTcExpr (FromThenTo $1 $3 $5) } + | exp pquals { sL (comb2 $1 $>) $ mkHsDo PArrComp (reverse (unLoc $2)) $1 } -- We are reusing `lexps' and `pquals' from the list case. @@ -1213,8 +1224,7 @@ gdpats :: { Located [LGRHS RdrName] } | gdpat { L1 [$1] } gdpat :: { LGRHS RdrName } - : '|' quals '->' exp { let r = L (getLoc $4) (ResultStmt $4) - in LL $ GRHS (reverse (r : unLoc $2)) } + : '|' quals '->' exp { sL (comb2 $1 $>) $ GRHS (reverse (unLoc $2)) $4 } ----------------------------------------------------------------------------- -- Statement sequences @@ -1224,7 +1234,7 @@ stmtlist :: { Located [LStmt RdrName] } | vocurly stmts close { $2 } -- do { ;; s ; s ; ; s ;; } --- The last Stmt should be a ResultStmt, but that's hard to enforce +-- The last Stmt should be an expression, but that's hard to enforce -- here, because we need too much lookahead if we see do { e ; } -- So we use ExprStmts throughout, and switch the last one over -- in ParseUtils.checkDo instead @@ -1246,13 +1256,13 @@ maybe_stmt :: { Maybe (LStmt RdrName) } stmt :: { LStmt RdrName } : qual { $1 } | infixexp '->' exp {% checkPattern $3 >>= \p -> - return (LL $ BindStmt p $1) } - | 'rec' stmtlist { LL $ RecStmt (unLoc $2) undefined undefined undefined } + return (LL $ mkBindStmt p $1) } + | 'rec' stmtlist { LL $ mkRecStmt (unLoc $2) } qual :: { LStmt RdrName } - : infixexp '<-' exp {% checkPattern $1 >>= \p -> - return (LL $ BindStmt p $3) } - | exp { L1 $ ExprStmt $1 placeHolderType } + : exp '<-' exp {% checkPattern $1 >>= \p -> + return (LL $ mkBindStmt p $3) } + | exp { L1 $ mkExprStmt $1 } | 'let' binds { LL $ LetStmt (unLoc $2) } ----------------------------------------------------------------------------- @@ -1281,14 +1291,12 @@ dbinds :: { Located [LIPBind RdrName] } dbind :: { LIPBind RdrName } dbind : ipvar '=' exp { LL (IPBind (unLoc $1) $3) } ------------------------------------------------------------------------------ --- Variables, Constructors and Operators. +ipvar :: { Located (IPName RdrName) } + : IPDUPVARID { L1 (Dupable (mkUnqual varName (getIPDUPVARID $1))) } + | IPSPLITVARID { L1 (Linear (mkUnqual varName (getIPSPLITVARID $1))) } -identifier :: { Located RdrName } - : qvar { $1 } - | gcon { $1 } - | qvarop { $1 } - | qconop { $1 } +----------------------------------------------------------------------------- +-- Deprecations depreclist :: { Located [RdrName] } depreclist : deprec_var { L1 [unLoc $1] } @@ -1296,49 +1304,25 @@ depreclist : deprec_var { L1 [unLoc $1] } deprec_var :: { Located RdrName } deprec_var : var { $1 } - | tycon { $1 } - -gcon :: { Located RdrName } -- Data constructor namespace - : sysdcon { L1 $ nameRdrName (dataConName (unLoc $1)) } - | qcon { $1 } --- the case of '[:' ':]' is part of the production `parr' - -sysdcon :: { Located DataCon } -- Wired in data constructors - : '(' ')' { LL unitDataCon } - | '(' commas ')' { LL $ tupleCon Boxed $2 } - | '[' ']' { LL nilDataCon } - -var :: { Located RdrName } - : varid { $1 } - | '(' varsym ')' { LL (unLoc $2) } - -qvar :: { Located RdrName } - : qvarid { $1 } - | '(' varsym ')' { LL (unLoc $2) } - | '(' qvarsym1 ')' { LL (unLoc $2) } --- We've inlined qvarsym here so that the decision about --- whether it's a qvar or a var can be postponed until --- *after* we see the close paren. - -ipvar :: { Located (IPName RdrName) } - : IPDUPVARID { L1 (Dupable (mkUnqual varName (getIPDUPVARID $1))) } - | IPSPLITVARID { L1 (Linear (mkUnqual varName (getIPSPLITVARID $1))) } + | con { $1 } +----------------------------------------- +-- Data constructors qcon :: { Located RdrName } : qconid { $1 } | '(' qconsym ')' { LL (unLoc $2) } + | sysdcon { L1 $ nameRdrName (dataConName (unLoc $1)) } +-- The case of '[:' ':]' is part of the production `parr' -varop :: { Located RdrName } - : varsym { $1 } - | '`' varid '`' { LL (unLoc $2) } - -qvarop :: { Located RdrName } - : qvarsym { $1 } - | '`' qvarid '`' { LL (unLoc $2) } +con :: { Located RdrName } + : conid { $1 } + | '(' consym ')' { LL (unLoc $2) } + | sysdcon { L1 $ nameRdrName (dataConName (unLoc $1)) } -qvaropm :: { Located RdrName } - : qvarsym_no_minus { $1 } - | '`' qvarid '`' { LL (unLoc $2) } +sysdcon :: { Located DataCon } -- Wired in data constructors + : '(' ')' { LL unitDataCon } + | '(' commas ')' { LL $ tupleCon Boxed $2 } + | '[' ']' { LL nilDataCon } conop :: { Located RdrName } : consym { $1 } @@ -1367,10 +1351,6 @@ qtyconop :: { Located RdrName } -- Qualified or unqualified : qtyconsym { $1 } | '`' qtycon '`' { LL (unLoc $2) } -tyconop :: { Located RdrName } -- Unqualified - : tyconsym { $1 } - | '`' tycon '`' { LL (unLoc $2) } - qtycon :: { Located RdrName } -- Qualified or unqualified : QCONID { L1 $! mkQual tcClsName (getQCONID $1) } | tycon { $1 } @@ -1386,12 +1366,16 @@ tyconsym :: { Located RdrName } : CONSYM { L1 $! mkUnqual tcClsName (getCONSYM $1) } ----------------------------------------------------------------------------- --- Any operator +-- Operators op :: { Located RdrName } -- used in infix decls : varop { $1 } | conop { $1 } +varop :: { Located RdrName } + : varsym { $1 } + | '`' varid '`' { LL (unLoc $2) } + qop :: { LHsExpr RdrName } -- used in sections : qvarop { L1 $ HsVar (unLoc $1) } | qconop { L1 $ HsVar (unLoc $1) } @@ -1400,8 +1384,52 @@ qopm :: { LHsExpr RdrName } -- used in sections : qvaropm { L1 $ HsVar (unLoc $1) } | qconop { L1 $ HsVar (unLoc $1) } +qvarop :: { Located RdrName } + : qvarsym { $1 } + | '`' qvarid '`' { LL (unLoc $2) } + +qvaropm :: { Located RdrName } + : qvarsym_no_minus { $1 } + | '`' qvarid '`' { LL (unLoc $2) } + ----------------------------------------------------------------------------- --- VarIds +-- Type variables + +tyvar :: { Located RdrName } +tyvar : tyvarid { $1 } + | '(' tyvarsym ')' { LL (unLoc $2) } + +tyvarop :: { Located RdrName } +tyvarop : '`' tyvarid '`' { LL (unLoc $2) } + | tyvarsym { $1 } + +tyvarid :: { Located RdrName } + : VARID { L1 $! mkUnqual tvName (getVARID $1) } + | special_id { L1 $! mkUnqual tvName (unLoc $1) } + | 'unsafe' { L1 $! mkUnqual tvName FSLIT("unsafe") } + | 'safe' { L1 $! mkUnqual tvName FSLIT("safe") } + | 'threadsafe' { L1 $! mkUnqual tvName FSLIT("threadsafe") } + +tyvarsym :: { Located RdrName } +-- Does not include "!", because that is used for strictness marks +-- or ".", because that separates the quantified type vars from the rest +-- or "*", because that's used for kinds +tyvarsym : VARSYM { L1 $! mkUnqual tvName (getVARSYM $1) } + +----------------------------------------------------------------------------- +-- Variables + +var :: { Located RdrName } + : varid { $1 } + | '(' varsym ')' { LL (unLoc $2) } + +qvar :: { Located RdrName } + : qvarid { $1 } + | '(' varsym ')' { LL (unLoc $2) } + | '(' qvarsym1 ')' { LL (unLoc $2) } +-- We've inlined qvarsym here so that the decision about +-- whether it's a qvar or a var can be postponed until +-- *after* we see the close paren. qvarid :: { Located RdrName } : varid { $1 } @@ -1418,30 +1446,6 @@ varid_no_unsafe :: { Located RdrName } | special_id { L1 $! mkUnqual varName (unLoc $1) } | 'forall' { L1 $! mkUnqual varName FSLIT("forall") } -tyvar :: { Located RdrName } - : VARID { L1 $! mkUnqual tvName (getVARID $1) } - | special_id { L1 $! mkUnqual tvName (unLoc $1) } - | 'unsafe' { L1 $! mkUnqual tvName FSLIT("unsafe") } - | 'safe' { L1 $! mkUnqual tvName FSLIT("safe") } - | 'threadsafe' { L1 $! mkUnqual tvName FSLIT("threadsafe") } - --- These special_ids are treated as keywords in various places, --- but as ordinary ids elsewhere. 'special_id' collects all these --- except 'unsafe' and 'forall' whose treatment differs depending on context -special_id :: { Located UserFS } -special_id - : 'as' { L1 FSLIT("as") } - | 'qualified' { L1 FSLIT("qualified") } - | 'hiding' { L1 FSLIT("hiding") } - | 'export' { L1 FSLIT("export") } - | 'label' { L1 FSLIT("label") } - | 'dynamic' { L1 FSLIT("dynamic") } - | 'stdcall' { L1 FSLIT("stdcall") } - | 'ccall' { L1 FSLIT("ccall") } - ------------------------------------------------------------------------------ --- Variables - qvarsym :: { Located RdrName } : varsym { $1 } | qvarsym1 { $1 } @@ -1462,8 +1466,21 @@ varsym_no_minus :: { Located RdrName } -- varsym not including '-' | special_sym { L1 $ mkUnqual varName (unLoc $1) } --- See comments with special_id -special_sym :: { Located UserFS } +-- These special_ids are treated as keywords in various places, +-- but as ordinary ids elsewhere. 'special_id' collects all these +-- except 'unsafe' and 'forall' whose treatment differs depending on context +special_id :: { Located FastString } +special_id + : 'as' { L1 FSLIT("as") } + | 'qualified' { L1 FSLIT("qualified") } + | 'hiding' { L1 FSLIT("hiding") } + | 'export' { L1 FSLIT("export") } + | 'label' { L1 FSLIT("label") } + | 'dynamic' { L1 FSLIT("dynamic") } + | 'stdcall' { L1 FSLIT("stdcall") } + | 'ccall' { L1 FSLIT("ccall") } + +special_sym :: { Located FastString } special_sym : '!' { L1 FSLIT("!") } | '.' { L1 FSLIT(".") } | '*' { L1 FSLIT("*") } @@ -1511,10 +1528,10 @@ close :: { () } ----------------------------------------------------------------------------- -- Miscellaneous (mostly renamings) -modid :: { Located ModuleName } - : CONID { L1 $ mkModuleNameFS (getCONID $1) } +modid :: { Located Module } + : CONID { L1 $ mkModuleFS (getCONID $1) } | QCONID { L1 $ let (mod,c) = getQCONID $1 in - mkModuleNameFS + mkModuleFS (mkFastString (unpackFS mod ++ '.':unpackFS c)) } @@ -1549,6 +1566,8 @@ getPRIMINTEGER (L _ (ITprimint x)) = x getPRIMFLOAT (L _ (ITprimfloat x)) = x getPRIMDOUBLE (L _ (ITprimdouble x)) = x getTH_ID_SPLICE (L _ (ITidEscape x)) = x +getINLINE (L _ (ITinline_prag b)) = b +getSPEC_INLINE (L _ (ITspec_inline_prag b)) = b -- Utilities for combining source spans comb2 :: Located a -> Located b -> SrcSpan