content: {-# 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 pkgName str0 =
    let
      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 parserOpts <$> descriptionOpt
          , hmi_copyright = copyrightOpt
          , 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 parserOpts pkgName 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 {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)
  