Skip to content
Snippets Groups Projects
Commit 622ea3f4 authored by Oleg Grenrus's avatar Oleg Grenrus Committed by Alec Theriault
Browse files

Redo ParseModuleHeader

parent 8964666e
No related branches found
No related tags found
5 merge requests!38Make --no-tmp-comp-dir the default,!37Adapt to latest xhtml version, various optimizations,!31Support HsToken in DataDecl and ClassDecl,!12Drop orphan instance when defined upstream.,!10Haddock interfaces produced from `.hi` files
{-# 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)
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment