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

View file

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

View file

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

View file

@ -18,11 +18,7 @@ import Annex.Content
import Annex.Perms import Annex.Perms
import qualified Annex.Queue import qualified Annex.Queue
import qualified Database.Keys import qualified Database.Keys
#ifdef WITH_CLIBS
#ifndef __ANDROID__
import Utility.Touch import Utility.Touch
#endif
#endif
cmd :: Command cmd :: Command
cmd = notDirect $ noCommit $ withGlobalOptions annexedMatchingOptions $ cmd = notDirect $ noCommit $ withGlobalOptions annexedMatchingOptions $
@ -90,20 +86,16 @@ makeHardLink file key = do
fixSymlink :: FilePath -> FilePath -> CommandPerform fixSymlink :: FilePath -> FilePath -> CommandPerform
fixSymlink file link = do fixSymlink file link = do
liftIO $ do liftIO $ do
#ifdef WITH_CLIBS #if ! defined(mingw32_HOST_OS) && ! defined(__ANDROID__)
#ifndef __ANDROID__
-- preserve mtime of symlink -- preserve mtime of symlink
mtime <- catchMaybeIO $ TimeSpec . modificationTime mtime <- catchMaybeIO $ TimeSpec . modificationTime
<$> getSymbolicLinkStatus file <$> getSymbolicLinkStatus file
#endif
#endif #endif
createDirectoryIfMissing True (parentDir file) createDirectoryIfMissing True (parentDir file)
removeFile file removeFile file
createSymbolicLink link file createSymbolicLink link file
#ifdef WITH_CLIBS #if ! defined(mingw32_HOST_OS) && ! defined(__ANDROID__)
#ifndef __ANDROID__
maybe noop (\t -> touch file t False) mtime maybe noop (\t -> touch file t False) mtime
#endif
#endif #endif
next $ cleanupSymlink file 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> - Copyright 2011 Joey Hess <id@joeyh.name>
- -
@ -7,32 +7,12 @@
{-# LANGUAGE ForeignFunctionInterface, CPP #-} {-# LANGUAGE ForeignFunctionInterface, CPP #-}
module Utility.Touch ( module Utility.Touch.Old (
TimeSpec(..), TimeSpec(..),
touchBoth, touchBoth,
touch touch
) where ) 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/types.h>
#include <sys/stat.h> #include <sys/stat.h>
#include <fcntl.h> #include <fcntl.h>
@ -141,5 +121,3 @@ touchBoth file atime mtime follow =
touchBoth _ _ _ _ = return () touchBoth _ _ _ _ = return ()
#endif #endif
#endif #endif
#endif

View file

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