Merge pull request #334 from jacereda/decouple-autodeps

Decouple AutoDeps from linter

src/Development/Shake/Args.hs

@@ -6,6 +6,7 @@ import Paths_shake
 import Development.Shake.Types
 import Development.Shake.Core
 import Development.Shake.Demo
+import Development.Shake.FilePath
 import Development.Shake.Rules.File
 import Development.Shake.Progress
 import Development.Shake.Shake
@@ -115,7 +116,12 @@ shakeArgsWith baseOpts userOptions rules = do
         progressRecords = [x | ProgressRecord x <- flagsExtra]
         changeDirectory = listToMaybe [x | ChangeDirectory x <- flagsExtra]
         printDirectory = last $ False : [x | PrintDirectory x <- flagsExtra]
-        shakeOpts = foldl' (flip ($)) baseOpts flagsShake
+        oshakeOpts = foldl' (flip ($)) baseOpts flagsShake
+        shakeOpts = oshakeOpts {shakeLintInside = map (toStandard . normalise . addTrailingPathSeparator) $
+                                                  shakeLintInside oshakeOpts
+                               ,shakeLintIgnore = map toStandard $
+                                                  shakeLintIgnore oshakeOpts
+                               }
 
     -- error if you pass some clean and some dirty with specific flags
     errs <- return $ errs ++ flagsError ++ ["cannot mix " ++ a ++ " and " ++ b | a:b:_ <-
@@ -277,7 +283,6 @@ shakeOptsEx =
     ,yes $ Option "j" ["jobs"] (optIntArg 0 "jobs" "N" $ \i s -> s{shakeThreads=fromMaybe 0 i}) "Allow N jobs/threads at once [default CPUs]."
     ,yes $ Option "k" ["keep-going"] (noArg $ \s -> s{shakeStaunch=True}) "Keep going when some targets can't be made."
     ,yes $ Option "l" ["lint"] (noArg $ \s -> s{shakeLint=Just LintBasic}) "Perform limited validation after the run."
-    ,yes $ Option ""  ["lint-tracker"] (noArg $ \s -> s{shakeLint=Just LintTracker}) "Use tracker.exe to do validation."
     ,yes $ Option ""  ["lint-fsatrace"] (noArg $ \s -> s{shakeLint=Just LintFSATrace}) "Use fsatrace to do validation."
     ,yes $ Option ""  ["no-lint"] (noArg $ \s -> s{shakeLint=Nothing}) "Turn off --lint."
     ,yes $ Option ""  ["live"] (OptArg (\x -> Right ([], \s -> s{shakeLiveFiles=shakeLiveFiles s ++ [fromMaybe "live.txt" x]})) "FILE") "List the files that are live [to live.txt]."

src/Development/Shake/CmdOption.hs

@@ -24,5 +24,5 @@ data CmdOption
     | EchoStderr Bool -- ^ Should I echo the @stderr@? Defaults to 'True' unless a 'Stderr' result is required or you use 'FileStderr'.
     | FileStdout FilePath -- ^ Should I put the @stdout@ to a file.
     | FileStderr FilePath -- ^ Should I put the @stderr@ to a file.
-    | AutoDeps -- ^ Compute dependencies automatically. Requires either 'LintFSATrace' or 'LintTracker'.
+    | AutoDeps -- ^ Compute dependencies automatically.
       deriving (Eq,Ord,Show,Data,Typeable)

src/Development/Shake/Command.hs

@@ -123,79 +123,51 @@ commandExplicit funcName icopts results exe args = do
             [] -> traced (takeFileName exe)
 
     let tracker act = case shakeLint opts of
-            Just LintTracker -> winTracker act
             Just LintFSATrace -> fsatrace act
-            _ -> act exe args
-        track (rs,ws) = do
+            _ -> if autodepping then autodeps act else act exe args
+        autodepping = AutoDeps `elem` copts
+        inside = shakeLintInside opts
+        ignore = map (?==) $ shakeLintIgnore opts
+        ham cwd xs = [makeRelative cwd x | x <- map toStandard xs
+                                         , any (`isPrefixOf` x) inside
+                                         , not $ any ($ x) ignore]
+        withTemp f cont = do
+            (x, cleanup) <- liftIO f
+            actionFinally (cont x) cleanup
+
+        fsatrace act = withTemp newTempFile $ \file -> do
+            res <- act "fsatrace" $ file:"--":exe:args
+            xs <- liftIO $ parseFSAT "rwm" <$> readFileUTF8' file
             cwd <- liftIO getCurrentDirectory
-            let inside = map (toStandard . addTrailingPathSeparator . normalise) $ shakeLintInside opts
-                ignore = map (?==) $ shakeLintIgnore opts
-                ham xs = [x | x <- map toStandard xs
-                            , any (`isPrefixOf` x) inside
-                            , not $ any ($ x) ignore]
-                rel = map (makeRelative cwd)
-                reads = rel $ ham rs
-                writes = rel $ ham ws
-            when (AutoDeps `elem` copts) $
+            let reader (FSATRead x) = Just x; reader _ = Nothing
+                writer (FSATWrite x) = Just x; writer (FSATMove x _) = Just x; writer _ = Nothing
+                existing f = liftIO . filterM doesFileExist . nubOrd . mapMaybe f
+            rs <- existing reader xs
+            ws <- existing writer xs
+            let reads = ham cwd rs
+                writes = ham cwd ws
+            when autodepping $
                 needed reads
             trackRead reads
             trackWrite writes
+            return res
 
-        winTracker act = do
-            (dir, cleanup) <- liftIO newTempDir
-            flip actionFinally cleanup $ do
-                res <- act "tracker" $ "/if":dir:"/c":exe:args
-                liftIO (trackerFiles dir) >>= track
-                return res
-
-        fsatrace act = do
-            (file, cleanup) <- liftIO newTempFile
-            flip actionFinally cleanup $ do
-                res <- act "fsatrace" $ file:"--":exe:args
-                liftIO (fsatraceFiles file) >>= track
-                return res
+        autodeps act = withTemp newTempFile $ \file -> do
+            res <-  act "fsatrace" $ file:"--":exe:args
+            xs <- liftIO $ parseFSAT "r" <$> readFileUTF8' file
+            cwd <- liftIO getCurrentDirectory
+            let reader (FSATRead x) = x
+                reader _ = error "autodeps"
+            needNorm $ ham cwd $ map reader xs
+            return res
 
     skipper $ tracker $ \exe args -> verboser $ tracer $ commandExplicitIO funcName copts results exe args
 
 
--- | Given a directory (as passed to tracker /if) report on which files were used for reading/writing
-trackerFiles :: FilePath -> IO ([FilePath], [FilePath])
-trackerFiles dir = do
-    files <- getDirectoryContents dir
-    let f typ = do
-            files <- forM [x | x <- files, takeExtension x == ".tlog", takeExtension (dropExtension $ dropExtension x) == '.':typ] $ \file ->
-                fmap lines $ readFileEncoding utf16 $ dir </> file
-            fmap nubOrd $ mapMaybeM correctCase $ nubOrd $ concat files
-    liftM2 (,) (f "read") (f "write")
-
-
-correctCase :: FilePath -> IO (Maybe FilePath)
-correctCase = uncurry f . splitDrive
-    where
-        f pre "" = return $ Just pre
-        f pre x = do
-            let (a,b) = (takeDirectory1 x, dropDirectory1 x)
-            dir <- getDirectoryContents pre
-            case find ((==) a . upper) dir of
-                Nothing -> return Nothing -- if it can't be found it probably doesn't exist, so assume a file that wasn't really read
-                Just v -> f (pre </> v) b
-
-
-fsatraceFiles :: FilePath -> IO ([FilePath], [FilePath])
-fsatraceFiles file = do
-    xs <- parseFSAT <$> readFileUTF8 file
-    let reader (FSATRead x) = Just x; reader _ = Nothing
-        writer (FSATWrite x) = Just x; writer (FSATMove x _) = Just x; writer _ = Nothing
-        existing f = liftIO . filterM doesFileExist . nubOrd . mapMaybe f
-    frs <- existing reader xs
-    fws <- existing writer xs
-    return (frs, fws)
-
-
 data FSAT = FSATWrite FilePath | FSATRead FilePath | FSATMove FilePath FilePath | FSATDelete FilePath
 
-parseFSAT :: String -> [FSAT] -- any parse errors are skipped
-parseFSAT = mapMaybe (f . wordsBy (== '|')) . lines
+parseFSAT :: String -> String -> [FSAT] -- any parse errors are skipped
+parseFSAT ops = mapMaybe (f . wordsBy (== '|')) . filter ((`elem` ops) . head) . lines
     where f ["w",x] = Just $ FSATWrite x
           f ["r",x] = Just $ FSATRead x
           f ["m",x,y] = Just $ FSATMove x y

src/Development/Shake/Core.hs

@@ -538,10 +538,7 @@ applyKeyValue ks = do
                 liftIO $ globalLint $ "before building " ++ top
                 putWhen Chatty $ "# " ++ show k
                 res <- runExecute globalRules k
-                case shakeLint globalOptions of
-                    Just LintTracker -> trackCheckUsed
-                    Just LintFSATrace -> trackCheckUsed
-                    _ -> return ()
+                when (Just LintFSATrace == shakeLint globalOptions) trackCheckUsed
                 Action $ fmap ((,) res) getRW) $ \x -> case x of
                     Left e -> continue . Left . toException =<< shakeException global (showStack globalDatabase stack) e
                     Right (res, Local{..}) -> do

src/Development/Shake/Rules/File.hs

@@ -2,7 +2,7 @@
 {-# LANGUAGE ViewPatterns #-}
 
 module Development.Shake.Rules.File(
-    need, needBS, needed, neededBS, want,
+    need, needBS, needed, neededBS, needNorm, want,
     trackRead, trackWrite, trackAllow,
     defaultRuleFile,
     (%>), (|%>), (?>), phony, (~>), phonys,
@@ -116,6 +116,9 @@ defaultRuleFile = priority 0 $ rule $ \x -> Just $ do
 need :: [FilePath] -> Action ()
 need xs = (apply $ map (FileQ . packU_ . filepathNormalise . unpackU_ . packU) xs :: Action [FileA]) >> return ()
 
+needNorm :: [FilePath] -> Action ()
+needNorm xs = (apply $ map (FileQ . packU) xs :: Action [FileA]) >> return ()
+
 needBS :: [BS.ByteString] -> Action ()
 needBS xs = (apply $ map (FileQ . packU_ . filepathNormalise) xs :: Action [FileA]) >> return ()
 
@@ -152,13 +155,13 @@ neededCheck (map (packU_ . filepathNormalise . unpackU_) -> xs) = do
 
 -- | Track that a file was read by the action preceeding it. If 'shakeLint' is activated
 --   then these files must be dependencies of this rule. Calls to 'trackRead' are
---   automatically inserted in 'LintTracker' mode.
+--   automatically inserted in 'LintFSATrace' mode.
 trackRead :: [FilePath] -> Action ()
 trackRead = mapM_ (trackUse . FileQ . packU)
 
 -- | Track that a file was written by the action preceeding it. If 'shakeLint' is activated
 --   then these files must either be the target of this rule, or never referred to by the build system.
---   Calls to 'trackWrite' are automatically inserted in 'LintTracker' mode.
+--   Calls to 'trackWrite' are automatically inserted in 'LintFSATrace' mode.
 trackWrite :: [FilePath] -> Action ()
 trackWrite = mapM_ (trackChange . FileQ . packU)
 

src/Development/Shake/Types.hs

@@ -43,17 +43,11 @@ data Lint
     = LintBasic
         -- ^ The most basic form of linting. Checks that the current directory does not change and that results do not change after they
         --   are first written. Any calls to 'needed' will assert that they do not cause a rule to be rebuilt.
-    | LintTracker
-        -- ^ Track which files are accessed by command line programs run by 'command' or 'cmd', using @tracker.exe@ as supplied
-        --   with the Microsoft .NET 4.5 SDK (Windows only). Also performs all checks from 'LintBasic'. Note that some programs are not
-        --   tracked properly, particularly cygwin programs (it seems).
     | LintFSATrace
         -- ^ Track which files are accessed by command line programs
         -- using <https://github.com/jacereda/fsatrace fsatrace>.
     deriving (Eq,Ord,Show,Data,Typeable,Bounded,Enum)
 
--- LintTracker can be obtained from https://github.com/Zomega/fabricate/issues/3
-
 
 -- | How should you determine if a file has changed, used by 'shakeChange'. The most common values are
 --   'ChangeModtime' (very fast, @touch@ causes files to rebuild) and 'ChangeModtimeAndDigestInput'

src/Test/Command.hs

@@ -79,13 +79,12 @@ main = shaken test $ \args obj -> do
 
     "timeout" !> do
         opts <- getShakeOptions
-        when (shakeLint opts /= Just LintTracker) $ do
-            offset <- liftIO offsetTime
-            Exit exit <- cmd (Timeout 2) helper "w20"
-            t <- liftIO offset
-            putNormal $ "Timed out in " ++ showDuration t
-            when (exit == ExitSuccess) $ error "== ExitSuccess"
-            when (t < 2 || t > 8) $ error $ "failed to timeout, took " ++ show t
+        offset <- liftIO offsetTime
+        Exit exit <- cmd (Timeout 2) helper "w20"
+        t <- liftIO offset
+        putNormal $ "Timed out in " ++ showDuration t
+        when (exit == ExitSuccess) $ error "== ExitSuccess"
+        when (t < 2 || t > 8) $ error $ "failed to timeout, took " ++ show t
 
     "env" !> do
         -- use liftIO since it blows away PATH which makes lint-tracker stop working

src/Test/Type.hs

@@ -72,8 +72,7 @@ shaken test rules sleeper = do
                                  ,shakeReport = ["output/" ++ name ++ "/report.html"]
                                  ,shakeLint = Just t
                                  ,shakeLintInside = [cwd]
-                                 ,shakeLintIgnore = map (toStandard (normalise cwd) </>)
-                                                    [".cabal-sandbox//",".stack-work//"]
+                                 ,shakeLintIgnore = map (cwd </>) [".cabal-sandbox//",".stack-work//"]
                                  })
                     -- if you have passed sleep, supress the "no errors" warning
                     (do rules files obj; when ("--sleep" `elem` args) $ action $ return ())
@@ -96,17 +95,14 @@ shaken2 test rules = shaken test rules2
 tracker :: IO Lint
 tracker = do
   fsatrace <- findExecutable $ "fsatrace" <.> exe
-  trackerExe <- return Nothing -- findExecutable "tracker.exe"
   return $ if isJust fsatrace
            then LintFSATrace
-           else if isJust trackerExe
-                then LintTracker
-                else LintBasic
+           else LintBasic
 
 hasTracker :: IO Bool
 hasTracker = do
   t <- tracker
-  return $ t == LintFSATrace || t == LintTracker
+  return $ t == LintFSATrace
 
 
 shakeWithClean :: IO () -> ShakeOptions -> Rules () -> IO ()