Commit 3a1babd6 authored by Alan Zimmerman's avatar Alan Zimmerman

Work SourceText in for all integer literals

Summary:
Certain syntactic elements have integers in them, such as fixity
specifications, SPECIALISE pragmas and so on.

The lexer will accept mult-radix literals, with arbitrary leading zeros
in these.

Bring in a SourceText field to each affected AST element to capture the
original literal text for use with API Annotations.

Affected hsSyn elements are

```
     -- See note [Pragma source text]
     data Activation = NeverActive
                     | AlwaysActive
                     | 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 Fixity = Fixity SourceText Int FixityDirection
       -- Note [Pragma source text]
       deriving (Data, Typeable)
 ```

and

```
      | HsTickPragma         -- A pragma introduced tick
         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)
```

Updates haddock submodule

Test Plan: ./validate

Reviewers: goldfire, bgamari, austin

Reviewed By: bgamari

Subscribers: thomie, mpickering

Differential Revision: https://phabricator.haskell.org/D1781

GHC Trac Issues: #11430
parent 148a50b5
......@@ -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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -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';
......
......@@ -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
......
......@@ -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"
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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,
......
......@@ -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
......
......@@ -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 }
......
......@@ -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))
......
......@@ -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)
......
......@@ -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
......
......@@ -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)
......
......@@ -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]
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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)]
......
......@@ -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)
......
......@@ -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"
......
......@@ -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
......
......@@ -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
......
......@@ -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
("f",["0x1"])
("ib",["001"])
("ia",["1"])
("ia",["0x999"])
("ia",["1"])
("tp",["((\"0x1\",\"0x2\"),(\"0x3\",\"0x4\"))"])
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
......@@ -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'])
......@@ -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)
......
{-# 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