{-# Language OverloadedStrings #-}
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
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
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