X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FParser.y.pp;h=a827ee4c5e52b360568c6bc40f0e505f6e5d4076;hp=3958b9cf9a74d878db0885dc6ca8e7d40dcb3bb1;hb=HEAD;hpb=34c8d0312071f7d0f4d221a997d3408c653ef9e5 diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 3958b9c..a827ee4 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -41,9 +41,7 @@ import ForeignCall ( Safety(..), CExportSpec(..), CLabelString, ) import OccName ( varName, varNameDepth, dataName, tcClsName, tvName ) import DataCon ( DataCon, dataConName ) -import SrcLoc ( Located(..), unLoc, getLoc, noLoc, combineSrcSpans, - SrcSpan, combineLocs, srcLocFile, - mkSrcLoc, mkSrcSpan ) +import SrcLoc import Module import StaticFlags ( opt_SccProfilingOn, opt_Hpc ) import Type ( Kind, liftedTypeKind, unliftedTypeKind ) @@ -62,8 +60,10 @@ import Control.Monad ( unless ) import GHC.Exts import Data.Char import Control.Monad ( mplus ) + } + {- ----------------------------------------------------------------------------- 24 Februar 2006 @@ -254,19 +254,22 @@ incorrect. 'by' { L _ ITby } -- for list transform extension 'using' { L _ ITusing } -- for list transform extension - '{-# INLINE' { L _ (ITinline_prag _ _) } - '{-# SPECIALISE' { L _ ITspec_prag } + '{-# INLINE' { L _ (ITinline_prag _ _) } + '{-# SPECIALISE' { L _ ITspec_prag } '{-# SPECIALISE_INLINE' { L _ (ITspec_inline_prag _) } - '{-# SOURCE' { L _ ITsource_prag } - '{-# RULES' { L _ ITrules_prag } - '{-# CORE' { L _ ITcore_prag } -- hdaume: annotated core - '{-# SCC' { L _ ITscc_prag } - '{-# GENERATED' { L _ ITgenerated_prag } - '{-# DEPRECATED' { L _ ITdeprecated_prag } - '{-# WARNING' { L _ ITwarning_prag } - '{-# UNPACK' { L _ ITunpack_prag } - '{-# ANN' { L _ ITann_prag } - '#-}' { L _ ITclose_prag } + '{-# SOURCE' { L _ ITsource_prag } + '{-# RULES' { L _ ITrules_prag } + '{-# CORE' { L _ ITcore_prag } -- hdaume: annotated core + '{-# SCC' { L _ ITscc_prag } + '{-# GENERATED' { L _ ITgenerated_prag } + '{-# DEPRECATED' { L _ ITdeprecated_prag } + '{-# WARNING' { L _ ITwarning_prag } + '{-# UNPACK' { L _ ITunpack_prag } + '{-# ANN' { L _ ITann_prag } + '{-# VECTORISE' { L _ ITvect_prag } + '{-# VECTORISE_SCALAR' { L _ ITvect_scalar_prag } + '{-# NOVECTORISE' { L _ ITnovect_prag } + '#-}' { L _ ITclose_prag } '..' { L _ ITdotdot } -- reserved symbols ':' { L _ ITcolon } @@ -276,6 +279,7 @@ incorrect. '|' { L _ ITvbar } '<-' { L _ ITlarrow } '->' { L _ ITrarrow } + '~~>' { L _ ITkappa } '@' { L _ ITat } '~' { L _ ITtilde } '=>' { L _ ITdarrow } @@ -306,6 +310,8 @@ incorrect. '|)' { L _ ITcparenbar } '<[' { L _ ITopenBrak } ']>' { L _ ITcloseBrak } + '<{' { L _ ITopenBrak1 } + '}>' { L _ ITcloseBrak1 } '~~' { L _ ITescape } '~~$' { L _ ITescapeDollar } '%%' { L _ ITdoublePercent } @@ -474,7 +480,8 @@ export :: { LIE RdrName } | oqtycon '(' ')' { LL (IEThingWith (unLoc $1) []) } | oqtycon '(' qcnames ')' { LL (IEThingWith (unLoc $1) (reverse $3)) } | 'module' modid { LL (IEModuleContents (unLoc $2)) } - + | '<[' incdepth export decdepth ']>' { $3 } + | '<{' incdepth1 export decdepth '}>' { $3 } qcnames :: { [RdrName] } : qcnames ',' qcname_ext { unLoc $3 : $1 } | qcname_ext { [unLoc $1] } @@ -551,31 +558,34 @@ ops :: { Located [Located RdrName] } -- Top-Level Declarations topdecls :: { OrdList (LHsDecl RdrName) } - : topdecls ';' topdecl { $1 `appOL` $3 } - | topdecls ';' { $1 } - | topdecl { $1 } + : topdecls ';' topdecl { $1 `appOL` $3 } + | topdecls ';' { $1 } + | topdecl { $1 } topdecl :: { OrdList (LHsDecl RdrName) } - : cl_decl { unitOL (L1 (TyClD (unLoc $1))) } - | ty_decl { unitOL (L1 (TyClD (unLoc $1))) } - | 'instance' inst_type where_inst - { let (binds, sigs, ats, _) = cvBindsAndSigs (unLoc $3) - in - unitOL (L (comb3 $1 $2 $3) (InstD (InstDecl $2 binds sigs ats)))} + : cl_decl { unitOL (L1 (TyClD (unLoc $1))) } + | ty_decl { unitOL (L1 (TyClD (unLoc $1))) } + | 'instance' inst_type where_inst + { let (binds, sigs, ats, _) = cvBindsAndSigs (unLoc $3) + in + unitOL (L (comb3 $1 $2 $3) (InstD (InstDecl $2 binds sigs ats)))} | stand_alone_deriving { unitOL (LL (DerivD (unLoc $1))) } - | 'default' '(' comma_types0 ')' { unitOL (LL $ DefD (DefaultDecl $3)) } - | 'foreign' fdecl { unitOL (LL (unLoc $2)) } + | 'default' '(' comma_types0 ')' { unitOL (LL $ DefD (DefaultDecl $3)) } + | 'foreign' fdecl { unitOL (LL (unLoc $2)) } | '{-# DEPRECATED' deprecations '#-}' { $2 } | '{-# WARNING' warnings '#-}' { $2 } - | '{-# RULES' rules '#-}' { $2 } - | annotation { unitOL $1 } - | decl { unLoc $1 } - - -- Template Haskell Extension - -- The $(..) form is one possible form of infixexp - -- but we treat an arbitrary expression just as if - -- it had a $(..) wrapped around it - | infixexp { unitOL (LL $ mkTopSpliceDecl $1) } + | '{-# RULES' rules '#-}' { $2 } + | '{-# VECTORISE_SCALAR' qvar '#-}' { unitOL $ LL $ VectD (HsVect $2 Nothing) } + | '{-# VECTORISE' qvar '=' exp '#-}' { unitOL $ LL $ VectD (HsVect $2 (Just $4)) } + | '{-# NOVECTORISE' qvar '#-}' { unitOL $ LL $ VectD (HsNoVect $2) } + | annotation { unitOL $1 } + | decl { unLoc $1 } + + -- Template Haskell Extension + -- The $(..) form is one possible form of infixexp + -- but we treat an arbitrary expression just as if + -- it had a $(..) wrapped around it + | infixexp { unitOL (LL $ mkTopSpliceDecl $1) } -- Type classes -- @@ -722,6 +732,11 @@ decl_cls :: { Located (OrdList (LHsDecl RdrName)) } decl_cls : at_decl_cls { LL (unitOL (L1 (TyClD (unLoc $1)))) } | decl { $1 } + -- A 'default' signature used with the generic-programming extension + | 'default' infixexp '::' sigtypedoc + {% do { (TypeSig l ty) <- checkValSig $2 $4 + ; return (LL $ unitOL (LL $ SigD (GenericSig l ty))) } } + decls_cls :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed : decls_cls ';' decl_cls { LL (unLoc $1 `appOL` unLoc $3) } | decls_cls ';' { LL (unLoc $1) } @@ -991,6 +1006,7 @@ type :: { LHsType RdrName } | btype qtyconop type { LL $ HsOpTy $1 $2 $3 } | btype tyvarop type { LL $ HsOpTy $1 $2 $3 } | btype '->' ctype { LL $ HsFunTy $1 $3 } + | btype '~~>' ctype { LL $ HsKappaTy $1 $3 } | btype '~' btype { LL $ HsPredTy (HsEqualP $1 $3) } typedoc :: { LHsType RdrName } @@ -1016,7 +1032,8 @@ atype :: { LHsType RdrName } | '(' ctype ',' comma_types1 ')' { LL $ HsTupleTy Boxed ($2:$4) } | '(#' comma_types1 '#)' { LL $ HsTupleTy Unboxed $2 } | '[' ctype ']' { LL $ HsListTy $2 } - | '<[' ctype ']>' '@' tyvar { LL $ HsModalBoxType (unLoc $5) $2 } + | '<{' ctype '}>' '@' tyvar { LL $ HsModalBoxType (unLoc $5) $2 } + | '<[' ctype ']>' '@' tyvar { LL $ HsModalBoxType (unLoc $5) $2 } | '[:' ctype ':]' { LL $ HsPArrTy $2 } | '(' ctype ')' { LL $ HsParTy $2 } | '(' ctype '::' kind ')' { LL $ HsKindSig $2 (unLoc $4) } @@ -1024,8 +1041,6 @@ atype :: { LHsType RdrName } | '$(' exp ')' { LL $ mkHsSpliceTy $2 } | TH_ID_SPLICE { LL $ mkHsSpliceTy $ L1 $ HsVar $ mkUnqual varName (getTH_ID_SPLICE $1) } --- Generics - | INTEGER { L1 (HsNumTy (getINTEGER $1)) } -- An inst_type is what occurs in the head of an instance decl -- e.g. (Foo a, Gaz b) => Wibble a b @@ -1235,10 +1250,11 @@ gdrh :: { LGRHS RdrName } : '|' guardquals '=' exp { sL (comb2 $1 $>) $ GRHS (unLoc $2) $4 } sigdecl :: { Located (OrdList (LHsDecl RdrName)) } - : infixexp '::' sigtypedoc {% do s <- checkValSig $1 $3 - ; return (LL $ unitOL (LL $ SigD s)) } - -- See Note [Declaration/signature overlap] for why we need infixexp here - + : + -- See Note [Declaration/signature overlap] for why we need infixexp here + infixexp '::' sigtypedoc + {% do s <- checkValSig $1 $3 + ; return (LL $ unitOL (LL $ SigD s)) } | var ',' sig_vars '::' sigtypedoc { 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)))) @@ -1261,10 +1277,13 @@ quasiquote :: { Located (HsQuasiQuote RdrName) } : TH_QUASIQUOTE { let { loc = getLoc $1 ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1 ; quoterId = mkUnqual varName quoter } - in L1 (mkHsQuasiQuote quoterId quoteSpan quote) } + in L1 (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) } -incdepth :: { Located () } : {% do { incrBracketDepth ; return $ noLoc () } } -decdepth :: { Located () } : {% do { decrBracketDepth ; return $ noLoc () } } +incdepth :: { Located () } : {% do { incrBracketDepth ; return $ noLoc () } } +incdepth1 :: { Located () } : {% do { incrBracketDepth1 ; return $ noLoc () } } +decdepth :: { Located () } : {% do { decrBracketDepth ; return $ noLoc () } } +pushdepth :: { Located () } : {% do { pushBracketDepth ; return $ noLoc () } } +popdepth :: { Located () } : {% do { popBracketDepth ; return $ noLoc () } } exp :: { LHsExpr RdrName } @@ -1274,7 +1293,7 @@ exp :: { LHsExpr RdrName } | infixexp '-<<' exp { LL $ HsArrApp $1 $3 placeHolderType HsHigherOrderApp True } | infixexp '>>-' exp { LL $ HsArrApp $3 $1 placeHolderType HsHigherOrderApp False} | infixexp { $1 } - | '~~$' decdepth exp incdepth { sL (comb2 $3 $>) (HsHetMetEsc placeHolderType placeHolderType $3) } + | '~~$' pushdepth exp popdepth {% do { x <- mkHsHetMetEsc placeHolderType placeHolderType $3; return $ sL (comb2 $3 $>) x } } infixexp :: { LHsExpr RdrName } : exp10 { $1 } @@ -1282,9 +1301,12 @@ infixexp :: { LHsExpr RdrName } exp10 :: { LHsExpr RdrName } : '\\' apat apats opt_asig '->' exp - { LL $ HsLam (mkMatchGroup [LL $ Match ($2:$3) $4 - (unguardedGRHSs $6) - ]) } + {% do { x <- getParserBrakDepth + ; return + $ case x of + KappaFlavor:_ -> LL $ HsKappa (mkMatchGroup[LL $ Match ($2:$3) $4 (unguardedGRHSs $6) ]) + _ -> LL $ HsLam (mkMatchGroup [LL $ Match ($2:$3) $4 (unguardedGRHSs $6) ]) + } } | 'let' binds 'in' exp { LL $ HsLet (unLoc $2) $4 } | 'if' exp optSemi 'then' exp optSemi 'else' exp {% checkDoAndIfThenElse $2 $3 $5 $6 $8 >> @@ -1292,14 +1314,9 @@ exp10 :: { LHsExpr RdrName } | 'case' exp 'of' altslist { LL $ HsCase $2 (mkMatchGroup (unLoc $4)) } | '-' fexp { LL $ NegApp $2 noSyntaxExpr } - | 'do' stmtlist {% let loc = comb2 $1 $2 in - checkDo loc (unLoc $2) >>= \ (stmts,body) -> - return (L loc (mkHsDo DoExpr stmts body)) } - | 'mdo' stmtlist {% let loc = comb2 $1 $2 in - checkDo loc (unLoc $2) >>= \ (stmts,body) -> - return (L loc (mkHsDo MDoExpr - [L loc (mkRecStmt stmts)] - body)) } + | 'do' stmtlist { L (comb2 $1 $2) (mkHsDo DoExpr (unLoc $2)) } + | 'mdo' stmtlist { L (comb2 $1 $2) (mkHsDo MDoExpr (unLoc $2)) } + | scc_annot exp { LL $ if opt_SccProfilingOn then HsSCC (unLoc $1) $2 else HsPar $2 } @@ -1339,7 +1356,12 @@ hpc_annot :: { Located (FastString,(Int,Int),(Int,Int)) } } fexp :: { LHsExpr RdrName } - : fexp aexp { LL $ HsApp $1 $2 } + : fexp aexp {% do { x <- getParserBrakDepth + ; return $ case x of + [] -> LL $ HsApp $1 $2 + LambdaFlavor:_ -> LL $ HsApp $1 $2 + KappaFlavor:_ -> LL $ HsKappaApp $1 $2 + } } | aexp { $1 } aexp :: { LHsExpr RdrName } @@ -1406,9 +1428,10 @@ aexp2 :: { LHsExpr RdrName } | '(|' aexp2 cmdargs '|)' { LL $ HsArrForm $2 Nothing (reverse $3) } -- code type notation extension - | '<[' incdepth exp decdepth ']>' { sL (comb2 $3 $>) (HsHetMetBrak placeHolderType $3) } - | '~~' decdepth aexp incdepth { sL (comb2 $3 $>) (HsHetMetEsc placeHolderType placeHolderType $3) } - | '%%' decdepth aexp incdepth { sL (comb2 $3 $>) (HsHetMetCSP placeHolderType $3) } + | '<[' incdepth exp decdepth ']>' { sL (comb2 $3 $>) (HsHetMetBrak placeHolderType $3) } + | '<{' incdepth1 exp decdepth '}>' { sL (comb2 $3 $>) (HsHetMetBrak placeHolderType $3) } + | '~~' pushdepth aexp popdepth {% do { x <- mkHsHetMetEsc placeHolderType placeHolderType $3; return $ sL (comb2 $3 $>) x } } + | '%%' pushdepth aexp popdepth { sL (comb2 $3 $>) (HsHetMetCSP placeHolderType $3) } cmdargs :: { [LHsCmdTop RdrName] } : cmdargs acmd { $2 : $1 } @@ -1479,7 +1502,10 @@ list :: { LHsExpr RdrName } | texp ',' exp '..' { LL $ ArithSeq noPostTcExpr (FromThen $1 $3) } | texp '..' exp { LL $ ArithSeq noPostTcExpr (FromTo $1 $3) } | texp ',' exp '..' exp { LL $ ArithSeq noPostTcExpr (FromThenTo $1 $3 $5) } - | texp '|' flattenedpquals { sL (comb2 $1 $>) $ mkHsDo ListComp (unLoc $3) $1 } + | texp '|' flattenedpquals + {% checkMonadComp >>= \ ctxt -> + return (sL (comb2 $1 $>) $ + mkHsComp ctxt (unLoc $3) $1) } lexps :: { Located [LHsExpr RdrName] } : lexps ',' texp { LL (((:) $! $3) $! unLoc $1) } @@ -1494,7 +1520,7 @@ flattenedpquals :: { Located [LStmt RdrName] } -- We just had one thing in our "parallel" list so -- we simply return that thing directly - qss -> L1 [L1 $ ParStmt [(qs, undefined) | qs <- qss]] + qss -> L1 [L1 $ ParStmt [(qs, undefined) | qs <- qss] noSyntaxExpr noSyntaxExpr noSyntaxExpr] -- We actually found some actual parallel lists so -- we wrap them into as a ParStmt } @@ -1515,8 +1541,7 @@ squals :: { Located [LStmt RdrName] } -- In reverse order, because the last -- It is possible to enable bracketing (associating) qualifier lists by uncommenting the lines with {| |} -- above. Due to a lack of consensus on the syntax, this feature is not being used until we get user --- demand. Note that the {| |} symbols are reused from -XGenerics and hence if you want to compile --- a program that makes use of this temporary syntax you must supply that flag to GHC +-- demand. transformqual :: { Located ([LStmt RdrName] -> Stmt RdrName) } -- Function is applied to a list of stmts *in order* @@ -1551,7 +1576,7 @@ parr :: { LHsExpr RdrName } (reverse (unLoc $1)) } | texp '..' exp { LL $ PArrSeq noPostTcExpr (FromTo $1 $3) } | texp ',' exp '..' exp { LL $ PArrSeq noPostTcExpr (FromThenTo $1 $3 $5) } - | texp '|' flattenedpquals { LL $ mkHsDo PArrComp (unLoc $3) $1 } + | texp '|' flattenedpquals { LL $ mkHsComp PArrComp (unLoc $3) $1 } -- We are reusing `lexps' and `flattenedpquals' from the list case. @@ -1841,7 +1866,7 @@ qvarid :: { Located RdrName } | PREFIXQVARSYM { L1 $! mkQual varName (getPREFIXQVARSYM $1) } varid :: { Located RdrName } - : VARID {% do { depth <- getParserBrakDepth ; return (L1 $! mkUnqual (varNameDepth depth) (getVARID $1)) } } + : VARID {% do { depth <- getParserBrakDepth ; return (L1 $! mkUnqual (varNameDepth $ length depth) (getVARID $1)) } } | special_id { L1 $! mkUnqual varName (unLoc $1) } | 'unsafe' { L1 $! mkUnqual varName (fsLit "unsafe") } | 'safe' { L1 $! mkUnqual varName (fsLit "safe") } @@ -1867,9 +1892,9 @@ varsym :: { Located RdrName } varsym_no_minus :: { Located RdrName } -- varsym not including '-' : VARSYM {% do { depth <- getParserBrakDepth - ; return (L1 $! mkUnqual (varNameDepth depth) (getVARSYM $1)) } } + ; return (L1 $! mkUnqual (varNameDepth $ length depth) (getVARSYM $1)) } } | special_sym {% do { depth <- getParserBrakDepth - ; return (L1 $! mkUnqual (varNameDepth depth) (unLoc $1)) } } + ; return (L1 $! mkUnqual (varNameDepth $ length depth) (unLoc $1)) } } -- These special_ids are treated as keywords in various places, -- but as ordinary ids elsewhere. 'special_id' collects all these @@ -2050,4 +2075,12 @@ fileSrcSpan = do l <- getSrcLoc; let loc = mkSrcLoc (srcLocFile l) 1 1; return (mkSrcSpan loc loc) + +mkHsHetMetEsc a b c = do { depth <- getParserBrakDepth + ; return $ case head depth of + { LambdaFlavor -> HsHetMetEsc a b c + ; KappaFlavor -> HsHetMetEsc a b c + } + } + }