From 779b4b9c7bf3fe321a5dfc16122e5a1795fa2ba3 Mon Sep 17 00:00:00 2001 From: David Waern Date: Sat, 28 Mar 2009 00:03:55 +0000 Subject: -Wall police in H.I.Rename --- src/Haddock/Interface/Rename.hs | 87 +++++++++++++++++++++++------------------ 1 file changed, 49 insertions(+), 38 deletions(-) (limited to 'src/Haddock/Interface/Rename.hs') diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index 17fe1223..82b3b618 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -16,41 +16,37 @@ import Name import BasicTypes import SrcLoc import Bag (emptyBag) -import Outputable -import Util (thenCmp) import Data.List -import Data.Map (Map) import qualified Data.Map as Map hiding ( Map ) import Prelude hiding (mapM) import Data.Traversable (mapM) -import Control.Arrow import Control.Monad hiding (mapM) renameInterface :: LinkEnv -> Bool -> Interface -> ErrMsgM Interface -renameInterface renamingEnv warnings mod = +renameInterface 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 mod) - where fn env name = Map.insert name (ifaceMod mod) env + let localEnv = foldl fn renamingEnv (ifaceVisibleExports iface) + where fn env name = Map.insert name (ifaceMod iface) env - docMap = Map.map (\(_,x,_) -> x) (ifaceDeclMap mod) + docMap = Map.map (\(_,x,_) -> x) (ifaceDeclMap iface) docs = [ (n, doc) | (n, Just doc) <- Map.toList docMap ] renameMapElem (k,d) = do d' <- renameDoc d; return (k, d') -- 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 mod)) + = runRnFM localEnv (renameExportItems (ifaceExportItems iface)) (rnDocMap, missingNames2) = runRnFM localEnv (liftM Map.fromList (mapM renameMapElem docs)) (finalModuleDoc, missingNames3) - = runRnFM localEnv (renameMaybeDoc (ifaceDoc mod)) + = runRnFM localEnv (renameMaybeDoc (ifaceDoc iface)) -- combine the missing names and filter out the built-ins, which would -- otherwise allways be missing. @@ -66,14 +62,14 @@ renameInterface renamingEnv warnings mod = in do -- report things that we couldn't link to. Only do this for non-hidden -- modules. - unless (OptHide `elem` ifaceOptions mod || null strings || not warnings) $ - tell ["Warning: " ++ moduleString (ifaceMod mod) ++ + unless (OptHide `elem` ifaceOptions iface || null strings || not warnings) $ + tell ["Warning: " ++ moduleString (ifaceMod iface) ++ ": could not find link destinations for:\n"++ " " ++ concat (map (' ':) strings) ] - return $ mod { ifaceRnDoc = finalModuleDoc, - ifaceRnDocMap = rnDocMap, - ifaceRnExportItems = renamedExportItems } + return $ iface { ifaceRnDoc = finalModuleDoc, + ifaceRnDocMap = rnDocMap, + ifaceRnExportItems = renamedExportItems } -------------------------------------------------------------------------------- @@ -121,7 +117,7 @@ runRnFM env rn = unRn rn lkp where lkp n = case Map.lookup n env of Nothing -> (False, Undocumented n) - Just mod -> (True, Documented n mod) + Just mdl -> (True, Documented n mdl) -------------------------------------------------------------------------------- @@ -145,11 +141,12 @@ renameMaybeDoc :: Maybe (HsDoc Name) -> RnM (Maybe (HsDoc DocName)) renameMaybeDoc mbDoc = mapM renameDoc mbDoc -renameLDoc (L loc doc) = return . L loc =<< renameDoc doc +renameLDoc :: LHsDoc Name -> RnM (LHsDoc DocName) +renameLDoc = mapM renameDoc renameDoc :: HsDoc Name -> RnM (HsDoc DocName) -renameDoc doc = case doc of +renameDoc d = case d of DocEmpty -> return DocEmpty DocAppend a b -> do a' <- renameDoc a @@ -191,7 +188,8 @@ renameDoc doc = case doc of DocAName str -> return (DocAName str) -renameLPred (L loc p) = return . L loc =<< renamePred p +renameLPred :: LHsPred Name -> RnM (LHsPred DocName) +renameLPred = mapM renamePred renamePred :: HsPred Name -> RnM (HsPred DocName) @@ -209,9 +207,11 @@ renamePred (HsIParam (IPName name) t) = do return (HsIParam (IPName name') t') -renameLType (L loc t) = return . L loc =<< renameType t +renameLType :: LHsType Name -> RnM (LHsType DocName) +renameLType = mapM renameType +renameType :: HsType Name -> RnM (HsType DocName) renameType t = case t of HsForAllTy expl tyvars lcontext ltype -> do tyvars' <- mapM renameLTyVarBndr tyvars @@ -232,8 +232,8 @@ renameType t = case t of b' <- renameLType b return (HsFunTy a' b') - HsListTy t -> return . HsListTy =<< renameLType t - HsPArrTy t -> return . HsPArrTy =<< renameLType t + HsListTy ty -> return . HsListTy =<< renameLType ty + HsPArrTy ty -> return . HsPArrTy =<< renameLType ty HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts @@ -243,29 +243,31 @@ renameType t = case t of b' <- renameLType b return (HsOpTy a' (L loc op') b') - HsParTy t -> return . HsParTy =<< renameLType t + HsParTy ty -> return . HsParTy =<< renameLType ty HsNumTy n -> return (HsNumTy n) HsPredTy p -> return . HsPredTy =<< renamePred p - HsKindSig t k -> do - t' <- renameLType t - return (HsKindSig t' k) + HsKindSig ty k -> do + ty' <- renameLType ty + return (HsKindSig ty' k) - HsDocTy t doc -> do - t' <- renameLType t + HsDocTy ty doc -> do + ty' <- renameLType ty doc' <- renameLDoc doc - return (HsDocTy t' doc') + return (HsDocTy ty' doc') _ -> error "renameType" +renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName) renameLTyVarBndr (L loc tv) = do name' <- rename (hsTyVarName tv) return $ L loc (replaceTyVarName tv name') - + +renameLContext :: Located [LHsPred Name] -> RnM (Located [LHsPred DocName]) renameLContext (L loc context) = do context' <- mapM renameLPred context return (L loc context') @@ -279,10 +281,12 @@ renameInstHead (preds, className, types) = do return (preds', className', types') +renameLDecl :: LHsDecl Name -> RnM (LHsDecl DocName) renameLDecl (L loc d) = return . L loc =<< renameDecl d -renameDecl d = case d of +renameDecl :: HsDecl Name -> RnM (HsDecl DocName) +renameDecl decl = case decl of TyClD d -> do d' <- renameTyClD d return (TyClD d') @@ -298,9 +302,11 @@ renameDecl d = case d of _ -> error "renameDecl" +renameLTyClD :: LTyClDecl Name -> RnM (LTyClDecl DocName) renameLTyClD (L loc d) = return . L loc =<< renameTyClD d +renameTyClD :: TyClDecl Name -> RnM (TyClDecl DocName) renameTyClD d = case d of ForeignType lname a b -> do lname' <- renameL lname @@ -371,15 +377,18 @@ renameTyClD d = case d of renameLSig (L loc sig) = return . L loc =<< renameSig sig - + +renameSig :: Sig Name -> RnM (Sig DocName) renameSig sig = case sig of TypeSig lname ltype -> do lname' <- renameL lname ltype' <- renameLType ltype - return (TypeSig lname' ltype') + return (TypeSig lname' ltype') -- 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 x) = do lname' <- renameL lname ltype' <- renameLType ltype @@ -390,18 +399,19 @@ renameForD (ForeignExport lname ltype x) = do return (ForeignExport lname' ltype' x) +renameInstD :: InstDecl Name -> RnM (InstDecl DocName) renameInstD (InstDecl ltype _ _ lATs) = do - ltype <- renameLType ltype + ltype' <- renameLType ltype lATs' <- mapM renameLTyClD lATs - return (InstDecl ltype emptyBag [] lATs') + return (InstDecl ltype' emptyBag [] lATs') renameExportItem :: ExportItem Name -> RnM (ExportItem DocName) renameExportItem item = case item of - ExportModule mod -> return (ExportModule mod) - ExportGroup lev id doc -> do + ExportModule mdl -> return (ExportModule mdl) + ExportGroup lev id_ doc -> do doc' <- renameDoc doc - return (ExportGroup lev id doc') + return (ExportGroup lev id_ doc') ExportDecl decl doc subs instances -> do decl' <- renameLDecl decl doc' <- mapM renameDoc doc @@ -417,6 +427,7 @@ renameExportItem item = case item of return (ExportDoc doc') +renameSub :: (Name, Maybe (HsDoc Name)) -> RnM (DocName, Maybe (HsDoc DocName)) renameSub (n,doc) = do n' <- rename n doc' <- mapM renameDoc doc -- cgit v1.2.3