{-# 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
(Host -> Host -> Bool) -> (Host -> Host -> Bool) -> Eq Host
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, Int -> Host -> ShowS
[Host] -> ShowS
Host -> String
(Int -> Host -> ShowS)
-> (Host -> String) -> ([Host] -> ShowS) -> Show Host
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Host] -> ShowS
$cshowList :: [Host] -> ShowS
show :: Host -> String
$cshow :: Host -> String
showsPrec :: Int -> Host -> ShowS
$cshowsPrec :: Int -> Host -> ShowS
Show, Eq Host
Eq Host
-> (Host -> Host -> Ordering)
-> (Host -> Host -> Bool)
-> (Host -> Host -> Bool)
-> (Host -> Host -> Bool)
-> (Host -> Host -> Bool)
-> (Host -> Host -> Host)
-> (Host -> Host -> Host)
-> Ord 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
$cp1Ord :: Eq Host
Ord, String -> Host
(String -> Host) -> IsString Host
forall a. (String -> a) -> IsString a
fromString :: String -> Host
$cfromString :: String -> 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 Int)
_)) = 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
(Cli -> Cli -> Bool) -> (Cli -> Cli -> Bool) -> Eq Cli
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, Int -> Cli -> ShowS
[Cli] -> ShowS
Cli -> String
(Int -> Cli -> ShowS)
-> (Cli -> String) -> ([Cli] -> ShowS) -> Show Cli
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Cli] -> ShowS
$cshowList :: [Cli] -> ShowS
show :: Cli -> String
$cshow :: Cli -> String
showsPrec :: Int -> Cli -> ShowS
$cshowsPrec :: Int -> 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 (Action () -> Some @Type Action
forall {k} (tag :: k -> Type) (a :: k). tag a -> Some @k tag
Some ((Host, Maybe Int) -> Action ()
Run (Host, Maybe Int)
forall a. Default a => a
def)) Bool
False

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

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

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

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

getLogger :: Cli -> Logger
getLogger :: Cli -> Logger
getLogger Cli
cli =
  Logger
logToStdout
    Logger -> (Logger -> Logger) -> Logger
forall a b. a -> (a -> b) -> b
& Logger -> Logger
colorize
    Logger -> (Logger -> Logger) -> Logger
forall a b. a -> (a -> b) -> b
& LogLevel -> Logger -> Logger
allowLogLevelFrom (LogLevel -> LogLevel -> Bool -> LogLevel
forall a. a -> a -> Bool -> a
bool LogLevel
LevelInfo LogLevel
LevelDebug (Bool -> LogLevel) -> Bool -> LogLevel
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 (LogF -> Logger) -> LogF -> Logger
forall a b. (a -> b) -> a -> b
$ \Loc
loc Text
src LogLevel
level LogStr
msg ->
      if LogLevel
level LogLevel -> LogLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= LogLevel
minLevel
        then LogF
f Loc
loc Text
src LogLevel
level LogStr
msg
        else IO ()
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 :: Text -> Text -> m a
crash Text
source Text
msg = do
  Text -> Text -> m ()
forall (m :: Type -> Type). MonadLogger m => Text -> Text -> m ()
logErrorNS Text
source Text
msg
  String -> m a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ Text -> String
forall a. ToString a => a -> String
toString Text
msg