{-# LANGUAGE DeriveFunctor     #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE StrictData        #-}

{-|
Module      : Headroom.Ext.Haskell.Haddock
Description : Extraction of /Haddock module header/ fields
Copyright   : (c) 2019-2020 Vaclav Svejcar
License     : BSD-3-Clause
Maintainer  : vaclav.svejcar@gmail.com
Stability   : experimental
Portability : POSIX

Support for extracting data from /Haddock module headers/ present in
/Haskell source code files/ or /templates/.
-}

module Headroom.Ext.Haskell.Haddock
  ( HaddockModuleHeader(..)
  , extractFieldOffsets
  , extractModuleHeader
  , indentField
  , stripCommentSyntax
  )
where

import           Control.Applicative            ( Alternative(..) )
import           Control.Monad                  ( ap )
import           Data.Default.Class             ( Default(..) )
import           Headroom.Data.Regex            ( re
                                                , replace
                                                , scan
                                                )
import           Headroom.Data.TextExtra        ( fromLines
                                                , toLines
                                                )
import           Headroom.Template              ( Template(..) )
import           Headroom.Types                 ( HaddockFieldOffsets(..)
                                                , TemplateMeta(..)
                                                )
import           RIO
import qualified RIO.Char                      as C
import qualified RIO.Text                      as T


-- | Extracted fields from the /Haddock module header/.
data HaddockModuleHeader = HaddockModuleHeader
  { HaddockModuleHeader -> Maybe Text
hmhCopyright   :: Maybe Text
  -- ^ module copyright (content of the @Copyright@ field)
  , HaddockModuleHeader -> Maybe Text
hmhLicense     :: Maybe Text
  -- ^ module license (content of the @License@ field)
  , HaddockModuleHeader -> Maybe Text
hmhMaintainer  :: Maybe Text
  -- ^ module license (content of the @Maintainer@ field)
  , HaddockModuleHeader -> Maybe Text
hmhPortability :: Maybe Text
  -- ^ module license (content of the @Portability@ field)
  , HaddockModuleHeader -> Maybe Text
hmhStability   :: Maybe Text
  -- ^ module license (content of the @Stability@ field)
  , HaddockModuleHeader -> Maybe Text
hmhShortDesc   :: Maybe Text
  -- ^ module short description (content of the @Description@ field)
  , HaddockModuleHeader -> Maybe Text
hmhLongDesc    :: Maybe Text
  -- ^ module long description (the text after module header fields)
  }
  deriving (HaddockModuleHeader -> HaddockModuleHeader -> Bool
(HaddockModuleHeader -> HaddockModuleHeader -> Bool)
-> (HaddockModuleHeader -> HaddockModuleHeader -> Bool)
-> Eq HaddockModuleHeader
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HaddockModuleHeader -> HaddockModuleHeader -> Bool
$c/= :: HaddockModuleHeader -> HaddockModuleHeader -> Bool
== :: HaddockModuleHeader -> HaddockModuleHeader -> Bool
$c== :: HaddockModuleHeader -> HaddockModuleHeader -> Bool
Eq, Int -> HaddockModuleHeader -> ShowS
[HaddockModuleHeader] -> ShowS
HaddockModuleHeader -> String
(Int -> HaddockModuleHeader -> ShowS)
-> (HaddockModuleHeader -> String)
-> ([HaddockModuleHeader] -> ShowS)
-> Show HaddockModuleHeader
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HaddockModuleHeader] -> ShowS
$cshowList :: [HaddockModuleHeader] -> ShowS
show :: HaddockModuleHeader -> String
$cshow :: HaddockModuleHeader -> String
showsPrec :: Int -> HaddockModuleHeader -> ShowS
$cshowsPrec :: Int -> HaddockModuleHeader -> ShowS
Show)


-- | Extracts /offsets/ for selected haddock fields (i.e. number of chars
-- between start of line and field value). This is needed to properly format
-- multi-line field values rendered in new /license headers/.
extractFieldOffsets :: (Template t)
                    => t
                    -- ^ parsed /template/
                    -> HaddockFieldOffsets
                    -- ^ extracted field offsets
extractFieldOffsets :: t -> HaddockFieldOffsets
extractFieldOffsets t
template = HaddockFieldOffsets :: Maybe Int -> HaddockFieldOffsets
HaddockFieldOffsets { Maybe Int
hfoCopyright :: Maybe Int
hfoCopyright :: Maybe Int
.. }
 where
  hfoCopyright :: Maybe Int
hfoCopyright = Text -> Maybe Int
extractCopyrightOffset Text
text
  text :: Text
text         = Text -> Text
stripCommentSyntax (Text -> Text) -> (t -> Text) -> t -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Text
forall t. Template t => t -> Text
rawTemplate (t -> Text) -> t -> Text
forall a b. (a -> b) -> a -> b
$ t
template


extractCopyrightOffset :: Text -> Maybe Int
extractCopyrightOffset :: Text -> Maybe Int
extractCopyrightOffset Text
text = case Regex -> Text -> [(Text, [Text])]
scan [re|\h*Copyright\h*:\h*|] Text
text of
  [(Text
full, [Text]
_)] -> Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> (Text -> Int) -> Text -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Int
T.length (Text -> Maybe Int) -> Text -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Text
full
  [(Text, [Text])]
_           -> Maybe Int
forall a. Maybe a
Nothing


-- | Extracts metadata from given /Haddock/ module header.
extractModuleHeader :: Text
                    -- ^ text containing /Haddock/ module header
                    -> Maybe TemplateMeta
                    -- ^ extracted metadata from corresponding /template/
                    -> HaddockModuleHeader
                    -- ^ extracted metadata
extractModuleHeader :: Text -> Maybe TemplateMeta -> HaddockModuleHeader
extractModuleHeader Text
text Maybe TemplateMeta
meta =
  let hmhCopyright :: Maybe Text
hmhCopyright   = Maybe Int -> Text -> Text
indent Maybe Int
hfoCopyright (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe Text
extractField String
"Copyright"
      hmhLicense :: Maybe Text
hmhLicense     = String -> Maybe Text
extractField String
"License"
      hmhMaintainer :: Maybe Text
hmhMaintainer  = String -> Maybe Text
extractField String
"Maintainer"
      hmhPortability :: Maybe Text
hmhPortability = String -> Maybe Text
extractField String
"Portability"
      hmhStability :: Maybe Text
hmhStability   = String -> Maybe Text
extractField String
"Stability"
      hmhShortDesc :: Maybe Text
hmhShortDesc   = String -> Maybe Text
extractField String
"Description"
      hmhLongDesc :: Maybe Text
hmhLongDesc    = if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
rest' then Maybe Text
forall a. Maybe a
Nothing else String -> Maybe Text
process String
rest'
  in  HaddockModuleHeader :: Maybe Text
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> HaddockModuleHeader
HaddockModuleHeader { Maybe Text
hmhLongDesc :: Maybe Text
hmhShortDesc :: Maybe Text
hmhStability :: Maybe Text
hmhPortability :: Maybe Text
hmhMaintainer :: Maybe Text
hmhLicense :: Maybe Text
hmhCopyright :: Maybe Text
hmhLongDesc :: Maybe Text
hmhShortDesc :: Maybe Text
hmhStability :: Maybe Text
hmhPortability :: Maybe Text
hmhMaintainer :: Maybe Text
hmhLicense :: Maybe Text
hmhCopyright :: Maybe Text
.. }
 where
  ([(String, String)]
fields', String
rest') = ([(String, String)], String)
-> Maybe ([(String, String)], String)
-> ([(String, String)], String)
forall a. a -> Maybe a -> a
fromMaybe ([], String
input) (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
input
  input :: String
input            = Text -> String
T.unpack (Text -> String) -> (Text -> Text) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
stripCommentSyntax (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
text
  extractField :: String -> Maybe Text
extractField String
name = (String -> Text) -> Maybe String -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Text
T.strip (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) (String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
name [(String, String)]
fields')
  process :: String -> Maybe Text
process = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> (String -> Text) -> String -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
  indent :: Maybe Int -> Text -> Text
indent Maybe Int
c Text
t = Text -> Text
T.strip (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Maybe Int -> Text -> Text
indentField Maybe Int
c Text
t
  HaddockFieldOffsets {Maybe Int
hfoCopyright :: Maybe Int
hfoCopyright :: HaddockFieldOffsets -> Maybe Int
..} = case Maybe TemplateMeta
meta of
    Just (HaskellTemplateMeta HaddockFieldOffsets
offsets') -> HaddockFieldOffsets
offsets'
    Maybe TemplateMeta
_ -> HaddockFieldOffsets
forall a. Default a => a
def


-- | Adds correct indentation to multi-line /Haddock/ field values. It's usually
-- desired to have such values indented like this:
--
-- @
-- Copyright        : (c) 2020, 1st Author
--                    (c) 2020, 2nd Author
-- @
--
-- This functions achieves that using the /offset/ value, which specifies number
-- of empty characters that should be placed before second (and any subsequent)
-- line.
--
-- >>> indentField (Just 2) "foo\nbar\nbaz"
-- "foo\n  bar\n  baz"
indentField :: Maybe Int
            -- ^ offset (in number of black chars) for 2nd and subsequent lines
            -> Text
            -- ^ input text to indent
            -> Text
            -- ^ processed text
indentField :: Maybe Int -> Text -> Text
indentField Maybe Int
Nothing       Text
text = Text
text
indentField (Just Int
offset) Text
text = [Text] -> Text
fromLines ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
go ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
toLines (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
text
 where
  go :: [Text] -> [Text]
go []       = []
  go [Text
x     ] = [Text
x]
  go (Text
x : [Text]
xs) = Text
x Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.stripStart) [Text]
xs
  prefix :: Text
prefix = Int -> Text -> Text
T.replicate Int
offset Text
" "


-- | Strips /Haskell/ comment syntax tokens (e.g. @{-@, @-}@) from input text.
--
-- >>> stripCommentSyntax "{- foo -}\nbar\n"
-- "foo \nbar\n"
stripCommentSyntax :: Text
                   -- ^ input text to strip
                   -> Text
                   -- ^ resulting text without comment syntax tokens
stripCommentSyntax :: Text -> Text
stripCommentSyntax Text
text = [Text] -> Text
fromLines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text] -> [Text]
go (Text -> [Text]
toLines Text
text) []
 where
  regex :: Regex
regex = [re|^(-- \||-{2,})|^\h*({-\h?\|?)|(-})\h*$|]
  strip :: Text -> Text
strip = Regex -> (Text -> [Text] -> Text) -> Text -> Text
replace Regex
regex (([Text] -> Text) -> Text -> [Text] -> Text
forall a b. a -> b -> a
const (([Text] -> Text) -> Text -> [Text] -> Text)
-> (Text -> [Text] -> Text) -> Text -> Text -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
forall a b. a -> b -> a
const (Text -> Text -> [Text] -> Text) -> Text -> Text -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Text
"")
  go :: [Text] -> [Text] -> [Text]
go []       [Text]
acc = [Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
acc
  go (Text
x : [Text]
xs) [Text]
acc = [Text] -> [Text] -> [Text]
go [Text]
xs (Text -> Text
strip Text
x Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
acc)


--------------------------------------------------------------------------------
-- Below code is slightly modified version of code copied from:
-- https://github.com/haskell/haddock/blob/ghc-8.10/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
-------------------------------------------------------------------------------
-- 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
$ 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 <|> :: 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 -> String -> Maybe a
runP P a
p String
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] -> 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 (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
$ \case
  [] -> 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 -> ShowS
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
$ \case
  [] -> 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
C.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 (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
C.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
C.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 (m :: * -> *) a. Monad m => a -> m a
return (String
fn, String
val)

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