diff options
Diffstat (limited to 'haddock-api/src/Haddock/Interface')
| -rw-r--r-- | haddock-api/src/Haddock/Interface/AttachInstances.hs | 229 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Create.hs | 868 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/LexParseRn.hs | 141 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/ParseModuleHeader.hs | 150 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Rename.hs | 532 |
5 files changed, 1920 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..1341e57f --- /dev/null +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -0,0 +1,229 @@ +{-# 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 hiding ((<+>)) +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 DynFlags +import ErrUtils +import FamInstEnv +import FastString +import GHC +import GhcMonad (withSession) +import Id +import InstEnv +import MonadUtils (liftIO) +import Name +import Outputable (text, sep, (<+>)) +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) + insts <- 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 + ] + -- fam_insts but with failing type fams filtered out + cleanFamInsts = [ (fi, n) | (Right fi, n) <- fam_insts ] + famInstErrs = [ errm | (Left errm, _) <- fam_insts ] + in do + dfs <- getDynFlags + let mkBug = (text "haddock-bug:" <+>) . text + liftIO $ putMsg dfs (sep $ map mkBug famInstErrs) + return $ cls_insts ++ cleanFamInsts + Nothing -> return [] + return $ e { expItemInstances = insts } + 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..98a715a9 --- /dev/null +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -0,0 +1,868 @@ +{-# 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 (metaDocAppend) +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) +import qualified Outputable as O + +-- | 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.fsToPackageKey $ + ideclPkgQual impDecl) + (case ideclName impDecl of SrcLoc.L _ name -> name), + alias)) + impDecls + +-- similar to GHC.lookupModule +lookupModuleDyn :: + DynFlags -> Maybe PackageKey -> ModuleName -> Module +lookupModuleDyn _ (Just pkgId) mdlName = + Module.mkModule pkgId mdlName +lookupModuleDyn dflags Nothing mdlName = + case Packages.lookupModuleInAllPackages dflags mdlName of + (m,_):_ -> m + [] -> Module.mkModule Module.mainPackageKey mdlName + + +------------------------------------------------------------------------------- +-- 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 $ map unLoc msg) + WarningTxt msg -> format "Warning: " (concatFS $ map unLoc 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, MDoc Name)]] -> Map Name (MDoc Name) + f' = M.fromListWith metaDocAppend . concat + + mappings :: (LHsDecl Name, [HsDocString]) + -> ( [(Name, MDoc Name)] + , [(Name, Map Int (MDoc Name))] + , [(Name, [Name])] + , [(Name, [LHsDecl Name])] + ) + mappings (ldecl, docStrs) = + let L l decl = ldecl + declDoc :: [HsDocString] -> Map Int HsDocString + -> (Maybe (MDoc Name), Map Int (MDoc 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 cname, maybeToList $ fmap unL $ con_doc c, M.empty) + | c <- cons, cname <- con_names c ] + fields = [ (unL n, maybeToList $ fmap unL doc, M.empty) + | RecCon flds <- map con_details cons + , L _ (ConDeclField ns _ doc) <- flds + , n <- ns ] + +-- | 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 _ _ req prov ty) -> + let allTys = ty : concat [ 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_ + defs = mkDecls (bagToList . tcdMeths) ValD class_ + 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 ns f) <- hs_fixds group_, + L _ n <- ns ] + + +-- | 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_ ++ + mkDecls (valbinds . hs_valds) ValD group_ + 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 (L _ x)) = declWith x + lookupExport (IEThingAbs t) = declWith t + lookupExport (IEThingAll (L _ t)) = declWith t + lookupExport (IEThingWith (L _ t) _) = declWith t + lookupExport (IEModuleContents (L _ 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 -> case tyThingToLHsDecl x of + Left m -> liftErrMsg (tell [bugWarn m]) >> return Nothing + Right (m, t') -> liftErrMsg (tell $ map bugWarn m) + >> return (Just $ noLoc t') + where + warnLine x = O.text "haddock-bug:" O.<+> O.text x O.<> + O.comma O.<+> O.quotes (O.ppr t) O.<+> + O.text "-- Please report this on Haddock issue tracker!" + bugWarn = O.showSDoc dflags . warnLine + +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 packageKey expMod + packageKey = modulePackageKey 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 nwcs))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t nwcs)) : 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_names = ns } <- map unLoc rec + , L _ n <- ns + , 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 Nothing tvs (lctxt preds) ty)) []) + _ -> L pos (TypeSig lname (noLoc (HsForAllTy Implicit Nothing 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 | ((n,L _ (ConDeclField _nn 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 = [ (n,f) | f@(L _ (ConDeclField ns _ _)) <- flds, n <- ns, 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..35abf8a6 --- /dev/null +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -0,0 +1,141 @@ +{-# 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 (metaDocConcat) +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 (MDoc Name) +processDocStrings dflags gre strs = + case metaDocConcat $ map (processDocStringParas dflags gre) strs of + -- We check that we don't have any version info to render instead + -- of just checking if there is no comment: there may not be a + -- comment but we still want to pass through any meta data. + MetaDoc { _meta = Meta { _version = Nothing }, _doc = DocEmpty } -> Nothing + x -> Just x + +processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> MDoc Name +processDocStringParas dflags gre (HsDocString fs) = + overDoc (rename dflags gre) $ parseParas dflags (unpackFS fs) + +processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> Doc Name +processDocString dflags gre (HsDocString fs) = + rename dflags gre $ parseString dflags (unpackFS fs) + +processModuleHeader :: DynFlags -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString + -> ErrMsgM (HaddockModInfo Name, Maybe (MDoc 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' = overDoc (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..d92e8b2a --- /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, MDoc 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..1ea212f5 --- /dev/null +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -0,0 +1,532 @@ +{-# LANGUAGE TypeFamilies #-} +---------------------------------------------------------------------------- +-- | +-- 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, Traversable) + +import Haddock.GhcUtils +import Haddock.Types + +import Bag (emptyBag) +import GHC hiding (NoLink) +import Name +import NameSet +import Coercion + +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 :: Traversable t => t Name -> RnM (t 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 extra tyvars lcontext ltype -> do + tyvars' <- renameLTyVarBndrs tyvars + lcontext' <- renameLContext lcontext + ltype' <- renameLType ltype + return (HsForAllTy expl extra 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" + HsWildcardTy -> pure HsWildcardTy + HsNamedWildcardTy a -> HsNamedWildcardTy <$> rename a + +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 +-- 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 = placeHolderNames }) + + 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 = placeHolderNames }) + + 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 renameLTyFamDefltEqn 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 renameLTyFamInstEqn 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_names = lnames, con_qvars = ltyvars + , con_cxt = lcontext, con_details = details + , con_res = restype, con_doc = mbldoc }) = do + lnames' <- mapM renameL lnames + ltyvars' <- renameLTyVarBndrs ltyvars + lcontext' <- renameLContext lcontext + details' <- renameDetails details + restype' <- renameResType restype + mbldoc' <- mapM renameLDocHsSyn mbldoc + return (decl { con_names = lnames', con_qvars = ltyvars', con_cxt = lcontext' + , con_details = details', con_res = restype', con_doc = mbldoc' }) + + where + renameDetails (RecCon fields) = do + fields' <- mapM renameConDeclFieldField fields + return (RecCon 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 :: LConDeclField Name -> RnM (LConDeclField DocName) +renameConDeclFieldField (L l (ConDeclField names t doc)) = do + names' <- mapM renameL names + t' <- renameLType t + doc' <- mapM renameLDocHsSyn doc + return $ L l (ConDeclField names' 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' PlaceHolder) + PatSynSig lname (flag, qtvs) lreq lprov lty -> do + lname' <- renameL lname + qtvs' <- renameLTyVarBndrs qtvs + lreq' <- renameLContext lreq + lprov' <- renameLContext lprov + lty' <- renameLType lty + return $ PatSynSig lname' (flag, qtvs') lreq' lprov' lty' + FixSig (FixitySig lnames fixity) -> do + lnames' <- mapM renameL lnames + return $ FixSig (FixitySig lnames' 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_overlap_mode = omode + , 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_overlap_mode = omode + , 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' <- renameLTyFamInstEqn eqn + ; return (TyFamInstDecl { tfid_eqn = eqn' + , tfid_fvs = placeHolderNames }) } + +renameLTyFamInstEqn :: LTyFamInstEqn Name -> RnM (LTyFamInstEqn DocName) +renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats_w_bndrs, tfe_rhs = rhs })) + = do { tc' <- renameL tc + ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs) + ; rhs' <- renameLType rhs + ; return (L loc (TyFamEqn { tfe_tycon = tc' + , tfe_pats = HsWB pats' PlaceHolder PlaceHolder PlaceHolder + , tfe_rhs = rhs' })) } + +renameLTyFamDefltEqn :: LTyFamDefltEqn Name -> RnM (LTyFamDefltEqn DocName) +renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_rhs = rhs })) + = do { tc' <- renameL tc + ; tvs' <- renameLTyVarBndrs tvs + ; rhs' <- renameLType rhs + ; return (L loc (TyFamEqn { tfe_tycon = tc' + , tfe_pats = tvs' + , tfe_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 + = HsWB pats' PlaceHolder PlaceHolder PlaceHolder + , 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') + +type instance PostRn DocName NameSet = PlaceHolder +type instance PostRn DocName Fixity = PlaceHolder +type instance PostRn DocName Bool = PlaceHolder +type instance PostRn DocName [Name] = PlaceHolder + +type instance PostTc DocName Kind = PlaceHolder +type instance PostTc DocName Type = PlaceHolder +type instance PostTc DocName Coercion = PlaceHolder |