{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE UndecidableInstances #-}

module Ema.Route.Lib.Extra.PandocRoute (
  -- * Route
  PandocRoute (..),
  mkPandocRoute,

  -- * Model and Arg
  Model (..),
  Arg (..),

  -- * Looking up Pandoc values in model
  lookupPandocRoute,

  -- * Rendering
  PandocHtml (..),
  PandocError (..),
) where

import Control.Exception (throw, throwIO)
import Control.Monad.Logger (
  MonadLogger,
  MonadLoggerIO,
  logInfoNS,
 )
import Data.Default (Default (..))
import Data.List qualified as List
import Data.Map.Strict qualified as Map
import Data.SOP (I (I), NP (..))
import Data.Set qualified as Set
import Ema
import Ema.CLI qualified
import Ema.Route.Generic.TH
import Ema.Route.Lib.Extra.SlugRoute
import Generics.SOP qualified as SOP
import System.FilePath ((</>))
import System.UnionMount qualified as UnionMount
import Text.Pandoc (Pandoc, ReaderOptions, runIO)
import Text.Pandoc qualified as Pandoc
import Text.Pandoc.Sources (ToSources)
import UnliftIO (MonadUnliftIO)

-- | Represents the relative path to a file that pandoc can parse.
newtype PandocRoute = PandocRoute {PandocRoute -> SlugRoute Pandoc
unPandocRoute :: SlugRoute Pandoc}
  deriving stock (PandocRoute -> PandocRoute -> Bool
(PandocRoute -> PandocRoute -> Bool)
-> (PandocRoute -> PandocRoute -> Bool) -> Eq PandocRoute
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PandocRoute -> PandocRoute -> Bool
$c/= :: PandocRoute -> PandocRoute -> Bool
== :: PandocRoute -> PandocRoute -> Bool
$c== :: PandocRoute -> PandocRoute -> Bool
Eq, Eq PandocRoute
Eq PandocRoute
-> (PandocRoute -> PandocRoute -> Ordering)
-> (PandocRoute -> PandocRoute -> Bool)
-> (PandocRoute -> PandocRoute -> Bool)
-> (PandocRoute -> PandocRoute -> Bool)
-> (PandocRoute -> PandocRoute -> Bool)
-> (PandocRoute -> PandocRoute -> PandocRoute)
-> (PandocRoute -> PandocRoute -> PandocRoute)
-> Ord PandocRoute
PandocRoute -> PandocRoute -> Bool
PandocRoute -> PandocRoute -> Ordering
PandocRoute -> PandocRoute -> PandocRoute
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PandocRoute -> PandocRoute -> PandocRoute
$cmin :: PandocRoute -> PandocRoute -> PandocRoute
max :: PandocRoute -> PandocRoute -> PandocRoute
$cmax :: PandocRoute -> PandocRoute -> PandocRoute
>= :: PandocRoute -> PandocRoute -> Bool
$c>= :: PandocRoute -> PandocRoute -> Bool
> :: PandocRoute -> PandocRoute -> Bool
$c> :: PandocRoute -> PandocRoute -> Bool
<= :: PandocRoute -> PandocRoute -> Bool
$c<= :: PandocRoute -> PandocRoute -> Bool
< :: PandocRoute -> PandocRoute -> Bool
$c< :: PandocRoute -> PandocRoute -> Bool
compare :: PandocRoute -> PandocRoute -> Ordering
$ccompare :: PandocRoute -> PandocRoute -> Ordering
$cp1Ord :: Eq PandocRoute
Ord, Int -> PandocRoute -> ShowS
[PandocRoute] -> ShowS
PandocRoute -> String
(Int -> PandocRoute -> ShowS)
-> (PandocRoute -> String)
-> ([PandocRoute] -> ShowS)
-> Show PandocRoute
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PandocRoute] -> ShowS
$cshowList :: [PandocRoute] -> ShowS
show :: PandocRoute -> String
$cshow :: PandocRoute -> String
showsPrec :: Int -> PandocRoute -> ShowS
$cshowsPrec :: Int -> PandocRoute -> ShowS
Show, (forall x. PandocRoute -> Rep PandocRoute x)
-> (forall x. Rep PandocRoute x -> PandocRoute)
-> Generic PandocRoute
forall x. Rep PandocRoute x -> PandocRoute
forall x. PandocRoute -> Rep PandocRoute x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PandocRoute x -> PandocRoute
$cfrom :: forall x. PandocRoute -> Rep PandocRoute x
Generic)
  deriving anyclass (All @[Type] (SListI @Type) (Code PandocRoute)
All @[Type] (SListI @Type) (Code PandocRoute)
-> (PandocRoute -> Rep PandocRoute)
-> (Rep PandocRoute -> PandocRoute)
-> Generic PandocRoute
Rep PandocRoute -> PandocRoute
PandocRoute -> Rep PandocRoute
forall a.
All @[Type] (SListI @Type) (Code a)
-> (a -> Rep a) -> (Rep a -> a) -> Generic a
to :: Rep PandocRoute -> PandocRoute
$cto :: Rep PandocRoute -> PandocRoute
from :: PandocRoute -> Rep PandocRoute
$cfrom :: PandocRoute -> Rep PandocRoute
$cp1Generic :: All @[Type] (SListI @Type) (Code PandocRoute)
SOP.Generic, Generic PandocRoute
Generic PandocRoute
-> (forall (proxy :: Type -> Type).
    proxy PandocRoute -> DatatypeInfo (Code PandocRoute))
-> HasDatatypeInfo PandocRoute
forall a.
Generic a
-> (forall (proxy :: Type -> Type).
    proxy a -> DatatypeInfo (Code a))
-> HasDatatypeInfo a
forall (proxy :: Type -> Type).
proxy PandocRoute -> DatatypeInfo (Code PandocRoute)
datatypeInfo :: proxy PandocRoute -> DatatypeInfo (Code PandocRoute)
$cdatatypeInfo :: forall (proxy :: Type -> Type).
proxy PandocRoute -> DatatypeInfo (Code PandocRoute)
$cp1HasDatatypeInfo :: Generic PandocRoute
SOP.HasDatatypeInfo)
  deriving
    (HasSubRoutes @Type PandocRoute
forall {k} (r :: k). HasSubRoutes @k r
HasSubRoutes, RouteModel PandocRoute -> [PandocRoute]
RouteModel PandocRoute -> Prism_ String PandocRoute
(RouteModel PandocRoute -> Prism_ String PandocRoute)
-> (RouteModel PandocRoute -> [PandocRoute]) -> IsRoute PandocRoute
forall r.
(RouteModel r -> Prism_ String r)
-> (RouteModel r -> [r]) -> IsRoute r
routeUniverse :: RouteModel PandocRoute -> [PandocRoute]
$crouteUniverse :: RouteModel PandocRoute -> [PandocRoute]
routePrism :: RouteModel PandocRoute -> Prism_ String PandocRoute
$croutePrism :: RouteModel PandocRoute -> Prism_ String PandocRoute
IsRoute)
    via ( GenericRoute
            PandocRoute
            '[ WithModel Model
             , WithSubRoutes
                '[ SlugRoute Pandoc
                 ]
             ]
        )

instance HasSubModels PandocRoute where
  subModels :: RouteModel PandocRoute
-> NP @Type I (MultiModel (SubRoutes @Type PandocRoute))
subModels RouteModel PandocRoute
m = Map (SlugRoute Pandoc) Pandoc -> I (Map (SlugRoute Pandoc) Pandoc)
forall a. a -> I a
I ((PandocRoute -> SlugRoute Pandoc)
-> Map PandocRoute Pandoc -> Map (SlugRoute Pandoc) Pandoc
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys PandocRoute -> SlugRoute Pandoc
unPandocRoute (Map PandocRoute Pandoc -> Map (SlugRoute Pandoc) Pandoc)
-> Map PandocRoute Pandoc -> Map (SlugRoute Pandoc) Pandoc
forall a b. (a -> b) -> a -> b
$ Model -> Map PandocRoute Pandoc
modelPandocs RouteModel PandocRoute
Model
m) I (Map (SlugRoute Pandoc) Pandoc)
-> NP @Type I ('[] @Type)
-> NP
     @Type I ((':) @Type (Map (SlugRoute Pandoc) Pandoc) ('[] @Type))
forall {k} (a :: k -> Type) (x :: k) (xs :: [k]).
a x -> NP @k a xs -> NP @k a ((':) @k x xs)
:* NP @Type I ('[] @Type)
forall {k} (a :: k -> Type). NP @k a ('[] @k)
Nil

instance IsString PandocRoute where
  fromString :: String -> PandocRoute
fromString String
fp = PandocRoute
-> ((String, PandocRoute) -> PandocRoute)
-> Maybe (String, PandocRoute)
-> PandocRoute
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> PandocRoute
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> PandocRoute) -> Text -> PandocRoute
forall a b. (a -> b) -> a -> b
$ Text
"Bad path: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. ToText a => a -> Text
toText String
fp) (String, PandocRoute) -> PandocRoute
forall a b. (a, b) -> b
snd (Maybe (String, PandocRoute) -> PandocRoute)
-> Maybe (String, PandocRoute) -> PandocRoute
forall a b. (a -> b) -> a -> b
$ String -> Maybe (String, PandocRoute)
mkPandocRoute String
fp

mkPandocRoute :: FilePath -> Maybe (String, PandocRoute)
mkPandocRoute :: String -> Maybe (String, PandocRoute)
mkPandocRoute String
fp = do
  (String
ext, SlugRoute Pandoc
r) <- String -> Maybe (String, SlugRoute Pandoc)
forall a. String -> Maybe (String, SlugRoute a)
mkSlugRoute String
fp
  (String, PandocRoute) -> Maybe (String, PandocRoute)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (String
ext, SlugRoute Pandoc -> PandocRoute
PandocRoute SlugRoute Pandoc
r)

data Model = Model
  { Model -> Arg
modelArg :: Arg
  , Model -> Map PandocRoute Pandoc
modelPandocs :: Map PandocRoute Pandoc
  }
  deriving stock ((forall x. Model -> Rep Model x)
-> (forall x. Rep Model x -> Model) -> Generic Model
forall x. Rep Model x -> Model
forall x. Model -> Rep Model x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Model x -> Model
$cfrom :: forall x. Model -> Rep Model x
Generic)

lookupPandocRoute :: Model -> PandocRoute -> Maybe (Pandoc, Pandoc -> PandocHtml)
lookupPandocRoute :: Model -> PandocRoute -> Maybe (Pandoc, Pandoc -> PandocHtml)
lookupPandocRoute Model
model PandocRoute
r = do
  Pandoc
pandoc <- PandocRoute -> Map PandocRoute Pandoc -> Maybe Pandoc
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PandocRoute
r (Map PandocRoute Pandoc -> Maybe Pandoc)
-> Map PandocRoute Pandoc -> Maybe Pandoc
forall a b. (a -> b) -> a -> b
$ Model -> Map PandocRoute Pandoc
modelPandocs Model
model
  let render :: Pandoc -> PandocHtml
render = Text -> PandocHtml
PandocHtml (Text -> PandocHtml) -> (Pandoc -> Text) -> Pandoc -> PandocHtml
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => WriterOptions -> Pandoc -> Text
WriterOptions -> Pandoc -> Text
renderHtml (Arg -> WriterOptions
argWriterOpts (Arg -> WriterOptions) -> Arg -> WriterOptions
forall a b. (a -> b) -> a -> b
$ Model -> Arg
modelArg Model
model)
  (Pandoc, Pandoc -> PandocHtml)
-> Maybe (Pandoc, Pandoc -> PandocHtml)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Pandoc
pandoc, Pandoc -> PandocHtml
render)
  where
    renderHtml :: HasCallStack => Pandoc.WriterOptions -> Pandoc -> Text
    renderHtml :: WriterOptions -> Pandoc -> Text
renderHtml WriterOptions
writerSettings Pandoc
pandoc =
      (PandocError -> Text)
-> (Text -> Text) -> Either PandocError Text -> Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (PandocError -> Text
forall a e. Exception e => e -> a
throw (PandocError -> Text)
-> (PandocError -> PandocError) -> PandocError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> PandocError
PandocError_RenderError (Text -> PandocError)
-> (PandocError -> Text) -> PandocError -> PandocError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PandocError -> Text
forall b a. (Show a, IsString b) => a -> b
show) Text -> Text
forall a. a -> a
id (Either PandocError Text -> Text)
-> Either PandocError Text -> Text
forall a b. (a -> b) -> a -> b
$
        PandocPure Text -> Either PandocError Text
forall a. PandocPure a -> Either PandocError a
Pandoc.runPure (PandocPure Text -> Either PandocError Text)
-> PandocPure Text -> Either PandocError Text
forall a b. (a -> b) -> a -> b
$ WriterOptions -> Pandoc -> PandocPure Text
forall (m :: Type -> Type).
PandocMonad m =>
WriterOptions -> Pandoc -> m Text
Pandoc.writeHtml5String WriterOptions
writerSettings Pandoc
pandoc

data Arg = Arg
  { -- Base directory
    Arg -> String
argBaseDir :: FilePath
  , -- Pandoc reader formats supported, as file extension; eg: '.md'
    Arg -> Set String
argFormats :: Set String
  , Arg -> ReaderOptions
argReaderOpts :: Pandoc.ReaderOptions
  , Arg -> WriterOptions
argWriterOpts :: Pandoc.WriterOptions
  }
  deriving stock ((forall x. Arg -> Rep Arg x)
-> (forall x. Rep Arg x -> Arg) -> Generic Arg
forall x. Rep Arg x -> Arg
forall x. Arg -> Rep Arg x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Arg x -> Arg
$cfrom :: forall x. Arg -> Rep Arg x
Generic)

instance Default Arg where
  def :: Arg
def = String -> Set String -> ReaderOptions -> WriterOptions -> Arg
Arg String
"." Set String
formats ReaderOptions
defaultReaderOpts WriterOptions
defaultWriterOpts
    where
      formats :: Set String
formats = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList [String]
knownPandocFormats
      defaultReaderOpts :: ReaderOptions
defaultReaderOpts = ReaderOptions
forall a. Default a => a
def {readerExtensions :: Extensions
Pandoc.readerExtensions = Extensions
exts}
      defaultWriterOpts :: WriterOptions
defaultWriterOpts = WriterOptions
forall a. Default a => a
def {writerExtensions :: Extensions
Pandoc.writerExtensions = Extensions
exts}
      exts :: Pandoc.Extensions
      exts :: Extensions
exts =
        -- Sensible defaults for Markdown and others
        Extensions
Pandoc.pandocExtensions Extensions -> Extensions -> Extensions
forall a. Semigroup a => a -> a -> a
<> [Extension] -> Extensions
Pandoc.extensionsFromList [Extension
Pandoc.Ext_attributes]

instance EmaSite PandocRoute where
  type SiteArg PandocRoute = Arg

  -- Returns the `Pandoc` AST along with the function that renders it to HTML.
  type SiteOutput PandocRoute = (Pandoc, Pandoc -> PandocHtml)

  siteInput :: Some @Type Action
-> SiteArg PandocRoute -> m (Dynamic m (RouteModel PandocRoute))
siteInput Some @Type Action
_ SiteArg PandocRoute
arg = do
    (Map PandocRoute Pandoc -> Model)
-> Dynamic m (Map PandocRoute Pandoc) -> Dynamic m Model
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Arg -> Map PandocRoute Pandoc -> Model
Model SiteArg PandocRoute
Arg
arg) (Dynamic m (Map PandocRoute Pandoc) -> Dynamic m Model)
-> m (Dynamic m (Map PandocRoute Pandoc)) -> m (Dynamic m Model)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> Set String
-> ReaderOptions
-> m (Dynamic m (Map PandocRoute Pandoc))
forall (m :: Type -> Type).
(MonadIO m, MonadUnliftIO m, MonadLogger m, MonadLoggerIO m) =>
String
-> Set String
-> ReaderOptions
-> m (Dynamic m (Map PandocRoute Pandoc))
pandocFilesDyn (Arg -> String
argBaseDir SiteArg PandocRoute
Arg
arg) (Arg -> Set String
argFormats SiteArg PandocRoute
Arg
arg) (Arg -> ReaderOptions
argReaderOpts SiteArg PandocRoute
Arg
arg)
  siteOutput :: Prism' String PandocRoute
-> RouteModel PandocRoute
-> PandocRoute
-> m (SiteOutput PandocRoute)
siteOutput Prism' String PandocRoute
_rp RouteModel PandocRoute
model PandocRoute
r = do
    m (Pandoc, Pandoc -> PandocHtml)
-> ((Pandoc, Pandoc -> PandocHtml)
    -> m (Pandoc, Pandoc -> PandocHtml))
-> Maybe (Pandoc, Pandoc -> PandocHtml)
-> m (Pandoc, Pandoc -> PandocHtml)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO (Pandoc, Pandoc -> PandocHtml)
-> m (Pandoc, Pandoc -> PandocHtml)
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (Pandoc, Pandoc -> PandocHtml)
 -> m (Pandoc, Pandoc -> PandocHtml))
-> IO (Pandoc, Pandoc -> PandocHtml)
-> m (Pandoc, Pandoc -> PandocHtml)
forall a b. (a -> b) -> a -> b
$ PandocError -> IO (Pandoc, Pandoc -> PandocHtml)
forall e a. Exception e => e -> IO a
throwIO (PandocError -> IO (Pandoc, Pandoc -> PandocHtml))
-> PandocError -> IO (Pandoc, Pandoc -> PandocHtml)
forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocError_Missing (Text -> PandocError) -> Text -> PandocError
forall a b. (a -> b) -> a -> b
$ PandocRoute -> Text
forall b a. (Show a, IsString b) => a -> b
show PandocRoute
r) (Pandoc, Pandoc -> PandocHtml) -> m (Pandoc, Pandoc -> PandocHtml)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe (Pandoc, Pandoc -> PandocHtml)
 -> m (Pandoc, Pandoc -> PandocHtml))
-> Maybe (Pandoc, Pandoc -> PandocHtml)
-> m (Pandoc, Pandoc -> PandocHtml)
forall a b. (a -> b) -> a -> b
$ Model -> PandocRoute -> Maybe (Pandoc, Pandoc -> PandocHtml)
lookupPandocRoute RouteModel PandocRoute
Model
model PandocRoute
r

pandocFilesDyn ::
  forall m.
  (MonadIO m, MonadUnliftIO m, MonadLogger m, MonadLoggerIO m) =>
  FilePath ->
  Set String ->
  ReaderOptions ->
  m (Dynamic m (Map PandocRoute Pandoc))
pandocFilesDyn :: String
-> Set String
-> ReaderOptions
-> m (Dynamic m (Map PandocRoute Pandoc))
pandocFilesDyn String
baseDir Set String
formats ReaderOptions
readerOpts = do
  let pats :: [((), String)]
pats =
        Set String -> [String]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList Set String
formats [String] -> (String -> ((), String)) -> [((), String)]
forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> \String
ext ->
          ((), String
"**/*" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
ext)
      ignorePats :: [String]
ignorePats = [String
".*"]
      model0 :: Map PandocRoute Pandoc
model0 = Map PandocRoute Pandoc
forall a. Monoid a => a
mempty
  (Map PandocRoute Pandoc, (Map PandocRoute Pandoc -> m ()) -> m ())
-> Dynamic m (Map PandocRoute Pandoc)
forall (m :: Type -> Type) a.
(a, (a -> m ()) -> m ()) -> Dynamic m a
Dynamic ((Map PandocRoute Pandoc, (Map PandocRoute Pandoc -> m ()) -> m ())
 -> Dynamic m (Map PandocRoute Pandoc))
-> m (Map PandocRoute Pandoc,
      (Map PandocRoute Pandoc -> m ()) -> m ())
-> m (Dynamic m (Map PandocRoute Pandoc))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> [((), String)]
-> [String]
-> Map PandocRoute Pandoc
-> (()
    -> String
    -> FileAction ()
    -> m (Map PandocRoute Pandoc -> Map PandocRoute Pandoc))
-> m (Map PandocRoute Pandoc,
      (Map PandocRoute Pandoc -> m ()) -> m ())
forall model (m :: Type -> Type) b.
(MonadIO m, MonadUnliftIO m, MonadLogger m, Show b, Ord b) =>
String
-> [(b, String)]
-> [String]
-> model
-> (b -> String -> FileAction () -> m (model -> model))
-> m (model, (model -> m ()) -> m ())
UnionMount.mount String
baseDir [((), String)]
pats [String]
ignorePats Map PandocRoute Pandoc
model0 ((String
 -> FileAction ()
 -> m (Map PandocRoute Pandoc -> Map PandocRoute Pandoc))
-> ()
-> String
-> FileAction ()
-> m (Map PandocRoute Pandoc -> Map PandocRoute Pandoc)
forall a b. a -> b -> a
const String
-> FileAction ()
-> m (Map PandocRoute Pandoc -> Map PandocRoute Pandoc)
(MonadIO m, MonadLogger m, MonadLoggerIO m) =>
String
-> FileAction ()
-> m (Map PandocRoute Pandoc -> Map PandocRoute Pandoc)
handleUpdate)
  where
    -- Take the file that got changed and update our in-memory `Model` accordingly.
    handleUpdate ::
      (MonadIO m, MonadLogger m, MonadLoggerIO m) =>
      FilePath ->
      UnionMount.FileAction () ->
      m (Map PandocRoute Pandoc -> Map PandocRoute Pandoc)
    handleUpdate :: String
-> FileAction ()
-> m (Map PandocRoute Pandoc -> Map PandocRoute Pandoc)
handleUpdate String
fp = \case
      UnionMount.Refresh RefreshAction
_ ()
_ -> do
        Maybe (PandocRoute, Pandoc)
mData <- String -> m (Maybe (PandocRoute, Pandoc))
(MonadIO m, MonadLogger m, MonadLoggerIO m) =>
String -> m (Maybe (PandocRoute, Pandoc))
readSource String
fp
        (Map PandocRoute Pandoc -> Map PandocRoute Pandoc)
-> m (Map PandocRoute Pandoc -> Map PandocRoute Pandoc)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((Map PandocRoute Pandoc -> Map PandocRoute Pandoc)
 -> m (Map PandocRoute Pandoc -> Map PandocRoute Pandoc))
-> (Map PandocRoute Pandoc -> Map PandocRoute Pandoc)
-> m (Map PandocRoute Pandoc -> Map PandocRoute Pandoc)
forall a b. (a -> b) -> a -> b
$ (Map PandocRoute Pandoc -> Map PandocRoute Pandoc)
-> ((PandocRoute, Pandoc)
    -> Map PandocRoute Pandoc -> Map PandocRoute Pandoc)
-> Maybe (PandocRoute, Pandoc)
-> Map PandocRoute Pandoc
-> Map PandocRoute Pandoc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map PandocRoute Pandoc -> Map PandocRoute Pandoc
forall a. a -> a
id ((PandocRoute
 -> Pandoc -> Map PandocRoute Pandoc -> Map PandocRoute Pandoc)
-> (PandocRoute, Pandoc)
-> Map PandocRoute Pandoc
-> Map PandocRoute Pandoc
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry PandocRoute
-> Pandoc -> Map PandocRoute Pandoc -> Map PandocRoute Pandoc
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert) Maybe (PandocRoute, Pandoc)
mData
      FileAction ()
UnionMount.Delete ->
        (Map PandocRoute Pandoc -> Map PandocRoute Pandoc)
-> m (Map PandocRoute Pandoc -> Map PandocRoute Pandoc)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((Map PandocRoute Pandoc -> Map PandocRoute Pandoc)
 -> m (Map PandocRoute Pandoc -> Map PandocRoute Pandoc))
-> (Map PandocRoute Pandoc -> Map PandocRoute Pandoc)
-> m (Map PandocRoute Pandoc -> Map PandocRoute Pandoc)
forall a b. (a -> b) -> a -> b
$ (Map PandocRoute Pandoc -> Map PandocRoute Pandoc)
-> ((String, PandocRoute)
    -> Map PandocRoute Pandoc -> Map PandocRoute Pandoc)
-> Maybe (String, PandocRoute)
-> Map PandocRoute Pandoc
-> Map PandocRoute Pandoc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map PandocRoute Pandoc -> Map PandocRoute Pandoc
forall a. a -> a
id (PandocRoute -> Map PandocRoute Pandoc -> Map PandocRoute Pandoc
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (PandocRoute -> Map PandocRoute Pandoc -> Map PandocRoute Pandoc)
-> ((String, PandocRoute) -> PandocRoute)
-> (String, PandocRoute)
-> Map PandocRoute Pandoc
-> Map PandocRoute Pandoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, PandocRoute) -> PandocRoute
forall a b. (a, b) -> b
snd) (Maybe (String, PandocRoute)
 -> Map PandocRoute Pandoc -> Map PandocRoute Pandoc)
-> Maybe (String, PandocRoute)
-> Map PandocRoute Pandoc
-> Map PandocRoute Pandoc
forall a b. (a -> b) -> a -> b
$ String -> Maybe (String, PandocRoute)
mkPandocRoute String
fp
    readSource :: (MonadIO m, MonadLogger m, MonadLoggerIO m) => FilePath -> m (Maybe (PandocRoute, Pandoc))
    readSource :: String -> m (Maybe (PandocRoute, Pandoc))
readSource String
fp = MaybeT m (PandocRoute, Pandoc) -> m (Maybe (PandocRoute, Pandoc))
forall (m :: Type -> Type) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT m (PandocRoute, Pandoc) -> m (Maybe (PandocRoute, Pandoc)))
-> MaybeT m (PandocRoute, Pandoc)
-> m (Maybe (PandocRoute, Pandoc))
forall a b. (a -> b) -> a -> b
$ do
      (String
ext, PandocRoute
r :: PandocRoute) <- Maybe (String, PandocRoute) -> MaybeT m (String, PandocRoute)
forall (m :: Type -> Type) a.
Applicative m =>
Maybe a -> MaybeT m a
hoistMaybe (String -> Maybe (String, PandocRoute)
mkPandocRoute String
fp)
      Bool -> MaybeT m ()
forall (f :: Type -> Type). Alternative f => Bool -> f ()
guard (Bool -> MaybeT m ()) -> Bool -> MaybeT m ()
forall a b. (a -> b) -> a -> b
$ String
ext String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
formats
      Text -> MaybeT m ()
forall (m :: Type -> Type). MonadLogger m => Text -> m ()
log (Text -> MaybeT m ()) -> Text -> MaybeT m ()
forall a b. (a -> b) -> a -> b
$ Text
"Reading " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. ToText a => a -> Text
toText String
fp
      Text
s :: Text <- (ByteString -> Text) -> MaybeT m ByteString -> MaybeT m Text
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (MaybeT m ByteString -> MaybeT m Text)
-> MaybeT m ByteString -> MaybeT m Text
forall a b. (a -> b) -> a -> b
$ String -> MaybeT m ByteString
forall (m :: Type -> Type). MonadIO m => String -> m ByteString
readFileBS (String -> MaybeT m ByteString) -> String -> MaybeT m ByteString
forall a b. (a -> b) -> a -> b
$ String
baseDir String -> ShowS
</> String
fp
      IO (Either PandocError Pandoc)
-> MaybeT m (Either PandocError Pandoc)
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (PandocIO Pandoc -> IO (Either PandocError Pandoc)
forall a. PandocIO a -> IO (Either PandocError a)
runIO (PandocIO Pandoc -> IO (Either PandocError Pandoc))
-> PandocIO Pandoc -> IO (Either PandocError Pandoc)
forall a b. (a -> b) -> a -> b
$ ReaderOptions -> String -> Text -> PandocIO Pandoc
forall (m :: Type -> Type) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> String -> a -> m Pandoc
readPandocSource ReaderOptions
readerOpts String
ext Text
s) MaybeT m (Either PandocError Pandoc)
-> (Either PandocError Pandoc -> MaybeT m (PandocRoute, Pandoc))
-> MaybeT m (PandocRoute, Pandoc)
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left PandocError
err -> Text -> Text -> MaybeT m (PandocRoute, Pandoc)
forall (m :: Type -> Type) a.
(MonadLoggerIO m, MonadFail m) =>
Text -> Text -> m a
Ema.CLI.crash Text
"PandocRoute" (Text -> MaybeT m (PandocRoute, Pandoc))
-> Text -> MaybeT m (PandocRoute, Pandoc)
forall a b. (a -> b) -> a -> b
$ PandocError -> Text
forall b a. (Show a, IsString b) => a -> b
show PandocError
err
        Right Pandoc
doc -> do
          (PandocRoute, Pandoc) -> MaybeT m (PandocRoute, Pandoc)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (PandocRoute
r, Pandoc
doc)

log :: MonadLogger m => Text -> m ()
log :: Text -> m ()
log = Text -> Text -> m ()
forall (m :: Type -> Type). MonadLogger m => Text -> Text -> m ()
logInfoNS Text
"PandocRoute"

data PandocError
  = PandocError_Missing Text
  | PandocError_RenderError Text
  deriving stock (PandocError -> PandocError -> Bool
(PandocError -> PandocError -> Bool)
-> (PandocError -> PandocError -> Bool) -> Eq PandocError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PandocError -> PandocError -> Bool
$c/= :: PandocError -> PandocError -> Bool
== :: PandocError -> PandocError -> Bool
$c== :: PandocError -> PandocError -> Bool
Eq, Int -> PandocError -> ShowS
[PandocError] -> ShowS
PandocError -> String
(Int -> PandocError -> ShowS)
-> (PandocError -> String)
-> ([PandocError] -> ShowS)
-> Show PandocError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PandocError] -> ShowS
$cshowList :: [PandocError] -> ShowS
show :: PandocError -> String
$cshow :: PandocError -> String
showsPrec :: Int -> PandocError -> ShowS
$cshowsPrec :: Int -> PandocError -> ShowS
Show)
  deriving anyclass (Show PandocError
Typeable @Type PandocError
Typeable @Type PandocError
-> Show PandocError
-> (PandocError -> SomeException)
-> (SomeException -> Maybe PandocError)
-> (PandocError -> String)
-> Exception PandocError
SomeException -> Maybe PandocError
PandocError -> String
PandocError -> SomeException
forall e.
Typeable @Type e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> Exception e
displayException :: PandocError -> String
$cdisplayException :: PandocError -> String
fromException :: SomeException -> Maybe PandocError
$cfromException :: SomeException -> Maybe PandocError
toException :: PandocError -> SomeException
$ctoException :: PandocError -> SomeException
$cp2Exception :: Show PandocError
$cp1Exception :: Typeable @Type PandocError
Exception)

newtype PandocHtml = PandocHtml {PandocHtml -> Text
unPandocHtml :: Text}
  deriving stock (PandocHtml -> PandocHtml -> Bool
(PandocHtml -> PandocHtml -> Bool)
-> (PandocHtml -> PandocHtml -> Bool) -> Eq PandocHtml
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PandocHtml -> PandocHtml -> Bool
$c/= :: PandocHtml -> PandocHtml -> Bool
== :: PandocHtml -> PandocHtml -> Bool
$c== :: PandocHtml -> PandocHtml -> Bool
Eq, (forall x. PandocHtml -> Rep PandocHtml x)
-> (forall x. Rep PandocHtml x -> PandocHtml) -> Generic PandocHtml
forall x. Rep PandocHtml x -> PandocHtml
forall x. PandocHtml -> Rep PandocHtml x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PandocHtml x -> PandocHtml
$cfrom :: forall x. PandocHtml -> Rep PandocHtml x
Generic)

-- Pandoc reader abstraction
--
-- TODO: Can we refactor this using,
-- https://github.com/jgm/pandoc/blob/16f0316fbaa4d667ba40772969ab8e28fea6a493/src/Text/Pandoc/App/FormatHeuristics.hs#L36

knownPandocFormats :: [String]
knownPandocFormats :: [String]
knownPandocFormats = [String
".md", String
".org"]

formatFromExt :: String -> Text
formatFromExt :: String -> Text
formatFromExt = \case
  String
".md" -> Text
"markdown"
  String
".org" -> Text
"org"
  String
ext -> UnsupportedPandocFormat -> Text
forall a e. Exception e => e -> a
throw (UnsupportedPandocFormat -> Text)
-> UnsupportedPandocFormat -> Text
forall a b. (a -> b) -> a -> b
$ String -> UnsupportedPandocFormat
UnsupportedPandocFormat String
ext

readPandocSource ::
  forall m a.
  (Pandoc.PandocMonad m, ToSources a) =>
  ReaderOptions ->
  [Char] ->
  a ->
  m Pandoc
readPandocSource :: ReaderOptions -> String -> a -> m Pandoc
readPandocSource ReaderOptions
readerOpts String
ext a
s =
  case Text -> [(Text, Reader m)] -> Maybe (Reader m)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
List.lookup (String -> Text
formatFromExt String
ext) [(Text, Reader m)]
forall (m :: Type -> Type). PandocMonad m => [(Text, Reader m)]
Pandoc.readers of
    Just (Pandoc.TextReader forall a. ToSources a => ReaderOptions -> a -> m Pandoc
f) -> ReaderOptions -> a -> m Pandoc
forall a. ToSources a => ReaderOptions -> a -> m Pandoc
f ReaderOptions
readerOpts a
s
    Maybe (Reader m)
_ -> UnsupportedPandocFormat -> m Pandoc
forall a e. Exception e => e -> a
throw (UnsupportedPandocFormat -> m Pandoc)
-> UnsupportedPandocFormat -> m Pandoc
forall a b. (a -> b) -> a -> b
$ String -> UnsupportedPandocFormat
UnsupportedPandocFormat String
ext

data UnsupportedPandocFormat = UnsupportedPandocFormat String
  deriving stock (UnsupportedPandocFormat -> UnsupportedPandocFormat -> Bool
(UnsupportedPandocFormat -> UnsupportedPandocFormat -> Bool)
-> (UnsupportedPandocFormat -> UnsupportedPandocFormat -> Bool)
-> Eq UnsupportedPandocFormat
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnsupportedPandocFormat -> UnsupportedPandocFormat -> Bool
$c/= :: UnsupportedPandocFormat -> UnsupportedPandocFormat -> Bool
== :: UnsupportedPandocFormat -> UnsupportedPandocFormat -> Bool
$c== :: UnsupportedPandocFormat -> UnsupportedPandocFormat -> Bool
Eq, Int -> UnsupportedPandocFormat -> ShowS
[UnsupportedPandocFormat] -> ShowS
UnsupportedPandocFormat -> String
(Int -> UnsupportedPandocFormat -> ShowS)
-> (UnsupportedPandocFormat -> String)
-> ([UnsupportedPandocFormat] -> ShowS)
-> Show UnsupportedPandocFormat
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UnsupportedPandocFormat] -> ShowS
$cshowList :: [UnsupportedPandocFormat] -> ShowS
show :: UnsupportedPandocFormat -> String
$cshow :: UnsupportedPandocFormat -> String
showsPrec :: Int -> UnsupportedPandocFormat -> ShowS
$cshowsPrec :: Int -> UnsupportedPandocFormat -> ShowS
Show)
  deriving anyclass (Show UnsupportedPandocFormat
Typeable @Type UnsupportedPandocFormat
Typeable @Type UnsupportedPandocFormat
-> Show UnsupportedPandocFormat
-> (UnsupportedPandocFormat -> SomeException)
-> (SomeException -> Maybe UnsupportedPandocFormat)
-> (UnsupportedPandocFormat -> String)
-> Exception UnsupportedPandocFormat
SomeException -> Maybe UnsupportedPandocFormat
UnsupportedPandocFormat -> String
UnsupportedPandocFormat -> SomeException
forall e.
Typeable @Type e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> Exception e
displayException :: UnsupportedPandocFormat -> String
$cdisplayException :: UnsupportedPandocFormat -> String
fromException :: SomeException -> Maybe UnsupportedPandocFormat
$cfromException :: SomeException -> Maybe UnsupportedPandocFormat
toException :: UnsupportedPandocFormat -> SomeException
$ctoException :: UnsupportedPandocFormat -> SomeException
$cp2Exception :: Show UnsupportedPandocFormat
$cp1Exception :: Typeable @Type UnsupportedPandocFormat
Exception)