diff options
Diffstat (limited to 'Coolbal/Target.hs')
| -rw-r--r-- | Coolbal/Target.hs | 94 |
1 files changed, 80 insertions, 14 deletions
diff --git a/Coolbal/Target.hs b/Coolbal/Target.hs index c698ceb..761f19d 100644 --- a/Coolbal/Target.hs +++ b/Coolbal/Target.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE StandaloneDeriving #-} module Coolbal.Target ( IsTarget(..), AnyTarget(..), @@ -8,12 +8,16 @@ module Coolbal.Target ( 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) -import System.Exit (ExitCode(..), die) +import System.Directory (createDirectoryIfMissing, doesFileExist, getModificationTime) +import System.Exit (ExitCode(..), die, exitWith) import System.FilePath ((</>)) +import System.IO.Error (catchIOError) import System.Process (rawSystem) import Coolbal.Util @@ -40,12 +44,18 @@ class IsTarget a where -- | Recompile the target. Argument is the root directory of the project. targetBuild :: FilePath -> a -> IO () -data AnyTarget = forall a. (Show a, IsTarget a) => AnyTarget a + -- | 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 ()) -deriving instance Show AnyTarget +data AnyTarget = AnyTargetExe ExeTarget + deriving (Show, Generic) -useAnyTarget :: (forall a. (Show a, IsTarget a) => a -> r) -> AnyTarget -> r -useAnyTarget f (AnyTarget x) = f x +instance Binary AnyTarget + +useAnyTarget :: (forall a. (Show a, Binary a, IsTarget a) => a -> r) -> AnyTarget -> r +useAnyTarget f (AnyTargetExe x) = f x data ExeTarget = ExeTarget { exeTargetName :: String @@ -58,18 +68,29 @@ data ExeTarget = ExeTarget -- ^ 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) + deriving (Show, Generic) + +instance Binary ExeTarget instance IsTarget ExeTarget where targetName = exeTargetName targetNameQualified e = "exe:" ++ targetName e - targetCheckOld _ _ = return True + 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" @@ -81,7 +102,7 @@ instance IsTarget ExeTarget where [["--make", "-static"] ,concat [[flag, buildDir] | flag <- ["-outputdir", "-odir", "-hidir", "-stubdir"]] - ,["-i" ++ buildDir, "-I" ++ buildDir] + ,["-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] @@ -92,6 +113,11 @@ instance IsTarget ExeTarget where ,exeTargetFlags tg]) >>= checkExitCode "ghc" + targetExecute tg = Just $ \projdir args -> do + let filename = escapeFileName (exeTargetName tg) + rawSystem (projdir </> "dist-coolbal/bin" </> filename) args + >>= exitWith + checkExitCode :: String -> ExitCode -> IO () checkExitCode _ ExitSuccess = return () checkExitCode procname (ExitFailure c) = @@ -106,7 +132,47 @@ escapeFileName = in n <= 0x1F || n >= 0x7F || c `elem` ":/\"*<>?\\|!") (\c -> case (c, ord c) of ('!', _) -> "!!" - (_, n) | n <= 0xFF -> '!' : showHex n "" - | n <= 0xFFFF -> '!' : 'u' : showHex n "" - | n <= 0xFFFFFF -> '!' : 'U' : showHex n "" + (_, 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 |