diff options
33 files changed, 285 insertions, 92 deletions
diff --git a/compiler/basicTypes/BasicTypes.hs b/compiler/basicTypes/BasicTypes.hs index f8d4e8fe3e..5db992de51 100644 --- a/compiler/basicTypes/BasicTypes.hs +++ b/compiler/basicTypes/BasicTypes.hs @@ -312,14 +312,15 @@ pprRuleName rn = doubleQuotes (ftext rn) -} ------------------------ -data Fixity = Fixity Int FixityDirection +data Fixity = Fixity SourceText Int FixityDirection + -- Note [Pragma source text] deriving (Data, Typeable) instance Outputable Fixity where - ppr (Fixity prec dir) = hcat [ppr dir, space, int prec] + ppr (Fixity _ prec dir) = hcat [ppr dir, space, int prec] instance Eq Fixity where -- Used to determine if two fixities conflict - (Fixity p1 dir1) == (Fixity p2 dir2) = p1==p2 && dir1 == dir2 + (Fixity _ p1 dir1) == (Fixity _ p2 dir2) = p1==p2 && dir1 == dir2 ------------------------ data FixityDirection = InfixL | InfixR | InfixN @@ -336,12 +337,12 @@ maxPrecedence = 9 minPrecedence = 0 defaultFixity :: Fixity -defaultFixity = Fixity maxPrecedence InfixL +defaultFixity = Fixity (show maxPrecedence) maxPrecedence InfixL negateFixity, funTyFixity :: Fixity -- Wired-in fixities -negateFixity = Fixity 6 InfixL -- Fixity of unary negate -funTyFixity = Fixity 0 InfixR -- Fixity of '->' +negateFixity = Fixity "6" 6 InfixL -- Fixity of unary negate +funTyFixity = Fixity "0" 0 InfixR -- Fixity of '->' {- Consider @@ -356,7 +357,7 @@ whether there's an error. compareFixity :: Fixity -> Fixity -> (Bool, -- Error please Bool) -- Associate to the right: a op1 (b op2 c) -compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2) +compareFixity (Fixity _ prec1 dir1) (Fixity _ prec2 dir2) = case prec1 `compare` prec2 of GT -> left LT -> right @@ -889,11 +890,15 @@ instance Outputable CompilerPhase where ppr (Phase n) = int n ppr InitialPhase = ptext (sLit "InitialPhase") +-- See note [Pragma source text] data Activation = NeverActive | AlwaysActive - | ActiveBefore PhaseNum -- Active only *strictly before* this phase - | ActiveAfter PhaseNum -- Active in this phase and later - deriving( Eq, Data, Typeable ) -- Eq used in comparing rules in HsDecls + | ActiveBefore SourceText PhaseNum + -- Active only *strictly before* this phase + | ActiveAfter SourceText PhaseNum + -- Active in this phase and later + deriving( Eq, Data, Typeable ) + -- Eq used in comparing rules in HsDecls data RuleMatchInfo = ConLike -- See Note [CONLIKE pragma] | FunLike @@ -1051,10 +1056,10 @@ setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma setInlinePragmaRuleMatchInfo prag info = prag { inl_rule = info } instance Outputable Activation where - ppr AlwaysActive = brackets (ptext (sLit "ALWAYS")) - ppr NeverActive = brackets (ptext (sLit "NEVER")) - ppr (ActiveBefore n) = brackets (char '~' <> int n) - ppr (ActiveAfter n) = brackets (int n) + ppr AlwaysActive = brackets (ptext (sLit "ALWAYS")) + ppr NeverActive = brackets (ptext (sLit "NEVER")) + ppr (ActiveBefore _ n) = brackets (char '~' <> int n) + ppr (ActiveAfter _ n) = brackets (int n) instance Outputable RuleMatchInfo where ppr ConLike = ptext (sLit "CONLIKE") @@ -1087,10 +1092,10 @@ isActive InitialPhase _ = False isActive (Phase p) act = isActiveIn p act isActiveIn :: PhaseNum -> Activation -> Bool -isActiveIn _ NeverActive = False -isActiveIn _ AlwaysActive = True -isActiveIn p (ActiveAfter n) = p <= n -isActiveIn p (ActiveBefore n) = p > n +isActiveIn _ NeverActive = False +isActiveIn _ AlwaysActive = True +isActiveIn p (ActiveAfter _ n) = p <= n +isActiveIn p (ActiveBefore _ n) = p > n competesWith :: Activation -> Activation -> Bool -- See Note [Activation competition] @@ -1098,13 +1103,13 @@ competesWith NeverActive _ = False competesWith _ NeverActive = False competesWith AlwaysActive _ = True -competesWith (ActiveBefore {}) AlwaysActive = True -competesWith (ActiveBefore {}) (ActiveBefore {}) = True -competesWith (ActiveBefore a) (ActiveAfter b) = a < b +competesWith (ActiveBefore {}) AlwaysActive = True +competesWith (ActiveBefore {}) (ActiveBefore {}) = True +competesWith (ActiveBefore _ a) (ActiveAfter _ b) = a < b competesWith (ActiveAfter {}) AlwaysActive = False competesWith (ActiveAfter {}) (ActiveBefore {}) = False -competesWith (ActiveAfter a) (ActiveAfter b) = a >= b +competesWith (ActiveAfter _ a) (ActiveAfter _ b) = a >= b {- Note [Competing activations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs index f796d76853..27e9dc1d17 100644 --- a/compiler/basicTypes/MkId.hs +++ b/compiler/basicTypes/MkId.hs @@ -1119,7 +1119,8 @@ seqId = pcMiscPrelId seqName ty info `setUnfoldingInfo` mkCompulsoryUnfolding rhs `setRuleInfo` mkRuleInfo [seq_cast_rule] - inline_prag = alwaysInlinePragma `setInlinePragmaActivation` ActiveAfter 0 + inline_prag + = alwaysInlinePragma `setInlinePragmaActivation` ActiveAfter "0" 0 -- Make 'seq' not inline-always, so that simpleOptExpr -- (see CoreSubst.simple_app) won't inline 'seq' on the -- LHS of rules. That way we can have rules for 'seq'; diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index 6dc7383d8b..762883b4d1 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -622,7 +622,7 @@ addTickHsExpr (HsTick t e) = addTickHsExpr (HsBinTick t0 t1 e) = liftM (HsBinTick t0 t1) (addTickLHsExprNever e) -addTickHsExpr (HsTickPragma _ _ (L pos e0)) = do +addTickHsExpr (HsTickPragma _ _ _ (L pos e0)) = do e2 <- allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0 return $ unLoc e2 diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index 357d2fd38f..cfa68338ea 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -717,7 +717,7 @@ dsExpr (HsBinTick ixT ixF e) = do mkBinaryTickBox ixT ixF e2 } -dsExpr (HsTickPragma _ _ expr) = do +dsExpr (HsTickPragma _ _ _ expr) = do dflags <- getDynFlags if gopt Opt_Hpc dflags then panic "dsExpr:HsTickPragma" diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index eadd243a11..acd32ba15b 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -531,7 +531,7 @@ repSafety PlayInterruptible = rep2 interruptibleName [] repSafety PlaySafe = rep2 safeName [] repFixD :: LFixitySig Name -> DsM [(SrcSpan, Core TH.DecQ)] -repFixD (L loc (FixitySig names (Fixity prec dir))) +repFixD (L loc (FixitySig names (Fixity _ prec dir))) = do { MkC prec' <- coreIntLit prec ; let rep_fn = case dir of InfixL -> infixLDName @@ -778,11 +778,11 @@ repRuleMatch ConLike = dataCon conLikeDataConName repRuleMatch FunLike = dataCon funLikeDataConName repPhases :: Activation -> DsM (Core TH.Phases) -repPhases (ActiveBefore i) = do { MkC arg <- coreIntLit i - ; dataCon' beforePhaseDataConName [arg] } -repPhases (ActiveAfter i) = do { MkC arg <- coreIntLit i - ; dataCon' fromPhaseDataConName [arg] } -repPhases _ = dataCon allPhasesDataConName +repPhases (ActiveBefore _ i) = do { MkC arg <- coreIntLit i + ; dataCon' beforePhaseDataConName [arg] } +repPhases (ActiveAfter _ i) = do { MkC arg <- coreIntLit i + ; dataCon' fromPhaseDataConName [arg] } +repPhases _ = dataCon allPhasesDataConName ------------------------------------------------------- -- Types diff --git a/compiler/deSugar/PmExpr.hs b/compiler/deSugar/PmExpr.hs index 56e7eb8eb7..4ca9461a5d 100644 --- a/compiler/deSugar/PmExpr.hs +++ b/compiler/deSugar/PmExpr.hs @@ -263,7 +263,7 @@ hsExprToPmExpr e@(RecordCon _ _ _ _) = PmExprOther e hsExprToPmExpr (HsTick _ e) = lhsExprToPmExpr e hsExprToPmExpr (HsBinTick _ _ e) = lhsExprToPmExpr e -hsExprToPmExpr (HsTickPragma _ _ e) = lhsExprToPmExpr e +hsExprToPmExpr (HsTickPragma _ _ _ e) = lhsExprToPmExpr e hsExprToPmExpr (HsSCC _ _ e) = lhsExprToPmExpr e hsExprToPmExpr (HsCoreAnn _ _ e) = lhsExprToPmExpr e hsExprToPmExpr (ExprWithTySig e _) = lhsExprToPmExpr e diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 251fa19d99..c76fc3a5c5 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -664,8 +664,8 @@ cvtRuleMatch TH.FunLike = Hs.FunLike cvtPhases :: TH.Phases -> Activation -> Activation cvtPhases AllPhases dflt = dflt -cvtPhases (FromPhase i) _ = ActiveAfter i -cvtPhases (BeforePhase i) _ = ActiveBefore i +cvtPhases (FromPhase i) _ = ActiveAfter (show i) i +cvtPhases (BeforePhase i) _ = ActiveBefore (show i) i cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr RdrName) cvtRuleBndr (RuleVar n) @@ -1267,7 +1267,7 @@ cvtInjectivityAnnotation (TH.InjectivityAnn annLHS annRHS) ----------------------------------------------------------- cvtFixity :: TH.Fixity -> Hs.Fixity -cvtFixity (TH.Fixity prec dir) = Hs.Fixity prec (cvt_dir dir) +cvtFixity (TH.Fixity prec dir) = Hs.Fixity (show prec) prec (cvt_dir dir) where cvt_dir TH.InfixL = Hs.InfixL cvt_dir TH.InfixR = Hs.InfixR diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index 158993eb2e..6b395a318a 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -477,6 +477,9 @@ data HsExpr id SourceText -- Note [Pragma source text] in BasicTypes (StringLiteral,(Int,Int),(Int,Int)) -- external span for this tick + ((SourceText,SourceText),(SourceText,SourceText)) + -- Source text for the four integers used in the span. + -- See note [Pragma source text] in BasicTypes (LHsExpr id) --------------------------------------- @@ -798,7 +801,7 @@ ppr_expr (HsBinTick tickIdTrue tickIdFalse exp) ppr tickIdFalse, ptext (sLit ">("), ppr exp,ptext (sLit ")")] -ppr_expr (HsTickPragma _ externalSrcLoc exp) +ppr_expr (HsTickPragma _ externalSrcLoc _ exp) = pprTicks (ppr exp) $ hcat [ptext (sLit "tickpragma<"), pprExternalSrcLoc externalSrcLoc, diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs index b0da64c7da..35c6b22027 100644 --- a/compiler/iface/LoadIface.hs +++ b/compiler/iface/LoadIface.hs @@ -817,7 +817,7 @@ ghcPrimIface mi_fix_fn = mkIfaceFixCache fixities } where - fixities = (getOccName seqId, Fixity 0 InfixR) -- seq is infixr 0 + fixities = (getOccName seqId, Fixity "0" 0 InfixR) -- seq is infixr 0 : (occName funTyConName, funTyFixity) -- trac #10145 : mapMaybe mkFixity allThePrimOps mkFixity op = (,) (primOpOcc op) <$> primOpFixity op diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 5f6f12cabe..7d903f64d8 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -757,10 +757,10 @@ impspec :: { Located (Bool, Located [LIE RdrName]) } ----------------------------------------------------------------------------- -- Fixity Declarations -prec :: { Located Int } - : {- empty -} { noLoc 9 } +prec :: { Located (SourceText,Int) } + : {- empty -} { noLoc ("",9) } | INTEGER - {% checkPrecP (sL1 $1 (fromInteger (getINTEGER $1))) } + {% checkPrecP (sL1 $1 (getINTEGERs $1,fromInteger (getINTEGER $1))) } infix :: { Located FixityDirection } : 'infix' { sL1 $1 InfixN } @@ -1362,9 +1362,9 @@ rule_activation :: { ([AddAnn],Maybe Activation) } rule_explicit_activation :: { ([AddAnn] ,Activation) } -- In brackets : '[' INTEGER ']' { ([mos $1,mj AnnVal $2,mcs $3] - ,ActiveAfter (fromInteger (getINTEGER $2))) } + ,ActiveAfter (getINTEGERs $2) (fromInteger (getINTEGER $2))) } | '[' '~' INTEGER ']' { ([mos $1,mj AnnTilde $2,mj AnnVal $3,mcs $4] - ,ActiveBefore (fromInteger (getINTEGER $3))) } + ,ActiveBefore (getINTEGERs $3) (fromInteger (getINTEGER $3))) } | '[' '~' ']' { ([mos $1,mj AnnTilde $2,mcs $3] ,NeverActive) } @@ -2055,7 +2055,7 @@ sigdecl :: { LHsDecl RdrName } | infix prec ops {% ams (sLL $1 $> $ SigD (FixSig (FixitySig (fromOL $ unLoc $3) - (Fixity (unLoc $2) (unLoc $1))))) + (Fixity (fst $ unLoc $2) (snd $ unLoc $2) (unLoc $1))))) [mj AnnInfix $1,mj AnnVal $2] } | pattern_synonym_sig { sLL $1 $> . SigD . unLoc $ $1 } @@ -2095,10 +2095,10 @@ activation :: { ([AddAnn],Maybe Activation) } explicit_activation :: { ([AddAnn],Activation) } -- In brackets : '[' INTEGER ']' { ([mj AnnOpenS $1,mj AnnVal $2,mj AnnCloseS $3] - ,ActiveAfter (fromInteger (getINTEGER $2))) } + ,ActiveAfter (getINTEGERs $2) (fromInteger (getINTEGER $2))) } | '[' '~' INTEGER ']' { ([mj AnnOpenS $1,mj AnnTilde $2,mj AnnVal $3 ,mj AnnCloseS $4] - ,ActiveBefore (fromInteger (getINTEGER $3))) } + ,ActiveBefore (getINTEGERs $3) (fromInteger (getINTEGER $3))) } ----------------------------------------------------------------------------- -- Expressions @@ -2183,8 +2183,9 @@ exp10 :: { LHsExpr RdrName } | scc_annot exp {% ams (sLL $1 $> $ HsSCC (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2) (fst $ fst $ unLoc $1) } - | hpc_annot exp {% ams (sLL $1 $> $ HsTickPragma (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2) - (fst $ fst $ unLoc $1) } + | hpc_annot exp {% ams (sLL $1 $> $ HsTickPragma (snd $ fst $ fst $ unLoc $1) + (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2) + (fst $ fst $ fst $ unLoc $1) } | 'proc' aexp '->' exp {% checkPattern empty $2 >>= \ p -> @@ -2213,9 +2214,11 @@ scc_annot :: { Located (([AddAnn],SourceText),StringLiteral) } ,mc $3],getSCC_PRAGs $1) ,(StringLiteral (unpackFS $ getVARID $2) (getVARID $2))) } -hpc_annot :: { Located (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,Int))) } +hpc_annot :: { Located ( (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,Int))), + ((SourceText,SourceText),(SourceText,SourceText)) + ) } : '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}' - { sLL $1 $> $ (([mo $1,mj AnnVal $2 + { sLL $1 $> $ ((([mo $1,mj AnnVal $2 ,mj AnnVal $3,mj AnnColon $4 ,mj AnnVal $5,mj AnnMinus $6 ,mj AnnVal $7,mj AnnColon $8 @@ -2229,6 +2232,12 @@ hpc_annot :: { Located (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,Int) , fromInteger $ getINTEGER $9 ) )) + , (( getINTEGERs $3 + , getINTEGERs $5 + ) + ,( getINTEGERs $7 + , getINTEGERs $9 + ))) } fexp :: { LHsExpr RdrName } diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index ada9bf25eb..11ec70c27d 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -1203,9 +1203,9 @@ cmdStmtFail loc e = parseErrorSDoc loc --------------------------------------------------------------------------- -- Miscellaneous utilities -checkPrecP :: Located Int -> P (Located Int) -checkPrecP (L l i) - | 0 <= i && i <= maxPrecedence = return (L l i) +checkPrecP :: Located (SourceText,Int) -> P (Located (SourceText,Int)) +checkPrecP (L l (src,i)) + | 0 <= i && i <= maxPrecedence = return (L l (src,i)) | otherwise = parseErrorSDoc l (text ("Precedence out of range: " ++ show i)) diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs index 6b71abfd45..252cce6e86 100644 --- a/compiler/rename/RnEnv.hs +++ b/compiler/rename/RnEnv.hs @@ -1420,7 +1420,7 @@ lookupFixityRn_help' :: Name -> RnM (Bool, Fixity) lookupFixityRn_help' name occ | isUnboundName name - = return (False, Fixity minPrecedence InfixL) + = return (False, Fixity (show minPrecedence) minPrecedence InfixL) -- Minimise errors from ubound names; eg -- a>0 `foo` b>0 -- where 'foo' is not in scope, should not give an error (Trac #7937) @@ -1499,7 +1499,7 @@ lookupFieldFixityRn (Ambiguous (L _ rdr) _) = get_ambiguous_fixity rdr [] -> panic "get_ambiguous_fixity: no candidates for a given RdrName" [ (_, fix):_ ] -> return fix ambigs -> addErr (ambiguous_fixity_err rdr_name ambigs) - >> return (Fixity minPrecedence InfixL) + >> return (Fixity(show minPrecedence) minPrecedence InfixL) lookup_gre_fixity gre = lookupFixityRn' (gre_name gre) (greOccName gre) diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs index 03f4b62043..c4f4bca35f 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -152,10 +152,10 @@ rnExpr (OpApp e1 op _ e2) -- more, so I've removed the test. Adding HsPars in TcGenDeriv -- should prevent bad things happening. ; fixity <- case op' of - L _ (HsVar (L _ n)) -> lookupFixityRn n - L _ (HsRecFld f) -> lookupFieldFixityRn f - _ -> return (Fixity minPrecedence InfixL) - -- c.f. lookupFixity for unbound + L _ (HsVar (L _ n)) -> lookupFixityRn n + L _ (HsRecFld f) -> lookupFieldFixityRn f + _ -> return (Fixity (show minPrecedence) minPrecedence InfixL) + -- c.f. lookupFixity for unbound ; final_e <- mkOpAppRn e1' op' fixity e2' ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) } @@ -202,9 +202,9 @@ rnExpr (HsCoreAnn src ann expr) rnExpr (HsSCC src lbl expr) = do { (expr', fvs_expr) <- rnLExpr expr ; return (HsSCC src lbl expr', fvs_expr) } -rnExpr (HsTickPragma src info expr) +rnExpr (HsTickPragma src info srcInfo expr) = do { (expr', fvs_expr) <- rnLExpr expr - ; return (HsTickPragma src info expr', fvs_expr) } + ; return (HsTickPragma src info srcInfo expr', fvs_expr) } rnExpr (HsLam matches) = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index 137b918f22..9a3dba216e 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -1303,8 +1303,8 @@ checkPrecMatch op (MG { mg_alts = L _ ms }) checkPrec :: Name -> Pat Name -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) () checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do - op_fix@(Fixity op_prec op_dir) <- lookupFixityRn op - op1_fix@(Fixity op1_prec op1_dir) <- lookupFixityRn (unLoc op1) + op_fix@(Fixity _ op_prec op_dir) <- lookupFixityRn op + op1_fix@(Fixity _ op1_prec op1_dir) <- lookupFixityRn (unLoc op1) let inf_ok = op1_prec > op_prec || (op1_prec == op_prec && @@ -1332,8 +1332,8 @@ checkSectionPrec direction section op arg _ -> return () where op_name = get_op op - go_for_it arg_op arg_fix@(Fixity arg_prec assoc) = do - op_fix@(Fixity op_prec _) <- lookupFixityRn op_name + go_for_it arg_op arg_fix@(Fixity _ arg_prec assoc) = do + op_fix@(Fixity _ op_prec _) <- lookupFixityRn op_name unless (op_prec < arg_prec || (op_prec == arg_prec && direction == assoc)) (sectionPrecErr (op_name, op_fix) diff --git a/compiler/simplCore/SimplUtils.hs b/compiler/simplCore/SimplUtils.hs index 846d1cc838..43c8cb65df 100644 --- a/compiler/simplCore/SimplUtils.hs +++ b/compiler/simplCore/SimplUtils.hs @@ -700,8 +700,8 @@ updModeForStableUnfoldings inline_rule_act current_mode -- For sm_rules, just inherit; sm_rules might be "off" -- because of -fno-enable-rewrite-rules where - phaseFromActivation (ActiveAfter n) = Phase n - phaseFromActivation _ = InitialPhase + phaseFromActivation (ActiveAfter _ n) = Phase n + phaseFromActivation _ = InitialPhase updModeForRules :: SimplifierMode -> SimplifierMode -- See Note [Simplifying rules] diff --git a/compiler/stranal/WorkWrap.hs b/compiler/stranal/WorkWrap.hs index c0a31c9b92..8a5ed67513 100644 --- a/compiler/stranal/WorkWrap.hs +++ b/compiler/stranal/WorkWrap.hs @@ -364,7 +364,7 @@ splitFun dflags fam_envs fn_id fn_info wrap_dmds res_info rhs -- Set the arity so that the Core Lint check that the -- arity is consistent with the demand type goes through - wrap_act = ActiveAfter 0 + wrap_act = ActiveAfter "0" 0 wrap_rhs = wrap_fn work_id wrap_prag = InlinePragma { inl_src = "{-# INLINE" , inl_inline = Inline diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index d5a001666f..592b0bfbf7 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -172,9 +172,9 @@ tcExpr (HsSCC src lbl expr) res_ty = do { expr' <- tcMonoExpr expr res_ty ; return (HsSCC src lbl expr') } -tcExpr (HsTickPragma src info expr) res_ty +tcExpr (HsTickPragma src info srcInfo expr) res_ty = do { expr' <- tcMonoExpr expr res_ty - ; return (HsTickPragma src info expr') } + ; return (HsTickPragma src info srcInfo expr') } tcExpr (HsCoreAnn src lbl expr) res_ty = do { expr' <- tcMonoExpr expr res_ty diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs index 330415522a..2990e18f10 100644 --- a/compiler/typecheck/TcGenDeriv.hs +++ b/compiler/typecheck/TcGenDeriv.hs @@ -1226,7 +1226,7 @@ appPrecedence = fromIntegral maxPrecedence + 1 getPrecedence :: (Name -> Fixity) -> Name -> Integer getPrecedence get_fixity nm = case get_fixity nm of - Fixity x _assoc -> fromIntegral x + Fixity _ x _assoc -> fromIntegral x -- NB: the Report says that associativity is not taken -- into account for either Read or Show; hence we -- ignore associativity here diff --git a/compiler/typecheck/TcGenGenerics.hs b/compiler/typecheck/TcGenGenerics.hs index 43433da2bc..2ebf3fda15 100644 --- a/compiler/typecheck/TcGenGenerics.hs +++ b/compiler/typecheck/TcGenGenerics.hs @@ -576,9 +576,9 @@ tc_mkRepTy gk_ tycon = ctFix c | dataConIsInfix c = case lookupFixity fix_env (dataConName c) of - Fixity n InfixL -> buildFix n pLA - Fixity n InfixR -> buildFix n pRA - Fixity n InfixN -> buildFix n pNA + Fixity _ n InfixL -> buildFix n pLA + Fixity _ n InfixR -> buildFix n pRA + Fixity _ n InfixN -> buildFix n pNA | otherwise = mkTyConTy pPrefix buildFix n assoc = mkTyConApp pInfix [ mkTyConTy assoc , mkNumLitTy (fromIntegral n)] diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index d8703a07e5..f055197ede 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -725,9 +725,9 @@ zonkExpr env (HsSCC src lbl expr) = do new_expr <- zonkLExpr env expr return (HsSCC src lbl new_expr) -zonkExpr env (HsTickPragma src info expr) +zonkExpr env (HsTickPragma src info srcInfo expr) = do new_expr <- zonkLExpr env expr - return (HsTickPragma src info new_expr) + return (HsTickPragma src info srcInfo new_expr) -- hdaume: core annotations zonkExpr env (HsCoreAnn src lbl expr) diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index 9465456bac..cdda69666e 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -2755,7 +2755,7 @@ exprCtOrigin (HsArrApp {}) = panic "exprCtOrigin HsArrApp" exprCtOrigin (HsArrForm {}) = panic "exprCtOrigin HsArrForm" exprCtOrigin (HsTick _ (L _ e)) = exprCtOrigin e exprCtOrigin (HsBinTick _ _ (L _ e)) = exprCtOrigin e -exprCtOrigin (HsTickPragma _ _ (L _ e)) = exprCtOrigin e +exprCtOrigin (HsTickPragma _ _ _ (L _ e)) = exprCtOrigin e exprCtOrigin EWildPat = panic "exprCtOrigin EWildPat" exprCtOrigin (EAsPat {}) = panic "exprCtOrigin EAsPat" exprCtOrigin (EViewPat {}) = panic "exprCtOrigin EViewPat" diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index 985798b381..ab2e30cb31 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -1812,7 +1812,7 @@ reifyFixity name = do { (found, fix) <- lookupFixityRn_help name ; return (if found then Just (conv_fix fix) else Nothing) } where - conv_fix (BasicTypes.Fixity i d) = TH.Fixity i (conv_dir d) + conv_fix (BasicTypes.Fixity _ i d) = TH.Fixity i (conv_dir d) conv_dir BasicTypes.InfixR = TH.InfixR conv_dir BasicTypes.InfixL = TH.InfixL conv_dir BasicTypes.InfixN = TH.InfixN diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index b70304d785..8800d98f9c 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -755,21 +755,25 @@ instance Binary Activation where putByte bh 0 put_ bh AlwaysActive = do putByte bh 1 - put_ bh (ActiveBefore aa) = do + put_ bh (ActiveBefore src aa) = do putByte bh 2 + put_ bh src put_ bh aa - put_ bh (ActiveAfter ab) = do + put_ bh (ActiveAfter src ab) = do putByte bh 3 + put_ bh src put_ bh ab get bh = do h <- getByte bh case h of 0 -> do return NeverActive 1 -> do return AlwaysActive - 2 -> do aa <- get bh - return (ActiveBefore aa) - _ -> do ab <- get bh - return (ActiveAfter ab) + 2 -> do src <- get bh + aa <- get bh + return (ActiveBefore src aa) + _ -> do src <- get bh + ab <- get bh + return (ActiveAfter src ab) instance Binary InlinePragma where put_ bh (InlinePragma s a b c d) = do @@ -859,13 +863,15 @@ instance Binary FixityDirection where _ -> do return InfixN instance Binary Fixity where - put_ bh (Fixity aa ab) = do + put_ bh (Fixity src aa ab) = do + put_ bh src put_ bh aa put_ bh ab get bh = do + src <- get bh aa <- get bh ab <- get bh - return (Fixity aa ab) + return (Fixity src aa ab) instance Binary WarningTxt where put_ bh (WarningTxt s w) = do diff --git a/testsuite/tests/ghc-api/annotations/Makefile b/testsuite/tests/ghc-api/annotations/Makefile index 212f7b0706..045cd4084d 100644 --- a/testsuite/tests/ghc-api/annotations/Makefile +++ b/testsuite/tests/ghc-api/annotations/Makefile @@ -7,6 +7,7 @@ clean: rm -f annotations comments parseTree rm -f listcomps rm -f stringSource + rm -f t11430 .PHONY: annotations annotations: @@ -118,3 +119,9 @@ T11321: .PHONY: T11332 T11332: $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test11332 + +.PHONY: T11430 +T11430: + rm -f t11430.o t11430.hi t11430 + '$(TEST_HC)' $(TEST_HC_OPTS) --make -v0 -package ghc t11430 + ./t11430 "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test11430 diff --git a/testsuite/tests/ghc-api/annotations/T11430.stdout b/testsuite/tests/ghc-api/annotations/T11430.stdout new file mode 100644 index 0000000000..32d7ff1b24 --- /dev/null +++ b/testsuite/tests/ghc-api/annotations/T11430.stdout @@ -0,0 +1,6 @@ +("f",["0x1"]) +("ib",["001"]) +("ia",["1"]) +("ia",["0x999"]) +("ia",["1"]) +("tp",["((\"0x1\",\"0x2\"),(\"0x3\",\"0x4\"))"]) diff --git a/testsuite/tests/ghc-api/annotations/Test11430.hs b/testsuite/tests/ghc-api/annotations/Test11430.hs new file mode 100644 index 0000000000..4b124e478c --- /dev/null +++ b/testsuite/tests/ghc-api/annotations/Test11430.hs @@ -0,0 +1,25 @@ +module Test11430 where + + +infixl 0x1 `f` + +x `f` y = x + + +{-# SPECIALISE [~ 001] x :: + Integer -> Integer -> Integer, + Integer -> Int -> Integer, + Int -> Int -> Int #-} +{-# INLINABLE [1] x #-} +x :: (Num a, Integral b) => a -> b -> a +x = undefined + +{-# SPECIALISE INLINE [0x999] y :: + Integer -> Integer -> Integer, + Integer -> Int -> Integer, + Int -> Int -> Int #-} +{-# INLINABLE [1] y #-} +y :: (Num a, Integral b) => a -> b -> a +y = undefined + +c = {-# GENERATED "foob\x61r" 0x1 : 0x2 - 0x3 : 0x4 #-} 0.00 diff --git a/testsuite/tests/ghc-api/annotations/all.T b/testsuite/tests/ghc-api/annotations/all.T index a2750ff08a..64f69e20f0 100644 --- a/testsuite/tests/ghc-api/annotations/all.T +++ b/testsuite/tests/ghc-api/annotations/all.T @@ -23,3 +23,4 @@ test('bundle-export', normal, run_command, ['$MAKE -s --no-print-directory bundl test('T10276', normal, run_command, ['$MAKE -s --no-print-directory T10276']) test('T11321', normal, run_command, ['$MAKE -s --no-print-directory T11321']) test('T11332', normal, run_command, ['$MAKE -s --no-print-directory T11332']) +test('T11430', normal, run_command, ['$MAKE -s --no-print-directory T11430']) diff --git a/testsuite/tests/ghc-api/annotations/stringSource.hs b/testsuite/tests/ghc-api/annotations/stringSource.hs index 1e8af17072..bf691ae8ea 100644 --- a/testsuite/tests/ghc-api/annotations/stringSource.hs +++ b/testsuite/tests/ghc-api/annotations/stringSource.hs @@ -82,7 +82,7 @@ testOneFile libdir fileName = do doHsExpr :: HsExpr RdrName -> [(String,[Located (SourceText,FastString)])] doHsExpr (HsCoreAnn src ss _) = [("co",[conv (noLoc ss)])] doHsExpr (HsSCC src ss _) = [("sc",[conv (noLoc ss)])] - doHsExpr (HsTickPragma src (ss,_,_) _) = [("tp",[conv (noLoc ss)])] + doHsExpr (HsTickPragma src (ss,_,_) _ss2 _) = [("tp",[conv (noLoc ss)])] doHsExpr _ = [] conv (GHC.L l (StringLiteral st fs)) = GHC.L l (st,fs) diff --git a/testsuite/tests/ghc-api/annotations/t11430.hs b/testsuite/tests/ghc-api/annotations/t11430.hs new file mode 100644 index 0000000000..1f00d1d5d2 --- /dev/null +++ b/testsuite/tests/ghc-api/annotations/t11430.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +-- This program must be called with GHC's libdir as the single command line +-- argument. +module Main where + +-- import Data.Generics +import Data.Data hiding (Fixity) +import Data.List +import System.IO +import GHC +import BasicTypes +import DynFlags +import FastString +import ForeignCall +import MonadUtils +import Outputable +import HsDecls +import Bag (filterBag,isEmptyBag) +import System.Directory (removeFile) +import System.Environment( getArgs ) +import qualified Data.Map as Map +import Data.Dynamic ( fromDynamic,Dynamic ) + +main::IO() +main = do + [libdir,fileName] <- getArgs + testOneFile libdir fileName + +testOneFile libdir fileName = do + ((anns,cs),p) <- runGhc (Just libdir) $ do + dflags <- getSessionDynFlags + setSessionDynFlags dflags + let mn =mkModuleName fileName + addTarget Target { targetId = TargetModule mn + , targetAllowObjCode = True + , targetContents = Nothing } + load LoadAllTargets + modSum <- getModSummary mn + p <- parseModule modSum + return (pm_annotations p,p) + + let tupArgs = gq (pm_parsed_source p) + + putStrLn (intercalate "\n" $ map show tupArgs) + -- putStrLn (pp tupArgs) + -- putStrLn (intercalate "\n" [showAnns anns]) + + where + gq ast = everything (++) ([] `mkQ` doFixity + `extQ` doRuleDecl + `extQ` doHsExpr + `extQ` doInline + ) ast + + doFixity :: Fixity -> [(String,[String])] + doFixity (Fixity ss _ _) = [("f",[ss])] + + doRuleDecl :: RuleDecl RdrName + -> [(String,[String])] + doRuleDecl (HsRule _ (ActiveBefore ss _) _ _ _ _ _) = [("rb",[ss])] + doRuleDecl (HsRule _ (ActiveAfter ss _) _ _ _ _ _) = [("ra",[ss])] + doRuleDecl (HsRule _ _ _ _ _ _ _) = [] + + doHsExpr :: HsExpr RdrName -> [(String,[String])] + doHsExpr (HsTickPragma src (_,_,_) ss _) = [("tp",[show ss])] + doHsExpr _ = [] + + doInline (InlinePragma _ _ _ (ActiveBefore ss _) _) = [("ib",[ss])] + doInline (InlinePragma _ _ _ (ActiveAfter ss _) _) = [("ia",[ss])] + doInline (InlinePragma _ _ _ _ _ ) = [] + +showAnns anns = "[\n" ++ (intercalate "\n" + $ map (\((s,k),v) + -> ("(AK " ++ pp s ++ " " ++ show k ++" = " ++ pp v ++ ")\n")) + $ Map.toList anns) + ++ "]\n" + +pp a = showPpr unsafeGlobalDynFlags a + +-- --------------------------------------------------------------------- + +-- Copied from syb for the test + + +-- | Generic queries of type \"r\", +-- i.e., take any \"a\" and return an \"r\" +-- +type GenericQ r = forall a. Data a => a -> r + + +-- | Make a generic query; +-- start from a type-specific case; +-- return a constant otherwise +-- +mkQ :: ( Typeable a + , Typeable b + ) + => r + -> (b -> r) + -> a + -> r +(r `mkQ` br) a = case cast a of + Just b -> br b + Nothing -> r + +-- | Extend a generic query by a type-specific case +extQ :: ( Typeable a + , Typeable b + ) + => (a -> q) + -> (b -> q) + -> a + -> q +extQ f g a = maybe (f a) g (cast a) + + +-- | Summarise all nodes in top-down, left-to-right order +everything :: (r -> r -> r) -> GenericQ r -> GenericQ r + +-- Apply f to x to summarise top-level node; +-- use gmapQ to recurse into immediate subterms; +-- use ordinary foldl to reduce list of intermediate results + +everything k f x = foldl k (f x) (gmapQ (everything k f) x) diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs index 781317ab11..e6af0f200e 100644 --- a/utils/genprimopcode/Main.hs +++ b/utils/genprimopcode/Main.hs @@ -350,7 +350,8 @@ gen_hs_source (Info defaults entries) = escape = concatMap (\c -> if c `elem` special then '\\':c:[] else c:[]) where special = "/'`\"@<" - pprFixity (Fixity i d) n = pprFixityDir d ++ " " ++ show i ++ " " ++ n + pprFixity (Fixity _ i d) n + = pprFixityDir d ++ " " ++ show i ++ " " ++ n {- Note [Placeholder declarations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -495,7 +496,7 @@ gen_latex_doc (Info defaults entries) Nothing -> "" mk_fixity o = case lookup_attrib "fixity" o of - Just (OptionFixity (Just (Fixity i d))) + Just (OptionFixity (Just (Fixity _ i d))) -> pprFixityDir d ++ " " ++ show i _ -> "" diff --git a/utils/genprimopcode/Parser.y b/utils/genprimopcode/Parser.y index 6a3c0d0043..51ca9ad6eb 100644 --- a/utils/genprimopcode/Parser.y +++ b/utils/genprimopcode/Parser.y @@ -77,9 +77,9 @@ pOption : lowerName '=' false { OptionFalse $1 } | fixity '=' pInfix { OptionFixity $3 } pInfix :: { Maybe Fixity } -pInfix : infix integer { Just $ Fixity $2 InfixN } - | infixl integer { Just $ Fixity $2 InfixL } - | infixr integer { Just $ Fixity $2 InfixR } +pInfix : infix integer { Just $ Fixity (show $2) $2 InfixN } + | infixl integer { Just $ Fixity (show $2) $2 InfixL } + | infixr integer { Just $ Fixity (show $2) $2 InfixR } | nothing { Nothing } diff --git a/utils/genprimopcode/Syntax.hs b/utils/genprimopcode/Syntax.hs index 68b20adbdd..17c264d44a 100644 --- a/utils/genprimopcode/Syntax.hs +++ b/utils/genprimopcode/Syntax.hs @@ -96,7 +96,9 @@ instance Show TyCon where -- Follow definitions of Fixity and FixityDirection in GHC -data Fixity = Fixity Int FixityDirection +-- The String exists so that it matches the SourceText field in +-- BasicTypes.Fixity +data Fixity = Fixity String Int FixityDirection deriving (Eq, Show) data FixityDirection = InfixN | InfixL | InfixR diff --git a/utils/haddock b/utils/haddock -Subproject a13d21c688cae176be4505a5a6e9d64739845ea +Subproject c2e89153c0aaf2dc4e3908701f19d739eb0d8b9 |