hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Fix upper bounds on binary for ghc<7.10

Browse Source
This commit is contained in:
Daniel Gröber
2015-11-26 14:48:26 +01:00
parent 8568a6785c
commit 604f2c18b0
9 changed files with 241 additions and 49 deletions
Download Patch File Download Diff File Expand all files Collapse all files

39
Language/Haskell/GhcMod/Caching.hs
View File

@@ -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