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

module Ema.CLI where

import Control.Monad.Logger (LogLevel (LevelDebug, LevelInfo), LogSource, MonadLoggerIO, logErrorNS)
import Control.Monad.Logger.Extras (
  Logger (Logger),
  colorize,
  logToStdout,
 )
import Data.Constraint.Extras.TH (deriveArgDict)
import Data.Default (Default (def))
import Data.GADT.Compare.TH (
  DeriveGCompare (deriveGCompare),
  DeriveGEQ (deriveGEq),
 )
import Data.GADT.Show.TH (DeriveGShow (deriveGShow))
import Data.Some (Some (..))
import Network.Wai.Handler.Warp (Port)
import Options.Applicative hiding (action)

-- | Host string to start the server on.
newtype Host = Host {Host -> Text
unHost :: Text}
  deriving newtype (Host -> Host -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Host -> Host -> Bool
$c/= :: Host -> Host -> Bool
== :: Host -> Host -> Bool
$c== :: Host -> Host -> Bool
Eq, Port -> Host -> ShowS
[Host] -> ShowS
Host -> FilePath
forall a.
(Port -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Host] -> ShowS
$cshowList :: [Host] -> ShowS
show :: Host -> FilePath
$cshow :: Host -> FilePath
showsPrec :: Port -> Host -> ShowS
$cshowsPrec :: Port -> Host -> ShowS
Show, Eq Host
Host -> Host -> Bool
Host -> Host -> Ordering
Host -> Host -> Host
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 :: Host -> Host -> Host
$cmin :: Host -> Host -> Host
max :: Host -> Host -> Host
$cmax :: Host -> Host -> Host
>= :: Host -> Host -> Bool
$c>= :: Host -> Host -> Bool
> :: Host -> Host -> Bool
$c> :: Host -> Host -> Bool
<= :: Host -> Host -> Bool
$c<= :: Host -> Host -> Bool
< :: Host -> Host -> Bool
$c< :: Host -> Host -> Bool
compare :: Host -> Host -> Ordering
$ccompare :: Host -> Host -> Ordering
Ord, FilePath -> Host
forall a. (FilePath -> a) -> IsString a
fromString :: FilePath -> Host
$cfromString :: FilePath -> Host
IsString)

instance Default Host where
  def :: Host
def = Host
"127.0.0.1"

-- | CLI subcommand
data Action result where
  -- | Generate static files at the given output directory, returning the list
  -- of generated files.
  Generate :: FilePath -> Action [FilePath]
  -- | Run the live server
  Run :: (Host, Maybe Port) -> Action ()

$(deriveGEq ''Action)
$(deriveGShow ''Action)
$(deriveGCompare ''Action)
$(deriveArgDict ''Action)

isLiveServer :: Some Action -> Bool
isLiveServer :: Some @Type Action -> Bool
isLiveServer (Some (Run (Host, Maybe Port)
_)) = Bool
True
isLiveServer Some @Type Action
_ = Bool
False

-- | Ema's command-line interface options
data Cli = Cli
  { Cli -> Some @Type Action
action :: Some Action
  -- ^ The Ema action to run
  , Cli -> Bool
verbose :: Bool
  -- ^ Logging verbosity
  }
  deriving stock (Cli -> Cli -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Cli -> Cli -> Bool
$c/= :: Cli -> Cli -> Bool
== :: Cli -> Cli -> Bool
$c== :: Cli -> Cli -> Bool
Eq, Port -> Cli -> ShowS
[Cli] -> ShowS
Cli -> FilePath
forall a.
(Port -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Cli] -> ShowS
$cshowList :: [Cli] -> ShowS
show :: Cli -> FilePath
$cshow :: Cli -> FilePath
showsPrec :: Port -> Cli -> ShowS
$cshowsPrec :: Port -> Cli -> ShowS
Show)

instance Default Cli where
  -- By default, run the live server on random port.
  def :: Cli
def = Some @Type Action -> Bool -> Cli
Cli (forall {k} (tag :: k -> Type) (a :: k). tag a -> Some @k tag
Some ((Host, Maybe Port) -> Action ()
Run forall a. Default a => a
def)) Bool
False

cliParser :: Parser Cli
cliParser :: Parser Cli
cliParser = do
  Some @Type Action
action <-
    forall a. Mod CommandFields a -> Parser a
subparser
      (forall a. FilePath -> ParserInfo a -> Mod CommandFields a
command FilePath
"gen" (forall a. Parser a -> InfoMod a -> ParserInfo a
info Parser (Some @Type Action)
generate (forall a. FilePath -> InfoMod a
progDesc FilePath
"Generate static site")))
      forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> forall a. Mod CommandFields a -> Parser a
subparser (forall a. FilePath -> ParserInfo a -> Mod CommandFields a
command FilePath
"run" (forall a. Parser a -> InfoMod a -> ParserInfo a
info Parser (Some @Type Action)
run (forall a. FilePath -> InfoMod a
progDesc FilePath
"Run the live server")))
      forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (forall {k} (tag :: k -> Type) (a :: k). tag a -> Some @k tag
Some forall a b. (a -> b) -> a -> b
$ (Host, Maybe Port) -> Action ()
Run forall a. Default a => a
def)
  Bool
verbose <- Mod FlagFields Bool -> Parser Bool
switch (forall (f :: Type -> Type) a. HasName f => FilePath -> Mod f a
long FilePath
"verbose" forall a. Semigroup a => a -> a -> a
<> forall (f :: Type -> Type) a. HasName f => Char -> Mod f a
short Char
'v' forall a. Semigroup a => a -> a -> a
<> forall (f :: Type -> Type) a. FilePath -> Mod f a
help FilePath
"Enable verbose logging")
  pure Cli {Bool
Some @Type Action
verbose :: Bool
action :: Some @Type Action
verbose :: Bool
action :: Some @Type Action
..}
  where
    run :: Parser (Some Action)
    run :: Parser (Some @Type Action)
run =
      forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall {k} (tag :: k -> Type) (a :: k). tag a -> Some @k tag
Some forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Host, Maybe Port) -> Action ()
Run) forall a b. (a -> b) -> a -> b
$ (,) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Host
hostParser forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> forall (f :: Type -> Type) a. Alternative f => f a -> f (Maybe a)
optional Parser Port
portParser
    generate :: Parser (Some Action)
    generate :: Parser (Some @Type Action)
generate =
      forall {k} (tag :: k -> Type) (a :: k). tag a -> Some @k tag
Some forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Action [FilePath]
Generate forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ReadM a -> Mod ArgumentFields a -> Parser a
argument forall s. IsString s => ReadM s
str (forall (f :: Type -> Type) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"DEST")

hostParser :: Parser Host
hostParser :: Parser Host
hostParser =
  forall s. IsString s => Mod OptionFields s -> Parser s
strOption (forall (f :: Type -> Type) a. HasName f => FilePath -> Mod f a
long FilePath
"host" forall a. Semigroup a => a -> a -> a
<> forall (f :: Type -> Type) a. HasName f => Char -> Mod f a
short Char
'h' forall a. Semigroup a => a -> a -> a
<> forall (f :: Type -> Type) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"HOST" forall a. Semigroup a => a -> a -> a
<> forall (f :: Type -> Type) a. FilePath -> Mod f a
help FilePath
"Host to bind to" forall a. Semigroup a => a -> a -> a
<> forall (f :: Type -> Type) a. HasValue f => a -> Mod f a
value forall a. Default a => a
def)

portParser :: Parser Port
portParser :: Parser Port
portParser =
  forall a. ReadM a -> Mod OptionFields a -> Parser a
option forall a. Read a => ReadM a
auto (forall (f :: Type -> Type) a. HasName f => FilePath -> Mod f a
long FilePath
"port" forall a. Semigroup a => a -> a -> a
<> forall (f :: Type -> Type) a. HasName f => Char -> Mod f a
short Char
'p' forall a. Semigroup a => a -> a -> a
<> forall (f :: Type -> Type) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"PORT" forall a. Semigroup a => a -> a -> a
<> forall (f :: Type -> Type) a. FilePath -> Mod f a
help FilePath
"Port to bind to")

-- | Parse Ema CLI arguments passed by the user.
cliAction :: IO Cli
cliAction :: IO Cli
cliAction = do
  forall a. ParserInfo a -> IO a
execParser ParserInfo Cli
opts
  where
    opts :: ParserInfo Cli
opts =
      forall a. Parser a -> InfoMod a -> ParserInfo a
info
        (Parser Cli
cliParser forall (f :: Type -> Type) a b.
Applicative f =>
f a -> f (a -> b) -> f b
<**> forall a. Parser (a -> a)
helper)
        ( forall a. InfoMod a
fullDesc
            forall a. Semigroup a => a -> a -> a
<> forall a. FilePath -> InfoMod a
progDesc FilePath
"Ema - static site generator"
            forall a. Semigroup a => a -> a -> a
<> forall a. FilePath -> InfoMod a
header FilePath
"Ema"
        )

getLogger :: Cli -> Logger
getLogger :: Cli -> Logger
getLogger Cli
cli =
  Logger
logToStdout
    forall a b. a -> (a -> b) -> b
& Logger -> Logger
colorize
    forall a b. a -> (a -> b) -> b
& LogLevel -> Logger -> Logger
allowLogLevelFrom (forall a. a -> a -> Bool -> a
bool LogLevel
LevelInfo LogLevel
LevelDebug forall a b. (a -> b) -> a -> b
$ Cli -> Bool
verbose Cli
cli)
  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

{- | Crash the program with the given error message

 First log the message using Error level, and then exit using `fail`.
-}
crash :: (MonadLoggerIO m, MonadFail m) => LogSource -> Text -> m a
crash :: forall (m :: Type -> Type) a.
(MonadLoggerIO m, MonadFail m) =>
Text -> Text -> m a
crash Text
source Text
msg = do
  forall (m :: Type -> Type). MonadLogger m => Text -> Text -> m ()
logErrorNS Text
source Text
msg
  forall (m :: Type -> Type) a. MonadFail m => FilePath -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. ToString a => a -> FilePath
toString Text
msg