[Git][ghc/ghc][wip/jade/ast] Wrangled until everything compiled.
Hassan Al-Awwadi (@hassan.awwadi)
gitlab at gitlab.haskell.org
Fri Sep 20 10:34:05 UTC 2024
Hassan Al-Awwadi pushed to branch wip/jade/ast at Glasgow Haskell Compiler / GHC
Commits:
45ea0e59 by Hassan Al-Awwadi at 2024-09-20T12:33:28+02:00
Wrangled until everything compiled.
There are two issues:
- FieldOcc used to only have one constructor and always be unambigious, this is no longer the case. Calls to foLabel are thus partial now. Don't know how much we care about this, since the partial calls are mostly inside functions that used to operate on the operate on the unambigious FieldOcc
- Lots of functions that take in a FieldOcc, or a HsExpr (with the HsRecSel constructor) now have a new case. It was not always clear to me what the correct implementation was for these. I have filled them in as far as I could and left one undefined...
- - - - -
19 changed files:
- compiler/GHC/Hs/Syn/Type.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs
- utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
- utils/haddock/haddock-api/src/Haddock/Convert.hs
- utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
- utils/haddock/haddock-api/src/Haddock/Types.hs
Changes:
=====================================
compiler/GHC/Hs/Syn/Type.hs
=====================================
@@ -104,7 +104,7 @@ hsExprType :: HsExpr GhcTc -> Type
hsExprType (HsVar _ (L _ id)) = idType id
hsExprType (HsUnboundVar (HER _ ty _) _) = ty
hsExprType (HsRecSel _ (FieldOcc _ id)) = idType (unLoc id)
-hsExprType (HsOverLabel v _ _) = dataConCantHappen v
+hsExprType (HsOverLabel v _) = dataConCantHappen v
hsExprType (HsIPVar v _) = dataConCantHappen v
hsExprType (HsOverLit _ lit) = overLitType lit
hsExprType (HsLit _ lit) = hsLitType lit
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -273,7 +273,7 @@ application. For example:
See the `HsApp` case for where it is filtered out
-}
-dsExpr (HsRecSel _ (FieldOcc id _))
+dsExpr (HsRecSel _ (FieldOcc _ (L _ id)))
= do { let name = getName id
RecSelId {sel_cons = (_, cons_wo_field)}
= idDetails id
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -284,7 +284,7 @@ repTopDs group@(HsGroup { hs_valds = valds
, hs_docs = docs })
= do { let { bndrs = hsScopedTvBinders valds
++ hsGroupBinders group
- ++ map foExt (hsPatSynSelectors valds)
+ ++ map (unLoc . foLabel) (hsPatSynSelectors valds)
; instds = tyclds >>= group_instds } ;
ss <- mkGenSyms bndrs ;
@@ -1538,7 +1538,8 @@ repE (HsVar _ (L _ x)) =
repE (HsIPVar _ n) = rep_implicit_param_name n >>= repImplicitParamVar
repE (HsOverLabel _ s) = repOverLabel s
-repE (HsRecSel _ (FieldOcc x _)) = repE (HsVar noExtField (noLocA x))
+repE (HsRecSel _ (FieldOcc _ (L _ x))) = repE (HsVar noExtField (noLocA x))
+repE r@(HsRecSel _ (XFieldOcc _)) = notHandled (ThAmbiguousRecordSelectors r)
-- Remember, we're desugaring renamer output here, so
-- HsOverlit can definitely occur
@@ -1816,10 +1817,11 @@ repUpdFields = repListM fieldExpTyConName rep_fld
where
rep_fld :: LHsRecUpdField GhcRn GhcRn -> MetaM (Core (M TH.FieldExp))
rep_fld (L l fld) = case unLoc (hfbLHS fld) of
- Unambiguous sel_name _ -> do { fn <- lookupLOcc (L l sel_name)
- ; e <- repLE (hfbRHS fld)
- ; repFieldExp fn e }
- Ambiguous{} -> notHandled (ThAmbiguousRecordUpdates fld)
+ FieldOcc _ (L _ sel_name) -> do { fn <- lookupLOcc (L l sel_name)
+ ; e <- repLE (hfbRHS fld)
+ ; repFieldExp fn e
+ }
+ (XFieldOcc _) -> notHandled (ThAmbiguousRecordUpdates fld)
@@ -2022,7 +2024,7 @@ rep_bind (L loc (PatSynBind _ (PSB { psb_id = syn
mkGenArgSyms (InfixCon arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2]
mkGenArgSyms (RecCon fields)
= do { let pats = map (unLoc . recordPatSynPatVar) fields
- sels = map (foExt . recordPatSynField) fields
+ sels = map (unLoc . foLabel . recordPatSynField) fields
; ss <- mkGenSyms sels
; return $ replaceNames (zip sels pats) ss }
@@ -2054,7 +2056,7 @@ repPatSynArgs (InfixCon arg1 arg2)
; arg2' <- lookupLOcc arg2
; repInfixPatSynArgs arg1' arg2' }
repPatSynArgs (RecCon fields)
- = do { sels' <- repList nameTyConName (lookupOcc . foExt) sels
+ = do { sels' <- repList nameTyConName (lookupOcc . unLoc . foLabel) sels
; repRecordPatSynArgs sels' }
where sels = map recordPatSynField fields
@@ -2877,7 +2879,7 @@ repRecConArgs ips = do
rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)
rep_one_ip :: LBangType GhcRn -> LFieldOcc GhcRn -> MetaM (Core (M TH.VarBangType))
- rep_one_ip t n = do { MkC v <- lookupOcc (foExt $ unLoc n)
+ rep_one_ip t n = do { MkC v <- lookupOcc (unLoc . foLabel $ unLoc n)
; MkC ty <- repBangTy t
; rep2 varBangTypeName [v,ty] }
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -1483,8 +1483,7 @@ instance HiePass p => ToHie (RFContext (LocatedA (FieldOcc (GhcPass p)))) where
case f of
FieldOcc _ fld ->
[toHie $ C (RecField c rhs) (L (locA nspan) $ unLoc fld)]
- XFieldOcc (Ambiguous (L nspan fld))
- -> [ toHie $ C (RecField c rhs) (L (locA nspan) fld) ]
+ XFieldOcc (Ambiguous _) -> []
HieTc ->
case f of
FieldOcc _ fld ->
@@ -2075,9 +2074,8 @@ instance ToHie (LocatedA (TyFamInstDecl GhcRn)) where
toHie (L sp (TyFamInstDecl _ d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d
instance HiePass p => ToHie (Context (FieldOcc (GhcPass p))) where
- toHie (C c (FieldOcc n (L l _))) = case hiePass @p of
- HieTc -> toHie (C c (L l n))
- HieRn -> toHie (C c (L l n))
+ toHie (C c (FieldOcc _ l)) = toHie (C c l)
+ toHie (C _ (XFieldOcc _)) = concatM []
instance HiePass p => ToHie (PatSynFieldContext (RecordPatSynField (GhcPass p))) where
toHie (PSC sp (RecordPatSynField a b)) = concatM $
=====================================
compiler/GHC/Rename/Bind.hs
=====================================
@@ -824,7 +824,9 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name
, psb_ext = fvs' }
selector_names = case details' of
RecCon names ->
- map (foExt . recordPatSynField) names
+ -- I don't actually know if its fine or not
+ -- that foLabel is partial.
+ map (unLoc . foLabel . recordPatSynField) names
_ -> []
; fvs' `seq` -- See Note [Free-variable space leak]
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -339,7 +339,7 @@ rnExpr (HsVar _ (L l v))
; this_mod <- getModule
; when (nameIsLocalOrFrom this_mod sel_name) $
checkThLocalName sel_name
- ; return (HsRecSel noExtField (FieldOcc sel_name (L l v) ), unitFV sel_name)
+ ; return (HsRecSel noExtField (FieldOcc v (L l sel_name)), unitFV sel_name)
}
| nm == nilDataConName
-- Treat [] as an ExplicitList, so that
@@ -417,7 +417,7 @@ rnExpr (OpApp _ e1 op e2)
-- should prevent bad things happening.
; fixity <- case op' of
L _ (HsVar _ (L _ n)) -> lookupFixityRn n
- L _ (HsRecSel _ f) -> lookupFieldFixityRn f
+ L _ (HsRecSel _ f) -> fromJust <$> lookupFieldFixityRn f
_ -> return (Fixity minPrecedence InfixL)
-- c.f. lookupFixity for unbound
=====================================
compiler/GHC/Rename/Pat.hs
=====================================
@@ -10,6 +10,8 @@
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+{-# HLINT ignore "Use camelCase" #-}
{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
@@ -257,6 +259,42 @@ newPatName (LetMk is_top fix_env) rdr_name
NotTopLevel -> newLocalBndrRn rdr_name
TopLevel -> newTopSrcBinder rdr_name
; bindLocalNames [name] $
+ -- Do *not* use bindLocalNameFV here;
+ -- Do *not* use bindLocalNameFV here;
+ -- Do *not* use bindLocalNameFV here;
+ -- Do *not* use bindLocalNameFV here;
+ -- see Note [View pattern usage]
+ -- see Note [View pattern usage]
+ -- see Note [View pattern usage]
+ -- see Note [View pattern usage]
+ -- For the TopLevel case
+ -- For the TopLevel case
+ -- For the TopLevel case
+ -- For the TopLevel case
+ -- see Note [bindLocalNames for an External name]
+ -- see Note [bindLocalNames for an External name]
+ -- see Note [bindLocalNames for an External name]
+ -- see Note [bindLocalNames for an External name]
+
+ -- Do *not* use bindLocalNameFV here;
+
+ -- Do *not* use bindLocalNameFV here;
+ -- see Note [View pattern usage]
+ -- see Note [View pattern usage]
+ -- For the TopLevel case
+ -- For the TopLevel case
+ -- see Note [bindLocalNames for an External name]
+ -- see Note [bindLocalNames for an External nam
+
+ -- Do *not* use bindLocalNameFV here;
+ -- Do *not* use bindLocalNameFV here;
+ -- see Note [View pattern usage]
+ -- see Note [View pattern usage]
+ -- For the TopLevel case
+ -- For the TopLevel case
+ -- see Note [bindLocalNames for an External name]
+ -- see Note [bindLocalNames for an External name]
+
-- Do *not* use bindLocalNameFV here;
-- see Note [View pattern usage]
-- For the TopLevel case
@@ -877,7 +915,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
; return $ L l $
HsFieldBind
{ hfbAnn = noAnn
- , hfbLHS = L loc (FieldOcc sel (L ll arg_rdr))
+ , hfbLHS = L loc (FieldOcc arg_rdr (L ll sel))
, hfbRHS = arg'
, hfbPun = pun } }
@@ -897,7 +935,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
; (rdr_env, lcl_env) <- getRdrEnvs
; conInfo <- lookupConstructorInfo con
; when (conFieldInfo conInfo == ConHasPositionalArgs) (addErr (TcRnIllegalWildcardsInConstructor con))
- ; let present_flds = mkOccSet $ map rdrNameOcc (getFieldLbls flds)
+ ; let present_flds = mkOccSet $ map nameOccName (getFieldLbls flds)
-- For constructor uses (but not patterns)
-- the arg should be in scope locally;
@@ -923,7 +961,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
; return [ L (noAnnSrcSpan loc) (HsFieldBind
{ hfbAnn = noAnn
, hfbLHS
- = L (noAnnSrcSpan loc) (FieldOcc sel (L (noAnnSrcSpan loc) arg_rdr))
+ = L (noAnnSrcSpan loc) (FieldOcc arg_rdr (L (noAnnSrcSpan loc) sel))
, hfbRHS = L locn (mk_arg loc arg_rdr)
, hfbPun = False })
| fl <- dot_dot_fields
@@ -1013,10 +1051,10 @@ rnHsRecUpdFields flds
-> RnM ([LHsRecUpdField GhcRn GhcRn], FreeVars)
rn_flds _ _ [] = return ([], emptyFVs)
rn_flds pun_ok mb_unambig_lbls
- ((L l (HsFieldBind { hfbLHS = L loc f
+ ((L l (HsFieldBind { hfbLHS = L loc (FieldOcc _ f)
, hfbRHS = arg
, hfbPun = pun })):flds)
- = do { let lbl = ambiguousFieldOccRdrName f
+ = do { let lbl = unLoc f
; (arg' :: LHsExpr GhcPs) <- if pun
then do { setSrcSpanA loc $
checkErr pun_ok (TcRnIllegalFieldPunning (L (locA loc) lbl))
@@ -1025,12 +1063,12 @@ rnHsRecUpdFields flds
; return (L (l2l loc) (HsVar noExtField (L (l2l loc) arg_rdr))) }
else return arg
; (arg'', fvs) <- rnLExpr arg'
- ; let lbl' :: AmbiguousFieldOcc GhcRn
+ ; let lbl' :: FieldOcc GhcRn
lbl' = case mb_unambig_lbls of
{ Just (fl:_) ->
let sel_name = flSelector fl
- in Unambiguous sel_name (L (l2l loc) lbl)
- ; _ -> Ambiguous noExtField (L (l2l loc) lbl) }
+ in FieldOcc lbl (L (l2l loc) sel_name)
+ ; _ -> XFieldOcc (Ambiguous (L (l2l loc) lbl)) }
fld' :: LHsRecUpdField GhcRn GhcRn
fld' = L l (HsFieldBind { hfbAnn = noAnn
, hfbLHS = L loc lbl'
@@ -1042,9 +1080,10 @@ rnHsRecUpdFields flds
getFieldIds :: [LHsRecField GhcRn arg] -> [Name]
getFieldIds flds = map (hsRecFieldSel . unLoc) flds
-getFieldLbls :: forall p arg . UnXRec p => [LHsRecField p arg] -> [RdrName]
-getFieldLbls flds
- = map (unXRec @p . foLabel . unXRec @p . hfbLHS . unXRec @p) flds
+-- The call to foLabel might be partial now. Don't know enough about
+-- the rest of the function chain to say if this is an issue.
+getFieldLbls :: forall p arg . UnXRec p => [LHsRecField p arg] -> [IdP p]
+getFieldLbls = map (unXRec @p . foLabel . unXRec @p . hfbLHS . unXRec @p)
needFlagDotDot :: HsRecFieldContext -> TcRnMessage
needFlagDotDot = TcRnIllegalWildcardsInRecord . toRecordFieldPart
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -1301,7 +1301,7 @@ expandRecordUpd record_expr possible_parents rbnds res_ty
; (cons, rbinds)
<- disambiguateRecordBinds record_expr record_rho possible_parents rbnds res_ty
; let upd_flds = map (unLoc . hfbLHS . unLoc) rbinds
- sel_ids = map selectorAmbiguousFieldOcc upd_flds
+ sel_ids = map (unLoc . foLabel) upd_flds
upd_fld_names = map idName sel_ids
relevant_cons = nonDetEltsUniqSet cons
relevant_con = head relevant_cons
@@ -1584,7 +1584,7 @@ disambiguateRecordBinds record_expr record_rho possible_parents rbnds res_ty
-> TcM (LHsRecUpdField GhcTc GhcRn)
lookupField fld_gre (L l upd)
= do { let L loc af = hfbLHS upd
- lbl = ambiguousFieldOccRdrName af
+ lbl = fieldOccRdrName af
mb_gre = pickGREs lbl [fld_gre]
-- NB: this GRE can be 'Nothing' when in GHCi.
-- See test T10439.
@@ -1596,7 +1596,7 @@ disambiguateRecordBinds record_expr record_rho possible_parents rbnds res_ty
; sel <- tcLookupId (greName fld_gre)
; return $ L l HsFieldBind
{ hfbAnn = hfbAnn upd
- , hfbLHS = L (l2l loc) $ Unambiguous sel (L (l2l loc) lbl)
+ , hfbLHS = L (l2l loc) $ FieldOcc lbl (L (l2l loc) sel)
, hfbRHS = hfbRHS upd
, hfbPun = hfbPun upd
} }
@@ -1669,11 +1669,11 @@ fieldCtxt field_name
tcRecordField :: ConLike -> Assoc Name Type
-> LFieldOcc GhcRn -> LHsExpr GhcRn
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
-tcRecordField con_like flds_w_tys (L loc (FieldOcc sel_name lbl)) rhs
+tcRecordField con_like flds_w_tys (L loc (FieldOcc rdr (L l sel_name))) rhs
| Just field_ty <- assocMaybe flds_w_tys sel_name
= addErrCtxt (fieldCtxt field_lbl) $
do { rhs' <- tcCheckPolyExprNC rhs field_ty
- ; hasFixedRuntimeRep_syntactic (FRRRecordCon (unLoc lbl) (unLoc rhs'))
+ ; hasFixedRuntimeRep_syntactic (FRRRecordCon rdr (unLoc rhs'))
field_ty
; let field_id = mkUserLocal (nameOccName sel_name)
(nameUnique sel_name)
@@ -1682,12 +1682,13 @@ tcRecordField con_like flds_w_tys (L loc (FieldOcc sel_name lbl)) rhs
-- (so we can find it easily)
-- but is a LocalId with the appropriate type of the RHS
-- (so the expansion knows the type of local binder to make)
- ; return (Just (L loc (FieldOcc field_id lbl), rhs')) }
+ ; return (Just (L loc (FieldOcc rdr (L l field_id)), rhs')) }
| otherwise
= do { addErrTc (badFieldConErr (getName con_like) field_lbl)
; return Nothing }
where
- field_lbl = FieldLabelString $ occNameFS $ rdrNameOcc (unLoc lbl)
+ field_lbl = FieldLabelString $ occNameFS $ rdrNameOcc rdr
+tcRecordField _ _ (L _ (XFieldOcc (Ambiguous _))) _ = pure Nothing
checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> [Scaled TcType] -> TcM ()
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -567,7 +567,7 @@ tcInferAppHead_maybe :: HsExpr GhcRn
tcInferAppHead_maybe fun
= case fun of
HsVar _ (L _ nm) -> Just <$> tcInferId nm
- HsRecSel _ f -> Just <$> tcInferRecSelId f
+ HsRecSel _ f -> tcInferRecSelId f
ExprWithTySig _ e hs_ty -> Just <$> tcExprWithSig e hs_ty
HsOverLit _ lit -> Just <$> tcInferOverLit lit
_ -> return Nothing
@@ -596,21 +596,20 @@ addHeadCtxt fun_ctxt thing_inside
********************************************************************* -}
tcInferRecSelId :: FieldOcc GhcRn
- -> TcM (HsExpr GhcTc, TcSigmaType)
-tcInferRecSelId (FieldOcc sel_name lbl)
- = do { sel_id <- tc_rec_sel_id
- ; let expr = HsRecSel noExtField (FieldOcc sel_id lbl)
- ; return (expr, idType sel_id)
+ -> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
+tcInferRecSelId (FieldOcc sel_name (L l n))
+ = do { sel_id <- tc_rec_sel_id
+ ; let expr = HsRecSel noExtField (FieldOcc sel_name (L l sel_id))
+ ; return $ Just(expr, idType sel_id)
}
where
occ :: OccName
- occ = rdrNameOcc (unLoc lbl)
-
+ occ = nameOccName n
tc_rec_sel_id :: TcM TcId
-- Like tc_infer_id, but returns an Id not a HsExpr,
-- so we can wrap it back up into a HsRecSel
tc_rec_sel_id
- = do { thing <- tcLookup sel_name
+ = do { thing <- tcLookup n
; case thing of
ATcId { tct_id = id }
-> do { check_naughty occ id -- See Note [Local record selectors]
@@ -625,6 +624,7 @@ tcInferRecSelId (FieldOcc sel_name lbl)
-- hence no checkTh stuff here
_ -> failWithTc $ TcRnExpectedValueId thing }
+tcInferRecSelId (XFieldOcc _) = pure Nothing
------------------------
=====================================
compiler/GHC/Tc/Gen/Pat.hs
=====================================
@@ -1645,15 +1645,23 @@ tcConValArgs con_like arg_tys penv con_args thing_inside = case con_args of
where
tc_field :: Checker (LHsRecField GhcRn (LPat GhcRn))
(LHsRecField GhcTc (LPat GhcTc))
- tc_field penv
- (L l (HsFieldBind ann (L loc (FieldOcc sel (L lr rdr))) pat pun))
- thing_inside
+ tc_field penv
+ (L l (HsFieldBind ann (L loc (FieldOcc rdr (L lr sel))) pat pun))
+ thing_inside
= do { sel' <- tcLookupId sel
; pat_ty <- setSrcSpanA loc $ find_field_ty sel
(occNameFS $ rdrNameOcc rdr)
; (pat', res) <- tcConArg penv (pat, pat_ty) thing_inside
- ; return (L l (HsFieldBind ann (L loc (FieldOcc sel' (L lr rdr))) pat'
+ ; return (L l (HsFieldBind ann (L loc (FieldOcc rdr (L lr sel'))) pat'
pun), res) }
+ tc_field _
+ (L _ (HsFieldBind _ (L _ (XFieldOcc (Ambiguous (L _ _)))) _ _))
+ _
+ -- I don't like leaving things undefined, and I don't like leaving
+ -- leaving pattern not matched. I think I should just throw in this
+ -- case, but I don't know exactly how to do that.
+ = undefined
+
-- See Note [Omitted record fields and linearity]
check_omitted_fields_multiplicity :: TcM MultiplicityCheckCoercions
check_omitted_fields_multiplicity = do
@@ -1682,7 +1690,7 @@ tcConValArgs con_like arg_tys penv con_args thing_inside = case con_args of
(bound_field_tys, omitted_field_tys) = partition is_bound all_field_tys
is_bound :: (Maybe FieldLabel, Scaled TcType) -> Bool
- is_bound (Just fl, _) = elem (flSelector fl) (map (\(L _ (HsFieldBind _ (L _ (FieldOcc sel _ )) _ _)) -> sel) rpats)
+ is_bound (Just fl, _) = elem (flSelector fl) (map (\(L _ (HsFieldBind _ (L _ (FieldOcc _ sel )) _ _)) -> unLoc sel) rpats)
is_bound _ = False
all_field_tys :: [(Maybe FieldLabel, Scaled TcType)]
=====================================
compiler/GHC/Tc/TyCl/Utils.hs
=====================================
@@ -946,8 +946,7 @@ mkOneRecordSelector all_cons idDetails fl has_sel
rec_field = noLocA (HsFieldBind
{ hfbAnn = noAnn
, hfbLHS
- = L locc (FieldOcc sel_name
- (L locn $ mkRdrUnqual (nameOccName sel_name)))
+ = L locc (FieldOcc (mkRdrUnqual $ nameOccName sel_name) (L locn sel_name))
, hfbRHS
= L loc' (VarPat noExtField (L locn field_var))
, hfbPun = False })
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs
=====================================
@@ -300,7 +300,7 @@ ppCtor sDocContext dat subdocs con at ConDeclH98{con_args = con_args'} =
f (RecCon (L _ recs)) =
f (PrefixCon [] $ map (hsLinear . cd_fld_type . unLoc) recs)
++ concat
- [ (concatMap (lookupCon sDocContext subdocs . noLocA . foExt . unLoc) (cd_fld_names r))
+ [ (concatMap (lookupCon sDocContext subdocs . noLocA . unLoc . foLabel . unLoc) (cd_fld_names r))
++ [out sDocContext (map (foExt . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]
| r <- map unLoc recs
]
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
=====================================
@@ -1027,7 +1027,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocNameI -> LaTeX
ppSideBySideField subdocs unicode (ConDeclField _ names ltype _) =
decltt
- ( cat (punctuate comma (map (ppBinder . rdrNameOcc . unLoc . foLabel . unLoc) names))
+ ( cat (punctuate comma (map (ppBinder . rdrNameOcc . foExt . unLoc) names))
<+> dcolon unicode
<+> ppLType unicode ltype
)
@@ -1035,7 +1035,7 @@ ppSideBySideField subdocs unicode (ConDeclField _ names ltype _) =
where
-- don't use cd_fld_doc for same reason we don't use con_doc above
-- Where there is more than one name, they all have the same documentation
- mbDoc = lookup (foExt $ unLoc name) subdocs >>= fmap _doc . combineDocumentation . fst
+ mbDoc = lookup (unLoc . foLabel . unLoc $ name) subdocs >>= fmap _doc . combineDocumentation . fst
name =
case Maybe.listToMaybe names of
Nothing -> error "No names. An invariant was broken. Please report this to the Haddock project"
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
=====================================
@@ -1536,7 +1536,7 @@ ppSideBySideField subdocs unicode qual (ConDeclField _ names ltype _) =
comma
[ ppBinder False (rdrNameOcc field)
| L _ name <- names
- , let field = (unLoc . foLabel) name
+ , let field = (foExt) name
]
)
<+> dcolon unicode
@@ -1547,14 +1547,14 @@ ppSideBySideField subdocs unicode qual (ConDeclField _ names ltype _) =
where
-- don't use cd_fld_doc for same reason we don't use con_doc above
-- Where there is more than one name, they all have the same documentation
- mbDoc = lookup (foExt $ unLoc declName) subdocs >>= combineDocumentation . fst
+ mbDoc = lookup (unLoc . foLabel $ unLoc declName) subdocs >>= combineDocumentation . fst
declName = case Maybe.listToMaybe names of
Nothing -> error "No names. An invariant was broken. Please report this to the Haddock project"
Just hd -> hd
ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocNameI -> Html
ppShortField summary unicode qual (ConDeclField _ names ltype _) =
- hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . unLoc . foLabel . unLoc) names))
+ hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . foExt . unLoc) names))
<+> dcolon unicode
<+> ppLType unicode qual HideEmptyContexts ltype
=====================================
utils/haddock/haddock-api/src/Haddock/Convert.hs
=====================================
@@ -496,7 +496,7 @@ synifyDataCon use_gadt_syntax dc =
noLocA $
ConDeclField
noAnn
- [noLocA $ FieldOcc (flSelector fl) (noLocA $ mkVarUnqual $ field_label $ flLabel fl)]
+ [noLocA $ FieldOcc (mkVarUnqual $ field_label $ flLabel fl) (noLocA (flSelector fl))]
synTy
Nothing
=====================================
utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
=====================================
@@ -374,7 +374,7 @@ restrictCons names decls = [L p d | L p (Just d) <- fmap keep <$> decls]
field_avail :: LConDeclField GhcRn -> Bool
field_avail (L _ (ConDeclField _ fs _ _)) =
- all (\f -> foExt (unLoc f) `elem` names) fs
+ all (\f -> (unLoc . foLabel . unLoc $ f) `elem` names) fs
field_types flds = [hsUnrestricted t | L _ (ConDeclField _ _ t _) <- flds]
keep _ = Nothing
@@ -563,7 +563,7 @@ instance Parent (ConDecl GhcRn) where
children con =
case getRecConArgs_maybe con of
Nothing -> []
- Just flds -> map (foExt . unLoc) $ concatMap (cd_fld_names . unLoc) (unLoc flds)
+ Just flds -> map (unLoc . foLabel . unLoc) $ concatMap (cd_fld_names . unLoc) (unLoc flds)
instance Parent (TyClDecl GhcRn) where
children d
=====================================
utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
=====================================
@@ -927,7 +927,7 @@ extractDecl prr dflags sDocContext name decl
Just rec <- toList $ getRecConArgs_maybe . unLoc <$> dd_cons (feqn_rhs d)
, ConDeclField{cd_fld_names = ns} <- map unLoc (unLoc rec)
, L _ n <- ns
- , foExt n == name
+ , unLoc (foLabel n) == name
]
in case matches of
[d0] -> extractDecl prr dflags sDocContext name (noLocA . InstD noExtField $ DataFamInstD noExtField d0)
@@ -996,7 +996,7 @@ extractRecSel nm t tvs (L _ con : rest) =
where
matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)]
matching_fields flds =
- [ (locA l, f) | f@(L _ (ConDeclField _ ns _ _)) <- flds, L l n <- ns, foExt n == nm
+ [ (locA l, f) | f@(L _ (ConDeclField _ ns _ _)) <- flds, L l n <- ns, unLoc (foLabel n) == nm
]
data_ty
-- ResTyGADT _ ty <- con_res con = ty
=====================================
utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
=====================================
@@ -745,9 +745,9 @@ renameConDeclFieldField (L l (ConDeclField _ names t doc)) = do
return $ L (locA l) (ConDeclField noExtField names' t' doc')
renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI)
-renameLFieldOcc (L l (FieldOcc sel lbl)) = do
+renameLFieldOcc (L l (FieldOcc rdr (L n sel))) = do
sel' <- renameName sel
- return $ L l (FieldOcc sel' lbl)
+ return $ L l (FieldOcc rdr (L n sel'))
renameSig :: Sig GhcRn -> RnM (Sig DocNameI)
renameSig sig = case sig of
=====================================
utils/haddock/haddock-api/src/Haddock/Types.hs
=====================================
@@ -885,8 +885,8 @@ type instance XUserTyVar DocNameI = NoExtField
type instance XKindedTyVar DocNameI = NoExtField
type instance XXTyVarBndr DocNameI = DataConCantHappen
-type instance XCFieldOcc DocNameI = DocName
-type instance XXFieldOcc DocNameI = NoExtField
+type instance XCFieldOcc DocNameI = RdrName
+type instance XXFieldOcc DocNameI = DataConCantHappen
type instance XFixitySig DocNameI = NoExtField
type instance XFixSig DocNameI = NoExtField
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/45ea0e5939e14ecbf978375816de20b10142f092
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/45ea0e5939e14ecbf978375816de20b10142f092
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240920/9636e1bb/attachment-0001.html>
More information about the ghc-commits
mailing list