{-# Language CPP, OverloadedStrings #-}

{-|
Module      : Client.Docs
Description : Compile-time documentation injection
Copyright   : (c) TheDaemoness 2023
License     : ISC
Maintainer  : emertens@gmail.com

This module adds the requisite functions to load and parse
a subset of AsciiDoc and embed it using Template Haskell.
-}
module Client.Docs
  ( Docs
  , loadDoc
  , lookupDoc
  , makeHeader
  ) where

import           Prelude hiding (readFile)

import           Control.Applicative ((<|>))
import qualified Data.Attoparsec.Text as Parse
import           Data.ByteString (readFile)
import           Data.Char (isSpace)
import           Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import           Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Lazy as LText
import qualified Data.Text.Lazy.Builder as Builder
import           Data.Text.Encoding (decodeUtf8)
import           Language.Haskell.TH (Exp, Q, runIO)
import           Language.Haskell.TH.Syntax (lift)
import           System.FilePath ((</>), (<.>))

#if MIN_VERSION_template_haskell(2,19,0)
import Language.Haskell.TH.Syntax (addDependentFile, makeRelativeToProject)
addRelativeDependentFile :: FilePath -> Q ()
addRelativeDependentFile :: String -> Q ()
addRelativeDependentFile String
relPath = String -> Q String
makeRelativeToProject String
relPath Q String -> (String -> Q ()) -> Q ()
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Q ()
addDependentFile
#else
addRelativeDependentFile :: FilePath -> Q ()
addRelativeDependentFile _ = return ()
#endif

type Docs = HashMap String LText.Text

data Line
  = Discarded
  | Section Text
  | Subsection Text
  | Contents LText.Text

makeHeader :: LText.Text -> LText.Text
makeHeader :: Text -> Text
makeHeader Text
header = Text -> Text -> Text
LText.append Text
"\^B" (Text -> Text -> Text
LText.append Text
header Text
":\^B\n")

loadDoc :: (String -> String) -> FilePath -> Q Docs
loadDoc :: (String -> String) -> String -> Q Docs
loadDoc String -> String
keymod String
path = String -> Q ()
addRelativeDependentFile String
splicePath Q () -> Q Docs -> Q Docs
forall a b. Q a -> Q b -> Q b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO Docs -> Q Docs
forall a. IO a -> Q a
runIO (String -> IO ByteString
readFile String
splicePath IO ByteString -> (ByteString -> IO Docs) -> IO Docs
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> IO Docs
forall {m :: * -> *}. MonadFail m => ByteString -> m Docs
renderDoc)
  where
    splicePath :: String
splicePath = String
"doc" String -> String -> String
</> String
path String -> String -> String
<.> String
"adoc"
    renderDoc :: ByteString -> m Docs
renderDoc ByteString
doc = case Parser [Line] -> Text -> Either String [Line]
forall a. Parser a -> Text -> Either String a
Parse.parseOnly Parser [Line]
lineParser (Text -> Either String [Line]) -> Text -> Either String [Line]
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8 ByteString
doc of
      Right [Line]
docs -> Docs -> m Docs
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Docs -> m Docs) -> Docs -> m Docs
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [Line] -> Docs
buildDocs String -> String
keymod [Line]
docs
      Left String
errorMsg -> String -> m Docs
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Parser failed on `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
splicePath String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"`: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
errorMsg)

lookupDoc :: LText.Text -> String -> Docs -> Q Exp
lookupDoc :: Text -> String -> Docs -> Q Exp
lookupDoc Text
header String
name Docs
docs =
  case String -> Docs -> Maybe Text
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup String
name Docs
docs of
    Just Text
doc -> Text -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Text -> m Exp
lift (Text -> Q Exp) -> Text -> Q Exp
forall a b. (a -> b) -> a -> b
$ Text -> Text
LText.toStrict (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text
LText.append Text
header Text
doc
    Maybe Text
Nothing -> String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
failMsg
  where
    failMsg :: String
failMsg = String
"No docs for `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"` (have " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show (Docs -> [String]
forall k v. HashMap k v -> [k]
HashMap.keys Docs
docs) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"

buildDocs :: (String -> String) -> [Line] -> Docs
buildDocs :: (String -> String) -> [Line] -> Docs
buildDocs String -> String
keymod [Line]
parsedLines = Docs
docs
  where
    folded :: (Docs, Text, Text)
folded = ((Docs, Text, Text) -> Line -> (Docs, Text, Text))
-> (Docs, Text, Text) -> [Line] -> (Docs, Text, Text)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ((String -> String)
-> (Docs, Text, Text) -> Line -> (Docs, Text, Text)
addLine String -> String
keymod) (Docs
forall k v. HashMap k v
HashMap.empty, Text
"", Text
LText.empty) [Line]
parsedLines
    (Docs
docs, Text
_, Text
_) = (String -> String)
-> (Docs, Text, Text) -> Line -> (Docs, Text, Text)
addLine String -> String
keymod (Docs, Text, Text)
folded (Text -> Line
Section Text
"")

data RenderContentsState
  = NormalState
  | CodeStartState
  | CodeEndState
  | CodeBlockState

renderContents :: RenderContentsState -> LText.Text -> LText.Text
renderContents :: RenderContentsState -> Text -> Text
renderContents RenderContentsState
state = Builder -> Text
Builder.toLazyText (Builder -> Text) -> (Text -> Builder) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RenderContentsState, Builder) -> Builder
forall a b. (a, b) -> b
snd ((RenderContentsState, Builder) -> Builder)
-> (Text -> (RenderContentsState, Builder)) -> Text -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((RenderContentsState, Builder)
 -> Char -> (RenderContentsState, Builder))
-> (RenderContentsState, Builder)
-> String
-> (RenderContentsState, Builder)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (RenderContentsState, Builder)
-> Char -> (RenderContentsState, Builder)
renderContents' (RenderContentsState
state, Builder
forall a. Monoid a => a
mempty) (String -> (RenderContentsState, Builder))
-> (Text -> String) -> Text -> (RenderContentsState, Builder)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
LText.unpack
  where
    renderContents' :: (RenderContentsState, Builder)
-> Char -> (RenderContentsState, Builder)
renderContents' (RenderContentsState
st, Builder
text) Char
char = case (RenderContentsState
st, Char
char) of
       (RenderContentsState
CodeStartState, Char
'+') -> (RenderContentsState
CodeBlockState, Builder
text Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Builder.fromText Text
"\^_")
       (RenderContentsState
CodeStartState, Char
_  ) -> (RenderContentsState
NormalState,    Builder
text Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Builder.fromText Text
"\^B" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
Builder.singleton Char
char)
       (RenderContentsState
CodeEndState,   Char
'`') -> (RenderContentsState
NormalState,    Builder
text Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Builder.fromText Text
"\^_")
       (RenderContentsState
CodeEndState,   Char
_  ) -> (RenderContentsState
CodeBlockState, Builder
text Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
Builder.singleton Char
'+' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
Builder.singleton Char
char)
       (RenderContentsState
NormalState,    Char
'`') -> (RenderContentsState
CodeStartState, Builder
text)
       (RenderContentsState
CodeBlockState, Char
'+') -> (RenderContentsState
CodeEndState,   Builder
text)
       (RenderContentsState
_,              Char
_  ) -> (RenderContentsState
st,             Builder
text Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
Builder.singleton Char
char)

addLine :: (String -> String) -> (Docs, Text, LText.Text) -> Line -> (Docs, Text, LText.Text)
addLine :: (String -> String)
-> (Docs, Text, Text) -> Line -> (Docs, Text, Text)
addLine String -> String
_      (Docs
docs, Text
section, Text
text)      Line
Discarded    = (Docs
docs, Text
section, Text
text)
addLine String -> String
_      (Docs
docs, Text
"", Text
_)              (Section Text
s') = (Docs
docs, Text
s', Text
LText.empty)
addLine String -> String
_      (Docs
docs, Text
"", Text
text)           Line
_            = (Docs
docs, Text
"", Text
text)
addLine String -> String
keymod (Docs
docs, Text
section, Text
text) Line
line              = case Line
line of
  -- TODO: Keep renderContents state across lines.
  -- Otherwise start in NormalState after each newline.
  Contents Text
text'   -> (Docs
docs, Text
section, Text -> Text
append' (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ RenderContentsState -> Text -> Text
renderContents RenderContentsState
NormalState Text
text')
  Subsection Text
text' -> (Docs
docs, Text
section, Text -> Text
append' (Text -> Text
makeHeader (Text -> Text
LText.fromStrict Text
text')))
  Section Text
s'       -> (String -> Text -> Docs -> Docs
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert (String -> String
keymod (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
section) Text
text Docs
docs, Text
s', Text
LText.empty)
  where
    append' :: Text -> Text
append' = Text -> Text -> Text
LText.append Text
text

lineParser :: Parse.Parser [Line]
lineParser :: Parser [Line]
lineParser = Parser Text Line -> Parser [Line]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
Parse.many1' (Parser Text Line
sectionParser Parser Text Line -> Parser Text Line -> Parser Text Line
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Line
contentsParser) Parser [Line] -> Parser Text () -> Parser [Line]
forall a b. Parser Text a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
forall t. Chunk t => Parser t ()
Parse.endOfInput
  where
    sectionParser :: Parser Text Line
sectionParser = Char -> Parser Char
Parse.char Char
'=' Parser Char -> Parser Text Line -> Parser Text Line
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Parser Text Line
sectionL2Parser Parser Text Line -> Parser Text Line -> Parser Text Line
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Line
sectionL3Parser Parser Text Line -> Parser Text Line -> Parser Text Line
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Line -> Parser Text Line
forall a. a -> Parser Text a
forall (m :: * -> *) a. Monad m => a -> m a
return Line
Discarded)
      where
        sectionL2Parser :: Parser Text Line
sectionL2Parser = do
          Text
_ <- Text -> Parser Text
Parse.string Text
"= "
          Text
name <- (Char -> Bool) -> Parser Text
Parse.takeWhile1 (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace)
          Parser Text ()
eolParser
          Line -> Parser Text Line
forall a. a -> Parser Text a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Line
Section Text
name)
        sectionL3Parser :: Parser Text Line
sectionL3Parser = do
          Text
_ <- (Char -> Bool) -> Parser Text
Parse.takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'=')
          (Char -> Bool) -> Parser Text ()
Parse.skipWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ')
          String
chars <- Parser Char -> Parser Text () -> Parser Text String
forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
Parse.manyTill Parser Char
Parse.anyChar Parser Text ()
eolParser
          Line -> Parser Text Line
forall a. a -> Parser Text a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Line
Subsection (Text -> Line) -> Text -> Line
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
chars)
    contentsParser :: Parser Text Line
contentsParser = do
      String
chars <- Parser Char -> Parser Text () -> Parser Text String
forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
Parse.manyTill Parser Char
Parse.anyChar Parser Text ()
eolParser
      Line -> Parser Text Line
forall a. a -> Parser Text a
forall (m :: * -> *) a. Monad m => a -> m a
return (Line -> Parser Text Line) -> Line -> Parser Text Line
forall a b. (a -> b) -> a -> b
$ Text -> Line
Contents (Text -> Line) -> Text -> Line
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
LText.fromChunks [Text
"  ", String -> Text
Text.pack String
chars, Text
"\n"]
    eolParser :: Parser Text ()
eolParser = do
      Text
spaces <- (Char -> Bool) -> Parser Text
Parse.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ')
      Char
_ <- if Text -> Bool
Text.null Text
spaces then Char -> Parser Char
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
'+' else Char -> Parser Char -> Parser Char
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
Parse.option Char
'+' (Char -> Parser Char
Parse.char Char
'+')
      Parser Text ()
Parse.endOfLine