Commit 11881ec6 authored by Alan Zimmerman's avatar Alan Zimmerman Committed by Austin Seipp
Browse files

API Annotations tweaks.

Summary:
HsTyLit now has SourceText

Update documentation of HsSyn to reflect which annotations are attached to which element.

Ensure that the parser always keeps HsSCC and HsTickPragma values, to
be ignored in the desugar phase if not needed

Bringing in SourceText for pragmas

Add Location in NPlusKPat

Add Location in FunDep

Make RecCon payload Located

Explicitly add AnnVal to RdrName where it is compound

Add Location in IPBind

Add Location to name in IEThingAbs

Add Maybe (Located id,Bool) to Match to track fun_id,infix
  This includes converting Match into a record and adding a note about why
  the fun_id needs to be replicated in the Match.

Add Location in KindedTyVar

Sort out semi-colons for parsing

  - import statements
  - stmts
  - decls
  - decls_cls
  - decls_inst

This updates the haddock submodule.

Test Plan: ./validate

Reviewers: hvr, austin, goldfire, simonpj

Reviewed By: simonpj

Subscribers: thomie, carter

Differential Revision: https://phabricator.haskell.org/D538
parent fffbf062
...@@ -84,7 +84,9 @@ module BasicTypes( ...@@ -84,7 +84,9 @@ module BasicTypes(
FractionalLit(..), negateFractionalLit, integralFractionalLit, FractionalLit(..), negateFractionalLit, integralFractionalLit,
HValue(..) HValue(..),
SourceText
) where ) where
import FastString import FastString
...@@ -263,14 +265,15 @@ initialVersion = 1 ...@@ -263,14 +265,15 @@ initialVersion = 1
-} -}
-- reason/explanation from a WARNING or DEPRECATED pragma -- reason/explanation from a WARNING or DEPRECATED pragma
data WarningTxt = WarningTxt [Located FastString] -- For SourceText usage, see note [Pragma source text]
| DeprecatedTxt [Located FastString] data WarningTxt = WarningTxt (Located SourceText) [Located FastString]
| DeprecatedTxt (Located SourceText) [Located FastString]
deriving (Eq, Data, Typeable) deriving (Eq, Data, Typeable)
instance Outputable WarningTxt where instance Outputable WarningTxt where
ppr (WarningTxt ws) = doubleQuotes (vcat (map (ftext . unLoc) ws)) ppr (WarningTxt _ ws) = doubleQuotes (vcat (map (ftext . unLoc) ws))
ppr (DeprecatedTxt ds) = text "Deprecated:" <+> ppr (DeprecatedTxt _ ds) = text "Deprecated:" <+>
doubleQuotes (vcat (map (ftext . unLoc) ds)) doubleQuotes (vcat (map (ftext . unLoc) ds))
{- {-
************************************************************************ ************************************************************************
...@@ -448,6 +451,13 @@ instance Outputable Origin where ...@@ -448,6 +451,13 @@ instance Outputable Origin where
-- | The semantics allowed for overlapping instances for a particular -- | The semantics allowed for overlapping instances for a particular
-- instance. See Note [Safe Haskell isSafeOverlap] (in `InstEnv.lhs`) for a -- instance. See Note [Safe Haskell isSafeOverlap] (in `InstEnv.lhs`) for a
-- explanation of the `isSafeOverlap` field. -- explanation of the `isSafeOverlap` field.
--
-- - 'ApiAnnotation.AnnKeywordId' :
-- 'ApiAnnotation.AnnOpen' @'\{-\# OVERLAPPABLE'@ or
-- @'\{-\# OVERLAPPING'@ or
-- @'\{-\# OVERLAPS'@ or
-- @'\{-\# INCOHERENT'@,
-- 'ApiAnnotation.AnnClose' @`\#-\}`@,
data OverlapFlag = OverlapFlag data OverlapFlag = OverlapFlag
{ overlapMode :: OverlapMode { overlapMode :: OverlapMode
, isSafeOverlap :: Bool , isSafeOverlap :: Bool
...@@ -460,27 +470,29 @@ setOverlapModeMaybe f (Just m) = f { overlapMode = m } ...@@ -460,27 +470,29 @@ setOverlapModeMaybe f (Just m) = f { overlapMode = m }
hasOverlappableFlag :: OverlapMode -> Bool hasOverlappableFlag :: OverlapMode -> Bool
hasOverlappableFlag mode = hasOverlappableFlag mode =
case mode of case mode of
Overlappable -> True Overlappable _ -> True
Overlaps -> True Overlaps _ -> True
Incoherent -> True Incoherent _ -> True
_ -> False _ -> False
hasOverlappingFlag :: OverlapMode -> Bool hasOverlappingFlag :: OverlapMode -> Bool
hasOverlappingFlag mode = hasOverlappingFlag mode =
case mode of case mode of
Overlapping -> True Overlapping _ -> True
Overlaps -> True Overlaps _ -> True
Incoherent -> True Incoherent _ -> True
_ -> False _ -> False
data OverlapMode -- See Note [Rules for instance lookup] in InstEnv data OverlapMode -- See Note [Rules for instance lookup] in InstEnv
= NoOverlap = NoOverlap SourceText
-- See Note [Pragma source text]
-- ^ This instance must not overlap another `NoOverlap` instance. -- ^ This instance must not overlap another `NoOverlap` instance.
-- However, it may be overlapped by `Overlapping` instances, -- However, it may be overlapped by `Overlapping` instances,
-- and it may overlap `Overlappable` instances. -- and it may overlap `Overlappable` instances.
| Overlappable | Overlappable SourceText
-- See Note [Pragma source text]
-- ^ Silently ignore this instance if you find a -- ^ Silently ignore this instance if you find a
-- more specific one that matches the constraint -- more specific one that matches the constraint
-- you are trying to resolve -- you are trying to resolve
...@@ -494,7 +506,8 @@ data OverlapMode -- See Note [Rules for instance lookup] in InstEnv ...@@ -494,7 +506,8 @@ data OverlapMode -- See Note [Rules for instance lookup] in InstEnv
-- its ambiguous which to choose) -- its ambiguous which to choose)
| Overlapping | Overlapping SourceText
-- See Note [Pragma source text]
-- ^ Silently ignore any more general instances that may be -- ^ Silently ignore any more general instances that may be
-- used to solve the constraint. -- used to solve the constraint.
-- --
...@@ -507,10 +520,12 @@ data OverlapMode -- See Note [Rules for instance lookup] in InstEnv ...@@ -507,10 +520,12 @@ data OverlapMode -- See Note [Rules for instance lookup] in InstEnv
-- it is ambiguous which to choose) -- it is ambiguous which to choose)
| Overlaps | Overlaps SourceText
-- See Note [Pragma source text]
-- ^ Equivalent to having both `Overlapping` and `Overlappable` flags. -- ^ Equivalent to having both `Overlapping` and `Overlappable` flags.
| Incoherent | Incoherent SourceText
-- See Note [Pragma source text]
-- ^ Behave like Overlappable and Overlapping, and in addition pick -- ^ Behave like Overlappable and Overlapping, and in addition pick
-- an an arbitrary one if there are multiple matching candidates, and -- an an arbitrary one if there are multiple matching candidates, and
-- don't worry about later instantiation -- don't worry about later instantiation
...@@ -529,11 +544,11 @@ instance Outputable OverlapFlag where ...@@ -529,11 +544,11 @@ instance Outputable OverlapFlag where
ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag) ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag)
instance Outputable OverlapMode where instance Outputable OverlapMode where
ppr NoOverlap = empty ppr (NoOverlap _) = empty
ppr Overlappable = ptext (sLit "[overlappable]") ppr (Overlappable _) = ptext (sLit "[overlappable]")
ppr Overlapping = ptext (sLit "[overlapping]") ppr (Overlapping _) = ptext (sLit "[overlapping]")
ppr Overlaps = ptext (sLit "[overlap ok]") ppr (Overlaps _) = ptext (sLit "[overlap ok]")
ppr Incoherent = ptext (sLit "[incoherent]") ppr (Incoherent _) = ptext (sLit "[incoherent]")
pprSafeOverlap :: Bool -> SDoc pprSafeOverlap :: Bool -> SDoc
pprSafeOverlap True = ptext $ sLit "[safe]" pprSafeOverlap True = ptext $ sLit "[safe]"
...@@ -765,6 +780,72 @@ succeeded Failed = False ...@@ -765,6 +780,72 @@ succeeded Failed = False
failed Succeeded = False failed Succeeded = False
failed Failed = True failed Failed = True
{-
************************************************************************
* *
\subsection{Source Text}
* *
************************************************************************
Keeping Source Text for source to source conversions
Note [Pragma source text]
~~~~~~~~~~~~~~~~~~~~~~~~~
The lexer does a case-insensitive match for pragmas, as well as
accepting both UK and US spelling variants.
So
{-# SPECIALISE #-}
{-# SPECIALIZE #-}
{-# Specialize #-}
will all generate ITspec_prag token for the start of the pragma.
In order to be able to do source to source conversions, the original
source text for the token needs to be preserved, hence the
`SourceText` field.
So the lexer will then generate
ITspec_prag "{ -# SPECIALISE"
ITspec_prag "{ -# SPECIALIZE"
ITspec_prag "{ -# Specialize"
for the cases above.
[without the space between '{' and '-', otherwise this comment won't parse]
Note [literal source text]
~~~~~~~~~~~~~~~~~~~~~~~~~~
The lexer/parser converts literals from their original source text
versions to an appropriate internal representation. This is a problem
for tools doing source to source conversions, so the original source
text is stored in literals where this can occur.
Motivating examples for HsLit
HsChar '\n', '\x20`
HsCharPrim '\x41`#
HsString "\x20\x41" == " A"
HsStringPrim "\x20"#
HsInt 001
HsIntPrim 002#
HsWordPrim 003##
HsInt64Prim 004##
HsWord64Prim 005##
HsInteger 006
For OverLitVal
HsIntegral 003,0x001
HsIsString "\x41nd"
-}
type SourceText = String -- Note [literal source text],[Pragma source text]
{- {-
************************************************************************ ************************************************************************
* * * *
...@@ -800,7 +881,8 @@ data RuleMatchInfo = ConLike -- See Note [CONLIKE pragma] ...@@ -800,7 +881,8 @@ data RuleMatchInfo = ConLike -- See Note [CONLIKE pragma]
data InlinePragma -- Note [InlinePragma] data InlinePragma -- Note [InlinePragma]
= InlinePragma = InlinePragma
{ inl_inline :: InlineSpec { inl_src :: SourceText -- Note [Pragma source text]
, inl_inline :: InlineSpec
, inl_sat :: Maybe Arity -- Just n <=> Inline only when applied to n , inl_sat :: Maybe Arity -- Just n <=> Inline only when applied to n
-- explicit (non-type, non-dictionary) args -- explicit (non-type, non-dictionary) args
...@@ -890,7 +972,8 @@ isEmptyInlineSpec _ = False ...@@ -890,7 +972,8 @@ isEmptyInlineSpec _ = False
defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma
:: InlinePragma :: InlinePragma
defaultInlinePragma = InlinePragma { inl_act = AlwaysActive defaultInlinePragma = InlinePragma { inl_src = "{-# INLINE"
, inl_act = AlwaysActive
, inl_rule = FunLike , inl_rule = FunLike
, inl_inline = EmptyInlineSpec , inl_inline = EmptyInlineSpec
, inl_sat = Nothing } , inl_sat = Nothing }
......
...@@ -453,6 +453,7 @@ data HsBang ...@@ -453,6 +453,7 @@ data HsBang
= HsNoBang -- Equivalent to (HsSrcBang Nothing False) = HsNoBang -- Equivalent to (HsSrcBang Nothing False)
| HsSrcBang -- What the user wrote in the source code | HsSrcBang -- What the user wrote in the source code
(Maybe SourceText) -- Note [Pragma source text] in BasicTypes
(Maybe Bool) -- Just True {-# UNPACK #-} (Maybe Bool) -- Just True {-# UNPACK #-}
-- Just False {-# NOUNPACK #-} -- Just False {-# NOUNPACK #-}
-- Nothing no pragma -- Nothing no pragma
...@@ -574,11 +575,11 @@ instance Data.Data DataCon where ...@@ -574,11 +575,11 @@ instance Data.Data DataCon where
dataTypeOf _ = mkNoRepType "DataCon" dataTypeOf _ = mkNoRepType "DataCon"
instance Outputable HsBang where instance Outputable HsBang where
ppr HsNoBang = empty ppr HsNoBang = empty
ppr (HsSrcBang prag bang) = pp_unpk prag <+> ppWhen bang (char '!') ppr (HsSrcBang _ prag bang) = pp_unpk prag <+> ppWhen bang (char '!')
ppr (HsUnpack Nothing) = ptext (sLit "Unpk") ppr (HsUnpack Nothing) = ptext (sLit "Unpk")
ppr (HsUnpack (Just co)) = ptext (sLit "Unpk") <> parens (ppr co) ppr (HsUnpack (Just co)) = ptext (sLit "Unpk") <> parens (ppr co)
ppr HsStrict = ptext (sLit "SrictNotUnpacked") ppr HsStrict = ptext (sLit "SrictNotUnpacked")
pp_unpk :: Maybe Bool -> SDoc pp_unpk :: Maybe Bool -> SDoc
pp_unpk Nothing = empty pp_unpk Nothing = empty
...@@ -593,16 +594,16 @@ instance Outputable StrictnessMark where ...@@ -593,16 +594,16 @@ instance Outputable StrictnessMark where
eqHsBang :: HsBang -> HsBang -> Bool eqHsBang :: HsBang -> HsBang -> Bool
eqHsBang HsNoBang HsNoBang = True eqHsBang HsNoBang HsNoBang = True
eqHsBang HsStrict HsStrict = True eqHsBang HsStrict HsStrict = True
eqHsBang (HsSrcBang u1 b1) (HsSrcBang u2 b2) = u1==u2 && b1==b2 eqHsBang (HsSrcBang _ u1 b1) (HsSrcBang _ u2 b2) = u1==u2 && b1==b2
eqHsBang (HsUnpack Nothing) (HsUnpack Nothing) = True eqHsBang (HsUnpack Nothing) (HsUnpack Nothing) = True
eqHsBang (HsUnpack (Just c1)) (HsUnpack (Just c2)) = eqType (coercionType c1) (coercionType c2) eqHsBang (HsUnpack (Just c1)) (HsUnpack (Just c2)) = eqType (coercionType c1) (coercionType c2)
eqHsBang _ _ = False eqHsBang _ _ = False
isBanged :: HsBang -> Bool isBanged :: HsBang -> Bool
isBanged HsNoBang = False isBanged HsNoBang = False
isBanged (HsSrcBang _ bang) = bang isBanged (HsSrcBang _ _ bang) = bang
isBanged (HsUnpack {}) = True isBanged (HsUnpack {}) = True
isBanged (HsStrict {}) = True isBanged (HsStrict {}) = True
isMarkedStrict :: StrictnessMark -> Bool isMarkedStrict :: StrictnessMark -> Bool
isMarkedStrict NotMarkedStrict = False isMarkedStrict NotMarkedStrict = False
......
...@@ -595,11 +595,11 @@ dataConArgRep ...@@ -595,11 +595,11 @@ dataConArgRep
dataConArgRep _ _ arg_ty HsNoBang dataConArgRep _ _ arg_ty HsNoBang
= (HsNoBang, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer)) = (HsNoBang, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
dataConArgRep _ _ arg_ty (HsSrcBang _ False) -- No '!' dataConArgRep _ _ arg_ty (HsSrcBang _ _ False) -- No '!'
= (HsNoBang, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer)) = (HsNoBang, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
dataConArgRep dflags fam_envs arg_ty dataConArgRep dflags fam_envs arg_ty
(HsSrcBang unpk_prag True) -- {-# UNPACK #-} ! (HsSrcBang _ unpk_prag True) -- {-# UNPACK #-} !
| not (gopt Opt_OmitInterfacePragmas dflags) -- Don't unpack if -fomit-iface-pragmas | not (gopt Opt_OmitInterfacePragmas dflags) -- Don't unpack if -fomit-iface-pragmas
-- Don't unpack if we aren't optimising; rather arbitrarily, -- Don't unpack if we aren't optimising; rather arbitrarily,
-- we use -fomit-iface-pragmas as the indication -- we use -fomit-iface-pragmas as the indication
...@@ -727,11 +727,11 @@ isUnpackableType fam_envs ty ...@@ -727,11 +727,11 @@ isUnpackableType fam_envs ty
-- NB: dataConSrcBangs gives the *user* request; -- NB: dataConSrcBangs gives the *user* request;
-- We'd get a black hole if we used dataConImplBangs -- We'd get a black hole if we used dataConImplBangs
attempt_unpack (HsUnpack {}) = True attempt_unpack (HsUnpack {}) = True
attempt_unpack (HsSrcBang (Just unpk) bang) = bang && unpk attempt_unpack (HsSrcBang _ (Just unpk) bang) = bang && unpk
attempt_unpack (HsSrcBang Nothing bang) = bang -- Be conservative attempt_unpack (HsSrcBang _ Nothing bang) = bang -- Be conservative
attempt_unpack HsStrict = False attempt_unpack HsStrict = False
attempt_unpack HsNoBang = False attempt_unpack HsNoBang = False
{- {-
Note [Unpack one-wide fields] Note [Unpack one-wide fields]
......
...@@ -86,6 +86,20 @@ import Data.Data ...@@ -86,6 +86,20 @@ import Data.Data
-- | Do not use the data constructors of RdrName directly: prefer the family -- | Do not use the data constructors of RdrName directly: prefer the family
-- of functions that creates them, such as 'mkRdrUnqual' -- of functions that creates them, such as 'mkRdrUnqual'
--
-- - Note: A Located RdrName will only have API Annotations if it is a
-- compound one,
-- e.g.
--
-- > `bar`
-- > ( ~ )
--
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',
-- 'ApiAnnotation.AnnOpen' @'('@ or @'['@ or @'[:'@,
-- 'ApiAnnotation.AnnClose' @')'@ or @']'@ or @':]'@,,
-- 'ApiAnnotation.AnnBackquote' @'`'@,
-- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnTildehsh',
-- 'ApiAnnotation.AnnTilde',
data RdrName data RdrName
= Unqual OccName = Unqual OccName
-- ^ Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@. -- ^ Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@.
......
-- (c) The University of Glasgow, 1992-2006 -- (c) The University of Glasgow, 1992-2006
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-}
-- Workaround for Trac #5252 crashes the bootstrap compiler without -O -- Workaround for Trac #5252 crashes the bootstrap compiler without -O
-- When the earliest compiler we want to boostrap with is -- When the earliest compiler we want to boostrap with is
...@@ -77,6 +82,10 @@ import Util ...@@ -77,6 +82,10 @@ import Util
import Outputable import Outputable
import FastString import FastString
#if __GLASGOW_HASKELL__ < 709
import Data.Foldable ( Foldable )
import Data.Traversable ( Traversable )
#endif
import Data.Bits import Data.Bits
import Data.Data import Data.Data
import Data.List import Data.List
...@@ -515,6 +524,8 @@ pprUserRealSpan show_path (SrcSpanPoint src_path line col) ...@@ -515,6 +524,8 @@ pprUserRealSpan show_path (SrcSpanPoint src_path line col)
-- | We attach SrcSpans to lots of things, so let's have a datatype for it. -- | We attach SrcSpans to lots of things, so let's have a datatype for it.
data GenLocated l e = L l e data GenLocated l e = L l e
deriving (Eq, Ord, Typeable, Data) deriving (Eq, Ord, Typeable, Data)
deriving instance Foldable (GenLocated l)
deriving instance Traversable (GenLocated l)
type Located e = GenLocated SrcSpan e type Located e = GenLocated SrcSpan e
type RealLocated e = GenLocated RealSrcSpan e type RealLocated e = GenLocated RealSrcSpan e
......
...@@ -452,11 +452,11 @@ get_lit :: Pat id -> Maybe HsLit ...@@ -452,11 +452,11 @@ get_lit :: Pat id -> Maybe HsLit
-- It doesn't matter which one, because they will only be compared -- It doesn't matter which one, because they will only be compared
-- with other HsLits gotten in the same way -- with other HsLits gotten in the same way
get_lit (LitPat lit) = Just lit get_lit (LitPat lit) = Just lit
get_lit (NPat (OverLit { ol_val = HsIntegral src i}) mb _) get_lit (NPat (L _ (OverLit { ol_val = HsIntegral src i})) mb _)
= Just (HsIntPrim src (mb_neg negate mb i)) = Just (HsIntPrim src (mb_neg negate mb i))
get_lit (NPat (OverLit { ol_val = HsFractional f }) mb _) get_lit (NPat (L _ (OverLit { ol_val = HsFractional f })) mb _)
= Just (HsFloatPrim (mb_neg negateFractionalLit mb f)) = Just (HsFloatPrim (mb_neg negateFractionalLit mb f))
get_lit (NPat (OverLit { ol_val = HsIsString src s }) _ _) get_lit (NPat (L _ (OverLit { ol_val = HsIsString src s })) _ _)
= Just (HsStringPrim src (fastStringToByteString s)) = Just (HsStringPrim src (fastStringToByteString s))
get_lit _ = Nothing get_lit _ = Nothing
...@@ -727,7 +727,7 @@ tidy_pat (TuplePat ps boxity tys) ...@@ -727,7 +727,7 @@ tidy_pat (TuplePat ps boxity tys)
where where
arity = length ps arity = length ps
tidy_pat (NPat lit mb_neg eq) = tidyNPat tidy_lit_pat lit mb_neg eq tidy_pat (NPat (L _ lit) mb_neg eq) = tidyNPat tidy_lit_pat lit mb_neg eq
tidy_pat (LitPat lit) = tidy_lit_pat lit tidy_pat (LitPat lit) = tidy_lit_pat lit
tidy_pat (ConPatIn {}) = panic "Check.tidy_pat: ConPatIn" tidy_pat (ConPatIn {}) = panic "Check.tidy_pat: ConPatIn"
......
...@@ -567,7 +567,7 @@ addTickHsExpr (HsTick t e) = ...@@ -567,7 +567,7 @@ addTickHsExpr (HsTick t e) =
addTickHsExpr (HsBinTick t0 t1 e) = addTickHsExpr (HsBinTick t0 t1 e) =
liftM (HsBinTick t0 t1) (addTickLHsExprNever 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 $ e2 <- allocTickBox (ExpBox False) False False pos $
addTickHsExpr e0 addTickHsExpr e0
return $ unLoc e2 return $ unLoc e2
...@@ -575,12 +575,14 @@ addTickHsExpr (PArrSeq ty arith_seq) = ...@@ -575,12 +575,14 @@ addTickHsExpr (PArrSeq ty arith_seq) =
liftM2 PArrSeq liftM2 PArrSeq
(return ty) (return ty)
(addTickArithSeqInfo arith_seq) (addTickArithSeqInfo arith_seq)
addTickHsExpr (HsSCC nm e) = addTickHsExpr (HsSCC src nm e) =
liftM2 HsSCC liftM3 HsSCC
(return src)
(return nm) (return nm)
(addTickLHsExpr e) (addTickLHsExpr e)
addTickHsExpr (HsCoreAnn nm e) = addTickHsExpr (HsCoreAnn src nm e) =
liftM2 HsCoreAnn liftM3 HsCoreAnn
(return src)
(return nm) (return nm)
(addTickLHsExpr e) (addTickLHsExpr e)
addTickHsExpr e@(HsBracket {}) = return e addTickHsExpr e@(HsBracket {}) = return e
...@@ -614,10 +616,10 @@ addTickMatchGroup is_lam mg@(MG { mg_alts = matches }) = do ...@@ -614,10 +616,10 @@ addTickMatchGroup is_lam mg@(MG { mg_alts = matches }) = do
return $ mg { mg_alts = matches' } return $ mg { mg_alts = matches' }
addTickMatch :: Bool -> Bool -> Match Id (LHsExpr Id) -> TM (Match Id (LHsExpr Id)) addTickMatch :: Bool -> Bool -> Match Id (LHsExpr Id) -> TM (Match Id (LHsExpr Id))
addTickMatch isOneOfMany isLambda (Match pats opSig gRHSs) = addTickMatch isOneOfMany isLambda (Match mf pats opSig gRHSs) =
bindLocals (collectPatsBinders pats) $ do bindLocals (collectPatsBinders pats) $ do
gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs
return $ Match pats opSig gRHSs' return $ Match mf pats opSig gRHSs'
addTickGRHSs :: Bool -> Bool -> GRHSs Id (LHsExpr Id) -> TM (GRHSs Id (LHsExpr Id)) addTickGRHSs :: Bool -> Bool -> GRHSs Id (LHsExpr Id) -> TM (GRHSs Id (LHsExpr Id))
addTickGRHSs isOneOfMany isLambda (GRHSs guarded local_binds) = do addTickGRHSs isOneOfMany isLambda (GRHSs guarded local_binds) = do
...@@ -829,10 +831,10 @@ addTickCmdMatchGroup mg@(MG { mg_alts = matches }) = do ...@@ -829,10 +831,10 @@ addTickCmdMatchGroup mg@(MG { mg_alts = matches }) = do
return $ mg { mg_alts = matches' } return $ mg { mg_alts = matches' }
addTickCmdMatch :: Match Id (LHsCmd Id) -> TM (Match Id (LHsCmd Id)) addTickCmdMatch :: Match Id (LHsCmd Id) -> TM (Match Id (LHsCmd Id))
addTickCmdMatch (Match pats opSig gRHSs) = addTickCmdMatch (Match mf pats opSig gRHSs) =
bindLocals (collectPatsBinders pats) $ do bindLocals (collectPatsBinders pats) $ do
gRHSs' <- addTickCmdGRHSs gRHSs gRHSs' <- addTickCmdGRHSs gRHSs
return $ Match pats opSig gRHSs' return $ Match mf pats opSig gRHSs'
addTickCmdGRHSs :: GRHSs Id (LHsCmd Id) -> TM (GRHSs Id (LHsCmd Id)) addTickCmdGRHSs :: GRHSs Id (LHsCmd Id) -> TM (GRHSs Id (LHsCmd Id))
addTickCmdGRHSs (GRHSs guarded local_binds) = do addTickCmdGRHSs (GRHSs guarded local_binds) = do
...@@ -1204,7 +1206,7 @@ hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals") ...@@ -1204,7 +1206,7 @@ hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")
matchesOneOfMany :: [LMatch Id body] -> Bool matchesOneOfMany :: [LMatch Id body] -> Bool
matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1 matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
where where
matchCount (L _ (Match _pats _ty (GRHSs grhss _binds))) = length grhss matchCount (L _ (Match _ _pats _ty (GRHSs grhss _binds))) = length grhss
type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel) type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)
......
...@@ -461,12 +461,12 @@ by simpleOptExpr (for the LHS) resp. the simplifiers (for the RHS). ...@@ -461,12 +461,12 @@ by simpleOptExpr (for the LHS) resp. the simplifiers (for the RHS).
-} -}
dsVect :: LVectDecl Id -> DsM CoreVect dsVect :: LVectDecl Id -> DsM CoreVect
dsVect (L loc (HsVect (L _ v) rhs)) dsVect (L loc (HsVect _ (L _ v) rhs))
= putSrcSpanDs loc $ = putSrcSpanDs loc $
do { rhs' <- dsLExpr rhs do { rhs' <- dsLExpr rhs
; return $ Vect v rhs' ; return $ Vect v rhs'
} }
dsVect (L _loc (HsNoVect (L _ v))) dsVect (L _loc (HsNoVect _ (L _ v)))
= return $ NoVect v = return $ NoVect v
dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon)) dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon))
= return $ VectType isScalar tycon' rhs_tycon = return $ VectType isScalar tycon' rhs_tycon
...@@ -474,11 +474,11 @@ dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon)) ...@@ -474,11 +474,11 @@ dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon))
tycon' | Just ty <- coreView $ mkTyConTy tycon