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
| IgnoreConfig
deriving (Flag -> Flag -> Bool
(Flag -> Flag -> Bool) -> (Flag -> Flag -> Bool) -> Eq Flag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Flag -> Flag -> Bool
== :: Flag -> Flag -> Bool
$c/= :: Flag -> Flag -> Bool
/= :: 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
$cfrom :: forall x. Flag -> Rep Flag x
from :: forall x. Flag -> Rep Flag x
$cto :: forall x. Rep Flag x -> Flag
to :: forall x. Rep Flag x -> Flag
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
$ccompare :: Flag -> Flag -> Ordering
compare :: Flag -> Flag -> Ordering
$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
>= :: Flag -> Flag -> Bool
$cmax :: Flag -> Flag -> Flag
max :: Flag -> Flag -> Flag
$cmin :: Flag -> Flag -> Flag
min :: Flag -> Flag -> 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
$creadsPrec :: Int -> ReadS Flag
readsPrec :: Int -> ReadS Flag
$creadList :: ReadS [Flag]
readList :: ReadS [Flag]
$creadPrec :: ReadPrec Flag
readPrec :: ReadPrec Flag
$creadListPrec :: ReadPrec [Flag]
readListPrec :: ReadPrec [Flag]
Read, Int -> Flag -> ShowS
[Flag] -> ShowS
Flag -> FilePath
(Int -> Flag -> ShowS)
-> (Flag -> FilePath) -> ([Flag] -> ShowS) -> Show Flag
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Flag -> ShowS
showsPrec :: Int -> Flag -> ShowS
$cshow :: Flag -> FilePath
show :: Flag -> FilePath
$cshowList :: [Flag] -> ShowS
showList :: [Flag] -> ShowS
Show)
instance NFData Flag
options :: [OptDescr Flag]
options :: [OptDescr Flag]
options = [ FilePath
-> [FilePath] -> ArgDescr Flag -> FilePath -> OptDescr Flag
forall a.
FilePath -> [FilePath] -> ArgDescr a -> FilePath -> OptDescr a
Option [Char
'h'] [FilePath
"help"] (Flag -> ArgDescr Flag
forall a. a -> ArgDescr a
NoArg Flag
Help) FilePath
"Explain CLI usage"
, FilePath
-> [FilePath] -> ArgDescr Flag -> FilePath -> OptDescr Flag
forall a.
FilePath -> [FilePath] -> ArgDescr a -> FilePath -> OptDescr a
Option [Char
'v'] [FilePath
"version"] (Flag -> ArgDescr Flag
forall a. a -> ArgDescr a
NoArg Flag
Version) FilePath
"Display version"
, FilePath
-> [FilePath] -> ArgDescr Flag -> FilePath -> OptDescr Flag
forall a.
FilePath -> [FilePath] -> ArgDescr a -> FilePath -> OptDescr a
Option [Char
'i'] [FilePath
"ignore-config"] (Flag -> ArgDescr Flag
forall a. a -> ArgDescr a
NoArg Flag
IgnoreConfig) FilePath
"Use default configuration"
]
launch :: IO ()
launch :: IO ()
launch = do
[FilePath]
args <- IO [FilePath]
getArgs
case ArgOrder Flag
-> [OptDescr Flag]
-> [FilePath]
-> ([Flag], [FilePath], [FilePath])
forall a.
ArgOrder a
-> [OptDescr a] -> [FilePath] -> ([a], [FilePath], [FilePath])
getOpt ArgOrder Flag
forall a. ArgOrder a
Permute [OptDescr Flag]
options [FilePath]
args of
([Flag]
optArgs, [], []) -> [Flag] -> IO ()
controlOptions [Flag]
optArgs
([Flag], [FilePath], [FilePath])
_ -> do IO ()
printUsage
IO ()
forall a. IO a
exitFailure
controlOptions :: [Flag] -> IO ()
controlOptions :: [Flag] -> IO ()
controlOptions [Flag]
flags
| Flag
Help Flag -> [Flag] -> Bool
forall a. Eq a => a -> [a] -> 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
IgnoreConfig] -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
[Flag]
_ -> do IO ()
printUsage
IO ()
forall a. IO a
exitFailure
printUsage :: IO ()
printUsage :: IO ()
printUsage = FilePath -> IO ()
putStr (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> [OptDescr Flag] -> FilePath
forall a. FilePath -> [OptDescr a] -> FilePath
usageInfo FilePath
header [OptDescr Flag]
options
where header :: FilePath
header = FilePath
"Usage: blucontrol [OPTIONS]"
printVersion :: IO ()
printVersion :: IO ()
printVersion = FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"blucontrol-" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Version -> FilePath
showVersion Version
version FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
" compiled with " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
compiler
where compiler :: FilePath
compiler = FilePath
compilerName FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"-" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Version -> FilePath
showVersion Version
compilerVersion
getXdgDir :: XdgDirectory -> IO FilePath
getXdgDir :: XdgDirectory -> IO FilePath
getXdgDir = (XdgDirectory -> FilePath -> IO FilePath)
-> FilePath -> XdgDirectory -> IO FilePath
forall a b c. (a -> b -> c) -> b -> a -> c
flip XdgDirectory -> FilePath -> IO FilePath
getXdgDirectory FilePath
"blucontrol"
build :: IO ()
build :: IO ()
build = do
FilePath
configPath <- (FilePath -> ShowS
</> FilePath
configLeafname) ShowS -> IO FilePath -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XdgDirectory -> IO FilePath
getXdgDir XdgDirectory
XdgConfig
Bool
configExists <- FilePath -> IO Bool
doesFileExist FilePath
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
FilePath
progName <- IO FilePath
getProgName
FilePath
compiledConfigPath <- (FilePath -> ShowS
</> FilePath
compiledConfigLeafname) ShowS -> IO FilePath -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XdgDirectory -> IO FilePath
getXdgDir XdgDirectory
XdgCache
if FilePath
progName FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
compiledConfigLeafname
then do UTCTime
configTime <- FilePath -> IO UTCTime
getModificationTime FilePath
configPath
UTCTime
compiledConfigTime <- FilePath -> IO UTCTime
getModificationTime FilePath
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
FilePath
-> Bool -> [FilePath] -> Maybe [(FilePath, FilePath)] -> IO ()
forall a.
FilePath
-> Bool -> [FilePath] -> Maybe [(FilePath, FilePath)] -> IO a
executeFile FilePath
compiledConfigPath Bool
False [] Maybe [(FilePath, FilePath)]
forall a. Maybe a
Nothing
else do IO ()
compile
FilePath
-> Bool -> [FilePath] -> Maybe [(FilePath, FilePath)] -> IO ()
forall a.
FilePath
-> Bool -> [FilePath] -> Maybe [(FilePath, FilePath)] -> IO a
executeFile FilePath
compiledConfigPath Bool
False [] Maybe [(FilePath, FilePath)]
forall a. Maybe a
Nothing
compile :: IO ()
compile :: IO ()
compile = do
FilePath
configDir <- XdgDirectory -> IO FilePath
getXdgDir XdgDirectory
XdgConfig
FilePath
cacheDir <- XdgDirectory -> IO FilePath
getXdgDir XdgDirectory
XdgCache
Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
False FilePath
cacheDir
let ghcFlags :: [FilePath]
ghcFlags = [ FilePath
"--make"
, FilePath
configLeafname
, FilePath
"-main-is", FilePath
"main"
, FilePath
"-v0"
, FilePath
"-o", FilePath
cacheDir FilePath -> ShowS
</> FilePath
compiledConfigLeafname
] [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
<> [FilePath]
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
=<<
FilePath
-> [FilePath]
-> Maybe FilePath
-> Maybe [(FilePath, FilePath)]
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO ProcessHandle
runProcess FilePath
ghcBinary [FilePath]
ghcFlags (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
configDir) Maybe [(FilePath, FilePath)]
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
ExitFailure Int
_ -> IO ()
forall a. IO a
exitFailure
compiledConfigLeafname :: FilePath
compiledConfigLeafname :: FilePath
compiledConfigLeafname = FilePath
"blucontrol-" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
arch FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"-" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
os
configLeafname :: FilePath
configLeafname :: FilePath
configLeafname = FilePath
"blucontrol.hs"