Merge pull request #1204 from wz1000/wip/haddock-hstocore

Use functions exported from GHC.HsToCore.Docs

Author: bgamari

haddock-api/src/Haddock/GhcUtils.hs

@@ -56,32 +56,6 @@ moduleString = moduleNameString . moduleName
 isNameSym :: Name -> Bool
 isNameSym = isSymOcc . nameOccName
 
-getMainDeclBinder :: (CollectPass (GhcPass p)) => HsDecl (GhcPass p) -> [IdP (GhcPass p)]
-getMainDeclBinder (TyClD _ d) = [tcdName d]
-getMainDeclBinder (ValD _ d) =
-  case collectHsBindBinders d of
-    []       -> []
-    (name:_) -> [name]
-getMainDeclBinder (SigD _ d) = sigNameNoLoc d
-getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name]
-getMainDeclBinder (ForD _ (ForeignExport _ _ _ _)) = []
-getMainDeclBinder _ = []
-
--- Extract the source location where an instance is defined. This is used
--- to correlate InstDecls with their Instance/CoAxiom Names, via the
--- instanceMap.
-getInstLoc :: InstDecl (GhcPass p) -> SrcSpan
-getInstLoc (ClsInstD _ (ClsInstDecl { cid_poly_ty = ty })) = getLoc (hsSigType ty)
-getInstLoc (DataFamInstD _ (DataFamInstDecl
-  { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}})) = l
-getInstLoc (TyFamInstD _ (TyFamInstDecl
-  -- Since CoAxioms' Names refer to the whole line for type family instances
-  -- in particular, we need to dig a bit deeper to pull out the entire
-  -- equation. This does not happen for data family instances, for some reason.
-  { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = L l _ }}})) = l
-
-
-
 -- Useful when there is a signature with multiple names, e.g.
 --   foo, bar :: Types..
 -- but only one of the names is exported and we have to change the
@@ -139,24 +113,9 @@ isClassD :: HsDecl a -> Bool
 isClassD (TyClD _ d) = isClassDecl d
 isClassD _ = False
 
-isValD :: HsDecl a -> Bool
-isValD (ValD _ _) = True
-isValD _ = False
-
 pretty :: Outputable a => DynFlags -> a -> String
 pretty = showPpr
 
-nubByName :: (a -> Name) -> [a] -> [a]
-nubByName f ns = go emptyNameSet ns
-  where
-    go !_ [] = []
-    go !s (x:xs)
-      | y `elemNameSet` s = go s xs
-      | otherwise         = let !s' = extendNameSet s y
-                            in x : go s' xs
-      where
-        y = f x
-
 -- ---------------------------------------------------------------------
 
 -- These functions are duplicated from the GHC API, as they must be

haddock-api/src/Haddock/Interface.hs

@@ -61,6 +61,7 @@ import GHC.Types.Name (nameIsFromExternalPackage, nameOccName)
 import GHC.Types.Name.Occurrence (isTcOcc)
 import GHC.Types.Name.Reader (unQualOK, gre_name, globalRdrEnvElts)
 import GHC.Utils.Error (withTimingD)
+import GHC.HsToCore.Docs
 
 #if defined(mingw32_HOST_OS)
 import System.IO

haddock-api/src/Haddock/Interface/AttachInstances.hs

@@ -44,6 +44,7 @@ import GHC.Core.TyCon
 import GHC.Core.TyCo.Rep
 import GHC.Builtin.Types.Prim( funTyConName )
 import GHC.Types.Var hiding (varName)
+import GHC.HsToCore.Docs
 
 type ExportedNames = Set.Set Name
 type Modules = Set.Set Module

haddock-api/src/Haddock/Interface/Create.hs

@@ -55,6 +55,7 @@ import GHC.Tc.Types
 import GHC.Data.FastString ( unpackFS, bytesFS )
 import GHC.Types.Basic ( StringLiteral(..), SourceText(..), PromotionFlag(..) )
 import qualified GHC.Utils.Outputable as O
+import GHC.HsToCore.Docs hiding (mkMaps)
 
 import GHC.Core.Multiplicity
 
@@ -436,109 +437,6 @@ mkMaps dflags pkgName gre instances decls = do
 --------------------------------------------------------------------------------
 
 
--- | Get all subordinate declarations inside a declaration, and their docs.
--- A subordinate declaration is something like the associate type or data
--- family of a type class.
-subordinates :: InstMap
-             -> HsDecl GhcRn
-             -> [(Name, [HsDocString], Map Int HsDocString)]
-subordinates instMap decl = case decl of
-  InstD _ (ClsInstD _ d) -> do
-    DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
-      FamEqn { feqn_tycon = L l _
-             , feqn_rhs   = defn }}} <- unLoc <$> cid_datafam_insts d
-    [ (n, [], M.empty) | Just n <- [SrcLoc.lookupSrcSpan l instMap] ] ++ dataSubs defn
-
-  InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = d })))
-    -> dataSubs (feqn_rhs d)
-  TyClD _ d | isClassDecl d -> classSubs d
-            | isDataDecl  d -> dataSubs (tcdDataDefn d)
-  _ -> []
-  where
-    classSubs dd = [ (name, doc, declTypeDocs d) | (L _ d, doc) <- classDecls dd
-                   , name <- getMainDeclBinder d, not (isValD d)
-                   ]
-    dataSubs :: HsDataDefn GhcRn -> [(Name, [HsDocString], Map Int HsDocString)]
-    dataSubs dd = constrs ++ fields ++ derivs
-      where
-        cons = map unL $ (dd_cons dd)
-        constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, conArgDocs c)
-                  | c <- cons, cname <- getConNames c ]
-        fields  = [ (extFieldOcc n, maybeToList $ fmap unL doc, M.empty)
-                  | RecCon flds <- map getConArgs cons
-                  , L _ (ConDeclField _ ns _ doc) <- (unLoc flds)
-                  , L _ n <- ns ]
-        derivs  = [ (instName, [unL doc], M.empty)
-                  | (l, doc) <- mapMaybe (extract_deriv_ty . hsib_body) $
-                                concatMap (unLoc . deriv_clause_tys . unLoc) $
-                                unLoc $ dd_derivs dd
-                  , Just instName <- [SrcLoc.lookupSrcSpan l instMap] ]
-
-        extract_deriv_ty :: LHsType GhcRn -> Maybe (SrcSpan, LHsDocString)
-        extract_deriv_ty (L l ty) =
-          case ty of
-            -- deriving (forall a. C a {- ^ Doc comment -})
-            HsForAllTy{ hst_tele = HsForAllInvis{}
-                      , hst_body = L _ (HsDocTy _ _ doc) }
-                            -> Just (l, doc)
-            -- deriving (C a {- ^ Doc comment -})
-            HsDocTy _ _ doc -> Just (l, doc)
-            _               -> Nothing
-
--- | Extract constructor argument docs from inside constructor decls.
-conArgDocs :: ConDecl GhcRn -> Map Int HsDocString
-conArgDocs con = case getConArgs con of
-                   PrefixCon args -> go 0 (map (unLoc . hsScaledThing) args ++ ret)
-                   InfixCon arg1 arg2 -> go 0 ([unLoc (hsScaledThing arg1),
-                                                unLoc (hsScaledThing arg2)] ++ ret)
-                   RecCon _ -> go 1 ret
-  where
-    go n (HsDocTy _ _ (L _ ds) : tys) = M.insert n ds $ go (n+1) tys
-    go n (HsBangTy _ _ (L _ (HsDocTy _ _ (L _ ds))) : tys) = M.insert n ds $ go (n+1) tys
-    go n (_ : tys) = go (n+1) tys
-    go _ [] = M.empty
-
-    ret = case con of
-            ConDeclGADT { con_res_ty = res_ty } -> [ unLoc res_ty ]
-            _ -> []
-
--- | Extract function argument docs from inside top-level decls.
-declTypeDocs :: HsDecl GhcRn -> Map Int HsDocString
-declTypeDocs (SigD  _ (TypeSig _ _ ty))          = typeDocs (unLoc (hsSigWcType ty))
-declTypeDocs (SigD  _ (ClassOpSig _ _ _ ty))     = typeDocs (unLoc (hsSigType ty))
-declTypeDocs (SigD  _ (PatSynSig _ _ ty))        = typeDocs (unLoc (hsSigType ty))
-declTypeDocs (ForD  _ (ForeignImport _ _ ty _))  = typeDocs (unLoc (hsSigType ty))
-declTypeDocs (TyClD _ (SynDecl { tcdRhs = ty })) = typeDocs (unLoc ty)
-declTypeDocs _ = M.empty
-
--- | Extract function argument docs from inside types.
-typeDocs :: HsType GhcRn -> Map Int HsDocString
-typeDocs = go 0
-  where
-    go n (HsForAllTy { hst_body = ty }) = go n (unLoc ty)
-    go n (HsQualTy   { hst_body = ty }) = go n (unLoc ty)
-    go n (HsFunTy _ _w (L _ (HsDocTy _ _ (L _ x))) (L _ ty)) = M.insert n x $ go (n+1) ty
-    go n (HsFunTy _ _ _ ty) = go (n+1) (unLoc ty)
-    go n (HsDocTy _ _ (L _ doc)) = M.singleton n doc
-    go _ _ = M.empty
-
--- | All the sub declarations of a class (that we handle), ordered by
--- source location, with documentation attached if it exists.
-classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
-classDecls class_ = filterDecls . collectDocs . SrcLoc.sortLocated $ decls
-  where
-    decls = docs ++ defs ++ sigs ++ ats
-    docs  = mkDecls tcdDocs (DocD noExtField) class_
-    defs  = mkDecls (bagToList . tcdMeths) (ValD noExtField) class_
-    sigs  = mkDecls tcdSigs (SigD noExtField) class_
-    ats   = mkDecls tcdATs (TyClD noExtField . FamDecl noExtField) class_
-
-
--- | The top-level declarations of a module that we care about,
--- ordered by source location, with documentation attached if it exists.
-topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
-topDecls =
-  filterClasses . filterDecls . collectDocs . SrcLoc.sortLocated . ungroup
 
 -- | Extract a map of fixity declarations only
 mkFixMap :: HsGroup GhcRn -> FixMap
@@ -548,86 +446,6 @@ mkFixMap group_ =
                L _ n <- ns ]
 
 
--- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'.
-ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn]
-ungroup group_ =
-  mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExtField)  group_ ++
-  mkDecls hs_derivds             (DerivD noExtField) group_ ++
-  mkDecls hs_defds               (DefD noExtField)   group_ ++
-  mkDecls hs_fords               (ForD noExtField)   group_ ++
-  mkDecls hs_docs                (DocD noExtField)   group_ ++
-  mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExtField)  group_ ++
-  mkDecls (typesigs . hs_valds)  (SigD noExtField)   group_ ++
-  mkDecls (valbinds . hs_valds)  (ValD noExtField)   group_
-  where
-    typesigs (XValBindsLR (NValBinds _ sigs)) = filter isUserLSig sigs
-    typesigs _ = error "expected ValBindsOut"
-
-    valbinds (XValBindsLR (NValBinds binds _)) = concatMap bagToList . snd . unzip $ binds
-    valbinds _ = error "expected ValBindsOut"
-
-
--- | Take a field of declarations from a data structure and create HsDecls
--- using the given constructor
-mkDecls :: (a -> [Located b]) -> (b -> c) -> a -> [Located c]
-mkDecls field con struct = [ L loc (con decl) | L loc decl <- field struct ]
-
---------------------------------------------------------------------------------
--- Filtering of declarations
---
--- We filter out declarations that we don't intend to handle later.
---------------------------------------------------------------------------------
-
-
--- | Filter out declarations that we don't handle in Haddock
-filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
-filterDecls = filter (isHandled . unL . fst)
-  where
-    isHandled (ForD _ (ForeignImport {})) = True
-    isHandled (TyClD {})  = True
-    isHandled (InstD {})  = True
-    isHandled (DerivD {}) = True
-    isHandled (SigD _ d)  = isUserLSig (reL d)
-    isHandled (ValD {})   = True
-    -- we keep doc declarations to be able to get at named docs
-    isHandled (DocD {})   = True
-    isHandled _ = False
-
--- | Go through all class declarations and filter their sub-declarations
-filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
-filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x
-                      | x@(L loc d, doc) <- decls ]
-  where
-    filterClass (TyClD x c) =
-      TyClD x $ c { tcdSigs = filter (liftA2 (||) isUserLSig isMinimalLSig) $ tcdSigs c }
-    filterClass _ = error "expected TyClD"
-
-
---------------------------------------------------------------------------------
--- Collect docs
---
--- To be able to attach the right Haddock comment to the right declaration,
--- we sort the declarations by their SrcLoc and "collect" the docs for each
--- declaration.
---------------------------------------------------------------------------------
-
-
--- | Collect docs and attach them to the right declarations.
-collectDocs :: [LHsDecl a] -> [(LHsDecl a, [HsDocString])]
-collectDocs = go Nothing []
-  where
-    go Nothing _ [] = []
-    go (Just prev) docs [] = finished prev docs []
-    go prev docs (L _ (DocD _ (DocCommentNext str)) : ds)
-      | Nothing <- prev = go Nothing (str:docs) ds
-      | Just decl <- prev = finished decl docs (go Nothing [str] ds)
-    go prev docs (L _ (DocD _ (DocCommentPrev str)) : ds) = go prev (str:docs) ds
-    go Nothing docs (d:ds) = go (Just d) docs ds
-    go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds)
-
-    finished decl docs rest = (decl, reverse docs) : rest
-
-
 -- | Build the list of items that will become the documentation, from the
 -- export list.  At this point, the list of ExportItems is in terms of
 -- original names.

haddock-api/src/Haddock/Interface/Rename.hs

@@ -31,6 +31,7 @@ import Control.Monad hiding (mapM)
 import Data.List
 import qualified Data.Map as Map hiding ( Map )
 import Prelude hiding (mapM)
+import GHC.HsToCore.Docs
 
 renameInterface :: DynFlags -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface
 renameInterface dflags renamingEnv warnings iface =