X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FParser.y.pp;h=9378f768db272d734173e91d7a505cd0790514e2;hb=9e4a57507258b242de787bd4263887ba90760139;hp=e8144a692a76743f4d47ea122a6aeee9cf97596d;hpb=ef5b4b146aa172d8ac10f39b5eb3d7a0f948d8f1;p=ghc-hetmet.git diff --git a/ghc/compiler/parser/Parser.y.pp b/ghc/compiler/parser/Parser.y.pp index e8144a6..9378f76 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, @@ -35,7 +36,6 @@ import Type ( Kind, mkArrowKind, liftedTypeKind ) import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..), Activation(..) ) import OrdList -import Bag ( emptyBag ) import Panic import FastString @@ -46,36 +46,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 +96,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 @@ -265,8 +274,8 @@ 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 } %% @@ -309,36 +318,19 @@ cvtopdecls :: { [LHsDecl RdrName] } : topdecls { cvTopDecls $1 } ----------------------------------------------------------------------------- --- Interfaces (.hi-boot files) - -iface :: { ModIface } - : 'module' modid 'where' ifacebody { mkBootIface (unLoc $2) $4 } +-- Module declaration & imports only -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 @@ -444,15 +436,20 @@ 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) + { L (comb4 $1 $2 $3 $4) -- We need the location on tycl_hdr + -- in case constrs and deriving are both empty (mkTyData DataType $2 Nothing (reverse (unLoc $3)) (unLoc $4)) } | 'data' tycl_hdr opt_kind_sig 'where' gadt_constrlist -- No deriving for GADTs @@ -474,12 +471,6 @@ 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 @@ -487,7 +478,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 } ----------------------------------------------------------------------------- @@ -775,7 +766,7 @@ 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 tyvarop gentype { LL $ HsOpTy $1 $2 $3 } | btype '->' gentype { LL $ HsFunTy $1 $3 } btype :: { LHsType RdrName } @@ -864,6 +855,7 @@ gadt_constrlist :: { Located [LConDecl RdrName] } gadt_constrs :: { Located [LConDecl RdrName] } : gadt_constrs ';' gadt_constr { LL ($3 : unLoc $1) } + | gadt_constrs ';' { $1 } | gadt_constr { L1 [$1] } gadt_constr :: { LConDecl RdrName } @@ -1365,10 +1357,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 } @@ -1416,13 +1404,27 @@ varid_no_unsafe :: { Located RdrName } | special_id { L1 $! mkUnqual varName (unLoc $1) } | 'forall' { L1 $! mkUnqual varName FSLIT("forall") } -tyvar :: { Located RdrName } +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) } + -- 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