{- |
Module: Pollock.Documentation.Parser
Copyright: (c) Trevis Elser 2023
License: MIT
Maintainer: trevis@flipstone.com
Stability: experimental
Portability: non-portable
-}
module Pollock.Documentation.Parser
  ( processDocStringParas
  , processDocStrings
  , parseText
  )
where

import qualified Control.Applicative as App
import qualified Control.Monad as M
import qualified Data.Attoparsec.Text as AttoText
import qualified Data.Char as Char
import qualified Data.Text as T

import qualified Pollock.CompatGHC as CompatGHC
import Pollock.Documentation.Doc
  ( Doc
      ( DocCodeBlock
      , DocEmpty
      , DocParagraph
      , DocProperty
      , DocString
      )
  )
import Pollock.Documentation.Metadata (Metadata (Metadata, version))
import Pollock.Documentation.MetadataAndDoc
  ( MetaAndDoc (MetaAndDoc, doc, meta)
  , metaAndDocConcat
  , withEmptyMetadata
  )

parseText :: T.Text -> Doc
parseText :: Text -> Doc
parseText =
  ([Char] -> Doc) -> (Doc -> Doc) -> Either [Char] Doc -> Doc
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Char] -> Doc
forall a. HasCallStack => [Char] -> a
error Doc -> Doc
forall a. a -> a
id
    (Either [Char] Doc -> Doc)
-> (Text -> Either [Char] Doc) -> Text -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser Doc -> Text -> Either [Char] Doc
forall a. Parser a -> Text -> Either [Char] a
AttoText.parseOnly ((Text -> Doc) -> Parser Text Text -> Parser Doc
forall a b. (a -> b) -> Parser Text a -> Parser Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Doc
docStringFromText Parser Text Text
AttoText.takeText)
    (Text -> Either [Char] Doc)
-> (Text -> Text) -> Text -> Either [Char] Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
T.filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\r')

processDocStringParas ::
  CompatGHC.HsDocString -> MetaAndDoc
processDocStringParas :: HsDocString -> MetaAndDoc
processDocStringParas =
  ([Char] -> MetaAndDoc)
-> (MetaAndDoc -> MetaAndDoc)
-> Either [Char] MetaAndDoc
-> MetaAndDoc
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Char] -> MetaAndDoc
forall a. HasCallStack => [Char] -> a
error MetaAndDoc -> MetaAndDoc
forall a. a -> a
id
    (Either [Char] MetaAndDoc -> MetaAndDoc)
-> (HsDocString -> Either [Char] MetaAndDoc)
-> HsDocString
-> MetaAndDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser MetaAndDoc -> Text -> Either [Char] MetaAndDoc
forall a. Parser a -> Text -> Either [Char] a
AttoText.parseOnly Parser MetaAndDoc
parseParas
    (Text -> Either [Char] MetaAndDoc)
-> (HsDocString -> Text) -> HsDocString -> Either [Char] MetaAndDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack
    ([Char] -> Text) -> (HsDocString -> [Char]) -> HsDocString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\r')
    ([Char] -> [Char])
-> (HsDocString -> [Char]) -> HsDocString -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsDocString -> [Char]
CompatGHC.renderHsDocString

processDocStrings ::
  [CompatGHC.HsDocString]
  -> Maybe MetaAndDoc
processDocStrings :: [HsDocString] -> Maybe MetaAndDoc
processDocStrings [HsDocString]
strs =
  case [MetaAndDoc] -> MetaAndDoc
metaAndDocConcat ([MetaAndDoc] -> MetaAndDoc) -> [MetaAndDoc] -> MetaAndDoc
forall a b. (a -> b) -> a -> b
$ (HsDocString -> MetaAndDoc) -> [HsDocString] -> [MetaAndDoc]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsDocString -> MetaAndDoc
processDocStringParas [HsDocString]
strs of
    -- We check that we don't have any version info to render instead
    -- of just checking if there is no comment: there may not be a
    -- comment but we still want to pass through any meta data.
    MetaAndDoc{meta :: MetaAndDoc -> Metadata
meta = Metadata Maybe SinceVersion
Nothing, doc :: MetaAndDoc -> Doc
doc = Doc
DocEmpty} -> Maybe MetaAndDoc
forall a. Maybe a
Nothing
    MetaAndDoc
x -> MetaAndDoc -> Maybe MetaAndDoc
forall a. a -> Maybe a
Just MetaAndDoc
x

since :: AttoText.Parser MetaAndDoc
since :: Parser MetaAndDoc
since = do
  Parser ()
skipHorizontalSpace
  Text
_ <- Text -> Parser Text Text
AttoText.string ([Char] -> Text
T.pack [Char]
"@since ")
  SinceVersion
s <- Parser Text Int -> Parser Text Text -> Parser Text SinceVersion
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
AttoText.sepBy1 Parser Text Int
forall a. Integral a => Parser a
AttoText.decimal (Text -> Parser Text Text
AttoText.string (Text -> Parser Text Text) -> Text -> Parser Text Text
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
".")
  Parser ()
skipHorizontalSpace
  let
    metadata :: Metadata
metadata =
      Metadata
        { version :: Maybe SinceVersion
version = SinceVersion -> Maybe SinceVersion
forall a. a -> Maybe a
Just SinceVersion
s
        }
  MetaAndDoc -> Parser MetaAndDoc
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MetaAndDoc -> Parser MetaAndDoc)
-> MetaAndDoc -> Parser MetaAndDoc
forall a b. (a -> b) -> a -> b
$ Metadata -> Doc -> MetaAndDoc
MetaAndDoc Metadata
metadata Doc
DocEmpty

skipHorizontalSpace :: AttoText.Parser ()
skipHorizontalSpace :: Parser ()
skipHorizontalSpace =
  (Char -> Bool) -> Parser ()
AttoText.skipWhile Char -> Bool
AttoText.isHorizontalSpace

takeLine :: AttoText.Parser T.Text
takeLine :: Parser Text Text
takeLine = Parser Text Text
takeToEndOfLine

takeNonEmptyLine :: AttoText.Parser T.Text
takeNonEmptyLine :: Parser Text Text
takeNonEmptyLine =
  (Text -> Bool) -> Parser Text Text -> Parser Text Text
forall (m :: * -> *) a. MonadPlus m => (a -> Bool) -> m a -> m a
M.mfilter ((Char -> Bool) -> Text -> Bool
T.any (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
Char.isSpace)) Parser Text Text
takeLine

birdtracks :: AttoText.Parser MetaAndDoc
birdtracks :: Parser MetaAndDoc
birdtracks =
  let line :: Parser Text Text
line = do
        Parser ()
skipHorizontalSpace
        Text
_ <- Text -> Parser Text Text
AttoText.string ([Char] -> Text
T.pack [Char]
">")
        Parser Text Text
takeLine
   in ([Text] -> MetaAndDoc) -> Parser Text [Text] -> Parser MetaAndDoc
forall a b. (a -> b) -> Parser Text a -> Parser Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Doc -> MetaAndDoc
withEmptyMetadata (Doc -> MetaAndDoc) -> ([Text] -> Doc) -> [Text] -> MetaAndDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc
DocCodeBlock (Doc -> Doc) -> ([Text] -> Doc) -> [Text] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Doc
docStringFromText (Text -> Doc) -> ([Text] -> Text) -> [Text] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
T.intercalate ([Char] -> Text
T.pack [Char]
"\n")) (Parser Text [Text] -> Parser MetaAndDoc)
-> Parser Text [Text] -> Parser MetaAndDoc
forall a b. (a -> b) -> a -> b
$
        Parser Text Text -> Parser Text [Text]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
AttoText.many1 Parser Text Text
line

paragraph :: AttoText.Parser MetaAndDoc
paragraph :: Parser MetaAndDoc
paragraph =
  [Parser MetaAndDoc] -> Parser MetaAndDoc
forall (f :: * -> *) a. Alternative f => [f a] -> f a
AttoText.choice
    [ Parser MetaAndDoc
since
    , Parser MetaAndDoc
birdtracks
    , (Doc -> MetaAndDoc) -> Parser Doc -> Parser MetaAndDoc
forall a b. (a -> b) -> Parser Text a -> Parser Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Doc -> MetaAndDoc
withEmptyMetadata Parser Doc
codeblock
    , (Doc -> MetaAndDoc) -> Parser Doc -> Parser MetaAndDoc
forall a b. (a -> b) -> Parser Text a -> Parser Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Doc -> MetaAndDoc
withEmptyMetadata Parser Doc
property
    , (Text -> MetaAndDoc) -> Parser Text Text -> Parser MetaAndDoc
forall a b. (a -> b) -> Parser Text a -> Parser Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Doc -> MetaAndDoc
withEmptyMetadata (Doc -> MetaAndDoc) -> (Text -> Doc) -> Text -> MetaAndDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Doc
docStringFromText) Parser Text Text
takeLine
    , (Doc -> MetaAndDoc) -> Parser Doc -> Parser MetaAndDoc
forall a b. (a -> b) -> Parser Text a -> Parser Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Doc -> MetaAndDoc
withEmptyMetadata (Doc -> MetaAndDoc) -> (Doc -> Doc) -> Doc -> MetaAndDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc
DocParagraph) Parser Doc
textParagraph
    ]

docStringFromText :: T.Text -> Doc
docStringFromText :: Text -> Doc
docStringFromText = [Char] -> Doc
DocString ([Char] -> Doc) -> (Text -> [Char]) -> Text -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack

textParagraph :: AttoText.Parser Doc
textParagraph :: Parser Doc
textParagraph = do
  [Text]
lines' <- Parser Text Text -> Parser Text [Text]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
AttoText.many1 Parser Text Text
takeNonEmptyLine
  Doc -> Parser Doc
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
App.pure (Doc -> Parser Doc) -> Doc -> Parser Doc
forall a b. (a -> b) -> a -> b
$ (Text -> Doc
docStringFromText (Text -> Doc) -> ([Text] -> Text) -> [Text] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
T.intercalate ([Char] -> Text
T.pack [Char]
"\n")) [Text]
lines'

parseParas :: AttoText.Parser MetaAndDoc
parseParas :: Parser MetaAndDoc
parseParas =
  ([MetaAndDoc] -> MetaAndDoc)
-> Parser Text [MetaAndDoc] -> Parser MetaAndDoc
forall a b. (a -> b) -> Parser Text a -> Parser Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [MetaAndDoc] -> MetaAndDoc
metaAndDocConcat (Parser Text [MetaAndDoc] -> Parser MetaAndDoc)
-> (Parser MetaAndDoc -> Parser Text [MetaAndDoc])
-> Parser MetaAndDoc
-> Parser MetaAndDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser MetaAndDoc -> Parser Text [MetaAndDoc]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
AttoText.many' (Parser MetaAndDoc -> Parser MetaAndDoc)
-> Parser MetaAndDoc -> Parser MetaAndDoc
forall a b. (a -> b) -> a -> b
$ do
    MetaAndDoc
p <- Parser MetaAndDoc
paragraph
    Parser ()
consumeEmptyLines
    MetaAndDoc -> Parser MetaAndDoc
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
App.pure MetaAndDoc
p

{- | Property parser.

>>> snd <$> parseOnly property "prop> hello world"
Right (DocProperty "hello world")
-}
property :: AttoText.Parser Doc
property :: Parser Doc
property =
  (Text -> Doc) -> Parser Text Text -> Parser Doc
forall a b. (a -> b) -> Parser Text a -> Parser Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Char] -> Doc
DocProperty ([Char] -> Doc) -> (Text -> [Char]) -> Text -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack (Text -> [Char]) -> (Text -> Text) -> Text -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip) (Parser Text Text -> Parser Doc) -> Parser Text Text -> Parser Doc
forall a b. (a -> b) -> a -> b
$ do
    Text
_ <- Text -> Parser Text Text
AttoText.string ([Char] -> Text
T.pack [Char]
"prop>")
    Parser Text Text
takeToEndOfLine

{- |
Paragraph level codeblock. Anything between the two delimiting \@ is parsed
for markup.
-}
codeblock :: AttoText.Parser Doc
codeblock :: Parser Doc
codeblock = do
  let
    atText :: Text
atText = [Char] -> Text
T.pack [Char]
"@"
  Text
_ <- Text -> Parser Text Text
AttoText.string Text
atText
  Parser ()
skipHorizontalSpace
  Parser ()
AttoText.endOfLine
  Doc
blockDoc <- Parser Doc
textParagraph
  Text
_ <- Text -> Parser Text Text
AttoText.string Text
atText
  Doc -> Parser Doc
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
App.pure (Doc -> Parser Doc) -> Doc -> Parser Doc
forall a b. (a -> b) -> a -> b
$ Doc -> Doc
DocCodeBlock Doc
blockDoc

takeToEndOfLine :: AttoText.Parser T.Text
takeToEndOfLine :: Parser Text Text
takeToEndOfLine = (Char -> Bool) -> Parser Text Text
AttoText.takeWhile1 (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
AttoText.isEndOfLine)

consumeEmptyLines :: AttoText.Parser ()
consumeEmptyLines :: Parser ()
consumeEmptyLines =
  Parser Text [()] -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
M.void (Parser Text [()] -> Parser ())
-> (Parser () -> Parser Text [()]) -> Parser () -> Parser ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser () -> Parser Text [()]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
AttoText.many' (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ do
    Parser ()
skipHorizontalSpace
    Parser ()
AttoText.endOfLine