Remaining fixes for PredTy removal

7 files changed, 62 insertions, 44 deletions

diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
index 44e83d64..adf95636 100644
--- a/src/Haddock/Backends/Hoogle.hs
+++ b/src/Haddock/Backends/Hoogle.hs
@@ -143,10 +143,10 @@ ppClass x = out x{tcdSigs=[]} :
         addContext (TypeSig name (L l sig)) = TypeSig name (L l $ f sig)
         addContext _ = error "expected TypeSig"
 
-        f (HsForAllTy a b con d) = HsForAllTy a b (reL $ context : unL con) d
+        f (HsForAllTy a b con d) = HsForAllTy a b (reL (context : unLoc con)) d
         f t = HsForAllTy Implicit [] (reL [context]) (reL t)
 
-        context = reL $ HsClassP (unL $ tcdLName x)
+        context = nlHsTyConApp (unL $ tcdLName x)
             (map (reL . HsTyVar . hsTyVarName . unL) (tcdTyVars x))
 
 
diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index 27f6bd5e..59fff6ae 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -24,7 +24,7 @@ import GHC
 import OccName
 import Name                 ( isTyConName, nameOccName )
 import RdrName              ( rdrNameOcc, isRdrTc )
-import BasicTypes           ( IPName(..), Boxity(..) )
+import BasicTypes           ( ipNameName )
 import Outputable           ( Outputable, ppr, showSDoc )
 import FastString           ( unpackFS, unpackLitString )
 
@@ -450,7 +450,7 @@ rDoc = maybeDoc . fmap latexStripTrailingWhitespace
 -------------------------------------------------------------------------------
 
 
-ppClassHdr :: Bool -> Located [LHsPred DocName] -> DocName
+ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName
            -> [Located (HsTyVarBndr DocName)] -> [Located ([DocName], [DocName])]
            -> Bool -> LaTeX
 ppClassHdr summ lctxt n tvs fds unicode =
@@ -771,7 +771,7 @@ ppContextNoArrow []  _ = empty
 ppContextNoArrow cxt unicode = pp_hs_context (map unLoc cxt) unicode
 
 
-ppContextNoLocs :: [HsPred DocName] -> Bool -> LaTeX
+ppContextNoLocs :: [HsType DocName] -> Bool -> LaTeX
 ppContextNoLocs []  _ = empty
 ppContextNoLocs cxt unicode = pp_hs_context cxt unicode <+> darrow unicode
 
@@ -780,17 +780,10 @@ ppContext :: HsContext DocName -> Bool -> LaTeX
 ppContext cxt unicode = ppContextNoLocs (map unLoc cxt) unicode
 
 
-pp_hs_context :: [HsPred DocName] -> Bool -> LaTeX
+pp_hs_context :: [HsType DocName] -> Bool -> LaTeX
 pp_hs_context []  _       = empty
-pp_hs_context [p] unicode = ppPred unicode p
-pp_hs_context cxt unicode = parenList (map (ppPred unicode) cxt)
-
-
-ppPred :: Bool -> HsPred DocName -> LaTeX
-ppPred unicode (HsClassP n ts) = ppAppNameTypes n (map unLoc ts) unicode
-ppPred unicode (HsEqualP t1 t2) = ppLType unicode t1 <> text "~" <> ppLType unicode t2
-ppPred unicode (HsIParam (IPName n) t)
-  = char '?' <> ppDocName n <> dcolon unicode <> ppLType unicode t
+pp_hs_context [p] unicode = ppType unicode p
+pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt)
 
 
 -------------------------------------------------------------------------------
@@ -807,9 +800,9 @@ ppBang HsNoBang = empty
 ppBang _        = char '!' -- Unpacked args is an implementation detail,
 
 
-tupleParens :: Boxity -> [LaTeX] -> LaTeX
-tupleParens Boxed   = parenList
-tupleParens Unboxed = ubxParenList
+tupleParens :: HsTupleSort -> [LaTeX] -> LaTeX
+tupleParens (HsBoxyTuple _) = parenList
+tupleParens HsUnboxedTuple  = ubxParenList
 
 
 -------------------------------------------------------------------------------
@@ -878,12 +871,16 @@ ppr_mono_ty _         (HsTupleTy con tys) u = tupleParens con (map (ppLType u) t
 ppr_mono_ty _         (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppKind kind)
 ppr_mono_ty _         (HsListTy ty)       u = brackets (ppr_mono_lty pREC_TOP ty u)
 ppr_mono_ty _         (HsPArrTy ty)       u = pabrackets (ppr_mono_lty pREC_TOP ty u)
-ppr_mono_ty _         (HsPredTy p)        u = parens (ppPred u p)
+ppr_mono_ty _         (HsIParamTy n ty)   u = brackets (ppDocName (ipNameName n) <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u)
 ppr_mono_ty _         (HsSpliceTy {})     _ = error "ppr_mono_ty HsSpliceTy"
 ppr_mono_ty _         (HsQuasiQuoteTy {}) _ = error "ppr_mono_ty HsQuasiQuoteTy"
 ppr_mono_ty _         (HsRecTy {})        _ = error "ppr_mono_ty HsRecTy"
 ppr_mono_ty _         (HsCoreTy {})       _ = error "ppr_mono_ty HsCoreTy"
 
+ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode
+  = maybeParen ctxt_prec pREC_OP $
+    ppr_mono_lty pREC_OP ty1 unicode <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode
+
 ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode
   = maybeParen ctxt_prec pREC_CON $
     hsep [ppr_mono_lty pREC_FUN fun_ty unicode, ppr_mono_lty pREC_CON arg_ty unicode]
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index add926ab..eb1219f4 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -32,9 +32,9 @@ import qualified Data.Map as Map
 import           Data.Maybe
 import           Text.XHtml hiding     ( name, title, p, quote )
 
-import BasicTypes            ( IPName(..), Boxity(..) )
 import GHC
 import Name
+import BasicTypes            ( ipNameName )
 import Outputable            ( ppr, showSDoc, Outputable )
 
 
@@ -301,7 +301,7 @@ ppContextNoArrow []  _       _     = noHtml
 ppContextNoArrow cxt unicode qual = pp_hs_context (map unLoc cxt) unicode qual
 
 
-ppContextNoLocs :: [HsPred DocName] -> Bool -> Qualification -> Html
+ppContextNoLocs :: [HsType DocName] -> Bool -> Qualification -> Html
 ppContextNoLocs []  _       _     = noHtml
 ppContextNoLocs cxt unicode qual = pp_hs_context cxt unicode qual 
     <+> darrow unicode
@@ -311,18 +311,10 @@ ppContext :: HsContext DocName -> Bool -> Qualification -> Html
 ppContext cxt unicode qual = ppContextNoLocs (map unLoc cxt) unicode qual
 
 
-pp_hs_context :: [HsPred DocName] -> Bool -> Qualification-> Html
+pp_hs_context :: [HsType DocName] -> Bool -> Qualification-> Html
 pp_hs_context []  _       _     = noHtml
-pp_hs_context [p] unicode qual = ppPred unicode qual p
-pp_hs_context cxt unicode qual = parenList (map (ppPred unicode qual) cxt)
-
-
-ppPred :: Bool -> Qualification -> HsPred DocName -> Html
-ppPred unicode qual (HsClassP n ts) = ppAppNameTypes n (map unLoc ts) unicode qual
-ppPred unicode qual (HsEqualP t1 t2) = ppLType unicode qual t1 <+> toHtml "~"
-    <+> ppLType unicode qual t2
-ppPred unicode qual (HsIParam (IPName n) t)
-  = toHtml "?" +++ ppDocName qual n <+> dcolon unicode <+> ppLType unicode qual t
+pp_hs_context [p] unicode qual = ppType unicode qual p
+pp_hs_context cxt unicode qual = parenList (map (ppType unicode qual) cxt)
 
 
 -------------------------------------------------------------------------------
@@ -330,7 +322,7 @@ ppPred unicode qual (HsIParam (IPName n) t)
 -------------------------------------------------------------------------------
 
 
-ppClassHdr :: Bool -> Located [LHsPred DocName] -> DocName
+ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName
            -> [Located (HsTyVarBndr DocName)] -> [Located ([DocName], [DocName])]
            -> Bool -> Qualification -> Html
 ppClassHdr summ lctxt n tvs fds unicode qual =
@@ -653,9 +645,9 @@ ppBang _        = toHtml "!" -- Unpacked args is an implementation detail,
                              -- so we just show the strictness annotation
 
 
-tupleParens :: Boxity -> [Html] -> Html
-tupleParens Boxed   = parenList
-tupleParens Unboxed = ubxParenList
+tupleParens :: HsTupleSort -> [Html] -> Html
+tupleParens (HsBoxyTuple _) = parenList
+tupleParens HsUnboxedTuple  = ubxParenList
 
 
 --------------------------------------------------------------------------------
@@ -724,7 +716,7 @@ ppr_mono_ty _         (HsKindSig ty kind) u q =
     parens (ppr_mono_lty pREC_TOP ty u q <+> dcolon u <+> ppKind kind)
 ppr_mono_ty _         (HsListTy ty)       u q = brackets (ppr_mono_lty pREC_TOP ty u q)
 ppr_mono_ty _         (HsPArrTy ty)       u q = pabrackets (ppr_mono_lty pREC_TOP ty u q)
-ppr_mono_ty _         (HsPredTy p)        u q = parens (ppPred u q p)
+ppr_mono_ty _         (HsIParamTy n ty)   u q = brackets (ppDocName q (ipNameName n) <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q)
 ppr_mono_ty _         (HsSpliceTy {})     _ _ = error "ppr_mono_ty HsSpliceTy"
 #if __GLASGOW_HASKELL__ == 612
 ppr_mono_ty _         (HsSpliceTyOut {})  _ _ = error "ppr_mono_ty HsQuasiQuoteTy"
@@ -734,6 +726,10 @@ ppr_mono_ty _         (HsQuasiQuoteTy {}) _ _ = error "ppr_mono_ty HsQuasiQuoteT
 ppr_mono_ty _         (HsRecTy {})        _ _ = error "ppr_mono_ty HsRecTy"
 ppr_mono_ty _         (HsCoreTy {})       _ _ = error "ppr_mono_ty HsCoreTy"
 
+ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual
+  = maybeParen ctxt_prec pREC_OP $
+    ppr_mono_lty pREC_OP ty1 unicode qual <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode qual
+
 ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual
   = maybeParen ctxt_prec pREC_CON $
     hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual, ppr_mono_lty pREC_CON arg_ty unicode qual]
diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs
index c392cc1c..c209f761 100644
--- a/src/Haddock/Convert.hs
+++ b/src/Haddock/Convert.hs
@@ -20,14 +20,18 @@ module Haddock.Convert where
 import HsSyn
 import TcType ( tcSplitTyConApp_maybe, tcSplitSigmaTy )
 import TypeRep
+import RnTypes ( mkIPName )
+import Kind ( liftedTypeKind, factKind )
 import Coercion ( splitKindFunTys, synTyConResKind )
 import Name
 import Var
 import Class
 import TyCon
 import DataCon
+import SrcLoc ( noSrcSpan )
+import BasicTypes ( TupleSort(..) )
 import TysPrim ( alphaTyVars )
-import TysWiredIn ( listTyConName )
+import TysWiredIn ( listTyConName, eqTyCon )
 import Bag ( emptyBag )
 import SrcLoc ( Located, noLoc, unLoc )
 
@@ -260,10 +264,22 @@ synifyType _ (TyVarTy tv) = noLoc $ HsTyVar (getName tv)
 synifyType _ (TyConApp tc tys)
   -- Use non-prefix tuple syntax where possible, because it looks nicer.
   | isTupleTyCon tc, tyConArity tc == length tys =
-     noLoc $ HsTupleTy (tupleTyConBoxity tc) (map (synifyType WithinType) tys)
+     noLoc $ HsTupleTy (case tupleTyConSort tc of
+                          BoxedTuple   -> HsBoxyTuple liftedTypeKind
+                          FactTuple    -> HsBoxyTuple factKind
+                          UnboxedTuple -> HsUnboxedTuple)
+                       (map (synifyType WithinType) tys)
   -- ditto for lists
   | getName tc == listTyConName, [ty] <- tys =
      noLoc $ HsListTy (synifyType WithinType ty)
+  -- ditto for implicit parameter tycons
+  | Just ip <- tyConIP_maybe tc
+  , [ty] <- tys
+  = noLoc $ HsIParamTy (mkIPName noSrcSpan ip) (synifyType WithinType ty)
+  -- and equalities
+  | tc == eqTyCon
+  , [ty1, ty2] <- tys
+  = noLoc $ HsEqTy (synifyType WithinType ty1) (synifyType WithinType ty2)
   -- Most TyCons:
   | otherwise =
     foldl (\t1 t2 -> noLoc (HsAppTy t1 t2))
@@ -291,3 +307,12 @@ synifyType s forallty@(ForAllTy _tv _ty) =
       sTau = synifyType WithinType tau
      in noLoc $
            HsForAllTy forallPlicitness sTvs sCtx sTau
+
+
+synifyInstHead :: ([TyVar], [PredType], Class, [Type]) ->
+                  ([HsType Name], Name, [HsType Name])
+synifyInstHead (_, preds, cls, ts) =
+  ( map (unLoc . synifyType WithinType) preds
+  , getName cls
+  , map (unLoc . synifyType WithinType) ts
+  )
diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs
index e4da3233..01d5b0f4 100644
--- a/src/Haddock/Interface/AttachInstances.hs
+++ b/src/Haddock/Interface/AttachInstances.hs
@@ -116,7 +116,6 @@ getAllInfo name = withSession $ \hsc_env -> do
 data SimpleType = SimpleType Name [SimpleType] deriving (Eq,Ord)
 
 
--- TODO: should we support PredTy here?
 instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], Name, [SimpleType])
 instHead (_, _, cls, args)
   = (map argCount args, className cls, map simplify args)
@@ -134,7 +133,6 @@ instHead (_, _, cls, args)
       where (SimpleType s ts) = simplify t1
     simplify (TyVarTy v) = SimpleType (tyVarName v) []
     simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts)
-    simplify _ = error "simplify"
 
 
 -- sortImage f = sortBy (\x y -> compare (f x) (f y))
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index f9d72bd0..860a0044 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -770,7 +770,7 @@ extractClassDecl c tvs0 (L pos (TypeSig lname ltype)) = case ltype of
   _ -> L pos (TypeSig lname (noLoc (mkImplicitHsForAllTy (lctxt []) ltype)))
   where
     lctxt = noLoc . ctxt
-    ctxt preds = noLoc (HsClassP c (map toTypeNoLoc tvs0)) : preds
+    ctxt preds = nlHsTyConApp c (map toTypeNoLoc tvs0) : preds
 extractClassDecl _ _ _ = error "extractClassDecl: unexpected decl"
 
 
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index f5782eed..cc49cd53 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -17,8 +17,8 @@ import Haddock.GhcUtils
 
 import GHC hiding (NoLink)
 import Name
-import BasicTypes
 import Bag (emptyBag)
+import BasicTypes ( IPName(..), ipNameName )
 
 import Data.List
 import qualified Data.Map as Map hiding ( Map )
@@ -235,6 +235,8 @@ renameType t = case t of
 
   HsListTy ty -> return . HsListTy =<< renameLType ty
   HsPArrTy ty -> return . HsPArrTy =<< renameLType ty
+  HsIParamTy n ty -> liftM2 HsIParamTy (liftM IPName (rename (ipNameName n))) (renameLType ty)
+  HsEqTy ty1 ty2 -> liftM2 HsEqTy (renameLType ty1) (renameLType ty2)
 
   HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts
 
@@ -272,7 +274,7 @@ renameLContext (L loc context) = do
 
 renameInstHead :: InstHead Name -> RnM (InstHead DocName)
 renameInstHead (preds, className, types) = do
-  preds' <- mapM renameLType preds
+  preds' <- mapM renameType preds
   className' <- rename className
   types' <- mapM renameType types
   return (preds', className', types')