From 5d41d4396425fc5c2e9b90d3e1e0baa5dc1ac224 Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Sat, 23 Aug 2014 10:09:34 +0100 Subject: Move sources under haddock-api/src --- src/Haddock/Interface/AttachInstances.hs | 221 -------- src/Haddock/Interface/Create.hs | 867 ----------------------------- src/Haddock/Interface/LexParseRn.hs | 146 ----- src/Haddock/Interface/ParseModuleHeader.hs | 150 ----- src/Haddock/Interface/Rename.hs | 506 ----------------- 5 files changed, 1890 deletions(-) delete mode 100644 src/Haddock/Interface/AttachInstances.hs delete mode 100644 src/Haddock/Interface/Create.hs delete mode 100644 src/Haddock/Interface/LexParseRn.hs delete mode 100644 src/Haddock/Interface/ParseModuleHeader.hs delete mode 100644 src/Haddock/Interface/Rename.hs (limited to 'src/Haddock/Interface') diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs deleted file mode 100644 index a0bac8fc..00000000 --- a/src/Haddock/Interface/AttachInstances.hs +++ /dev/null @@ -1,221 +0,0 @@ -{-# 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/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs deleted file mode 100644 index b66773ae..00000000 --- a/src/Haddock/Interface/Create.hs +++ /dev/null @@ -1,867 +0,0 @@ -{-# 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/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs deleted file mode 100644 index f1021436..00000000 --- a/src/Haddock/Interface/LexParseRn.hs +++ /dev/null @@ -1,146 +0,0 @@ -{-# 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/src/Haddock/Interface/ParseModuleHeader.hs b/src/Haddock/Interface/ParseModuleHeader.hs deleted file mode 100644 index 6848dc63..00000000 --- a/src/Haddock/Interface/ParseModuleHeader.hs +++ /dev/null @@ -1,150 +0,0 @@ -{-# 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/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs deleted file mode 100644 index 748e0210..00000000 --- a/src/Haddock/Interface/Rename.hs +++ /dev/null @@ -1,506 +0,0 @@ ----------------------------------------------------------------------------- --- | --- 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') -- cgit v1.2.3