aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Backends/Hoogle.hs
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock/Backends/Hoogle.hs')
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs10
1 files changed, 6 insertions, 4 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 27a7d804..75a49036 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -36,6 +36,8 @@ import Data.Version
import System.Directory
import System.FilePath
+import GHC.Core.Multiplicity
+
prefix :: [String]
prefix = ["-- Hoogle documentation, generated by Haddock"
,"-- See Hoogle, http://www.haskell.org/hoogle/"
@@ -76,7 +78,7 @@ dropHsDocTy = f
f (HsBangTy x a b) = HsBangTy x a (g b)
f (HsAppTy x a b) = HsAppTy x (g a) (g b)
f (HsAppKindTy x a b) = HsAppKindTy x (g a) (g b)
- f (HsFunTy x a b) = HsFunTy x (g a) (g b)
+ f (HsFunTy x w a b) = HsFunTy x w (g a) (g b)
f (HsListTy x a) = HsListTy x (g a)
f (HsTupleTy x a b) = HsTupleTy x a (map g b)
f (HsOpTy x a b c) = HsOpTy x (g a) b (g c)
@@ -236,14 +238,14 @@ ppCtor dflags dat subdocs con@ConDeclH98 {}
-- AZ:TODO get rid of the concatMap
= concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConArgs con)
where
- f (PrefixCon args) = [typeSig name $ args ++ [resType]]
+ f (PrefixCon args) = [typeSig name $ (map hsScaledThing args) ++ [resType]]
f (InfixCon a1 a2) = f $ PrefixCon [a1,a2]
- f (RecCon (L _ recs)) = f (PrefixCon $ map cd_fld_type (map unLoc recs)) ++ concat
+ f (RecCon (L _ recs)) = f (PrefixCon $ map (hsLinear . cd_fld_type . unLoc) recs) ++ concat
[(concatMap (lookupCon dflags subdocs . noLoc . extFieldOcc . unLoc) (cd_fld_names r)) ++
[out dflags (map (extFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]
| r <- map unLoc recs]
- funs = foldr1 (\x y -> reL $ HsFunTy noExtField x y)
+ funs = foldr1 (\x y -> reL $ HsFunTy noExtField HsUnrestrictedArrow x y)
apps = foldl1 (\x y -> reL $ HsAppTy noExtField x y)
typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds)