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

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

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

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

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

   in (HaddockModInfo :: forall name.
Maybe (Doc name)
-> Maybe Package
-> Maybe Package
-> Maybe Package
-> Maybe Package
-> Maybe Package
-> Maybe Package
-> Maybe Language
-> [Extension]
-> HaddockModInfo name
HaddockModInfo {
          hmi_description :: Maybe (Doc NsRdrName)
hmi_description = DynFlags -> Package -> Doc NsRdrName
forall mod. DynFlags -> Package -> DocH mod (Wrap NsRdrName)
parseString DynFlags
dflags (Package -> Doc NsRdrName)
-> Maybe Package -> Maybe (Doc NsRdrName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Package
descriptionOpt,
          hmi_copyright :: Maybe Package
hmi_copyright = Maybe Package
copyrightOpt,
          hmi_license :: Maybe Package
hmi_license = Maybe Package
spdxLicenceOpt Maybe Package -> Maybe Package -> Maybe Package
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Package
licenseOpt Maybe Package -> Maybe Package -> Maybe Package
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Package
licenceOpt,
          hmi_maintainer :: Maybe Package
hmi_maintainer = Maybe Package
maintainerOpt,
          hmi_stability :: Maybe Package
hmi_stability = Maybe Package
stabilityOpt,
          hmi_portability :: Maybe Package
hmi_portability = Maybe Package
portabilityOpt,
          hmi_safety :: Maybe Package
hmi_safety = Maybe Package
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 Package -> Package -> MDoc NsRdrName
forall mod.
DynFlags
-> Maybe Package -> Package -> MetaDoc mod (Wrap NsRdrName)
parseParas DynFlags
dflags Maybe Package
pkgName Package
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 { P a -> [C] -> Maybe ([C], a)
unP :: [C] -> Maybe ([C], a) }
  deriving a -> P b -> P a
(a -> b) -> P a -> P b
(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
<$ :: a -> P b -> P a
$c<$ :: forall a b. a -> P b -> P a
fmap :: (a -> b) -> P a -> P b
$cfmap :: forall a b. (a -> b) -> P a -> P b
Functor

instance Applicative P where
    pure :: 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)
    <*> :: 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 :: a -> P a
return = a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    P a
m >>= :: 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
        ([C]
s1, a
x) <- P a -> [C] -> Maybe ([C], a)
forall a. P a -> [C] -> Maybe ([C], a)
unP P a
m [C]
s0
        P b -> [C] -> Maybe ([C], b)
forall a. P a -> [C] -> Maybe ([C], a)
unP (a -> P b
k a
x) [C]
s1

instance Alternative P where
    empty :: 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 <|> :: 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 (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 :: P a -> Package -> Maybe a
runP P a
p Package
input = (([C], a) -> a) -> Maybe ([C], a) -> Maybe a
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] -> Package -> [C]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Char -> C
C [Int
0..] Package
l [C] -> [C] -> [C]
forall a. [a] -> [a] -> [a]
++ [Int -> Char -> C
C (Package -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Package
l) Char
'\n']
        | Package
l <- Package -> [Package]
lines Package
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 Package
rest = ([C] -> Maybe ([C], Package)) -> P Package
forall a. ([C] -> Maybe ([C], a)) -> P a
P (([C] -> Maybe ([C], Package)) -> P Package)
-> ([C] -> Maybe ([C], Package)) -> P Package
forall a b. (a -> b) -> a -> b
$ \[C]
cs -> ([C], Package) -> Maybe ([C], Package)
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 Package
munch Int -> Char -> Bool
p = ([C] -> Maybe ([C], Package)) -> P Package
forall a. ([C] -> Maybe ([C], a)) -> P a
P (([C] -> Maybe ([C], Package)) -> P Package)
-> ([C] -> Maybe ([C], Package)) -> P Package
forall a b. (a -> b) -> a -> b
$ \[C]
cs ->
    let (Package
xs,[C]
ys) = (C -> Maybe Char) -> [C] -> (Package, [C])
forall a b. (a -> Maybe b) -> [a] -> ([b], [a])
takeWhileMaybe C -> Maybe Char
p' [C]
cs in ([C], Package) -> Maybe ([C], Package)
forall a. a -> Maybe a
Just ([C]
ys, Package
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 Package
munch1 Int -> Char -> Bool
p = ([C] -> Maybe ([C], Package)) -> P Package
forall a. ([C] -> Maybe ([C], a)) -> P a
P (([C] -> Maybe ([C], Package)) -> P Package)
-> ([C] -> Maybe ([C], Package)) -> P Package
forall a b. (a -> b) -> a -> b
$ \[C]
s -> case [C]
s of
    [] -> Maybe ([C], Package)
forall a. Maybe a
Nothing
    (C
c:[C]
cs) | Just Char
c' <- C -> Maybe Char
p' C
c -> let (Package
xs,[C]
ys) = (C -> Maybe Char) -> [C] -> (Package, [C])
forall a b. (a -> Maybe b) -> [a] -> ([b], [a])
takeWhileMaybe C -> Maybe Char
p' [C]
cs in ([C], Package) -> Maybe ([C], Package)
forall a. a -> Maybe a
Just ([C]
ys, Char
c' Char -> Package -> Package
forall a. a -> [a] -> [a]
: Package
xs)
           | Bool
otherwise -> Maybe ([C], Package)
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 :: (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 (Package, Package)
field Int
i = do
    Package
fn <- (Int -> Char -> Bool) -> P Package
munch1 ((Int -> Char -> Bool) -> P Package)
-> (Int -> Char -> Bool) -> P Package
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
'-'
    P ()
skipSpaces
    Char
_ <- Char -> P Char
char Char
':'
    P ()
skipSpaces
    Package
val <- (Int -> Char -> Bool) -> P Package
munch ((Int -> Char -> Bool) -> P Package)
-> (Int -> Char -> Bool) -> P Package
forall a b. (a -> b) -> a -> b
$ \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
    (Package, Package) -> P (Package, Package)
forall (m :: * -> *) a. Monad m => a -> m a
return (Package
fn, Package
val)

fields :: P ([(String, String)], String)
fields :: P ([(Package, Package)], Package)
fields = do
    P ()
skipSpaces
    Int
i  <- P Int
curInd
    [(Package, Package)]
fs <- P (Package, Package) -> P [(Package, Package)]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Int -> P (Package, Package)
field Int
i)
    Package
r  <- P Package
rest
    ([(Package, Package)], Package)
-> P ([(Package, Package)], Package)
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Package, Package)]
fs, Package
r)