Make changes backwards-compatible

hiedb.cabal

@@ -49,6 +49,7 @@ library
                        HieDb.Utils,
                        HieDb.Create,
                        HieDb.Query,
+                       HieDb.Compat,
                        HieDb.Types,
                        HieDb.Dump,
                        HieDb.Html,

src/HieDb/Compat.hs

@@ -0,0 +1,49 @@
+
+{-# LANGUAGE CPP #-}
+module HieDb.Compat where
+
+import Compat.HieTypes
+
+#if __GLASGOW_HASKELL__ >= 900
+import Compat.HieUtils
+
+import qualified Data.Map as M
+import qualified Data.Set as S
+
+
+-- nodeInfo' :: Ord a => HieAST a -> NodeInfo a
+nodeInfo' :: HieAST TypeIndex -> NodeInfo TypeIndex
+nodeInfo' = M.foldl' combineNodeInfo' emptyNodeInfo . getSourcedNodeInfo . sourcedNodeInfo
+
+combineNodeInfo' :: Ord a => NodeInfo a -> NodeInfo a -> NodeInfo a
+(NodeInfo as ai ad) `combineNodeInfo'` (NodeInfo bs bi bd) =
+  NodeInfo (S.union as bs) (mergeSorted ai bi) (M.unionWith (<>) ad bd)
+  where
+    mergeSorted :: Ord a => [a] -> [a] -> [a]
+    mergeSorted la@(a:as) lb@(b:bs) = case compare a b of
+                                        LT -> a : mergeSorted as lb
+                                        EQ -> a : mergeSorted as bs
+                                        GT -> b : mergeSorted la bs
+    mergeSorted as [] = as
+    mergeSorted [] bs = bs
+#else
+import qualified FastString as FS
+
+import Module
+
+nodeInfo' :: HieAST TypeIndex -> NodeInfo TypeIndex
+nodeInfo' = nodeInfo
+type Unit = UnitId
+unitString :: Unit -> String
+unitString = unitIdString
+stringToUnit :: String -> Unit
+stringToUnit = stringToUnitId
+moduleUnit :: Module -> Unit
+moduleUnit = moduleUnitId
+unhelpfulSpanFS :: FS.FastString -> FS.FastString
+unhelpfulSpanFS = id
+#endif
+
+#if __GLASGOW_HASKELL__ >= 900
+#else
+#endif

src/HieDb/Create.hs

@@ -32,9 +32,10 @@ import System.Directory
 
 import Database.SQLite.Simple
 
+import HieDb.Compat
 import HieDb.Types
 import HieDb.Utils
-import GHC.Data.FastString  as FS      ( FastString )
+import FastString  as FS      ( FastString )
 
 sCHEMA_VERSION :: Integer
 sCHEMA_VERSION = 5

src/HieDb/Query.hs

@@ -33,6 +33,7 @@ import           Data.IORef
 import Database.SQLite.Simple
 
 import           HieDb.Dump (sourceCode)
+import           HieDb.Compat
 import           HieDb.Types
 import           HieDb.Utils
 import qualified HieDb.Html as Html

src/HieDb/Run.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE BlockArguments #-}
@@ -49,6 +50,7 @@ import qualified Data.ByteString.Char8 as BS
 import Options.Applicative
 
 import HieDb
+import HieDb.Compat
 import HieDb.Dump
 
 hiedbMain :: LibDir -> IO ()
@@ -362,7 +364,11 @@ runCommand libdir opts cmd = withHieDbAndFlags libdir (database opts) $ \dynFlag
         reportAmbiguousErr opts (Left $ NoNameAtPoint target sp)
       forM_ names $ \name -> do
         case nameSrcSpan name of
+#if __GLASGOW_HASKELL__ >= 900
           RealSrcSpan dsp _ -> do
+#else
+          RealSrcSpan dsp -> do
+#endif
             unless (quiet opts) $
               hPutStrLn stderr $ unwords ["Name", ppName opts (nameOccName name),"at",ppSpan opts sp,"is defined at:"]
             contents <- case nameModule_maybe name of

src/HieDb/Types.hs

@@ -35,6 +35,8 @@ import Database.SQLite.Simple.FromField
 
 import qualified Text.ParserCombinators.ReadP as R
 
+import HieDb.Compat
+
 newtype HieDb = HieDb { getConn :: Connection }
 
 data HieDbException
@@ -80,16 +82,11 @@ instance ToField ModuleName where
 instance FromField ModuleName where
   fromField fld = mkModuleName . T.unpack <$> fromField fld
 
-instance ToField (GenUnit UnitId) where
+instance ToField Unit where
   toField uid = SQLText $ T.pack $ unitString uid
-instance FromField (GenUnit UnitId) where
+instance FromField Unit where
   fromField fld = stringToUnit . T.unpack <$> fromField fld
 
-instance ToField UnitId where
-  toField uid = SQLText $ T.pack $ unitIdString uid
-instance FromField UnitId where
-  fromField fld = stringToUnitId . T.unpack <$> fromField fld
-
 instance ToField Fingerprint where
   toField hash = SQLText $ T.pack $ show hash
 instance FromField Fingerprint where

src/HieDb/Utils.hs

@@ -26,7 +26,6 @@ import DynFlags
 import SysTools
 
 import qualified Data.Map as M
-import qualified Data.Set as S
 
 import qualified FastString as FS
 
@@ -46,6 +45,7 @@ import Data.Monoid
 import Data.IORef
 
 import HieDb.Types
+import HieDb.Compat
 import Database.SQLite.Simple
 
 addTypeRef :: HieDb -> FilePath -> A.Array TypeIndex HieTypeFlat -> A.Array TypeIndex (Maybe Int64) -> RealSrcSpan -> TypeIndex -> IO ()
@@ -72,8 +72,11 @@ addTypeRef (getConn -> conn) hf arr ixs sp = go 0
 #endif
         HTyConApp _ (HieArgs xs) -> mapM_ (next . snd) xs
         HForAllTy ((_ , a),_) b -> mapM_ next [a,b]
-        -- HFunTy a b -> mapM_ next [a,b]
-        HFunTy a b _ -> mapM_ next [a,b]
+#if __GLASGOW_HASKELL__ >= 900
+        HFunTy a b c -> mapM_ next [a,b,c]
+#else
+        HFunTy a b -> mapM_ next [a,b]
+#endif
         HQualTy a b -> mapM_ next [a,b]
         HLitTy _ -> pure ()
         HCastTy a -> go d a
@@ -117,7 +120,11 @@ findDefInFile occ mdl file = do
   nc <- readIORef ncr
   return $ case lookupOrigNameCache (nsNames nc) mdl occ of
     Just name -> case nameSrcSpan name of
+#if __GLASGOW_HASKELL__ >= 900
       RealSrcSpan sp _ -> Right (sp, mdl)
+#else
+      RealSrcSpan sp -> Right (sp, mdl)
+#endif
       UnhelpfulSpan msg -> Left $ NameUnhelpfulSpan name (FS.unpackFS $ unhelpfulSpanFS msg)
     Nothing -> Left $ NameNotFound occ (Just $ moduleName mdl) (Just $ moduleUnit mdl)
 
@@ -200,7 +207,11 @@ genDefRow path smod refmap = genRows $ M.toList refmap
   where
     genRows = mapMaybe go
     getSpan name dets
+#if __GLASGOW_HASKELL__ >= 900
       | RealSrcSpan sp _ <- nameSrcSpan name = Just sp
+#else
+      | RealSrcSpan sp <- nameSrcSpan name = Just sp
+#endif
       | otherwise = do
           (sp, _dets) <- find defSpan dets
           pure sp
@@ -229,19 +240,3 @@ identifierTree [email protected]{ nodeChildren } =
     { rootLabel = nd { nodeChildren = mempty }
     , subForest = map identifierTree nodeChildren
     }
-
--- nodeInfo' :: Ord a => HieAST a -> NodeInfo a
-nodeInfo' :: HieAST TypeIndex -> NodeInfo TypeIndex
-nodeInfo' = M.foldl' combineNodeInfo' emptyNodeInfo . getSourcedNodeInfo . sourcedNodeInfo
-
-combineNodeInfo' :: Ord a => NodeInfo a -> NodeInfo a -> NodeInfo a
-(NodeInfo as ai ad) `combineNodeInfo'` (NodeInfo bs bi bd) =
-  NodeInfo (S.union as bs) (mergeSorted ai bi) (M.unionWith (<>) ad bd)
-  where
-    mergeSorted :: Ord a => [a] -> [a] -> [a]
-    mergeSorted la@(a:as) lb@(b:bs) = case compare a b of
-                                        LT -> a : mergeSorted as lb
-                                        EQ -> a : mergeSorted as bs
-                                        GT -> b : mergeSorted la bs
-    mergeSorted as [] = as
-    mergeSorted [] bs = bs