compiler/parser/HaddockUtils.hs

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