Commit 7927658e authored by Alan Zimmerman's avatar Alan Zimmerman Committed by Austin Seipp

AST changes to prepare for API annotations, for #9628

Summary:
AST changes to prepare for API annotations

Add locations to parts of the AST so that API annotations can
then be added.

The outline of the whole process is captured here
https://ghc.haskell.org/trac/ghc/wiki/GhcAstAnnotations

This change updates the haddock submodule.

Test Plan: sh ./validate

Reviewers: austin, simonpj, Mikolaj

Reviewed By: simonpj, Mikolaj

Subscribers: thomie, goldfire, carter

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

GHC Trac Issues: #9628
parent cfa574ce
......@@ -89,6 +89,7 @@ module BasicTypes(
import FastString
import Outputable
import SrcLoc ( Located,unLoc )
import Data.Data hiding (Fixity)
import Data.Function (on)
......@@ -263,14 +264,14 @@ initialVersion = 1
\begin{code}
-- reason/explanation from a WARNING or DEPRECATED pragma
data WarningTxt = WarningTxt [FastString]
| DeprecatedTxt [FastString]
data WarningTxt = WarningTxt [Located FastString]
| DeprecatedTxt [Located FastString]
deriving (Eq, Data, Typeable)
instance Outputable WarningTxt where
ppr (WarningTxt ws) = doubleQuotes (vcat (map ftext ws))
ppr (WarningTxt ws) = doubleQuotes (vcat (map (ftext . unLoc) ws))
ppr (DeprecatedTxt ds) = text "Deprecated:" <+>
doubleQuotes (vcat (map ftext ds))
doubleQuotes (vcat (map (ftext . unLoc) ds))
\end{code}
%************************************************************************
......
......@@ -166,8 +166,9 @@ untidy_con :: HsConPatDetails Name -> HsConPatDetails Name
untidy_con (PrefixCon pats) = PrefixCon (map untidy_pars pats)
untidy_con (InfixCon p1 p2) = InfixCon (untidy_pars p1) (untidy_pars p2)
untidy_con (RecCon (HsRecFields flds dd))
= RecCon (HsRecFields [ fld { hsRecFieldArg = untidy_pars (hsRecFieldArg fld) }
| fld <- flds ] dd)
= RecCon (HsRecFields [ L l (fld { hsRecFieldArg
= untidy_pars (hsRecFieldArg fld) })
| L l fld <- flds ] dd)
pars :: NeedPars -> WarningPat -> Pat Name
pars True p = ParPat p
......@@ -765,7 +766,8 @@ tidy_con con (RecCon (HsRecFields fs _))
field_pats = case con of
RealDataCon dc -> map (\ f -> (f, nlWildPatId)) (dataConFieldLabels dc)
PatSynCon{} -> panic "Check.tidy_con: pattern synonym with record syntax"
all_pats = foldr (\(HsRecField id p _) acc -> insertNm (getName (unLoc id)) p acc)
all_pats = foldr (\(L _ (HsRecField id p _)) acc
-> insertNm (getName (unLoc id)) p acc)
field_pats fs
insertNm nm p [] = [(nm,p)]
......
......@@ -593,9 +593,10 @@ addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar"
-- Others dhould never happen in expression content.
addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e)
addTickTupArg :: HsTupArg Id -> TM (HsTupArg Id)
addTickTupArg (Present e) = do { e' <- addTickLHsExpr e; return (Present e') }
addTickTupArg (Missing ty) = return (Missing ty)
addTickTupArg :: LHsTupArg Id -> TM (LHsTupArg Id)
addTickTupArg (L l (Present e)) = do { e' <- addTickLHsExpr e
; return (L l (Present e')) }
addTickTupArg (L l (Missing ty)) = return (L l (Missing ty))
addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup Id (LHsExpr Id) -> TM (MatchGroup Id (LHsExpr Id))
addTickMatchGroup is_lam mg@(MG { mg_alts = matches }) = do
......@@ -891,9 +892,9 @@ addTickHsRecordBinds (HsRecFields fields dd)
= do { fields' <- mapM process fields
; return (HsRecFields fields' dd) }
where
process (HsRecField ids expr doc)
process (L l (HsRecField ids expr doc))
= do { expr' <- addTickLHsExpr expr
; return (HsRecField ids expr' doc) }
; return (L l (HsRecField ids expr' doc)) }
addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id)
addTickArithSeqInfo (From e1) =
......
......@@ -349,7 +349,7 @@ Reason
dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
= putSrcSpanDs loc $
do { let bndrs' = [var | RuleBndr (L _ var) <- vars]
do { let bndrs' = [var | L _ (RuleBndr (L _ var)) <- vars]
; lhs' <- unsetGOptM Opt_EnableRewriteRules $
unsetWOptM Opt_WarnIdentities $
......@@ -373,7 +373,8 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
fn_name = idName fn_id
final_rhs = simpleOptExpr rhs'' -- De-crap it
rule = mkRule False {- Not auto -} is_local
name act fn_name final_bndrs args final_rhs
(unLoc name) act fn_name final_bndrs args
final_rhs
inline_shadows_rule -- Function can be inlined before rule fires
| wopt Opt_WarnInlineRuleShadowing dflags
......@@ -390,7 +391,8 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
| otherwise = False
; when inline_shadows_rule $
warnDs (vcat [ hang (ptext (sLit "Rule") <+> doubleQuotes (ftext name)
warnDs (vcat [ hang (ptext (sLit "Rule")
<+> doubleQuotes (ftext $ unLoc name)
<+> ptext (sLit "may never fire"))
2 (ptext (sLit "because") <+> quotes (ppr fn_id)
<+> ptext (sLit "might inline first"))
......
......@@ -278,12 +278,12 @@ dsExpr (SectionR op expr) = do
Lam x_id (mkCoreAppsDs core_op [Var x_id, Var y_id]))
dsExpr (ExplicitTuple tup_args boxity)
= do { let go (lam_vars, args) (Missing ty)
= do { let go (lam_vars, args) (L _ (Missing ty))
-- For every missing expression, we need
-- another lambda in the desugaring.
= do { lam_var <- newSysLocalDs ty
; return (lam_var : lam_vars, Var lam_var : args) }
go (lam_vars, args) (Present expr)
go (lam_vars, args) (L _ (Present expr))
-- Expressions that are present don't generate
-- lambdas, just arguments.
= do { core_expr <- dsLExpr expr
......@@ -495,15 +495,15 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
; return (add_field_binds field_binds' $
bindNonRec discrim_var record_expr' matching_code) }
where
ds_field :: HsRecField Id (LHsExpr Id) -> DsM (Name, Id, CoreExpr)
ds_field :: LHsRecField Id (LHsExpr Id) -> DsM (Name, Id, CoreExpr)
-- Clone the Id in the HsRecField, because its Name is that
-- of the record selector, and we must not make that a lcoal binder
-- else we shadow other uses of the record selector
-- Hence 'lcl_id'. Cf Trac #2735
ds_field rec_field = do { rhs <- dsLExpr (hsRecFieldArg rec_field)
; let fld_id = unLoc (hsRecFieldId rec_field)
; lcl_id <- newSysLocalDs (idType fld_id)
; return (idName fld_id, lcl_id, rhs) }
ds_field (L _ rec_field) = do { rhs <- dsLExpr (hsRecFieldArg rec_field)
; let fld_id = unLoc (hsRecFieldId rec_field)
; lcl_id <- newSysLocalDs (idType fld_id)
; return (idName fld_id, lcl_id, rhs) }
add_field_binds [] expr = expr
add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr)
......@@ -613,9 +613,9 @@ dsExpr (HsType {}) = panic "dsExpr:HsType"
dsExpr (HsDo {}) = panic "dsExpr:HsDo"
findField :: [HsRecField Id arg] -> Name -> [arg]
findField :: [LHsRecField Id arg] -> Name -> [arg]
findField rbinds lbl
= [rhs | HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs } <- rbinds
= [rhs | L _ (HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs }) <- rbinds
, lbl == idName (unLoc id) ]
\end{code}
......
......@@ -107,7 +107,8 @@ dsForeigns' fos = do
traceIf (text "fi end" <+> ppr id)
return (h, c, [], bs)
do_decl (ForeignExport (L _ id) _ co (CExport (CExportStatic ext_nm cconv))) = do
do_decl (ForeignExport (L _ id) _ co
(CExport (L _ (CExportStatic ext_nm cconv)) _)) = do
(h, c, _, _) <- dsFExport id co ext_nm cconv False
return (h, c, [id], [])
\end{code}
......@@ -142,8 +143,8 @@ dsFImport :: Id
-> Coercion
-> ForeignImport
-> DsM ([Binding], SDoc, SDoc)
dsFImport id co (CImport cconv safety mHeader spec) = do
(ids, h, c) <- dsCImport id co spec cconv safety mHeader
dsFImport id co (CImport cconv safety mHeader spec _) = do
(ids, h, c) <- dsCImport id co spec (unLoc cconv) (unLoc safety) mHeader
return (ids, h, c)
dsCImport :: Id
......
This diff is collapsed.
......@@ -973,8 +973,8 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
exp _ _ = False
---------
tup_arg (Present e1) (Present e2) = lexp e1 e2
tup_arg (Missing t1) (Missing t2) = eqType t1 t2
tup_arg (L _ (Present e1)) (L _ (Present e2)) = lexp e1 e2
tup_arg (L _ (Missing t1)) (L _ (Missing t2)) = eqType t1 t2
tup_arg _ _ = False
---------
......
......@@ -187,8 +187,8 @@ matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor
= arg_vars
where
fld_var_env = mkNameEnv $ zipEqual "get_arg_vars" fields1 arg_vars
lookup_fld rpat = lookupNameEnv_NF fld_var_env
(idName (unLoc (hsRecFieldId rpat)))
lookup_fld (L _ rpat) = lookupNameEnv_NF fld_var_env
(idName (unLoc (hsRecFieldId rpat)))
select_arg_vars _ [] = panic "matchOneCon/select_arg_vars []"
matchOneConLike _ _ [] = panic "matchOneCon []"
......@@ -203,7 +203,8 @@ compatible_pats _ _ = True -- Prefix or infix co
same_fields :: HsRecFields Id (LPat Id) -> HsRecFields Id (LPat Id) -> Bool
same_fields flds1 flds2
= all2 (\f1 f2 -> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2))
= all2 (\(L _ f1) (L _ f2)
-> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2))
(rec_flds flds1) (rec_flds flds2)
......@@ -224,7 +225,7 @@ conArgPats arg_tys (RecCon (HsRecFields { rec_flds = rpats }))
| null rpats = map WildPat arg_tys
-- Important special case for C {}, which can be used for a
-- datacon that isn't declared to have fields at all
| otherwise = map (unLoc . hsRecFieldArg) rpats
| otherwise = map (unLoc . hsRecFieldArg . unLoc) rpats
\end{code}
Note [Record patterns]
......
......@@ -176,7 +176,7 @@ cvtDec (TH.InfixD fx nm)
-- the RdrName says it's a variable or a constructor. So, just assume
-- it's a variable or constructor and proceed.
= do { nm' <- vcNameL nm
; returnJustL (Hs.SigD (FixSig (FixitySig nm' (cvtFixity fx)))) }
; returnJustL (Hs.SigD (FixSig (FixitySig [nm'] (cvtFixity fx)))) }
cvtDec (PragmaD prag)
= cvtPragmaD prag
......@@ -208,7 +208,8 @@ cvtDec (NewtypeD ctxt tc tvs constr derivs)
; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing
, dd_ctxt = ctxt'
, dd_kindSig = Nothing
, dd_cons = [con'], dd_derivs = derivs' }
, dd_cons = [con']
, dd_derivs = derivs' }
; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
, tcdDataDefn = defn
, tcdFVs = placeHolderNames }) }
......@@ -416,7 +417,8 @@ cvtConstr (RecC c varstrtys)
= do { c' <- cNameL c
; cxt' <- returnL []
; args' <- mapM cvt_id_arg varstrtys
; returnL $ mkSimpleConDecl c' noExistentials cxt' (RecCon args') }
; returnL $ mkSimpleConDecl c' noExistentials cxt'
(RecCon args') }
cvtConstr (InfixC st1 c st2)
= do { c' <- cNameL c
......@@ -437,16 +439,18 @@ cvt_arg (NotStrict, ty) = cvtType ty
cvt_arg (IsStrict, ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsUserBang Nothing True) ty' }
cvt_arg (Unpacked, ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsUserBang (Just True) True) ty' }
cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (ConDeclField RdrName)
cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (LConDeclField RdrName)
cvt_id_arg (i, str, ty)
= do { i' <- vNameL i
; ty' <- cvt_arg (str,ty)
; return (ConDeclField { cd_fld_name = i', cd_fld_type = ty', cd_fld_doc = Nothing}) }
; return $ noLoc (ConDeclField { cd_fld_names = [i']
, cd_fld_type = ty'
, cd_fld_doc = Nothing}) }
cvtDerivs :: [TH.Name] -> CvtM (Maybe [LHsType RdrName])
cvtDerivs :: [TH.Name] -> CvtM (Maybe (Located [LHsType RdrName]))
cvtDerivs [] = return Nothing
cvtDerivs cs = do { cs' <- mapM cvt_one cs
; return (Just cs') }
; return (Just (noLoc cs')) }
where
cvt_one c = do { c' <- tconName c
; returnL $ HsTyVar c' }
......@@ -463,8 +467,9 @@ noExistentials = []
cvtForD :: Foreign -> CvtM (ForeignDecl RdrName)
cvtForD (ImportF callconv safety from nm ty)
| Just impspec <- parseCImport (cvt_conv callconv) safety'
(mkFastString (TH.nameBase nm)) from
| Just impspec <- parseCImport (noLoc (cvt_conv callconv)) (noLoc safety')
(mkFastString (TH.nameBase nm))
from (noLoc (mkFastString from))
= do { nm' <- vNameL nm
; ty' <- cvtType ty
; return (ForeignImport nm' ty' noForeignImportCoercionYet impspec)
......@@ -480,7 +485,9 @@ cvtForD (ImportF callconv safety from nm ty)
cvtForD (ExportF callconv as nm ty)
= do { nm' <- vNameL nm
; ty' <- cvtType ty
; let e = CExport (CExportStatic (mkFastString as) (cvt_conv callconv))
; let e = CExport (noLoc (CExportStatic (mkFastString as)
(cvt_conv callconv)))
(noLoc (mkFastString as))
; return $ ForeignExport nm' ty' noForeignExportCoercionYet e }
cvt_conv :: TH.Callconv -> CCallConv
......@@ -514,7 +521,7 @@ cvtPragmaD (SpecialiseP nm ty inline phases)
, inl_rule = Hs.FunLike
, inl_act = cvtPhases phases dflt
, inl_sat = Nothing }
; returnJustL $ Hs.SigD $ SpecSig nm' ty' ip }
; returnJustL $ Hs.SigD $ SpecSig nm' [ty'] ip }
cvtPragmaD (SpecialiseInstP ty)
= do { ty' <- cvtType ty
......@@ -526,7 +533,7 @@ cvtPragmaD (RuleP nm bndrs lhs rhs phases)
; bndrs' <- mapM cvtRuleBndr bndrs
; lhs' <- cvtl lhs
; rhs' <- cvtl rhs
; returnJustL $ Hs.RuleD $ HsRule nm' act bndrs'
; returnJustL $ Hs.RuleD $ HsRule (noLoc nm') act bndrs'
lhs' placeHolderNames
rhs' placeHolderNames
}
......@@ -567,14 +574,14 @@ cvtPhases AllPhases dflt = dflt
cvtPhases (FromPhase i) _ = ActiveAfter i
cvtPhases (BeforePhase i) _ = ActiveBefore i
cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.RuleBndr RdrName)
cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr RdrName)
cvtRuleBndr (RuleVar n)
= do { n' <- vNameL n
; return $ Hs.RuleBndr n' }
; return $ noLoc $ Hs.RuleBndr n' }
cvtRuleBndr (TypedRuleVar n ty)
= do { n' <- vNameL n
; ty' <- cvtType ty
; return $ Hs.RuleBndrSig n' $ mkHsWithBndrs ty' }
; return $ noLoc $ Hs.RuleBndrSig n' $ mkHsWithBndrs ty' }
---------------------------------------------------
-- Declarations
......@@ -622,8 +629,12 @@ cvtl e = wrapL (cvt e)
cvt (TupE [e]) = do { e' <- cvtl e; return $ HsPar e' }
-- Note [Dropping constructors]
-- Singleton tuples treated like nothing (just parens)
cvt (TupE es) = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Boxed }
cvt (UnboxedTupE es) = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Unboxed }
cvt (TupE es) = do { es' <- mapM cvtl es
; return $ ExplicitTuple (map (noLoc . Present) es')
Boxed }
cvt (UnboxedTupE es) = do { es' <- mapM cvtl es
; return $ ExplicitTuple
(map (noLoc . Present) es') Unboxed }
cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;
; return $ HsIf (Just noSyntaxExpr) x' y' z' }
cvt (MultiIfE alts)
......@@ -694,10 +705,11 @@ and the above expression would be reassociated to
which we don't want.
-}
cvtFld :: (TH.Name, TH.Exp) -> CvtM (HsRecField RdrName (LHsExpr RdrName))
cvtFld :: (TH.Name, TH.Exp) -> CvtM (LHsRecField RdrName (LHsExpr RdrName))
cvtFld (v,e)
= do { v' <- vNameL v; e' <- cvtl e
; return (HsRecField { hsRecFieldId = v', hsRecFieldArg = e', hsRecPun = False}) }
; return (noLoc $ HsRecField { hsRecFieldId = v', hsRecFieldArg = e'
, hsRecPun = False}) }
cvtDD :: Range -> CvtM (ArithSeqInfo RdrName)
cvtDD (FromR x) = do { x' <- cvtl x; return $ From x' }
......@@ -907,10 +919,11 @@ cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t
cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p
; return $ ViewPat e' p' placeHolderType }
cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName))
cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField RdrName (LPat RdrName))
cvtPatFld (s,p)
= do { s' <- vNameL s; p' <- cvtPat p
; return (HsRecField { hsRecFieldId = s', hsRecFieldArg = p', hsRecPun = False}) }
; return (noLoc $ HsRecField { hsRecFieldId = s', hsRecFieldArg = p'
, hsRecPun = False}) }
{- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.
The produced tree of infix patterns will be left-biased, provided @x@ is.
......
......@@ -607,7 +607,7 @@ data Sig name
-- > {-# SPECIALISE f :: Int -> Int #-}
--
| SpecSig (Located name) -- Specialise a function or datatype ...
(LHsType name) -- ... to these types
[LHsType name] -- ... to these types
InlinePragma -- The pragma on SPECIALISE_INLINE form.
-- If it's just defaultInlinePragma, then we said
-- SPECIALISE, not SPECIALISE_INLINE
......@@ -630,7 +630,7 @@ deriving instance (DataId name) => Data (Sig name)
type LFixitySig name = Located (FixitySig name)
data FixitySig name = FixitySig (Located name) Fixity
data FixitySig name = FixitySig [Located name] Fixity
deriving (Data, Typeable)
-- | TsSpecPrags conveys pragmas from the type checker to the desugarer
......@@ -727,7 +727,8 @@ ppr_sig (TypeSig vars ty) = pprVarSig (map unLoc vars) (ppr ty)
ppr_sig (GenericSig vars ty) = ptext (sLit "default") <+> pprVarSig (map unLoc vars) (ppr ty)
ppr_sig (IdSig id) = pprVarSig [id] (ppr (varType id))
ppr_sig (FixSig fix_sig) = ppr fix_sig
ppr_sig (SpecSig var ty inl) = pragBrackets (pprSpec (unLoc var) (ppr ty) inl)
ppr_sig (SpecSig var ty inl)
= pragBrackets (pprSpec (unLoc var) (interpp'SP ty) inl)
ppr_sig (InlineSig var inl) = pragBrackets (ppr inl <+> pprPrefixOcc (unLoc var))
ppr_sig (SpecInstSig ty) = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty)
ppr_sig (MinimalSig bf) = pragBrackets (pprMinimalSig bf)
......@@ -750,7 +751,9 @@ pprPatSynSig ident _is_bidir tvs prov req ty
(Just prov, Just req) -> prov <+> darrow <+> req <+> darrow
instance OutputableBndr name => Outputable (FixitySig name) where
ppr (FixitySig name fixity) = sep [ppr fixity, pprInfixOcc (unLoc name)]
ppr (FixitySig names fixity) = sep [ppr fixity, pprops]
where
pprops = hsep $ punctuate comma (map (pprInfixOcc . unLoc) names)
pragBrackets :: SDoc -> SDoc
pragBrackets doc = ptext (sLit "{-#") <+> doc <+> ptext (sLit "#-}")
......
This diff is collapsed.
......@@ -161,8 +161,8 @@ data HsExpr id
(LHsExpr id) -- operand
-- | Used for explicit tuples and sections thereof
| ExplicitTuple
[HsTupArg id]
| ExplicitTuple
[LHsTupArg id]
Boxity
| HsCase (LHsExpr id)
......@@ -339,17 +339,18 @@ data HsExpr id
deriving instance (DataId id) => Data (HsExpr id)
-- | HsTupArg is used for tuple sections
-- (,a,) is represented by ExplicitTuple [Mising ty1, Present a, Missing ty3]
-- (,a,) is represented by ExplicitTuple [Missing ty1, Present a, Missing ty3]
-- Which in turn stands for (\x:ty1 \y:ty2. (x,a,y))
type LHsTupArg id = Located (HsTupArg id)
data HsTupArg id
= Present (LHsExpr id) -- ^ The argument
| Missing (PostTc id Type) -- ^ The argument is missing, but this is its type
deriving (Typeable)
deriving instance (DataId id) => Data (HsTupArg id)
tupArgPresent :: HsTupArg id -> Bool
tupArgPresent (Present {}) = True
tupArgPresent (Missing {}) = False
tupArgPresent :: LHsTupArg id -> Bool
tupArgPresent (L _ (Present {})) = True
tupArgPresent (L _ (Missing {})) = False
\end{code}
Note [Parens in HsSyn]
......@@ -477,7 +478,8 @@ ppr_expr (SectionR op expr)
pp_infixly v = sep [pprInfixOcc v, pp_expr]
ppr_expr (ExplicitTuple exprs boxity)
= tupleParens (boxityNormalTupleSort boxity) (fcat (ppr_tup_args exprs))
= tupleParens (boxityNormalTupleSort boxity)
(fcat (ppr_tup_args $ map unLoc exprs))
where
ppr_tup_args [] = []
ppr_tup_args (Present e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es
......
......@@ -41,7 +41,8 @@ data ImportDecl name
ideclQualified :: Bool, -- ^ True => qualified
ideclImplicit :: Bool, -- ^ True => implicit import (of Prelude)
ideclAs :: Maybe ModuleName, -- ^ as Module
ideclHiding :: Maybe (Bool, [LIE name]) -- ^ (True => hiding, names)
ideclHiding :: Maybe (Bool, Located [LIE name])
-- ^ (True => hiding, names)
} deriving (Data, Typeable)
simpleImportDecl :: ModuleName -> ImportDecl name
......@@ -86,8 +87,8 @@ instance (OutputableBndr name, HasOccName name) => Outputable (ImportDecl name)
ppr_imp False = empty
pp_spec Nothing = empty
pp_spec (Just (False, ies)) = ppr_ies ies
pp_spec (Just (True, ies)) = ptext (sLit "hiding") <+> ppr_ies ies
pp_spec (Just (False, (L _ ies))) = ppr_ies ies
pp_spec (Just (True, (L _ ies))) = ptext (sLit "hiding") <+> ppr_ies ies
ppr_ies [] = ptext (sLit "()")
ppr_ies ies = char '(' <+> interpp'SP ies <+> char ')'
......@@ -104,11 +105,12 @@ type LIE name = Located (IE name)
-- | Imported or exported entity.
data IE name
= IEVar name
| IEThingAbs name -- ^ Class/Type (can't tell)
| IEThingAll name -- ^ Class/Type plus all methods/constructors
| IEThingWith name [name] -- ^ Class/Type plus some methods/constructors
| IEModuleContents ModuleName -- ^ (Export Only)
= IEVar (Located name)
| IEThingAbs name -- ^ Class/Type (can't tell)
| IEThingAll (Located name) -- ^ Class/Type plus all methods/constructors
| IEThingWith (Located name) [Located name]
-- ^ Class/Type plus some methods/constructors
| IEModuleContents (Located ModuleName) -- ^ (Export Only)
| IEGroup Int HsDocString -- ^ Doc section heading
| IEDoc HsDocString -- ^ Some documentation
| IEDocNamed String -- ^ Reference to named doc
......@@ -117,21 +119,21 @@ data IE name
\begin{code}
ieName :: IE name -> name
ieName (IEVar n) = n
ieName (IEThingAbs n) = n
ieName (IEThingWith n _) = n
ieName (IEThingAll n) = n
ieName (IEVar (L _ n)) = n
ieName (IEThingAbs n) = n
ieName (IEThingWith (L _ n) _) = n
ieName (IEThingAll (L _ n)) = n
ieName _ = panic "ieName failed pattern match!"
ieNames :: IE a -> [a]
ieNames (IEVar n ) = [n]
ieNames (IEThingAbs n ) = [n]
ieNames (IEThingAll n ) = [n]
ieNames (IEThingWith n ns) = n : ns
ieNames (IEModuleContents _ ) = []
ieNames (IEGroup _ _ ) = []
ieNames (IEDoc _ ) = []
ieNames (IEDocNamed _ ) = []
ieNames (IEVar (L _ n) ) = [n]
ieNames (IEThingAbs n ) = [n]
ieNames (IEThingAll (L _ n) ) = [n]
ieNames (IEThingWith (L _ n) ns) = n : map unLoc ns
ieNames (IEModuleContents _ ) = []
ieNames (IEGroup _ _ ) = []
ieNames (IEDoc _ ) = []
ieNames (IEDocNamed _ ) = []
\end{code}
\begin{code}
......@@ -144,16 +146,15 @@ pprImpExp name = type_pref <+> pprPrefixOcc name
| otherwise = empty
instance (HasOccName name, OutputableBndr name) => Outputable (IE name) where
ppr (IEVar var) = pprPrefixOcc var
ppr (IEVar var) = pprPrefixOcc (unLoc var)
ppr (IEThingAbs thing) = pprImpExp thing
ppr (IEThingAll thing) = hcat [pprImpExp thing, text "(..)"]
ppr (IEThingAll thing) = hcat [pprImpExp (unLoc thing), text "(..)"]
ppr (IEThingWith thing withs)
= pprImpExp thing <> parens (fsep (punctuate comma (map pprImpExp withs)))
= pprImpExp (unLoc thing) <> parens (fsep (punctuate comma
(map pprImpExp $ map unLoc withs)))
ppr (IEModuleContents mod')
= ptext (sLit "module") <+> ppr mod'
ppr (IEGroup n _) = text ("<IEGroup: " ++ (show n) ++ ">")
ppr (IEDoc doc) = ppr doc
ppr (IEDocNamed string) = text ("<IEDocNamed: " ++ string ++ ">")
\end{code}
......@@ -18,7 +18,7 @@ module HsPat (
HsConDetails(..),
HsConPatDetails, hsConPatArgs,
HsRecFields(..), HsRecField(..), hsRecFields,
HsRecFields(..), HsRecField(..), LHsRecField, hsRecFields,
mkPrefixConPat, mkCharLitPat, mkNilPat,
......@@ -187,7 +187,7 @@ type HsConPatDetails id = HsConDetails (LPat id) (HsRecFields id (LPat id))
hsConPatArgs :: HsConPatDetails id -> [LPat id]
hsConPatArgs (PrefixCon ps) = ps
hsConPatArgs (RecCon fs) = map hsRecFieldArg (rec_flds fs)
hsConPatArgs (RecCon fs) = map (hsRecFieldArg . unLoc) (rec_flds fs)
hsConPatArgs (InfixCon p1 p2) = [p1,p2]
\end{code}
......@@ -198,7 +198,7 @@ However HsRecFields is used only for patterns and expressions
data HsRecFields id arg -- A bunch of record fields
-- { x = 3, y = True }
-- Used for both expressions and patterns
= HsRecFields { rec_flds :: [HsRecField id arg],
= HsRecFields { rec_flds :: [LHsRecField id arg],
rec_dotdot :: Maybe Int } -- Note [DotDot fields]
deriving (Data, Typeable)
......@@ -216,6 +216,7 @@ data HsRecFields id arg -- A bunch of record fields
-- the first 'n' being the user-written ones
-- and the remainder being 'filled in' implicitly
type LHsRecField id arg = Located (HsRecField id arg)
data HsRecField id arg = HsRecField {
hsRecFieldId :: Located id,
hsRecFieldArg :: arg, -- Filled in by renamer
......@@ -235,7 +236,7 @@ data HsRecField id arg = HsRecField {
-- T { A.x } means T { A.x = x }
hsRecFields :: HsRecFields id arg -> [id]
hsRecFields rbinds = map (unLoc . hsRecFieldId) (rec_flds rbinds)
hsRecFields rbinds = map (unLoc . hsRecFieldId . unLoc) (rec_flds rbinds)
\end{code}
%************************************************************************
......
......@@ -63,7 +63,7 @@ data HsModule name
hsmodName :: Maybe (Located ModuleName),
-- ^ @Nothing@: \"module X where\" is omitted (in which case the next
-- field is Nothing too)
hsmodExports :: Maybe [LIE name],
hsmodExports :: Maybe (Located [LIE name]),
-- ^ Export list
--
-- - @Nothing@: export list omitted, so export everything
......@@ -78,7 +78,7 @@ data HsModule name
-- downstream.
hsmodDecls :: [LHsDecl name],
-- ^ Type, class, value, and interface signature decls
hsmodDeprecMessage :: Maybe WarningTxt,
hsmodDeprecMessage :: Maybe (Located WarningTxt),
-- ^ reason\/explanation for warning/deprecation of this module
hsmodHaddockModHeader :: Maybe LHsDocString
-- ^ Haddock module info and description, unparsed
......@@ -92,7 +92,8 @@ instance (OutputableBndr name, HasOccName name)
=> Outputable (HsModule name) where
ppr (HsModule Nothing _ imports decls _ mbDoc)
= pp_mb mbDoc $$ pp_nonnull imports $$ pp_nonnull decls
= pp_mb mbDoc $$ pp_nonnull imports
$$ pp_nonnull decls
ppr (HsModule (Just name) exports imports decls deprec mbDoc)
= vcat [
......@@ -101,7 +102,7 @@ instance (OutputableBndr name, HasOccName name)
Nothing -> pp_header (ptext (sLit "where"))
Just es -> vcat [
pp_header lparen,
nest 8 (fsep (punctuate comma (map ppr es))),
nest 8 (fsep (punctuate comma (map ppr (unLoc es)))),
nest 4 (ptext (sLit ") where"))
],
pp_nonnull imports,
......
......@@ -30,7 +30,7 @@ module HsTypes (
LBangType, BangType, HsBang(..),
getBangType, getBangStrictness,
ConDeclField(..), pprConDeclFields,
ConDeclField(..), LConDeclField, pprConDeclFields,
mkHsQTvs, hsQTvBndrs, isHsKindedTyVar, hsTvbAllKinded,
mkExplicitHsForAllTy, mkImplicitHsForAllTy, mkQualifiedHsForAllTy,
......@@ -258,18 +258,18 @@ data HsType name
| HsDocTy (LHsType name) LHsDocString -- A documented type
| HsBangTy HsBang (LHsType name) -- Bang-style type annotations
| HsRecTy [ConDeclField name] -- Only in data type declarations
| HsRecTy [LConDeclField name] -- Only in data type declarations
| HsCoreTy Type -- An escape hatch for tunnelling a *closed*
-- Core Type through HsSyn.
| HsExplicitListTy -- A promoted explicit list
(PostTc name Kind) -- See Note [Promoted lists and tuples]
[LHsType name]
[LHsType name]
| HsExplicitTupleTy -- A promoted explicit tuple
[PostTc name Kind] -- See Note [Promoted lists and tuples]
[LHsType name]
[LHsType name]
| HsTyLit HsTyLit -- A promoted numeric literal.
......@@ -398,10 +398,11 @@ data HsTupleSort = HsUnboxedTuple
data HsExplicitFlag = Qualified | Implicit | Explicit deriving (Data, Typeable)
type LConDeclField name = Located (ConDeclField name)
data ConDeclField name -- Record fields have Haddoc docs on them
= ConDeclField { cd_fld_name :: Located name,
cd_fld_type :: LBangType name,
cd_fld_doc :: Maybe LHsDocString }
= ConDeclField { cd_fld_names :: [Located name],
cd_fld_type :: LBangType name,
cd_fld_doc :: Maybe LHsDocString }
deriving (Typeable)
deriving instance (DataId name) => Data (ConDeclField name)
......@@ -616,12 +617,14 @@ pprHsContextMaybe [] = Nothing
pprHsContextMaybe [L _ pred] = Just $ ppr_mono_ty FunPrec pred
pprHsContextMaybe cxt = Just $ parens (interpp'SP cxt)
pprConDeclFields :: OutputableBndr name => [ConDeclField name] -> SDoc
pprConDeclFields :: OutputableBndr name => [LConDeclField name] -> SDoc
pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields)))
where
ppr_fld (ConDeclField { cd_fld_name = n, cd_fld_type = ty,
cd_fld_doc = doc })
= ppr n <+> dcolon <+> ppr ty <+> ppr_mbDoc doc
ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty,
cd_fld_doc = doc }))
= ppr_names ns <+> dcolon <+> ppr ty <+> ppr_mbDoc doc
ppr_names [n] = ppr n
ppr_names ns = sep (punctuate comma (map ppr ns))
\end{code}
Note [Printing KindedTyVars]
......
......@@ -416,7 +416,7 @@ types on the tuple.
mkLHsTupleExpr :: [LHsExpr a] -> LHsExpr a
-- Makes a pre-typechecker boxed tuple, deals with 1 case
mkLHsTupleExpr [e] = e
mkLHsTupleExpr es = noLoc $ ExplicitTuple (map Present es) Boxed
mkLHsTupleExpr es = noLoc $ ExplicitTuple (map (noLoc . Present) es) Boxed
mkLHsVarTuple :: [a] -> LHsExpr a
mkLHsVarTuple ids = mkLHsTupleExpr (map nlHsVar ids)
......@@ -792,7 +792,8 @@ hsDataFamInstBinders (DataFamInstDecl { dfid_defn = defn })
-------------------
-- the SrcLoc returned are for the whole declarations, not just the names
hsDataDefnBinders :: Eq name => HsDataDefn name -> [Located name]
hsDataDefnBinders (HsDataDefn { dd_cons = cons }) = hsConDeclsBinders cons
hsDataDefnBinders (HsDataDefn { dd_cons = cons })
= hsConDeclsBinders cons
-- See Note [Binders in family instances]
-------------------
......@@ -809,12 +810,12 @@ hsConDeclsBinders cons = go id cons
case r of
-- remove only the first occurrence of any seen field in order to
-- avoid circumventing detection of duplicate fields (#9156)
L loc (ConDecl { con_name = L _ name , con_details = RecCon flds }) ->
(L loc name) : r' ++ go remSeen' rs
where r' = remSeen (map cd_fld_name flds)
L loc (ConDecl { con_names = names, con_details = RecCon flds }) ->
(map (L loc . unLoc) names) ++ r' ++ go remSeen' rs
where r' = remSeen (concatMap (cd_fld_names . unLoc) flds)
remSeen' = foldr (.) remSeen [deleteBy ((==) `on` unLoc) v | v <- r']
L loc (ConDecl { con_name = L _ name }) ->
(L loc name) : go remSeen rs
L loc (ConDecl { con_names = names }) ->
(map (L loc . unLoc) names) ++ go remSeen rs
\end{code}
......@@ -898,7 +899,8 @@ lPatImplicits = hs_lpat
details (RecCon fs) = hs_lpats explicit `unionNameSets` mkNameSet (collectPatsBinders implicit)
where (explicit, implicit) = partitionEithers [if pat_explicit then Left pat else Right pat
| (i, fld) <- [0..] `zip` rec_flds fs
, let pat = hsRecFieldArg fld
, let pat = hsRecFieldArg
(unLoc fld)
pat_explicit = maybe True (i<) (rec_dotdot fs)]
details (InfixCon p1 p2) = hs_lpat p1 `unionNameSets` hs_lpat p2
\end{code}
......@@ -81,7 +81,8 @@ getImports dflags buf filename source_filename = do
ord_idecls
implicit_prelude = xopt Opt_ImplicitPrelude dflags
implicit_imports = mkPrelImports (unLoc mod) main_loc implicit_prelude imps
implicit_imports = mkPrelImports (unLoc mod) main_loc
implicit_prelude imps
in
return (src_idecls, implicit_imports ++ ordinary_imps, mod)
......
......@@ -813,7 +813,7 @@ hscCheckSafeImports tcg_env = do
warns dflags rules = listToBag $ map (warnRules dflags) rules