X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FParser.y.pp;h=83b299a7b86243d55515b2b60aa01e93396a30a1;hb=252abd9e355fe12e8f6f1e0192542a0df6ddccac;hp=8276bb5757eae3f427bf687ceadc0321c2ca9a04;hpb=354011fa6b76e00d3954f9bdbc0e20181c78e45f;p=ghc-hetmet.git diff --git a/ghc/compiler/parser/Parser.y.pp b/ghc/compiler/parser/Parser.y.pp index 8276bb5..83b299a 100644 --- a/ghc/compiler/parser/Parser.y.pp +++ b/ghc/compiler/parser/Parser.y.pp @@ -8,7 +8,7 @@ -- --------------------------------------------------------------------------- { -module Parser ( parseModule, parseStmt, parseIdentifier, parseIface ) where +module Parser ( parseModule, parseStmt, parseIdentifier, parseIface, parseType ) where #define INCLUDE #include INCLUDE "HsVersions.h" @@ -21,23 +21,23 @@ 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 @@ -58,6 +58,9 @@ Conflicts: 29 shift/reduce, [SDM 19/9/2002] 1 for ambiguity in 'if x then y else z :: T' [State 136] (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' + (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] (e::a) `b` c, or (e :: (a `b` c)) @@ -263,6 +266,7 @@ TH_TY_QUOTE { L _ ITtyQuote } -- ''T %name parseStmt maybe_stmt %name parseIdentifier identifier %name parseIface iface +%name parseType ctype %tokentype { Located Token } %% @@ -327,10 +331,12 @@ ifacedecl :: { HsDecl RdrName } { 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 + | 'data' tycl_hdr constrs -- No deriving in hi-boot + { TyClD (mkTyData DataType (unLoc $2) (reverse (unLoc $3)) Nothing) } + | 'newtype' tycl_hdr -- Constructor is optional { TyClD (mkTyData NewType (unLoc $2) [] Nothing) } + | 'newtype' tycl_hdr '=' newconstr + { TyClD (mkTyData NewType (unLoc $2) [$4] Nothing) } | 'class' tycl_hdr fds { TyClD (mkClassDecl (unLoc $2) (unLoc $3) [] emptyBag) } @@ -721,9 +727,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) } @@ -751,7 +757,7 @@ 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 } @@ -783,6 +789,10 @@ atype :: { LHsType RdrName } inst_type :: { LHsType RdrName } : ctype {% checkInstType $1 } +inst_types1 :: { [LHsType RdrName] } + : inst_type { [$1] } + | inst_type ',' inst_types1 { $1 : $3 } + comma_types0 :: { [LHsType RdrName] } : comma_types1 { $1 } | {- empty -} { [] } @@ -892,9 +902,17 @@ strict_mark :: { Located HsBang } : '!' { L1 HsStrict } | '{-# UNPACK' '#-}' '!' { LL HsUnbox } -deriving :: { Located (Maybe (LHsContext RdrName)) } - : {- empty -} { noLoc Nothing } - | 'deriving' context { LL (Just $2) } +-- 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,7 +941,7 @@ 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) } @@ -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 } @@ -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) } @@ -1539,8 +1557,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) }