compiler/parser/HaddockUtils.hs

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