module Blucontrol.Main.CLI (
  launch
) where

import Control.DeepSeq
import Control.Monad (when)
import Data.Version (showVersion)
import GHC.Generics
import System.Console.GetOpt
import System.Directory (XdgDirectory (..), createDirectoryIfMissing, doesFileExist, getModificationTime, getXdgDirectory)
import System.Environment (getArgs, getProgName)
import System.Exit (ExitCode (..), exitFailure, exitSuccess)
import System.FilePath ((</>))
import System.Info (arch, compilerName, compilerVersion, os)
import System.Posix.Process (executeFile)
import System.Process (runProcess, waitForProcess)

import Blucontrol.Main.GHC.Internal
import Paths_blucontrol (version)

data Flag = Help
          | Version
  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, (forall x. Flag -> Rep Flag x)
-> (forall x. Rep Flag x -> Flag) -> Generic Flag
forall x. Rep Flag x -> Flag
forall x. Flag -> Rep Flag x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Flag x -> Flag
$cfrom :: forall x. Flag -> Rep Flag x
Generic, 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, 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, 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)

instance NFData Flag

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'] [String
"help"] (Flag -> ArgDescr Flag
forall a. a -> ArgDescr a
NoArg Flag
Help) String
"Explain CLI usage"
          , String -> [String] -> ArgDescr Flag -> String -> OptDescr Flag
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
'v'] [String
"version"] (Flag -> ArgDescr Flag
forall a. a -> ArgDescr a
NoArg Flag
Version) String
"Display version"
          ]

launch :: IO ()
launch :: IO ()
launch = do
  [String]
args <- IO [String]
getArgs
  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]
optArgs, [], []) -> [Flag] -> IO ()
controlOptions [Flag]
optArgs
    ([Flag], [String], [String])
_ -> do IO ()
printUsage
            IO ()
forall a. IO a
exitFailure

controlOptions :: [Flag] -> IO ()
controlOptions :: [Flag] -> IO ()
controlOptions [Flag]
flags
  | Flag
Help Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags = do IO ()
printUsage
                           IO ()
forall a. IO a
exitSuccess
  | Bool
otherwise = case [Flag]
flags of
    [] -> IO ()
build
    [Flag
Version] -> do IO ()
printVersion
                    IO ()
forall a. IO a
exitSuccess
    [Flag]
_ -> do IO ()
printUsage
            IO ()
forall a. IO a
exitFailure

printUsage :: IO ()
printUsage :: IO ()
printUsage = String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> [OptDescr Flag] -> String
forall a. String -> [OptDescr a] -> String
usageInfo String
header [OptDescr Flag]
options
  where header :: String
header = String
"Usage: blucontrol [OPTIONS]"

printVersion :: IO ()
printVersion :: IO ()
printVersion = String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"blucontrol-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Version -> String
showVersion Version
version String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" compiled with " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
compiler
  where compiler :: String
compiler = String
compilerName String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Version -> String
showVersion Version
compilerVersion

getXdgDir :: XdgDirectory -> IO FilePath
getXdgDir :: XdgDirectory -> IO String
getXdgDir = (XdgDirectory -> String -> IO String)
-> String -> XdgDirectory -> IO String
forall a b c. (a -> b -> c) -> b -> a -> c
flip XdgDirectory -> String -> IO String
getXdgDirectory String
"blucontrol"

build :: IO ()
build :: IO ()
build = do
  String
configPath <- (String -> ShowS
</> String
configLeafname) ShowS -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XdgDirectory -> IO String
getXdgDir XdgDirectory
XdgConfig
  Bool
configExists <- String -> IO Bool
doesFileExist String
configPath
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
configExists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    String
progName <- IO String
getProgName
    String
compiledConfigPath <- (String -> ShowS
</> String
compiledConfigLeafname) ShowS -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XdgDirectory -> IO String
getXdgDir XdgDirectory
XdgCache
    if String
progName String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
compiledConfigLeafname
       then do UTCTime
configTime <- String -> IO UTCTime
getModificationTime String
configPath -- TODO: getModificationTime can fail
               UTCTime
compiledConfigTime <- String -> IO UTCTime
getModificationTime String
compiledConfigPath
               Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UTCTime
configTime UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> UTCTime
compiledConfigTime) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                 IO ()
compile
                 String -> Bool -> [String] -> Maybe [(String, String)] -> IO ()
forall a.
String -> Bool -> [String] -> Maybe [(String, String)] -> IO a
executeFile String
compiledConfigPath Bool
False [] Maybe [(String, String)]
forall a. Maybe a
Nothing
       else do IO ()
compile
               String -> Bool -> [String] -> Maybe [(String, String)] -> IO ()
forall a.
String -> Bool -> [String] -> Maybe [(String, String)] -> IO a
executeFile String
compiledConfigPath Bool
False [] Maybe [(String, String)]
forall a. Maybe a
Nothing

compile :: IO ()
compile :: IO ()
compile = do
  String
configDir <- XdgDirectory -> IO String
getXdgDir XdgDirectory
XdgConfig
  String
cacheDir <- XdgDirectory -> IO String
getXdgDir XdgDirectory
XdgCache
  Bool -> String -> IO ()
createDirectoryIfMissing Bool
False String
cacheDir
  let ghcFlags :: [String]
ghcFlags = [ String
"--make"
                 , String
configLeafname
                 , String
"-main-is", String
"main"
                 , String
"-v0"
                 , String
"-o", String
cacheDir String -> ShowS
</> String
compiledConfigLeafname
                 ] [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
ghcAdditionalFlags
  ExitCode
status <- ProcessHandle -> IO ExitCode
waitForProcess (ProcessHandle -> IO ExitCode) -> IO ProcessHandle -> IO ExitCode
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
    String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO ProcessHandle
runProcess String
ghcBinary [String]
ghcFlags (String -> Maybe String
forall a. a -> Maybe a
Just String
configDir) Maybe [(String, String)]
forall a. Maybe a
Nothing Maybe Handle
forall a. Maybe a
Nothing Maybe Handle
forall a. Maybe a
Nothing Maybe Handle
forall a. Maybe a
Nothing
  case ExitCode
status of
    ExitCode
ExitSuccess -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    ExitFailure Int
_ -> IO ()
forall a. IO a
exitFailure

compiledConfigLeafname :: FilePath
compiledConfigLeafname :: String
compiledConfigLeafname = String
"blucontrol-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
arch String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
os

configLeafname :: FilePath
configLeafname :: String
configLeafname = String
"blucontrol.hs"