{- |
Module:  Pollock.ModuleInfo.ModuleHeader
Copyright: (c) Trevis Elser 2023
License:  MIT
Maintainer: trevis@flipstone.com
Stability: experimental
Portability: not-portable
-}
module Pollock.ModuleInfo.ModuleHeader
  ( ModuleHeader (..)
  , processModuleHeader
  ) where

import qualified Control.Applicative as App
import qualified Data.Char as Char
import qualified Data.Maybe as Maybe

import qualified Pollock.CompatGHC as CompatGHC

-- FIXME Consider safety, language and extensions if they are manually present? Does anyone
-- actually do that? Unclear, but could be useful.
data ModuleHeader = ModuleHeader
  { ModuleHeader -> Maybe String
description :: !(Maybe String)
  -- ^ The description field of the Haddock module header.
  , ModuleHeader -> Maybe String
copyright :: !(Maybe String)
  -- ^ The copyright field of the Haddock module header.
  , ModuleHeader -> Maybe String
license :: !(Maybe String)
  -- ^ The license field of the Haddock module header.
  , ModuleHeader -> Maybe String
maintainer :: !(Maybe String)
  -- ^ The maintainer field of the Haddock module header.
  , ModuleHeader -> Maybe String
stability :: !(Maybe String)
  -- ^ The stability field of the Haddock module header.
  , ModuleHeader -> Maybe String
portability :: !(Maybe String)
  -- ^ The portability field of the Haddock module header.
  }

emptyHaddockModInfo :: ModuleHeader
emptyHaddockModInfo :: ModuleHeader
emptyHaddockModInfo =
  ModuleHeader
    { description :: Maybe String
description = Maybe String
forall a. Maybe a
Nothing
    , copyright :: Maybe String
copyright = Maybe String
forall a. Maybe a
Nothing
    , license :: Maybe String
license = Maybe String
forall a. Maybe a
Nothing
    , maintainer :: Maybe String
maintainer = Maybe String
forall a. Maybe a
Nothing
    , stability :: Maybe String
stability = Maybe String
forall a. Maybe a
Nothing
    , portability :: Maybe String
portability = Maybe String
forall a. Maybe a
Nothing
    }

processModuleHeader ::
  Maybe CompatGHC.HsDocString
  -> ModuleHeader
processModuleHeader :: Maybe HsDocString -> ModuleHeader
processModuleHeader Maybe HsDocString
mayStr =
  case Maybe HsDocString
mayStr of
    Maybe HsDocString
Nothing -> ModuleHeader
emptyHaddockModInfo
    Just HsDocString
hds ->
      String -> ModuleHeader
parseModuleHeader (String -> ModuleHeader) -> String -> ModuleHeader
forall a b. (a -> b) -> a -> b
$ HsDocString -> String
CompatGHC.renderHsDocString HsDocString
hds

parseModuleHeader ::
  String -> ModuleHeader
parseModuleHeader :: String -> ModuleHeader
parseModuleHeader String
str0 =
  let
    kvs :: [(String, String)]
    kvs :: [(String, String)]
kvs = [(String, String)]
-> Maybe [(String, String)] -> [(String, String)]
forall a. a -> Maybe a -> a
Maybe.fromMaybe [(String, String)]
forall a. Monoid a => a
mempty (Maybe [(String, String)] -> [(String, String)])
-> Maybe [(String, String)] -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ P [(String, String)] -> String -> Maybe [(String, String)]
forall a. P a -> String -> Maybe a
runP P [(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
Char.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
Char.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
    ModuleHeader
      { description :: Maybe String
description = Maybe String
descriptionOpt
      , copyright :: Maybe String
copyright = Maybe String
copyrightOpt
      , license :: Maybe String
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
App.<|> 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
App.<|> Maybe String
licenceOpt
      , maintainer :: Maybe String
maintainer = Maybe String
maintainerOpt
      , stability :: Maybe String
stability = Maybe String
stabilityOpt
      , portability :: Maybe String
portability = Maybe String
portabilityOpt
      }

-------------------------------------------------------------------------------
-- 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)}

instance Functor P where
  fmap :: forall a b. (a -> b) -> P a -> P b
fmap a -> b
f (P [C] -> Maybe ([C], a)
pn) =
    ([C] -> Maybe ([C], b)) -> P b
forall a. ([C] -> Maybe ([C], a)) -> P a
P (((([C], a) -> ([C], b)) -> Maybe ([C], a) -> Maybe ([C], b)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((([C], a) -> ([C], b)) -> Maybe ([C], a) -> Maybe ([C], b))
-> ((a -> b) -> ([C], a) -> ([C], b))
-> (a -> b)
-> Maybe ([C], a)
-> Maybe ([C], b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> ([C], a) -> ([C], b)
forall a b. (a -> b) -> ([C], a) -> ([C], b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) a -> b
f (Maybe ([C], a) -> Maybe ([C], b))
-> ([C] -> Maybe ([C], a)) -> [C] -> Maybe ([C], b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [C] -> Maybe ([C], a)
pn)

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)
m1 P a
m2 =
    ([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]
t0 ->
      case P (a -> b) -> [C] -> Maybe ([C], a -> b)
forall a. P a -> [C] -> Maybe ([C], a)
unP P (a -> b)
m1 [C]
t0 of
        Maybe ([C], a -> b)
Nothing -> Maybe ([C], b)
forall a. Maybe a
Nothing
        Just ([C]
t1, a -> b
z) ->
          ((([C], a) -> ([C], b)) -> Maybe ([C], a) -> Maybe ([C], b)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((([C], a) -> ([C], b)) -> Maybe ([C], a) -> Maybe ([C], b))
-> ((a -> b) -> ([C], a) -> ([C], b))
-> (a -> b)
-> Maybe ([C], a)
-> Maybe ([C], b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> ([C], a) -> ([C], b)
forall a b. (a -> b) -> ([C], a) -> ([C], b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) a -> b
z (P a -> [C] -> Maybe ([C], a)
forall a. P a -> [C] -> Maybe ([C], a)
unP P a
m2 [C]
t1)

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

instance App.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
$ Maybe ([C], a) -> [C] -> Maybe ([C], a)
forall a b. a -> b -> a
const 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
App.<|> 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. Semigroup 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

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
Char.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
  String
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
Char.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
  String
val <- (Int -> Char -> Bool) -> P String
munch ((Int -> Char -> Bool) -> P String)
-> (Int -> Char -> Bool) -> P String
forall a b. (a -> b) -> a -> b
$ \Int
j Char
c -> Char -> Bool
Char.isSpace Char
c Bool -> Bool -> Bool
|| Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
i
  (String, String) -> P (String, String)
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
fn, String
val)

fields :: P [(String, String)]
fields :: P [(String, String)]
fields = do
  P ()
skipSpaces
  Int
i <- P Int
curInd
  P (String, String) -> P [(String, String)]
forall a. P a -> P [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
App.many (Int -> P (String, String)
field Int
i)