{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      : Jikka.Main
-- Description : is the entry point of the @jikka@ command. / @jikka@ コマンドのエントリポイントです。
-- Copyright   : (c) Kimiyuki Onaka, 2021
-- License     : Apache License 2.0
-- Maintainer  : kimiyuki95@gmail.com
-- Stability   : experimental
-- Portability : portable
module Jikka.Main where

import Data.Maybe (fromMaybe)
import qualified Data.Text.IO as T
import Data.Version (showVersion)
import qualified Jikka.CPlusPlus.Convert.BundleRuntime as BundleRuntime
import qualified Jikka.CPlusPlus.Convert.EmbedOriginalCode as EmbedOriginalCode
import Jikka.Common.Error
import Jikka.Common.Format.Error (hPrintError, hPrintErrorWithText)
import qualified Jikka.Main.Subcommand.Convert as Convert
import qualified Jikka.Main.Subcommand.Debug as Debug
import qualified Jikka.Main.Subcommand.Execute as Execute
import Jikka.Main.Target
import Paths_Jikka (version)
import System.Console.GetOpt
import System.Exit (ExitCode (..))
import System.IO (hPutStr, stderr)

data Flag
  = Help
  | Verbose
  | Version
  | Source String
  | Target String
  | BundleRuntimeHeaders Bool
  | EmbedOriginalCode Bool
  deriving (Flag -> Flag -> Bool
(Flag -> Flag -> Bool) -> (Flag -> Flag -> Bool) -> Eq Flag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Flag -> Flag -> Bool
$c/= :: Flag -> Flag -> Bool
== :: Flag -> Flag -> Bool
$c== :: Flag -> Flag -> Bool
Eq, Eq Flag
Eq Flag
-> (Flag -> Flag -> Ordering)
-> (Flag -> Flag -> Bool)
-> (Flag -> Flag -> Bool)
-> (Flag -> Flag -> Bool)
-> (Flag -> Flag -> Bool)
-> (Flag -> Flag -> Flag)
-> (Flag -> Flag -> Flag)
-> Ord Flag
Flag -> Flag -> Bool
Flag -> Flag -> Ordering
Flag -> Flag -> Flag
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 :: Flag -> Flag -> Flag
$cmin :: Flag -> Flag -> Flag
max :: Flag -> Flag -> Flag
$cmax :: Flag -> Flag -> Flag
>= :: Flag -> Flag -> Bool
$c>= :: Flag -> Flag -> Bool
> :: Flag -> Flag -> Bool
$c> :: Flag -> Flag -> Bool
<= :: Flag -> Flag -> Bool
$c<= :: Flag -> Flag -> Bool
< :: Flag -> Flag -> Bool
$c< :: Flag -> Flag -> Bool
compare :: Flag -> Flag -> Ordering
$ccompare :: Flag -> Flag -> Ordering
$cp1Ord :: Eq Flag
Ord, Int -> Flag -> ShowS
[Flag] -> ShowS
Flag -> String
(Int -> Flag -> ShowS)
-> (Flag -> String) -> ([Flag] -> ShowS) -> Show Flag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Flag] -> ShowS
$cshowList :: [Flag] -> ShowS
show :: Flag -> String
$cshow :: Flag -> String
showsPrec :: Int -> Flag -> ShowS
$cshowsPrec :: Int -> Flag -> ShowS
Show, ReadPrec [Flag]
ReadPrec Flag
Int -> ReadS Flag
ReadS [Flag]
(Int -> ReadS Flag)
-> ReadS [Flag] -> ReadPrec Flag -> ReadPrec [Flag] -> Read Flag
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Flag]
$creadListPrec :: ReadPrec [Flag]
readPrec :: ReadPrec Flag
$creadPrec :: ReadPrec Flag
readList :: ReadS [Flag]
$creadList :: ReadS [Flag]
readsPrec :: Int -> ReadS Flag
$creadsPrec :: Int -> ReadS Flag
Read)

data Options = Options
  { Options -> Bool
verbose :: Bool,
    Options -> Target
source :: Target,
    Options -> Maybe Target
target :: Maybe Target,
    Options -> Bool
bundleRuntimeHeaders :: Bool,
    Options -> Bool
embedOriginalCode :: Bool
  }
  deriving (Options -> Options -> Bool
(Options -> Options -> Bool)
-> (Options -> Options -> Bool) -> Eq Options
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Options -> Options -> Bool
$c/= :: Options -> Options -> Bool
== :: Options -> Options -> Bool
$c== :: Options -> Options -> Bool
Eq, Eq Options
Eq Options
-> (Options -> Options -> Ordering)
-> (Options -> Options -> Bool)
-> (Options -> Options -> Bool)
-> (Options -> Options -> Bool)
-> (Options -> Options -> Bool)
-> (Options -> Options -> Options)
-> (Options -> Options -> Options)
-> Ord Options
Options -> Options -> Bool
Options -> Options -> Ordering
Options -> Options -> Options
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 :: Options -> Options -> Options
$cmin :: Options -> Options -> Options
max :: Options -> Options -> Options
$cmax :: Options -> Options -> Options
>= :: Options -> Options -> Bool
$c>= :: Options -> Options -> Bool
> :: Options -> Options -> Bool
$c> :: Options -> Options -> Bool
<= :: Options -> Options -> Bool
$c<= :: Options -> Options -> Bool
< :: Options -> Options -> Bool
$c< :: Options -> Options -> Bool
compare :: Options -> Options -> Ordering
$ccompare :: Options -> Options -> Ordering
$cp1Ord :: Eq Options
Ord, Int -> Options -> ShowS
[Options] -> ShowS
Options -> String
(Int -> Options -> ShowS)
-> (Options -> String) -> ([Options] -> ShowS) -> Show Options
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Options] -> ShowS
$cshowList :: [Options] -> ShowS
show :: Options -> String
$cshow :: Options -> String
showsPrec :: Int -> Options -> ShowS
$cshowsPrec :: Int -> Options -> ShowS
Show, ReadPrec [Options]
ReadPrec Options
Int -> ReadS Options
ReadS [Options]
(Int -> ReadS Options)
-> ReadS [Options]
-> ReadPrec Options
-> ReadPrec [Options]
-> Read Options
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Options]
$creadListPrec :: ReadPrec [Options]
readPrec :: ReadPrec Options
$creadPrec :: ReadPrec Options
readList :: ReadS [Options]
$creadList :: ReadS [Options]
readsPrec :: Int -> ReadS Options
$creadsPrec :: Int -> ReadS Options
Read)

defaultOptions :: Options
defaultOptions :: Options
defaultOptions =
  Options :: Bool -> Target -> Maybe Target -> Bool -> Bool -> Options
Options
    { verbose :: Bool
verbose = Bool
False,
      source :: Target
source = Target
PythonTarget,
      target :: Maybe Target
target = Maybe Target
forall a. Maybe a
Nothing,
      bundleRuntimeHeaders :: Bool
bundleRuntimeHeaders = Bool
True,
      embedOriginalCode :: Bool
embedOriginalCode = Bool
True
    }

header :: String -> String
header :: ShowS
header String
progName = String
"Usage: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
progName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" [convert | debug | execute] FILE"

options :: [OptDescr Flag]
options :: [OptDescr Flag]
options =
  [ String -> [String] -> ArgDescr Flag -> String -> OptDescr Flag
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
'h', Char
'?'] [String
"help"] (Flag -> ArgDescr Flag
forall a. a -> ArgDescr a
NoArg Flag
Help) String
"",
    String -> [String] -> ArgDescr Flag -> String -> OptDescr Flag
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
'v'] [String
"verbose"] (Flag -> ArgDescr Flag
forall a. a -> ArgDescr a
NoArg Flag
Verbose) String
"",
    String -> [String] -> ArgDescr Flag -> String -> OptDescr Flag
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [] [String
"version"] (Flag -> ArgDescr Flag
forall a. a -> ArgDescr a
NoArg Flag
Version) String
"",
    String -> [String] -> ArgDescr Flag -> String -> OptDescr Flag
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [] [String
"source"] ((String -> Flag) -> String -> ArgDescr Flag
forall a. (String -> a) -> String -> ArgDescr a
ReqArg String -> Flag
Source String
"SOURCE") String
"\"python\" or \"core\"",
    String -> [String] -> ArgDescr Flag -> String -> OptDescr Flag
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [] [String
"target"] ((String -> Flag) -> String -> ArgDescr Flag
forall a. (String -> a) -> String -> ArgDescr a
ReqArg String -> Flag
Target String
"TARGET") String
"\"python\", \"rpython\", \"core\" or \"cxx\"",
    String -> [String] -> ArgDescr Flag -> String -> OptDescr Flag
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [] [String
"bundle-runtime-headers"] (Flag -> ArgDescr Flag
forall a. a -> ArgDescr a
NoArg (Bool -> Flag
BundleRuntimeHeaders Bool
True)) String
"bundles C++ runtime headers",
    String -> [String] -> ArgDescr Flag -> String -> OptDescr Flag
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [] [String
"no-bundle-runtime-headers"] (Flag -> ArgDescr Flag
forall a. a -> ArgDescr a
NoArg (Bool -> Flag
BundleRuntimeHeaders Bool
False)) String
"",
    String -> [String] -> ArgDescr Flag -> String -> OptDescr Flag
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [] [String
"embed-original-code"] (Flag -> ArgDescr Flag
forall a. a -> ArgDescr a
NoArg (Bool -> Flag
EmbedOriginalCode Bool
True)) String
"embeds the original Python code",
    String -> [String] -> ArgDescr Flag -> String -> OptDescr Flag
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [] [String
"no-embed-original-code"] (Flag -> ArgDescr Flag
forall a. a -> ArgDescr a
NoArg (Bool -> Flag
EmbedOriginalCode Bool
False)) String
""
  ]

main :: String -> [String] -> IO ExitCode
main :: String -> [String] -> IO ExitCode
main String
name [String]
args = do
  let usage :: String
usage = String -> [OptDescr Flag] -> String
forall a. String -> [OptDescr a] -> String
usageInfo (ShowS
header String
name) [OptDescr Flag]
options
  case ArgOrder Flag
-> [OptDescr Flag] -> [String] -> ([Flag], [String], [String])
forall a.
ArgOrder a -> [OptDescr a] -> [String] -> ([a], [String], [String])
getOpt ArgOrder Flag
forall a. ArgOrder a
Permute [OptDescr Flag]
options [String]
args of
    ([Flag]
parsed, [String]
_, []) | Flag
Help Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
parsed -> do
      String -> IO ()
putStr String
usage
      ExitCode -> IO ExitCode
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
ExitSuccess
    ([Flag]
parsed, [String]
_, []) | Flag
Version Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
parsed -> do
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Char
'v' Char -> ShowS
forall a. a -> [a] -> [a]
: Version -> String
showVersion Version
version
      ExitCode -> IO ExitCode
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
ExitSuccess
    ([Flag]
parsed, [String
subcmd, String
path], []) -> case String -> [Flag] -> Either Error Options
parseFlags String
name [Flag]
parsed of
      Left Error
err -> do
        Handle -> Error -> IO ()
hPrintError Handle
stderr Error
err
        ExitCode -> IO ExitCode
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode -> IO ExitCode) -> ExitCode -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
1
      Right Options
opts -> do
        Either Error ()
result <- ExceptT Error IO () -> IO (Either Error ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Error IO () -> IO (Either Error ()))
-> ExceptT Error IO () -> IO (Either Error ())
forall a b. (a -> b) -> a -> b
$ String -> Options -> String -> ExceptT Error IO ()
runSubcommand String
subcmd Options
opts String
path
        case Either Error ()
result of
          Left Error
err -> do
            Text
text <- IO Text -> IO Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> IO Text) -> IO Text -> IO Text
forall a b. (a -> b) -> a -> b
$ String -> IO Text
T.readFile String
path
            Handle -> Text -> Error -> IO ()
hPrintErrorWithText Handle
stderr Text
text Error
err
            ExitCode -> IO ExitCode
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode -> IO ExitCode) -> ExitCode -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
1
          Right () -> do
            ExitCode -> IO ExitCode
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
ExitSuccess
    ([Flag]
_, [String]
_, [String]
errors) | [String]
errors [String] -> [String] -> Bool
forall a. Eq a => a -> a -> Bool
/= [] -> do
      [String] -> (String -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
errors ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
msg -> do
        let err :: Error
err = ErrorGroup -> Error -> Error
WithGroup ErrorGroup
CommandLineError (String -> Error
Error String
msg)
        Handle -> Error -> IO ()
hPrintError Handle
stderr Error
err
      ExitCode -> IO ExitCode
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode -> IO ExitCode) -> ExitCode -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
1
    ([Flag], [String], [String])
_ -> do
      Handle -> String -> IO ()
hPutStr Handle
stderr String
usage
      ExitCode -> IO ExitCode
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode -> IO ExitCode) -> ExitCode -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
1

parseFlags :: String -> [Flag] -> Either Error Options
parseFlags :: String -> [Flag] -> Either Error Options
parseFlags String
_ = Options -> [Flag] -> Either Error Options
go Options
defaultOptions
  where
    go :: Options -> [Flag] -> Either Error Options
    go :: Options -> [Flag] -> Either Error Options
go Options
opts [] = Options -> Either Error Options
forall a b. b -> Either a b
Right Options
opts
    go Options
opts (Flag
flag : [Flag]
flags) = case Flag
flag of
      Flag
Help -> String -> Either Error Options
forall (m :: * -> *) a. MonadError Error m => String -> m a
throwCommandLineError String
"parseFlags is not called when --help is specified"
      Flag
Version -> String -> Either Error Options
forall (m :: * -> *) a. MonadError Error m => String -> m a
throwCommandLineError String
"parseFlags is not called when --version is specified"
      Flag
Verbose -> Options -> [Flag] -> Either Error Options
go (Options
opts {verbose :: Bool
verbose = Bool
True}) [Flag]
flags
      Source String
source -> do
        Target
source <- String -> Either Error Target
parseTarget String
source
        Options -> [Flag] -> Either Error Options
go (Options
opts {source :: Target
source = Target
source}) [Flag]
flags
      Target String
target -> do
        Target
target <- String -> Either Error Target
parseTarget String
target
        Options -> [Flag] -> Either Error Options
go (Options
opts {target :: Maybe Target
target = Target -> Maybe Target
forall a. a -> Maybe a
Just Target
target}) [Flag]
flags
      BundleRuntimeHeaders Bool
p -> Options -> [Flag] -> Either Error Options
go (Options
opts {bundleRuntimeHeaders :: Bool
bundleRuntimeHeaders = Bool
p}) [Flag]
flags
      EmbedOriginalCode Bool
p -> Options -> [Flag] -> Either Error Options
go (Options
opts {embedOriginalCode :: Bool
embedOriginalCode = Bool
p}) [Flag]
flags

runSubcommand :: String -> Options -> FilePath -> ExceptT Error IO ()
runSubcommand :: String -> Options -> String -> ExceptT Error IO ()
runSubcommand String
subcmd Options
opts String
path = case String
subcmd of
  String
"convert" -> do
    Text
input <- IO Text -> ExceptT Error IO Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> ExceptT Error IO Text)
-> IO Text -> ExceptT Error IO Text
forall a b. (a -> b) -> a -> b
$ String -> IO Text
T.readFile String
path
    let target' :: Target
target' = Target -> Maybe Target -> Target
forall a. a -> Maybe a -> a
fromMaybe Target
CPlusPlusTarget (Options -> Maybe Target
target Options
opts)
    Text
output <- Either Error Text -> ExceptT Error IO Text
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either Error Text -> ExceptT Error IO Text)
-> Either Error Text -> ExceptT Error IO Text
forall a b. (a -> b) -> a -> b
$ Target -> Target -> String -> Text -> Either Error Text
Convert.run (Options -> Target
source Options
opts) Target
target' String
path Text
input
    Text
output <-
      if Target
target' Target -> Target -> Bool
forall a. Eq a => a -> a -> Bool
== Target
CPlusPlusTarget Bool -> Bool -> Bool
&& Options -> Bool
bundleRuntimeHeaders Options
opts
        then Text -> ExceptT Error IO Text
forall (m :: * -> *).
(MonadIO m, MonadError Error m) =>
Text -> m Text
BundleRuntime.run Text
output
        else Text -> ExceptT Error IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
output
    Text
output <-
      Text -> ExceptT Error IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> ExceptT Error IO Text) -> Text -> ExceptT Error IO Text
forall a b. (a -> b) -> a -> b
$
        if Target
target' Target -> Target -> Bool
forall a. Eq a => a -> a -> Bool
== Target
CPlusPlusTarget Bool -> Bool -> Bool
&& Options -> Bool
embedOriginalCode Options
opts
          then Text -> Text -> Text
EmbedOriginalCode.run Text
input Text
output
          else Text
output
    IO () -> ExceptT Error IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT Error IO ()) -> IO () -> ExceptT Error IO ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStr Text
output
  String
"debug" -> String -> ExceptT Error IO ()
Debug.run String
path -- TODO: make this subcommand convenient
  String
"execute" -> Target -> String -> ExceptT Error IO ()
Execute.run (Target -> Maybe Target -> Target
forall a. a -> Maybe a -> a
fromMaybe Target
CoreTarget (Options -> Maybe Target
target Options
opts)) String
path -- TODO: use source
  String
_ -> String -> ExceptT Error IO ()
forall (m :: * -> *) a. MonadError Error m => String -> m a
throwCommandLineError (String -> ExceptT Error IO ()) -> String -> ExceptT Error IO ()
forall a b. (a -> b) -> a -> b
$ String
"undefined subcommand: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
subcmd