diff options
| author | David Waern <david.waern@gmail.com> | 2010-05-13 19:51:10 +0000 | 
|---|---|---|
| committer | David Waern <david.waern@gmail.com> | 2010-05-13 19:51:10 +0000 | 
| commit | 4c859013da2ed2822bedafc72080028eb3f0ae7b (patch) | |
| tree | a38cf490703ef77b95c1b3853bd68349d72f9567 /src/Haddock | |
| parent | 3cf0ab44b650effc5de6ec4096139b4681ba5f3b (diff) | |
Fix stylistic issues in H.Utils
Diffstat (limited to 'src/Haddock')
| -rw-r--r-- | src/Haddock/Utils.hs | 43 | 
1 files changed, 38 insertions, 5 deletions
| diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs index 9e7aeb2a..9a712d70 100644 --- a/src/Haddock/Utils.hs +++ b/src/Haddock/Utils.hs @@ -38,9 +38,6 @@ module Haddock.Utils (    -- * List utilities    replace, -  -- * Binary extras ---  FormatVersion, mkFormatVersion   -      -- * MTL stuff    MonadIO(..), @@ -49,6 +46,7 @@ module Haddock.Utils (    out   ) where +  import Haddock.Types  import Haddock.GhcUtils @@ -99,11 +97,12 @@ out progVerbosity msgVerbosity msg  -- Some Utilities --- | extract a module's short description. +-- | Extract a module's short description.  toDescription :: Interface -> Maybe (Doc Name)  toDescription = hmi_description . ifaceInfo --- | extract a module's short description. + +-- | Extract a module's short description.  toInstalledDescription :: InstalledInterface -> Maybe (Doc Name)  toInstalledDescription = hmi_description . instInfo @@ -111,6 +110,7 @@ toInstalledDescription = hmi_description . instInfo  -- ---------------------------------------------------------------------------  -- Making abstract declarations +  restrictTo :: [Name] -> (LHsDecl Name) -> (LHsDecl Name)  restrictTo names (L loc decl) = L loc $ case decl of    TyClD d | isDataDecl d && tcdND d == DataType ->  @@ -124,6 +124,7 @@ restrictTo names (L loc decl) = L loc $ case decl of      TyClD (d { tcdSigs = restrictDecls names (tcdSigs d),                 tcdATs = restrictATs names (tcdATs d) })    _ -> decl +  restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name]  restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]   @@ -145,6 +146,7 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]      keep _ | otherwise = Nothing +  restrictDecls :: [Name] -> [LSig Name] -> [LSig Name]  restrictDecls names decls = filter keep decls    where keep d = fromJust (sigName d) `elem` names @@ -158,6 +160,7 @@ restrictATs names ats = [ at | at <- ats , tcdName (unL at) `elem` names ]  -- -----------------------------------------------------------------------------  -- Filename mangling functions stolen from s main/DriverUtil.lhs. +  moduleHtmlFile :: Module -> FilePath  moduleHtmlFile mdl =    case Map.lookup mdl html_xrefs of @@ -167,33 +170,40 @@ moduleHtmlFile mdl =     mdl' = map (\c -> if c == '.' then '-' else c)                 (moduleNameString (moduleName mdl)) +  nameHtmlRef :: Module -> OccName -> String	  nameHtmlRef mdl n = moduleHtmlFile mdl ++ '#':escapeStr (anchorNameStr n) +  contentsHtmlFile, indexHtmlFile :: String  contentsHtmlFile = "index.html"  indexHtmlFile = "doc-index.html" +  -- | The name of the module index file to be displayed inside a frame.  -- Modules are display in full, but without indentation.  Clicking opens in  -- the main window.  frameIndexHtmlFile :: String  frameIndexHtmlFile = "index-frames.html" +  moduleIndexFrameName, mainFrameName, synopsisFrameName :: String  moduleIndexFrameName = "modules"  mainFrameName = "main"  synopsisFrameName = "synopsis" +  subIndexHtmlFile :: Char -> String  subIndexHtmlFile a = "doc-index-" ++ b ++ ".html"     where b | isAlpha a = [a]             | otherwise = show (ord a) +  anchorNameStr :: OccName -> String  anchorNameStr name | isValOcc name = "v:" ++ occNameString name                      | otherwise     = "t:" ++ occNameString name +  pathJoin :: [FilePath] -> FilePath  pathJoin = foldr join []    where join :: FilePath -> FilePath -> FilePath @@ -203,9 +213,11 @@ pathJoin = foldr join []            | isPathSeparator (last path1) = path1++path2            | otherwise                    = path1++pathSeparator:path2 +  -- -----------------------------------------------------------------------------  -- Files we need to copy from our $libdir +  cssFile, iconFile, jsFile, plusFile, minusFile, framesFile :: String  cssFile   = "haddock.css"  iconFile  = "haskell_icon.gif" @@ -214,38 +226,48 @@ plusFile  = "plus.gif"  minusFile = "minus.gif"  framesFile = "frames.html" +  -----------------------------------------------------------------------------  -- misc. +  getProgramName :: IO String  getProgramName = liftM (`withoutSuffix` ".bin") getProgName     where str `withoutSuffix` suff              | suff `isSuffixOf` str = take (length str - length suff) str              | otherwise             = str +  bye :: String -> IO a  bye s = putStr s >> exitWith ExitSuccess +  die :: String -> IO a  die s = hPutStr stderr s >> exitWith (ExitFailure 1) +  dieMsg :: String -> IO a  dieMsg s = getProgramName >>= \prog -> die (prog ++ ": " ++ s) +  noDieMsg :: String -> IO ()  noDieMsg s = getProgramName >>= \prog -> hPutStr stderr (prog ++ ": " ++ s) +  mapSnd :: (b -> c) -> [(a,b)] -> [(a,c)]  mapSnd _ [] = []  mapSnd f ((x,y):xs) = (x,f y) : mapSnd f xs +  mapMaybeM :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b)  mapMaybeM _ Nothing = return Nothing  mapMaybeM f (Just a) = liftM Just (f a) +  escapeStr :: String -> String  escapeStr = escapeURIString isUnreserved +  -- Following few functions are copy'n'pasted from Network.URI module  -- to avoid depending on the network lib, since doing so gives a  -- circular build dependency between haddock and network @@ -265,9 +287,11 @@ escapeURIChar p c              | d < 10    = chr (ord '0' + fromIntegral d)              | otherwise = chr (ord 'A' + fromIntegral (d - 10)) +  escapeURIString :: (Char -> Bool) -> String -> String  escapeURIString = concatMap . escapeURIChar +  isUnreserved :: Char -> Bool  isUnreserved c = isAlphaNumChar c || (c `elem` "-_.~") @@ -288,10 +312,12 @@ isAlphaNumChar c = isAlphaChar c || isDigitChar c  -- mapping is constant for any single run of Haddock.  So for the time  -- being I'm going to use a write-once global variable. +  {-# NOINLINE html_xrefs_ref #-}  html_xrefs_ref :: IORef (Map Module FilePath)  html_xrefs_ref = unsafePerformIO (newIORef (error "module_map")) +  {-# NOINLINE html_xrefs #-}  html_xrefs :: Map Module FilePath  html_xrefs = unsafePerformIO (readIORef html_xrefs_ref) @@ -309,6 +335,7 @@ replace a b = map (\x -> if x == a then b else x)  -----------------------------------------------------------------------------  -- put here temporarily +  markup :: DocMarkup id a -> Doc id -> a  markup m DocEmpty              = markupEmpty m  markup m (DocAppend d1 d2)     = markupAppend m (markup m d1) (markup m d2) @@ -327,9 +354,11 @@ markup m (DocAName ref)        = markupAName m ref  markup m (DocPic img)          = markupPic m img  markup m (DocExamples e)       = markupExample m e +  markupPair :: DocMarkup id a -> (Doc id, Doc id) -> (a, a)  markupPair m (a,b) = (markup m a, markup m b) +  -- | The identity markup  idMarkup :: DocMarkup a (Doc a)  idMarkup = Markup { @@ -355,14 +384,18 @@ idMarkup = Markup {  -----------------------------------------------------------------------------  -- put here temporarily +  newtype FormatVersion = FormatVersion Int deriving (Eq,Ord) +  nullFormatVersion :: FormatVersion  nullFormatVersion = mkFormatVersion 0 +  mkFormatVersion :: Int -> FormatVersion  mkFormatVersion = FormatVersion +  instance Binary FormatVersion where     put_ bh (FormatVersion i) =        case compare i 0 of | 
