Fix upper bounds on binary for ghc<7.10

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

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 $
+            either (const Nothing) Just
-                decodeE $ LBS.fromStrict $ BS.drop 1 rest
+                `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 CabalHelper.Programs where
-instance Binary ChModuleName
+    put = gput . from
-instance Binary ChComponentName
+    get = to `fmap` gget
-instance Binary ChEntrypoint
+instance Binary ChModuleName where
-
+    put = gput . from
-instance Binary UTCTime where
+    get = to `fmap` gget
-    put (UTCTime (ModifiedJulianDay day) difftime) =
+instance Binary ChComponentName where
-        put day >> put (toRational difftime)
+    put = gput . from
-    get = do
+    get = to `fmap` gget
-        UTCTime <$> (ModifiedJulianDay <$> get) <*> (fromRational <$> get)
+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

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

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

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