WIP splitting of Target module and towards parallel buildsHEADmaster

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