diff options
Diffstat (limited to 'haddock-api/src/Haddock/Backends/Hoogle.hs')
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hoogle.hs | 33 |
1 files changed, 12 insertions, 21 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 55075e20..8664db27 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -64,7 +64,8 @@ dropHsDocTy :: HsType a -> HsType a dropHsDocTy = f where g (L src x) = L src (f x) - f (HsForAllTy a b c d e) = HsForAllTy a b c d (g e) + f (HsForAllTy a e) = HsForAllTy a (g e) + f (HsQualTy a e) = HsQualTy a (g e) 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) @@ -81,14 +82,6 @@ outHsType :: OutputableBndr a => DynFlags -> HsType a -> String outHsType dflags = out dflags . dropHsDocTy -makeExplicit :: HsType a -> HsType a -makeExplicit (HsForAllTy _ a b c d) = HsForAllTy Explicit a b c d -makeExplicit x = x - -makeExplicitL :: LHsType a -> LHsType a -makeExplicitL (L src x) = L src (makeExplicit x) - - dropComment :: String -> String dropComment (' ':'-':'-':' ':_) = [] dropComment (x:xs) = x : dropComment xs @@ -120,22 +113,19 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl f (TyClD d@DataDecl{}) = ppData dflags d subdocs f (TyClD d@SynDecl{}) = ppSynonym dflags d f (TyClD d@ClassDecl{}) = ppClass dflags d - f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ [] - f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ [] + f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ + f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ f (SigD sig) = ppSig dflags sig f _ = [] ppExport _ _ = [] ppSig :: DynFlags -> Sig Name -> [String] -ppSig dflags (TypeSig names sig _) +ppSig dflags (TypeSig names sig) = [operator prettyNames ++ " :: " ++ outHsType dflags typ] where prettyNames = intercalate ", " $ map (out dflags) names - typ = case unL sig of - HsForAllTy Explicit a b c d -> HsForAllTy Implicit a b c d - HsForAllTy Qualified a b c d -> HsForAllTy Implicit a b c d - x -> x + typ = unL (hsSigType sig) ppSig _ _ = [] @@ -144,12 +134,13 @@ ppClass :: DynFlags -> TyClDecl Name -> [String] ppClass dflags x = out dflags x{tcdSigs=[]} : concatMap (ppSig dflags . addContext . unL) (tcdSigs x) where - addContext (TypeSig name (L l sig) nwcs) = TypeSig name (L l $ f sig) nwcs + addContext (TypeSig name sig) = TypeSig name (mkHsSigType (f (hsSigType sig))) addContext (MinimalSig src sig) = MinimalSig src sig addContext _ = error "expected TypeSig" - f (HsForAllTy a b c con d) = HsForAllTy a b c (reL (context : unLoc con)) d - f t = HsForAllTy Implicit Nothing emptyHsQTvs (reL [context]) (reL t) + f (L _ (HsForAllTy a ty)) = reL (HsForallTy a (f ty)) + f (L _ (HsQualTy cxt ty)) = HsQualTy (reL (context : unLoc cxt)) ty + f ty = HsQualTy (reL [context]) ty context = nlHsTyConApp (tcdName x) (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars x))) @@ -194,10 +185,10 @@ ppCtor dflags dat subdocs con [out dflags (map (selectorFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] | r <- map unLoc recs] - funs = foldr1 (\x y -> reL $ HsFunTy (makeExplicitL x) (makeExplicitL y)) + funs = foldr1 (\x y -> reL $ HsFunTy x y) apps = foldl1 (\x y -> reL $ HsAppTy x y) - typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (makeExplicit $ unL $ funs flds) + typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds) name = out dflags $ map unL $ con_names con resType = case con_res con of |