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

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(
FractionalLit(..), negateFractionalLit, integralFractionalLit,
HValue(..)
HValue(..),
SourceText
) where
import FastString
......@@ -263,14 +265,15 @@ initialVersion = 1
-}
-- reason/explanation from a WARNING or DEPRECATED pragma
data WarningTxt = WarningTxt [Located FastString]
| DeprecatedTxt [Located FastString]
-- For SourceText usage, see note [Pragma source text]
data WarningTxt = WarningTxt (Located SourceText) [Located FastString]
| DeprecatedTxt (Located SourceText) [Located FastString]
deriving (Eq, Data, Typeable)
instance Outputable WarningTxt where
ppr (WarningTxt ws) = doubleQuotes (vcat (map (ftext . unLoc) ws))
ppr (DeprecatedTxt ds) = text "Deprecated:" <+>
doubleQuotes (vcat (map (ftext . unLoc) ds))
ppr (WarningTxt _ ws) = doubleQuotes (vcat (map (ftext . unLoc) ws))
ppr (DeprecatedTxt _ ds) = text "Deprecated:" <+>
doubleQuotes (vcat (map (ftext . unLoc) ds))
{-
************************************************************************
......@@ -448,6 +451,13 @@ instance Outputable Origin where
-- | The semantics allowed for overlapping instances for a particular
-- instance. See Note [Safe Haskell isSafeOverlap] (in `InstEnv.lhs`) for a
-- explanation of the `isSafeOverlap` field.
--
-- - 'ApiAnnotation.AnnKeywordId' :
-- 'ApiAnnotation.AnnOpen' @'\{-\# OVERLAPPABLE'@ or
-- @'\{-\# OVERLAPPING'@ or
-- @'\{-\# OVERLAPS'@ or
-- @'\{-\# INCOHERENT'@,
-- 'ApiAnnotation.AnnClose' @`\#-\}`@,
data OverlapFlag = OverlapFlag
{ overlapMode :: OverlapMode
, isSafeOverlap :: Bool
......@@ -460,27 +470,29 @@ setOverlapModeMaybe f (Just m) = f { overlapMode = m }
hasOverlappableFlag :: OverlapMode -> Bool
hasOverlappableFlag mode =
case mode of
Overlappable -> True
Overlaps -> True
Incoherent -> True
_ -> False
Overlappable _ -> True
Overlaps _ -> True
Incoherent _ -> True
_ -> False
hasOverlappingFlag :: OverlapMode -> Bool
hasOverlappingFlag mode =
case mode of
Overlapping -> True
Overlaps -> True
Incoherent -> True
_ -> False
Overlapping _ -> True
Overlaps _ -> True
Incoherent _ -> True
_ -> False
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.
-- However, it may be overlapped by `Overlapping` instances,
-- and it may overlap `Overlappable` instances.
| Overlappable
| Overlappable SourceText
-- See Note [Pragma source text]
-- ^ Silently ignore this instance if you find a
-- more specific one that matches the constraint
-- you are trying to resolve
......@@ -494,7 +506,8 @@ data OverlapMode -- See Note [Rules for instance lookup] in InstEnv
-- its ambiguous which to choose)
| Overlapping
| Overlapping SourceText
-- See Note [Pragma source text]
-- ^ Silently ignore any more general instances that may be
-- used to solve the constraint.
--
......@@ -507,10 +520,12 @@ data OverlapMode -- See Note [Rules for instance lookup] in InstEnv
-- it is ambiguous which to choose)
| Overlaps
| Overlaps SourceText
-- See Note [Pragma source text]
-- ^ 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
-- an an arbitrary one if there are multiple matching candidates, and
-- don't worry about later instantiation
......@@ -529,11 +544,11 @@ instance Outputable OverlapFlag where
ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag)
instance Outputable OverlapMode where
ppr NoOverlap = empty
ppr Overlappable = ptext (sLit "[overlappable]")
ppr Overlapping = ptext (sLit "[overlapping]")
ppr Overlaps = ptext (sLit "[overlap ok]")
ppr Incoherent = ptext (sLit "[incoherent]")
ppr (NoOverlap _) = empty
ppr (Overlappable _) = ptext (sLit "[overlappable]")
ppr (Overlapping _) = ptext (sLit "[overlapping]")
ppr (Overlaps _) = ptext (sLit "[overlap ok]")
ppr (Incoherent _) = ptext (sLit "[incoherent]")
pprSafeOverlap :: Bool -> SDoc
pprSafeOverlap True = ptext $ sLit "[safe]"
......@@ -765,6 +780,72 @@ succeeded Failed = False
failed Succeeded = False
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]
data InlinePragma -- Note [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
-- explicit (non-type, non-dictionary) args
......@@ -890,7 +972,8 @@ isEmptyInlineSpec _ = False
defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma
:: InlinePragma
defaultInlinePragma = InlinePragma { inl_act = AlwaysActive
defaultInlinePragma = InlinePragma { inl_src = "{-# INLINE"
, inl_act = AlwaysActive
, inl_rule = FunLike
, inl_inline = EmptyInlineSpec
, inl_sat = Nothing }
......
......@@ -453,6 +453,7 @@ data HsBang
= HsNoBang -- Equivalent to (HsSrcBang Nothing False)
| HsSrcBang -- What the user wrote in the source code
(Maybe SourceText) -- Note [Pragma source text] in BasicTypes
(Maybe Bool) -- Just True {-# UNPACK #-}
-- Just False {-# NOUNPACK #-}
-- Nothing no pragma
......@@ -574,11 +575,11 @@ instance Data.Data DataCon where
dataTypeOf _ = mkNoRepType "DataCon"
instance Outputable HsBang where
ppr HsNoBang = empty
ppr (HsSrcBang prag bang) = pp_unpk prag <+> ppWhen bang (char '!')
ppr (HsUnpack Nothing) = ptext (sLit "Unpk")
ppr (HsUnpack (Just co)) = ptext (sLit "Unpk") <> parens (ppr co)
ppr HsStrict = ptext (sLit "SrictNotUnpacked")
ppr HsNoBang = empty
ppr (HsSrcBang _ prag bang) = pp_unpk prag <+> ppWhen bang (char '!')
ppr (HsUnpack Nothing) = ptext (sLit "Unpk")
ppr (HsUnpack (Just co)) = ptext (sLit "Unpk") <> parens (ppr co)
ppr HsStrict = ptext (sLit "SrictNotUnpacked")
pp_unpk :: Maybe Bool -> SDoc
pp_unpk Nothing = empty
......@@ -593,16 +594,16 @@ instance Outputable StrictnessMark where
eqHsBang :: HsBang -> HsBang -> Bool
eqHsBang HsNoBang HsNoBang = 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 (Just c1)) (HsUnpack (Just c2)) = eqType (coercionType c1) (coercionType c2)
eqHsBang _ _ = False
isBanged :: HsBang -> Bool
isBanged HsNoBang = False
isBanged (HsSrcBang _ bang) = bang
isBanged (HsUnpack {}) = True
isBanged (HsStrict {}) = True
isBanged HsNoBang = False
isBanged (HsSrcBang _ _ bang) = bang
isBanged (HsUnpack {}) = True
isBanged (HsStrict {}) = True
isMarkedStrict :: StrictnessMark -> Bool
isMarkedStrict NotMarkedStrict = False
......
......@@ -595,11 +595,11 @@ dataConArgRep
dataConArgRep _ _ arg_ty HsNoBang
= (HsNoBang, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
dataConArgRep _ _ arg_ty (HsSrcBang _ False) -- No '!'
dataConArgRep _ _ arg_ty (HsSrcBang _ _ False) -- No '!'
= (HsNoBang, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
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
-- Don't unpack if we aren't optimising; rather arbitrarily,
-- we use -fomit-iface-pragmas as the indication
......@@ -727,11 +727,11 @@ isUnpackableType fam_envs ty
-- NB: dataConSrcBangs gives the *user* request;
-- We'd get a black hole if we used dataConImplBangs
attempt_unpack (HsUnpack {}) = True
attempt_unpack (HsSrcBang (Just unpk) bang) = bang && unpk
attempt_unpack (HsSrcBang Nothing bang) = bang -- Be conservative
attempt_unpack HsStrict = False
attempt_unpack HsNoBang = False
attempt_unpack (HsUnpack {}) = True
attempt_unpack (HsSrcBang _ (Just unpk) bang) = bang && unpk
attempt_unpack (HsSrcBang _ Nothing bang) = bang -- Be conservative
attempt_unpack HsStrict = False
attempt_unpack HsNoBang = False
{-
Note [Unpack one-wide fields]
......
......@@ -86,6 +86,20 @@ import Data.Data
-- | Do not use the data constructors of RdrName directly: prefer the family
-- 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
= Unqual OccName
-- ^ Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@.
......
-- (c) The University of Glasgow, 1992-2006
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -fno-omit-interface-pragmas #-}
-- Workaround for Trac #5252 crashes the bootstrap compiler without -O
-- When the earliest compiler we want to boostrap with is
......@@ -77,6 +82,10 @@ import Util
import Outputable
import FastString
#if __GLASGOW_HASKELL__ < 709
import Data.Foldable ( Foldable )
import Data.Traversable ( Traversable )
#endif
import Data.Bits
import Data.Data
import Data.List
......@@ -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.
data GenLocated l e = L l e
deriving (Eq, Ord, Typeable, Data)
deriving instance Foldable (GenLocated l)
deriving instance Traversable (GenLocated l)
type Located e = GenLocated SrcSpan e
type RealLocated e = GenLocated RealSrcSpan e
......
......@@ -452,11 +452,11 @@ get_lit :: Pat id -> Maybe HsLit
-- It doesn't matter which one, because they will only be compared
-- with other HsLits gotten in the same way
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))
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))
get_lit (NPat (OverLit { ol_val = HsIsString src s }) _ _)
get_lit (NPat (L _ (OverLit { ol_val = HsIsString src s })) _ _)
= Just (HsStringPrim src (fastStringToByteString s))
get_lit _ = Nothing
......@@ -727,7 +727,7 @@ tidy_pat (TuplePat ps boxity tys)
where
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 (ConPatIn {}) = panic "Check.tidy_pat: ConPatIn"
......
......@@ -567,7 +567,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
......@@ -575,12 +575,14 @@ addTickHsExpr (PArrSeq ty arith_seq) =
liftM2 PArrSeq
(return ty)
(addTickArithSeqInfo arith_seq)
addTickHsExpr (HsSCC nm e) =
liftM2 HsSCC
addTickHsExpr (HsSCC src nm e) =
liftM3 HsSCC
(return src)
(return nm)
(addTickLHsExpr e)
addTickHsExpr (HsCoreAnn nm e) =
liftM2 HsCoreAnn
addTickHsExpr (HsCoreAnn src nm e) =
liftM3 HsCoreAnn
(return src)
(return nm)
(addTickLHsExpr e)
addTickHsExpr e@(HsBracket {}) = return e
......@@ -614,10 +616,10 @@ addTickMatchGroup is_lam mg@(MG { mg_alts = matches }) = do
return $ mg { mg_alts = matches' }
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
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 isOneOfMany isLambda (GRHSs guarded local_binds) = do
......@@ -829,10 +831,10 @@ addTickCmdMatchGroup mg@(MG { mg_alts = matches }) = do
return $ mg { mg_alts = matches' }
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
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 guarded local_binds) = do
......@@ -1204,7 +1206,7 @@ hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")
matchesOneOfMany :: [LMatch Id body] -> Bool
matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
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)
......
......@@ -461,12 +461,12 @@ by simpleOptExpr (for the LHS) resp. the simplifiers (for the RHS).
-}
dsVect :: LVectDecl Id -> DsM CoreVect
dsVect (L loc (HsVect (L _ v) rhs))
dsVect (L loc (HsVect _ (L _ v) rhs))
= putSrcSpanDs loc $
do { rhs' <- dsLExpr rhs
; return $ Vect v rhs'
}
dsVect (L _loc (HsNoVect (L _ v)))
dsVect (L _loc (HsNoVect _ (L _ v)))
= return $ NoVect v
dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon))
= return $ VectType isScalar tycon' rhs_tycon
......@@ -474,11 +474,11 @@ dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon))
tycon' | Just ty <- coreView $ mkTyConTy tycon
, (tycon', []) <- splitTyConApp ty = tycon'
| otherwise = tycon
dsVect vd@(L _ (HsVectTypeIn _ _ _))
dsVect vd@(L _ (HsVectTypeIn _ _ _ _))
= pprPanic "Desugar.dsVect: unexpected 'HsVectTypeIn'" (ppr vd)
dsVect (L _loc (HsVectClassOut cls))
= return $ VectClass (classTyCon cls)
dsVect vc@(L _ (HsVectClassIn _))
dsVect vc@(L _ (HsVectClassIn _ _))
= pprPanic "Desugar.dsVect: unexpected 'HsVectClassIn'" (ppr vc)
dsVect (L _loc (HsVectInstOut inst))
= return $ VectInst (instanceDFunId inst)
......
......@@ -399,7 +399,8 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do
-- ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd
dsCmd ids local_vars stack_ty res_ty
(HsCmdLam (MG { mg_alts = [L _ (Match pats _ (GRHSs [L _ (GRHS [] body)] _ ))] }))
(HsCmdLam (MG { mg_alts = [L _ (Match _ pats _
(GRHSs [L _ (GRHS [] body)] _ ))] }))
env_ids = do
let
pat_vars = mkVarSet (collectPatsBinders pats)
......@@ -1046,7 +1047,7 @@ matchSimplys _ _ _ _ _ = panic "matchSimplys"
-- List of leaf expressions, with set of variables bound in each
leavesMatch :: LMatch Id (Located (body Id)) -> [(Located (body Id), IdSet)]
leavesMatch (L _ (Match pats _ (GRHSs grhss binds)))
leavesMatch (L _ (Match _ pats _ (GRHSs grhss binds)))
= let
defined_vars = mkVarSet (collectPatsBinders pats)
`unionVarSet`
......@@ -1065,11 +1066,11 @@ replaceLeavesMatch
-> LMatch Id (Located (body Id)) -- the matches of a case command
-> ([Located (body' Id)], -- remaining leaf expressions
LMatch Id (Located (body' Id))) -- updated match
replaceLeavesMatch _res_ty leaves (L loc (Match pat mt (GRHSs grhss binds)))
replaceLeavesMatch _res_ty leaves (L loc (Match mf pat mt (GRHSs grhss binds)))
= let
(leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss
in
(leaves', L loc (Match pat mt (GRHSs grhss' binds)))
(leaves', L loc (Match mf pat mt (GRHSs grhss' binds)))
replaceLeavesGRHS
:: [Located (body' Id)] -- replacement leaf expressions of that type
......
......@@ -300,13 +300,18 @@ dsExpr (ExplicitTuple tup_args boxity)
mkCoreConApps (tupleCon (boxityNormalTupleSort boxity) (length tup_args))
(map (Type . exprType) args ++ args) }
dsExpr (HsSCC cc expr@(L loc _)) = do
mod_name <- getModule
count <- goptM Opt_ProfCountEntries
uniq <- newUnique
Tick (ProfNote (mkUserCC cc mod_name loc uniq) count True) <$> dsLExpr expr
dsExpr (HsCoreAnn _ expr)
dsExpr (HsSCC _ cc expr@(L loc _)) = do
dflags <- getDynFlags
if gopt Opt_SccProfilingOn dflags
then do
mod_name <- getModule
count <- goptM Opt_ProfCountEntries
uniq <- newUnique
Tick (ProfNote (mkUserCC cc mod_name loc uniq) count True)
<$> dsLExpr expr
else dsLExpr expr
dsExpr (HsCoreAnn _ _ expr)
= dsLExpr expr
dsExpr (HsCase discrim matches)
......@@ -669,13 +674,18 @@ dsExpr (HsBinTick ixT ixF e) = do
mkBinaryTickBox ixT ixF e2
}
dsExpr (HsTickPragma _ _ expr) = do
dflags <- getDynFlags
if gopt Opt_Hpc dflags
then panic "dsExpr:HsTickPragma"
else dsLExpr expr
-- HsSyn constructs that just shouldn't be here:
dsExpr (ExprWithTySig {}) = panic "dsExpr:ExprWithTySig"
dsExpr (HsBracket {}) = panic "dsExpr:HsBracket"
dsExpr (HsQuasiQuoteE {}) = panic "dsExpr:HsQuasiQuoteE"
dsExpr (HsArrApp {}) = panic "dsExpr:HsArrApp"
dsExpr (HsArrForm {}) = panic "dsExpr:HsArrForm"
dsExpr (HsTickPragma {}) = panic "dsExpr:HsTickPragma"
dsExpr (EWildPat {}) = panic "dsExpr:EWildPat"
dsExpr (EAsPat {}) = panic "dsExpr:EAsPat"
dsExpr (EViewPat {}) = panic "dsExpr:EViewPat"
......@@ -684,6 +694,7 @@ dsExpr (HsType {}) = panic "dsExpr:HsType"
dsExpr (HsDo {}) = panic "dsExpr:HsDo"
findField :: [LHsRecField Id arg] -> Name -> [arg]
findField rbinds lbl
= [rhs | L _ (HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs }) <- rbinds
......
......@@ -713,7 +713,7 @@ toCType = f False
-- Note that we aren't looking through type synonyms or
-- anything, as it may be the synonym that is annotated.
| TyConApp tycon _ <- t
, Just (CType mHeader cType) <- tyConCType_maybe tycon
, Just (CType _ mHeader cType) <- tyConCType_maybe tycon
= (mHeader, ftext cType)
-- If we don't know a C type for this type, then try looking
-- through one layer of type synonym etc.
......
......@@ -147,9 +147,11 @@ repTopDs group@(HsGroup { hs_valds = valds
; fix_ds <- mapM repFixD fixds
; _ <- mapM no_default_decl defds
; for_ds <- mapM repForD fords
; _ <- mapM no_warn warnds
; _ <- mapM no_warn (concatMap (wd_warnings . unLoc)
warnds)
; ann_ds <- mapM repAnnD annds
; rule_ds <- mapM repRuleD ruleds
; rule_ds <- mapM repRuleD (concatMap (rds_rules . unLoc)
ruleds)
; _ <- mapM no_vect vects
; _ <- mapM no_doc docs
......@@ -361,7 +363,7 @@ mk_extra_tvs tc tvs defn
= do { uniq <- newUnique
; let { occ = mkTyVarOccFS (fsLit "t")
; nm = mkInternalName uniq occ loc
; hs_tv = L loc (KindedTyVar nm kind) }
; hs_tv = L loc (KindedTyVar (noLoc nm) kind) }
; hs_tvs <- go rest
; return (hs_tv : hs_tvs) }
......@@ -374,13 +376,14 @@ mk_extra_tvs tc tvs defn
-------------------------
-- represent fundeps
--
repLFunDeps :: [Located (FunDep Name)] -> DsM (Core [TH.FunDep])
repLFunDeps :: [Located (FunDep (Located Name))] -> DsM (Core [TH.FunDep])
repLFunDeps fds = repList funDepTyConName repLFunDep fds
repLFunDep :: Located (FunDep Name) -> DsM (Core TH.FunDep)
repLFunDep (L _ (xs, ys)) = do xs' <- repList nameTyConName lookupBinder xs
ys' <- repList nameTyConName lookupBinder ys
repFunDep xs' ys'
repLFunDep :: Located (FunDep (Located Name)) -> DsM (Core TH.FunDep)
repLFunDep (L _ (xs, ys))
= do xs' <- repList nameTyConName (lookupBinder . unLoc) xs
ys' <- repList nameTyConName (lookupBinder . unLoc) ys
repFunDep xs' ys'
-- represent family declaration flavours
--
......@@ -550,17 +553,17 @@ repRuleBndr (L _ (RuleBndrSig n (HsWB { hswb_cts = ty })))
; rep2 typedRuleVarName [n', ty'] }
repAnnD :: LAnnDecl Name -> DsM (SrcSpan, Core TH.DecQ)