diff --git a/Language/Haskell/GhcMod/Cradle.hs b/Language/Haskell/GhcMod/Cradle.hs index e7db5a689..12f05e03c 100644 --- a/Language/Haskell/GhcMod/Cradle.hs +++ b/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 = "" + } diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index 35ec1c0bf..f920c0843 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/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,13 +119,14 @@ 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' @@ -134,12 +134,8 @@ loadSymbolDb = do -- | 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. diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs index b8f9c658b..955fa6a62 100644 --- a/Language/Haskell/GhcMod/Gap.hs +++ b/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 diff --git a/Language/Haskell/GhcMod/GhcPkg.hs b/Language/Haskell/GhcMod/GhcPkg.hs index db2581d2e..0bd62af24 100644 --- a/Language/Haskell/GhcMod/GhcPkg.hs +++ b/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] diff --git a/Language/Haskell/GhcMod/PathsAndFiles.hs b/Language/Haskell/GhcMod/PathsAndFiles.hs index 6c0a68e96..db7671294 100644 --- a/Language/Haskell/GhcMod/PathsAndFiles.hs +++ b/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 diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index bd41fd4d5..a3f9ea297 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/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 diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index f73e01f21..4c6d697c9 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -134,6 +134,7 @@ data Project = CabalProject | SandboxProject | PlainProject | StackProject StackEnv + | ExplicitProject deriving (Eq, Show, Ord) isCabalHelperProject :: Project -> Bool diff --git a/Language/Haskell/GhcMod/Utils.hs b/Language/Haskell/GhcMod/Utils.hs index 15782b016..c6005fbac 100644 --- a/Language/Haskell/GhcMod/Utils.hs +++ b/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 diff --git a/ghc-mod.cabal b/ghc-mod.cabal index d882262ae..4ff3c8475 100644 --- a/ghc-mod.cabal +++ b/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 diff --git a/test/CheckSpec.hs b/test/CheckSpec.hs index 9b1ea38b9..636bbcb5d 100644 --- a/test/CheckSpec.hs +++ b/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 diff --git a/test/CustomPackageDbSpec.hs b/test/CustomPackageDbSpec.hs index c19c193ec..e15669b59 100644 --- a/test/CustomPackageDbSpec.hs +++ b/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" diff --git a/test/FindSpec.hs b/test/FindSpec.hs index 6f693aab9..1cc5ebc06 100644 --- a/test/FindSpec.hs +++ b/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"] diff --git a/test/InfoSpec.hs b/test/InfoSpec.hs index de9f3e418..558143ed9 100644 --- a/test/InfoSpec.hs +++ b/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`) diff --git a/test/ListSpec.hs b/test/ListSpec.hs index 166d3c248..b5d10b912 100644 --- a/test/ListSpec.hs +++ b/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"] diff --git a/test/TestUtils.hs b/test/TestUtils.hs index af5367ba2..896cd4054 100644 --- a/test/TestUtils.hs +++ b/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 diff --git a/test/data/custom-cradle/ghc-mod.package-db-stack b/test/data/custom-cradle/ghc-mod.package-db-stack index ce2d74166..81ba0a9d1 100644 --- a/test/data/custom-cradle/ghc-mod.package-db-stack +++ b/test/data/custom-cradle/ghc-mod.package-db-stack @@ -1,5 +1,4 @@ global -user package-db-a package-db-b package-db-c diff --git a/test/data/options-cradle/ghc-mod.options b/test/data/options-cradle/ghc-mod.options new file mode 100644 index 000000000..bf11cfa3b --- /dev/null +++ b/test/data/options-cradle/ghc-mod.options @@ -0,0 +1,2 @@ +-isrc +-DINTERPRETED diff --git a/test/data/options-cradle/ghc-mod.package-db-stack b/test/data/options-cradle/ghc-mod.package-db-stack new file mode 100644 index 000000000..ce2d74166 --- /dev/null +++ b/test/data/options-cradle/ghc-mod.package-db-stack @@ -0,0 +1,5 @@ +global +user +package-db-a +package-db-b +package-db-c diff --git a/test/data/options-cradle/package-db-a/package.cache b/test/data/options-cradle/package-db-a/package.cache new file mode 100644 index 000000000..1b1cb4d44 Binary files /dev/null and b/test/data/options-cradle/package-db-a/package.cache differ diff --git a/test/data/options-cradle/package-db-b/package.cache b/test/data/options-cradle/package-db-b/package.cache new file mode 100644 index 000000000..1b1cb4d44 Binary files /dev/null and b/test/data/options-cradle/package-db-b/package.cache differ diff --git a/test/data/options-cradle/package-db-c/package.cache b/test/data/options-cradle/package-db-c/package.cache new file mode 100644 index 000000000..1b1cb4d44 Binary files /dev/null and b/test/data/options-cradle/package-db-c/package.cache differ diff --git a/test/data/options-cradle/src/Main.hs b/test/data/options-cradle/src/Main.hs new file mode 100644 index 000000000..1ce1b436a --- /dev/null +++ b/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 diff --git a/test/data/options-cradle/src/Main2.hs b/test/data/options-cradle/src/Main2.hs new file mode 100644 index 000000000..ce7c2ddcf --- /dev/null +++ b/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