Markdown.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Docs.Markdown where

import Commonmark
import qualified Data.ByteString as BS
import Data.Char (isPunctuation, isSpace)
import Data.FileEmbed (embedDir)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified System.FilePath as Native
import qualified System.FilePath.Posix as Posix
import UI.Core (Doc (..), DocBlock (..), DocInline (..), DocMap, DocStyle (..))

instance Semigroup Doc where
  Doc a <> Doc b = Doc (a <> b)

instance Monoid Doc where
  mempty = Doc []

instance Rangeable Doc where
  ranged _ x = x

instance Rangeable [DocInline] where
  ranged _ x = x

instance HasAttributes Doc where
  addAttributes _ x = x

instance HasAttributes [DocInline] where
  addAttributes _ x = x

instance IsInline [DocInline] where
  lineBreak = [Linebreak]
  softBreak = [Linebreak]
  str s = [TextChunk s Normal]
  entity e = [TextChunk e Normal]
  escapedChar c = [TextChunk (T.singleton c) Normal]
  emph = map toEmph
    where
      toEmph (TextChunk x _) = TextChunk x Emph
      toEmph x = x
  strong = map toStrong
    where
      toStrong (TextChunk x _) = TextChunk x Strong
      toStrong x = x
  code c = [TextChunk c Code]
  rawInline _fmt t = [TextChunk t Normal]
  link dest _title l = [Link (T.concat $ map labelText l) dest]
  image dest _title l = [Link (T.concat $ map labelText l) dest]

labelText :: DocInline -> Text
labelText (TextChunk t _) = t
labelText (Link t _) = t
labelText Linebreak = ""

instance IsBlock [DocInline] Doc where
  paragraph is = Doc [Paragraph $ mergePunctuation is]
  plain is = Doc [Paragraph $ mergePunctuation is]
  thematicBreak = Doc [Paragraph [TextChunk "\n---\n" Normal]]
  blockQuote = id
  codeBlock _info ct = Doc [CodeBlock ct]
  heading _lvl is = Doc [Paragraph is]
  rawBlock _fmt t = Doc [Paragraph [TextChunk t Normal]]
  referenceLinkDefinition _ _ = mempty
  list _ty _spacing = mconcat

mergePunctuation :: [DocInline] -> [DocInline]
mergePunctuation (TextChunk a s1 : TextChunk b s2 : ds)
  | T.all isSpace b = TextChunk a s1 : TextChunk b s2 : mergePunctuation ds
  | T.all isSpace a = TextChunk a s1 : mergePunctuation (TextChunk b s2 : ds)
  | isPuncBack a || isPuncFront b = mergePunctuation $ TextChunk (a <> b) s1 : ds
  | otherwise = TextChunk a s1 : mergePunctuation (TextChunk b s2 : ds)
  where
    isPuncFront x = case T.uncons x of
      Just (c, _) -> isPunctuation c
      Nothing -> False
    isPuncBack x = case T.unsnoc x of
      Just (_, c) -> isPunctuation c
      Nothing -> False
mergePunctuation (d : ds) = d : mergePunctuation ds
mergePunctuation x = x

parseDoc :: Text -> Either ParseError Doc
parseDoc src =
  case commonmark "input" src of
    Left err -> Left err
    Right blocks -> Right blocks

normalizePath :: FilePath -> String
normalizePath = Posix.joinPath . Native.splitDirectories

embeddedFilesList :: [(FilePath, BS.ByteString)]
embeddedFilesList = $(embedDir "docs")

docMap :: DocMap
docMap = Map.fromList [(T.pack $ normalizePath path, toDoc content) | (path, content) <- embeddedFilesList]
  where
    toDoc bs = case parseDoc $ TE.decodeUtf8 bs of
      Left err -> error $ "Error in parsing documentation:" <> show err
      Right x -> x

startDoc :: Doc
startDoc = fromMaybe (error "Failed to get start Documentation!") $ Map.lookup "welcome.md" docMap