src/Haddock/Interface/LexParseRn.hs

+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Haddock.Interface.LexParseRn
+-- Copyright   :  (c) Isaac Dupree 2009,
+-- License     :  BSD-like
+--
+-- Maintainer  :  haddock@projects.haskell.org
+-- Stability   :  experimental
+-- Portability :  portable
+-----------------------------------------------------------------------------
+module Haddock.Interface.LexParseRn
+  ( HaddockCommentType(..)
+  , lexParseRnHaddockComment
+  , lexParseRnHaddockCommentList
+  , lexParseRnMbHaddockComment
+  , lexParseRnHaddockModHeader
+  ) where
+
+
+import Haddock.Types
+import Haddock.Lex
+import Haddock.Parse
+import Haddock.Interface.ParseModuleHeader
+import Haddock.Doc
+
+import Control.Applicative
+import Data.Maybe
+import FastString
+import GHC
+import Name
+import Outputable
+import RdrName
+import RnEnv
+
+
+data HaddockCommentType = NormalHaddockComment | DocSectionComment
+
+
+lexParseRnHaddockCommentList :: DynFlags -> HaddockCommentType -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (Doc Name))
+lexParseRnHaddockCommentList dflags hty gre docStrs = do
+  docMbs <- mapM (lexParseRnHaddockComment dflags hty gre) docStrs
+  let docs = catMaybes docMbs
+  let doc = foldl docAppend DocEmpty docs
+  case doc of
+    DocEmpty -> return Nothing
+    _ -> return (Just doc)
+
+
+lexParseRnHaddockComment :: DynFlags -> HaddockCommentType ->
+    GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name))
+lexParseRnHaddockComment dflags hty gre (HsDocString fs) = do
+   let str = unpackFS fs
+   let toks = tokenise dflags str (0,0) -- TODO: real position
+   let parse = case hty of
+         NormalHaddockComment -> parseParas
+         DocSectionComment -> parseString
+   case parse toks of
+     Nothing -> do
+       tell ["doc comment parse failed: "++str]
+       return Nothing
+     Just doc -> return (Just (rename gre doc))
+
+
+lexParseRnMbHaddockComment :: DynFlags -> HaddockCommentType -> GlobalRdrEnv -> Maybe HsDocString -> ErrMsgM (Maybe (Doc Name))
+lexParseRnMbHaddockComment _ _ _ Nothing = return Nothing
+lexParseRnMbHaddockComment dflags hty gre (Just d) = lexParseRnHaddockComment dflags hty gre d
+
+
+-- yes, you always get a HaddockModInfo though it might be empty
+lexParseRnHaddockModHeader :: DynFlags -> GlobalRdrEnv -> SafeHaskellMode -> GhcDocHdr
+                           -> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name))
+lexParseRnHaddockModHeader dflags gre safety mbStr = do
+  (hmi, docn) <-
+    case mbStr of
+      Nothing -> return failure
+      Just (L _ (HsDocString fs)) -> do
+        let str = unpackFS fs
+        case parseModuleHeader dflags str of
+          Left mess -> do
+            tell ["haddock module header parse failed: " ++ mess]
+            return failure
+          Right (info, doc) -> return (renameHmi gre info, Just (rename gre doc))
+  return (hmi { hmi_safety = Just $ showPpr safety }, docn)
+  where
+    failure = (emptyHaddockModInfo, Nothing)
+
+
+renameHmi :: GlobalRdrEnv -> HaddockModInfo RdrName -> HaddockModInfo Name
+renameHmi gre hmi = hmi { hmi_description = rename gre <$> hmi_description hmi }
+
+
+rename :: GlobalRdrEnv -> Doc RdrName -> Doc Name
+rename 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 (showSDoc $ ppr x))
+              [a] -> outOfScope a
+              a:b:_ | isRdrTc a -> outOfScope a | otherwise -> outOfScope 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.
+      DocEmphasis doc -> DocEmphasis (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
+      DocURL str -> DocURL str
+      DocPic str -> DocPic str
+      DocAName str -> DocAName str
+      DocExamples e -> DocExamples e
+      DocEmpty -> DocEmpty
+      DocString str -> DocString str
+
+
+outOfScope :: RdrName -> Doc a
+outOfScope 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 (showSDoc $ ppr a))

src/Haddock/Interface/ParseModuleHeader.hs

+-----------------------------------------------------------------------------
+-- |
+-- 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 Haddock.Types
+import Haddock.Lex
+import Haddock.Parse
+
+import RdrName
+import DynFlags
+
+import Data.Char
+
+-- -----------------------------------------------------------------------------
+-- 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 -> Either 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
+
+      description1 :: Either String (Maybe (Doc RdrName))
+      description1 = case descriptionOpt of
+         Nothing -> Right Nothing
+         -- TODO: pass real file position
+         Just description -> case parseString $ tokenise dflags description (0,0) of
+            Nothing -> Left ("Cannot parse Description: " ++ description)
+            Just doc -> Right (Just doc)
+   in
+      case description1 of
+         Left mess -> Left mess
+         -- TODO: pass real file position
+         Right docOpt -> case parseParas $ tokenise dflags str8 (0,0) of
+           Nothing -> Left "Cannot parse header documentation paragraphs"
+           Just doc -> Right (HaddockModInfo {
+            hmi_description = docOpt,
+            hmi_portability = portabilityOpt,
+            hmi_stability = stabilityOpt,
+            hmi_maintainer = maintainerOpt,
+            hmi_safety = Nothing
+            }, doc)
+
+-- | 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)
+         | True = ([],s)
+
+      extractNextLine :: String -> (String,String)
+      extractNextLine [] = ([],[])
+      extractNextLine (c:cs)
+         | c == '\n' =
+            ([],cs)
+         | True =
+            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
+         | True = Nothing
+

src/Haddock/Utils/FastMutInt2.hs

-{-# OPTIONS_GHC -cpp -fglasgow-exts #-}
---
--- (c) The University of Glasgow 2002
---
--- Unboxed mutable Ints
-
-module Haddock.Utils.FastMutInt2(
-	FastMutInt, newFastMutInt,
-	readFastMutInt, writeFastMutInt,
-	incFastMutInt, incFastMutIntBy
-  ) where
-
-#include "MachDeps.h"
-
-#ifndef SIZEOF_HSINT
-#define SIZEOF_HSINT  INT_SIZE_IN_BYTES
-#endif
-
-
-#if __GLASGOW_HASKELL__ < 503
-import GlaExts
-import PrelIOBase
-#else
-import GHC.Base
-import GHC.IOBase
-#endif
-
-#if __GLASGOW_HASKELL__ < 411
-newByteArray# = newCharArray#
-#endif
-
-#ifdef __GLASGOW_HASKELL__
-data FastMutInt = FastMutInt (MutableByteArray# RealWorld)
-
-newFastMutInt :: IO FastMutInt
-newFastMutInt = IO $ \s0 ->
-  case newByteArray# size s0 of { (# s, arr #) ->
-  (# s, FastMutInt arr #) }
-  where I# size = SIZEOF_HSINT
-
-readFastMutInt :: FastMutInt -> IO Int
-readFastMutInt (FastMutInt arr) = IO $ \s0 ->
-  case readIntArray# arr 0# s0 of { (# s, i #) ->
-  (# s, I# i #) }
-
-writeFastMutInt :: FastMutInt -> Int -> IO ()
-writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s0 ->
-  case writeIntArray# arr 0# i s0 of { s ->
-  (# s, () #) }
-
-incFastMutInt :: FastMutInt -> IO Int	-- Returns original value
-incFastMutInt (FastMutInt arr) = IO $ \s0 ->
-  case readIntArray# arr 0# s0 of { (# s1, i #) ->
-  case writeIntArray# arr 0# (i +# 1#) s1 of { s ->
-  (# s, I# i #) } }
-
-incFastMutIntBy :: FastMutInt -> Int -> IO Int	-- Returns original value
-incFastMutIntBy (FastMutInt arr) (I# n) = IO $ \s0 ->
-  case readIntArray# arr 0# s0 of { (# s1, i #) ->
-  case writeIntArray# arr 0# (i +# n) s1 of { s ->
-  (# s, I# i #) } }
-#endif
-