1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
|
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# 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
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
useAnyTarget :: (forall a. (Show a, Binary 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
|
