diff options
Diffstat (limited to 'Coolbal/Target.hs')
| -rw-r--r-- | Coolbal/Target.hs | 175 |
1 files changed, 7 insertions, 168 deletions
diff --git a/Coolbal/Target.hs b/Coolbal/Target.hs index 68ac043..ae938fd 100644 --- a/Coolbal/Target.hs +++ b/Coolbal/Target.hs @@ -1,185 +1,24 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} module Coolbal.Target ( - IsTarget(..), AnyTarget(..), - ExeTarget(..), useAnyTarget, ) where -import Data.Binary (Binary) -import Data.Char (ord) -import Data.List (intercalate) -import Data.Time.Clock (UTCTime) import GHC.Generics (Generic) -import Numeric (showHex) -import System.Directory (createDirectoryIfMissing, doesFileExist, getModificationTime, removeDirectoryRecursive) -import System.Exit (ExitCode(..), die, exitWith) -import System.FilePath ((</>)) -import System.IO.Error (catchIOError) -import System.Process (rawSystem) -import Coolbal.Util +import Coolbal.EnvBinary +import Coolbal.Target.Class +import Coolbal.Target.Executable -class IsTarget a where - -- | The name of the target. - targetName :: a -> String - - -- | The name of the target, qualified with a cabal-style prefix indicating the kind of target. - targetNameQualified :: a -> String - - -- | The name of the target, qualified with a cabal-style prefix indicating - -- the kind of target, except that the ':' is rendered as a '-'. - targetNameQualifiedFilename :: a -> FilePath - targetNameQualifiedFilename tg = case break (== ':') (targetNameQualified tg) of - (pre, ':' : post) -> pre ++ '-' : post - _ -> error "targetNameQualifiedFilename: unexpected form of targetNameQualified" - - -- | Check whether the target must be recompiled due to changes on disk. - -- Argument is the root directory of the project. - targetCheckOld :: FilePath -> a -> IO Bool - - -- | Recompile the target. Argument is the root directory of the project. - targetBuild :: FilePath -> a -> IO () - - -- | If the target is an executable target, return an IO action that runs - -- the executable with the specified arguments. The 'FilePath' is the root - -- directory of the project. - targetExecute :: a -> Maybe (FilePath -> [String] -> IO ()) - - -- | Remove the build artifacts for this target. - targetRemoveBuildArtifacts :: FilePath -> a -> IO () - data AnyTarget = AnyTargetExe ExeTarget deriving (Show, Generic) -instance Binary AnyTarget +instance EnvBinary RestoreEnv AnyTarget -useAnyTarget :: (forall a. (Show a, Binary a, IsTarget a) => a -> r) -> AnyTarget -> r +useAnyTarget :: (forall a. (Show a, IsTarget a) => a -> r) -> AnyTarget -> r useAnyTarget f (AnyTargetExe x) = f x - -data ExeTarget = ExeTarget - { exeTargetName :: String - -- ^ Target name, and name of output executable file - , exeTargetPkgDbDir :: FilePath - -- ^ Absolute path to the package.db directory - , exeTargetDeps :: [String] - -- ^ Package identifiers of dependencies (for -package-id flags) - , exeTargetLanguage :: String - -- ^ Haskell language (e.g. Haskell2010) - , exeTargetMain :: FilePath - -- ^ Main file - , exeTargetSrcDirs :: [FilePath] - -- ^ Source directories - , exeTargetModules :: [[String]] - -- ^ Other modules in the target - , exeTargetFlags :: [String] - -- ^ User-specified compiler flags - } - deriving (Show, Generic) - -instance Binary ExeTarget - -instance IsTarget ExeTarget where - targetName = exeTargetName - targetNameQualified e = "exe:" ++ targetName e - - targetCheckOld projdir tg = do - mbinTm <- maybeModificationTime (projdir </> "dist-coolbal/bin" </> escapeFileName (exeTargetName tg)) - case mbinTm of - Just binTm -> do - anyNewerThan binTm (findFile' (exeTargetSrcDirs tg) (exeTargetMain tg) - : [findSourceFile' (exeTargetSrcDirs tg) m | m <- exeTargetModules tg]) - Nothing -> - return True - - targetBuild projdir tg = do - let buildDir = projdir </> "dist-coolbal/build" - </> escapeFileName (targetNameQualifiedFilename tg) - binDir = projdir </> "dist-coolbal/bin" - binName = binDir </> escapeFileName (exeTargetName tg) - createDirectoryIfMissing True binDir - rawSystem "ghc" (concat - [["--make", "-static"] - ,concat [[flag, buildDir] - | flag <- ["-outputdir", "-odir", "-hidir", "-stubdir"]] - ,["-i" ++ dir | dir <- exeTargetSrcDirs tg] - ,["-hide-all-packages", "-Wmissing-home-modules", "-no-user-package-db"] - ,["-package-db", exeTargetPkgDbDir tg] - ,concat [["-package-id", dep] | dep <- exeTargetDeps tg] - ,["-X" ++ exeTargetLanguage tg] - ,[exeTargetMain tg] - ,map (intercalate ".") (exeTargetModules tg) - ,["-o", binName] - ,exeTargetFlags tg]) - >>= checkExitCode - - targetExecute tg = Just $ \projdir args -> do - let filename = escapeFileName (exeTargetName tg) - rawSystem (projdir </> "dist-coolbal/bin" </> filename) args - >>= exitWith - - targetRemoveBuildArtifacts projdir tg = - removeDirectoryRecursive - (projdir </> "dist-coolbal/build" - </> escapeFileName (targetNameQualifiedFilename tg)) - -checkExitCode :: ExitCode -> IO () -checkExitCode ExitSuccess = return () -checkExitCode c@(ExitFailure _) = exitWith c - -escapeFileName :: String -> FilePath -escapeFileName = - -- NTFS/POSIX not allows: 0x00-0x1F 0x7F- : / " * < > ? \ | - -- We use ! as an escape character, and hence disallow that too. - genericEscapeString - (\c -> let n = ord c - in n <= 0x1F || n >= 0x7F || c `elem` ":/\"*<>?\\|!") - (\c -> case (c, ord c) of - ('!', _) -> "!!" - (_, n) | n <= 0xFF -> '!' : leftPad 2 '0' (showHex n "") - | n <= 0xFFFF -> '!' : 'u' : leftPad 4 '0' (showHex n "") - | n <= 0xFFFFFF -> '!' : 'U' : leftPad 6 '0' (showHex n "") - | otherwise -> error "Super-high unicode?") - where - leftPad n c s = replicate (max 0 (n - length s)) c ++ s - -maybeModificationTime' :: FilePath -> IO UTCTime -maybeModificationTime' path = maybeModificationTime path >>= \case - Just tm -> return tm - Nothing -> die ("File not found: '" ++ path ++ "'") - -maybeModificationTime :: FilePath -> IO (Maybe UTCTime) -maybeModificationTime path = - catchIOError (Just <$> getModificationTime path) (\_ -> return Nothing) - -findSourceFile' :: [FilePath] -> [String] -> IO FilePath -findSourceFile' ds m = findSourceFile ds m >>= \case - Just fp -> return fp - Nothing -> die ("Module not found in source directories: " ++ intercalate "." m) - -findSourceFile :: [FilePath] -> [String] -> IO (Maybe FilePath) -findSourceFile dirs modname = findFile dirs (foldr (</>) "" modname ++ ".hs") - -findFile' :: [FilePath] -> FilePath -> IO FilePath -findFile' ds fname = findFile ds fname >>= \case - Just fp -> return fp - Nothing -> die ("File not found in source directories: '" ++ fname ++ "'") - -findFile :: [FilePath] -> FilePath -> IO (Maybe FilePath) -findFile [] _ = return Nothing -findFile (dir:ds) fname = do - ok <- doesFileExist (dir </> fname) - if ok then return (Just (dir </> fname)) - else findFile ds fname - -anyNewerThan :: UTCTime -> [IO FilePath] -> IO Bool -anyNewerThan _ [] = return False -anyNewerThan reftm (fp:fps) = do - fp' <- fp - tm <- maybeModificationTime' fp' - if tm > reftm - then return True - else anyNewerThan reftm fps |