X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FHaddockUtils.hs;h=bf22cd77c10b026ac6dee1c1ace8d41b010a3c9f;hp=ea73911c996516b394730a57432abc9626974398;hb=9a82b1ffa35fa4c3927c66a1037a37d436cf6aac;hpb=432b9c9322181a3644083e3c19b7e240d90659e7

diff --git a/compiler/parser/HaddockUtils.hs b/compiler/parser/HaddockUtils.hs
index ea73911..bf22cd7 100644
--- a/compiler/parser/HaddockUtils.hs
+++ b/compiler/parser/HaddockUtils.hs
@@ -2,171 +2,29 @@
 module HaddockUtils where
 
 import HsSyn
-import HsDoc
-import {-# SOURCE #-} HaddockLex
-import HaddockParse
 import SrcLoc
-import RdrName
 
 import Control.Monad
-import Data.Maybe
-import Data.Char
-import Data.Either
-
--- -----------------------------------------------------------------------------
--- 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 :: String -> Either String (String, HaddockModInfo RdrName)
-parseModuleHeader 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 (HsDoc RdrName))
-      description1 = case descriptionOpt of
-         Nothing -> Right Nothing
-         Just description -> case parseHaddockString . tokenise $ description of
-
-            MyLeft mess -> Left ("Cannot parse Description: " ++ mess)
-            MyRight doc -> Right (Just doc)
-   in
-      case description1 of
-         Left mess -> Left mess
-         Right docOpt -> Right (str8,HaddockModInfo {
-            hmi_description = docOpt,
-            hmi_portability = portabilityOpt,
-            hmi_stability = stabilityOpt,
-            hmi_maintainer = maintainerOpt
-            })
-
--- | 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
 
 -- -----------------------------------------------------------------------------
 -- Adding documentation to record fields (used in parsing).
 
-addFieldDoc :: ConDeclField a -> Maybe (LHsDoc a) -> ConDeclField a
+addFieldDoc :: ConDeclField a -> Maybe LHsDocString -> ConDeclField a
 addFieldDoc fld doc = fld { cd_fld_doc = cd_fld_doc fld `mplus` doc }
 
-addFieldDocs :: [ConDeclField a] -> Maybe (LHsDoc a) -> [ConDeclField a]
+addFieldDocs :: [ConDeclField a] -> Maybe LHsDocString -> [ConDeclField a]
 addFieldDocs [] _ = []
 addFieldDocs (x:xs) doc = addFieldDoc x doc : xs
 
-addConDoc :: LConDecl a -> Maybe (LHsDoc a) -> LConDecl a
+addConDoc :: LConDecl a -> Maybe LHsDocString -> LConDecl a
 addConDoc decl    Nothing = decl
 addConDoc (L p c) doc     = L p ( c { con_doc = con_doc c `mplus` doc } )
 
-addConDocs :: [LConDecl a] -> Maybe (LHsDoc a) -> [LConDecl a]
+addConDocs :: [LConDecl a] -> Maybe LHsDocString -> [LConDecl a]
 addConDocs [] _ = []
 addConDocs [x] doc = [addConDoc x doc]
 addConDocs (x:xs) doc = x : addConDocs xs doc
 
-addConDocFirst :: [LConDecl a] -> Maybe (LHsDoc a) -> [LConDecl a]
+addConDocFirst :: [LConDecl a] -> Maybe LHsDocString -> [LConDecl a]
 addConDocFirst [] _ = []
 addConDocFirst (x:xs) doc = addConDoc x doc : xs