Miscellaneous improvements to Convert

haddock-api/src/Haddock/Backends/Hoogle.hs

@@ -263,8 +263,13 @@ ppCtor dflags dat subdocs con@ConDeclH98 {}
         -- docs for con_names on why it is a list to begin with.
         name = commaSeparate dflags . map unL $ getConNames con
 
-        resType = apps $ map (reL . HsTyVar NoExt NotPromoted . reL) $
-                        (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _ _) <- hsQTvExplicit $ tyClDeclTyVars dat]
+        tyVarArg (UserTyVar _ n) = HsTyVar NoExt NotPromoted n
+        tyVarArg (KindedTyVar _ n lty) = HsKindSig NoExt (reL (HsTyVar NoExt NotPromoted n)) lty
+        tyVarArg _ = panic "ppCtor"
+
+        resType = apps $ map reL $
+                        (HsTyVar NoExt NotPromoted (reL (tcdName dat))) :
+                        map (tyVarArg . unLoc) (hsQTvExplicit $ tyClDeclTyVars dat)
 
 ppCtor dflags _dat subdocs con@(ConDeclGADT { })
    = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f

haddock-api/src/Haddock/Backends/LaTeX.hs

@@ -960,7 +960,7 @@ ppContext cxt unicode = ppContextNoLocs (map unLoc cxt) unicode
 
 pp_hs_context :: [HsType DocNameI] -> Bool -> LaTeX
 pp_hs_context []  _       = empty
-pp_hs_context [p] unicode = ppType unicode p
+pp_hs_context [p] unicode = ppCtxType unicode p
 pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt)
 
 
@@ -995,11 +995,11 @@ ppLType       unicode y = ppType unicode (unLoc y)
 ppLParendType unicode y = ppParendType unicode (unLoc y)
 ppLFunLhType  unicode y = ppFunLhType unicode (unLoc y)
 
-
-ppType, ppParendType, ppFunLhType :: Bool -> HsType DocNameI -> LaTeX
+ppType, ppParendType, ppFunLhType, ppCtxType :: Bool -> HsType DocNameI -> LaTeX
 ppType       unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode
 ppParendType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode
 ppFunLhType  unicode ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode
+ppCtxType    unicode ty = ppr_mono_ty (reparenTypePrec PREC_CTX ty) unicode
 
 ppLHsTypeArg :: Bool -> LHsTypeArg DocNameI -> LaTeX
 ppLHsTypeArg unicode (HsValArg ty) = ppLParendType unicode ty
@@ -1045,7 +1045,7 @@ ppr_mono_ty (HsTupleTy _ con tys) u = tupleParens con (map (ppLType u) tys)
 ppr_mono_ty (HsSumTy _ tys) u       = sumParens (map (ppLType u) tys)
 ppr_mono_ty (HsKindSig _ ty kind) u = parens (ppr_mono_lty ty u <+> dcolon u <+> ppLKind u kind)
 ppr_mono_ty (HsListTy _ ty)       u = brackets (ppr_mono_lty ty u)
-ppr_mono_ty (HsIParamTy _ (L _ n) ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty ty u)
+ppr_mono_ty (HsIParamTy _ (L _ n) ty) u = ppIPName n <+> dcolon u <+> ppr_mono_lty ty u
 ppr_mono_ty (HsSpliceTy {})     _ = error "ppr_mono_ty HsSpliceTy"
 ppr_mono_ty (HsRecTy {})        _ = text "{..}"
 ppr_mono_ty (XHsType (NHsCoreTy {}))  _ = error "ppr_mono_ty HsCoreTy"
@@ -1110,7 +1110,7 @@ ppVerbOccName :: OccName -> LaTeX
 ppVerbOccName = text . latexFilter . occNameString
 
 ppIPName :: HsIPName -> LaTeX
-ppIPName ip = text $ unpackFS $ hsIPNameFS ip
+ppIPName = text . ('?':) . unpackFS . hsIPNameFS
 
 ppOccName :: OccName -> LaTeX
 ppOccName = text . occNameString

haddock-api/src/Haddock/GhcUtils.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE BangPatterns, FlexibleInstances, ViewPatterns #-}
+{-# LANGUAGE BangPatterns, StandaloneDeriving, FlexibleInstances, ViewPatterns #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -24,6 +24,7 @@ import Data.Char ( isSpace )
 import Haddock.Types( DocNameI )
 
 import Exception
+import FV
 import Outputable ( Outputable, panic, showPpr )
 import Name
 import NameSet
@@ -33,6 +34,12 @@ import GHC
 import Class
 import DynFlags
 import SrcLoc    ( advanceSrcLoc )
+import Var       ( VarBndr(..), TyVarBinder, tyVarKind, updateTyVarKind,
+                   isInvisibleArgFlag )
+import VarSet    ( VarSet, emptyVarSet )
+import VarEnv    ( TyVarEnv, extendVarEnv, elemVarEnv, emptyVarEnv )
+import TyCoRep   ( Type(..), isRuntimeRepVar )
+import TysWiredIn( liftedRepDataConTyCon )
 
 import           StringBuffer ( StringBuffer )
 import qualified StringBuffer             as S
@@ -549,3 +556,104 @@ tryCppLine !loc !buf = spanSpace (S.prevChar buf '\n' == '\n') loc buf
 
         (c   , b') -> spanCppLine (advanceSrcLoc l c) b'
 
+-------------------------------------------------------------------------------
+-- * Free variables of a 'Type'
+-------------------------------------------------------------------------------
+
+-- | Get free type variables in a 'Type' in their order of appearance.
+-- See [Ordering of implicit variables].
+orderedFVs
+  :: VarSet  -- ^ free variables to ignore 
+  -> [Type]  -- ^ types to traverse (in order) looking for free variables
+  -> [TyVar] -- ^ free type variables, in the order they appear in
+orderedFVs vs tys =
+  reverse . fst $ tyCoFVsOfTypes' tys (const True) vs ([], emptyVarSet)
+
+
+-- See the "Free variables of types and coercions" section in 'TyCoRep', or
+-- check out Note [Free variables of types]. The functions in this section
+-- don't output type variables in the order they first appear in in the 'Type'.
+--
+-- For example, 'tyCoVarsOfTypeList' reports an incorrect order for the type
+-- of 'const :: a -> b -> a':
+--
+-- >>> import Name 
+-- >>> import TyCoRep
+-- >>> import TysPrim
+-- >>> import Var
+-- >>> a = TyVarTy alphaTyVar
+-- >>> b = TyVarTy betaTyVar
+-- >>> constTy = mkFunTys [a, b] a
+-- >>> map (getOccString . tyVarName) (tyCoVarsOfTypeList constTy)
+-- ["b","a"]
+--
+-- However, we want to reuse the very optimized traversal machinery there, so
+-- so we make our own `tyCoFVsOfType'`, `tyCoFVsBndr'`, and `tyCoVarsOfTypes'`.
+-- All these do differently is traverse in a different order and ignore
+-- coercion variables.
+
+-- | Just like 'tyCoFVsOfType', but traverses type variables in reverse order
+-- of  appearance.
+tyCoFVsOfType' :: Type -> FV
+tyCoFVsOfType' (TyVarTy v)        a b c = (FV.unitFV v `unionFV` tyCoFVsOfType' (tyVarKind v)) a b c
+tyCoFVsOfType' (TyConApp _ tys)   a b c = tyCoFVsOfTypes' tys a b c
+tyCoFVsOfType' (LitTy {})         a b c = emptyFV a b c
+tyCoFVsOfType' (AppTy fun arg)    a b c = (tyCoFVsOfType' arg `unionFV` tyCoFVsOfType' fun) a b c
+tyCoFVsOfType' (FunTy arg res)    a b c = (tyCoFVsOfType' res `unionFV` tyCoFVsOfType' arg) a b c
+tyCoFVsOfType' (ForAllTy bndr ty) a b c = tyCoFVsBndr' bndr (tyCoFVsOfType' ty)  a b c
+tyCoFVsOfType' (CastTy ty _)      a b c = (tyCoFVsOfType' ty) a b c
+tyCoFVsOfType' (CoercionTy _ )    a b c = emptyFV a b c
+
+-- | Just like 'tyCoFVsOfTypes', but traverses type variables in reverse order
+-- of appearance.
+tyCoFVsOfTypes' :: [Type] -> FV
+tyCoFVsOfTypes' (ty:tys) fv_cand in_scope acc = (tyCoFVsOfTypes' tys `unionFV` tyCoFVsOfType' ty) fv_cand in_scope acc
+tyCoFVsOfTypes' []       fv_cand in_scope acc = emptyFV fv_cand in_scope acc
+
+-- | Just like 'tyCoFVsBndr', but traverses type variables in reverse order of
+-- appearance.
+tyCoFVsBndr' :: TyVarBinder -> FV -> FV
+tyCoFVsBndr' (Bndr tv _) fvs = FV.delFV tv fvs `unionFV` tyCoFVsOfType' (tyVarKind tv)
+
+
+-------------------------------------------------------------------------------
+-- * Defaulting RuntimeRep variables
+-------------------------------------------------------------------------------
+
+-- | Traverses the type, defaulting type variables of kind 'RuntimeRep' to
+-- 'LiftedType'. See 'defaultRuntimeRepVars' in IfaceType.hs the original such
+-- function working over `IfaceType`'s.
+defaultRuntimeRepVars :: Type -> Type
+defaultRuntimeRepVars = go emptyVarEnv
+  where
+    go :: TyVarEnv () -> Type -> Type
+    go subs (ForAllTy (Bndr var flg) ty)
+      | isRuntimeRepVar var
+      , isInvisibleArgFlag flg
+      = let subs' = extendVarEnv subs var ()
+        in go subs' ty
+      | otherwise
+      = ForAllTy (Bndr (updateTyVarKind (go subs) var) flg)
+                 (go subs ty)
+
+    go subs (TyVarTy tv)
+      | tv `elemVarEnv` subs
+      = TyConApp liftedRepDataConTyCon []
+      | otherwise
+      = TyVarTy (updateTyVarKind (go subs) tv)
+
+    go subs (TyConApp tc tc_args)
+      = TyConApp tc (map (go subs) tc_args)
+
+    go subs (FunTy arg res)
+      = FunTy (go subs arg) (go subs res)
+
+    go subs (AppTy t u)
+      = AppTy (go subs t) (go subs u)
+
+    go subs (CastTy x co)
+      = CastTy (go subs x) co
+
+    go _ ty@(LitTy {}) = ty
+    go _ ty@(CoercionTy {}) = ty
+

haddock-api/src/Haddock/Interface/Create.hs

@@ -891,7 +891,7 @@ hiDecl dflags t = do
     Nothing -> do
       liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty dflags t]
       return Nothing
-    Just x -> case tyThingToLHsDecl x of
+    Just x -> case tyThingToLHsDecl ShowRuntimeRep x of
       Left m -> liftErrMsg (tell [bugWarn m]) >> return Nothing
       Right (m, t') -> liftErrMsg (tell $ map bugWarn m)
                       >> return (Just $ noLoc t')

hoogle-test/ref/Bug873/test.txt

@@ -21,7 +21,7 @@ module Bug873
 --   Note that <tt>(<a>$</a>)</tt> is levity-polymorphic in its result
 --   type, so that <tt>foo <a>$</a> True</tt> where <tt>foo :: Bool -&gt;
 --   Int#</tt> is well-typed.
-($) :: () => (a -> b) -> a -> b
+($) :: forall (r :: RuntimeRep) a (b :: TYPE r). (a -> b) -> a -> b
 infixr 0 $
 ($$) :: (a -> b) -> a -> b
 infixr 0 $$

html-test/ref/Bug548.html

@@ -148,7 +148,9 @@
 			><p class="src"
 			><a href="#"
 			  >from1</a
-			  > :: <a href="#" title="Bug548"
+			  > :: <span class="keyword"
+			  >forall</span
+			  > (a0 :: k). <a href="#" title="Bug548"
 			  >WrappedArrow</a
 			  > a b a0 -&gt; <a href="#" title="GHC.Generics"
 			  >Rep1</a
@@ -160,7 +162,9 @@
 			><p class="src"
 			><a href="#"
 			  >to1</a
-			  > :: <a href="#" title="GHC.Generics"
+			  > :: <span class="keyword"
+			  >forall</span
+			  > (a0 :: k). <a href="#" title="GHC.Generics"
 			  >Rep1</a
 			  > (<a href="#" title="Bug548"
 			  >WrappedArrow</a

html-test/ref/Instances.html

@@ -2038,8 +2038,6 @@
 			  >Int</a
 			  > c <a href="#" title="Data.Bool"
 			  >Bool</a
-			  > :: <a href="#" title="Data.Kind"
-			  >Type</a
 			  > <a href="#" class="selflink"
 			  >#</a
 			  ></p
@@ -2050,9 +2048,7 @@
 			  >Thud</a
 			  > <a href="#" title="Data.Int"
 			  >Int</a
-			  > c :: <a href="#" title="Data.Kind"
-			  >Type</a
-			  > <a href="#" class="selflink"
+			  > c <a href="#" class="selflink"
 			  >#</a
 			  ></p
 			></div
@@ -2112,19 +2108,15 @@
 			  >type</span
 			  > <a href="#" title="Instances"
 			  >Plugh</a
-			  > [a] c [b] :: <a href="#" title="Data.Kind"
-			  >Type</a
-			  > <a href="#" class="selflink"
+			  > [a] c [b] <a href="#" class="selflink"
 			  >#</a
 			  ></p
 			><p class="src"
 			><span class="keyword"
 			  >data</span
 			  > <a href="#" title="Instances"
 			  >Thud</a
-			  > [a] c :: <a href="#" title="Data.Kind"
-			  >Type</a
-			  > <a href="#" class="selflink"
+			  > [a] c <a href="#" class="selflink"
 			  >#</a
 			  ></p
 			></div

html-test/ref/Operators.html

@@ -96,9 +96,7 @@
 	      >pattern</span
 	      > <a href="#"
 	      >(:+)</a
-	      > :: <span class="keyword"
-	      >forall</span
-	      > a. a -&gt; a -&gt; [a]</li
+	      > :: a -&gt; a -&gt; [a]</li
 	    ><li class="src short"
 	    ><span class="keyword"
 	      >data</span
@@ -285,9 +283,7 @@
 	    >pattern</span
 	    > <a id="v::-43-" class="def"
 	    >(:+)</a
-	    > :: <span class="keyword"
-	    >forall</span
-	    > a. a -&gt; a -&gt; [a] <span class="fixity"
+	    > :: a -&gt; a -&gt; [a] <span class="fixity"
 	    >infixr 3</span
 	    ><span class="rightedge"
 	    ></span
@@ -529,4 +525,4 @@
     ></div
     ></body
   ></html
->
+>