aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock/Interface
diff options
context:
space:
mode:
Diffstat (limited to 'src/Haddock/Interface')
-rw-r--r--src/Haddock/Interface/AttachInstances.hs221
-rw-r--r--src/Haddock/Interface/Create.hs867
-rw-r--r--src/Haddock/Interface/LexParseRn.hs146
-rw-r--r--src/Haddock/Interface/ParseModuleHeader.hs150
-rw-r--r--src/Haddock/Interface/Rename.hs506
5 files changed, 0 insertions, 1890 deletions
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')
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-22 04:43:58 +0000