move old ghc compat code into separate module; eliminate WITH_CLIBS

This avoids hsc2hs being run except when building for the old version of ghc.
Should speed up builds.
This commit is contained in:
Joey Hess 2016-02-15 11:47:33 -04:00
parent a665f92b91
commit 40207b26ea
Failed to extract signature
7 changed files with 61 additions and 57 deletions

View file

@ -5,8 +5,6 @@
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Annex.Ingest (
LockedDown(..),
LockDownConfig(..),
@ -38,13 +36,9 @@ import Utility.InodeCache
import Annex.ReplaceFile
import Utility.Tmp
import Utility.CopyFile
import Utility.Touch
import Git.FilePath
import Annex.InodeSentinal
#ifdef WITH_CLIBS
#ifndef __ANDROID__
import Utility.Touch
#endif
#endif
import Control.Exception (IOException)
@ -260,11 +254,7 @@ makeLink file key mcache = flip catchNonAsync (restoreFile file key) $ do
-- touch symlink to have same time as the original file,
-- as provided in the InodeCache
case mcache of
#if defined(WITH_CLIBS) && ! defined(__ANDROID__)
Just c -> liftIO $ touch file (TimeSpec $ inodeCacheToMtime c) False
#else
Just _ -> noop
#endif
Nothing -> noop
return l

View file

@ -25,7 +25,7 @@ import Assistant.Threads.RemoteControl
import Assistant.Threads.SanityChecker
import Assistant.Threads.Cronner
import Assistant.Threads.ProblemFixer
#ifdef WITH_CLIBS
#ifndef mingw32_HOST_OS
import Assistant.Threads.MountWatcher
#endif
import Assistant.Threads.NetWatcher
@ -170,7 +170,7 @@ startDaemon assistant foreground startdelay cannotrun listenhost startbrowser =
, assist $ sanityCheckerDailyThread urlrenderer
, assist sanityCheckerHourlyThread
, assist $ problemFixerThread urlrenderer
#ifdef WITH_CLIBS
#ifndef mingw32_HOST_OS
, assist $ mountWatcherThread urlrenderer
#endif
, assist netWatcherThread

View file

@ -24,9 +24,7 @@ import qualified Git.Branch
import Config.Files
import Utility.FreeDesktop
import Utility.DiskFree
#ifdef WITH_CLIBS
import Utility.Mounts
#endif
import Utility.DataUnits
import Remote (prettyUUID)
import Annex.UUID
@ -359,7 +357,6 @@ driveList :: IO [RemovableDrive]
-- Could use wmic, but it only works for administrators.
driveList = mapM (\d -> genRemovableDrive $ d:":\\") ['A'..'Z']
#else
#ifdef WITH_CLIBS
driveList = mapM (genRemovableDrive . mnt_dir) =<< filter sane <$> getMounts
where
-- filter out some things that are surely not removable drives
@ -379,9 +376,6 @@ driveList = mapM (genRemovableDrive . mnt_dir) =<< filter sane <$> getMounts
| dir == "/sdcard" = False
#endif
| otherwise = True
#else
driveList = return []
#endif
#endif
genRemovableDrive :: FilePath -> IO RemovableDrive

View file

@ -18,11 +18,7 @@ import Annex.Content
import Annex.Perms
import qualified Annex.Queue
import qualified Database.Keys
#ifdef WITH_CLIBS
#ifndef __ANDROID__
import Utility.Touch
#endif
#endif
cmd :: Command
cmd = notDirect $ noCommit $ withGlobalOptions annexedMatchingOptions $
@ -90,20 +86,16 @@ makeHardLink file key = do
fixSymlink :: FilePath -> FilePath -> CommandPerform
fixSymlink file link = do
liftIO $ do
#ifdef WITH_CLIBS
#ifndef __ANDROID__
#if ! defined(mingw32_HOST_OS) && ! defined(__ANDROID__)
-- preserve mtime of symlink
mtime <- catchMaybeIO $ TimeSpec . modificationTime
<$> getSymbolicLinkStatus file
#endif
#endif
createDirectoryIfMissing True (parentDir file)
removeFile file
createSymbolicLink link file
#ifdef WITH_CLIBS
#ifndef __ANDROID__
#if ! defined(mingw32_HOST_OS) && ! defined(__ANDROID__)
maybe noop (\t -> touch file t False) mtime
#endif
#endif
next $ cleanupSymlink file

52
Utility/Touch.hs Normal file
View file

@ -0,0 +1,52 @@
{- More control over touching a file.
-
- Copyright 2011 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
{-# LANGUAGE CPP #-}
module Utility.Touch (
TimeSpec(..),
touchBoth,
touch
) where
#if ! defined(mingw32_HOST_OS) && ! defined(__ANDROID__)
#if MIN_VERSION_unix(2,7,0)
import System.Posix.Files
import System.Posix.Types
newtype TimeSpec = TimeSpec EpochTime
{- Changes the access and modification times of an existing file.
Can follow symlinks, or not. Throws IO error on failure. -}
touchBoth :: FilePath -> TimeSpec -> TimeSpec -> Bool -> IO ()
touchBoth file (TimeSpec atime) (TimeSpec mtime) follow
| follow = setFileTimes file atime mtime
| otherwise = setSymbolicLinkTimesHiRes file (realToFrac atime) (realToFrac mtime)
touch :: FilePath -> TimeSpec -> Bool -> IO ()
touch file mtime = touchBoth file mtime mtime
#else
import Utility.Touch.Old
#endif
#else
import System.PosixCompat
newtype TimeSpec = TimeSpec EpochTime
{- Noop for Windows -}
touchBoth FilePath -> TimeSpec -> TimeSpec -> Bool -> IO ()
touchBoth _ _ _ _ = return ()
touch :: FilePath -> TimeSpec -> Bool -> IO ()
touch _ _ = return ()
#endif

View file

@ -1,4 +1,4 @@
{- More control over touching a file.
{- Compatability interface for old version of unix, to be removed eventally.
-
- Copyright 2011 Joey Hess <id@joeyh.name>
-
@ -7,32 +7,12 @@
{-# LANGUAGE ForeignFunctionInterface, CPP #-}
module Utility.Touch (
module Utility.Touch.Old (
TimeSpec(..),
touchBoth,
touch
) where
#if MIN_VERSION_unix(2,7,0)
import System.Posix.Files
import System.Posix.Types
newtype TimeSpec = TimeSpec EpochTime
{- Changes the access and modification times of an existing file.
Can follow symlinks, or not. Throws IO error on failure. -}
touchBoth :: FilePath -> TimeSpec -> TimeSpec -> Bool -> IO ()
touchBoth file (TimeSpec atime) (TimeSpec mtime) follow
| follow = setFileTimes file atime mtime
| otherwise = setSymbolicLinkTimesHiRes file (realToFrac atime) (realToFrac mtime)
touch :: FilePath -> TimeSpec -> Bool -> IO ()
touch file mtime = touchBoth file mtime mtime
#else
{- Compatability interface for old version of unix, to be removed eventally. -}
#include <sys/types.h>
#include <sys/stat.h>
#include <fcntl.h>
@ -141,5 +121,3 @@ touchBoth file atime mtime follow =
touchBoth _ _ _ _ = return ()
#endif
#endif
#endif

View file

@ -144,10 +144,8 @@ Executable git-annex
process (>= 1.3.0.0)
else
Build-Depends: unix
-- Need to list these because they're generated from .hsc files.
Other-Modules: Utility.Touch
Include-Dirs: Utility
CPP-Options: -DWITH_CLIBS
if impl(ghc <= 7.6.3)
Other-Modules: Utility.Touch.Old
if flag(TestSuite)
Build-Depends: tasty (>= 0.7), tasty-hunit, tasty-quickcheck, tasty-rerun,