diff options
Diffstat (limited to 'haddock-api/src/Haddock/Backends/Hoogle.hs')
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hoogle.hs | 69 |
1 files changed, 35 insertions, 34 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index a89ac2c7..885c608b 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Backends.Hoogle @@ -75,23 +76,22 @@ dropHsDocTy :: HsType a -> HsType a dropHsDocTy = f where g (L src x) = L src (f x) - 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) - 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 _) = f $ unL a + f (HsForAllTy x a e) = HsForAllTy x a (g e) + f (HsQualTy x a e) = HsQualTy x a (g e) + f (HsBangTy x a b) = HsBangTy x a (g b) + f (HsAppTy x a b) = HsAppTy x (g a) (g b) + f (HsFunTy x a b) = HsFunTy x (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) + f (HsParTy x a) = HsParTy x (g a) + f (HsKindSig x a b) = HsKindSig x (g a) b + f (HsDocTy _ a _) = f $ unL a f x = x -outHsType :: (SourceTextX a, OutputableBndrId a) +outHsType :: (a ~ GhcPass p, OutputableBndrId a) => DynFlags -> HsType a -> String -outHsType dflags = out dflags . dropHsDocTy +outHsType dflags = out dflags . reparenType . dropHsDocTy dropComment :: String -> String @@ -127,20 +127,20 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl , expItemFixities = fixities } = ppDocumentation dflags dc ++ f decl ++ ppFixities where - f (TyClD d@DataDecl{}) = ppData dflags d subdocs - f (TyClD d@SynDecl{}) = ppSynonym dflags d - f (TyClD d@ClassDecl{}) = ppClass dflags d subdocs - f (TyClD (FamDecl d)) = ppFam dflags d - 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 (TyClD _ d@DataDecl{}) = ppData dflags d subdocs + f (TyClD _ d@SynDecl{}) = ppSynonym dflags d + f (TyClD _ d@ClassDecl{}) = ppClass dflags d subdocs + f (TyClD _ (FamDecl _ d)) = ppFam dflags d + 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 _ = [] ppFixities = concatMap (ppFixity dflags) fixities ppExport _ _ = [] ppSigWithDoc :: DynFlags -> Sig GhcRn -> [(Name, DocForDecl Name)] -> [String] -ppSigWithDoc dflags (TypeSig names sig) subdocs +ppSigWithDoc dflags (TypeSig _ names sig) subdocs = concatMap mkDocSig names where mkDocSig n = mkSubdoc dflags n subdocs [pp_sig dflags [n] (hsSigWcType sig)] @@ -191,7 +191,7 @@ ppClass dflags decl subdocs = , tcdTyVars = feqn_pats tfe , tcdFixity = feqn_fixity tfe , tcdRhs = feqn_rhs tfe - , tcdFVs = emptyNameSet + , tcdSExt = emptyNameSet } ppFam :: DynFlags -> FamilyDecl GhcRn -> [String] @@ -203,6 +203,7 @@ ppFam dflags decl@(FamilyDecl { fdInfo = info }) -- for Hoogle, so pretend it doesn't have any. ClosedTypeFamily{} -> decl { fdInfo = OpenTypeFamily } _ -> decl +ppFam _ XFamilyDecl {} = panic "ppFam" ppInstance :: DynFlags -> ClsInst -> [String] ppInstance dflags x = @@ -242,17 +243,17 @@ lookupCon dflags subdocs (L _ name) = case lookup name subdocs of ppCtor :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> ConDecl GhcRn -> [String] ppCtor dflags dat subdocs con@ConDeclH98 {} -- AZ:TODO get rid of the concatMap - = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConDetails con) + = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConArgs con) where f (PrefixCon args) = [typeSig name $ args ++ [resType]] f (InfixCon a1 a2) = f $ PrefixCon [a1,a2] f (RecCon (L _ recs)) = f (PrefixCon $ map cd_fld_type (map unLoc recs)) ++ concat - [(concatMap (lookupCon dflags subdocs . noLoc . selectorFieldOcc . unLoc) (cd_fld_names r)) ++ - [out dflags (map (selectorFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] + [(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 x y) - apps = foldl1 (\x y -> reL $ HsAppTy x y) + funs = foldr1 (\x y -> reL $ HsFunTy NoExt x y) + apps = foldl1 (\x y -> reL $ HsAppTy NoExt x y) typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds) @@ -260,20 +261,20 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} -- docs for con_names on why it is a list to begin with. name = commaSeparate dflags . map unL $ getConNames con - resType = apps $ map (reL . HsTyVar NotPromoted . reL) $ - (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvExplicit $ tyClDeclTyVars dat] + resType = apps $ map (reL . HsTyVar NoExt NotPromoted . reL) $ + (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _ _) <- hsQTvExplicit $ tyClDeclTyVars dat] -ppCtor dflags _dat subdocs con@ConDeclGADT {} +ppCtor dflags _dat subdocs con@(ConDeclGADT { }) = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f where - f = [typeSig name (hsib_body $ con_type con)] + f = [typeSig name (getGADTConTypeG con)] typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unL ty) name = out dflags $ map unL $ getConNames con - +ppCtor _ _ _ XConDecl {} = panic "haddock:ppCtor" ppFixity :: DynFlags -> (Name, Fixity) -> [String] -ppFixity dflags (name, fixity) = [out dflags ((FixitySig [noLoc name] fixity) :: FixitySig GhcRn)] +ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExt [noLoc name] fixity) :: FixitySig GhcRn)] --------------------------------------------------------------------- |