diff options
| author | sheaf <sam.derbyshire@gmail.com> | 2022-03-29 16:36:45 +0200 |
|---|---|---|
| committer | sheaf <sam.derbyshire@gmail.com> | 2022-04-01 12:02:02 +0200 |
| commit | 58237d76c96325f25627bfd7cdad5b93364d29a4 (patch) | |
| tree | 4ecfac250db22272c83acc777a8c4157d28af3b1 /haddock-api/src/Haddock/Interface | |
| parent | 559e41505e81d93939e9afa6aa9793b0a428924f (diff) | |
Keep track of promotion ticks in HsOpTy
Keeping track of promotion ticks in HsOpTy allows us to properly
pretty-print promoted constructors such as lists.
Diffstat (limited to 'haddock-api/src/Haddock/Interface')
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Rename.hs | 4 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Specialize.hs | 9 |
2 files changed, 7 insertions, 6 deletions
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index f2b3a9fa..6057bf75 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -290,11 +290,11 @@ renameType t = case t of HsTupleTy _ b ts -> return . HsTupleTy noAnn b =<< mapM renameLType ts HsSumTy _ ts -> HsSumTy noAnn <$> mapM renameLType ts - HsOpTy _ a (L loc op) b -> do + HsOpTy _ prom a (L loc op) b -> do op' <- rename op a' <- renameLType a b' <- renameLType b - return (HsOpTy noAnn a' (L loc op') b') + return (HsOpTy noAnn prom a' (L loc op') b') HsParTy _ ty -> return . (HsParTy noAnn) =<< renameLType ty diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index 399e5d0d..d1164858 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -16,6 +16,7 @@ import Haddock.Syb import Haddock.Types import GHC +import GHC.Types.Basic ( PromotionFlag(..) ) import GHC.Types.Name import GHC.Data.FastString import GHC.Builtin.Types ( listTyConName, unrestrictedFunTyConName ) @@ -132,8 +133,8 @@ 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 +sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ prom (L l name))) la)) lb) + | isSymOcc $ getOccName name' = mkHsOpTy prom la (L l name) lb | unrestrictedFunTyConName == name' = HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) la lb where name' = getName name @@ -293,8 +294,8 @@ renameType (HsFunTy x w la lr) = HsFunTy x <$> renameHsArrow w <*> renameLType l renameType (HsListTy x lt) = HsListTy x <$> renameLType lt renameType (HsTupleTy x srt lt) = HsTupleTy x srt <$> mapM renameLType lt renameType (HsSumTy x lt) = HsSumTy x <$> mapM renameLType lt -renameType (HsOpTy x la lop lb) = - HsOpTy x <$> renameLType la <*> locatedN renameName lop <*> renameLType lb +renameType (HsOpTy x prom la lop lb) = + HsOpTy x prom <$> renameLType la <*> locatedN renameName lop <*> renameLType lb renameType (HsParTy x lt) = HsParTy x <$> renameLType lt renameType (HsIParamTy x ip lt) = HsIParamTy x ip <$> renameLType lt renameType (HsKindSig x lt lk) = HsKindSig x <$> renameLType lt <*> pure lk |