ehaskell-0.7: EHaskellTools.hs

module EHaskellTools (
  createEhsDir
, copyModuleFile
, writeCode
, makeExe
, runExe
, processOptionEhs
) where

import System.Directory   (createDirectory, doesDirectoryExist, copyFile,
                           doesFileExist)
import System.FilePath    (takeDirectory, takeFileName)
import System.Process     (runProcess, waitForProcess)
import System.Exit        (ExitCode(ExitSuccess), exitWith)
import Data.Maybe         (maybeToList)
import Data.Function.Tools(applyUnless, apply2way)
import Control.Monad      (unless)
import Control.Monad.Tools(unlessM, whenM)
import Text.RegexPR       (gsubRegexPR)
import YJTools.Tribial    (ghcMake)

addDir :: FilePath -> FilePath -> FilePath
addDir dir fp = applyUnless (null dir) ((dir ++ "/") ++) fp

edir :: FilePath -> FilePath
edir infile = let d = takeDirectory infile
               in applyUnless (null d) ((d ++ "/") ++) "_ehs/"

createEhsDir :: FilePath -> IO ()
createEhsDir = apply2way unlessM doesDirectoryExist createDirectory . edir

copyModuleFile :: FilePath -> String -> IO ()
copyModuleFile infile modName
  = let dir = takeDirectory infile
        src = addDir dir $ modName ++ ".hs"
     in whenM (doesFileExist src) $
              copyFile src (edir infile ++ modName ++ ".hs")

writeCode :: FilePath -> String -> IO ()
writeCode infile code = do
  let exeName = gsubRegexPR "\\." "_" $ takeFileName infile
      srcFile = edir infile ++ exeName ++ ".hs"
  writeFile srcFile code

makeExe :: FilePath -> IO ()
makeExe infile = do
  let exeName = gsubRegexPR "\\." "_" $ takeFileName infile
  exitIfFail $ ghcMake exeName $ edir infile

runExe :: FilePath -> Maybe FilePath -> IO ()
runExe infile outfile = do
  let exeName = gsubRegexPR "\\." "_" $ takeFileName infile
      exeFile = edir infile ++ exeName
  exitIfFail $ runProcess exeFile (maybeToList outfile) Nothing Nothing Nothing Nothing Nothing
    >>= waitForProcess

exitIfFail :: IO ExitCode -> IO ()
exitIfFail act = do
  ec <- act
  unless (ec == ExitSuccess) $ exitWith ec

processOptionEhs :: [ String ] -> ( [ String ], Maybe String, String )
processOptionEhs args
  = let (eqs, args_)        = (takeOptionEq args, dropOptionEq args)
        (outfile, [infile]) = (takeOptionO args_, dropOptionO args_)
     in (eqs, outfile, infile)

takeOptionO :: [ String ] -> Maybe String
takeOptionO []         = Nothing
takeOptionO ("-o":f:_) = Just f
takeOptionO (_:as)     = takeOptionO as
dropOptionO :: [ String ] -> [ String ]
dropOptionO []          = []
dropOptionO ("-o":_:as) = as
dropOptionO (a:as)      = a : dropOptionO as

takeOptionEq :: [ String ] -> [ String ]
takeOptionEq [] = []
takeOptionEq (('-':_):as) = takeOptionEq as
takeOptionEq (a:as)
  | elem '=' a = a : takeOptionEq as
  | otherwise  =     takeOptionEq as
dropOptionEq :: [ String ] -> [ String ]
dropOptionEq [] = []
dropOptionEq (a@('-':_):as) = a : dropOptionEq as
dropOptionEq (a:as)
  | elem '=' a = dropOptionEq as
  | otherwise  = a : dropOptionEq as