compiler/parser/HaddockUtils.hs

   1 {-# OPTIONS -w #-}
   2 -- The above warning supression flag is a temporary kludge.
   3 -- While working on this module you are encouraged to remove it and fix
   4 -- any warnings in the module. See
   5 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
   6 -- for details
   7
   8 module HaddockUtils where
   9
  10 import HsSyn
  11 import HsDoc
  12 import {-# SOURCE #-} HaddockLex
  13 import HaddockParse
  14 import SrcLoc
  15 import RdrName
  16
  17 import Control.Monad
  18 import Data.Maybe
  19 import Data.Char
  20 import Data.Either
  21
  22 -- -----------------------------------------------------------------------------
  23 -- Parsing module headers
  24
  25 -- NB.  The headers must be given in the order Module, Description,
  26 -- Copyright, License, Maintainer, Stability, Portability, except that
  27 -- any or all may be omitted.
  28 parseModuleHeader :: String -> Either String (String, HaddockModInfo RdrName)
  29 parseModuleHeader str0 =
  30    let
  31       getKey :: String -> String -> (Maybe String,String)
  32       getKey key str = case parseKey key str of
  33          Nothing -> (Nothing,str)
  34          Just (value,rest) -> (Just value,rest)
  35
  36       (moduleOpt,str1) = getKey "Module" str0
  37       (descriptionOpt,str2) = getKey "Description" str1
  38       (copyrightOpt,str3) = getKey "Copyright" str2
  39       (licenseOpt,str4) = getKey "License" str3
  40       (licenceOpt,str5) = getKey "Licence" str4
  41       (maintainerOpt,str6) = getKey "Maintainer" str5
  42       (stabilityOpt,str7) = getKey "Stability" str6
  43       (portabilityOpt,str8) = getKey "Portability" str7
  44
  45       description1 :: Either String (Maybe (HsDoc RdrName))
  46       description1 = case descriptionOpt of
  47          Nothing -> Right Nothing
  48          Just description -> case parseHaddockString . tokenise $ description of
  49
  50             MyLeft mess -> Left ("Cannot parse Description: " ++ mess)
  51             MyRight doc -> Right (Just doc)
  52    in
  53       case description1 of
  54          Left mess -> Left mess
  55          Right docOpt -> Right (str8,HaddockModInfo {
  56             hmi_description = docOpt,
  57             hmi_portability = portabilityOpt,
  58             hmi_stability = stabilityOpt,
  59             hmi_maintainer = maintainerOpt
  60             })
  61
  62 -- | This function is how we read keys.
  63 --
  64 -- all fields in the header are optional and have the form
  65 --
  66 -- [spaces1][field name][spaces] ":"
  67 --    [text]"\n" ([spaces2][space][text]"\n" | [spaces]"\n")*
  68 -- where each [spaces2] should have [spaces1] as a prefix.
  69 --
  70 -- Thus for the key "Description",
  71 --
  72 -- > Description : this is a
  73 -- >    rather long
  74 -- >
  75 -- >    description
  76 -- >
  77 -- > The module comment starts here
  78 --
  79 -- the value will be "this is a .. description" and the rest will begin
  80 -- at "The module comment".
  81 parseKey :: String -> String -> Maybe (String,String)
  82 parseKey key toParse0 =
  83    do
  84       let
  85          (spaces0,toParse1) = extractLeadingSpaces toParse0
  86
  87          indentation = spaces0
  88       afterKey0 <- extractPrefix key toParse1
  89       let
  90          afterKey1 = extractLeadingSpaces afterKey0
  91       afterColon0 <- case snd afterKey1 of
  92          ':':afterColon -> return afterColon
  93          _ -> Nothing
  94       let
  95          (_,afterColon1) = extractLeadingSpaces afterColon0
  96
  97       return (scanKey True indentation afterColon1)
  98    where
  99       scanKey :: Bool -> String -> String -> (String,String)
 100       scanKey isFirst indentation [] = ([],[])
 101       scanKey isFirst indentation str =
 102          let
 103             (nextLine,rest1) = extractNextLine str
 104
 105             accept = isFirst || sufficientIndentation || allSpaces
 106
 107             sufficientIndentation = case extractPrefix indentation nextLine of
 108                Just (c:_) | isSpace c -> True
 109                _ -> False
 110
 111             allSpaces = case extractLeadingSpaces nextLine of
 112                (_,[]) -> True
 113                _ -> False
 114          in
 115             if accept
 116                then
 117                   let
 118                      (scanned1,rest2) = scanKey False indentation rest1
 119
 120                      scanned2 = case scanned1 of
 121                         "" -> if allSpaces then "" else nextLine
 122                         _ -> nextLine ++ "\n" ++ scanned1
 123                   in
 124                      (scanned2,rest2)
 125                else
 126                   ([],str)
 127
 128       extractLeadingSpaces :: String -> (String,String)
 129       extractLeadingSpaces [] = ([],[])
 130       extractLeadingSpaces (s@(c:cs))
 131          | isSpace c =
 132             let
 133                (spaces1,cs1) = extractLeadingSpaces cs
 134             in
 135                (c:spaces1,cs1)
 136          | True = ([],s)
 137
 138       extractNextLine :: String -> (String,String)
 139       extractNextLine [] = ([],[])
 140       extractNextLine (c:cs)
 141          | c == '\n' =
 142             ([],cs)
 143          | True =
 144             let
 145                (line,rest) = extractNextLine cs
 146             in
 147                (c:line,rest)
 148
 149       -- comparison is case-insensitive.
 150       extractPrefix :: String -> String -> Maybe String
 151       extractPrefix [] s = Just s
 152       extractPrefix s [] = Nothing
 153       extractPrefix (c1:cs1) (c2:cs2)
 154          | toUpper c1 == toUpper c2 = extractPrefix cs1 cs2
 155          | True = Nothing
 156
 157 -- -----------------------------------------------------------------------------
 158 -- Adding documentation to record fields (used in parsing).
 159
 160 type Field a = ([Located a], LBangType a, Maybe (LHsDoc a))
 161
 162 addFieldDoc :: Field a -> Maybe (LHsDoc a) -> Field a
 163 addFieldDoc (a, b, c) doc = (a, b, c `mplus` doc)
 164
 165 addFieldDocs :: [Field a] -> Maybe (LHsDoc a) -> [Field a]
 166 addFieldDocs [] _ = []
 167 addFieldDocs (x:xs) doc = addFieldDoc x doc : xs
 168
 169 addConDoc :: LConDecl a -> Maybe (LHsDoc a) -> LConDecl a
 170 addConDoc (L p c) doc = L p ( c { con_doc = con_doc c `mplus` doc } )
 171
 172 addConDocs :: [LConDecl a] -> Maybe (LHsDoc a) -> [LConDecl a]
 173 addConDocs [] _ = []
 174 addConDocs [x] doc = [addConDoc x doc]
 175 addConDocs (x:xs) doc = x : addConDocs xs doc
 176
 177 addConDocFirst :: [LConDecl a] -> Maybe (LHsDoc a) -> [LConDecl a]
 178 addConDocFirst [] _ = []
 179 addConDocFirst (x:xs) doc = addConDoc x doc : xs