{-# Language 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           Data.Text.Encoding (decodeUtf8)
import           Language.Haskell.TH (Exp, Q, runIO)
import           Language.Haskell.TH.Syntax (lift)
import qualified Data.Text.Lazy.Builder as Builder

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 = forall a. IO a -> Q a
runIO (String -> IO ByteString
readFile String
splicePath forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {m :: * -> *}. MonadFail m => ByteString -> m Docs
renderDoc)
  where
    splicePath :: String
splicePath = String
"doc/" forall a. [a] -> [a] -> [a]
++ String
path forall a. [a] -> [a] -> [a]
++ String
".adoc"
    renderDoc :: ByteString -> m Docs
renderDoc ByteString
doc = case forall a. Parser a -> Text -> Either String a
Parse.parseOnly Parser [Line]
lineParser forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8 ByteString
doc of
      Right [Line]
docs -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (String -> String) -> [Line] -> Docs
buildDocs String -> String
keymod [Line]
docs
      Left String
errorMsg -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Parser failed on `" forall a. [a] -> [a] -> [a]
++ String
splicePath forall a. [a] -> [a] -> [a]
++ 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 forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup String
name Docs
docs of
    Just Text
doc -> forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
lift forall a b. (a -> b) -> a -> b
$ Text -> Text
LText.toStrict forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text
LText.append Text
header Text
doc
    Maybe Text
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
failMsg
  where
    failMsg :: String
failMsg = String
"No docs for `" forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
"` (have " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall k v. HashMap k v -> [k]
HashMap.keys Docs
docs) 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 = 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) (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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (RenderContentsState, Builder)
-> Char -> (RenderContentsState, Builder)
renderContents' (RenderContentsState
state, forall a. Monoid a => a
mempty) 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 forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Builder.fromText Text
"\^_")
       (RenderContentsState
CodeStartState, Char
_  ) -> (RenderContentsState
NormalState,    Builder
text forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Builder.fromText Text
"\^B" forall a. Semigroup a => a -> a -> a
<> Char -> Builder
Builder.singleton Char
char)
       (RenderContentsState
CodeEndState,   Char
'`') -> (RenderContentsState
NormalState,    Builder
text forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Builder.fromText Text
"\^_")
       (RenderContentsState
CodeEndState,   Char
_  ) -> (RenderContentsState
CodeBlockState, Builder
text forall a. Semigroup a => a -> a -> a
<> Char -> Builder
Builder.singleton Char
'+' 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 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' 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'       -> (forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert (String -> String
keymod 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 = forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
Parse.many1' (Parser Text Line
sectionParser forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Line
contentsParser) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall t. Chunk t => Parser t ()
Parse.endOfInput
  where
    sectionParser :: Parser Text Line
sectionParser = Char -> Parser Char
Parse.char Char
'=' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Parser Text Line
sectionL2Parser forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Line
sectionL3Parser forall (f :: * -> *) a. Alternative f => f a -> f a -> f 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace)
          Parser Text ()
eolParser
          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 (forall a. Eq a => a -> a -> Bool
== Char
'=')
          (Char -> Bool) -> Parser Text ()
Parse.skipWhile (forall a. Eq a => a -> a -> Bool
== Char
' ')
          String
chars <- forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
Parse.manyTill Parser Char
Parse.anyChar Parser Text ()
eolParser
          forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Line
Subsection forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
chars)
    contentsParser :: Parser Text Line
contentsParser = do
      String
chars <- forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
Parse.manyTill Parser Char
Parse.anyChar Parser Text ()
eolParser
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> Line
Contents 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 (forall a. Eq a => a -> a -> Bool
== Char
' ')
      Char
_ <- if Text -> Bool
Text.null Text
spaces then forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
'+' else forall (f :: * -> *) a. Alternative f => a -> f a -> f a
Parse.option Char
'+' (Char -> Parser Char
Parse.char Char
'+')
      Parser Text ()
Parse.endOfLine