{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

-- | Parsing Markdown using the mmark parser.
module Rib.Parser.MMark
  ( -- * Parsing
    parse,
    parsePure,
    parseWith,
    parsePureWith,
    defaultExts,

    -- * Rendering
    render,

    -- * Extracting information
    getFirstImg,
    getFirstParagraphText,
    projectYaml,

    -- * Re-exports
    MMark,
  )
where

import Control.Foldl (Fold (..))
import Development.Shake (Action, readFile')
import Lucid.Base (HtmlT (..))
import Path
import Relude
import Rib.Shake (ribInputDir)
import Text.MMark (MMark, projectYaml)
import qualified Text.MMark as MMark
import qualified Text.MMark.Extension as Ext
import qualified Text.MMark.Extension.Common as Ext
import qualified Text.Megaparsec as M
import Text.URI (URI)

-- | Render a MMark document as HTML
render :: Monad m => MMark -> HtmlT m ()
render :: MMark -> HtmlT m ()
render = HtmlT Identity () -> HtmlT m ()
forall (m :: * -> *). Monad m => HtmlT Identity () -> HtmlT m ()
liftHtml (HtmlT Identity () -> HtmlT m ())
-> (MMark -> HtmlT Identity ()) -> MMark -> HtmlT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MMark -> HtmlT Identity ()
MMark.render
  where
    liftHtml :: Monad m => HtmlT Identity () -> HtmlT m ()
    liftHtml :: HtmlT Identity () -> HtmlT m ()
liftHtml = m (HashMap Text Text -> Builder, ()) -> HtmlT m ()
forall (m :: * -> *) a.
m (HashMap Text Text -> Builder, a) -> HtmlT m a
HtmlT (m (HashMap Text Text -> Builder, ()) -> HtmlT m ())
-> (HtmlT Identity () -> m (HashMap Text Text -> Builder, ()))
-> HtmlT Identity ()
-> HtmlT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HashMap Text Text -> Builder, ())
-> m (HashMap Text Text -> Builder, ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((HashMap Text Text -> Builder, ())
 -> m (HashMap Text Text -> Builder, ()))
-> (HtmlT Identity () -> (HashMap Text Text -> Builder, ()))
-> HtmlT Identity ()
-> m (HashMap Text Text -> Builder, ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity (HashMap Text Text -> Builder, ())
-> (HashMap Text Text -> Builder, ())
forall a. Identity a -> a
runIdentity (Identity (HashMap Text Text -> Builder, ())
 -> (HashMap Text Text -> Builder, ()))
-> (HtmlT Identity ()
    -> Identity (HashMap Text Text -> Builder, ()))
-> HtmlT Identity ()
-> (HashMap Text Text -> Builder, ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HtmlT Identity () -> Identity (HashMap Text Text -> Builder, ())
forall (m :: * -> *) a.
HtmlT m a -> m (HashMap Text Text -> Builder, a)
runHtmlT

-- | Like `parsePure` but takes a custom list of MMark extensions
parsePureWith ::
  [MMark.Extension] ->
  -- | Filepath corresponding to the text to be parsed (used only in parse errors)
  FilePath ->
  -- | Text to be parsed
  Text ->
  Either Text MMark
parsePureWith :: [Extension] -> FilePath -> Text -> Either Text MMark
parsePureWith exts :: [Extension]
exts k :: FilePath
k s :: Text
s = case FilePath -> Text -> Either (ParseErrorBundle Text MMarkErr) MMark
MMark.parse FilePath
k Text
s of
  Left e :: ParseErrorBundle Text MMarkErr
e -> Text -> Either Text MMark
forall a b. a -> Either a b
Left (Text -> Either Text MMark) -> Text -> Either Text MMark
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
forall a. ToText a => a -> Text
toText (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle Text MMarkErr -> FilePath
forall s e.
(Stream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> FilePath
M.errorBundlePretty ParseErrorBundle Text MMarkErr
e
  Right doc :: MMark
doc -> MMark -> Either Text MMark
forall a b. b -> Either a b
Right (MMark -> Either Text MMark) -> MMark -> Either Text MMark
forall a b. (a -> b) -> a -> b
$ [Extension] -> MMark -> MMark
MMark.useExtensions [Extension]
exts (MMark -> MMark) -> MMark -> MMark
forall a b. (a -> b) -> a -> b
$ MMark -> MMark
useTocExt MMark
doc

-- | Pure version of `parse`
parsePure ::
  -- | Filepath corresponding to the text to be parsed (used only in parse errors)
  FilePath ->
  -- | Text to be parsed
  Text ->
  Either Text MMark
parsePure :: FilePath -> Text -> Either Text MMark
parsePure = [Extension] -> FilePath -> Text -> Either Text MMark
parsePureWith [Extension]
defaultExts

-- | Parse Markdown using mmark
parse :: Path Rel File -> Action MMark
parse :: Path Rel File -> Action MMark
parse = [Extension] -> Path Rel File -> Action MMark
parseWith [Extension]
defaultExts

-- | Like `parse` but takes a custom list of MMark extensions
parseWith :: [MMark.Extension] -> Path Rel File -> Action MMark
parseWith :: [Extension] -> Path Rel File -> Action MMark
parseWith exts :: [Extension]
exts f :: Path Rel File
f =
  (Text -> Action MMark)
-> (MMark -> Action MMark) -> Either Text MMark -> Action MMark
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (FilePath -> Action MMark
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> Action MMark)
-> (Text -> FilePath) -> Text -> Action MMark
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
forall a. ToString a => a -> FilePath
toString) MMark -> Action MMark
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text MMark -> Action MMark)
-> Action (Either Text MMark) -> Action MMark
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
    Path Rel Dir
inputDir <- Action (Path Rel Dir)
ribInputDir
    Text
s <- FilePath -> Text
forall a. ToText a => a -> Text
toText (FilePath -> Text) -> Action FilePath -> Action Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Partial => FilePath -> Action FilePath
FilePath -> Action FilePath
readFile' (Path Rel File -> FilePath
forall b t. Path b t -> FilePath
toFilePath (Path Rel File -> FilePath) -> Path Rel File -> FilePath
forall a b. (a -> b) -> a -> b
$ Path Rel Dir
inputDir Path Rel Dir -> Path Rel File -> Path Rel File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
f)
    Either Text MMark -> Action (Either Text MMark)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text MMark -> Action (Either Text MMark))
-> Either Text MMark -> Action (Either Text MMark)
forall a b. (a -> b) -> a -> b
$ [Extension] -> FilePath -> Text -> Either Text MMark
parsePureWith [Extension]
exts (Path Rel File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Rel File
f) Text
s

-- | Get the first image in the document if one exists
getFirstImg :: MMark -> Maybe URI
getFirstImg :: MMark -> Maybe URI
getFirstImg = (MMark -> Fold Bni (Maybe URI) -> Maybe URI)
-> Fold Bni (Maybe URI) -> MMark -> Maybe URI
forall a b c. (a -> b -> c) -> b -> a -> c
flip MMark -> Fold Bni (Maybe URI) -> Maybe URI
forall a. MMark -> Fold Bni a -> a
MMark.runScanner (Fold Bni (Maybe URI) -> MMark -> Maybe URI)
-> Fold Bni (Maybe URI) -> MMark -> Maybe URI
forall a b. (a -> b) -> a -> b
$ (Maybe URI -> Bni -> Maybe URI)
-> Maybe URI -> (Maybe URI -> Maybe URI) -> Fold Bni (Maybe URI)
forall a b x. (x -> a -> x) -> x -> (x -> b) -> Fold a b
Fold Maybe URI -> Bni -> Maybe URI
f Maybe URI
forall a. Maybe a
Nothing Maybe URI -> Maybe URI
forall a. a -> a
id
  where
    f :: Maybe URI -> Bni -> Maybe URI
f acc :: Maybe URI
acc blk :: Bni
blk = Maybe URI
acc Maybe URI -> Maybe URI -> Maybe URI
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [URI] -> Maybe URI
forall a. [a] -> Maybe a
listToMaybe ((Inline -> Maybe URI) -> [Inline] -> [URI]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Inline -> Maybe URI
getImgUri (Bni -> [Inline]
inlinesContainingImg Bni
blk))
    getImgUri :: Inline -> Maybe URI
getImgUri = \case
      Ext.Image _ uri :: URI
uri _ -> URI -> Maybe URI
forall a. a -> Maybe a
Just URI
uri
      _ -> Maybe URI
forall a. Maybe a
Nothing
    inlinesContainingImg :: Ext.Bni -> [Ext.Inline]
    inlinesContainingImg :: Bni -> [Inline]
inlinesContainingImg = \case
      Ext.Naked xs :: NonEmpty Inline
xs -> NonEmpty Inline -> [Inline]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Inline
xs
      Ext.Paragraph xs :: NonEmpty Inline
xs -> NonEmpty Inline -> [Inline]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Inline
xs
      _ -> []

-- | Get the first paragraph text of a MMark document.
--
-- Useful to determine "preview" of your notes.
getFirstParagraphText :: MMark -> Maybe Text
getFirstParagraphText :: MMark -> Maybe Text
getFirstParagraphText =
  (MMark -> Fold Bni (Maybe Text) -> Maybe Text)
-> Fold Bni (Maybe Text) -> MMark -> Maybe Text
forall a b c. (a -> b -> c) -> b -> a -> c
flip MMark -> Fold Bni (Maybe Text) -> Maybe Text
forall a. MMark -> Fold Bni a -> a
MMark.runScanner (Fold Bni (Maybe Text) -> MMark -> Maybe Text)
-> Fold Bni (Maybe Text) -> MMark -> Maybe Text
forall a b. (a -> b) -> a -> b
$ (Maybe Text -> Bni -> Maybe Text)
-> Maybe Text
-> (Maybe Text -> Maybe Text)
-> Fold Bni (Maybe Text)
forall a b x. (x -> a -> x) -> x -> (x -> b) -> Fold a b
Fold Maybe Text -> Bni -> Maybe Text
f Maybe Text
forall a. Maybe a
Nothing Maybe Text -> Maybe Text
forall a. a -> a
id
  where
    f :: Maybe Text -> Bni -> Maybe Text
f acc :: Maybe Text
acc blk :: Bni
blk = Maybe Text
acc Maybe Text -> Maybe Text -> Maybe Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (NonEmpty Inline -> Text
Ext.asPlainText (NonEmpty Inline -> Text) -> Maybe (NonEmpty Inline) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bni -> Maybe (NonEmpty Inline)
forall a. Block a -> Maybe a
getPara Bni
blk)
    getPara :: Block a -> Maybe a
getPara = \case
      Ext.Paragraph xs :: a
xs -> a -> Maybe a
forall a. a -> Maybe a
Just a
xs
      _ -> Maybe a
forall a. Maybe a
Nothing

defaultExts :: [MMark.Extension]
defaultExts :: [Extension]
defaultExts =
  [ Extension
Ext.fontAwesome,
    Extension
Ext.footnotes,
    Extension
Ext.kbd,
    Extension
Ext.linkTarget,
    Maybe Char -> Extension
Ext.mathJax (Char -> Maybe Char
forall a. a -> Maybe a
Just '$'),
    Extension
Ext.punctuationPrettifier,
    -- For list of parsers supported, see:
    -- https://github.com/jgm/skylighting/tree/master/skylighting-core/xml
    Extension
Ext.skylighting
  ]

useTocExt :: MMark -> MMark
useTocExt :: MMark -> MMark
useTocExt doc :: MMark
doc = Extension -> MMark -> MMark
MMark.useExtension (Text -> Toc -> Extension
Ext.toc "toc" Toc
toc) MMark
doc
  where
    toc :: Toc
toc = MMark -> Fold Bni Toc -> Toc
forall a. MMark -> Fold Bni a -> a
MMark.runScanner MMark
doc (Fold Bni Toc -> Toc) -> Fold Bni Toc -> Toc
forall a b. (a -> b) -> a -> b
$ (Int -> Bool) -> Fold Bni Toc
Ext.tocScanner (\x :: Int
x -> Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 1 Bool -> Bool -> Bool
&& Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 5)