From ec20bd15e724d580a01d9fad98791bb53db5e57c Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Tue, 27 Oct 2015 17:34:18 +0000 Subject: Follow changes to HsTYpe Not yet complete (but on a wip/ branch) --- haddock-api/src/Haddock/Backends/Hoogle.hs | 31 +++++++++++------------------- 1 file changed, 11 insertions(+), 20 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 8664db27..b7dfad64 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -113,38 +113,29 @@ 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 _ _)) = pp_sig dflags [name] (hsSigType typ) + f (ForD (ForeignExport name typ _ _)) = pp_sig dflags [name] (hsSigType typ) f (SigD sig) = ppSig dflags sig f _ = [] ppExport _ _ = [] ppSig :: DynFlags -> Sig Name -> [String] -ppSig dflags (TypeSig names sig) - = [operator prettyNames ++ " :: " ++ outHsType dflags typ] - where - prettyNames = intercalate ", " $ map (out dflags) names - typ = unL (hsSigType sig) +ppSig dflags (TypeSig names sig) = pp_sig dflags names (hsSigWcType sig) ppSig _ _ = [] +pp_sig :: DynFlags -> [Located Name] -> LHsType Name -> [String] +pp_sig dflags names (L _ typ) + = [operator prettyNames ++ " :: " ++ outHsType dflags typ] + where + prettyNames = intercalate ", " $ map (out dflags) names -- note: does not yet output documentation for class methods ppClass :: DynFlags -> TyClDecl Name -> [String] ppClass dflags x = out dflags x{tcdSigs=[]} : - concatMap (ppSig dflags . addContext . unL) (tcdSigs x) - where - addContext (TypeSig name sig) = TypeSig name (mkHsSigType (f (hsSigType sig))) - addContext (MinimalSig src sig) = MinimalSig src sig - addContext _ = error "expected TypeSig" - - 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))) - + concatMap (ppSig dflags . unL . add_ctxt) (tcdSigs x) + where + add_ctxt = addClassContext (tcdName x) (tyClDeclTyVars x) ppInstance :: DynFlags -> ClsInst -> [String] ppInstance dflags x = [dropComment $ out dflags x] -- cgit v1.2.3