aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Interface
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock/Interface')
-rw-r--r--haddock-api/src/Haddock/Interface/AttachInstances.hs221
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs867
-rw-r--r--haddock-api/src/Haddock/Interface/LexParseRn.hs146
-rw-r--r--haddock-api/src/Haddock/Interface/ParseModuleHeader.hs150
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs506
5 files changed, 1890 insertions, 0 deletions
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
new file mode 100644
index 00000000..a0bac8fc
--- /dev/null
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -0,0 +1,221 @@
+{-# LANGUAGE CPP, MagicHash #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.Interface.AttachInstances
+-- Copyright : (c) Simon Marlow 2006,
+-- David Waern 2006-2009,
+-- Isaac Dupree 2009
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+-----------------------------------------------------------------------------
+module Haddock.Interface.AttachInstances (attachInstances) where
+
+
+import Haddock.Types
+import Haddock.Convert
+import Haddock.GhcUtils
+
+import Control.Arrow
+import Data.List
+import Data.Ord (comparing)
+import Data.Function (on)
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+
+import Class
+import FamInstEnv
+import FastString
+import GHC
+import GhcMonad (withSession)
+import Id
+import InstEnv
+import MonadUtils (liftIO)
+import Name
+import PrelNames
+import TcRnDriver (tcRnGetInfo)
+import TcType (tcSplitSigmaTy)
+import TyCon
+import TypeRep
+import TysPrim( funTyCon )
+import Var hiding (varName)
+#define FSLIT(x) (mkFastString# (x#))
+
+type ExportedNames = Set.Set Name
+type Modules = Set.Set Module
+type ExportInfo = (ExportedNames, Modules)
+
+-- Also attaches fixities
+attachInstances :: ExportInfo -> [Interface] -> InstIfaceMap -> Ghc [Interface]
+attachInstances expInfo ifaces instIfaceMap = mapM attach ifaces
+ where
+ -- TODO: take an IfaceMap as input
+ ifaceMap = Map.fromList [ (ifaceMod i, i) | i <- ifaces ]
+
+ attach iface = do
+ newItems <- mapM (attachToExportItem expInfo iface ifaceMap instIfaceMap)
+ (ifaceExportItems iface)
+ return $ iface { ifaceExportItems = newItems }
+
+
+attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> ExportItem Name -> Ghc (ExportItem Name)
+attachToExportItem expInfo iface ifaceMap instIfaceMap export =
+ case attachFixities export of
+ e@ExportDecl { expItemDecl = L _ (TyClD d) } -> do
+ mb_info <- getAllInfo (tcdName d)
+ let export' =
+ e {
+ expItemInstances =
+ case mb_info of
+ Just (_, _, cls_instances, fam_instances) ->
+ let fam_insts = [ (synifyFamInst i opaque, n)
+ | i <- sortBy (comparing instFam) fam_instances
+ , let n = instLookup instDocMap (getName i) iface ifaceMap instIfaceMap
+ , not $ isNameHidden expInfo (fi_fam i)
+ , not $ any (isTypeHidden expInfo) (fi_tys i)
+ , let opaque = isTypeHidden expInfo (fi_rhs i)
+ ]
+ cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap)
+ | let is = [ (instanceHead' i, getName i) | i <- cls_instances ]
+ , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is
+ , not $ isInstanceHidden expInfo cls tys
+ ]
+ in cls_insts ++ fam_insts
+ Nothing -> []
+ }
+ return export'
+ e -> return e
+ where
+ attachFixities e@ExportDecl{ expItemDecl = L _ d } = e { expItemFixities =
+ nubBy ((==) `on` fst) $ expItemFixities e ++
+ [ (n',f) | n <- getMainDeclBinder d
+ , Just subs <- [instLookup instSubMap n iface ifaceMap instIfaceMap]
+ , n' <- n : subs
+ , Just f <- [instLookup instFixMap n' iface ifaceMap instIfaceMap]
+ ] }
+
+ attachFixities e = e
+
+
+instLookup :: (InstalledInterface -> Map.Map Name a) -> Name
+ -> Interface -> IfaceMap -> InstIfaceMap -> Maybe a
+instLookup f name iface ifaceMap instIfaceMap =
+ case Map.lookup name (f $ toInstalledIface iface) of
+ res@(Just _) -> res
+ Nothing -> do
+ let ifaceMaps = Map.union (fmap toInstalledIface ifaceMap) instIfaceMap
+ iface' <- Map.lookup (nameModule name) ifaceMaps
+ Map.lookup name (f iface')
+
+-- | Like GHC's 'instanceHead' but drops "silent" arguments.
+instanceHead' :: ClsInst -> ([TyVar], ThetaType, Class, [Type])
+instanceHead' ispec = (tvs, dropSilentArgs dfun theta, cls, tys)
+ where
+ dfun = is_dfun ispec
+ (tvs, cls, tys) = instanceHead ispec
+ (_, theta, _) = tcSplitSigmaTy (idType dfun)
+
+-- | Drop "silent" arguments. See GHC Note [Silent superclass
+-- arguments].
+dropSilentArgs :: DFunId -> ThetaType -> ThetaType
+dropSilentArgs dfun theta = drop (dfunNSilent dfun) theta
+
+
+-- | Like GHC's getInfo but doesn't cut things out depending on the
+-- interative context, which we don't set sufficiently anyway.
+getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst]))
+getAllInfo name = withSession $ \hsc_env -> do
+ (_msgs, r) <- liftIO $ tcRnGetInfo hsc_env name
+ return r
+
+
+--------------------------------------------------------------------------------
+-- Collecting and sorting instances
+--------------------------------------------------------------------------------
+
+
+-- | Simplified type for sorting types, ignoring qualification (not visible
+-- in Haddock output) and unifying special tycons with normal ones.
+-- For the benefit of the user (looks nice and predictable) and the
+-- tests (which prefer output to be deterministic).
+data SimpleType = SimpleType Name [SimpleType]
+ | SimpleTyLit TyLit
+ deriving (Eq,Ord)
+
+
+instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], Name, [SimpleType])
+instHead (_, _, cls, args)
+ = (map argCount args, className cls, map simplify args)
+
+argCount :: Type -> Int
+argCount (AppTy t _) = argCount t + 1
+argCount (TyConApp _ ts) = length ts
+argCount (FunTy _ _ ) = 2
+argCount (ForAllTy _ t) = argCount t
+argCount _ = 0
+
+simplify :: Type -> SimpleType
+simplify (ForAllTy _ t) = simplify t
+simplify (FunTy t1 t2) = SimpleType funTyConName [simplify t1, simplify t2]
+simplify (AppTy t1 t2) = SimpleType s (ts ++ [simplify t2])
+ where (SimpleType s ts) = simplify t1
+simplify (TyVarTy v) = SimpleType (tyVarName v) []
+simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts)
+simplify (LitTy l) = SimpleTyLit l
+
+-- Used for sorting
+instFam :: FamInst -> ([Int], Name, [SimpleType], Int, SimpleType)
+instFam FamInst { fi_fam = n, fi_tys = ts, fi_rhs = t }
+ = (map argCount ts, n, map simplify ts, argCount t, simplify t)
+
+
+funTyConName :: Name
+funTyConName = mkWiredInName gHC_PRIM
+ (mkOccNameFS tcName FSLIT("(->)"))
+ funTyConKey
+ (ATyCon funTyCon) -- Relevant TyCon
+ BuiltInSyntax
+
+--------------------------------------------------------------------------------
+-- Filtering hidden instances
+--------------------------------------------------------------------------------
+
+-- | A class or data type is hidden iff
+--
+-- * it is defined in one of the modules that are being processed
+--
+-- * and it is not exported by any non-hidden module
+isNameHidden :: ExportInfo -> Name -> Bool
+isNameHidden (names, modules) name =
+ nameModule name `Set.member` modules &&
+ not (name `Set.member` names)
+
+-- | We say that an instance is «hidden» iff its class or any (part)
+-- of its type(s) is hidden.
+isInstanceHidden :: ExportInfo -> Class -> [Type] -> Bool
+isInstanceHidden expInfo cls tys =
+ instClassHidden || instTypeHidden
+ where
+ instClassHidden :: Bool
+ instClassHidden = isNameHidden expInfo $ getName cls
+
+ instTypeHidden :: Bool
+ instTypeHidden = any (isTypeHidden expInfo) tys
+
+isTypeHidden :: ExportInfo -> Type -> Bool
+isTypeHidden expInfo = typeHidden
+ where
+ typeHidden :: Type -> Bool
+ typeHidden t =
+ case t of
+ TyVarTy {} -> False
+ AppTy t1 t2 -> typeHidden t1 || typeHidden t2
+ TyConApp tcon args -> nameHidden (getName tcon) || any typeHidden args
+ FunTy t1 t2 -> typeHidden t1 || typeHidden t2
+ ForAllTy _ ty -> typeHidden ty
+ LitTy _ -> False
+
+ nameHidden :: Name -> Bool
+ nameHidden = isNameHidden expInfo
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
new file mode 100644
index 00000000..b66773ae
--- /dev/null
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -0,0 +1,867 @@
+{-# LANGUAGE CPP, TupleSections, BangPatterns, LambdaCase #-}
+{-# OPTIONS_GHC -Wwarn #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.Interface.Create
+-- Copyright : (c) Simon Marlow 2003-2006,
+-- David Waern 2006-2009,
+-- Mateusz Kowalczyk 2013
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+-----------------------------------------------------------------------------
+module Haddock.Interface.Create (createInterface) where
+
+import Documentation.Haddock.Doc (docAppend)
+import Haddock.Types
+import Haddock.Options
+import Haddock.GhcUtils
+import Haddock.Utils
+import Haddock.Convert
+import Haddock.Interface.LexParseRn
+
+import qualified Data.Map as M
+import Data.Map (Map)
+import Data.List
+import Data.Maybe
+import Data.Monoid
+import Data.Ord
+import Control.Applicative
+import Control.Arrow (second)
+import Control.DeepSeq
+import Control.Monad
+import Data.Function (on)
+import qualified Data.Foldable as F
+
+import qualified Packages
+import qualified Module
+import qualified SrcLoc
+import GHC
+import HscTypes
+import Name
+import Bag
+import RdrName
+import TcRnTypes
+import FastString (concatFS)
+
+
+-- | Use a 'TypecheckedModule' to produce an 'Interface'.
+-- To do this, we need access to already processed modules in the topological
+-- sort. That's what's in the 'IfaceMap'.
+createInterface :: TypecheckedModule -> [Flag] -> IfaceMap -> InstIfaceMap -> ErrMsgGhc Interface
+createInterface tm flags modMap instIfaceMap = do
+
+ let ms = pm_mod_summary . tm_parsed_module $ tm
+ mi = moduleInfo tm
+ L _ hsm = parsedSource tm
+ !safety = modInfoSafe mi
+ mdl = ms_mod ms
+ dflags = ms_hspp_opts ms
+ !instances = modInfoInstances mi
+ !fam_instances = md_fam_insts md
+ !exportedNames = modInfoExports mi
+
+ (TcGblEnv {tcg_rdr_env = gre, tcg_warns = warnings}, md) = tm_internals_ tm
+
+ -- The renamed source should always be available to us, but it's best
+ -- to be on the safe side.
+ (group_, mayExports, mayDocHeader) <-
+ case renamedSource tm of
+ Nothing -> do
+ liftErrMsg $ tell [ "Warning: Renamed source is not available." ]
+ return (emptyRnGroup, Nothing, Nothing)
+ Just (x, _, y, z) -> return (x, y, z)
+
+ opts0 <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl
+ let opts
+ | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0
+ | otherwise = opts0
+
+ (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader
+
+ let declsWithDocs = topDecls group_
+ fixMap = mkFixMap group_
+ (decls, _) = unzip declsWithDocs
+ localInsts = filter (nameIsLocalOrFrom mdl) $ map getName instances
+ ++ map getName fam_instances
+ -- Locations of all TH splices
+ splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ]
+
+ maps@(!docMap, !argMap, !subMap, !declMap, _) =
+ mkMaps dflags gre localInsts declsWithDocs
+
+ let exports0 = fmap (reverse . map unLoc) mayExports
+ exports
+ | OptIgnoreExports `elem` opts = Nothing
+ | otherwise = exports0
+ warningMap = mkWarningMap dflags warnings gre exportedNames
+
+ let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap))
+
+ exportItems <- mkExportItems modMap mdl allWarnings gre exportedNames decls
+ maps fixMap splices exports instIfaceMap dflags
+
+ let !visibleNames = mkVisibleNames maps exportItems opts
+
+ -- Measure haddock documentation coverage.
+ let prunedExportItems0 = pruneExportItems exportItems
+ !haddockable = 1 + length exportItems -- module + exports
+ !haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0
+ !coverage = (haddockable, haddocked)
+
+ -- Prune the export list to just those declarations that have
+ -- documentation, if the 'prune' option is on.
+ let prunedExportItems'
+ | OptPrune `elem` opts = prunedExportItems0
+ | otherwise = exportItems
+ !prunedExportItems = seqList prunedExportItems' `seq` prunedExportItems'
+
+ let !aliases =
+ mkAliasMap dflags $ tm_renamed_source tm
+ modWarn = moduleWarning dflags gre warnings
+
+ return $! Interface {
+ ifaceMod = mdl
+ , ifaceOrigFilename = msHsFilePath ms
+ , ifaceInfo = info
+ , ifaceDoc = Documentation mbDoc modWarn
+ , ifaceRnDoc = Documentation Nothing Nothing
+ , ifaceOptions = opts
+ , ifaceDocMap = docMap
+ , ifaceArgMap = argMap
+ , ifaceRnDocMap = M.empty
+ , ifaceRnArgMap = M.empty
+ , ifaceExportItems = prunedExportItems
+ , ifaceRnExportItems = []
+ , ifaceExports = exportedNames
+ , ifaceVisibleExports = visibleNames
+ , ifaceDeclMap = declMap
+ , ifaceSubMap = subMap
+ , ifaceFixMap = fixMap
+ , ifaceModuleAliases = aliases
+ , ifaceInstances = instances
+ , ifaceFamInstances = fam_instances
+ , ifaceHaddockCoverage = coverage
+ , ifaceWarningMap = warningMap
+ }
+
+mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName
+mkAliasMap dflags mRenamedSource =
+ case mRenamedSource of
+ Nothing -> M.empty
+ Just (_,impDecls,_,_) ->
+ M.fromList $
+ mapMaybe (\(SrcLoc.L _ impDecl) -> do
+ alias <- ideclAs impDecl
+ return $
+ (lookupModuleDyn dflags
+ (fmap Module.fsToPackageId $
+ ideclPkgQual impDecl)
+ (case ideclName impDecl of SrcLoc.L _ name -> name),
+ alias))
+ impDecls
+
+-- similar to GHC.lookupModule
+lookupModuleDyn ::
+ DynFlags -> Maybe PackageId -> ModuleName -> Module
+lookupModuleDyn _ (Just pkgId) mdlName =
+ Module.mkModule pkgId mdlName
+lookupModuleDyn dflags Nothing mdlName =
+ flip Module.mkModule mdlName $
+ case filter snd $
+ Packages.lookupModuleInAllPackages dflags mdlName of
+ (pkgId,_):_ -> Packages.packageConfigId pkgId
+ [] -> Module.mainPackageId
+
+
+-------------------------------------------------------------------------------
+-- Warnings
+-------------------------------------------------------------------------------
+
+mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> WarningMap
+mkWarningMap dflags warnings gre exps = case warnings of
+ NoWarnings -> M.empty
+ WarnAll _ -> M.empty
+ WarnSome ws ->
+ let ws' = [ (n, w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ
+ , let n = gre_name elt, n `elem` exps ]
+ in M.fromList $ map (second $ parseWarning dflags gre) ws'
+
+moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> Maybe (Doc Name)
+moduleWarning _ _ NoWarnings = Nothing
+moduleWarning _ _ (WarnSome _) = Nothing
+moduleWarning dflags gre (WarnAll w) = Just $ parseWarning dflags gre w
+
+parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> Doc Name
+parseWarning dflags gre w = force $ case w of
+ DeprecatedTxt msg -> format "Deprecated: " (concatFS msg)
+ WarningTxt msg -> format "Warning: " (concatFS msg)
+ where
+ format x xs = DocWarning . DocParagraph . DocAppend (DocString x)
+ . processDocString dflags gre $ HsDocString xs
+
+
+-------------------------------------------------------------------------------
+-- Doc options
+--
+-- Haddock options that are embedded in the source file
+-------------------------------------------------------------------------------
+
+
+mkDocOpts :: Maybe String -> [Flag] -> Module -> ErrMsgM [DocOption]
+mkDocOpts mbOpts flags mdl = do
+ opts <- case mbOpts of
+ Just opts -> case words $ replace ',' ' ' opts of
+ [] -> tell ["No option supplied to DOC_OPTION/doc_option"] >> return []
+ xs -> liftM catMaybes (mapM parseOption xs)
+ Nothing -> return []
+ hm <- if Flag_HideModule (moduleString mdl) `elem` flags
+ then return $ OptHide : opts
+ else return opts
+ if Flag_ShowExtensions (moduleString mdl) `elem` flags
+ then return $ OptShowExtensions : hm
+ else return hm
+
+
+parseOption :: String -> ErrMsgM (Maybe DocOption)
+parseOption "hide" = return (Just OptHide)
+parseOption "prune" = return (Just OptPrune)
+parseOption "ignore-exports" = return (Just OptIgnoreExports)
+parseOption "not-home" = return (Just OptNotHome)
+parseOption "show-extensions" = return (Just OptShowExtensions)
+parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing
+
+
+--------------------------------------------------------------------------------
+-- Maps
+--------------------------------------------------------------------------------
+
+
+type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap, InstMap)
+
+-- | Create 'Maps' by looping through the declarations. For each declaration,
+-- find its names, its subordinates, and its doc strings. Process doc strings
+-- into 'Doc's.
+mkMaps :: DynFlags
+ -> GlobalRdrEnv
+ -> [Name]
+ -> [(LHsDecl Name, [HsDocString])]
+ -> Maps
+mkMaps dflags gre instances decls =
+ let (a, b, c, d) = unzip4 $ map mappings decls
+ in (f' $ map (nubBy ((==) `on` fst)) a , f b, f c, f d, instanceMap)
+ where
+ f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b
+ f = M.fromListWith (<>) . concat
+
+ f' :: [[(Name, Doc Name)]] -> Map Name (Doc Name)
+ f' = M.fromListWith docAppend . concat
+
+ mappings :: (LHsDecl Name, [HsDocString])
+ -> ( [(Name, Doc Name)]
+ , [(Name, Map Int (Doc Name))]
+ , [(Name, [Name])]
+ , [(Name, [LHsDecl Name])]
+ )
+ mappings (ldecl, docStrs) =
+ let L l decl = ldecl
+ declDoc :: [HsDocString] -> Map Int HsDocString
+ -> (Maybe (Doc Name), Map Int (Doc Name))
+ declDoc strs m =
+ let doc' = processDocStrings dflags gre strs
+ m' = M.map (processDocStringParas dflags gre) m
+ in (doc', m')
+ (doc, args) = declDoc docStrs (typeDocs decl)
+ subs :: [(Name, [HsDocString], Map Int HsDocString)]
+ subs = subordinates instanceMap decl
+ (subDocs, subArgs) = unzip $ map (\(_, strs, m) -> declDoc strs m) subs
+ ns = names l decl
+ subNs = [ n | (n, _, _) <- subs ]
+ dm = [ (n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs ]
+ am = [ (n, args) | n <- ns ] ++ zip subNs subArgs
+ sm = [ (n, subNs) | n <- ns ]
+ cm = [ (n, [ldecl]) | n <- ns ++ subNs ]
+ in seqList ns `seq`
+ seqList subNs `seq`
+ doc `seq`
+ seqList subDocs `seq`
+ seqList subArgs `seq`
+ (dm, am, sm, cm)
+
+ instanceMap :: Map SrcSpan Name
+ instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ]
+
+ names :: SrcSpan -> HsDecl Name -> [Name]
+ names l (InstD d) = maybeToList (M.lookup loc instanceMap) -- See note [2].
+ where loc = case d of
+ TyFamInstD _ -> l -- The CoAx's loc is the whole line, but only for TFs
+ _ -> getInstLoc d
+ names _ decl = getMainDeclBinder decl
+
+-- Note [2]:
+------------
+-- We relate ClsInsts to InstDecls using the SrcSpans buried inside them.
+-- That should work for normal user-written instances (from looking at GHC
+-- sources). We can assume that commented instances are user-written.
+-- This lets us relate Names (from ClsInsts) to comments (associated
+-- with InstDecls).
+
+
+--------------------------------------------------------------------------------
+-- Declarations
+--------------------------------------------------------------------------------
+
+
+-- | Get all subordinate declarations inside a declaration, and their docs.
+subordinates :: InstMap -> HsDecl Name -> [(Name, [HsDocString], Map Int HsDocString)]
+subordinates instMap decl = case decl of
+ InstD (ClsInstD d) -> do
+ DataFamInstDecl { dfid_tycon = L l _
+ , dfid_defn = def } <- unLoc <$> cid_datafam_insts d
+ [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs def
+
+ InstD (DataFamInstD d) -> dataSubs (dfid_defn d)
+ TyClD d | isClassDecl d -> classSubs d
+ | isDataDecl d -> dataSubs (tcdDataDefn d)
+ _ -> []
+ where
+ classSubs dd = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls dd
+ , name <- getMainDeclBinder d, not (isValD d)
+ ]
+ dataSubs dd = constrs ++ fields
+ where
+ cons = map unL $ (dd_cons dd)
+ constrs = [ (unL $ con_name c, maybeToList $ fmap unL $ con_doc c, M.empty)
+ | c <- cons ]
+ fields = [ (unL n, maybeToList $ fmap unL doc, M.empty)
+ | RecCon flds <- map con_details cons
+ , ConDeclField n _ doc <- flds ]
+
+-- | Extract function argument docs from inside types.
+typeDocs :: HsDecl Name -> Map Int HsDocString
+typeDocs d =
+ let docs = go 0 in
+ case d of
+ SigD (TypeSig _ ty) -> docs (unLoc ty)
+ SigD (PatSynSig _ arg_tys ty req prov) ->
+ let allTys = ty : concat [ F.toList arg_tys, unLoc req, unLoc prov ]
+ in F.foldMap (docs . unLoc) allTys
+ ForD (ForeignImport _ ty _ _) -> docs (unLoc ty)
+ TyClD (SynDecl { tcdRhs = ty }) -> docs (unLoc ty)
+ _ -> M.empty
+ where
+ go n (HsForAllTy _ _ _ ty) = go n (unLoc ty)
+ go n (HsFunTy (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 Name -> [(LHsDecl Name, [HsDocString])]
+classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls
+ where
+ decls = docs ++ defs ++ sigs ++ ats
+ docs = mkDecls tcdDocs DocD class_
+#if MIN_VERSION_ghc(7,8,3)
+ defs = mkDecls (bagToList . tcdMeths) ValD class_
+#else
+ defs = mkDecls (map snd . bagToList . tcdMeths) ValD class_
+#endif
+ sigs = mkDecls tcdSigs SigD class_
+ ats = mkDecls tcdATs (TyClD . FamDecl) class_
+
+
+-- | The top-level declarations of a module that we care about,
+-- ordered by source location, with documentation attached if it exists.
+topDecls :: HsGroup Name -> [(LHsDecl Name, [HsDocString])]
+topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup
+
+-- | Extract a map of fixity declarations only
+mkFixMap :: HsGroup Name -> FixMap
+mkFixMap group_ = M.fromList [ (n,f)
+ | L _ (FixitySig (L _ n) f) <- hs_fixds group_ ]
+
+
+-- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'.
+ungroup :: HsGroup Name -> [LHsDecl Name]
+ungroup group_ =
+ mkDecls (tyClGroupConcat . hs_tyclds) TyClD group_ ++
+ mkDecls hs_derivds DerivD group_ ++
+ mkDecls hs_defds DefD group_ ++
+ mkDecls hs_fords ForD group_ ++
+ mkDecls hs_docs DocD group_ ++
+ mkDecls hs_instds InstD group_ ++
+ mkDecls (typesigs . hs_valds) SigD group_ ++
+#if MIN_VERSION_ghc(7,8,3)
+ mkDecls (valbinds . hs_valds) ValD group_
+#else
+ mkDecls (map snd . valbinds . hs_valds) ValD group_
+#endif
+ where
+ typesigs (ValBindsOut _ sigs) = filter isVanillaLSig sigs
+ typesigs _ = error "expected ValBindsOut"
+
+ valbinds (ValBindsOut 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 ]
+
+
+-- | Sort by source location
+sortByLoc :: [Located a] -> [Located a]
+sortByLoc = sortBy (comparing getLoc)
+
+
+--------------------------------------------------------------------------------
+-- 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 (SigD d) = isVanillaLSig (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 c) =
+ TyClD $ c { tcdSigs = filter (liftA2 (||) isVanillaLSig 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.
+--
+-- We create the export items even if the module is hidden, since they
+-- might be useful when creating the export items for other modules.
+mkExportItems
+ :: IfaceMap
+ -> Module -- this module
+ -> WarningMap
+ -> GlobalRdrEnv
+ -> [Name] -- exported names (orig)
+ -> [LHsDecl Name]
+ -> Maps
+ -> FixMap
+ -> [SrcSpan] -- splice locations
+ -> Maybe [IE Name]
+ -> InstIfaceMap
+ -> DynFlags
+ -> ErrMsgGhc [ExportItem Name]
+mkExportItems
+ modMap thisMod warnings gre exportedNames decls
+ maps@(docMap, argMap, subMap, declMap, instMap) fixMap splices optExports instIfaceMap dflags =
+ case optExports of
+ Nothing -> fullModuleContents dflags warnings gre maps fixMap splices decls
+ Just exports -> liftM concat $ mapM lookupExport exports
+ where
+ lookupExport (IEVar x) = declWith x
+ lookupExport (IEThingAbs t) = declWith t
+ lookupExport (IEThingAll t) = declWith t
+ lookupExport (IEThingWith t _) = declWith t
+ lookupExport (IEModuleContents m) =
+ moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices
+ lookupExport (IEGroup lev docStr) = return $
+ return . ExportGroup lev "" $ processDocString dflags gre docStr
+
+ lookupExport (IEDoc docStr) = return $
+ return . ExportDoc $ processDocStringParas dflags gre docStr
+
+ lookupExport (IEDocNamed str) = liftErrMsg $
+ findNamedDoc str [ unL d | d <- decls ] >>= return . \case
+ Nothing -> []
+ Just doc -> return . ExportDoc $ processDocStringParas dflags gre doc
+
+ declWith :: Name -> ErrMsgGhc [ ExportItem Name ]
+ declWith t =
+ case findDecl t of
+ ([L l (ValD _)], (doc, _)) -> do
+ -- Top-level binding without type signature
+ export <- hiValExportItem dflags t doc (l `elem` splices) $ M.lookup t fixMap
+ return [export]
+ (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds ->
+ let declNames = getMainDeclBinder (unL decl)
+ in case () of
+ _
+ -- temp hack: we filter out separately exported ATs, since we haven't decided how
+ -- to handle them yet. We should really give an warning message also, and filter the
+ -- name out in mkVisibleNames...
+ | t `elem` declATs (unL decl) -> return []
+
+ -- We should not show a subordinate by itself if any of its
+ -- parents is also exported. See note [1].
+ | t `notElem` declNames,
+ Just p <- find isExported (parents t $ unL decl) ->
+ do liftErrMsg $ tell [
+ "Warning: " ++ moduleString thisMod ++ ": " ++
+ pretty dflags (nameOccName t) ++ " is exported separately but " ++
+ "will be documented under " ++ pretty dflags (nameOccName p) ++
+ ". Consider exporting it together with its parent(s)" ++
+ " for code clarity." ]
+ return []
+
+ -- normal case
+ | otherwise -> case decl of
+ -- A single signature might refer to many names, but we
+ -- create an export item for a single name only. So we
+ -- modify the signature to contain only that single name.
+ L loc (SigD sig) ->
+ -- fromJust is safe since we already checked in guards
+ -- that 't' is a name declared in this declaration.
+ let newDecl = L loc . SigD . fromJust $ filterSigNames (== t) sig
+ in return [ mkExportDecl t newDecl docs_ ]
+
+ L loc (TyClD cl@ClassDecl{}) -> do
+ mdef <- liftGhcToErrMsgGhc $ minimalDef t
+ let sig = maybeToList $ fmap (noLoc . MinimalSig . fmap noLoc) mdef
+ return [ mkExportDecl t
+ (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ ]
+
+ _ -> return [ mkExportDecl t decl docs_ ]
+
+ -- Declaration from another package
+ ([], _) -> do
+ mayDecl <- hiDecl dflags t
+ case mayDecl of
+ Nothing -> return [ ExportNoDecl t [] ]
+ Just decl ->
+ -- We try to get the subs and docs
+ -- from the installed .haddock file for that package.
+ case M.lookup (nameModule t) instIfaceMap of
+ Nothing -> do
+ liftErrMsg $ tell
+ ["Warning: Couldn't find .haddock for export " ++ pretty dflags t]
+ let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates instMap (unLoc decl) ]
+ return [ mkExportDecl t decl (noDocForDecl, subs_) ]
+ Just iface ->
+ return [ mkExportDecl t decl (lookupDocs t warnings (instDocMap iface) (instArgMap iface) (instSubMap iface)) ]
+
+ _ -> return []
+
+
+ mkExportDecl :: Name -> LHsDecl Name -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem Name
+ mkExportDecl name decl (doc, subs) = decl'
+ where
+ decl' = ExportDecl (restrictTo sub_names (extractDecl name mdl decl)) doc subs' [] fixities False
+ mdl = nameModule name
+ subs' = filter (isExported . fst) subs
+ sub_names = map fst subs'
+ fixities = [ (n, f) | n <- name:sub_names, Just f <- [M.lookup n fixMap] ]
+
+
+ isExported = (`elem` exportedNames)
+
+
+ findDecl :: Name -> ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)]))
+ findDecl n
+ | m == thisMod, Just ds <- M.lookup n declMap =
+ (ds, lookupDocs n warnings docMap argMap subMap)
+ | Just iface <- M.lookup m modMap, Just ds <- M.lookup n (ifaceDeclMap iface) =
+ (ds, lookupDocs n warnings (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface))
+ | otherwise = ([], (noDocForDecl, []))
+ where
+ m = nameModule n
+
+
+hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl Name))
+hiDecl dflags t = do
+ mayTyThing <- liftGhcToErrMsgGhc $ lookupName t
+ case mayTyThing of
+ Nothing -> do
+ liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty dflags t]
+ return Nothing
+ Just x -> return (Just (tyThingToLHsDecl x))
+
+
+hiValExportItem :: DynFlags -> Name -> DocForDecl Name -> Bool -> Maybe Fixity -> ErrMsgGhc (ExportItem Name)
+hiValExportItem dflags name doc splice fixity = do
+ mayDecl <- hiDecl dflags name
+ case mayDecl of
+ Nothing -> return (ExportNoDecl name [])
+ Just decl -> return (ExportDecl decl doc [] [] fixities splice)
+ where
+ fixities = case fixity of
+ Just f -> [(name, f)]
+ Nothing -> []
+
+
+-- | Lookup docs for a declaration from maps.
+lookupDocs :: Name -> WarningMap -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)])
+lookupDocs n warnings docMap argMap subMap =
+ let lookupArgDoc x = M.findWithDefault M.empty x argMap in
+ let doc = (lookupDoc n, lookupArgDoc n) in
+ let subs = M.findWithDefault [] n subMap in
+ let subDocs = [ (s, (lookupDoc s, lookupArgDoc s)) | s <- subs ] in
+ (doc, subDocs)
+ where
+ lookupDoc name = Documentation (M.lookup name docMap) (M.lookup name warnings)
+
+
+-- | Return all export items produced by an exported module. That is, we're
+-- interested in the exports produced by \"module B\" in such a scenario:
+--
+-- > module A (module B) where
+-- > import B (...) hiding (...)
+--
+-- There are three different cases to consider:
+--
+-- 1) B is hidden, in which case we return all its exports that are in scope in A.
+-- 2) B is visible, but not all its exports are in scope in A, in which case we
+-- only return those that are.
+-- 3) B is visible and all its exports are in scope, in which case we return
+-- a single 'ExportModule' item.
+moduleExports :: Module -- ^ Module A
+ -> ModuleName -- ^ The real name of B, the exported module
+ -> DynFlags -- ^ The flags used when typechecking A
+ -> WarningMap
+ -> GlobalRdrEnv -- ^ The renaming environment used for A
+ -> [Name] -- ^ All the exports of A
+ -> [LHsDecl Name] -- ^ All the declarations in A
+ -> IfaceMap -- ^ Already created interfaces
+ -> InstIfaceMap -- ^ Interfaces in other packages
+ -> Maps
+ -> FixMap
+ -> [SrcSpan] -- ^ Locations of all TH splices
+ -> ErrMsgGhc [ExportItem Name] -- ^ Resulting export items
+moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfaceMap maps fixMap splices
+ | m == thisMod = fullModuleContents dflags warnings gre maps fixMap splices decls
+ | otherwise =
+ case M.lookup m ifaceMap of
+ Just iface
+ | OptHide `elem` ifaceOptions iface -> return (ifaceExportItems iface)
+ | otherwise -> return [ ExportModule m ]
+
+ Nothing -> -- We have to try to find it in the installed interfaces
+ -- (external packages).
+ case M.lookup expMod (M.mapKeys moduleName instIfaceMap) of
+ Just iface -> return [ ExportModule (instMod iface) ]
+ Nothing -> do
+ liftErrMsg $
+ tell ["Warning: " ++ pretty dflags thisMod ++ ": Could not find " ++
+ "documentation for exported module: " ++ pretty dflags expMod]
+ return []
+ where
+ m = mkModule packageId expMod
+ packageId = modulePackageId thisMod
+
+
+-- Note [1]:
+------------
+-- It is unnecessary to document a subordinate by itself at the top level if
+-- any of its parents is also documented. Furthermore, if the subordinate is a
+-- record field or a class method, documenting it under its parent
+-- indicates its special status.
+--
+-- A user might expect that it should show up separately, so we issue a
+-- warning. It's a fine opportunity to also tell the user she might want to
+-- export the subordinate through the parent export item for clarity.
+--
+-- The code removes top-level subordinates also when the parent is exported
+-- through a 'module' export. I think that is fine.
+--
+-- (For more information, see Trac #69)
+
+
+fullModuleContents :: DynFlags -> WarningMap -> GlobalRdrEnv -> Maps -> FixMap -> [SrcSpan]
+ -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name]
+fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) fixMap splices decls =
+ liftM catMaybes $ mapM mkExportItem (expandSig decls)
+ where
+ -- A type signature can have multiple names, like:
+ -- foo, bar :: Types..
+ --
+ -- We go through the list of declarations and expand type signatures, so
+ -- that every type signature has exactly one name!
+ expandSig :: [LHsDecl name] -> [LHsDecl name]
+ expandSig = foldr f []
+ where
+ f :: LHsDecl name -> [LHsDecl name] -> [LHsDecl name]
+ f (L l (SigD (TypeSig names t))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t)) : acc) xs names
+ f (L l (SigD (GenericSig names t))) xs = foldr (\n acc -> L l (SigD (GenericSig [n] t)) : acc) xs names
+ f x xs = x : xs
+
+ mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name))
+ mkExportItem (L _ (DocD (DocGroup lev docStr))) = do
+ return . Just . ExportGroup lev "" $ processDocString dflags gre docStr
+ mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do
+ return . Just . ExportDoc $ processDocStringParas dflags gre docStr
+ mkExportItem (L l (ValD d))
+ | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap =
+ -- Top-level binding without type signature.
+ let (doc, _) = lookupDocs name warnings docMap argMap subMap in
+ fmap Just (hiValExportItem dflags name doc (l `elem` splices) $ M.lookup name fixMap)
+ | otherwise = return Nothing
+ mkExportItem decl@(L l (InstD d))
+ | Just name <- M.lookup (getInstLoc d) instMap =
+ let (doc, subs) = lookupDocs name warnings docMap argMap subMap in
+ return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices))
+ mkExportItem (L l (TyClD cl@ClassDecl{ tcdLName = L _ name, tcdSigs = sigs })) = do
+ mdef <- liftGhcToErrMsgGhc $ minimalDef name
+ let sig = maybeToList $ fmap (noLoc . MinimalSig . fmap noLoc) mdef
+ expDecl (L l (TyClD cl { tcdSigs = sig ++ sigs })) l name
+ mkExportItem decl@(L l d)
+ | name:_ <- getMainDeclBinder d = expDecl decl l name
+ | otherwise = return Nothing
+
+ fixities name subs = [ (n,f) | n <- name : map fst subs
+ , Just f <- [M.lookup n fixMap] ]
+
+ expDecl decl l name = return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices))
+ where (doc, subs) = lookupDocs name warnings docMap argMap subMap
+
+
+-- | Sometimes the declaration we want to export is not the "main" declaration:
+-- it might be an individual record selector or a class method. In these
+-- cases we have to extract the required declaration (and somehow cobble
+-- together a type signature for it...).
+extractDecl :: Name -> Module -> LHsDecl Name -> LHsDecl Name
+extractDecl name mdl decl
+ | name `elem` getMainDeclBinder (unLoc decl) = decl
+ | otherwise =
+ case unLoc decl of
+ TyClD d@ClassDecl {} ->
+ let matches = [ sig | sig <- tcdSigs d, name `elem` sigName sig,
+ isVanillaLSig sig ] -- TODO: document fixity
+ in case matches of
+ [s0] -> let (n, tyvar_names) = (tcdName d, getTyVars d)
+ L pos sig = extractClassDecl n tyvar_names s0
+ in L pos (SigD sig)
+ _ -> error "internal: extractDecl (ClassDecl)"
+ TyClD d@DataDecl {} ->
+ let (n, tyvar_names) = (tcdName d, map toTypeNoLoc $ getTyVars d)
+ in SigD <$> extractRecSel name mdl n tyvar_names (dd_cons (tcdDataDefn d))
+ InstD (DataFamInstD DataFamInstDecl { dfid_tycon = L _ n
+ , dfid_pats = HsWB { hswb_cts = tys }
+ , dfid_defn = defn }) ->
+ SigD <$> extractRecSel name mdl n tys (dd_cons defn)
+ InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) ->
+ let matches = [ d | L _ d <- insts
+ , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d)
+ , ConDeclField { cd_fld_name = L _ n } <- rec
+ , n == name
+ ]
+ in case matches of
+ [d0] -> extractDecl name mdl (noLoc . InstD $ DataFamInstD d0)
+ _ -> error "internal: extractDecl (ClsInstD)"
+ _ -> error "internal: extractDecl"
+ where
+ getTyVars = hsLTyVarLocNames . tyClDeclTyVars
+
+
+toTypeNoLoc :: Located Name -> LHsType Name
+toTypeNoLoc = noLoc . HsTyVar . unLoc
+
+
+extractClassDecl :: Name -> [Located Name] -> LSig Name -> LSig Name
+extractClassDecl c tvs0 (L pos (TypeSig lname ltype)) = case ltype of
+ L _ (HsForAllTy expl tvs (L _ preds) ty) ->
+ L pos (TypeSig lname (noLoc (HsForAllTy expl tvs (lctxt preds) ty)))
+ _ -> L pos (TypeSig lname (noLoc (HsForAllTy Implicit emptyHsQTvs (lctxt []) ltype)))
+ where
+ lctxt = noLoc . ctxt
+ ctxt preds = nlHsTyConApp c (map toTypeNoLoc tvs0) : preds
+extractClassDecl _ _ _ = error "extractClassDecl: unexpected decl"
+
+
+extractRecSel :: Name -> Module -> Name -> [LHsType Name] -> [LConDecl Name]
+ -> LSig Name
+extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found"
+
+extractRecSel nm mdl t tvs (L _ con : rest) =
+ case con_details con of
+ RecCon fields | (ConDeclField n ty _ : _) <- matching_fields fields ->
+ L (getLoc n) (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty))))
+ _ -> extractRecSel nm mdl t tvs rest
+ where
+ matching_fields flds = [ f | f@(ConDeclField n _ _) <- flds, unLoc n == nm ]
+ data_ty
+ | ResTyGADT ty <- con_res con = ty
+ | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) tvs
+
+
+-- | Keep export items with docs.
+pruneExportItems :: [ExportItem Name] -> [ExportItem Name]
+pruneExportItems = filter hasDoc
+ where
+ hasDoc (ExportDecl{expItemMbDoc = (Documentation d _, _)}) = isJust d
+ hasDoc _ = True
+
+
+mkVisibleNames :: Maps -> [ExportItem Name] -> [DocOption] -> [Name]
+mkVisibleNames (_, _, _, _, instMap) exports opts
+ | OptHide `elem` opts = []
+ | otherwise = let ns = concatMap exportName exports
+ in seqList ns `seq` ns
+ where
+ exportName e@ExportDecl {} = name ++ subs
+ where subs = map fst (expItemSubDocs e)
+ name = case unLoc $ expItemDecl e of
+ InstD d -> maybeToList $ M.lookup (getInstLoc d) instMap
+ decl -> getMainDeclBinder decl
+ exportName ExportNoDecl {} = [] -- we don't count these as visible, since
+ -- we don't want links to go to them.
+ exportName _ = []
+
+seqList :: [a] -> ()
+seqList [] = ()
+seqList (x : xs) = x `seq` seqList xs
+
+-- | Find a stand-alone documentation comment by its name.
+findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString)
+findNamedDoc name = search
+ where
+ search [] = do
+ tell ["Cannot find documentation for: $" ++ name]
+ return Nothing
+ search (DocD (DocCommentNamed name' doc) : rest)
+ | name == name' = return (Just doc)
+ | otherwise = search rest
+ search (_other_decl : rest) = search rest
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
new file mode 100644
index 00000000..f1021436
--- /dev/null
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -0,0 +1,146 @@
+{-# OPTIONS_GHC -Wwarn #-}
+{-# LANGUAGE BangPatterns #-}
+ -----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.Interface.LexParseRn
+-- Copyright : (c) Isaac Dupree 2009,
+-- Mateusz Kowalczyk 2013
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+-----------------------------------------------------------------------------
+module Haddock.Interface.LexParseRn
+ ( processDocString
+ , processDocStringParas
+ , processDocStrings
+ , processModuleHeader
+ ) where
+
+import Control.Applicative
+import Data.IntSet (toList)
+import Data.List
+import Documentation.Haddock.Doc (docConcat)
+import DynFlags (ExtensionFlag(..), languageExtensions)
+import FastString
+import GHC
+import Haddock.Interface.ParseModuleHeader
+import Haddock.Parser
+import Haddock.Types
+import Name
+import Outputable (showPpr)
+import RdrName
+
+processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> Maybe (Doc Name)
+processDocStrings dflags gre strs =
+ case docConcat $ map (processDocStringParas dflags gre) strs of
+ DocEmpty -> Nothing
+ x -> Just x
+
+
+processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> Doc Name
+processDocStringParas = process parseParas
+
+
+processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> Doc Name
+processDocString = process parseString
+
+process :: (DynFlags -> String -> Doc RdrName)
+ -> DynFlags
+ -> GlobalRdrEnv
+ -> HsDocString
+ -> Doc Name
+process parse dflags gre (HsDocString fs) =
+ rename dflags gre $ parse dflags (unpackFS fs)
+
+
+processModuleHeader :: DynFlags -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString
+ -> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name))
+processModuleHeader dflags gre safety mayStr = do
+ (hmi, doc) <-
+ case mayStr of
+ Nothing -> return failure
+ Just (L _ (HsDocString fs)) -> do
+ let str = unpackFS fs
+ (hmi, doc) = parseModuleHeader dflags str
+ !descr = rename dflags gre <$> hmi_description hmi
+ hmi' = hmi { hmi_description = descr }
+ doc' = rename dflags gre doc
+ return (hmi', Just doc')
+
+ let flags :: [ExtensionFlag]
+ -- We remove the flags implied by the language setting and we display the language instead
+ flags = map toEnum (toList $ extensionFlags dflags) \\ languageExtensions (language dflags)
+ return (hmi { hmi_safety = Just $ showPpr dflags safety
+ , hmi_language = language dflags
+ , hmi_extensions = flags
+ } , doc)
+ where
+ failure = (emptyHaddockModInfo, Nothing)
+
+
+rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> Doc Name
+rename dflags gre = rn
+ where
+ rn d = case d of
+ DocAppend a b -> DocAppend (rn a) (rn b)
+ DocParagraph doc -> DocParagraph (rn doc)
+ DocIdentifier x -> do
+ let choices = dataTcOccs' x
+ let names = concatMap (\c -> map gre_name (lookupGRE_RdrName c gre)) choices
+ case names of
+ [] ->
+ case choices of
+ [] -> DocMonospaced (DocString (showPpr dflags x))
+ [a] -> outOfScope dflags a
+ a:b:_ | isRdrTc a -> outOfScope dflags a
+ | otherwise -> outOfScope dflags b
+ [a] -> DocIdentifier a
+ a:b:_ | isTyConName a -> DocIdentifier a | otherwise -> DocIdentifier b
+ -- If an id can refer to multiple things, we give precedence to type
+ -- constructors.
+
+ DocWarning doc -> DocWarning (rn doc)
+ DocEmphasis doc -> DocEmphasis (rn doc)
+ DocBold doc -> DocBold (rn doc)
+ DocMonospaced doc -> DocMonospaced (rn doc)
+ DocUnorderedList docs -> DocUnorderedList (map rn docs)
+ DocOrderedList docs -> DocOrderedList (map rn docs)
+ DocDefList list -> DocDefList [ (rn a, rn b) | (a, b) <- list ]
+ DocCodeBlock doc -> DocCodeBlock (rn doc)
+ DocIdentifierUnchecked x -> DocIdentifierUnchecked x
+ DocModule str -> DocModule str
+ DocHyperlink l -> DocHyperlink l
+ DocPic str -> DocPic str
+ DocAName str -> DocAName str
+ DocProperty p -> DocProperty p
+ DocExamples e -> DocExamples e
+ DocEmpty -> DocEmpty
+ DocString str -> DocString str
+ DocHeader (Header l t) -> DocHeader $ Header l (rn t)
+
+dataTcOccs' :: RdrName -> [RdrName]
+-- If the input is a data constructor, return both it and a type
+-- constructor. This is useful when we aren't sure which we are
+-- looking at.
+--
+-- We use this definition instead of the GHC's to provide proper linking to
+-- functions accross modules. See ticket #253 on Haddock Trac.
+dataTcOccs' rdr_name
+ | isDataOcc occ = [rdr_name, rdr_name_tc]
+ | otherwise = [rdr_name]
+ where
+ occ = rdrNameOcc rdr_name
+ rdr_name_tc = setRdrNameSpace rdr_name tcName
+
+
+outOfScope :: DynFlags -> RdrName -> Doc a
+outOfScope dflags x =
+ case x of
+ Unqual occ -> monospaced occ
+ Qual mdl occ -> DocIdentifierUnchecked (mdl, occ)
+ Orig _ occ -> monospaced occ
+ Exact name -> monospaced name -- Shouldn't happen since x is out of scope
+ where
+ monospaced a = DocMonospaced (DocString (showPpr dflags a))
diff --git a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
new file mode 100644
index 00000000..6848dc63
--- /dev/null
+++ b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
@@ -0,0 +1,150 @@
+{-# OPTIONS_GHC -Wwarn #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.Interface.ParseModuleHeader
+-- Copyright : (c) Simon Marlow 2006, Isaac Dupree 2009
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+-----------------------------------------------------------------------------
+module Haddock.Interface.ParseModuleHeader (parseModuleHeader) where
+
+import Control.Applicative ((<$>))
+import Control.Monad (mplus)
+import Data.Char
+import DynFlags
+import Haddock.Parser
+import Haddock.Types
+import RdrName
+
+-- -----------------------------------------------------------------------------
+-- Parsing module headers
+
+-- NB. The headers must be given in the order Module, Description,
+-- Copyright, License, Maintainer, Stability, Portability, except that
+-- any or all may be omitted.
+parseModuleHeader :: DynFlags -> String -> (HaddockModInfo RdrName, Doc RdrName)
+parseModuleHeader dflags str0 =
+ let
+ getKey :: String -> String -> (Maybe String,String)
+ getKey key str = case parseKey key str of
+ Nothing -> (Nothing,str)
+ Just (value,rest) -> (Just value,rest)
+
+ (_moduleOpt,str1) = getKey "Module" str0
+ (descriptionOpt,str2) = getKey "Description" str1
+ (copyrightOpt,str3) = getKey "Copyright" str2
+ (licenseOpt,str4) = getKey "License" str3
+ (licenceOpt,str5) = getKey "Licence" str4
+ (maintainerOpt,str6) = getKey "Maintainer" str5
+ (stabilityOpt,str7) = getKey "Stability" str6
+ (portabilityOpt,str8) = getKey "Portability" str7
+
+ in (HaddockModInfo {
+ hmi_description = parseString dflags <$> descriptionOpt,
+ hmi_copyright = copyrightOpt,
+ hmi_license = licenseOpt `mplus` licenceOpt,
+ hmi_maintainer = maintainerOpt,
+ hmi_stability = stabilityOpt,
+ hmi_portability = portabilityOpt,
+ hmi_safety = Nothing,
+ hmi_language = Nothing, -- set in LexParseRn
+ hmi_extensions = [] -- also set in LexParseRn
+ }, parseParas dflags str8)
+
+-- | This function is how we read keys.
+--
+-- all fields in the header are optional and have the form
+--
+-- [spaces1][field name][spaces] ":"
+-- [text]"\n" ([spaces2][space][text]"\n" | [spaces]"\n")*
+-- where each [spaces2] should have [spaces1] as a prefix.
+--
+-- Thus for the key "Description",
+--
+-- > Description : this is a
+-- > rather long
+-- >
+-- > description
+-- >
+-- > The module comment starts here
+--
+-- the value will be "this is a .. description" and the rest will begin
+-- at "The module comment".
+parseKey :: String -> String -> Maybe (String,String)
+parseKey key toParse0 =
+ do
+ let
+ (spaces0,toParse1) = extractLeadingSpaces toParse0
+
+ indentation = spaces0
+ afterKey0 <- extractPrefix key toParse1
+ let
+ afterKey1 = extractLeadingSpaces afterKey0
+ afterColon0 <- case snd afterKey1 of
+ ':':afterColon -> return afterColon
+ _ -> Nothing
+ let
+ (_,afterColon1) = extractLeadingSpaces afterColon0
+
+ return (scanKey True indentation afterColon1)
+ where
+ scanKey :: Bool -> String -> String -> (String,String)
+ scanKey _ _ [] = ([],[])
+ scanKey isFirst indentation str =
+ let
+ (nextLine,rest1) = extractNextLine str
+
+ accept = isFirst || sufficientIndentation || allSpaces
+
+ sufficientIndentation = case extractPrefix indentation nextLine of
+ Just (c:_) | isSpace c -> True
+ _ -> False
+
+ allSpaces = case extractLeadingSpaces nextLine of
+ (_,[]) -> True
+ _ -> False
+ in
+ if accept
+ then
+ let
+ (scanned1,rest2) = scanKey False indentation rest1
+
+ scanned2 = case scanned1 of
+ "" -> if allSpaces then "" else nextLine
+ _ -> nextLine ++ "\n" ++ scanned1
+ in
+ (scanned2,rest2)
+ else
+ ([],str)
+
+ extractLeadingSpaces :: String -> (String,String)
+ extractLeadingSpaces [] = ([],[])
+ extractLeadingSpaces (s@(c:cs))
+ | isSpace c =
+ let
+ (spaces1,cs1) = extractLeadingSpaces cs
+ in
+ (c:spaces1,cs1)
+ | otherwise = ([],s)
+
+ extractNextLine :: String -> (String,String)
+ extractNextLine [] = ([],[])
+ extractNextLine (c:cs)
+ | c == '\n' =
+ ([],cs)
+ | otherwise =
+ let
+ (line,rest) = extractNextLine cs
+ in
+ (c:line,rest)
+
+ -- comparison is case-insensitive.
+ extractPrefix :: String -> String -> Maybe String
+ extractPrefix [] s = Just s
+ extractPrefix _ [] = Nothing
+ extractPrefix (c1:cs1) (c2:cs2)
+ | toUpper c1 == toUpper c2 = extractPrefix cs1 cs2
+ | otherwise = Nothing
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
new file mode 100644
index 00000000..748e0210
--- /dev/null
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -0,0 +1,506 @@
+----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.Interface.Rename
+-- Copyright : (c) Simon Marlow 2003-2006,
+-- David Waern 2006-2009
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+-----------------------------------------------------------------------------
+module Haddock.Interface.Rename (renameInterface) where
+
+
+import Data.Traversable (traverse)
+
+import Haddock.GhcUtils
+import Haddock.Types
+
+import Bag (emptyBag)
+import GHC hiding (NoLink)
+import Name
+
+import Control.Applicative
+import Control.Monad hiding (mapM)
+import Data.List
+import qualified Data.Map as Map hiding ( Map )
+import Data.Traversable (mapM)
+import Prelude hiding (mapM)
+
+
+renameInterface :: DynFlags -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface
+renameInterface dflags renamingEnv warnings iface =
+
+ -- first create the local env, where every name exported by this module
+ -- is mapped to itself, and everything else comes from the global renaming
+ -- env
+ let localEnv = foldl fn renamingEnv (ifaceVisibleExports iface)
+ where fn env name = Map.insert name (ifaceMod iface) env
+
+ -- rename names in the exported declarations to point to things that
+ -- are closer to, or maybe even exported by, the current module.
+ (renamedExportItems, missingNames1)
+ = runRnFM localEnv (renameExportItems (ifaceExportItems iface))
+
+ (rnDocMap, missingNames2) = runRnFM localEnv (mapM renameDoc (ifaceDocMap iface))
+
+ (rnArgMap, missingNames3) = runRnFM localEnv (mapM (mapM renameDoc) (ifaceArgMap iface))
+
+ (finalModuleDoc, missingNames4)
+ = runRnFM localEnv (renameDocumentation (ifaceDoc iface))
+
+ -- combine the missing names and filter out the built-ins, which would
+ -- otherwise allways be missing.
+ missingNames = nub $ filter isExternalName -- XXX: isExternalName filters out too much
+ (missingNames1 ++ missingNames2 ++ missingNames3 ++ missingNames4)
+
+ -- filter out certain built in type constructors using their string
+ -- representation. TODO: use the Name constants from the GHC API.
+-- strings = filter (`notElem` ["()", "[]", "(->)"])
+-- (map pretty missingNames)
+ strings = map (pretty dflags) . filter (\n -> not (isSystemName n || isBuiltInSyntax n)) $ missingNames
+
+ in do
+ -- report things that we couldn't link to. Only do this for non-hidden
+ -- modules.
+ unless (OptHide `elem` ifaceOptions iface || null strings || not warnings) $
+ tell ["Warning: " ++ moduleString (ifaceMod iface) ++
+ ": could not find link destinations for:\n"++
+ unwords (" " : strings) ]
+
+ return $ iface { ifaceRnDoc = finalModuleDoc,
+ ifaceRnDocMap = rnDocMap,
+ ifaceRnArgMap = rnArgMap,
+ ifaceRnExportItems = renamedExportItems }
+
+
+--------------------------------------------------------------------------------
+-- Monad for renaming
+--
+-- The monad does two things for us: it passes around the environment for
+-- renaming, and it returns a list of names which couldn't be found in
+-- the environment.
+--------------------------------------------------------------------------------
+
+
+newtype RnM a =
+ RnM { unRn :: (Name -> (Bool, DocName)) -- name lookup function
+ -> (a,[Name])
+ }
+
+instance Monad RnM where
+ (>>=) = thenRn
+ return = returnRn
+
+instance Functor RnM where
+ fmap f x = do a <- x; return (f a)
+
+instance Applicative RnM where
+ pure = return
+ (<*>) = ap
+
+returnRn :: a -> RnM a
+returnRn a = RnM (const (a,[]))
+thenRn :: RnM a -> (a -> RnM b) -> RnM b
+m `thenRn` k = RnM (\lkp -> case unRn m lkp of
+ (a,out1) -> case unRn (k a) lkp of
+ (b,out2) -> (b,out1++out2))
+
+getLookupRn :: RnM (Name -> (Bool, DocName))
+getLookupRn = RnM (\lkp -> (lkp,[]))
+
+outRn :: Name -> RnM ()
+outRn name = RnM (const ((),[name]))
+
+lookupRn :: Name -> RnM DocName
+lookupRn name = do
+ lkp <- getLookupRn
+ case lkp name of
+ (False,maps_to) -> do outRn name; return maps_to
+ (True, maps_to) -> return maps_to
+
+
+runRnFM :: LinkEnv -> RnM a -> (a,[Name])
+runRnFM env rn = unRn rn lkp
+ where
+ lkp n = case Map.lookup n env of
+ Nothing -> (False, Undocumented n)
+ Just mdl -> (True, Documented n mdl)
+
+
+--------------------------------------------------------------------------------
+-- Renaming
+--------------------------------------------------------------------------------
+
+
+rename :: Name -> RnM DocName
+rename = lookupRn
+
+
+renameL :: Located Name -> RnM (Located DocName)
+renameL = mapM rename
+
+
+renameExportItems :: [ExportItem Name] -> RnM [ExportItem DocName]
+renameExportItems = mapM renameExportItem
+
+
+renameDocForDecl :: DocForDecl Name -> RnM (DocForDecl DocName)
+renameDocForDecl (doc, fnArgsDoc) =
+ (,) <$> renameDocumentation doc <*> renameFnArgsDoc fnArgsDoc
+
+
+renameDocumentation :: Documentation Name -> RnM (Documentation DocName)
+renameDocumentation (Documentation mDoc mWarning) =
+ Documentation <$> mapM renameDoc mDoc <*> mapM renameDoc mWarning
+
+
+renameLDocHsSyn :: LHsDocString -> RnM LHsDocString
+renameLDocHsSyn = return
+
+
+renameDoc :: Doc Name -> RnM (Doc DocName)
+renameDoc = traverse rename
+
+
+renameFnArgsDoc :: FnArgsDoc Name -> RnM (FnArgsDoc DocName)
+renameFnArgsDoc = mapM renameDoc
+
+
+renameLType :: LHsType Name -> RnM (LHsType DocName)
+renameLType = mapM renameType
+
+renameLKind :: LHsKind Name -> RnM (LHsKind DocName)
+renameLKind = renameLType
+
+renameMaybeLKind :: Maybe (LHsKind Name) -> RnM (Maybe (LHsKind DocName))
+renameMaybeLKind = traverse renameLKind
+
+renameType :: HsType Name -> RnM (HsType DocName)
+renameType t = case t of
+ HsForAllTy expl tyvars lcontext ltype -> do
+ tyvars' <- renameLTyVarBndrs tyvars
+ lcontext' <- renameLContext lcontext
+ ltype' <- renameLType ltype
+ return (HsForAllTy expl tyvars' lcontext' ltype')
+
+ HsTyVar n -> return . HsTyVar =<< rename n
+ HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype
+
+ HsAppTy a b -> do
+ a' <- renameLType a
+ b' <- renameLType b
+ return (HsAppTy a' b')
+
+ HsFunTy a b -> do
+ a' <- renameLType a
+ b' <- renameLType b
+ return (HsFunTy a' b')
+
+ HsListTy ty -> return . HsListTy =<< renameLType ty
+ HsPArrTy ty -> return . HsPArrTy =<< renameLType ty
+ HsIParamTy n ty -> liftM (HsIParamTy n) (renameLType ty)
+ HsEqTy ty1 ty2 -> liftM2 HsEqTy (renameLType ty1) (renameLType ty2)
+
+ HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts
+
+ HsOpTy a (w, L loc op) b -> do
+ op' <- rename op
+ a' <- renameLType a
+ b' <- renameLType b
+ return (HsOpTy a' (w, L loc op') b')
+
+ HsParTy ty -> return . HsParTy =<< renameLType ty
+
+ HsKindSig ty k -> do
+ ty' <- renameLType ty
+ k' <- renameLKind k
+ return (HsKindSig ty' k')
+
+ HsDocTy ty doc -> do
+ ty' <- renameLType ty
+ doc' <- renameLDocHsSyn doc
+ return (HsDocTy ty' doc')
+
+ HsTyLit x -> return (HsTyLit x)
+
+ HsWrapTy a b -> HsWrapTy a <$> renameType b
+ HsRecTy a -> HsRecTy <$> mapM renameConDeclFieldField a
+ HsCoreTy a -> pure (HsCoreTy a)
+ HsExplicitListTy a b -> HsExplicitListTy a <$> mapM renameLType b
+ HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b
+ HsQuasiQuoteTy a -> HsQuasiQuoteTy <$> renameHsQuasiQuote a
+ HsSpliceTy _ _ -> error "renameType: HsSpliceTy"
+
+renameHsQuasiQuote :: HsQuasiQuote Name -> RnM (HsQuasiQuote DocName)
+renameHsQuasiQuote (HsQuasiQuote a b c) = HsQuasiQuote <$> rename a <*> pure b <*> pure c
+
+renameLTyVarBndrs :: LHsTyVarBndrs Name -> RnM (LHsTyVarBndrs DocName)
+renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs })
+ = do { tvs' <- mapM renameLTyVarBndr tvs
+ ; return (HsQTvs { hsq_kvs = error "haddock:renameLTyVarBndrs", hsq_tvs = tvs' }) }
+ -- This is rather bogus, but I'm not sure what else to do
+
+renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName)
+renameLTyVarBndr (L loc (UserTyVar n))
+ = do { n' <- rename n
+ ; return (L loc (UserTyVar n')) }
+renameLTyVarBndr (L loc (KindedTyVar n kind))
+ = do { n' <- rename n
+ ; kind' <- renameLKind kind
+ ; return (L loc (KindedTyVar n' kind')) }
+
+renameLContext :: Located [LHsType Name] -> RnM (Located [LHsType DocName])
+renameLContext (L loc context) = do
+ context' <- mapM renameLType context
+ return (L loc context')
+
+
+renameInstHead :: InstHead Name -> RnM (InstHead DocName)
+renameInstHead (className, k, types, rest) = do
+ className' <- rename className
+ k' <- mapM renameType k
+ types' <- mapM renameType types
+ rest' <- case rest of
+ ClassInst cs -> ClassInst <$> mapM renameType cs
+ TypeInst ts -> TypeInst <$> traverse renameType ts
+ DataInst dd -> DataInst <$> renameTyClD dd
+ return (className', k', types', rest')
+
+
+renameLDecl :: LHsDecl Name -> RnM (LHsDecl DocName)
+renameLDecl (L loc d) = return . L loc =<< renameDecl d
+
+
+renameDecl :: HsDecl Name -> RnM (HsDecl DocName)
+renameDecl decl = case decl of
+ TyClD d -> do
+ d' <- renameTyClD d
+ return (TyClD d')
+ SigD s -> do
+ s' <- renameSig s
+ return (SigD s')
+ ForD d -> do
+ d' <- renameForD d
+ return (ForD d')
+ InstD d -> do
+ d' <- renameInstD d
+ return (InstD d')
+ _ -> error "renameDecl"
+
+renameLThing :: (a Name -> RnM (a DocName)) -> Located (a Name) -> RnM (Located (a DocName))
+renameLThing fn (L loc x) = return . L loc =<< fn x
+
+renameTyClD :: TyClDecl Name -> RnM (TyClDecl DocName)
+renameTyClD d = case d of
+ ForeignType lname b -> do
+ lname' <- renameL lname
+ return (ForeignType lname' b)
+
+-- TyFamily flav lname ltyvars kind tckind -> do
+ FamDecl { tcdFam = decl } -> do
+ decl' <- renameFamilyDecl decl
+ return (FamDecl { tcdFam = decl' })
+
+ SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdRhs = rhs, tcdFVs = fvs } -> do
+ lname' <- renameL lname
+ tyvars' <- renameLTyVarBndrs tyvars
+ rhs' <- renameLType rhs
+ return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdRhs = rhs', tcdFVs = fvs })
+
+ DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdDataDefn = defn, tcdFVs = fvs } -> do
+ lname' <- renameL lname
+ tyvars' <- renameLTyVarBndrs tyvars
+ defn' <- renameDataDefn defn
+ return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdDataDefn = defn', tcdFVs = fvs })
+
+ ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars
+ , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do
+ lcontext' <- renameLContext lcontext
+ lname' <- renameL lname
+ ltyvars' <- renameLTyVarBndrs ltyvars
+ lfundeps' <- mapM renameLFunDep lfundeps
+ lsigs' <- mapM renameLSig lsigs
+ ats' <- mapM (renameLThing renameFamilyDecl) ats
+ at_defs' <- mapM (mapM renameTyFamInstD) at_defs
+ -- we don't need the default methods or the already collected doc entities
+ return (ClassDecl { tcdCtxt = lcontext', tcdLName = lname', tcdTyVars = ltyvars'
+ , tcdFDs = lfundeps', tcdSigs = lsigs', tcdMeths= emptyBag
+ , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdFVs = placeHolderNames })
+
+ where
+ renameLFunDep (L loc (xs, ys)) = do
+ xs' <- mapM rename xs
+ ys' <- mapM rename ys
+ return (L loc (xs', ys'))
+
+ renameLSig (L loc sig) = return . L loc =<< renameSig sig
+
+renameFamilyDecl :: FamilyDecl Name -> RnM (FamilyDecl DocName)
+renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname
+ , fdTyVars = ltyvars, fdKindSig = tckind }) = do
+ info' <- renameFamilyInfo info
+ lname' <- renameL lname
+ ltyvars' <- renameLTyVarBndrs ltyvars
+ tckind' <- renameMaybeLKind tckind
+ return (FamilyDecl { fdInfo = info', fdLName = lname'
+ , fdTyVars = ltyvars', fdKindSig = tckind' })
+
+renameFamilyInfo :: FamilyInfo Name -> RnM (FamilyInfo DocName)
+renameFamilyInfo DataFamily = return DataFamily
+renameFamilyInfo OpenTypeFamily = return OpenTypeFamily
+renameFamilyInfo (ClosedTypeFamily eqns)
+ = do { eqns' <- mapM (renameLThing renameTyFamInstEqn) eqns
+ ; return $ ClosedTypeFamily eqns' }
+
+renameDataDefn :: HsDataDefn Name -> RnM (HsDataDefn DocName)
+renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType
+ , dd_kindSig = k, dd_cons = cons }) = do
+ lcontext' <- renameLContext lcontext
+ k' <- renameMaybeLKind k
+ cons' <- mapM (mapM renameCon) cons
+ -- I don't think we need the derivings, so we return Nothing
+ return (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType
+ , dd_kindSig = k', dd_cons = cons', dd_derivs = Nothing })
+
+renameCon :: ConDecl Name -> RnM (ConDecl DocName)
+renameCon decl@(ConDecl { con_name = lname, con_qvars = ltyvars
+ , con_cxt = lcontext, con_details = details
+ , con_res = restype, con_doc = mbldoc }) = do
+ lname' <- renameL lname
+ ltyvars' <- renameLTyVarBndrs ltyvars
+ lcontext' <- renameLContext lcontext
+ details' <- renameDetails details
+ restype' <- renameResType restype
+ mbldoc' <- mapM renameLDocHsSyn mbldoc
+ return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext'
+ , con_details = details', con_res = restype', con_doc = mbldoc' })
+ where
+ renameDetails (RecCon fields) = return . RecCon =<< mapM renameConDeclFieldField fields
+ renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps
+ renameDetails (InfixCon a b) = do
+ a' <- renameLType a
+ b' <- renameLType b
+ return (InfixCon a' b')
+
+ renameResType (ResTyH98) = return ResTyH98
+ renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t
+
+
+renameConDeclFieldField :: ConDeclField Name -> RnM (ConDeclField DocName)
+renameConDeclFieldField (ConDeclField name t doc) = do
+ name' <- renameL name
+ t' <- renameLType t
+ doc' <- mapM renameLDocHsSyn doc
+ return (ConDeclField name' t' doc')
+
+
+renameSig :: Sig Name -> RnM (Sig DocName)
+renameSig sig = case sig of
+ TypeSig lnames ltype -> do
+ lnames' <- mapM renameL lnames
+ ltype' <- renameLType ltype
+ return (TypeSig lnames' ltype')
+ PatSynSig lname args ltype lreq lprov -> do
+ lname' <- renameL lname
+ args' <- case args of
+ PrefixPatSyn largs -> PrefixPatSyn <$> mapM renameLType largs
+ InfixPatSyn lleft lright -> InfixPatSyn <$> renameLType lleft <*> renameLType lright
+ ltype' <- renameLType ltype
+ lreq' <- renameLContext lreq
+ lprov' <- renameLContext lprov
+ return $ PatSynSig lname' args' ltype' lreq' lprov'
+ FixSig (FixitySig lname fixity) -> do
+ lname' <- renameL lname
+ return $ FixSig (FixitySig lname' fixity)
+ MinimalSig s -> MinimalSig <$> traverse renameL s
+ -- we have filtered out all other kinds of signatures in Interface.Create
+ _ -> error "expected TypeSig"
+
+
+renameForD :: ForeignDecl Name -> RnM (ForeignDecl DocName)
+renameForD (ForeignImport lname ltype co x) = do
+ lname' <- renameL lname
+ ltype' <- renameLType ltype
+ return (ForeignImport lname' ltype' co x)
+renameForD (ForeignExport lname ltype co x) = do
+ lname' <- renameL lname
+ ltype' <- renameLType ltype
+ return (ForeignExport lname' ltype' co x)
+
+
+renameInstD :: InstDecl Name -> RnM (InstDecl DocName)
+renameInstD (ClsInstD { cid_inst = d }) = do
+ d' <- renameClsInstD d
+ return (ClsInstD { cid_inst = d' })
+renameInstD (TyFamInstD { tfid_inst = d }) = do
+ d' <- renameTyFamInstD d
+ return (TyFamInstD { tfid_inst = d' })
+renameInstD (DataFamInstD { dfid_inst = d }) = do
+ d' <- renameDataFamInstD d
+ return (DataFamInstD { dfid_inst = d' })
+
+renameClsInstD :: ClsInstDecl Name -> RnM (ClsInstDecl DocName)
+renameClsInstD (ClsInstDecl { cid_poly_ty =ltype, cid_tyfam_insts = lATs, cid_datafam_insts = lADTs }) = do
+ ltype' <- renameLType ltype
+ lATs' <- mapM (mapM renameTyFamInstD) lATs
+ lADTs' <- mapM (mapM renameDataFamInstD) lADTs
+ return (ClsInstDecl { cid_poly_ty = ltype', cid_binds = emptyBag, cid_sigs = []
+ , cid_tyfam_insts = lATs', cid_datafam_insts = lADTs' })
+
+
+renameTyFamInstD :: TyFamInstDecl Name -> RnM (TyFamInstDecl DocName)
+renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })
+ = do { eqn' <- renameLThing renameTyFamInstEqn eqn
+ ; return (TyFamInstDecl { tfid_eqn = eqn'
+ , tfid_fvs = placeHolderNames }) }
+
+renameTyFamInstEqn :: TyFamInstEqn Name -> RnM (TyFamInstEqn DocName)
+renameTyFamInstEqn (TyFamInstEqn { tfie_tycon = tc, tfie_pats = pats_w_bndrs, tfie_rhs = rhs })
+ = do { tc' <- renameL tc
+ ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs)
+ ; rhs' <- renameLType rhs
+ ; return (TyFamInstEqn { tfie_tycon = tc', tfie_pats = pats_w_bndrs { hswb_cts = pats' }
+ , tfie_rhs = rhs' }) }
+
+renameDataFamInstD :: DataFamInstDecl Name -> RnM (DataFamInstDecl DocName)
+renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats_w_bndrs, dfid_defn = defn })
+ = do { tc' <- renameL tc
+ ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs)
+ ; defn' <- renameDataDefn defn
+ ; return (DataFamInstDecl { dfid_tycon = tc', dfid_pats = pats_w_bndrs { hswb_cts = pats' }
+ , dfid_defn = defn', dfid_fvs = placeHolderNames }) }
+
+renameExportItem :: ExportItem Name -> RnM (ExportItem DocName)
+renameExportItem item = case item of
+ ExportModule mdl -> return (ExportModule mdl)
+ ExportGroup lev id_ doc -> do
+ doc' <- renameDoc doc
+ return (ExportGroup lev id_ doc')
+ ExportDecl decl doc subs instances fixities splice -> do
+ decl' <- renameLDecl decl
+ doc' <- renameDocForDecl doc
+ subs' <- mapM renameSub subs
+ instances' <- forM instances $ \(inst, idoc) -> do
+ inst' <- renameInstHead inst
+ idoc' <- mapM renameDoc idoc
+ return (inst', idoc')
+ fixities' <- forM fixities $ \(name, fixity) -> do
+ name' <- lookupRn name
+ return (name', fixity)
+ return (ExportDecl decl' doc' subs' instances' fixities' splice)
+ ExportNoDecl x subs -> do
+ x' <- lookupRn x
+ subs' <- mapM lookupRn subs
+ return (ExportNoDecl x' subs')
+ ExportDoc doc -> do
+ doc' <- renameDoc doc
+ return (ExportDoc doc')
+
+
+renameSub :: (Name, DocForDecl Name) -> RnM (DocName, DocForDecl DocName)
+renameSub (n,doc) = do
+ n' <- rename n
+ doc' <- renameDocForDecl doc
+ return (n', doc')