compiler/parser/HaddockUtils.hs

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