Add tests for custom option cradles in CheckSpec, FindSpec, ListSpec.

Language/Haskell/GhcMod/Find.hs

@@ -28,7 +28,6 @@ import Exception
 import Language.Haskell.GhcMod.Convert
 import Language.Haskell.GhcMod.Gap
 import Language.Haskell.GhcMod.Monad
-import Language.Haskell.GhcMod.Output
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Utils
 import Language.Haskell.GhcMod.World
@@ -111,26 +110,23 @@ loadSymbolDb' = do
         return db
   doLoad =<< liftIO (doesFileExist cache)
 
--- | Loading a file and creates 'SymbolDb'.
 loadSymbolDb :: IOish m => GhcModT m SymbolDb
 loadSymbolDb = do
-  ghcMod <- liftIO ghcModExecutable
-  readProc <- gmReadProcess'
-  out <- liftIO $ readProc ghcMod ["--verbose", "error", "dumpsym"] ""
-  return $!! decode out
+  ts <- liftIO getCurrentModTime
+  st <- runGmPkgGhc $ (liftIO . getGlobalSymbolTable) =<< G.getSession
+  return SymbolDb {
+      sdTable = st
+    , sdTimestamp = ts
+    }
 
 ----------------------------------------------------------------
 -- used 'ghc-mod dumpsym'
 
 -- | Dumps a 'Binary' representation of 'SymbolDb' to stdout
 dumpSymbol :: IOish m => GhcModT m ()
 dumpSymbol = do
-  ts <- liftIO getCurrentModTime
-  st <- runGmPkgGhc $ (liftIO . getGlobalSymbolTable) =<< G.getSession
-  liftIO . LBS.putStr $ encode SymbolDb {
-      sdTable = st
-    , sdTimestamp = ts
-    }
+  symbolDb <- loadSymbolDb
+  liftIO . LBS.putStr $ encode symbolDb
 
 -- | Check whether given file is older than any file from the given set.
 -- Returns True if given file does not exist.

test/CheckSpec.hs

@@ -77,16 +77,14 @@ spec = do
                 res `shouldBe` "NiceQualification.hs:4:8:Couldn't match expected type `IO ()' with actual type `[Char]'\NULIn the expression: \"wrong type\"\NULIn an equation for `main': main = \"wrong type\"\n"
 #endif
 
-        it "works with explicit options" $ do
-            withDirectory_ "test/data/options-cradle" $ do
-                res <- runD $ checkSyntax ["src/Main.hs"]
-                res `shouldBe` ""
+        it "works with explicit options" $ bracketTagged $ do
+            res <- runD $ checkSyntax ["src/Main.hs"]
+            res `shouldBe` ""
 
-        it "emits error with explicit options" $ do
-            withDirectory_ "test/data/options-cradle" $ do
-                res <- runD $ checkSyntax ["src/Main2.hs"]
+        it "emits error with explicit options" $ bracketTagged $ do
+            res <- runD $ checkSyntax ["src/Main2.hs"]
 #if __GLASGOW_HASKELL__ >= 708
-                res `shouldBe` "src/Main2.hs:10:11:Couldn't match expected type \8216Int\8217 with actual type \8216a0 -> a0\8217\NULProbable cause: \8216id\8217 is applied to too few arguments\NULIn the second argument of \8216(+)\8217, namely \8216id\8217\NULIn the expression: 0 + id\n"
+            res `shouldBe` "src/Main2.hs:10:11:Couldn't match expected type \8216Int\8217 with actual type \8216a0 -> a0\8217\NULProbable cause: \8216id\8217 is applied to too few arguments\NULIn the second argument of \8216(+)\8217, namely \8216id\8217\NULIn the expression: 0 + id\n"
 #else
-                res `shouldBe` "src/Main2.hs:10:11:Couldn't match expected type `Int' with actual type `a0 -> a0'\NULIn the second argument of `(+)', namely `id'\NULIn the expression: 0 + id\NULIn an equation for `foo': foo = 0 + id\n"
+            res `shouldBe` "src/Main2.hs:10:11:Couldn't match expected type `Int' with actual type `a0 -> a0'\NULIn the second argument of `(+)', namely `id'\NULIn the expression: 0 + id\NULIn an equation for `foo': foo = 0 + id\n"
 #endif

test/CustomPackageDbSpec.hs

@@ -17,7 +17,6 @@ spec = do
             let tdir = "test/data/custom-cradle"
             Just stack <- runD' tdir $ getCustomPkgDbStack
             stack `shouldBe` [ GlobalDb
-                             , UserDb
                              , PackageDb "package-db-a"
                              , PackageDb "package-db-b"
                              , PackageDb "package-db-c"

test/FindSpec.hs

@@ -5,9 +5,20 @@ import Language.Haskell.GhcMod.Find
 import Test.Hspec
 import TestUtils
 
+import Dir
+
 spec :: Spec
 spec = do
     describe "db <- loadSymbolDb" $ do
         it "lookupSymbol' db \"head\"  contains at least `Data.List'" $ do
             db <- runD $ loadSymbolDb
             lookupSym "head" db `shouldContain` [ModuleString "Data.List"]
+
+        it "lookupSymbol' db \"untag\"  contains at least `Data.Tagged'" $ bracketTagged $ do
+            db <- runD $ loadSymbolDb
+            lookupSym "untag" db `shouldContain` [ModuleString "Data.Tagged"]
+
+        it "lookupSymbol' db \"untag\" does not contain `Data.Tagged' if not installed" $ do
+          withDirectory_ "test/data/options-cradle" $ do
+            db <- runD $ loadSymbolDb
+            lookupSym "untag" db `shouldNotContain` [ModuleString "Data.Tagged"]

test/InfoSpec.hs

@@ -25,10 +25,9 @@ spec = do
             res <- runD' tdir $ types "ImportsTH.hs" 3 8
             res `shouldBe` unlines ["3 8 3 16 \"String -> IO ()\"", "3 8 3 20 \"IO ()\"", "3 1 3 20 \"IO ()\""]
 
-        it "works with a module in Explicit project type" $ do
-            let tdir = "test/data/options-cradle"
-            res <- runD' tdir $ types "src/Main.hs" 7 10
-            res `shouldBe` unlines ["7 8 7 14 \"() -> IO ()\"\n7 8 7 17 \"IO ()\"\n7 1 7 17 \"IO ()\""]
+        it "works with a module in Explicit project type" $ bracketTagged $ do
+            res <- runD $ types "src/Main.hs" 9 10
+            res `shouldBe` unlines ["9 8 9 14 \"() -> IO ()\"\n9 8 9 17 \"IO ()\"\n9 1 9 17 \"IO ()\""]
 
     describe "info" $ do
         it "works for non exported functions" $ do
@@ -46,7 +45,6 @@ spec = do
             res <- runD' tdir $ info "ImportsTH.hs" $ Expression "bar"
             res `shouldSatisfy` ("bar :: [Char]" `isPrefixOf`)
 
-        it "works with a module in Explicit project type" $ do
-            let tdir = "test/data/options-cradle"
-            res <- runD' tdir $ info "src/Main.hs" $ Expression "foo"
+        it "works with a module in Explicit project type" $ bracketTagged $ do
+            res <- runD $ info "src/Main.hs" $ Expression "foo"
             res `shouldSatisfy` ("foo :: Int" `isPrefixOf`)

test/ListSpec.hs

@@ -14,8 +14,11 @@ spec = do
             mdls <- runD $ lines <$> modules False
             mdls `shouldContain` ["Data.Map"]
 
-    describe "modules" $ do
-        it "contains at least `Main'" $ do
+        it "contains at least `Data.Tagged'" $ bracketTagged $ do
+            mdls <- runD $ lines <$> modules False
+            mdls `shouldContain` ["Data.Tagged"]
+
+        it "does not contain `Data.Tagged'" $ do
             withDirectory_ "test/data/options-cradle" $ do
                 mdls <- runD $ lines <$> modules False
-                mdls `shouldContain` ["Data.Map"]
+                mdls `shouldNotContain` ["Data.Tagged"]

test/TestUtils.hs

@@ -10,6 +10,7 @@ module TestUtils (
   , shouldReturnError
   , isPkgDbAt
   , isPkgConfDAt
+  , bracketTagged
   , module Language.Haskell.GhcMod.Monad
   , module Language.Haskell.GhcMod.Types
   ) where
@@ -22,13 +23,16 @@ import Language.Haskell.GhcMod.Types
 import Control.Arrow
 import Control.Category
 import Control.Applicative
+import Control.Monad
 import Control.Monad.Error (ErrorT, runErrorT)
 import Control.Monad.Trans.Journal
 import Data.List.Split
 import Data.Label
 import Data.String
+import Dir
 import System.FilePath
 import System.Directory
+import System.Process
 import Test.Hspec
 import Prelude hiding ((.))
 
@@ -122,3 +126,16 @@ isPkgDbAt _ _ = False
 
 instance IsString ModuleName where
     fromString = mkModuleName
+
+-- | Bracketing function for test/data/options-cradle environment to install tagged in package-db-a
+bracketTagged :: IO a -> IO a
+bracketTagged m = do
+    withDirectory_ "test/data/options-cradle" $ do
+        void $ system "cabal install --global --package-db=package-db-a --prefix=$(pwd) tagged"
+        putStrLn "start"
+        void $ system "ghc-pkg list --global --user --package-db=package-db-a tagged"
+        putStrLn "stop"
+        res <- m
+        void $ system "ghc-pkg --package-db=package-db-a unregister tagged"
+        -- void $ system "cabal sandbox delete"
+        return res

test/data/custom-cradle/ghc-mod.package-db-stack

@@ -1,5 +1,4 @@
 global
-user
 package-db-a
 package-db-b
 package-db-c

test/data/options-cradle/src/Main.hs

@@ -3,6 +3,8 @@ module Main
   , foo
   ) where
 
+import Data.Tagged
+
 main :: IO ()
 main = return ()