aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock')
-rw-r--r--haddock-api/src/Haddock/Interface/ParseModuleHeader.hs218
1 files changed, 125 insertions, 93 deletions
diff --git a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
index 050901b6..e4528522 100644
--- a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
+++ b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveFunctor #-}
{-# OPTIONS_GHC -Wwarn #-}
-----------------------------------------------------------------------------
-- |
@@ -11,7 +12,8 @@
-----------------------------------------------------------------------------
module Haddock.Interface.ParseModuleHeader (parseModuleHeader) where
-import Control.Monad (mplus)
+import Control.Applicative (Alternative (..))
+import Control.Monad (ap)
import Data.Char
import DynFlags
import Haddock.Parser
@@ -27,34 +29,44 @@ import RdrName
parseModuleHeader :: DynFlags -> Maybe Package -> String -> (HaddockModInfo RdrName, MDoc RdrName)
parseModuleHeader dflags pkgName 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
- (spdxLicenceOpt,str6) = getKey "SPDX-License-Identifier" str5
- (maintainerOpt,str7) = getKey "Maintainer" str6
- (stabilityOpt,str8) = getKey "Stability" str7
- (portabilityOpt,str9) = getKey "Portability" str8
+ kvs :: [(String, String)]
+ str1 :: String
+
+ (kvs, str1) = maybe ([], str0) id $ runP fields str0
+
+ -- trim whitespaces
+ trim :: String -> String
+ trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse
+
+ getKey :: String -> Maybe String
+ getKey key = fmap trim (lookup key kvs)
+
+ descriptionOpt = getKey "Description"
+ copyrightOpt = getKey "Copyright"
+ licenseOpt = getKey "License"
+ licenceOpt = getKey "Licence"
+ spdxLicenceOpt = getKey "SPDX-License-Identifier"
+ maintainerOpt = getKey "Maintainer"
+ stabilityOpt = getKey "Stability"
+ portabilityOpt = getKey "Portability"
in (HaddockModInfo {
hmi_description = parseString dflags <$> descriptionOpt,
hmi_copyright = copyrightOpt,
- hmi_license = spdxLicenceOpt `mplus` licenseOpt `mplus` licenceOpt,
+ hmi_license = spdxLicenceOpt <|> licenseOpt <|> licenceOpt,
hmi_maintainer = maintainerOpt,
hmi_stability = stabilityOpt,
hmi_portability = portabilityOpt,
hmi_safety = Nothing,
hmi_language = Nothing, -- set in LexParseRn
hmi_extensions = [] -- also set in LexParseRn
- }, parseParas dflags pkgName str9)
+ }, parseParas dflags pkgName str1)
+
+-------------------------------------------------------------------------------
+-- Small parser to parse module header.
+-------------------------------------------------------------------------------
--- | This function is how we read keys.
+-- | The below is a small parser framework how we read keys.
--
-- all fields in the header are optional and have the form
--
@@ -73,78 +85,98 @@ parseModuleHeader dflags pkgName str0 =
--
-- 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 (dropWhile (`elem` ['\r', '\n']) 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)
- | otherwise = ([],s)
-
- extractNextLine :: String -> (String,String)
- extractNextLine [] = ([],[])
- extractNextLine (c:cs)
- | c == '\n' =
- ([],cs)
- | otherwise =
- 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
- | otherwise = Nothing
+
+data C = C {-# UNPACK #-} !Int Char
+
+newtype P a = P { unP :: [C] -> Maybe ([C], a) }
+ deriving Functor
+
+instance Applicative P where
+ pure x = P $ \s -> Just (s, x)
+ (<*>) = ap
+
+instance Monad P where
+ return = pure
+ m >>= k = P $ \s0 -> do
+ (s1, x) <- unP m s0
+ unP (k x) s1
+
+instance Alternative P where
+ empty = P $ \_ -> Nothing
+ a <|> b = P $ \s -> unP a s <|> unP b s
+
+runP :: P a -> String -> Maybe a
+runP p input = fmap snd (unP p input')
+ where
+ input' = concat
+ [ zipWith C [0..] l ++ [C (length l) '\n']
+ | l <- lines input
+ ]
+
+-------------------------------------------------------------------------------
+--
+-------------------------------------------------------------------------------
+
+curInd :: P Int
+curInd = P $ \s -> Just . (,) s $ case s of
+ [] -> 0
+ C i _ : _ -> i
+
+rest :: P String
+rest = P $ \cs -> Just ([], [ c | C _ c <- cs ])
+
+munch :: (Int -> Char -> Bool) -> P String
+munch p = P $ \cs ->
+ let (xs,ys) = takeWhileMaybe p' cs in Just (ys, xs)
+ where
+ p' (C i c)
+ | p i c = Just c
+ | otherwise = Nothing
+
+munch1 :: (Int -> Char -> Bool) -> P String
+munch1 p = P $ \s -> case s of
+ [] -> Nothing
+ (c:cs) | Just c' <- p' c -> let (xs,ys) = takeWhileMaybe p' cs in Just (ys, c' : xs)
+ | otherwise -> Nothing
+ where
+ p' (C i c)
+ | p i c = Just c
+ | otherwise = Nothing
+
+char :: Char -> P Char
+char c = P $ \s -> case s of
+ [] -> Nothing
+ (C _ c' : cs) | c == c' -> Just (cs, c)
+ | otherwise -> Nothing
+
+skipSpaces :: P ()
+skipSpaces = P $ \cs -> Just (dropWhile (\(C _ c) -> isSpace c) cs, ())
+
+takeWhileMaybe :: (a -> Maybe b) -> [a] -> ([b], [a])
+takeWhileMaybe f = go where
+ go xs0@[] = ([], xs0)
+ go xs0@(x:xs) = case f x of
+ Just y -> let (ys, zs) = go xs in (y : ys, zs)
+ Nothing -> ([], xs0)
+
+-------------------------------------------------------------------------------
+-- Fields
+-------------------------------------------------------------------------------
+
+field :: Int -> P (String, String)
+field i = do
+ fn <- munch1 $ \_ c -> isAlpha c || c == '-'
+ skipSpaces
+ _ <- char ':'
+ skipSpaces
+ val <- munch $ \j c -> isSpace c || j > i
+ return (fn, val)
+
+fields :: P ([(String, String)], String)
+fields = do
+ skipSpaces
+ i <- curInd
+ fs <- many (field i)
+ r <- rest
+ return (fs, r)
+
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-16 10:11:56 +0000