Explicit project (Was: #585)

Language/Haskell/GhcMod/Cradle.hs

@@ -47,6 +47,7 @@ findCradle' Programs { stackProgram, cabalProgram } dir = run $
     msum [ stackCradle stackProgram dir
          , cabalCradle cabalProgram dir
          , sandboxCradle dir
+         , explicitCradle dir
          , plainCradle dir
          ]
  where run a = fillTempDir =<< (fromJustNote "findCradle'" <$> runMaybeT a)
@@ -57,6 +58,7 @@ findSpecCradle Programs { stackProgram, cabalProgram } dir = do
     let cfs = [ stackCradleSpec stackProgram
               , cabalCradle cabalProgram
               , sandboxCradle
+              , explicitCradle
               ]
     cs <- catMaybes <$> mapM (runMaybeT . ($ dir)) cfs
     gcs <- filterM isNotGmCradle cs
@@ -184,3 +186,15 @@ plainCradle wdir = do
       , cradleCabalFile  = Nothing
       , cradleDistDir    = "dist"
       }
+
+explicitCradle :: IOish m => FilePath -> MaybeT m Cradle
+explicitCradle wdir = do
+    optionsFile <- MaybeT $ liftIO $ findExplicitOptionsFile wdir
+    return $ Cradle {
+        cradleProject    = ExplicitProject
+      , cradleCurrentDir = wdir
+      , cradleRootDir    = takeDirectory optionsFile
+      , cradleTempDir    = error "tmpDir"
+      , cradleCabalFile  = Just optionsFile
+      , cradleDistDir    = ""
+      }

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
@@ -120,26 +119,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 getGlobalSymbolTable
+  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 $ getGlobalSymbolTable
-  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.

Language/Haskell/GhcMod/Gap.hs

@@ -73,7 +73,6 @@ import StringBuffer
 import TcType
 import Var (varType)
 import System.Directory
-import SysTools
 #if __GLASGOW_HASKELL__ >= 800
 import GHCi (stopIServ)
 #endif

Language/Haskell/GhcMod/GhcPkg.hs

@@ -87,6 +87,7 @@ getPackageDbStack = do
         getCabalPackageDbStack
     (StackProject StackEnv {..}) ->
         return $ map PackageDb [seSnapshotPkgDb, seLocalPkgDb]
+    ExplicitProject -> return []
   return $ fromMaybe stack mCusPkgStack
 
 getPackageCachePaths :: IOish m => FilePath -> GhcModT m [FilePath]

Language/Haskell/GhcMod/PathsAndFiles.hs

@@ -80,6 +80,15 @@ findStackConfigFile dir = do
       Just (d, Just a)  -> return $ Just $ d </> a
       Just (_, Nothing) -> error "findStackConfigFile"
 
+findExplicitOptionsFile :: FilePath -> IO (Maybe FilePath)
+findExplicitOptionsFile dir = do
+    dss <- findFileInParentsP (==explicitOptionsFile) dir
+    return $ case find (not . null . snd) $ dss of
+               Just (expDir, _:_) -> Just (expDir </> explicitOptionsFile)
+               _ -> Nothing
+  where
+    explicitOptionsFile = "ghc-mod.options"
+
 -- | Get path to sandbox config file
 getSandboxDb :: Cradle -> IO (Maybe GhcPkgDb)
 getSandboxDb crdl = do

Language/Haskell/GhcMod/Target.hs

@@ -24,7 +24,6 @@ import GHC
 #if __GLASGOW_HASKELL__ >= 800
 import GHC.LanguageExtensions
 #endif
-import GHC.Paths (libdir)
 import SysTools
 import DynFlags
 import HscTypes
@@ -106,7 +105,7 @@ initSession opts mdf = do
    putNewSession s = do
      crdl <- cradle
      nhsc_env_ref <- liftIO . newIORef =<< newLightEnv (initDF crdl)
-     runLightGhc' nhsc_env_ref $ setSessionDynFlags =<< getSessionDynFlags
+     void $ runLightGhc' nhsc_env_ref $ setSessionDynFlags =<< getSessionDynFlags
      gmsPut s { gmGhcSession = Just $ GmGhcSession nhsc_env_ref }
 
 
@@ -188,12 +187,22 @@ targetGhcOptions crdl sefnmn = do
     when (Set.null sefnmn) $ error "targetGhcOptions: no targets given"
 
     case cradleProject crdl of
-      proj
-          | isCabalHelperProject proj -> cabalOpts crdl
-          | otherwise -> sandboxOpts crdl
+      proj | isCabalHelperProject proj -> cabalOpts crdl
+      ExplicitProject -> do
+        opts <- explicitOpts crdl
+        dbStack <- maybe [] id <$> getCustomPkgDbStack
+        return $ opts ++ ghcDbStackOpts dbStack
+      _  -> sandboxOpts crdl
  where
    zipMap f l = l `zip` (f `map` l)
 
+   explicitOpts :: Cradle -> GhcModT m [String]
+   explicitOpts Cradle {..} = case cradleCabalFile of
+       Nothing -> return []
+       Just optionsFile -> do
+           contents <- liftIO $ readFile optionsFile
+           return $ lines contents
+
    cabalOpts :: Cradle -> GhcModT m [String]
    cabalOpts Cradle{..} = do
        mcs <- cabalResolvedComponents

Language/Haskell/GhcMod/Types.hs

@@ -134,6 +134,7 @@ data Project = CabalProject
              | SandboxProject
              | PlainProject
              | StackProject StackEnv
+             | ExplicitProject
                deriving (Eq, Show, Ord)
 
 isCabalHelperProject :: Project -> Bool

Language/Haskell/GhcMod/Utils.hs

@@ -38,9 +38,7 @@ import System.Environment
 import System.FilePath
 import System.IO.Temp (createTempDirectory)
 import System.Process (readProcess)
-import Text.Printf
 
-import Paths_ghc_mod (getLibexecDir)
 import Utils
 import Prelude
 

ghc-mod.cabal

@@ -94,8 +94,12 @@ Extra-Source-Files:     ChangeLog
                         test/data/stack-project/app/*.hs
                         test/data/stack-project/src/*.hs
                         test/data/stack-project/test/*.hs
-                        bench/data/simple-cabal/simple-cabal.cabal
-                        bench/data/simple-cabal/*.hs
+                        test/data/options-cradle/ghc-mod.options
+                        test/data/options-cradle/ghc-mod.package-db-stack
+                        test/data/options-cradle/package-db-a/package.cache
+                        test/data/options-cradle/package-db-b/package.cache
+                        test/data/options-cradle/package-db-c/package.cache
+                        test/data/options-cradle/src/*.hs
 
 Custom-Setup
   Setup-Depends:         base

test/CheckSpec.hs

@@ -78,3 +78,15 @@ spec = do
 #else
                 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" $ bracketTagged $ do
+            res <- runD $ checkSyntax ["src/Main.hs"]
+            res `shouldBe` ""
+
+        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"
+#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"
+#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

@@ -1,15 +1,8 @@
 {-# LANGUAGE CPP #-}
 module InfoSpec where
 
-import Control.Applicative
 import Data.List (isPrefixOf)
 import Language.Haskell.GhcMod
-#if __GLASGOW_HASKELL__ < 706
-import System.Environment.Executable (getExecutablePath)
-#else
-import System.Environment (getExecutablePath)
-#endif
-import System.FilePath
 import Test.Hspec
 import TestUtils
 import Prelude
@@ -46,6 +39,10 @@ spec = do
             res <- runD' tdir $ types False "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" $ bracketTagged $ do
+            res <- runD $ types True "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
             let tdir = "test/data/non-exported"
@@ -62,5 +59,6 @@ spec = do
             res <- runD' tdir $ info "ImportsTH.hs" $ Expression "bar"
             res `shouldSatisfy` ("bar :: [Char]" `isPrefixOf`)
 
-getDistDir :: IO FilePath
-getDistDir = takeDirectory . takeDirectory . takeDirectory <$> getExecutablePath
+        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

@@ -1,6 +1,7 @@
 module ListSpec where
 
 import Control.Applicative
+import Dir
 import Language.Haskell.GhcMod
 import Test.Hspec
 import TestUtils
@@ -12,3 +13,12 @@ spec = do
         it "contains at least `Data.Map'" $ do
             mdls <- runD $ lines <$> modules False
             mdls `shouldContain` ["Data.Map"]
+
+        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 `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/ghc-mod.options

@@ -0,0 +1,2 @@
+-isrc
+-DINTERPRETED

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

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

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

@@ -0,0 +1,12 @@
+module Main
+  ( main
+  , foo
+  ) where
+
+import Data.Tagged
+
+main :: IO ()
+main = return ()
+
+foo :: Int
+foo = 0

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

@@ -0,0 +1,10 @@
+module Main2
+  ( main
+  , foo
+  ) where
+
+main :: IO ()
+main = return ()
+
+foo :: Int
+foo = 0 + id