{-# 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 GHC.Parser.Lexer (ParserOpts)

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 :: ParserOpts -> Maybe Package -> String -> (HaddockModInfo NsRdrName, MDoc NsRdrName)
parseModuleHeader :: ParserOpts
-> Maybe String
-> String
-> (HaddockModInfo NsRdrName, MDoc NsRdrName)
parseModuleHeader ParserOpts
parserOpts 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 :: Type -> Type) 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 = ParserOpts -> String -> Doc NsRdrName
forall mod. ParserOpts -> String -> DocH mod (Wrap NsRdrName)
parseString ParserOpts
parserOpts (String -> Doc NsRdrName) -> Maybe String -> Maybe (Doc NsRdrName)
forall (f :: Type -> Type) 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 :: Type -> Type) 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 :: Type -> Type) 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
        }
    , ParserOpts -> Maybe String -> String -> MDoc NsRdrName
forall mod.
ParserOpts
-> Maybe String -> String -> MetaDoc mod (Wrap NsRdrName)
parseParas ParserOpts
parserOpts 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 :: Type -> Type).
(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 :: Type -> Type) 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 :: Type -> Type) 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 :: Type -> Type) 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 :: Type -> Type) 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 :: Type -> Type) 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 :: Type -> Type) 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)