diff options
author | Thomas Winant <thomas.winant@cs.kuleuven.be> | 2015-06-08 23:47:28 -0500 |
---|---|---|
committer | Austin Seipp <aseipp@pobox.com> | 2015-06-08 23:47:28 -0500 |
commit | 553c719236972f3a1d445146352ec94614979b63 (patch) | |
tree | aa8e1891ca8fd3b2f2d11480d4961a68a7ef4824 /haddock-api/src/Haddock | |
parent | 45df734c8e0242ca2e88fba5359207e49d7bf158 (diff) |
Update after wild card renaming refactoring in D613
Summary:
* Move `Post*` type instances to `Haddock.Types` as other modules than
`Haddock.Interface.Rename` will rely on these type instances.
* Update after wild card renaming refactoring in D613.
Reviewers: simonpj, austin
Reviewed By: austin
Differential Revision: https://phabricator.haskell.org/D954
GHC Trac Issues: #10098
Diffstat (limited to 'haddock-api/src/Haddock')
-rw-r--r-- | haddock-api/src/Haddock/Backends/LaTeX.hs | 12 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 12 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Interface/Rename.hs | 19 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Types.hs | 19 |
4 files changed, 37 insertions, 25 deletions
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index c9262c7e..e1090a0e 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -898,9 +898,11 @@ ppr_mono_ty :: Int -> HsType DocName -> Bool -> LaTeX ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode = maybeParen ctxt_prec pREC_FUN $ hsep [ppForAll expl tvs ctxt' unicode, ppr_mono_lty pREC_TOP ty unicode] - where ctxt' = case extra of - Just loc -> (++ [L loc HsWildcardTy]) `fmap` ctxt - Nothing -> ctxt + where + anonWC = HsWildCardTy (AnonWildCard PlaceHolder) + ctxt' + | Just loc <- extra = (++ [L loc anonWC]) `fmap` ctxt + | otherwise = ctxt ppr_mono_ty _ (HsBangTy b ty) u = ppBang b <> ppLParendType u ty ppr_mono_ty _ (HsTyVar name) _ = ppDocName name @@ -939,9 +941,9 @@ ppr_mono_ty ctxt_prec (HsParTy ty) unicode ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode = ppr_mono_lty ctxt_prec ty unicode -ppr_mono_ty _ HsWildcardTy _ = char '_' +ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ = char '_' -ppr_mono_ty _ (HsNamedWildcardTy name) _ = ppDocName name +ppr_mono_ty _ (HsWildCardTy (NamedWildCard name)) _ = ppDocName name ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 88aa966c..c0be9735 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -852,9 +852,11 @@ ppr_mono_ty :: Int -> HsType DocName -> Unicode -> Qualification -> Html ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode qual = maybeParen ctxt_prec pREC_FUN $ ppForAllCon expl tvs ctxt' unicode qual <+> ppr_mono_lty pREC_TOP ty unicode qual - where ctxt' = case extra of - Just loc -> (++ [L loc HsWildcardTy]) `fmap` ctxt - Nothing -> ctxt + where + anonWC = HsWildCardTy (AnonWildCard PlaceHolder) + ctxt' + | Just loc <- extra = (++ [L loc anonWC]) `fmap` ctxt + | otherwise = ctxt -- UnicodeSyntax alternatives ppr_mono_ty _ (HsTyVar name) True _ @@ -899,9 +901,9 @@ ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual = ppr_mono_lty ctxt_prec ty unicode qual -ppr_mono_ty _ HsWildcardTy _ _ = char '_' +ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ _ = char '_' -ppr_mono_ty _ (HsNamedWildcardTy name) _ q = ppDocName q Prefix True name +ppr_mono_ty _ (HsWildCardTy (NamedWildCard name)) _ q = ppDocName q Prefix True name ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 56e5b07f..2b50ce9a 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TypeFamilies #-} ---------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.Rename @@ -21,8 +20,6 @@ import Haddock.Types import Bag (emptyBag) import GHC hiding (NoLink) import Name -import NameSet -import Coercion import Control.Applicative import Control.Monad hiding (mapM) @@ -234,8 +231,7 @@ renameType t = case t of HsExplicitListTy a b -> HsExplicitListTy a <$> mapM renameLType b HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b HsSpliceTy _ _ -> error "renameType: HsSpliceTy" - HsWildcardTy -> pure HsWildcardTy - HsNamedWildcardTy a -> HsNamedWildcardTy <$> rename a + HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a renameLTyVarBndrs :: LHsTyVarBndrs Name -> RnM (LHsTyVarBndrs DocName) renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs }) @@ -257,6 +253,10 @@ renameLContext (L loc context) = do context' <- mapM renameLType context return (L loc context') +renameWildCardInfo :: HsWildCardInfo Name -> RnM (HsWildCardInfo DocName) +renameWildCardInfo (AnonWildCard _) = pure (AnonWildCard PlaceHolder) +renameWildCardInfo (NamedWildCard name) = NamedWildCard <$> rename name + renameInstHead :: InstHead Name -> RnM (InstHead DocName) renameInstHead (className, k, types, rest) = do className' <- rename className @@ -517,12 +517,3 @@ renameSub (n,doc) = do n' <- rename n doc' <- renameDocForDecl doc return (n', doc') - -type instance PostRn DocName NameSet = PlaceHolder -type instance PostRn DocName Fixity = PlaceHolder -type instance PostRn DocName Bool = PlaceHolder -type instance PostRn DocName [Name] = PlaceHolder - -type instance PostTc DocName Kind = PlaceHolder -type instance PostTc DocName Type = PlaceHolder -type instance PostTc DocName Coercion = PlaceHolder diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index e93294a0..847320a7 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving, TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | @@ -34,6 +34,8 @@ import GHC hiding (NoLink) import DynFlags (ExtensionFlag, Language) import OccName import Outputable +import NameSet (NameSet) +import Coercion (Coercion) import Control.Applicative (Applicative(..)) import Control.Monad (ap) @@ -551,3 +553,18 @@ instance Monad ErrMsgGhc where return a = WriterGhc (return (a, [])) m >>= k = WriterGhc $ runWriterGhc m >>= \ (a, msgs1) -> fmap (second (msgs1 ++)) (runWriterGhc (k a)) + + +----------------------------------------------------------------------------- +-- * Pass sensitive types +----------------------------------------------------------------------------- + +type instance PostRn DocName NameSet = PlaceHolder +type instance PostRn DocName Fixity = PlaceHolder +type instance PostRn DocName Bool = PlaceHolder +type instance PostRn DocName Name = PlaceHolder +type instance PostRn DocName [Name] = PlaceHolder + +type instance PostTc DocName Kind = PlaceHolder +type instance PostTc DocName Type = PlaceHolder +type instance PostTc DocName Coercion = PlaceHolder |