Fix upper bounds on binary for ghc<7.10

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

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

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.

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

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