diff --git a/Data/Binary/Generic.hs b/Data/Binary/Generic.hs new file mode 100644 index 0000000..bc040cd --- /dev/null +++ b/Data/Binary/Generic.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE BangPatterns, CPP, FlexibleInstances, KindSignatures, + ScopedTypeVariables, TypeOperators, TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Binary.Generic +-- Copyright : Bryan O'Sullivan +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Bryan O'Sullivan +-- Stability : unstable +-- Portability : Only works with GHC 7.2 and newer +-- +-- Instances for supporting GHC generics. +-- +----------------------------------------------------------------------------- +module Data.Binary.Generic where + +import Control.Applicative +import Data.Binary hiding (GBinary(..)) +import Data.Bits +import GHC.Generics +import Prelude + +class GBinary f where + gput :: f t -> Put + gget :: Get (f t) + +-- Type without constructors +instance GBinary V1 where + gput _ = return () + gget = return undefined + +-- Constructor without arguments +instance GBinary U1 where + gput U1 = return () + gget = return U1 + +-- Product: constructor with parameters +instance (GBinary a, GBinary b) => GBinary (a :*: b) where + gput (x :*: y) = gput x >> gput y + gget = (:*:) <$> gget <*> gget + +-- Metadata (constructor name, etc) +instance GBinary a => GBinary (M1 i c a) where + gput = gput . unM1 + gget = M1 <$> gget + +-- Constants, additional parameters, and rank-1 recursion +instance Binary a => GBinary (K1 i a) where + gput = put . unK1 + gget = K1 <$> get + +-- Borrowed from the cereal package. + +-- The following GBinary instance for sums has support for serializing +-- types with up to 2^64-1 constructors. It will use the minimal +-- number of bytes needed to encode the constructor. For example when +-- a type has 2^8 constructors or less it will use a single byte to +-- encode the constructor. If it has 2^16 constructors or less it will +-- use two bytes, and so on till 2^64-1. + +#define GUARD(WORD) (size - 1) <= fromIntegral (maxBound :: WORD) +#define PUTSUM(WORD) GUARD(WORD) = putSum (0 :: WORD) (fromIntegral size) +#define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum (fromIntegral size) + +instance ( GSum a, GSum b + , GBinary a, GBinary b + , SumSize a, SumSize b) => GBinary (a :+: b) where + gput | PUTSUM(Word8) | PUTSUM(Word16) | PUTSUM(Word32) | PUTSUM(Word64) + | otherwise = sizeError "encode" size + where + size = unTagged (sumSize :: Tagged (a :+: b) Word64) + {-# INLINE gput #-} + + gget | GETSUM(Word8) | GETSUM(Word16) | GETSUM(Word32) | GETSUM(Word64) + | otherwise = sizeError "decode" size + where + size = unTagged (sumSize :: Tagged (a :+: b) Word64) + {-# INLINE gget #-} + +sizeError :: Show size => String -> size -> error +sizeError s size = + error $ "Can't " ++ s ++ " a type with " ++ show size ++ " constructors" + +------------------------------------------------------------------------ + +checkGetSum :: (Ord word, Num word, Bits word, GSum f) + => word -> word -> Get (f a) +checkGetSum size code | code < size = getSum code size + | otherwise = fail "Unknown encoding for constructor" +{-# INLINE checkGetSum #-} + +class GSum f where + getSum :: (Ord word, Num word, Bits word) => word -> word -> Get (f a) + putSum :: (Num w, Bits w, Binary w) => w -> w -> f a -> Put + +instance (GSum a, GSum b, GBinary a, GBinary b) => GSum (a :+: b) where + getSum !code !size | code < sizeL = L1 <$> getSum code sizeL + | otherwise = R1 <$> getSum (code - sizeL) sizeR + where + sizeL = size `shiftR` 1 + sizeR = size - sizeL + {-# INLINE getSum #-} + + putSum !code !size s = case s of + L1 x -> putSum code sizeL x + R1 x -> putSum (code + sizeL) sizeR x + where + sizeL = size `shiftR` 1 + sizeR = size - sizeL + {-# INLINE putSum #-} + +instance GBinary a => GSum (C1 c a) where + getSum _ _ = gget + {-# INLINE getSum #-} + + putSum !code _ x = put code *> gput x + {-# INLINE putSum #-} + +------------------------------------------------------------------------ + +class SumSize f where + sumSize :: Tagged f Word64 + +newtype Tagged (s :: * -> *) b = Tagged {unTagged :: b} + +instance (SumSize a, SumSize b) => SumSize (a :+: b) where + sumSize = Tagged $ unTagged (sumSize :: Tagged a Word64) + + unTagged (sumSize :: Tagged b Word64) + +instance SumSize (C1 c a) where + sumSize = Tagged 1 diff --git a/Language/Haskell/GhcMod/Caching.hs b/Language/Haskell/GhcMod/Caching.hs index 33bf232..0f7cfb6 100644 --- a/Language/Haskell/GhcMod/Caching.hs +++ b/Language/Haskell/GhcMod/Caching.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP, OverloadedStrings #-} module Language.Haskell.GhcMod.Caching ( module Language.Haskell.GhcMod.Caching , module Language.Haskell.GhcMod.Caching.Types @@ -7,17 +7,21 @@ module Language.Haskell.GhcMod.Caching ( import Control.Arrow (first) import Control.Monad import Control.Monad.Trans.Maybe +#if !MIN_VERSION_binary(0,7,0) +import Control.Exception +#endif import Data.Maybe -import Data.Binary (Binary, encode, decodeOrFail) +import Data.Binary hiding (get) import Data.Version import Data.Label import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 -import Data.Time (UTCTime, getCurrentTime) import System.FilePath +import System.Directory.ModTime import Utils (TimedFile(..), timeMaybe, mightExist) import Paths_ghc_mod (version) +import Prelude import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Caching.Types @@ -33,7 +37,7 @@ cached dir cd d = do mcc <- readCache case mcc of Nothing -> do - t <- liftIO $ getCurrentTime + t <- liftIO $ getCurrentModTime writeCache (TimedCacheFiles t []) Nothing "cache missing or unreadable" Just (t, ifs, d', a) | d /= d' -> do tcfs <- timeCacheInput dir ifs @@ -47,9 +51,12 @@ cached dir cd d = do where cacheHeader = BS8.pack $ "Written by ghc-mod " ++ showVersion version ++ "\n" + lbsToStrict = BS.concat . LBS.toChunks + lbsFromStrict bs = LBS.fromChunks [bs] + writeCache tcfs ma cause = do (ifs', a) <- (cachedAction cd) tcfs d ma - t <- liftIO $ getCurrentTime + t <- liftIO $ getCurrentModTime gmLog GmDebug "" $ (text "regenerating cache") <+>: text (cacheFile cd) <+> parens (text cause) case cacheLens cd of @@ -58,7 +65,7 @@ cached dir cd d = do gmLog GmDebug "" $ (text "writing memory cache") <+>: text (cacheFile cd) setLabel label $ Just (t, ifs', d, a) - let c = BS.append cacheHeader $ LBS.toStrict $ encode (t, ifs', d, a) + let c = BS.append cacheHeader $ lbsToStrict $ encode (t, ifs', d, a) liftIO $ BS.writeFile (dir cacheFile cd) c @@ -68,7 +75,7 @@ cached dir cd d = do s <- gmsGet gmsPut $ set l x s - readCache :: m (Maybe (UTCTime, [FilePath], d, a)) + readCache :: m (Maybe (ModTime, [FilePath], d, a)) readCache = runMaybeT $ do case cacheLens cd of Just label -> do @@ -78,26 +85,34 @@ cached dir cd d = do Nothing -> readCacheFromFile - readCacheFromFile :: MaybeT m (UTCTime, [FilePath], d, a) + readCacheFromFile :: MaybeT m (ModTime, [FilePath], d, a) readCacheFromFile = do f <- MaybeT $ liftIO $ mightExist $ cacheFile cd readCacheFromFile' f - readCacheFromFile' :: FilePath -> MaybeT m (UTCTime, [FilePath], d, a) + readCacheFromFile' :: FilePath -> MaybeT m (ModTime, [FilePath], d, a) readCacheFromFile' f = MaybeT $ do gmLog GmDebug "" $ (text "reading cache") <+>: text (cacheFile cd) cc <- liftIO $ BS.readFile f case first BS8.words $ BS8.span (/='\n') cc of (["Written", "by", "ghc-mod", ver], rest) | BS8.unpack ver == showVersion version -> - return $ either (const Nothing) Just $ - decodeE $ LBS.fromStrict $ BS.drop 1 rest + either (const Nothing) Just + `liftM` decodeE (lbsFromStrict $ BS.drop 1 rest) _ -> return Nothing decodeE b = do - case decodeOrFail b of +#if MIN_VERSION_binary(0,7,0) + return $ case decodeOrFail b of Left (_rest, _offset, errmsg) -> Left errmsg Right (_reset, _offset, a) -> Right a +#else + ea <- liftIO $ try $ evaluate $ decode b + return $ case ea of + Left (ErrorCall errmsg) -> Left errmsg + Right a -> Right a + +#endif timeCacheInput :: MonadIO m => FilePath -> [FilePath] -> m [TimedFile] timeCacheInput dir ifs = liftIO $ do diff --git a/Language/Haskell/GhcMod/Caching/Types.hs b/Language/Haskell/GhcMod/Caching/Types.hs index 2524c83..5e07c1e 100644 --- a/Language/Haskell/GhcMod/Caching/Types.hs +++ b/Language/Haskell/GhcMod/Caching/Types.hs @@ -2,10 +2,10 @@ module Language.Haskell.GhcMod.Caching.Types where import Utils import Data.Label -import Data.Time (UTCTime) +import System.Directory.ModTime import Distribution.Helper -type CacheContents d a = Maybe (UTCTime, [FilePath], d, a) +type CacheContents d a = Maybe (ModTime, [FilePath], d, a) type CacheLens s d a = s :-> CacheContents d a data Cached m s d a = Cached { @@ -47,6 +47,6 @@ data TimedCacheFiles = TimedCacheFiles { -- ^ 'cacheFile' timestamp tcFiles :: [TimedFile] -- ^ Timestamped files returned by the cached action - } deriving (Eq, Ord, Show) + } deriving (Eq, Ord) type ChCacheData = (Programs, FilePath, (String, String)) diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index b001e0d..3962b01 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/Language/Haskell/GhcMod/Find.hs @@ -29,7 +29,8 @@ import Language.Haskell.GhcMod.World (timedPackageCaches) import Language.Haskell.GhcMod.Output import Name (getOccString) import Module (moduleName) -import System.Directory (doesFileExist, getModificationTime) +import System.Directory (doesFileExist) +import System.Directory.ModTime import System.FilePath (()) import System.IO import Prelude @@ -120,7 +121,7 @@ isOlderThan cache files = do if not exist then return True else do - tCache <- getModificationTime cache + tCache <- getModTime cache return $ any (tCache <=) $ map tfTime files -- including equal just in case -- | Browsing all functions in all system modules. diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 7f1d7a5..881a29b 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -15,7 +15,8 @@ import Control.Exception (Exception) import Control.Applicative import Control.Concurrent import Control.Monad -import Data.Binary +import Data.Binary hiding (gput, gget) +import Data.Binary.Generic import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) @@ -24,8 +25,6 @@ import Data.Monoid import Data.Maybe import Data.Typeable (Typeable) import Data.IORef -import Data.Time (UTCTime(..)) -import Data.Time.Calendar (Day(..)) import Data.Label.Derive import Distribution.Helper hiding (Programs(..)) import qualified Distribution.Helper as CabalHelper @@ -232,7 +231,9 @@ data GhcPkgDb = GlobalDb | PackageDb String deriving (Eq, Show, Generic) -instance Binary GhcPkgDb +instance Binary GhcPkgDb where + put = gput . from + get = to `fmap` gget -- | A single GHC command line option. type GHCOption = String @@ -303,11 +304,15 @@ data GmComponent (t :: GmComponentType) eps = GmComponent { , gmcSourceDirs :: [FilePath] } deriving (Eq, Ord, Show, Read, Generic, Functor) -instance Binary eps => Binary (GmComponent t eps) +instance Binary eps => Binary (GmComponent t eps) where + put = gput . from + get = to `fmap` gget data ModulePath = ModulePath { mpModule :: ModuleName, mpPath :: FilePath } deriving (Eq, Ord, Show, Read, Generic, Typeable) -instance Binary ModulePath +instance Binary ModulePath where + put = gput . from + get = to `fmap` gget instance Binary ModuleName where get = mkModuleName <$> get @@ -367,16 +372,18 @@ instance Error GhcModError where instance Exception GhcModError -instance Binary CabalHelper.Programs -instance Binary ChModuleName -instance Binary ChComponentName -instance Binary ChEntrypoint - -instance Binary UTCTime where - put (UTCTime (ModifiedJulianDay day) difftime) = - put day >> put (toRational difftime) - get = do - UTCTime <$> (ModifiedJulianDay <$> get) <*> (fromRational <$> get) +instance Binary CabalHelper.Programs where + put = gput . from + get = to `fmap` gget +instance Binary ChModuleName where + put = gput . from + get = to `fmap` gget +instance Binary ChComponentName where + put = gput . from + get = to `fmap` gget +instance Binary ChEntrypoint where + put = gput . from + get = to `fmap` gget mkLabel ''GhcModCaches mkLabel ''GhcModState diff --git a/Language/Haskell/GhcMod/World.hs b/Language/Haskell/GhcMod/World.hs index 0d413e5..89596b8 100644 --- a/Language/Haskell/GhcMod/World.hs +++ b/Language/Haskell/GhcMod/World.hs @@ -20,7 +20,7 @@ data World = World { , worldCabalConfig :: Maybe TimedFile , worldCabalSandboxConfig :: Maybe TimedFile , worldSymbolCache :: Maybe TimedFile - } deriving (Eq, Show) + } deriving (Eq) timedPackageCaches :: IOish m => GhcModT m [TimedFile] timedPackageCaches = do diff --git a/System/Directory/ModTime.hs b/System/Directory/ModTime.hs new file mode 100644 index 0000000..66d46a2 --- /dev/null +++ b/System/Directory/ModTime.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE CPP #-} +module System.Directory.ModTime where + +import Control.Applicative +import Data.Binary +#if MIN_VERSION_directory(1,2,0) +import Data.Time (UTCTime(..), Day(..), getCurrentTime) +#else +import System.Time (ClockTime(..), getClockTime) +#endif +import System.Directory +import Prelude + +#if MIN_VERSION_directory(1,2,0) + +newtype ModTime = ModTime UTCTime + deriving (Eq, Ord) +getCurrentModTime = ModTime <$> getCurrentTime + +instance Binary ModTime where + put (ModTime (UTCTime (ModifiedJulianDay day) difftime)) = + put day >> put (toRational difftime) + get = + ModTime <$> (UTCTime <$> (ModifiedJulianDay <$> get) <*> (fromRational <$> get)) + +#else + +newtype ModTime = ModTime ClockTime + deriving (Eq, Ord, Show) +getCurrentModTime = ModTime <$> getClockTime + +instance Binary ModTime where + put (ModTime (TOD s ps)) = + put s >> put ps + get = + ModTime . TOD <$> get <*> get + +#endif + +getCurrentModTime :: IO ModTime + +getModTime :: FilePath -> IO ModTime +getModTime f = ModTime <$> getModificationTime f diff --git a/Utils.hs b/Utils.hs index a4c1ff2..c62768a 100644 --- a/Utils.hs +++ b/Utils.hs @@ -4,29 +4,18 @@ module Utils where import Control.Applicative import Data.Traversable import System.Directory +import System.Directory.ModTime -#if MIN_VERSION_directory(1,2,0) -import Data.Time (UTCTime) -#else -import System.Time (ClockTime) -#endif import Prelude - -#if MIN_VERSION_directory(1,2,0) -type ModTime = UTCTime -#else -type ModTime = ClockTime -#endif - data TimedFile = TimedFile { tfPath :: FilePath, tfTime :: ModTime } - deriving (Eq, Show) + deriving (Eq) instance Ord TimedFile where compare (TimedFile _ a) (TimedFile _ b) = compare a b timeFile :: FilePath -> IO TimedFile -timeFile f = TimedFile <$> pure f <*> getModificationTime f +timeFile f = TimedFile <$> pure f <*> getModTime f mightExist :: FilePath -> IO (Maybe FilePath) mightExist f = do diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 83452ab..b8d3d07 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -145,9 +145,11 @@ Library Language.Haskell.GhcMod.World Other-Modules: Paths_ghc_mod Utils + Data.Binary.Generic + System.Directory.ModTime Build-Depends: base < 5 && >= 4.0 , bytestring < 0.11 - , binary < 0.8 && >= 0.7 + , binary < 0.8 && >= 0.5.1.0 , containers < 0.6 , cabal-helper < 0.7 && >= 0.6.1.0 , deepseq < 1.5 @@ -213,6 +215,7 @@ Executable ghc-modi Default-Extensions: ConstraintKinds, FlexibleContexts HS-Source-Dirs: src, . Build-Depends: base < 5 && >= 4.0 + , binary < 0.8 && >= 0.5.1.0 , directory < 1.3 , filepath < 1.5 , process < 1.3