Fix upper bounds on binary for ghc<7.10
This commit is contained in:
Daniel Gröber
parent
8568a6785c
commit
604f2c18b0
|
|
@ -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 <bos@serpentine.com>
|
||||
-- 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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
17
Utils.hs
17
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue