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 -- TODO: getModificationTime can fail
               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"