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
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])]