{-# OPTIONS_GHC -Wwarn #-}
{-# LANGUAGE DeriveFunctor #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Haddock.Interface.ParseModuleHeader
-- Copyright   :  (c) Simon Marlow 2006, Isaac Dupree 2009
-- License     :  BSD-like
--
-- Maintainer  :  haddock@projects.haskell.org
-- Stability   :  experimental
-- Portability :  portable
-----------------------------------------------------------------------------
module Haddock.Interface.ParseModuleHeader (parseModuleHeader) where

import Control.Applicative (Alternative (..))
import Control.Monad (ap)
import Data.Char
import GHC.Driver.Session
import Haddock.Parser
import Haddock.Types

-- -----------------------------------------------------------------------------
-- 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 :: DynFlags -> Maybe Package -> String -> (HaddockModInfo NsRdrName, MDoc NsRdrName)
parseModuleHeader :: DynFlags
-> Maybe String
-> String
-> (HaddockModInfo NsRdrName, MDoc NsRdrName)
parseModuleHeader DynFlags
dflags Maybe String
pkgName String
str0 =
   let
      kvs :: [(String, String)]
      str1 :: String

      ([(String, String)]
kvs, String
str1) = ([(String, String)], String)
-> (([(String, String)], String) -> ([(String, String)], String))
-> Maybe ([(String, String)], String)
-> ([(String, String)], String)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([], String
str0) ([(String, String)], String) -> ([(String, String)], String)
forall a. a -> a
id (Maybe ([(String, String)], String)
 -> ([(String, String)], String))
-> Maybe ([(String, String)], String)
-> ([(String, String)], String)
forall a b. (a -> b) -> a -> b
$ P ([(String, String)], String)
-> String -> Maybe ([(String, String)], String)
forall a. P a -> String -> Maybe a
runP P ([(String, String)], String)
fields String
str0

      -- trim whitespaces
      trim :: String -> String
      trim :: String -> String
trim = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse

      getKey :: String -> Maybe String
      getKey :: String -> Maybe String
getKey String
key = (String -> String) -> Maybe String -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> String
trim (String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
key [(String, String)]
kvs)

      descriptionOpt :: Maybe String
descriptionOpt = String -> Maybe String
getKey String
"Description"
      copyrightOpt :: Maybe String
copyrightOpt   = String -> Maybe String
getKey String
"Copyright"
      licenseOpt :: Maybe String
licenseOpt     = String -> Maybe String
getKey String
"License"
      licenceOpt :: Maybe String
licenceOpt     = String -> Maybe String
getKey String
"Licence"
      spdxLicenceOpt :: Maybe String
spdxLicenceOpt = String -> Maybe String
getKey String
"SPDX-License-Identifier"
      maintainerOpt :: Maybe String
maintainerOpt  = String -> Maybe String
getKey String
"Maintainer"
      stabilityOpt :: Maybe String
stabilityOpt   = String -> Maybe String
getKey String
"Stability"
      portabilityOpt :: Maybe String
portabilityOpt = String -> Maybe String
getKey String
"Portability"

   in (HaddockModInfo {
          hmi_description :: Maybe (Doc NsRdrName)
hmi_description = DynFlags -> String -> Doc NsRdrName
forall mod. DynFlags -> String -> DocH mod (Wrap NsRdrName)
parseString DynFlags
dflags (String -> Doc NsRdrName) -> Maybe String -> Maybe (Doc NsRdrName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
descriptionOpt,
          hmi_copyright :: Maybe String
hmi_copyright = Maybe String
copyrightOpt,
          hmi_license :: Maybe String
hmi_license = Maybe String
spdxLicenceOpt Maybe String -> Maybe String -> Maybe String
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe String
licenseOpt Maybe String -> Maybe String -> Maybe String
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe String
licenceOpt,
          hmi_maintainer :: Maybe String
hmi_maintainer = Maybe String
maintainerOpt,
          hmi_stability :: Maybe String
hmi_stability = Maybe String
stabilityOpt,
          hmi_portability :: Maybe String
hmi_portability = Maybe String
portabilityOpt,
          hmi_safety :: Maybe String
hmi_safety = Maybe String
forall a. Maybe a
Nothing,
          hmi_language :: Maybe Language
hmi_language = Maybe Language
forall a. Maybe a
Nothing, -- set in LexParseRn
          hmi_extensions :: [Extension]
hmi_extensions = [] -- also set in LexParseRn
          }, DynFlags -> Maybe String -> String -> MDoc NsRdrName
forall mod.
DynFlags -> Maybe String -> String -> MetaDoc mod (Wrap NsRdrName)
parseParas DynFlags
dflags Maybe String
pkgName String
str1)

-------------------------------------------------------------------------------
-- Small parser to parse module header.
-------------------------------------------------------------------------------

-- | The below is a small parser framework 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".

-- | 'C' is a 'Char' carrying its column.
--
-- This let us make an indentation-aware parser, as we know current indentation.
-- by looking at the next character in the stream ('curInd').
--
-- Thus we can munch all spaces but only not-spaces which are indented.
--
data C = C {-# UNPACK #-} !Int Char

newtype P a = P { forall a. P a -> [C] -> Maybe ([C], a)
unP :: [C] -> Maybe ([C], a) }
  deriving (forall a b. (a -> b) -> P a -> P b)
-> (forall a b. a -> P b -> P a) -> Functor P
forall a b. a -> P b -> P a
forall a b. (a -> b) -> P a -> P b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> P a -> P b
fmap :: forall a b. (a -> b) -> P a -> P b
$c<$ :: forall a b. a -> P b -> P a
<$ :: forall a b. a -> P b -> P a
Functor

instance Applicative P where
    pure :: forall a. a -> P a
pure a
x = ([C] -> Maybe ([C], a)) -> P a
forall a. ([C] -> Maybe ([C], a)) -> P a
P (([C] -> Maybe ([C], a)) -> P a) -> ([C] -> Maybe ([C], a)) -> P a
forall a b. (a -> b) -> a -> b
$ \[C]
s -> ([C], a) -> Maybe ([C], a)
forall a. a -> Maybe a
Just ([C]
s, a
x)
    <*> :: forall a b. P (a -> b) -> P a -> P b
(<*>)  = P (a -> b) -> P a -> P b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad P where
    return :: forall a. a -> P a
return = a -> P a
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    P a
m >>= :: forall a b. P a -> (a -> P b) -> P b
>>= a -> P b
k = ([C] -> Maybe ([C], b)) -> P b
forall a. ([C] -> Maybe ([C], a)) -> P a
P (([C] -> Maybe ([C], b)) -> P b) -> ([C] -> Maybe ([C], b)) -> P b
forall a b. (a -> b) -> a -> b
$ \[C]
s0 -> do
        (s1, x) <- P a -> [C] -> Maybe ([C], a)
forall a. P a -> [C] -> Maybe ([C], a)
unP P a
m [C]
s0
        unP (k x) s1

instance Alternative P where
    empty :: forall a. P a
empty   = ([C] -> Maybe ([C], a)) -> P a
forall a. ([C] -> Maybe ([C], a)) -> P a
P (([C] -> Maybe ([C], a)) -> P a) -> ([C] -> Maybe ([C], a)) -> P a
forall a b. (a -> b) -> a -> b
$ \[C]
_ -> Maybe ([C], a)
forall a. Maybe a
Nothing
    P a
a <|> :: forall a. P a -> P a -> P a
<|> P a
b = ([C] -> Maybe ([C], a)) -> P a
forall a. ([C] -> Maybe ([C], a)) -> P a
P (([C] -> Maybe ([C], a)) -> P a) -> ([C] -> Maybe ([C], a)) -> P a
forall a b. (a -> b) -> a -> b
$ \[C]
s -> P a -> [C] -> Maybe ([C], a)
forall a. P a -> [C] -> Maybe ([C], a)
unP P a
a [C]
s Maybe ([C], a) -> Maybe ([C], a) -> Maybe ([C], a)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P a -> [C] -> Maybe ([C], a)
forall a. P a -> [C] -> Maybe ([C], a)
unP P a
b [C]
s

runP :: P a -> String -> Maybe a
runP :: forall a. P a -> String -> Maybe a
runP P a
p String
input = (([C], a) -> a) -> Maybe ([C], a) -> Maybe a
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([C], a) -> a
forall a b. (a, b) -> b
snd (P a -> [C] -> Maybe ([C], a)
forall a. P a -> [C] -> Maybe ([C], a)
unP P a
p [C]
input')
  where
    input' :: [C]
input' = [[C]] -> [C]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ (Int -> Char -> C) -> [Int] -> String -> [C]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Char -> C
C [Int
0..] String
l [C] -> [C] -> [C]
forall a. [a] -> [a] -> [a]
++ [Int -> Char -> C
C (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
l) Char
'\n']
        | String
l <- String -> [String]
lines String
input
        ]

-------------------------------------------------------------------------------
--
-------------------------------------------------------------------------------

curInd :: P Int
curInd :: P Int
curInd = ([C] -> Maybe ([C], Int)) -> P Int
forall a. ([C] -> Maybe ([C], a)) -> P a
P (([C] -> Maybe ([C], Int)) -> P Int)
-> ([C] -> Maybe ([C], Int)) -> P Int
forall a b. (a -> b) -> a -> b
$ \[C]
s -> ([C], Int) -> Maybe ([C], Int)
forall a. a -> Maybe a
Just (([C], Int) -> Maybe ([C], Int))
-> (Int -> ([C], Int)) -> Int -> Maybe ([C], Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) [C]
s (Int -> Maybe ([C], Int)) -> Int -> Maybe ([C], Int)
forall a b. (a -> b) -> a -> b
$ case [C]
s of
    []        -> Int
0
    C Int
i Char
_ : [C]
_ -> Int
i

rest :: P String
rest :: P String
rest = ([C] -> Maybe ([C], String)) -> P String
forall a. ([C] -> Maybe ([C], a)) -> P a
P (([C] -> Maybe ([C], String)) -> P String)
-> ([C] -> Maybe ([C], String)) -> P String
forall a b. (a -> b) -> a -> b
$ \[C]
cs -> ([C], String) -> Maybe ([C], String)
forall a. a -> Maybe a
Just ([], [ Char
c | C Int
_ Char
c <- [C]
cs ])

munch :: (Int -> Char -> Bool) -> P String
munch :: (Int -> Char -> Bool) -> P String
munch Int -> Char -> Bool
p = ([C] -> Maybe ([C], String)) -> P String
forall a. ([C] -> Maybe ([C], a)) -> P a
P (([C] -> Maybe ([C], String)) -> P String)
-> ([C] -> Maybe ([C], String)) -> P String
forall a b. (a -> b) -> a -> b
$ \[C]
cs ->
    let (String
xs,[C]
ys) = (C -> Maybe Char) -> [C] -> (String, [C])
forall a b. (a -> Maybe b) -> [a] -> ([b], [a])
takeWhileMaybe C -> Maybe Char
p' [C]
cs in ([C], String) -> Maybe ([C], String)
forall a. a -> Maybe a
Just ([C]
ys, String
xs)
  where
    p' :: C -> Maybe Char
p' (C Int
i Char
c)
        | Int -> Char -> Bool
p Int
i Char
c  = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
c
        | Bool
otherwise = Maybe Char
forall a. Maybe a
Nothing

munch1 :: (Int -> Char -> Bool) -> P String
munch1 :: (Int -> Char -> Bool) -> P String
munch1 Int -> Char -> Bool
p = ([C] -> Maybe ([C], String)) -> P String
forall a. ([C] -> Maybe ([C], a)) -> P a
P (([C] -> Maybe ([C], String)) -> P String)
-> ([C] -> Maybe ([C], String)) -> P String
forall a b. (a -> b) -> a -> b
$ \[C]
s -> case [C]
s of
    [] -> Maybe ([C], String)
forall a. Maybe a
Nothing
    (C
c:[C]
cs) | Just Char
c' <- C -> Maybe Char
p' C
c -> let (String
xs,[C]
ys) = (C -> Maybe Char) -> [C] -> (String, [C])
forall a b. (a -> Maybe b) -> [a] -> ([b], [a])
takeWhileMaybe C -> Maybe Char
p' [C]
cs in ([C], String) -> Maybe ([C], String)
forall a. a -> Maybe a
Just ([C]
ys, Char
c' Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs)
           | Bool
otherwise -> Maybe ([C], String)
forall a. Maybe a
Nothing
  where
    p' :: C -> Maybe Char
p' (C Int
i Char
c)
        | Int -> Char -> Bool
p Int
i Char
c  = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
c
        | Bool
otherwise = Maybe Char
forall a. Maybe a
Nothing

char :: Char -> P Char
char :: Char -> P Char
char Char
c = ([C] -> Maybe ([C], Char)) -> P Char
forall a. ([C] -> Maybe ([C], a)) -> P a
P (([C] -> Maybe ([C], Char)) -> P Char)
-> ([C] -> Maybe ([C], Char)) -> P Char
forall a b. (a -> b) -> a -> b
$ \[C]
s -> case [C]
s of
    []                        -> Maybe ([C], Char)
forall a. Maybe a
Nothing
    (C Int
_ Char
c' : [C]
cs) | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c'   -> ([C], Char) -> Maybe ([C], Char)
forall a. a -> Maybe a
Just ([C]
cs, Char
c)
                  | Bool
otherwise -> Maybe ([C], Char)
forall a. Maybe a
Nothing

skipSpaces :: P ()
skipSpaces :: P ()
skipSpaces = ([C] -> Maybe ([C], ())) -> P ()
forall a. ([C] -> Maybe ([C], a)) -> P a
P (([C] -> Maybe ([C], ())) -> P ())
-> ([C] -> Maybe ([C], ())) -> P ()
forall a b. (a -> b) -> a -> b
$ \[C]
cs -> ([C], ()) -> Maybe ([C], ())
forall a. a -> Maybe a
Just ((C -> Bool) -> [C] -> [C]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (\(C Int
_ Char
c) -> Char -> Bool
isSpace Char
c) [C]
cs, ())

takeWhileMaybe :: (a -> Maybe b) -> [a] -> ([b], [a])
takeWhileMaybe :: forall a b. (a -> Maybe b) -> [a] -> ([b], [a])
takeWhileMaybe a -> Maybe b
f = [a] -> ([b], [a])
go where
    go :: [a] -> ([b], [a])
go xs0 :: [a]
xs0@[] = ([], [a]
xs0)
    go xs0 :: [a]
xs0@(a
x:[a]
xs) = case a -> Maybe b
f a
x of
        Just b
y  -> let ([b]
ys, [a]
zs) = [a] -> ([b], [a])
go [a]
xs in (b
y b -> [b] -> [b]
forall a. a -> [a] -> [a]
: [b]
ys, [a]
zs)
        Maybe b
Nothing -> ([], [a]
xs0)

-------------------------------------------------------------------------------
-- Fields
-------------------------------------------------------------------------------

field :: Int -> P (String, String)
field :: Int -> P (String, String)
field Int
i = do
    fn <- (Int -> Char -> Bool) -> P String
munch1 ((Int -> Char -> Bool) -> P String)
-> (Int -> Char -> Bool) -> P String
forall a b. (a -> b) -> a -> b
$ \Int
_ Char
c -> Char -> Bool
isAlpha Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-'
    skipSpaces
    _ <- char ':'
    skipSpaces
    val <- munch $ \Int
j Char
c -> Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
|| Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
i
    return (fn, val)

fields :: P ([(String, String)], String)
fields :: P ([(String, String)], String)
fields = do
    P ()
skipSpaces
    i  <- P Int
curInd
    fs <- many (field i)
    r  <- rest
    return (fs, r)