X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FParser.y.pp;h=4fa738a9932c6133b1910f7bfc636df099b4606d;hb=f1fd052239528b02d386bc8d07610ec81071a537;hp=02a723a512b04060ba4521f79259fa2fa719ba23;hpb=cb2be98ac73ffcc2e2cd631de403e83569a12b4d;p=ghc-hetmet.git diff --git a/ghc/compiler/parser/Parser.y.pp b/ghc/compiler/parser/Parser.y.pp index 02a723a..4fa738a 100644 --- a/ghc/compiler/parser/Parser.y.pp +++ b/ghc/compiler/parser/Parser.y.pp @@ -8,36 +8,36 @@ -- --------------------------------------------------------------------------- { -module Parser ( parseModule, parseStmt, parseIdentifier, parseIface ) 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, listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR ) import Type ( funTyCon ) -import ForeignCall ( Safety(..), CExportSpec(..), +import ForeignCall ( Safety(..), CExportSpec(..), CLabelString, CCallConv(..), CCallTarget(..), defaultCCallConv ) import OccName ( UserFS, varName, dataName, tcClsName, tvName ) import DataCon ( DataCon, dataConName ) import SrcLoc ( Located(..), unLoc, getLoc, noLoc, combineSrcSpans, - SrcSpan, combineLocs, mkGeneralSrcSpan, srcLocFile ) + SrcSpan, combineLocs, srcLocFile, + mkSrcLoc, mkSrcSpan ) import Module import CmdLineOpts ( opt_SccProfilingOn ) import Type ( Kind, mkArrowKind, liftedTypeKind ) import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..), - NewOrData(..), Activation(..) ) + Activation(..) ) import OrdList -import Bag ( emptyBag ) import Panic -import CStrings ( CLabelString ) import FastString import Maybes ( orElse ) import Outputable @@ -46,33 +46,49 @@ import GLAEXTS {- ----------------------------------------------------------------------------- -Conflicts: 29 shift/reduce, [SDM 19/9/2002] +Conflicts: 34 shift/reduce (1.15) -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) -8 for ambiguity in 'e :: a `b` c'. Does this mean [States 160,246] +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 ... + +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 @@ -80,10 +96,6 @@ Conflicts: 29 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 @@ -262,7 +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 } %% @@ -279,9 +292,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 @@ -307,32 +318,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 - { TyClD (mkTyData DataType (unLoc $2) [] Nothing) } - | 'newtype' tycl_hdr - { TyClD (mkTyData NewType (unLoc $2) [] Nothing) } - | 'class' tycl_hdr fds - { TyClD (mkClassDecl (unLoc $2) (unLoc $3) [] emptyBag) } +header_body :: { [LImportDecl RdrName] } + : '{' importdecls { $2 } + | vocurly importdecls { $2 } ----------------------------------------------------------------------------- -- The Export List @@ -389,7 +387,7 @@ optqualified :: { Bool } : 'qualified' { True } | {- empty -} { False } -maybeas :: { Located (Maybe ModuleName) } +maybeas :: { Located (Maybe Module) } : 'as' modid { LL (Just (unLoc $2)) } | {- empty -} { noLoc Nothing } @@ -438,20 +436,29 @@ 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 (unLoc $2) (reverse (unLoc $3)) (unLoc $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 + { 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 (unLoc $2) [$4] (unLoc $5)) } + (mkTyData NewType $2 Nothing [$4] (unLoc $5)) } | 'class' tycl_hdr fds where { let @@ -460,11 +467,9 @@ tycl_decl :: { LTyClDecl RdrName } L (comb4 $1 $2 $3 $4) (mkClassDecl (unLoc $2) (unLoc $3) sigs binds) } -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]) } +opt_kind_sig :: { Maybe Kind } + : { Nothing } + | '::' kind { Just $2 } -- tycl_hdr parses the header of a type or class decl, -- which takes the form @@ -473,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 } ----------------------------------------------------------------------------- @@ -482,7 +487,7 @@ tycl_hdr :: { Located (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrNam decls :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed : decls ';' decl { LL (unLoc $1 `appOL` unLoc $3) } | decls ';' { LL (unLoc $1) } - | decl { L1 (unLoc $1) } + | decl { $1 } | {- empty -} { noLoc nilOL } @@ -721,9 +726,9 @@ opt_asig :: { Maybe (LHsType RdrName) } : {- empty -} { Nothing } | '::' atype { Just $2 } -sigtypes :: { [LHsType RdrName] } +sigtypes1 :: { [LHsType RdrName] } : sigtype { [ $1 ] } - | sigtypes ',' sigtype { $3 : $1 } + | sigtype ',' sigtypes1 { $1 : $3 } sigtype :: { LHsType RdrName } : ctype { L1 (mkImplicitHsForAllTy (noLoc []) $1) } @@ -736,6 +741,10 @@ sig_vars :: { Located [Located RdrName] } ----------------------------------------------------------------------------- -- Types +strict_mark :: { Located HsBang } + : '!' { L1 HsStrict } + | '{-# UNPACK' '#-}' '!' { LL HsUnbox } + -- A ctype is a for-all type ctype :: { LHsType RdrName } : 'forall' tv_bndrs '.' ctype { LL $ mkExplicitHsForAllTy $2 (noLoc []) $4 } @@ -751,13 +760,13 @@ context :: { LHsContext RdrName } : btype {% checkContext $1 } type :: { LHsType RdrName } - : ipvar '::' gentype { LL (HsPredTy (LL $ HsIParam (unLoc $1) $3)) } + : ipvar '::' gentype { LL (HsPredTy (HsIParam (unLoc $1) $3)) } | gentype { $1 } 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 } @@ -766,7 +775,8 @@ btype :: { LHsType RdrName } atype :: { LHsType RdrName } : gtycon { L1 (HsTyVar (unLoc $1)) } - | tyvar { L1 (HsTyVar (unLoc $1)) } + | tyvarid { L1 (HsTyVar (unLoc $1)) } + | strict_mark atype { LL (HsBangTy (unLoc $1) $2) } | '(' type ',' comma_types1 ')' { LL $ HsTupleTy Boxed ($2:$4) } | '(#' comma_types1 '#)' { LL $ HsTupleTy Unboxed $2 } | '[' type ']' { LL $ HsListTy $2 } @@ -781,7 +791,11 @@ atype :: { LHsType RdrName } -- It's kept as a single type, with a MonoDictTy at the right -- hand corner, for convenience. inst_type :: { LHsType RdrName } - : ctype {% checkInstType $1 } + : sigtype {% checkInstType $1 } + +inst_types1 :: { [LHsType RdrName] } + : inst_type { [$1] } + | inst_type ',' inst_types1 { $1 : $3 } comma_types0 :: { [LHsType RdrName] } : comma_types1 { $1 } @@ -831,11 +845,22 @@ akind :: { Kind } -- Datatype declarations newconstr :: { LConDecl RdrName } - : conid atype { LL $ ConDecl $1 [] (noLoc []) - (PrefixCon [(unbangedType $2)]) } + : conid atype { LL $ ConDecl $1 [] (noLoc []) (PrefixCon [$2]) } | conid '{' var '::' ctype '}' - { LL $ ConDecl $1 [] (noLoc []) - (RecCon [($3, (unbangedType $5))]) } + { 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] } + +gadt_constr :: { LConDecl RdrName } + : qcon '::' sigtype + { LL (GadtDecl $1 $3) } constrs :: { Located [LConDecl RdrName] } : {- empty; a GHC extension -} { noLoc [] } @@ -858,43 +883,36 @@ forall :: { Located [LHsTyVarBndr RdrName] } | {- empty -} { noLoc [] } constr_stuff :: { Located (Located RdrName, HsConDetails RdrName (LBangType RdrName)) } +-- We parse the constructor declaration +-- C t1 t2 +-- as a btype (treating C as a type constructor) and then convert C to be +-- a data constructor. Reason: it might continue like this: +-- C t1 t2 %: D Int +-- in which case C really would be a type constructor. We can't resolve this +-- ambiguity till we come across the constructor oprerator :% (or not, more usually) : btype {% mkPrefixCon $1 [] >>= return.LL } - | btype bang_atype satypes {% do { r <- mkPrefixCon $1 ($2 : unLoc $3); - return (L (comb3 $1 $2 $3) r) } } | oqtycon '{' '}' {% mkRecCon $1 [] >>= return.LL } | oqtycon '{' fielddecls '}' {% mkRecCon $1 $3 >>= return.LL } - | sbtype conop sbtype { LL ($2, InfixCon $1 $3) } - -bang_atype :: { LBangType RdrName } - : strict_mark atype { LL (BangType (unLoc $1) $2) } - -satypes :: { Located [LBangType RdrName] } - : atype satypes { LL (unbangedType $1 : unLoc $2) } - | bang_atype satypes { LL ($1 : unLoc $2) } - | {- empty -} { noLoc [] } - -sbtype :: { LBangType RdrName } - : btype { unbangedType $1 } - | strict_mark atype { LL (BangType (unLoc $1) $2) } + | btype conop btype { LL ($2, InfixCon $1 $3) } fielddecls :: { [([Located RdrName], LBangType RdrName)] } : fielddecl ',' fielddecls { unLoc $1 : $3 } | fielddecl { [unLoc $1] } fielddecl :: { Located ([Located RdrName], LBangType RdrName) } - : sig_vars '::' stype { LL (reverse (unLoc $1), $3) } - -stype :: { LBangType RdrName } - : ctype { unbangedType $1 } - | strict_mark atype { LL (BangType (unLoc $1) $2) } - -strict_mark :: { Located HsBang } - : '!' { L1 HsStrict } - | '{-# UNPACK' '#-}' '!' { LL HsUnbox } - -deriving :: { Located (Maybe (LHsContext RdrName)) } - : {- empty -} { noLoc Nothing } - | 'deriving' context { LL (Just $2) } + : sig_vars '::' ctype { LL (reverse (unLoc $1), $3) } + +-- We allow the odd-looking 'inst_type' in a deriving clause, so that +-- we can do deriving( forall a. C [a] ) in a newtype (GHC extension). +-- The 'C [a]' part is converted to an HsPredTy by checkInstType +-- We don't allow a context, but that's sorted out by the type checker. +deriving :: { Located (Maybe [LHsType RdrName]) } + : {- empty -} { noLoc Nothing } + | 'deriving' qtycon {% do { let { L loc tv = $2 } + ; p <- checkInstType (L loc (HsTyVar tv)) + ; return (LL (Just [p])) } } + | 'deriving' '(' ')' { LL (Just []) } + | 'deriving' '(' inst_types1 ')' { LL (Just $3) } -- Glasgow extension: allow partial -- applications in derivings @@ -923,12 +941,12 @@ deriving :: { Located (Maybe (LHsContext RdrName)) } decl :: { Located (OrdList (LHsDecl RdrName)) } : sigdecl { $1 } - | infixexp opt_sig rhs {% do { r <- checkValDef $1 $2 (unLoc $3); + | infixexp opt_sig rhs {% do { r <- checkValDef $1 $2 $3; return (LL $ unitOL (LL $ ValD r)) } } rhs :: { Located (GRHSs RdrName) } - : '=' exp wherebinds { L (comb3 $1 $2 $3) $ GRHSs (unguardedRHS $2) (unLoc $3) placeHolderType } - | gdrhs wherebinds { LL $ GRHSs (reverse (unLoc $1)) (unLoc $2) placeHolderType } + : '=' exp wherebinds { L (comb3 $1 $2 $3) $ GRHSs (unguardedRHS $2) (unLoc $3) } + | gdrhs wherebinds { LL $ GRHSs (reverse (unLoc $1)) (unLoc $2) } gdrhs :: { Located [LGRHS RdrName] } : gdrhs gdrh { LL ($2 : unLoc $1) } @@ -951,7 +969,7 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) } { LL $ unitOL (LL $ SigD (InlineSig True $3 $2)) } | '{-# NOINLINE' inverse_activation qvar '#-}' { LL $ unitOL (LL $ SigD (InlineSig False $3 $2)) } - | '{-# SPECIALISE' qvar '::' sigtypes '#-}' + | '{-# SPECIALISE' qvar '::' sigtypes1 '#-}' { LL $ toOL [ LL $ SigD (SpecSig $2 t) | t <- $4] } | '{-# SPECIALISE' 'instance' inst_type '#-}' @@ -962,10 +980,10 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) } exp :: { LHsExpr RdrName } : infixexp '::' sigtype { LL $ ExprWithTySig $1 $3 } - | fexp '-<' exp { LL $ HsArrApp $1 $3 placeHolderType HsFirstOrderApp True } - | fexp '>-' exp { LL $ HsArrApp $3 $1 placeHolderType HsFirstOrderApp False } - | fexp '-<<' exp { LL $ HsArrApp $1 $3 placeHolderType HsHigherOrderApp True } - | fexp '>>-' exp { LL $ HsArrApp $3 $1 placeHolderType HsHigherOrderApp False} + | infixexp '-<' exp { LL $ HsArrApp $1 $3 placeHolderType HsFirstOrderApp True } + | infixexp '>-' exp { LL $ HsArrApp $3 $1 placeHolderType HsFirstOrderApp False } + | infixexp '-<<' exp { LL $ HsArrApp $1 $3 placeHolderType HsHigherOrderApp True } + | infixexp '>>-' exp { LL $ HsArrApp $3 $1 placeHolderType HsHigherOrderApp False} | infixexp { $1 } infixexp :: { LHsExpr RdrName } @@ -975,12 +993,12 @@ infixexp :: { LHsExpr RdrName } exp10 :: { LHsExpr RdrName } : '\\' aexp aexps opt_asig '->' exp {% checkPatterns ($2 : reverse $3) >>= \ ps -> - return (LL $ HsLam (LL $ Match ps $4 + return (LL $ HsLam (mkMatchGroup [LL $ Match ps $4 (GRHSs (unguardedRHS $6) [] - placeHolderType))) } + )])) } | 'let' binds 'in' exp { LL $ HsLet (unLoc $2) $4 } | 'if' exp 'then' exp 'else' exp { LL $ HsIf $2 $4 $6 } - | 'case' exp 'of' altslist { LL $ HsCase $2 (unLoc $4) } + | 'case' exp 'of' altslist { LL $ HsCase $2 (mkMatchGroup (unLoc $4)) } | '-' fexp { LL $ mkHsNegApp $2 } | 'do' stmtlist {% let loc = comb2 $1 $2 in @@ -1057,7 +1075,7 @@ aexp2 :: { LHsExpr RdrName } | '$(' exp ')' { LL $ HsSpliceE (mkHsSplice $2) } -- $( exp ) | TH_VAR_QUOTE qvar { LL $ HsBracket (VarBr (unLoc $2)) } - | TH_VAR_QUOTE qcon { LL $ HsBracket (VarBr (unLoc $2)) } + | TH_VAR_QUOTE gcon { 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) } @@ -1174,8 +1192,7 @@ alt :: { LMatch RdrName } return (LL (Match [p] $2 (unLoc $3))) } alt_rhs :: { Located (GRHSs RdrName) } - : ralt wherebinds { LL (GRHSs (unLoc $1) (unLoc $2) - placeHolderType) } + : ralt wherebinds { LL (GRHSs (unLoc $1) (unLoc $2)) } ralt :: { Located [LGRHS RdrName] } : '->' exp { LL (unguardedRHS $2) } @@ -1340,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 } @@ -1391,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 @@ -1444,7 +1471,7 @@ special_sym : '!' { L1 FSLIT("!") } ----------------------------------------------------------------------------- -- Data constructors -qconid :: { Located RdrName } -- Qualified or unqualifiedb +qconid :: { Located RdrName } -- Qualified or unqualified : conid { $1 } | QCONID { L1 $ mkQual dataName (getQCONID $1) } @@ -1484,10 +1511,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)) } @@ -1539,8 +1566,12 @@ comb4 a b c d = combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $ sL :: SrcSpan -> a -> Located a sL span a = span `seq` L span a --- Make a source location that is just the filename. This seems slightly --- neater than trying to construct the span of the text within the file. +-- Make a source location for the file. We're a bit lazy here and just +-- make a point SrcSpan at line 1, column 0. Strictly speaking we should +-- try to find the span of the whole file (ToDo). fileSrcSpan :: P SrcSpan -fileSrcSpan = do l <- getSrcLoc; return (mkGeneralSrcSpan (srcLocFile l)) +fileSrcSpan = do + l <- getSrcLoc; + let loc = mkSrcLoc (srcLocFile l) 1 0; + return (mkSrcSpan loc loc) }