{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}

module Emanote.Source.Dynamic
  ( emanoteSiteInput,
    EmanoteConfig (..),
    emanoteCompileTailwind,
    emanoteConfigCli,
    emanoteConfigNoteFn,
    emanoteConfigPandocRenderers,
  )
where

import Control.Monad.Logger (MonadLogger, MonadLoggerIO)
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Some (Some)
import Data.UUID.V4 qualified as UUID
import Ema (Dynamic (..))
import Ema.CLI qualified
import Emanote.CLI qualified as CLI
import Emanote.Model.Note (Note)
import Emanote.Model.Stork.Index qualified as Stork
import Emanote.Model.Type qualified as Model
import Emanote.Pandoc.Renderer (EmanotePandocRenderers)
import Emanote.Prelude (chainM)
import Emanote.Route (LMLRoute)
import Emanote.Source.Loc (Loc)
import Emanote.Source.Loc qualified as Loc
import Emanote.Source.Patch qualified as Patch
import Emanote.Source.Pattern qualified as Pattern
import Optics.TH (makeLenses)
import Paths_emanote qualified
import Relude
import System.UnionMount qualified as UM
import UnliftIO (MonadUnliftIO)

-- | Everything that's required to run an Emanote site.
data EmanoteConfig = EmanoteConfig
  { -- | CLI arguments (includes layers)
    EmanoteConfig -> Cli
_emanoteConfigCli :: CLI.Cli,
    -- | A function to filter the `Note` before it gets added to the model.
    EmanoteConfig -> Note -> Note
_emanoteConfigNoteFn :: Note -> Note,
    -- | How to render Pandoc to Heist HTML.
    EmanoteConfig -> EmanotePandocRenderers Model LMLRoute
_emanoteConfigPandocRenderers :: EmanotePandocRenderers Model.Model LMLRoute,
    -- | Whether to replace Tailwind2 CDN with a minimized Tailwind3 CSS file.
    EmanoteConfig -> Bool
_emanoteCompileTailwind :: Bool
  }

-- | Make an Ema `Dynamic` for the Emanote model.
--
-- The bulk of logic for building the Dynamic is in `Patch.hs`.
emanoteSiteInput :: (MonadUnliftIO m, MonadLoggerIO m) => Some Ema.CLI.Action -> EmanoteConfig -> m (Dynamic m Model.ModelEma)
emanoteSiteInput :: forall (m :: Type -> Type).
(MonadUnliftIO m, MonadLoggerIO m) =>
Some @Type Action -> EmanoteConfig -> m (Dynamic m ModelEma)
emanoteSiteInput Some @Type Action
cliAct EmanoteConfig {Bool
EmanotePandocRenderers Model LMLRoute
Cli
Note -> Note
_emanoteCompileTailwind :: Bool
_emanoteConfigPandocRenderers :: EmanotePandocRenderers Model LMLRoute
_emanoteConfigNoteFn :: Note -> Note
_emanoteConfigCli :: Cli
_emanoteCompileTailwind :: EmanoteConfig -> Bool
_emanoteConfigPandocRenderers :: EmanoteConfig -> EmanotePandocRenderers Model LMLRoute
_emanoteConfigNoteFn :: EmanoteConfig -> Note -> Note
_emanoteConfigCli :: EmanoteConfig -> Cli
..} = do
  Loc
defaultLayer <- FilePath -> Loc
Loc.defaultLayer (FilePath -> Loc) -> m FilePath -> m Loc
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> IO FilePath -> m FilePath
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO IO FilePath
Paths_emanote.getDataDir
  UUID
instanceId <- IO UUID -> m UUID
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO IO UUID
UUID.nextRandom
  IndexVar
storkIndex <- m IndexVar
forall (m :: Type -> Type). MonadIO m => m IndexVar
Stork.newIndex
  let layers :: Set Loc
layers = NonEmpty FilePath -> Set Loc
Loc.userLayers (Cli -> NonEmpty FilePath
CLI.layers Cli
_emanoteConfigCli) Set Loc -> Set Loc -> Set Loc
forall a. Semigroup a => a -> a -> a
<> OneItem (Set Loc) -> Set Loc
forall x. One x => OneItem x -> x
one OneItem (Set Loc)
Loc
defaultLayer
      initialModel :: ModelEma
initialModel = Set Loc
-> Some @Type Action
-> EmanotePandocRenderers Model LMLRoute
-> Bool
-> UUID
-> IndexVar
-> ModelEma
Model.emptyModel Set Loc
layers Some @Type Action
cliAct EmanotePandocRenderers Model LMLRoute
_emanoteConfigPandocRenderers Bool
_emanoteCompileTailwind UUID
instanceId IndexVar
storkIndex
  (ModelEma, (ModelEma -> m ()) -> m ()) -> Dynamic m ModelEma
forall (m :: Type -> Type) a.
(a, (a -> m ()) -> m ()) -> Dynamic m a
Dynamic
    ((ModelEma, (ModelEma -> m ()) -> m ()) -> Dynamic m ModelEma)
-> m (ModelEma, (ModelEma -> m ()) -> m ())
-> m (Dynamic m ModelEma)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Set (Loc, FilePath)
-> [(FileType SourceExt, FilePath)]
-> [FilePath]
-> ModelEma
-> (Change Loc (FileType SourceExt) -> m (ModelEma -> ModelEma))
-> m (ModelEma, (ModelEma -> m ()) -> m ())
forall source tag model (m :: Type -> Type).
(MonadIO m, MonadUnliftIO m, MonadLogger m, Ord source, Ord tag) =>
Set (source, FilePath)
-> [(tag, FilePath)]
-> [FilePath]
-> model
-> (Change source tag -> m (model -> model))
-> m (model, (model -> m ()) -> m ())
UM.unionMount
      (Set Loc
layers Set Loc -> (Set Loc -> Set (Loc, FilePath)) -> Set (Loc, FilePath)
forall a b. a -> (a -> b) -> b
& (Loc -> (Loc, FilePath)) -> Set Loc -> Set (Loc, FilePath)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (Loc -> Loc
forall a. a -> a
id (Loc -> Loc) -> (Loc -> FilePath) -> Loc -> (Loc, FilePath)
forall (a :: Type -> Type -> Type) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Loc -> FilePath
Loc.locPath))
      [(FileType SourceExt, FilePath)]
Pattern.filePatterns
      [FilePath]
Pattern.ignorePatterns
      ModelEma
initialModel
      (ChangeHandler (FileType SourceExt) ModelEma m
-> Change Loc (FileType SourceExt) -> m (ModelEma -> ModelEma)
forall (m :: Type -> Type) tag model.
(MonadIO m, MonadLogger m) =>
ChangeHandler tag model m -> Change Loc tag -> m (model -> model)
mapFsChanges (ChangeHandler (FileType SourceExt) ModelEma m
 -> Change Loc (FileType SourceExt) -> m (ModelEma -> ModelEma))
-> ChangeHandler (FileType SourceExt) ModelEma m
-> Change Loc (FileType SourceExt)
-> m (ModelEma -> ModelEma)
forall a b. (a -> b) -> a -> b
$ Set Loc
-> (Note -> Note)
-> IndexVar
-> ChangeHandler (FileType SourceExt) ModelEma m
forall (m :: Type -> Type).
(MonadIO m, MonadLogger m, MonadLoggerIO m) =>
Set Loc
-> (Note -> Note)
-> IndexVar
-> FileType SourceExt
-> FilePath
-> FileAction (NonEmpty (Loc, FilePath))
-> m (ModelEma -> ModelEma)
Patch.patchModel Set Loc
layers Note -> Note
_emanoteConfigNoteFn IndexVar
storkIndex)

type ChangeHandler tag model m =
  tag ->
  FilePath ->
  UM.FileAction (NonEmpty (Loc, FilePath)) ->
  m (model -> model)

mapFsChanges :: (MonadIO m, MonadLogger m) => ChangeHandler tag model m -> UM.Change Loc tag -> m (model -> model)
mapFsChanges :: forall (m :: Type -> Type) tag model.
(MonadIO m, MonadLogger m) =>
ChangeHandler tag model m -> Change Loc tag -> m (model -> model)
mapFsChanges ChangeHandler tag model m
h Change Loc tag
ch = do
  (tag
 -> Map FilePath (FileAction (NonEmpty (Loc, FilePath)))
 -> m (model -> model))
-> (tag, Map FilePath (FileAction (NonEmpty (Loc, FilePath))))
-> m (model -> model)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (ChangeHandler tag model m
-> tag
-> Map FilePath (FileAction (NonEmpty (Loc, FilePath)))
-> m (model -> model)
forall (m :: Type -> Type) tag model.
(MonadIO m, MonadLogger m) =>
ChangeHandler tag model m
-> tag
-> Map FilePath (FileAction (NonEmpty (Loc, FilePath)))
-> m (model -> model)
mapFsChangesOnExt ChangeHandler tag model m
h) ((tag, Map FilePath (FileAction (NonEmpty (Loc, FilePath))))
 -> m (model -> model))
-> [(tag, Map FilePath (FileAction (NonEmpty (Loc, FilePath))))]
-> m (model -> model)
forall (m :: Type -> Type) b a.
Monad m =>
(b -> m (a -> a)) -> [b] -> m (a -> a)
`chainM` Change Loc tag
-> [(tag, Map FilePath (FileAction (NonEmpty (Loc, FilePath))))]
forall k a. Map k a -> [(k, a)]
Map.toList Change Loc tag
ch
  where
    -- Temporarily use block buffering before calling an IO action that is
    -- known ahead to log rapidly, so as to not hamper serial processing speed.
    -- FIXME: This buffers warnings and errors (when parsing .md file) without
    -- dumping them to console. So disabling for now. But we need a proper fix.
    _withBlockBuffering :: f a -> f a
_withBlockBuffering f a
f =
      (Handle -> BufferMode -> f ()
forall (m :: Type -> Type).
MonadIO m =>
Handle -> BufferMode -> m ()
hSetBuffering Handle
stdout (Maybe Int -> BufferMode
BlockBuffering Maybe Int
forall a. Maybe a
Nothing) f () -> f () -> f ()
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> Handle -> BufferMode -> f ()
forall (m :: Type -> Type).
MonadIO m =>
Handle -> BufferMode -> m ()
hSetBuffering Handle
stderr BufferMode
LineBuffering)
        f () -> f a -> f a
forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f b
*> f a
f
        f a -> f () -> f a
forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f a
<* (Handle -> f ()
forall (m :: Type -> Type). MonadIO m => Handle -> m ()
hFlush Handle
stdout f () -> f () -> f ()
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> Handle -> f ()
forall (m :: Type -> Type). MonadIO m => Handle -> m ()
hFlush Handle
stderr f () -> f () -> f ()
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> Handle -> BufferMode -> f ()
forall (m :: Type -> Type).
MonadIO m =>
Handle -> BufferMode -> m ()
hSetBuffering Handle
stdout BufferMode
LineBuffering)

mapFsChangesOnExt ::
  (MonadIO m, MonadLogger m) =>
  ChangeHandler tag model m ->
  tag ->
  Map FilePath (UM.FileAction (NonEmpty (Loc, FilePath))) ->
  m (model -> model)
mapFsChangesOnExt :: forall (m :: Type -> Type) tag model.
(MonadIO m, MonadLogger m) =>
ChangeHandler tag model m
-> tag
-> Map FilePath (FileAction (NonEmpty (Loc, FilePath)))
-> m (model -> model)
mapFsChangesOnExt ChangeHandler tag model m
h tag
fpType Map FilePath (FileAction (NonEmpty (Loc, FilePath)))
fps = do
  (FilePath
 -> FileAction (NonEmpty (Loc, FilePath)) -> m (model -> model))
-> (FilePath, FileAction (NonEmpty (Loc, FilePath)))
-> m (model -> model)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (ChangeHandler tag model m
h tag
fpType) ((FilePath, FileAction (NonEmpty (Loc, FilePath)))
 -> m (model -> model))
-> [(FilePath, FileAction (NonEmpty (Loc, FilePath)))]
-> m (model -> model)
forall (m :: Type -> Type) b a.
Monad m =>
(b -> m (a -> a)) -> [b] -> m (a -> a)
`chainM` Map FilePath (FileAction (NonEmpty (Loc, FilePath)))
-> [(FilePath, FileAction (NonEmpty (Loc, FilePath)))]
forall k a. Map k a -> [(k, a)]
Map.toList Map FilePath (FileAction (NonEmpty (Loc, FilePath)))
fps

makeLenses ''EmanoteConfig