[arch-commits] Commit in haskell-hiedb/trunk (PKGBUILD ghc9.patch)
Felix Yan
felixonmars at archlinux.org
Mon Jun 28 12:26:36 UTC 2021
Date: Monday, June 28, 2021 @ 12:26:36
Author: felixonmars
Revision: 967689
upgpkg: haskell-hiedb 0.3.0.1-45: rebuild with ghc 9.0.1
Added:
haskell-hiedb/trunk/ghc9.patch
Modified:
haskell-hiedb/trunk/PKGBUILD
------------+
PKGBUILD | 13
ghc9.patch | 1061 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2 files changed, 1069 insertions(+), 5 deletions(-)
Modified: PKGBUILD
===================================================================
--- PKGBUILD 2021-06-28 11:47:38 UTC (rev 967688)
+++ PKGBUILD 2021-06-28 12:26:36 UTC (rev 967689)
@@ -3,22 +3,25 @@
_hkgname=hiedb
pkgname=haskell-hiedb
pkgver=0.3.0.1
-pkgrel=44
+pkgrel=45
pkgdesc="Generates a references DB from .hie files"
url="https://github.com/wz1000/HieDb"
license=("BSD")
arch=('x86_64')
depends=('ghc-libs' 'haskell-algebraic-graphs' 'haskell-ansi-terminal' 'haskell-extra' 'haskell-ghc'
- 'haskell-ghc-paths' 'haskell-hie-compat' 'haskell-lucid' 'haskell-optparse-applicative'
- 'haskell-sqlite-simple')
+ 'haskell-ghc-api-compat' 'haskell-ghc-paths' 'haskell-hie-compat' 'haskell-lucid'
+ 'haskell-optparse-applicative' 'haskell-sqlite-simple')
makedepends=('ghc' 'haskell-hspec' 'haskell-temporary')
# https://github.com/wz1000/HieDb/pull/27
#source=("https://hackage.haskell.org/packages/archive/$_hkgname/$pkgver/$_hkgname-$pkgver.tar.gz")
-source=("https://github.com/wz1000/HieDb/archive/$pkgver/$pkgname-$pkgver.tar.gz")
-sha256sums=('7c0d3c56f7c0ea9b5af84f9c9f8547dc2a12abf0ab3e599c9ebdff3d2bf7b980')
+source=("https://github.com/wz1000/HieDb/archive/$pkgver/$pkgname-$pkgver.tar.gz"
+ ghc9.patch)
+sha256sums=('7c0d3c56f7c0ea9b5af84f9c9f8547dc2a12abf0ab3e599c9ebdff3d2bf7b980'
+ '2c86858d805a69603ffa4680b2a989b5732f43ec47ab42e5de1d37794b097372')
prepare() {
cd HieDb-$pkgver
+ patch -p1 -i ../ghc9.patch
sed -i 's/callProcess "ghc" \$/callProcess "ghc" $ "-dynamic" :/' test/Main.hs
}
Added: ghc9.patch
===================================================================
--- ghc9.patch (rev 0)
+++ ghc9.patch 2021-06-28 12:26:36 UTC (rev 967689)
@@ -0,0 +1,1061 @@
+From ddd3c1ee822c2759f9b67a6e199770e6097b5ef0 Mon Sep 17 00:00:00 2001
+From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= <anka.213 at gmail.com>
+Date: Tue, 30 Mar 2021 00:52:11 +0800
+Subject: [PATCH 1/7] Add non-backwards compatible support for ghc-9.0.1
+
+---
+ hiedb.cabal | 4 +++-
+ src/HieDb/Create.hs | 15 +++++++++------
+ src/HieDb/Query.hs | 28 ++++++++++++++--------------
+ src/HieDb/Run.hs | 41 +++++++++++++++++++++--------------------
+ src/HieDb/Types.hs | 25 ++++++++++++++++---------
+ src/HieDb/Utils.hs | 34 ++++++++++++++++++++++++++--------
+ test/Main.hs | 26 ++++++++++++++------------
+ test/Test/Orphans.hs | 4 ++--
+ 8 files changed, 105 insertions(+), 72 deletions(-)
+
+diff --git a/hiedb.cabal b/hiedb.cabal
+index 82fc7b6..f198504 100644
+--- a/hiedb.cabal
++++ b/hiedb.cabal
+@@ -25,7 +25,7 @@ source-repository head
+
+ common common-options
+ default-language: Haskell2010
+- build-depends: base >= 4.12 && < 4.15
++ build-depends: base >= 4.12 && < 4.16
+ ghc-options: -Wall
+ -Wincomplete-uni-patterns
+ -Wincomplete-record-updates
+@@ -69,6 +69,7 @@ library
+ , optparse-applicative
+ , extra
+ , ansi-terminal
++ , ghc-api-compat
+
+ test-suite hiedb-tests
+ import: common-options
+@@ -85,3 +86,4 @@ test-suite hiedb-tests
+ , hspec
+ , process
+ , temporary
++ , ghc-api-compat
+diff --git a/src/HieDb/Create.hs b/src/HieDb/Create.hs
+index 3572843..57c3fac 100644
+--- a/src/HieDb/Create.hs
++++ b/src/HieDb/Create.hs
+@@ -34,6 +34,7 @@ import Database.SQLite.Simple
+
+ import HieDb.Types
+ import HieDb.Utils
++import GHC.Data.FastString as FS ( FastString )
+
+ sCHEMA_VERSION :: Integer
+ sCHEMA_VERSION = 5
+@@ -60,7 +61,7 @@ checkVersion k db@(getConn -> conn) = do
+ withHieDb :: FilePath -> (HieDb -> IO a) -> IO a
+ withHieDb fp f = withConnection fp (checkVersion f . HieDb)
+
+-{-| Given GHC LibDir and path to @.hiedb@ file,
++{-| Given GHC LibDir and path to @.hiedb@ file,
+ constructs DynFlags (required for printing info from @.hie@ files)
+ and 'HieDb' and passes them to given function.
+ -}
+@@ -150,7 +151,7 @@ initConn (getConn -> conn) = do
+ execute_ conn "CREATE INDEX IF NOT EXISTS typerefs_mod ON typerefs(hieFile)"
+
+ {-| Add names of types from @.hie@ file to 'HieDb'.
+-Returns an Array mapping 'TypeIndex' to database ID assigned to the
++Returns an Array mapping 'TypeIndex' to database ID assigned to the
+ corresponding record in DB.
+ -}
+ addArr :: HieDb -> A.Array TypeIndex HieTypeFlat -> IO (A.Array TypeIndex (Maybe Int64))
+@@ -166,7 +167,7 @@ addArr (getConn -> conn) arr = do
+ Just m -> do
+ let occ = nameOccName n
+ mod = moduleName m
+- uid = moduleUnitId m
++ uid = moduleUnit m
+ execute conn "INSERT INTO typenames(name,mod,unit) VALUES (?,?,?)" (occ,mod,uid)
+ Just . fromOnly . head <$> query conn "SELECT id FROM typenames WHERE name = ? AND mod = ? AND unit = ?" (occ,mod,uid)
+
+@@ -179,7 +180,9 @@ addTypeRefs
+ -> IO ()
+ addTypeRefs db path hf ixs = mapM_ addTypesFromAst asts
+ where
++ arr :: A.Array TypeIndex HieTypeFlat
+ arr = hie_types hf
++ asts :: M.Map FS.FastString (HieAST TypeIndex)
+ asts = getAsts $ hie_asts hf
+ addTypesFromAst :: HieAST TypeIndex -> IO ()
+ addTypesFromAst ast = do
+@@ -187,7 +190,7 @@ addTypeRefs db path hf ixs = mapM_ addTypesFromAst asts
+ $ mapMaybe (\x -> guard (any (not . isOccurrence) (identInfo x)) *> identType x)
+ $ M.elems
+ $ nodeIdentifiers
+- $ nodeInfo ast
++ $ nodeInfo' ast
+ mapM_ addTypesFromAst $ nodeChildren ast
+
+ {-| Adds all references from given @.hie@ file to 'HieDb'.
+@@ -219,7 +222,7 @@ addRefsFromLoaded db@(getConn -> conn) path sourceFile hash hf = liftIO $ withTr
+
+ let isBoot = "boot" `isSuffixOf` path
+ mod = moduleName smod
+- uid = moduleUnitId smod
++ uid = moduleUnit smod
+ smod = hie_module hf
+ refmap = generateReferencesMap $ getAsts $ hie_asts hf
+ (srcFile, isReal) = case sourceFile of
+@@ -243,7 +246,7 @@ addRefsFromLoaded db@(getConn -> conn) path sourceFile hash hf = liftIO $ withTr
+ No action is taken if the corresponding @.hie@ file has not been indexed yet.
+ -}
+ addSrcFile
+- :: HieDb
++ :: HieDb
+ -> FilePath -- ^ Path to @.hie@ file
+ -> FilePath -- ^ Path to .hs file to be added to DB
+ -> Bool -- ^ Is this a real source file? I.e. does it come from user's project (as opposed to from project's dependency)?
+diff --git a/src/HieDb/Query.hs b/src/HieDb/Query.hs
+index 93f6132..9fe9913 100644
+--- a/src/HieDb/Query.hs
++++ b/src/HieDb/Query.hs
+@@ -41,11 +41,11 @@ import qualified HieDb.Html as Html
+ getAllIndexedMods :: HieDb -> IO [HieModuleRow]
+ getAllIndexedMods (getConn -> conn) = query_ conn "SELECT * FROM mods"
+
+-{-| Lookup UnitId associated with given ModuleName.
++{-| Lookup Unit associated with given ModuleName.
+ HieDbErr is returned if no module with given name has been indexed
+ or if ModuleName is ambiguous (i.e. there are multiple packages containing module with given name)
+ -}
+-resolveUnitId :: HieDb -> ModuleName -> IO (Either HieDbErr UnitId)
++resolveUnitId :: HieDb -> ModuleName -> IO (Either HieDbErr Unit)
+ resolveUnitId (getConn -> conn) mn = do
+ luid <- query conn "SELECT mod, unit, is_boot, hs_src, is_real, hash FROM mods WHERE mod = ? and is_boot = 0" (Only mn)
+ return $ case luid of
+@@ -53,7 +53,7 @@ resolveUnitId (getConn -> conn) mn = do
+ [x] -> Right $ modInfoUnit x
+ (x:xs) -> Left $ AmbiguousUnitId $ x :| xs
+
+-findReferences :: HieDb -> Bool -> OccName -> Maybe ModuleName -> Maybe UnitId -> [FilePath] -> IO [Res RefRow]
++findReferences :: HieDb -> Bool -> OccName -> Maybe ModuleName -> Maybe Unit -> [FilePath] -> IO [Res RefRow]
+ findReferences (getConn -> conn) isReal occ mn uid exclude =
+ queryNamed conn thisQuery ([":occ" := occ, ":mod" := mn, ":unit" := uid, ":real" := isReal] ++ excludedFields)
+ where
+@@ -65,8 +65,8 @@ findReferences (getConn -> conn) isReal occ mn uid exclude =
+ \((NOT :real) OR (mods.is_real AND mods.hs_src IS NOT NULL))"
+ <> " AND mods.hs_src NOT IN (" <> Query (T.intercalate "," (map (\(l := _) -> l) excludedFields)) <> ")"
+
+-{-| Lookup 'HieModule' row from 'HieDb' given its 'ModuleName' and 'UnitId' -}
+-lookupHieFile :: HieDb -> ModuleName -> UnitId -> IO (Maybe HieModuleRow)
++{-| Lookup 'HieModule' row from 'HieDb' given its 'ModuleName' and 'Unit' -}
++lookupHieFile :: HieDb -> ModuleName -> Unit -> IO (Maybe HieModuleRow)
+ lookupHieFile (getConn -> conn) mn uid = do
+ files <- query conn "SELECT * FROM mods WHERE mod = ? AND unit = ? AND is_boot = 0" (mn, uid)
+ case files of
+@@ -89,7 +89,7 @@ lookupHieFileFromSource (getConn -> conn) fp = do
+ ++ show fp ++ ". Entries: "
+ ++ intercalate ", " (map (show . toRow) xs)
+
+-findTypeRefs :: HieDb -> Bool -> OccName -> Maybe ModuleName -> Maybe UnitId -> [FilePath] -> IO [Res TypeRef]
++findTypeRefs :: HieDb -> Bool -> OccName -> Maybe ModuleName -> Maybe Unit -> [FilePath] -> IO [Res TypeRef]
+ findTypeRefs (getConn -> conn) isReal occ mn uid exclude
+ = queryNamed conn thisQuery ([":occ" := occ, ":mod" := mn, ":unit" := uid, ":real" := isReal] ++ excludedFields)
+ where
+@@ -103,14 +103,14 @@ findTypeRefs (getConn -> conn) isReal occ mn uid exclude
+ <> " AND mods.hs_src NOT IN (" <> Query (T.intercalate "," (map (\(l := _) -> l) excludedFields)) <> ")"
+ <> " ORDER BY typerefs.depth ASC"
+
+-findDef :: HieDb -> OccName -> Maybe ModuleName -> Maybe UnitId -> IO [Res DefRow]
++findDef :: HieDb -> OccName -> Maybe ModuleName -> Maybe Unit -> IO [Res DefRow]
+ findDef conn occ mn uid
+ = queryNamed (getConn conn) "SELECT defs.*, mods.mod,mods.unit,mods.is_boot,mods.hs_src,mods.is_real,mods.hash \
+ \FROM defs JOIN mods USING (hieFile) \
+ \WHERE occ = :occ AND (:mod IS NULL OR mod = :mod) AND (:unit IS NULL OR unit = :unit)"
+ [":occ" := occ,":mod" := mn, ":unit" := uid]
+
+-findOneDef :: HieDb -> OccName -> Maybe ModuleName -> Maybe UnitId -> IO (Either HieDbErr (Res DefRow))
++findOneDef :: HieDb -> OccName -> Maybe ModuleName -> Maybe Unit -> IO (Either HieDbErr (Res DefRow))
+ findOneDef conn occ mn muid = wrap <$> findDef conn occ mn muid
+ where
+ wrap [x] = Right x
+@@ -126,7 +126,7 @@ searchDef conn cs
+ \LIMIT 200" (Only $ '_':cs++"%")
+
+ {-| @withTarget db t f@ runs function @f@ with HieFile specified by HieTarget @t at .
+-In case the target is given by ModuleName (and optionally UnitId) it is first resolved
++In case the target is given by ModuleName (and optionally Unit) it is first resolved
+ from HieDb, which can lead to error if given file is not indexed/Module name is ambiguous.
+ -}
+ withTarget
+@@ -151,7 +151,7 @@ withTarget conn target f = case target of
+ nc <- newIORef =<< makeNc
+ runDbM nc $ do
+ Right <$> withHieFile fp' (return . f)
+-
++
+
+ type Vertex = (String, String, String, Int, Int, Int, Int)
+
+@@ -197,7 +197,7 @@ getVertices (getConn -> conn) ss = Set.toList <$> foldM f Set.empty ss
+ one s = do
+ let n = toNsChar (occNameSpace $ symName s) : occNameString (symName s)
+ m = moduleNameString $ moduleName $ symModule s
+- u = unitIdString (moduleUnitId $ symModule s)
++ u = unitString (moduleUnit $ symModule s)
+ query conn "SELECT mods.mod, decls.hieFile, decls.occ, decls.sl, decls.sc, decls.el, decls.ec \
+ \FROM decls JOIN mods USING (hieFile) \
+ \WHERE ( decls.occ = ? AND mods.mod = ? AND mods.unit = ? ) " (n, m, u)
+@@ -224,9 +224,9 @@ getAnnotations db symbols = do
+ m2 = foldl' (f Html.Unreachable) m1 us
+ return m2
+ where
+- f :: Html.Color
+- -> Map FilePath (ModuleName, Set Html.Span)
+- -> Vertex
++ f :: Html.Color
++ -> Map FilePath (ModuleName, Set Html.Span)
++ -> Vertex
+ -> Map FilePath (ModuleName, Set Html.Span)
+ f c m v =
+ let (fp, mod', sp) = g c v
+diff --git a/src/HieDb/Run.hs b/src/HieDb/Run.hs
+index 1184748..0c98134 100644
+--- a/src/HieDb/Run.hs
++++ b/src/HieDb/Run.hs
+@@ -14,6 +14,7 @@ import Name
+ import Module
+ import Outputable ((<+>),hang,showSDoc,ppr,text)
+ import IfaceType (IfaceType)
++import SrcLoc
+
+ import qualified FastString as FS
+
+@@ -86,15 +87,15 @@ data Options
+ data Command
+ = Init
+ | Index [FilePath]
+- | NameRefs String (Maybe ModuleName) (Maybe UnitId)
+- | TypeRefs String (Maybe ModuleName) (Maybe UnitId)
+- | NameDef String (Maybe ModuleName) (Maybe UnitId)
+- | TypeDef String (Maybe ModuleName) (Maybe UnitId)
++ | NameRefs String (Maybe ModuleName) (Maybe Unit)
++ | TypeRefs String (Maybe ModuleName) (Maybe Unit)
++ | NameDef String (Maybe ModuleName) (Maybe Unit)
++ | TypeDef String (Maybe ModuleName) (Maybe Unit)
+ | Cat HieTarget
+ | Ls
+ | Rm [HieTarget]
+ | ModuleUIDs ModuleName
+- | LookupHieFile ModuleName (Maybe UnitId)
++ | LookupHieFile ModuleName (Maybe Unit)
+ | RefsAtPoint HieTarget (Int,Int) (Maybe (Int,Int))
+ | TypesAtPoint HieTarget (Int,Int) (Maybe (Int,Int))
+ | DefsAtPoint HieTarget (Int,Int) (Maybe (Int,Int))
+@@ -195,9 +196,9 @@ cmdParser
+ posParser :: Char -> Parser (Int,Int)
+ posParser c = (,) <$> argument auto (metavar $ c:"LINE") <*> argument auto (metavar $ c:"COL")
+
+-maybeUnitId :: Parser (Maybe UnitId)
++maybeUnitId :: Parser (Maybe Unit)
+ maybeUnitId =
+- optional (stringToUnitId <$> strOption (short 'u' <> long "unit-id" <> metavar "UNITID"))
++ optional (stringToUnit <$> strOption (short 'u' <> long "unit-id" <> metavar "UNITID"))
+
+ symbolParser :: Parser Symbol
+ symbolParser = argument auto $ metavar "SYMBOL"
+@@ -299,7 +300,7 @@ runCommand libdir opts cmd = withHieDbAndFlags libdir (database opts) $ \dynFlag
+ putStr "\t"
+ putStr $ moduleNameString $ modInfoName $ hieModInfo mod
+ putStr "\t"
+- putStrLn $ unitIdString $ modInfoUnit $ hieModInfo mod
++ putStrLn $ unitString $ modInfoUnit $ hieModInfo mod
+ Rm targets -> do
+ forM_ targets $ \target -> do
+ case target of
+@@ -330,7 +331,7 @@ runCommand libdir opts cmd = withHieDbAndFlags libdir (database opts) $ \dynFlag
+ Nothing -> return $ Left (NotIndexed mn $ Just uid)
+ Just x -> Right <$> putStrLn (hieModuleHieFile x)
+ RefsAtPoint target sp mep -> hieFileCommand conn opts target $ \hf -> do
+- let names = concat $ pointCommand hf sp mep $ rights . M.keys . nodeIdentifiers . nodeInfo
++ let names = concat $ pointCommand hf sp mep $ rights . M.keys . nodeIdentifiers . nodeInfo'
+ when (null names) $
+ reportAmbiguousErr opts (Left $ NoNameAtPoint target sp)
+ forM_ names $ \name -> do
+@@ -339,7 +340,7 @@ runCommand libdir opts cmd = withHieDbAndFlags libdir (database opts) $ \dynFlag
+ hPutStrLn stderr ""
+ case nameModule_maybe name of
+ Just mod -> do
+- reportRefs opts =<< findReferences conn False (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnitId mod) []
++ reportRefs opts =<< findReferences conn False (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnit mod) []
+ Nothing -> do
+ let refmap = generateReferencesMap (getAsts $ hie_asts hf)
+ refs = map (toRef . fst) $ M.findWithDefault [] (Right name) refmap
+@@ -349,19 +350,19 @@ runCommand libdir opts cmd = withHieDbAndFlags libdir (database opts) $ \dynFlag
+ ,Just $ Right (hie_hs_src hf))
+ reportRefSpans opts refs
+ TypesAtPoint target sp mep -> hieFileCommand conn opts target $ \hf -> do
+- let types' = concat $ pointCommand hf sp mep $ nodeType . nodeInfo
++ let types' = concat $ pointCommand hf sp mep $ nodeType . nodeInfo'
+ types = map (flip recoverFullType $ hie_types hf) types'
+ when (null types) $
+ reportAmbiguousErr opts (Left $ NoNameAtPoint target sp)
+ forM_ types $ \typ -> do
+ putStrLn $ renderHieType dynFlags typ
+ DefsAtPoint target sp mep -> hieFileCommand conn opts target $ \hf -> do
+- let names = concat $ pointCommand hf sp mep $ rights . M.keys . nodeIdentifiers . nodeInfo
++ let names = concat $ pointCommand hf sp mep $ rights . M.keys . nodeIdentifiers . nodeInfo'
+ when (null names) $
+ reportAmbiguousErr opts (Left $ NoNameAtPoint target sp)
+ forM_ names $ \name -> do
+ case nameSrcSpan name of
+- RealSrcSpan dsp -> do
++ RealSrcSpan dsp _ -> do
+ unless (quiet opts) $
+ hPutStrLn stderr $ unwords ["Name", ppName opts (nameOccName name),"at",ppSpan opts sp,"is defined at:"]
+ contents <- case nameModule_maybe name of
+@@ -369,7 +370,7 @@ runCommand libdir opts cmd = withHieDbAndFlags libdir (database opts) $ \dynFlag
+ Just mod
+ | mod == hie_module hf -> pure $ Just $ Right $ hie_hs_src hf
+ | otherwise -> unsafeInterleaveIO $ do
+- loc <- findOneDef conn (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnitId mod)
++ loc <- findOneDef conn (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnit mod)
+ pure $ case loc of
+ Left _ -> Nothing
+ Right (row:._) -> Just $ Left $ defSrc row
+@@ -384,7 +385,7 @@ runCommand libdir opts cmd = withHieDbAndFlags libdir (database opts) $ \dynFlag
+ case nameModule_maybe name of
+ Just mod -> do
+ (row:.inf) <- reportAmbiguousErr opts
+- =<< findOneDef conn (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnitId mod)
++ =<< findOneDef conn (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnit mod)
+ unless (quiet opts) $
+ hPutStrLn stderr $ unwords ["Name", ppName opts (nameOccName name),"at",ppSpan opts sp,"is defined at:"]
+ reportRefSpans opts
+@@ -394,10 +395,10 @@ runCommand libdir opts cmd = withHieDbAndFlags libdir (database opts) $ \dynFlag
+ ,Just $ Left $ defSrc row
+ )]
+ Nothing -> do
+- reportAmbiguousErr opts $ Left $ NameUnhelpfulSpan name (FS.unpackFS msg)
++ reportAmbiguousErr opts $ Left $ NameUnhelpfulSpan name (FS.unpackFS $ unhelpfulSpanFS msg)
+ InfoAtPoint target sp mep -> hieFileCommand conn opts target $ \hf -> do
+ mapM_ (uncurry $ printInfo dynFlags) $ pointCommand hf sp mep $ \ast ->
+- (hieTypeToIface . flip recoverFullType (hie_types hf) <$> nodeInfo ast, nodeSpan ast)
++ (hieTypeToIface . flip recoverFullType (hie_types hf) <$> nodeInfo' ast, nodeSpan ast)
+ RefGraph -> declRefs conn
+ Dump path -> do
+ nc <- newIORef =<< makeNc
+@@ -450,13 +451,13 @@ showHieDbErr :: Options -> HieDbErr -> String
+ showHieDbErr opts e = case e of
+ NoNameAtPoint t spn -> unwords ["No symbols found at",ppSpan opts spn,"in",either id (\(mn,muid) -> ppMod opts mn ++ maybe "" (\uid -> "("++ppUnit opts uid++")") muid) t]
+ NotIndexed mn muid -> unwords ["Module", ppMod opts mn ++ maybe "" (\uid -> "("++ppUnit opts uid++")") muid, "not indexed."]
+- AmbiguousUnitId xs -> unlines $ "UnitId could be any of:" : map ((" - "<>) . unitIdString . modInfoUnit) (toList xs)
++ AmbiguousUnitId xs -> unlines $ "Unit could be any of:" : map ((" - "<>) . unitString . modInfoUnit) (toList xs)
+ <> ["Use --unit-id to disambiguate"]
+ NameNotFound occ mn muid -> unwords
+ ["Couldn't find name:", ppName opts occ, maybe "" (("from module " ++) . moduleNameString) mn ++ maybe "" (\uid ->"("++ppUnit opts uid++")") muid]
+ NameUnhelpfulSpan nm msg -> unwords
+ ["Got no helpful spans for:", occNameString (nameOccName nm), "\nMsg:", msg]
+-
++
+ reportRefSpans :: Options -> [(Module,(Int,Int),(Int,Int),Maybe (Either FilePath BS.ByteString))] -> IO ()
+ reportRefSpans opts xs = do
+ nc <- newIORef =<< makeNc
+@@ -530,7 +531,7 @@ ppName = colouredPP Red occNameString
+ ppMod :: Options -> ModuleName -> String
+ ppMod = colouredPP Green moduleNameString
+
+-ppUnit :: Options -> UnitId -> String
++ppUnit :: Options -> Unit -> String
+ ppUnit = colouredPP Yellow show
+
+ ppSpan :: Options -> (Int,Int) -> String
+diff --git a/src/HieDb/Types.hs b/src/HieDb/Types.hs
+index 3e1717a..11ee355 100644
+--- a/src/HieDb/Types.hs
++++ b/src/HieDb/Types.hs
+@@ -5,6 +5,7 @@
+ {-# LANGUAGE BlockArguments #-}
+ {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+ {-# LANGUAGE StandaloneDeriving #-}
++{-# LANGUAGE FlexibleInstances #-}
+ {-# OPTIONS_GHC -Wno-orphans #-}
+ module HieDb.Types where
+
+@@ -55,7 +56,7 @@ data SourceFile = RealFile FilePath | FakeFile (Maybe FilePath)
+ data ModuleInfo
+ = ModuleInfo
+ { modInfoName :: ModuleName
+- , modInfoUnit :: UnitId -- ^ Identifies the package this module is part of
++ , modInfoUnit :: Unit -- ^ Identifies the package this module is part of
+ , modInfoIsBoot :: Bool -- ^ True, when this ModuleInfo was created by indexing @.hie-boot@ file;
+ -- False when it was created from @.hie@ file
+ , modInfoSrcFile :: Maybe FilePath -- ^ The path to the haskell source file, from which the @.hie@ file was created
+@@ -79,6 +80,11 @@ instance ToField ModuleName where
+ instance FromField ModuleName where
+ fromField fld = mkModuleName . T.unpack <$> fromField fld
+
++instance ToField (GenUnit UnitId) where
++ toField uid = SQLText $ T.pack $ unitString uid
++instance FromField (GenUnit UnitId) where
++ fromField fld = stringToUnit . T.unpack <$> fromField fld
++
+ instance ToField UnitId where
+ toField uid = SQLText $ T.pack $ unitIdString uid
+ instance FromField UnitId where
+@@ -139,7 +145,7 @@ data RefRow
+ { refSrc :: FilePath
+ , refNameOcc :: OccName
+ , refNameMod :: ModuleName
+- , refNameUnit :: UnitId
++ , refNameUnit :: Unit
+ , refSLine :: Int
+ , refSCol :: Int
+ , refELine :: Int
+@@ -175,7 +181,7 @@ instance FromRow DeclRow where
+ data TypeName = TypeName
+ { typeName :: OccName
+ , typeMod :: ModuleName
+- , typeUnit :: UnitId
++ , typeUnit :: Unit
+ }
+
+ data TypeRef = TypeRef
+@@ -233,9 +239,9 @@ instance MonadIO m => NameCacheMonad (DbMonadT m) where
+
+
+ data HieDbErr
+- = NotIndexed ModuleName (Maybe UnitId)
++ = NotIndexed ModuleName (Maybe Unit)
+ | AmbiguousUnitId (NonEmpty ModuleInfo)
+- | NameNotFound OccName (Maybe ModuleName) (Maybe UnitId)
++ | NameNotFound OccName (Maybe ModuleName) (Maybe Unit)
+ | NoNameAtPoint HieTarget (Int,Int)
+ | NameUnhelpfulSpan Name String
+
+@@ -251,7 +257,8 @@ instance Show Symbol where
+ <> ":"
+ <> moduleNameString (moduleName $ symModule s)
+ <> ":"
+- <> unitIdString (moduleUnitId $ symModule s)
++ -- <> unitIdString (moduleUnit $ symModule s)
++ <> unitString (moduleUnit $ symModule s)
+
+ instance Read Symbol where
+ readsPrec = const $ R.readP_to_S readSymbol
+@@ -275,7 +282,7 @@ readSymbol = do
+ u <- R.many1 R.get
+ R.eof
+ let mn = mkModuleName m
+- uid = stringToUnitId u
++ uid = stringToUnit u
+ sym = Symbol
+ { symName = mkOccName ns n
+ , symModule = mkModule uid mn
+@@ -288,5 +295,5 @@ newtype LibDir = LibDir FilePath
+
+ -- | A way to specify which HieFile to operate on.
+ -- Either the path to @.hie@ file is given in the Left
+--- Or ModuleName (with optional UnitId) is given in the Right
+-type HieTarget = Either FilePath (ModuleName, Maybe UnitId)
++-- Or ModuleName (with optional Unit) is given in the Right
++type HieTarget = Either FilePath (ModuleName, Maybe Unit)
+diff --git a/src/HieDb/Utils.hs b/src/HieDb/Utils.hs
+index 9e5b34e..1ca1cab 100644
+--- a/src/HieDb/Utils.hs
++++ b/src/HieDb/Utils.hs
+@@ -26,6 +26,7 @@ import DynFlags
+ import SysTools
+
+ import qualified Data.Map as M
++import qualified Data.Set as S
+
+ import qualified FastString as FS
+
+@@ -71,7 +72,8 @@ 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]
++ HFunTy a b _ -> mapM_ next [a,b]
+ HQualTy a b -> mapM_ next [a,b]
+ HLitTy _ -> pure ()
+ HCastTy a -> go d a
+@@ -115,9 +117,9 @@ findDefInFile occ mdl file = do
+ nc <- readIORef ncr
+ return $ case lookupOrigNameCache (nsNames nc) mdl occ of
+ Just name -> case nameSrcSpan name of
+- RealSrcSpan sp -> Right (sp, mdl)
+- UnhelpfulSpan msg -> Left $ NameUnhelpfulSpan name (FS.unpackFS msg)
+- Nothing -> Left $ NameNotFound occ (Just $ moduleName mdl) (Just $ moduleUnitId mdl)
++ RealSrcSpan sp _ -> Right (sp, mdl)
++ UnhelpfulSpan msg -> Left $ NameUnhelpfulSpan name (FS.unpackFS $ unhelpfulSpanFS msg)
++ Nothing -> Left $ NameNotFound occ (Just $ moduleName mdl) (Just $ moduleUnit mdl)
+
+ pointCommand :: HieFile -> (Int, Int) -> Maybe (Int, Int) -> (HieAST TypeIndex -> a) -> [a]
+ pointCommand hf (sl,sc) mep k =
+@@ -158,7 +160,7 @@ genRefsAndDecls path smdl refmap = genRows $ flat $ M.toList refmap
+
+ goRef (Right name, (sp,_))
+ | Just mod <- nameModule_maybe name = Just $
+- RefRow path occ (moduleName mod) (moduleUnitId mod) sl sc el ec
++ RefRow path occ (moduleName mod) (moduleUnit mod) sl sc el ec
+ where
+ occ = nameOccName name
+ sl = srcSpanStartLine sp
+@@ -198,7 +200,7 @@ genDefRow path smod refmap = genRows $ M.toList refmap
+ where
+ genRows = mapMaybe go
+ getSpan name dets
+- | RealSrcSpan sp <- nameSrcSpan name = Just sp
++ | RealSrcSpan sp _ <- nameSrcSpan name = Just sp
+ | otherwise = do
+ (sp, _dets) <- find defSpan dets
+ pure sp
+@@ -222,8 +224,24 @@ genDefRow path smod refmap = genRows $ M.toList refmap
+ go _ = Nothing
+
+ identifierTree :: HieTypes.HieAST a -> Data.Tree.Tree ( HieTypes.HieAST a )
+-identifierTree HieTypes.Node{ nodeInfo, nodeSpan, nodeChildren } =
++identifierTree nd at HieTypes.Node{ nodeChildren } =
+ Data.Tree.Node
+- { rootLabel = HieTypes.Node{ nodeInfo, nodeSpan, nodeChildren = mempty }
++ { 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
+diff --git a/test/Main.hs b/test/Main.hs
+index c9023d2..42d2850 100644
+--- a/test/Main.hs
++++ b/test/Main.hs
+@@ -6,7 +6,7 @@ import HieDb.Query (getAllIndexedMods, lookupHieFile, resolveUnitId, lookupHieFi
+ import HieDb.Run (Command (..), Options (..), runCommand)
+ import HieDb.Types (HieDbErr (..), SourceFile(..), runDbM)
+ import HieDb.Utils (makeNc)
+-import Module (mkModuleName, moduleNameString, stringToUnitId)
++import Module (mkModuleName, moduleNameString, stringToUnit)
+ import System.Directory (findExecutable, getCurrentDirectory, removeDirectoryRecursive)
+ import System.Exit (ExitCode (..), die)
+ import System.FilePath ((</>))
+@@ -53,7 +53,7 @@ apiSpec = describe "api" $
+ res <- resolveUnitId conn (mkModuleName "Module1")
+ case res of
+ Left e -> fail $ "Unexpected error: " <> show e
+- Right unitId -> unitId `shouldBe` stringToUnitId "main"
++ Right unit -> unit `shouldBe` stringToUnit "main"
+
+ it "returns NotIndexed error on not-indexed module" $ \conn -> do
+ let notIndexedModule = mkModuleName "NotIndexed"
+@@ -61,12 +61,12 @@ apiSpec = describe "api" $
+ case res of
+ Left (NotIndexed modName Nothing) -> modName `shouldBe` notIndexedModule
+ Left e -> fail $ "Unexpected error: " <> show e
+- Right unitId -> fail $ "Unexpected success: " <> show unitId
++ Right unit -> fail $ "Unexpected success: " <> show unit
+
+ describe "lookupHieFile" $ do
+ it "Should lookup indexed Module" $ \conn -> do
+ let modName = mkModuleName "Module1"
+- res <- lookupHieFile conn modName (stringToUnitId "main")
++ res <- lookupHieFile conn modName (stringToUnit "main")
+ case res of
+ Just modRow -> do
+ hieModuleHieFile modRow `shouldEndWith` "Module1.hie"
+@@ -75,7 +75,7 @@ apiSpec = describe "api" $
+ modInfoName modInfo `shouldBe` modName
+ Nothing -> fail "Should have looked up indexed file"
+ it "Should return Nothing for not indexed Module" $ \conn -> do
+- res <- lookupHieFile conn (mkModuleName "NotIndexed") (stringToUnitId "main")
++ res <- lookupHieFile conn (mkModuleName "NotIndexed") (stringToUnit "main")
+ case res of
+ Nothing -> pure ()
+ Just _ -> fail "Lookup suceeded unexpectedly"
+@@ -203,18 +203,20 @@ cliSpec =
+ , "Identifiers:"
+ , "Symbol:c:Data1Constructor1:Sub.Module2:main"
+ , "Data1Constructor1 defined at test/data/Sub/Module2.hs:10:7-23"
+- , " IdentifierDetails Nothing {Decl ConDec (Just SrcSpanOneLine \"test/data/Sub/Module2.hs\" 10 7 24)}"
++ , " Details: Nothing {declaration of constructor bound at: test/data/Sub/Module2.hs:10:7-23}"
+ , "Types:\n"
+ ]
+ it "correctly prints type signatures" $
+ runHieDbCli ["point-info", "Module1", "10", "10"]
+ `suceedsWithStdin` unlines
+ [ "Span: test/data/Module1.hs:10:8-11"
+- , "Constructors: {(HsVar, HsExpr), (HsWrap, HsExpr)}"
++ , "Constructors: {(HsVar, HsExpr), (XExpr, HsExpr)}"
+ , "Identifiers:"
+ , "Symbol:v:even:GHC.Real:base"
+ , "even defined at <no location info>"
+- , " IdentifierDetails Just forall a. Integral a => a -> Bool {Use}"
++ , " Details: Just forall a. Integral a => a -> Bool {usage}"
++ , "$dIntegral defined at <no location info>"
++ , " Details: Just Integral Int {usage of evidence variable}"
+ , "Types:"
+ , "Int -> Bool"
+ , "forall a. Integral a => a -> Bool"
+@@ -252,7 +254,7 @@ cliSpec =
+ it "lists uids for given module" $
+ runHieDbCli ["module-uids", "Module1"]
+ `suceedsWithStdin` "main\n"
+-
++
+ describe "rm" $
+ it "removes given module from DB" $ do
+ runHieDbCli ["rm", "Module1"]
+@@ -260,7 +262,7 @@ cliSpec =
+ -- Check with 'ls' comand that there's just one module left
+ cwd <- getCurrentDirectory
+ runHieDbCli ["ls"] `suceedsWithStdin` (cwd </> testTmp </> "Sub/Module2.hie\tSub.Module2\tmain\n")
+-
++
+
+
+ suceedsWithStdin :: IO (ExitCode, String, String) -> String -> Expectation
+diff --git a/test/Test/Orphans.hs b/test/Test/Orphans.hs
+index af1124a..3d7684b 100644
+--- a/test/Test/Orphans.hs
++++ b/test/Test/Orphans.hs
+@@ -3,7 +3,7 @@
+ module Test.Orphans where
+
+ import HieDb.Types
+-import Module (ModuleName, moduleName, moduleNameString, moduleUnitId)
++import Module (ModuleName, moduleName, moduleNameString, moduleUnit)
+ import Name (Name, nameModule, nameOccName)
+ import OccName (OccName, occNameString)
+
+@@ -14,7 +14,7 @@ instance Show Name where
+ let occ = nameOccName n
+ mod' = nameModule n
+ mn = moduleName mod'
+- uid = moduleUnitId mod'
++ uid = moduleUnit mod'
+ in show uid <> ":" <> show mn <> ":" <> show occ
+
+ deriving instance Show HieDbErr
+
+From 511dbb8dfe85d7c1625cb92051948d550c69b5c1 Mon Sep 17 00:00:00 2001
+From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= <anka.213 at gmail.com>
+Date: Tue, 30 Mar 2021 01:55:37 +0800
+Subject: [PATCH 2/7] Make changes backwards-compatible
+
+---
+ hiedb.cabal | 1 +
+ src/HieDb/Compat.hs | 49 +++++++++++++++++++++++++++++++++++++++++++++
+ src/HieDb/Create.hs | 3 ++-
+ src/HieDb/Query.hs | 1 +
+ src/HieDb/Run.hs | 6 ++++++
+ src/HieDb/Types.hs | 11 ++++------
+ src/HieDb/Utils.hs | 33 +++++++++++++-----------------
+ 7 files changed, 77 insertions(+), 27 deletions(-)
+ create mode 100644 src/HieDb/Compat.hs
+
+diff --git a/hiedb.cabal b/hiedb.cabal
+index f198504..540a278 100644
+--- a/hiedb.cabal
++++ b/hiedb.cabal
+@@ -49,6 +49,7 @@ library
+ HieDb.Utils,
+ HieDb.Create,
+ HieDb.Query,
++ HieDb.Compat,
+ HieDb.Types,
+ HieDb.Dump,
+ HieDb.Html,
+diff --git a/src/HieDb/Compat.hs b/src/HieDb/Compat.hs
+new file mode 100644
+index 0000000..9fe8b6c
+--- /dev/null
++++ b/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
+diff --git a/src/HieDb/Create.hs b/src/HieDb/Create.hs
+index 57c3fac..47e76a5 100644
+--- a/src/HieDb/Create.hs
++++ b/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
+diff --git a/src/HieDb/Query.hs b/src/HieDb/Query.hs
+index 9fe9913..29f44d5 100644
+--- a/src/HieDb/Query.hs
++++ b/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
+diff --git a/src/HieDb/Run.hs b/src/HieDb/Run.hs
+index 0c98134..b92adb2 100644
+--- a/src/HieDb/Run.hs
++++ b/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
+diff --git a/src/HieDb/Types.hs b/src/HieDb/Types.hs
+index 11ee355..3bc2ec7 100644
+--- a/src/HieDb/Types.hs
++++ b/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
+diff --git a/src/HieDb/Utils.hs b/src/HieDb/Utils.hs
+index 1ca1cab..d47a8b2 100644
+--- a/src/HieDb/Utils.hs
++++ b/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 nd at HieTypes.Node{ 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
+
+From 06db1ed8e2d97ba64b88d928f622c5a8adc7389d Mon Sep 17 00:00:00 2001
+From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= <anka.213 at gmail.com>
+Date: Tue, 30 Mar 2021 02:41:59 +0800
+Subject: [PATCH 3/7] Fix warnings and tests
+
+---
+ cabal.project | 3 ---
+ src/HieDb/Compat.hs | 15 ++++++++++++---
+ src/HieDb/Query.hs | 2 +-
+ src/HieDb/Run.hs | 2 --
+ test/Main.hs | 16 +++++++++++++++-
+ test/Test/Orphans.hs | 3 ++-
+ 6 files changed, 30 insertions(+), 11 deletions(-)
+ delete mode 100644 cabal.project
+
+diff --git a/cabal.project b/cabal.project
+deleted file mode 100644
+index 5aaedaa..0000000
+--- a/cabal.project
++++ /dev/null
+@@ -1,3 +0,0 @@
+-packages: .
+--- package hiedb
+--- ghc-options: -fwrite-ide-info -hiedir /home/zubin/hiedb/.hie/
+diff --git a/src/HieDb/Compat.hs b/src/HieDb/Compat.hs
+index 9fe8b6c..98c224a 100644
+--- a/src/HieDb/Compat.hs
++++ b/src/HieDb/Compat.hs
+@@ -1,10 +1,21 @@
+
+ {-# LANGUAGE CPP #-}
+-module HieDb.Compat where
++module HieDb.Compat (
++ nodeInfo'
++ , Unit
++ , unitString
++ , stringToUnit
++ , moduleUnit
++ , unhelpfulSpanFS
++
++) where
+
+ import Compat.HieTypes
+
++import Module
++
+ #if __GLASGOW_HASKELL__ >= 900
++import GHC.Types.SrcLoc
+ import Compat.HieUtils
+
+ import qualified Data.Map as M
+@@ -29,8 +40,6 @@ combineNodeInfo' :: Ord a => NodeInfo a -> NodeInfo a -> NodeInfo a
+ #else
+ import qualified FastString as FS
+
+-import Module
+-
+ nodeInfo' :: HieAST TypeIndex -> NodeInfo TypeIndex
+ nodeInfo' = nodeInfo
+ type Unit = UnitId
+diff --git a/src/HieDb/Query.hs b/src/HieDb/Query.hs
+index 29f44d5..cde533e 100644
+--- a/src/HieDb/Query.hs
++++ b/src/HieDb/Query.hs
+@@ -12,7 +12,7 @@ import qualified Algebra.Graph.Export.Dot as G
+
+ import GHC
+ import Compat.HieTypes
+-import Module
++-- import Module
+ import Name
+
+ import System.Directory
+diff --git a/src/HieDb/Run.hs b/src/HieDb/Run.hs
+index b92adb2..b0e737e 100644
+--- a/src/HieDb/Run.hs
++++ b/src/HieDb/Run.hs
+@@ -12,10 +12,8 @@ import GHC
+ import Compat.HieTypes
+ import Compat.HieUtils
+ import Name
+-import Module
+ import Outputable ((<+>),hang,showSDoc,ppr,text)
+ import IfaceType (IfaceType)
+-import SrcLoc
+
+ import qualified FastString as FS
+
+diff --git a/test/Main.hs b/test/Main.hs
+index 42d2850..a88d520 100644
+--- a/test/Main.hs
++++ b/test/Main.hs
+@@ -1,3 +1,4 @@
++{-# LANGUAGE CPP #-}
+ module Main where
+
+ import GHC.Paths (libdir)
+@@ -6,7 +7,8 @@ import HieDb.Query (getAllIndexedMods, lookupHieFile, resolveUnitId, lookupHieFi
+ import HieDb.Run (Command (..), Options (..), runCommand)
+ import HieDb.Types (HieDbErr (..), SourceFile(..), runDbM)
+ import HieDb.Utils (makeNc)
+-import Module (mkModuleName, moduleNameString, stringToUnit)
++import HieDb.Compat (stringToUnit)
++import Module (mkModuleName, moduleNameString)
+ import System.Directory (findExecutable, getCurrentDirectory, removeDirectoryRecursive)
+ import System.Exit (ExitCode (..), die)
+ import System.FilePath ((</>))
+@@ -203,20 +205,32 @@ cliSpec =
+ , "Identifiers:"
+ , "Symbol:c:Data1Constructor1:Sub.Module2:main"
+ , "Data1Constructor1 defined at test/data/Sub/Module2.hs:10:7-23"
++#if __GLASGOW_HASKELL__ >= 900
+ , " Details: Nothing {declaration of constructor bound at: test/data/Sub/Module2.hs:10:7-23}"
++#else
++ , " IdentifierDetails Nothing {Decl ConDec (Just SrcSpanOneLine \"test/data/Sub/Module2.hs\" 10 7 24)}"
++#endif
+ , "Types:\n"
+ ]
+ it "correctly prints type signatures" $
+ runHieDbCli ["point-info", "Module1", "10", "10"]
+ `suceedsWithStdin` unlines
+ [ "Span: test/data/Module1.hs:10:8-11"
++#if __GLASGOW_HASKELL__ >= 900
+ , "Constructors: {(HsVar, HsExpr), (XExpr, HsExpr)}"
++#else
++ , "Constructors: {(HsVar, HsExpr), (HsWrap, HsExpr)}"
++#endif
+ , "Identifiers:"
+ , "Symbol:v:even:GHC.Real:base"
+ , "even defined at <no location info>"
++#if __GLASGOW_HASKELL__ >= 900
+ , " Details: Just forall a. Integral a => a -> Bool {usage}"
+ , "$dIntegral defined at <no location info>"
+ , " Details: Just Integral Int {usage of evidence variable}"
++#else
++ , " IdentifierDetails Just forall a. Integral a => a -> Bool {Use}"
++#endif
+ , "Types:"
+ , "Int -> Bool"
+ , "forall a. Integral a => a -> Bool"
+diff --git a/test/Test/Orphans.hs b/test/Test/Orphans.hs
+index 3d7684b..b114dc4 100644
+--- a/test/Test/Orphans.hs
++++ b/test/Test/Orphans.hs
+@@ -2,8 +2,9 @@
+ {-# OPTIONS_GHC -fno-warn-orphans #-}
+ module Test.Orphans where
+
++import HieDb.Compat
+ import HieDb.Types
+-import Module (ModuleName, moduleName, moduleNameString, moduleUnit)
++import Module (ModuleName, moduleName, moduleNameString)
+ import Name (Name, nameModule, nameOccName)
+ import OccName (OccName, occNameString)
+
+
More information about the arch-commits
mailing list