[commit: haddock] adamse-D1033, ghc-head, wip/orf-reboot: Update after wild card renaming refactoring in D613 (553c719)
git at git.haskell.org
git at git.haskell.org
Wed Jul 8 08:39:07 UTC 2015
Repository : ssh://git@git.haskell.org/haddock
On branches: adamse-D1033,ghc-head,wip/orf-reboot
Link : http://git.haskell.org/haddock.git/commitdiff/553c719236972f3a1d445146352ec94614979b63
>---------------------------------------------------------------
commit 553c719236972f3a1d445146352ec94614979b63
Author: Thomas Winant <thomas.winant at cs.kuleuven.be>
Date: Mon Jun 8 23:47:28 2015 -0500
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
>---------------------------------------------------------------
553c719236972f3a1d445146352ec94614979b63
haddock-api/src/Haddock/Backends/LaTeX.hs | 12 +++++++-----
haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 12 +++++++-----
haddock-api/src/Haddock/Interface/Rename.hs | 19 +++++--------------
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 c9262c7..e1090a0 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 88aa966..c0be973 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 56e5b07..2b50ce9 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 e93294a..847320a 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
More information about the ghc-commits
mailing list