Drop HsDocTy annotations, they mess up pretty printing and also have a bracketing bug (#2584)

1 files changed, 29 insertions, 9 deletions

diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
index dfd72758..8b184a54 100644
--- a/src/Haddock/Backends/Hoogle.hs
+++ b/src/Haddock/Backends/Hoogle.hs
@@ -54,6 +54,26 @@ ppModule iface = "" : doc (ifaceDoc iface) ++
 ---------------------------------------------------------------------
 -- Utility functions
 
+dropHsDocTy :: HsType a -> HsType a
+dropHsDocTy = f
+    where
+        g (L src x) = L src (f x)
+        f (HsForAllTy a b c d) = HsForAllTy a b c (g d)
+        f (HsBangTy a b) = HsBangTy a (g b)
+        f (HsAppTy a b) = HsAppTy (g a) (g b)
+        f (HsFunTy a b) = HsFunTy (g a) (g b)
+        f (HsListTy a) = HsListTy (g a)
+        f (HsPArrTy a) = HsPArrTy (g a)
+        f (HsTupleTy a b) = HsTupleTy a (map g b)
+        f (HsOpTy a b c) = HsOpTy (g a) b (g c)
+        f (HsParTy a) = HsParTy (g a)
+        f (HsKindSig a b) = HsKindSig (g a) b
+        f (HsDocTy a b) = f $ unL a
+        f x = x
+
+outHsType :: OutputableBndr a => HsType a -> String
+outHsType = out . dropHsDocTy
+
 
 dropComment (' ':'-':'-':' ':_) = []
 dropComment (x:xs) = x : dropComment xs
@@ -68,10 +88,6 @@ out = f . unwords . map (dropWhile isSpace) . lines . showSDocUnqual . ppr
         f [] = []
 
 
-typeSig :: String -> [String] -> String
-typeSig name flds = operator name ++ " :: " ++ concat (intersperse " -> " flds)
-
-
 operator :: String -> String
 operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = "(" ++ x:xs ++ ")"
 operator x = x
@@ -94,7 +110,7 @@ ppExport _ = []
 
 
 ppSig :: Sig Name -> [String]
-ppSig (TypeSig name sig) = [operator (out name) ++ " :: " ++ out typ]
+ppSig (TypeSig name sig) = [operator (out name) ++ " :: " ++ outHsType typ]
     where
         typ = case unL sig of
                    HsForAllTy Explicit a b c -> HsForAllTy Implicit a b c
@@ -142,18 +158,22 @@ ppData x = showData x{tcdCons=[],tcdDerivs=Nothing} :
 ppCtor :: TyClDecl Name -> ConDecl Name -> [String]
 ppCtor dat con = ldoc (con_doc con) ++ f (con_details con)
     where
-        f (PrefixCon args) = [typeSig name $ map out args ++ [resType]]
+        f (PrefixCon args) = [typeSig name $ args ++ [resType]]
         f (InfixCon a1 a2) = f $ PrefixCon [a1,a2]
         f (RecCon recs) = f (PrefixCon $ map cd_fld_type recs) ++ concat
                           [ldoc (cd_fld_doc r) ++
-                           [out (unL $ cd_fld_name r) `typeSig` [resType, out $ cd_fld_type r]]
+                           [out (unL $ cd_fld_name r) `typeSig` [resType, cd_fld_type r]]
                           | r <- recs]
 
+        funs = foldr1 (\x y -> reL $ HsFunTy x y)
+        apps = foldl1 (\x y -> reL $ HsAppTy x y)
+
+        typeSig name flds = operator name ++ " :: " ++ outHsType (unL $ funs flds)
         name = out $ unL $ con_name con
 
         resType = case con_res con of
-            ResTyH98 -> unwords $ operator (out (tcdLName dat)) : map out (tcdTyVars dat)
-            ResTyGADT x -> out $ unL x
+            ResTyH98 -> apps $ map (reL . HsTyVar) $ unL (tcdLName dat) : [x | UserTyVar x <- map unL $ tcdTyVars dat]
+            ResTyGADT x -> x
 
 
 ---------------------------------------------------------------------