{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Emanote (
  run,
  defaultEmanoteConfig,
) where

import Control.Monad.Logger (LogLevel (LevelError), runStderrLoggingT, runStdoutLoggingT)
import Control.Monad.Logger.Extras (Logger (Logger), logToStderr, runLoggerLoggingT)
import Control.Monad.Writer.Strict (MonadWriter (tell), WriterT (runWriterT))
import Data.Default (def)
import Data.Dependent.Sum (DSum ((:=>)))
import Data.Map.Strict qualified as Map
import Ema (
  EmaSite (..),
  IsRoute (..),
  fromPrism_,
  runSiteWithCli,
  toPrism_,
 )
import Ema.CLI qualified
import Ema.Dynamic (Dynamic (Dynamic))
import Emanote.CLI qualified as CLI
import Emanote.Model.Link.Rel (ResolvedRelTarget (..))
import Emanote.Model.Type (modelCompileTailwind)
import Emanote.Model.Type qualified as Model
import Emanote.Pandoc.Renderer
import Emanote.Pandoc.Renderer.Embed qualified as PF
import Emanote.Pandoc.Renderer.Query qualified as PF
import Emanote.Pandoc.Renderer.Url qualified as PF
import Emanote.Prelude (log, logE, logW)
import Emanote.Route.ModelRoute (LMLRoute, lmlRouteCase)
import Emanote.Route.SiteRoute.Class (emanoteGeneratableRoutes, emanoteRouteEncoder)
import Emanote.Route.SiteRoute.Type (SiteRoute)
import Emanote.Source.Dynamic (EmanoteConfig (..), emanoteSiteInput)
import Emanote.View.Common (generatedCssFile)
import Emanote.View.Export qualified as Export
import Emanote.View.Template qualified as View
import Optics.Core ((%), (.~), (^.))
import Relude
import System.FilePath ((</>))
import UnliftIO (MonadUnliftIO)
import Web.Tailwind qualified as Tailwind

instance IsRoute SiteRoute where
  type RouteModel SiteRoute = Model.ModelEma
  routePrism :: RouteModel SiteRoute -> Prism_ FilePath SiteRoute
routePrism = forall s a. Prism' s a -> Prism_ s a
toPrism_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => ModelEma -> Prism' FilePath SiteRoute
emanoteRouteEncoder
  routeUniverse :: RouteModel SiteRoute -> [SiteRoute]
routeUniverse = ModelEma -> [SiteRoute]
emanoteGeneratableRoutes

instance EmaSite SiteRoute where
  type SiteArg SiteRoute = EmanoteConfig
  siteInput :: forall (m :: Type -> Type).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
Some @Type Action
-> SiteArg SiteRoute -> m (Dynamic m (RouteModel SiteRoute))
siteInput = forall (m :: Type -> Type).
(MonadUnliftIO m, MonadLoggerIO m) =>
Some @Type Action -> EmanoteConfig -> m (Dynamic m ModelEma)
emanoteSiteInput
  siteOutput :: forall (m :: Type -> Type).
(MonadIO m, MonadLoggerIO m) =>
Prism' FilePath SiteRoute
-> RouteModel SiteRoute -> SiteRoute -> m (SiteOutput SiteRoute)
siteOutput = forall (m :: Type -> Type).
(MonadIO m, MonadLoggerIO m) =>
Prism' FilePath SiteRoute
-> ModelEma -> SiteRoute -> m (Asset LByteString)
View.emanoteSiteOutput

defaultEmanoteConfig :: CLI.Cli -> EmanoteConfig
defaultEmanoteConfig :: Cli -> EmanoteConfig
defaultEmanoteConfig Cli
cli =
  Cli
-> (Note -> Note)
-> EmanotePandocRenderers Model LMLRoute
-> Bool
-> EmanoteConfig
EmanoteConfig Cli
cli forall a. a -> a
id EmanotePandocRenderers Model LMLRoute
defaultEmanotePandocRenderers Bool
False

run :: EmanoteConfig -> IO ()
run :: EmanoteConfig -> IO ()
run cfg :: EmanoteConfig
cfg@EmanoteConfig {Bool
EmanotePandocRenderers Model LMLRoute
Cli
Note -> Note
_emanoteCompileTailwind :: EmanoteConfig -> Bool
_emanoteConfigPandocRenderers :: EmanoteConfig -> EmanotePandocRenderers Model LMLRoute
_emanoteConfigNoteFn :: EmanoteConfig -> Note -> Note
_emanoteConfigCli :: EmanoteConfig -> Cli
_emanoteCompileTailwind :: Bool
_emanoteConfigPandocRenderers :: EmanotePandocRenderers Model LMLRoute
_emanoteConfigNoteFn :: Note -> Note
_emanoteConfigCli :: Cli
..} = do
  case Cli -> Cmd
CLI.cmd Cli
_emanoteConfigCli of
    CLI.Cmd_Ema Cli
emaCli ->
      forall r.
(Show r, Eq r, EmaStaticSite r) =>
Cli -> SiteArg r -> IO (RouteModel r, DSum @Type Action Identity)
Ema.runSiteWithCli @SiteRoute Cli
emaCli EmanoteConfig
cfg
        forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= EmanoteConfig -> (ModelEma, DSum @Type Action Identity) -> IO ()
postRun EmanoteConfig
cfg
    Cmd
CLI.Cmd_Export -> do
      Dynamic (ModelEma -> Model
unModelEma -> Model
model0, (ModelEma -> LoggingT IO ()) -> LoggingT IO ()
_) <-
        forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: Type -> Type) a. LoggingT m a -> Logger -> m a
runLoggerLoggingT Logger
oneOffLogger forall a b. (a -> b) -> a -> b
$
          forall r (m :: Type -> Type).
(EmaSite r, MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
Some @Type Action -> SiteArg r -> m (Dynamic m (RouteModel r))
siteInput @SiteRoute (Cli -> Some @Type Action
Ema.CLI.action forall a. Default a => a
def) EmanoteConfig
cfg
      forall (m :: Type -> Type). MonadIO m => LByteString -> m ()
putLBSLn forall a b. (a -> b) -> a -> b
$ Model -> LByteString
Export.renderGraphExport Model
model0
  where
    -- A logger suited for running one-off commands.
    oneOffLogger :: Logger
oneOffLogger =
      Logger
logToStderr
        forall a b. a -> (a -> b) -> b
& LogLevel -> Logger -> Logger
allowLogLevelFrom LogLevel
LevelError
      where
        allowLogLevelFrom :: LogLevel -> Logger -> Logger
        allowLogLevelFrom :: LogLevel -> Logger -> Logger
allowLogLevelFrom LogLevel
minLevel (Logger LogF
f) = LogF -> Logger
Logger forall a b. (a -> b) -> a -> b
$ \Loc
loc Text
src LogLevel
level LogStr
msg ->
          if LogLevel
level forall a. Ord a => a -> a -> Bool
>= LogLevel
minLevel
            then LogF
f Loc
loc Text
src LogLevel
level LogStr
msg
            else forall (f :: Type -> Type). Applicative f => f ()
pass

postRun :: EmanoteConfig -> (Model.ModelEma, DSum Ema.CLI.Action Identity) -> IO ()
postRun :: EmanoteConfig -> (ModelEma, DSum @Type Action Identity) -> IO ()
postRun 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
..} = \case
  (ModelEma -> Model
unModelEma -> Model
model0, Ema.CLI.Generate FilePath
outPath :=> Identity a
genPaths) -> do
    forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Model
model0 forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (encF :: Type -> Type). Lens' (ModelT encF) Bool
modelCompileTailwind) forall a b. (a -> b) -> a -> b
$
      forall (m :: Type -> Type).
MonadUnliftIO m =>
FilePath -> [FilePath] -> m ()
compileTailwindCss (FilePath
outPath FilePath -> FilePath -> FilePath
</> FilePath
generatedCssFile) a
genPaths
    Cli -> Map LMLRoute [Link] -> IO ()
checkBrokenLinks Cli
_emanoteConfigCli forall a b. (a -> b) -> a -> b
$ Model -> Map LMLRoute [Link]
Export.modelRels Model
model0
    Map LMLRoute [Text] -> IO ()
checkBadMarkdownFiles forall a b. (a -> b) -> a -> b
$ Model -> Map LMLRoute [Text]
Model.modelNoteErrors Model
model0
  (ModelEma, DSum @Type Action Identity)
_ ->
    forall (f :: Type -> Type). Applicative f => f ()
pass

unModelEma :: Model.ModelEma -> Model.Model
unModelEma :: ModelEma -> Model
unModelEma ModelEma
m = Prism' FilePath SiteRoute -> ModelEma -> Model
Model.withRoutePrism (forall s a. Prism_ s a -> Prism' s a
fromPrism_ forall a b. (a -> b) -> a -> b
$ forall r. IsRoute r => RouteModel r -> Prism_ FilePath r
routePrism @SiteRoute ModelEma
m) ModelEma
m

checkBadMarkdownFiles :: Map LMLRoute [Text] -> IO ()
checkBadMarkdownFiles :: Map LMLRoute [Text] -> IO ()
checkBadMarkdownFiles Map LMLRoute [Text]
noteErrs = forall (m :: Type -> Type) a. MonadIO m => LoggingT m a -> m a
runStderrLoggingT forall a b. (a -> b) -> a -> b
$ do
  forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall k a. Map k a -> [(k, a)]
Map.toList Map LMLRoute [Text]
noteErrs) forall a b. (a -> b) -> a -> b
$ \(LMLRoute
noteRoute, [Text]
errs) -> do
    forall (m :: Type -> Type). MonadLogger m => Text -> m ()
logW forall a b. (a -> b) -> a -> b
$ Text
"Bad markdown file: " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show LMLRoute
noteRoute
    forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Text]
errs forall a b. (a -> b) -> a -> b
$ \Text
err -> do
      forall (m :: Type -> Type). MonadLogger m => Text -> m ()
logE forall a b. (a -> b) -> a -> b
$ Text
"  - " forall a. Semigroup a => a -> a -> a
<> Text
err
  forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null Map LMLRoute [Text]
noteErrs) forall a b. (a -> b) -> a -> b
$ do
    forall (m :: Type -> Type). MonadLogger m => Text -> m ()
logE Text
"Errors found."
    forall (m :: Type -> Type) a. MonadIO m => m a
exitFailure

checkBrokenLinks :: CLI.Cli -> Map LMLRoute [Export.Link] -> IO ()
checkBrokenLinks :: Cli -> Map LMLRoute [Link] -> IO ()
checkBrokenLinks Cli
cli Map LMLRoute [Link]
modelRels = forall (m :: Type -> Type) a. MonadIO m => LoggingT m a -> m a
runStderrLoggingT forall a b. (a -> b) -> a -> b
$ do
  ((), Sum Int
res :: Sum Int) <- forall w (m :: Type -> Type) a. WriterT w m a -> m (a, w)
runWriterT forall a b. (a -> b) -> a -> b
$
    forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall k a. Map k a -> [(k, a)]
Map.toList Map LMLRoute [Link]
modelRels) forall a b. (a -> b) -> a -> b
$ \(LMLRoute
noteRoute, [Link]
rels) ->
      forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a. Ord a => [a] -> [a]
sortNub [Link]
rels) forall a b. (a -> b) -> a -> b
$ \(Export.Link UnresolvedRelTarget
urt ResolvedRelTarget Text
rrt) ->
        case ResolvedRelTarget Text
rrt of
          RRTFound Text
_ -> forall (f :: Type -> Type). Applicative f => f ()
pass
          ResolvedRelTarget Text
RRTMissing -> do
            forall (m :: Type -> Type). MonadLogger m => Text -> m ()
logW forall a b. (a -> b) -> a -> b
$ Text
"Broken link: " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show (LMLRoute
-> Either
     (R @SourceExt ('LMLType 'Md)) (R @SourceExt ('LMLType 'Org))
lmlRouteCase LMLRoute
noteRoute) forall a. Semigroup a => a -> a -> a
<> Text
" -> " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show UnresolvedRelTarget
urt
            forall w (m :: Type -> Type). MonadWriter w m => w -> m ()
tell Sum Int
1
          RRTAmbiguous NonEmpty Text
ls -> do
            forall (m :: Type -> Type). MonadLogger m => Text -> m ()
logW forall a b. (a -> b) -> a -> b
$ Text
"Ambiguous link: " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show (LMLRoute
-> Either
     (R @SourceExt ('LMLType 'Md)) (R @SourceExt ('LMLType 'Org))
lmlRouteCase LMLRoute
noteRoute) forall a. Semigroup a => a -> a -> a
<> Text
" -> " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show UnresolvedRelTarget
urt forall a. Semigroup a => a -> a -> a
<> Text
" ambiguities: " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show NonEmpty Text
ls
            forall w (m :: Type -> Type). MonadWriter w m => w -> m ()
tell Sum Int
1
  if Sum Int
res forall a. Eq a => a -> a -> Bool
== Sum Int
0
    then do
      forall (m :: Type -> Type). MonadLogger m => Text -> m ()
log Text
"No broken links detected."
    else forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (Cli -> Bool
CLI.allowBrokenLinks Cli
cli) forall a b. (a -> b) -> a -> b
$ do
      forall (m :: Type -> Type). MonadLogger m => Text -> m ()
logE forall a b. (a -> b) -> a -> b
$ Text
"Found " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show (forall a. Sum a -> a
getSum Sum Int
res) forall a. Semigroup a => a -> a -> a
<> Text
" broken links! Emanote generated the site, but the generated site has broken links."
      forall (m :: Type -> Type). MonadLogger m => Text -> m ()
log Text
"(Tip: use `--allow-broken-links` to ignore this check.)"
      forall (m :: Type -> Type) a. MonadIO m => m a
exitFailure

compileTailwindCss :: MonadUnliftIO m => FilePath -> [FilePath] -> m ()
compileTailwindCss :: forall (m :: Type -> Type).
MonadUnliftIO m =>
FilePath -> [FilePath] -> m ()
compileTailwindCss FilePath
cssPath [FilePath]
genPaths = do
  forall (m :: Type -> Type) a. MonadIO m => LoggingT m a -> m a
runStdoutLoggingT forall a b. (a -> b) -> a -> b
$ do
    forall (m :: Type -> Type). MonadLogger m => Text -> m ()
log forall a b. (a -> b) -> a -> b
$ Text
"Running Tailwind CSS v3 compiler to generate: " forall a. Semigroup a => a -> a -> a
<> forall a. ToText a => a -> Text
toText FilePath
cssPath
    forall (m :: Type -> Type).
(MonadUnliftIO m, MonadLogger m, HasCallStack) =>
Tailwind -> m ()
Tailwind.runTailwind forall a b. (a -> b) -> a -> b
$
      forall a. Default a => a
def
        forall a b. a -> (a -> b) -> b
& Lens' Tailwind TailwindConfig
Tailwind.tailwindConfig forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Iso' TailwindConfig [FilePath]
Tailwind.tailwindConfigContent forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ [FilePath]
genPaths
        forall a b. a -> (a -> b) -> b
& Lens' Tailwind FilePath
Tailwind.tailwindOutput forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ FilePath
cssPath
        forall a b. a -> (a -> b) -> b
& Lens' Tailwind Mode
Tailwind.tailwindMode forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ Mode
Tailwind.Production

defaultEmanotePandocRenderers :: EmanotePandocRenderers Model.Model LMLRoute
defaultEmanotePandocRenderers :: EmanotePandocRenderers Model LMLRoute
defaultEmanotePandocRenderers =
  let blockRenderers :: PandocRenderers Model LMLRoute
blockRenderers =
        forall model route.
[PandocInlineRenderer model route]
-> [PandocBlockRenderer model route] -> PandocRenderers model route
PandocRenderers
          [ PandocInlineRenderer Model LMLRoute
PF.embedInlineWikiLinkResolvingSplice -- embedInlineWikiLinkResolvingSplice should be first to recognize inline Link elements first
          , PandocInlineRenderer Model LMLRoute
PF.urlResolvingSplice
          ]
          [ PandocBlockRenderer Model LMLRoute
PF.embedBlockWikiLinkResolvingSplice
          , PandocBlockRenderer Model LMLRoute
PF.embedBlockRegularLinkResolvingSplice
          , PandocBlockRenderer Model LMLRoute
PF.queryResolvingSplice
          ]
      inlineRenderers :: PandocRenderers Model LMLRoute
inlineRenderers =
        forall model route.
[PandocInlineRenderer model route]
-> [PandocBlockRenderer model route] -> PandocRenderers model route
PandocRenderers
          [ PandocInlineRenderer Model LMLRoute
PF.embedInlineWikiLinkResolvingSplice -- embedInlineWikiLinkResolvingSplice should be first to recognize inline Link elements first
          , PandocInlineRenderer Model LMLRoute
PF.urlResolvingSplice
          ]
          forall a. Monoid a => a
mempty
      linkInlineRenderers :: PandocRenderers Model LMLRoute
linkInlineRenderers =
        forall model route.
[PandocInlineRenderer model route]
-> [PandocBlockRenderer model route] -> PandocRenderers model route
PandocRenderers
          [ PandocInlineRenderer Model LMLRoute
PF.plainifyWikiLinkSplice
          ]
          forall a. Monoid a => a
mempty
   in EmanotePandocRenderers {PandocRenderers Model LMLRoute
linkInlineRenderers :: PandocRenderers Model LMLRoute
inlineRenderers :: PandocRenderers Model LMLRoute
blockRenderers :: PandocRenderers Model LMLRoute
linkInlineRenderers :: PandocRenderers Model LMLRoute
inlineRenderers :: PandocRenderers Model LMLRoute
blockRenderers :: PandocRenderers Model LMLRoute
..}