content: {-# 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 relPath = makeRelativeToProject relPath >>= 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 header = LText.append "\^B" (LText.append header ":\^B\n")
  
  loadDoc :: (String -> String) -> FilePath -> Q Docs
  loadDoc keymod path = addRelativeDependentFile splicePath >> runIO (readFile splicePath >>= renderDoc)
    where
      splicePath = "doc" </> path <.> "adoc"
      renderDoc doc = case Parse.parseOnly lineParser $ decodeUtf8 doc of
        Right docs -> return $ buildDocs keymod docs
        Left errorMsg -> fail ("Parser failed on `" ++ splicePath ++ "`: " ++ errorMsg)
  
  lookupDoc :: LText.Text -> String -> Docs -> Q Exp
  lookupDoc header name docs =
    case HashMap.lookup name docs of
      Just doc -> lift $ LText.toStrict $ LText.append header doc
      Nothing -> fail failMsg
    where
      failMsg = "No docs for `" ++ name ++ "` (have " ++ show (HashMap.keys docs) ++ ")"
  
  buildDocs :: (String -> String) -> [Line] -> Docs
  buildDocs keymod parsedLines = docs
    where
      folded = foldl (addLine keymod) (HashMap.empty, "", LText.empty) parsedLines
      (docs, _, _) = addLine keymod folded (Section "")
  
  data RenderContentsState
    = NormalState
    | CodeStartState
    | CodeEndState
    | CodeBlockState
  
  renderContents :: RenderContentsState -> LText.Text -> LText.Text
  renderContents state = Builder.toLazyText . snd . foldl renderContents' (state, mempty) . LText.unpack
    where
      renderContents' (st, text) char = case (st, char) of
         (CodeStartState, '+') -> (CodeBlockState, text <> Builder.fromText "\^_")
         (CodeStartState, _  ) -> (NormalState,    text <> Builder.fromText "\^B" <> Builder.singleton char)
         (CodeEndState,   '`') -> (NormalState,    text <> Builder.fromText "\^_")
         (CodeEndState,   _  ) -> (CodeBlockState, text <> Builder.singleton '+' <> Builder.singleton char)
         (NormalState,    '`') -> (CodeStartState, text)
         (CodeBlockState, '+') -> (CodeEndState,   text)
         (_,              _  ) -> (st,             text <> Builder.singleton char)
  
  addLine :: (String -> String) -> (Docs, Text, LText.Text) -> Line -> (Docs, Text, LText.Text)
  addLine _      (docs, section, text)      Discarded    = (docs, section, text)
  addLine _      (docs, "", _)              (Section s') = (docs, s', LText.empty)
  addLine _      (docs, "", text)           _            = (docs, "", text)
  addLine keymod (docs, section, text) line              = case line of
    -- TODO: Keep renderContents state across lines.
    -- Otherwise start in NormalState after each newline.
    Contents text'   -> (docs, section, append' $ renderContents NormalState text')
    Subsection text' -> (docs, section, append' (makeHeader (LText.fromStrict text')))
    Section s'       -> (HashMap.insert (keymod $ Text.unpack section) text docs, s', LText.empty)
    where
      append' = LText.append text
  
  lineParser :: Parse.Parser [Line]
  lineParser = Parse.many1' (sectionParser <|> contentsParser) <* Parse.endOfInput
    where
      sectionParser = Parse.char '=' >> (sectionL2Parser <|> sectionL3Parser <|> return Discarded)
        where
          sectionL2Parser = do
            _ <- Parse.string "= "
            name <- Parse.takeWhile1 (not . isSpace)
            eolParser
            return (Section name)
          sectionL3Parser = do
            _ <- Parse.takeWhile1 (== '=')
            Parse.skipWhile (== ' ')
            chars <- Parse.manyTill Parse.anyChar eolParser
            return (Subsection $ Text.pack chars)
      contentsParser = do
        chars <- Parse.manyTill Parse.anyChar eolParser
        return $ Contents $ LText.fromChunks ["  ", Text.pack chars, "\n"]
      eolParser = do
        spaces <- Parse.takeWhile (== ' ')
        _ <- if Text.null spaces then pure '+' else Parse.option '+' (Parse.char '+')
        Parse.endOfLine
  