module System.JBI.Commands.Tool where
import System.JBI.Config
import System.JBI.Tagged
import Control.Applicative (liftA2)
import Control.Monad (when)
import Data.Aeson (ToJSON(toJSON))
import Data.Char (isDigit)
import Data.Maybe (listToMaybe)
import Data.String (IsString(..))
import Data.Version (Version, parseVersion)
import GHC.Generics (Generic)
import System.Directory (findExecutable)
import System.Exit (ExitCode(ExitSuccess))
import System.IO (IOMode(WriteMode), hPutStrLn, stderr,
withFile)
import System.Process (CreateProcess(..),
StdStream(Inherit, UseHandle), proc,
readProcessWithExitCode,
showCommandForUser, waitForProcess,
withCreateProcess)
import Text.ParserCombinators.ReadP (eof, readP_to_S)
class Tool t where
commandName :: Tagged t CommandName
commandVersion :: Config -> Tagged t CommandPath -> IO (Maybe (Tagged t Version))
commandVersion = withTaggedF . tryFindVersion
commandPath :: (Tool t) => IO (Maybe (Tagged t CommandPath))
commandPath = withTaggedF findExecutable commandName
commandInformation :: (Tool t) => Config -> IO (Maybe (Installed t))
commandInformation cfg = commandPath >>= mapM getVersion
where
getVersion :: (Tool t') => Tagged t' CommandPath -> IO (Installed t')
getVersion tcp = Installed tcp <$> commandVersion cfg tcp
data GHC
instance Tool GHC where
commandName = "ghc"
newtype CommandName = CommandName { nameOfCommand :: String }
deriving (Eq, Ord, Show, Read)
instance IsString CommandName where
fromString = CommandName
newtype CommandPath = CommandPath { pathToCommand :: FilePath }
deriving (Eq, Ord, Show, Read)
instance ToJSON CommandPath where
toJSON = toJSON . pathToCommand
instance IsString CommandPath where
fromString = CommandPath
data Installed t = Installed
{ path :: !(Tagged t CommandPath)
, version :: !(Maybe (Tagged t Version))
} deriving (Eq, Ord, Show, Read, Generic, ToJSON)
tryFindVersion :: Config -> FilePath -> IO (Maybe Version)
tryFindVersion = tryFindVersionBy findVersion
where
findVersion str = takeVersion (dropWhile (not . isDigit) str)
takeVersion :: String -> String
takeVersion = takeWhile (liftA2 (||) isDigit (=='.'))
tryFindVersionBy :: (String -> String) -> Config -> FilePath -> IO (Maybe Version)
tryFindVersionBy findVersion cfg cmd =
fmap (>>= parseVer) (tryRunOutput cfg cmd ["--version"])
where
parseVer ver = case readP_to_S (parseVersion <* eof) (findVersion ver) of
[(v,"")] -> Just v
_ -> Nothing
type Args = [String]
tryRunOutput :: Config -> FilePath -> Args -> IO (Maybe String)
tryRunOutput cfg cmd args = do
printDebug cfg cmd args
res <- readProcessWithExitCode cmd args ""
return $ case res of
(ExitSuccess, out, "" ) -> Just out
(ExitSuccess, "", err) -> Just err
_ -> Nothing
tryRunLine :: Config -> FilePath -> Args -> IO (Maybe String)
tryRunLine cfg cmd = fmap (>>= listToMaybe . lines) . tryRunOutput cfg cmd
tryRun :: Config -> Tagged t CommandPath -> Args -> IO ExitCode
tryRun cfg cmd args = do
printDebug cfg cmd' args
withCreateProcess cp $ \_ _ _ ph ->
waitForProcess ph
where
cmd' = stripTag cmd
cp = (proc cmd' args) { std_in = Inherit
, std_out = Inherit
, std_err = Inherit
}
tryRunErr :: String -> IO ExitCode -> IO ExitCode
tryRunErr msg act = do
res <- act
if res == ExitSuccess
then return res
else res <$ hPutStrLn stderr msg
tryRunToFile :: Config -> FilePath -> Tagged t CommandPath -> Args -> IO ExitCode
tryRunToFile cfg file cmd args = do
printDebug cfg cmd' args
withFile file WriteMode $ \h ->
withCreateProcess (cp h) $ \_ _ _ ph ->
waitForProcess ph
where
cmd' = stripTag cmd
cp h = (proc cmd' args) { std_in = Inherit
, std_out = UseHandle h
, std_err = Inherit
}
printDebug :: Config -> FilePath -> Args -> IO ()
printDebug cfg cmd args =
when (debugMode cfg) (hPutStrLn stderr (makeBox ("Running: " ++ cmdStr)))
where
cmdStr = showCommandForUser cmd args
(.&&.) :: (Monad m) => m ExitCode -> m ExitCode -> m ExitCode
m1 .&&. m2 = do ec1 <- m1
case ec1 of
ExitSuccess -> m2
_ -> return ec1
infixr 3 .&&.
(.||.) :: (Monad m) => m ExitCode -> m ExitCode -> m ExitCode
m1 .||. m2 = do ec1 <- m1
case ec1 of
ExitSuccess -> return ec1
_ -> m2
infixr 2 .||.
tryCommand :: String -> IO ExitCode -> IO ExitCode -> IO ExitCode
tryCommand msg tryWith run = run .||. tryAgain
where
tryAgain = do
putStrLn (makeBox msg)
tryWith .&&. run
makeBox :: String -> String
makeBox msg = unlines [ border
, "* " ++ msg ++ " *"
, border
]
where
msgLen = length msg
boxLen = msgLen + 4
border = replicate boxLen '*'
allSuccess :: (Monad m, Foldable t) => t (m ExitCode) -> m ExitCode
allSuccess = foldr (.&&.) (return ExitSuccess)
allM :: Monad m => (a -> m Bool) -> [a] -> m Bool
allM _ [] = return True
allM f (b:bs) = f b >>= (\bv -> if bv then allM f bs else return False)