-
Notifications
You must be signed in to change notification settings - Fork 370
/
Build.hs
191 lines (168 loc) · 6.63 KB
/
Build.hs
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
186
187
188
189
190
191
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Build
( getDeps
, touchDeps
, touch
, recompDeps
) where
-- FIXME there's a bug when getFileStatus applies to a file
-- temporary deleted (e.g., Vim saving a file)
import Control.Applicative ((<|>), many)
import qualified Data.Attoparsec.Text.Lazy as A
import Data.Char (isSpace, isUpper)
import qualified Data.Text.Lazy.IO as TIO
import Control.Exception (SomeException, try)
import Control.Monad (when, filterM, forM, forM_, (>=>))
import Data.Monoid (mappend)
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified System.Posix.Types
import System.Directory
import System.FilePath (takeExtension, replaceExtension, (</>))
import System.PosixCompat.Files (getFileStatus, setFileTimes,
accessTime, modificationTime)
touch :: IO ()
touch = touchDeps id updateFileTime =<< fmap snd (getDeps [])
recompDeps :: [FilePath] -> IO ()
recompDeps = getDeps >=> touchDeps hiFile removeHi . snd
type Deps = Map.Map FilePath (Set.Set FilePath)
getDeps :: [FilePath] -> IO ([FilePath], Deps)
getDeps hsSourceDirs = do
let defSrcDirs = case hsSourceDirs of
[] -> ["."]
ds -> ds
hss <- fmap concat $ mapM findHaskellFiles defSrcDirs
deps' <- mapM determineDeps hss
return $ (hss, fixDeps $ zip hss deps')
touchDeps :: (FilePath -> FilePath) ->
(FilePath -> FilePath -> IO ()) ->
Deps -> IO ()
touchDeps f action deps = (mapM_ go . Map.toList) deps
where
go (x, ys) =
forM_ (Set.toList ys) $ \y -> do
n <- x `isNewerThan` f y
when n $ do
putStrLn ("Forcing recompile for " ++ y ++ " because of " ++ x)
action x y
-- | remove the .hi files for a .hs file, thereby forcing a recompile
removeHi :: FilePath -> FilePath -> IO ()
removeHi _ hs = mapM_ removeFile' hiFiles
where
removeFile' file = try' (removeFile file) >> return ()
hiFiles = map (\e -> "dist/build" </> replaceExtension hs e)
["hi", "p_hi"]
-- | change file mtime of .hs file to that of the dependency
updateFileTime :: FilePath -> FilePath -> IO ()
updateFileTime x hs = do
(_ , modx) <- getFileStatus' x
(access, _ ) <- getFileStatus' hs
_ <- try' (setFileTimes hs access modx)
return ()
hiFile :: FilePath -> FilePath
hiFile hs = "dist/build" </> replaceExtension hs "hi"
try' :: IO x -> IO (Either SomeException x)
try' = try
isNewerThan :: FilePath -> FilePath -> IO Bool
isNewerThan f1 f2 = do
(_, mod1) <- getFileStatus' f1
(_, mod2) <- getFileStatus' f2
return (mod1 > mod2)
getFileStatus' :: FilePath ->
IO (System.Posix.Types.EpochTime, System.Posix.Types.EpochTime)
getFileStatus' fp = do
efs <- try' $ getFileStatus fp
case efs of
Left _ -> return (0, 0)
Right fs -> return (accessTime fs, modificationTime fs)
fixDeps :: [(FilePath, [FilePath])] -> Deps
fixDeps =
Map.unionsWith mappend . map go
where
go :: (FilePath, [FilePath]) -> Deps
go (x, ys) = Map.fromList $ map (\y -> (y, Set.singleton x)) ys
findHaskellFiles :: FilePath -> IO [FilePath]
findHaskellFiles path = do
contents <- getDirectoryContents path
fmap concat $ mapM go contents
where
go ('.':_) = return []
go filename = do
d <- doesDirectoryExist full
if not d
then if isHaskellFile
then return [full]
else return []
else if isHaskellDir
then findHaskellFiles full
else return []
where
-- this could fail on unicode
isHaskellDir = isUpper (head filename)
isHaskellFile = takeExtension filename `elem` watch_files
full = path </> filename
watch_files = [".hs", ".lhs"]
data TempType = StaticFiles FilePath
| Verbatim | Messages FilePath | Hamlet
deriving Show
determineDeps :: FilePath -> IO [FilePath]
determineDeps x = do
y <- TIO.readFile x -- FIXME catch IO exceptions
let z = A.parse (many $ (parser <|> (A.anyChar >> return Nothing))) y
case z of
A.Fail{} -> return []
A.Done _ r -> mapM go r >>= filterM doesFileExist . concat
where
go (Just (StaticFiles fp, _)) = getFolderContents fp
go (Just (Hamlet, f)) = return [f, "templates/" ++ f ++ ".hamlet"]
go (Just (Verbatim, f)) = return [f]
go (Just (Messages f, _)) = return [f]
go Nothing = return []
parser = do
ty <- (do _ <- A.string "\nstaticFiles \""
x' <- A.many1 $ A.satisfy (/= '"')
return $ StaticFiles x')
<|> (A.string "$(parseRoutesFile " >> return Verbatim)
<|> (A.string "$(hamletFile " >> return Hamlet)
<|> (A.string "$(ihamletFile " >> return Hamlet)
<|> (A.string "$(whamletFile " >> return Hamlet)
<|> (A.string "$(html " >> return Hamlet)
<|> (A.string "$(widgetFile " >> return Hamlet)
<|> (A.string "$(Settings.hamletFile " >> return Hamlet)
<|> (A.string "$(Settings.widgetFile " >> return Hamlet)
<|> (A.string "$(persistFile " >> return Verbatim)
<|> (
A.string "$(persistFileWith " >>
A.many1 (A.satisfy (/= '"')) >>
return Verbatim)
<|> (do
_ <- A.string "\nmkMessage \""
A.skipWhile (/= '"')
_ <- A.string "\" \""
x' <- A.many1 $ A.satisfy (/= '"')
_ <- A.string "\" \""
y <- A.many1 $ A.satisfy (/= '"')
_ <- A.string "\""
return $ Messages $ concat [x', "/", y, ".msg"])
case ty of
Messages{} -> return $ Just (ty, "")
StaticFiles{} -> return $ Just (ty, "")
_ -> do
A.skipWhile isSpace
_ <- A.char '"'
y <- A.many1 $ A.satisfy (/= '"')
_ <- A.char '"'
A.skipWhile isSpace
_ <- A.char ')'
return $ Just (ty, y)
getFolderContents :: FilePath -> IO [FilePath]
getFolderContents fp = do
cs <- getDirectoryContents fp
let notHidden ('.':_) = False
notHidden ('t':"mp") = False
notHidden _ = True
fmap concat $ forM (filter notHidden cs) $ \c -> do
let f = fp ++ '/' : c
isFile <- doesFileExist f
if isFile then return [f] else getFolderContents f