aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs6
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs6
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs6
-rw-r--r--haddock-api/src/Haddock/Convert.hs8
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs6
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs6
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs11
-rw-r--r--haddock-api/src/Haddock/Interface/Specialize.hs4
8 files changed, 27 insertions, 26 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 38d378e2..dfb167a3 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -251,7 +251,7 @@ ppCtor dflags dat subdocs con@ConDeclH98 { con_args = con_args' }
[out dflags (map (foExt . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]
| r <- map unLoc recs]
- funs = foldr1 (\x y -> reL $ HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) x y)
+ funs = foldr1 (\x y -> reL $ HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) x y)
apps = foldl1 (\x y -> reL $ HsAppTy noExtField x y)
typeSig nm flds = operator nm ++ " :: " ++
@@ -284,8 +284,8 @@ ppCtor dflags _dat subdocs (ConDeclGADT { con_names = names
Nothing -> tau_ty
tau_ty = foldr mkFunTy res_ty $
case args of PrefixConGADT pos_args -> map hsScaledThing pos_args
- RecConGADT (L _ flds) -> map (cd_fld_type . unL) flds
- mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) a b)
+ RecConGADT (L _ flds) _ -> map (cd_fld_type . unL) flds
+ mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) a b)
ppFixity :: DynFlags -> (Name, Fixity) -> [String]
ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExtField [noLocA name] fixity) :: FixitySig GhcRn)]
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index c7ba5a80..eb524ec7 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -843,7 +843,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
fieldPart = case con of
ConDeclGADT{con_g_args = con_args'} -> case con_args' of
-- GADT record declarations
- RecConGADT _ -> doConstrArgsWithDocs []
+ RecConGADT _ _ -> doConstrArgsWithDocs []
-- GADT prefix data constructors
PrefixConGADT args | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args)
_ -> empty
@@ -1108,9 +1108,9 @@ ppr_mono_ty (HsFunTy _ mult ty1 ty2) u
= sep [ ppr_mono_lty ty1 u
, arr <+> ppr_mono_lty ty2 u ]
where arr = case mult of
- HsLinearArrow _ _ -> lollipop u
+ HsLinearArrow _ -> lollipop u
HsUnrestrictedArrow _ -> arrow u
- HsExplicitMult _ _ m -> multAnnotation <> ppr_mono_lty m u <+> arrow u
+ HsExplicitMult _ m _ -> multAnnotation <> ppr_mono_lty m u <+> arrow u
ppr_mono_ty (HsBangTy _ b ty) u = ppBang b <> ppLParendType u ty
ppr_mono_ty (HsTyVar _ NotPromoted (L _ name)) _ = ppDocName name
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 994b5d0d..336f23ac 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -969,7 +969,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
fieldPart = case con of
ConDeclGADT{con_g_args = con_args'} -> case con_args' of
-- GADT record declarations
- RecConGADT _ -> [ doConstrArgsWithDocs [] ]
+ RecConGADT _ _ -> [ doConstrArgsWithDocs [] ]
-- GADT prefix data constructors
PrefixConGADT args | hasArgDocs -> [ doConstrArgsWithDocs args ]
_ -> []
@@ -1250,9 +1250,9 @@ ppr_mono_ty (HsFunTy _ mult ty1 ty2) u q e =
, arr <+> ppr_mono_lty ty2 u q e
]
where arr = case mult of
- HsLinearArrow _ _ -> lollipop u
+ HsLinearArrow _ -> lollipop u
HsUnrestrictedArrow _ -> arrow u
- HsExplicitMult _ _ m -> multAnnotation <> ppr_mono_lty m u q e <+> arrow u
+ HsExplicitMult _ m _ -> multAnnotation <> ppr_mono_lty m u q e <+> arrow u
ppr_mono_ty (HsTupleTy _ con tys) u q _ =
tupleParens con (map (ppLType u q HideEmptyContexts) tys)
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index a2bdb1b9..cf533c20 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -401,7 +401,7 @@ synifyDataCon use_gadt_syntax dc =
mk_gadt_arg_tys :: HsConDeclGADTDetails GhcRn
mk_gadt_arg_tys
- | use_named_field_syntax = RecConGADT (noLocA field_tys)
+ | use_named_field_syntax = RecConGADT (noLocA field_tys) noHsUniTok
| otherwise = PrefixConGADT (map hsUnrestricted linear_tys)
-- finally we get synifyDataCon's result!
@@ -797,9 +797,9 @@ noKindTyVars _ _ = emptyVarSet
synifyMult :: [TyVar] -> Mult -> HsArrow GhcRn
synifyMult vs t = case t of
- One -> HsLinearArrow NormalSyntax Nothing
- Many -> HsUnrestrictedArrow NormalSyntax
- ty -> HsExplicitMult NormalSyntax Nothing (synifyType WithinType vs ty)
+ One -> HsLinearArrow (HsPct1 noHsTok noHsUniTok)
+ Many -> HsUnrestrictedArrow noHsUniTok
+ ty -> HsExplicitMult noHsTok (synifyType WithinType vs ty) noHsUniTok
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index fa567da8..599404a0 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -177,11 +177,11 @@ getGADTConType (ConDeclGADT { con_bndrs = L _ outer_bndrs
-- tau_ty :: LHsType DocNameI
tau_ty = case args of
- RecConGADT flds -> mkFunTy (noLocA (HsRecTy noAnn (unLoc flds))) res_ty
+ RecConGADT flds _ -> mkFunTy (noLocA (HsRecTy noAnn (unLoc flds))) res_ty
PrefixConGADT pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args)
mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI
- mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) a b)
+ mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) a b)
getGADTConType (ConDeclH98 {}) = panic "getGADTConType"
-- Should only be called on ConDeclGADT
@@ -283,7 +283,7 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
ConDeclGADT { con_g_args = con_args' } -> case con_args' of
PrefixConGADT {} -> Just d
- RecConGADT fields
+ RecConGADT fields _
| all field_avail (unLoc fields) -> Just d
| otherwise -> Just (d { con_g_args = PrefixConGADT (field_types $ unLoc fields) })
-- see above
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 2d79bb97..2782f711 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -1142,7 +1142,7 @@ extractPatternSyn nm t tvs cons =
InfixCon arg1 arg2 -> map hsScaledThing [arg1, arg2]
ConDeclGADT { con_g_args = con_args' } -> case con_args' of
PrefixConGADT args' -> map hsScaledThing args'
- RecConGADT (L _ fields) -> cd_fld_type . unLoc <$> fields
+ RecConGADT (L _ fields) _ -> cd_fld_type . unLoc <$> fields
typ = longArrow args (data_ty con)
typ' =
case con of
@@ -1152,7 +1152,7 @@ extractPatternSyn nm t tvs cons =
in PatSynSig noAnn [noLocA nm] (mkEmptySigType typ'')
longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn
- longArrow inputs output = foldr (\x y -> noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) x y)) output inputs
+ longArrow inputs output = foldr (\x y -> noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) x y)) output inputs
data_ty con
| ConDeclGADT{} <- con = con_res_ty con
@@ -1169,7 +1169,7 @@ extractRecSel _ _ _ [] = Left "extractRecSel: selector not found"
extractRecSel nm t tvs (L _ con : rest) =
case getRecConArgs_maybe con of
Just (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields ->
- pure (L (noAnnSrcSpan l) (TypeSig noAnn [noLocA nm] (mkEmptyWildCardBndrs $ mkEmptySigType (noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) data_ty (getBangType ty))))))
+ pure (L (noAnnSrcSpan l) (TypeSig noAnn [noLocA nm] (mkEmptyWildCardBndrs $ mkEmptySigType (noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) data_ty (getBangType ty))))))
_ -> extractRecSel nm t tvs rest
where
matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)]
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 693a22ef..98b3a6e6 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -245,9 +245,10 @@ renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)
renameMaybeInjectivityAnn = traverse renameInjectivityAnn
renameArrow :: HsArrow GhcRn -> RnM (HsArrow DocNameI)
-renameArrow (HsUnrestrictedArrow u) = return (HsUnrestrictedArrow u)
-renameArrow (HsLinearArrow u a) = return (HsLinearArrow u a)
-renameArrow (HsExplicitMult u a p) = HsExplicitMult u a <$> renameLType p
+renameArrow (HsUnrestrictedArrow arr) = return (HsUnrestrictedArrow arr)
+renameArrow (HsLinearArrow (HsPct1 pct1 arr)) = return (HsLinearArrow (HsPct1 pct1 arr))
+renameArrow (HsLinearArrow (HsLolly arr)) = return (HsLinearArrow (HsLolly arr))
+renameArrow (HsExplicitMult pct p arr) = (\p' -> HsExplicitMult pct p' arr) <$> renameLType p
renameType :: HsType GhcRn -> RnM (HsType DocNameI)
renameType t = case t of
@@ -548,9 +549,9 @@ renameH98Details (InfixCon a b) = do
renameGADTDetails :: HsConDeclGADTDetails GhcRn
-> RnM (HsConDeclGADTDetails DocNameI)
-renameGADTDetails (RecConGADT (L l fields)) = do
+renameGADTDetails (RecConGADT (L l fields) arr) = do
fields' <- mapM renameConDeclFieldField fields
- return (RecConGADT (L (locA l) fields'))
+ return (RecConGADT (L (locA l) fields') arr)
renameGADTDetails (PrefixConGADT ps) = PrefixConGADT <$> mapM renameHsScaled ps
renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI)
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index 657da7ae..399e5d0d 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -134,7 +134,7 @@ sugarTuples typ =
sugarOperators :: HsType GhcRn -> HsType GhcRn
sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ _ (L l name))) la)) lb)
| isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb
- | unrestrictedFunTyConName == name' = HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) la lb
+ | unrestrictedFunTyConName == name' = HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) la lb
where
name' = getName name
sugarOperators typ = typ
@@ -311,7 +311,7 @@ renameType t@(HsTyLit _ _) = pure t
renameType (HsWildCardTy wc) = pure (HsWildCardTy wc)
renameHsArrow :: HsArrow GhcRn -> Rename (IdP GhcRn) (HsArrow GhcRn)
-renameHsArrow (HsExplicitMult u a p) = HsExplicitMult u a <$> renameLType p
+renameHsArrow (HsExplicitMult pct p arr) = (\p' -> HsExplicitMult pct p' arr) <$> renameLType p
renameHsArrow mult = pure mult
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-23 06:20:11 +0000