diff --git a/Cabal.hs b/Cabal.hs index a7b72e8..f373200 100644 --- a/Cabal.hs +++ b/Cabal.hs @@ -1,26 +1,22 @@ {-# LANGUAGE OverloadedStrings, RecordWildCards #-} -module Cabal (getDirs, fromCabal) where +module Cabal (fromCabal) where import CabalApi -import Control.Applicative -import Control.Exception -import Control.Monad -import Data.List import Distribution.PackageDescription (BuildInfo(..), usedExtensions) import Distribution.Text (display) -import System.Directory import System.FilePath import Types ---------------------------------------------------------------- -fromCabal :: [GHCOption] -> IO ([GHCOption] - ,[IncludeDir] - ,[Package] - ,[LangExt]) -fromCabal ghcOptions = do - (owdir,cdir,cfile) <- getDirs +fromCabal :: [GHCOption] + -> Cradle + -> IO ([GHCOption] + ,[IncludeDir] + ,[Package] + ,[LangExt]) +fromCabal ghcOptions cradle = do cabal <- cabalParseFile cfile let binfo@BuildInfo{..} = cabalBuildInfo cabal let exts = map (("-X" ++) . display) $ usedExtensions binfo @@ -34,31 +30,12 @@ fromCabal ghcOptions = do let depPkgs = removeMe cfile $ cabalAllDependPackages cabal hdrExts = cabalAllExtentions cabal return (gopts,idirs,depPkgs,hdrExts) + where + owdir = cradleCurrentDir cradle + Just cdir = cradleCabalDir cradle + Just cfile = cradleCabalDir cradle removeMe :: FilePath -> [String] -> [String] removeMe cabalfile = filter (/= me) where me = dropExtension $ takeFileName cabalfile - ----------------------------------------------------------------- - --- CurrentWorkingDir, CabalDir, CabalFile -getDirs :: IO (FilePath,FilePath,FilePath) -getDirs = do - wdir <- getCurrentDirectory - (cdir,cfile) <- cabalDir wdir - return (wdir,cdir,cfile) - --- Causes error, catched in the upper function. --- CabalDir, CabalFile -cabalDir :: FilePath -> IO (FilePath,FilePath) -cabalDir dir = do - cnts <- (filter isCabal <$> getDirectoryContents dir) - >>= filterM (\file -> doesFileExist (dir file)) - let dir' = takeDirectory dir - case cnts of - [] | dir' == dir -> throwIO $ userError "No cabal file" - | otherwise -> cabalDir dir' - cfile:_ -> return (dir,dir cfile) - where - isCabal name = ".cabal" `isSuffixOf` name && length name > 6 diff --git a/Check.hs b/Check.hs index e8428ec..909fed7 100644 --- a/Check.hs +++ b/Check.hs @@ -11,16 +11,16 @@ import Types ---------------------------------------------------------------- -checkSyntax :: Options -> String -> IO String -checkSyntax opt file = unlines <$> check opt file +checkSyntax :: Options -> Cradle -> String -> IO String +checkSyntax opt cradle file = unlines <$> check opt cradle file ---------------------------------------------------------------- -check :: Options -> String -> IO [String] -check opt fileName = withGHC' fileName $ checkIt `gcatch` handleErrMsg +check :: Options -> Cradle -> String -> IO [String] +check opt cradle fileName = withGHC' fileName $ checkIt `gcatch` handleErrMsg where checkIt = do - readLog <- initializeGHC opt fileName options True + readLog <- initializeGHC opt cradle fileName options True setTargetFile fileName _ <- load LoadAllTargets liftIO readLog diff --git a/Cradle.hs b/Cradle.hs index 97dc6ff..2f8c761 100644 --- a/Cradle.hs +++ b/Cradle.hs @@ -13,8 +13,8 @@ import System.FilePath ((),takeDirectory) import Types -- An error would be thrown -checkEnv :: Maybe FilePath -> IO Cradle -checkEnv (Just sbox) = do +findCradle :: Maybe FilePath -> IO Cradle +findCradle (Just sbox) = do (strver, ver) <- ghcVersion conf <- checkPackageConf sbox strver let confOpts = ghcPackageConfOptions ver conf @@ -33,7 +33,7 @@ checkEnv (Just sbox) = do , cradleCabalFile = Just cfile , cradlePackageConfOpts = Just confOpts } -checkEnv Nothing = do +findCradle Nothing = do (strver, ver) <- ghcVersion wdir <- getCurrentDirectory cfiles <- cabalDir wdir diff --git a/GHCApi.hs b/GHCApi.hs index 3397508..972e764 100644 --- a/GHCApi.hs +++ b/GHCApi.hs @@ -4,12 +4,12 @@ import Cabal import Control.Applicative import Control.Exception import CoreMonad +import Data.Maybe (isJust) import DynFlags import ErrMsg import Exception import GHC import GHC.Paths (libdir) -import GHCChoice import HeaderInfo import System.Exit import System.IO @@ -42,13 +42,15 @@ initSession0 opt = getSessionDynFlags >>= importDirs :: [IncludeDir] importDirs = [".","..","../..","../../..","../../../..","../../../../.."] -initializeGHC :: Options -> FilePath -> [GHCOption] -> Bool -> Ghc LogReader -initializeGHC opt fileName ghcOptions logging = withCabal ||> withoutCabal +initializeGHC :: Options -> Cradle -> FilePath -> [GHCOption] -> Bool -> Ghc LogReader +initializeGHC opt cradle fileName ghcOptions logging + | cabal = + initSession opt ghcOptions importDirs Nothing Nothing logging fileName + | otherwise = do + (gopts,idirs,depPkgs,hdrExts) <- liftIO $ fromCabal ghcOptions cradle + initSession opt gopts idirs (Just depPkgs) (Just hdrExts) logging fileName where - withoutCabal = initSession opt ghcOptions importDirs Nothing Nothing logging fileName - withCabal = do - (gopts,idirs,depPkgs,hdrExts) <- liftIO $ fromCabal ghcOptions - initSession opt gopts idirs (Just depPkgs) (Just hdrExts) logging fileName + cabal = isJust $ cradleCabalFile cradle initSession :: Options -> [GHCOption] diff --git a/GHCMod.hs b/GHCMod.hs index ebe5a36..028066b 100644 --- a/GHCMod.hs +++ b/GHCMod.hs @@ -86,19 +86,16 @@ main :: IO () main = flip catches handlers $ do args <- getArgs let (opt',cmdArg) = parseArgs argspec args - cradle <- checkEnv $ sandbox opt' - let mpkgopts = cradlePackageConfOpts cradle - opt = case mpkgopts of - Nothing -> opt' - Just pkgopts -> opt' { ghcOpts = pkgopts ++ ghcOpts opt' } + cradle <- findCradle $ sandbox opt' + let opt = ajustOpts opt' cradle res <- case safelist cmdArg 0 of "browse" -> concat <$> mapM (browseModule opt) (tail cmdArg) "list" -> listModules opt - "check" -> withFile (checkSyntax opt) (safelist cmdArg 1) - "expand" -> withFile (checkSyntax opt { expandSplice = True }) + "check" -> withFile (checkSyntax opt cradle) (safelist cmdArg 1) + "expand" -> withFile (checkSyntax opt { expandSplice = True } cradle) (safelist cmdArg 1) - "type" -> withFile (typeExpr opt (safelist cmdArg 2) (read $ safelist cmdArg 3) (read $ safelist cmdArg 4)) (safelist cmdArg 1) - "info" -> withFile (infoExpr opt (safelist cmdArg 2) (safelist cmdArg 3)) (safelist cmdArg 1) + "type" -> withFile (typeExpr opt cradle (safelist cmdArg 2) (read $ safelist cmdArg 3) (read $ safelist cmdArg 4)) (safelist cmdArg 1) + "info" -> withFile (infoExpr opt cradle (safelist cmdArg 2) (safelist cmdArg 3)) (safelist cmdArg 1) "lint" -> withFile (lintSyntax opt) (safelist cmdArg 1) "lang" -> listLanguages opt "flag" -> listFlags opt @@ -134,6 +131,11 @@ main = flip catches handlers $ do safelist xs idx | length xs <= idx = throw SafeList | otherwise = xs !! idx + ajustOpts opt cradle = case mpkgopts of + Nothing -> opt + Just pkgopts -> opt { ghcOpts = pkgopts ++ ghcOpts opt } + where + mpkgopts = cradlePackageConfOpts cradle ---------------------------------------------------------------- diff --git a/Info.hs b/Info.hs index d657a23..5e651f9 100644 --- a/Info.hs +++ b/Info.hs @@ -33,12 +33,12 @@ type ModuleString = String ---------------------------------------------------------------- -infoExpr :: Options -> ModuleString -> Expression -> FilePath -> IO String -infoExpr opt modstr expr file = (++ "\n") <$> info opt file modstr expr +infoExpr :: Options -> Cradle -> ModuleString -> Expression -> FilePath -> IO String +infoExpr opt cradle modstr expr file = (++ "\n") <$> info opt cradle file modstr expr -info :: Options -> FilePath -> ModuleString -> FilePath -> IO String -info opt fileName modstr expr = - inModuleContext opt fileName modstr exprToInfo "Cannot show info" +info :: Options -> Cradle -> FilePath -> ModuleString -> FilePath -> IO String +info opt cradle fileName modstr expr = + inModuleContext opt cradle fileName modstr exprToInfo "Cannot show info" where exprToInfo = infoThing expr @@ -64,12 +64,12 @@ instance HasType (LHsBind Id) where instance HasType (LPat Id) where getType _ (L spn pat) = return $ Just (spn, hsPatType pat) -typeExpr :: Options -> ModuleString -> Int -> Int -> FilePath -> IO String -typeExpr opt modstr lineNo colNo file = Info.typeOf opt file modstr lineNo colNo +typeExpr :: Options -> Cradle -> ModuleString -> Int -> Int -> FilePath -> IO String +typeExpr opt cradle modstr lineNo colNo file = Info.typeOf opt cradle file modstr lineNo colNo -typeOf :: Options -> FilePath -> ModuleString -> Int -> Int -> IO String -typeOf opt fileName modstr lineNo colNo = - inModuleContext opt fileName modstr exprToType errmsg +typeOf :: Options -> Cradle -> FilePath -> ModuleString -> Int -> Int -> IO String +typeOf opt cradle fileName modstr lineNo colNo = + inModuleContext opt cradle fileName modstr exprToType errmsg where exprToType = do modSum <- getModSummary $ mkModuleName modstr @@ -137,17 +137,17 @@ pprInfo pefas (thing, fixity, insts) ---------------------------------------------------------------- -inModuleContext :: Options -> FilePath -> ModuleString -> Ghc String -> String -> IO String -inModuleContext opt fileName modstr action errmsg = +inModuleContext :: Options -> Cradle -> FilePath -> ModuleString -> Ghc String -> String -> IO String +inModuleContext opt cradle fileName modstr action errmsg = withGHC (valid ||> invalid ||> return errmsg) where valid = do - _ <- initializeGHC opt fileName ["-w"] False + _ <- initializeGHC opt cradle fileName ["-w"] False setTargetFile fileName _ <- load LoadAllTargets doif setContextFromTarget action invalid = do - _ <- initializeGHC opt fileName ["-w"] False + _ <- initializeGHC opt cradle fileName ["-w"] False setTargetBuffer _ <- load LoadAllTargets doif setContextFromTarget action diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 45283d1..59c11c3 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -76,7 +76,6 @@ Test-Suite spec Type: exitcode-stdio-1.0 Other-Modules: Expectation BrowseSpec - CabalSpec CabalApiSpec CheckSpec FlagSpec diff --git a/test/CabalSpec.hs b/test/CabalSpec.hs deleted file mode 100644 index d9f1291..0000000 --- a/test/CabalSpec.hs +++ /dev/null @@ -1,23 +0,0 @@ -module CabalSpec where - -import Control.Applicative -import System.Directory -import Test.Hspec -import Cabal -import Expectation - -spec :: Spec -spec = do - describe "getDirs" $ do - it "obtains two directories and a cabal file" $ do - len <- length <$> getCurrentDirectory - withDirectory "test/data/subdir1/subdir2" $ do - (x,y,z) <- getDirs - (drop len x, drop len y, drop len z) `shouldBe` ("/test/data/subdir1/subdir2","/test/data","/test/data/cabalapi.cabal") - - describe "getDirs" $ do - it "obtains two directories and a cabal file" $ do - len <- length <$> getCurrentDirectory - withDirectory "test/data/subdir1/subdir2" $ do - (x,y,z,w) <- fromCabal [] - (x, map (drop len) y, z, w) `shouldBe` (["-XHaskell98"],["/test/data","/test/data/subdir1/subdir2"],["Cabal","base","containers","convertible","directory","filepath","ghc","ghc-paths","ghc-syb-utils","hlint","hspec","io-choice","old-time","process","regex-posix","syb","time","transformers"], []) diff --git a/test/CheckSpec.hs b/test/CheckSpec.hs index fb5843d..7c43379 100644 --- a/test/CheckSpec.hs +++ b/test/CheckSpec.hs @@ -1,8 +1,9 @@ module CheckSpec where -import Test.Hspec import Check +import Cradle import Expectation +import Test.Hspec import Types spec :: Spec @@ -10,5 +11,6 @@ spec = do describe "checkSyntax" $ do it "can check even if an executable depends on its library" $ do withDirectory "test/data/ghc-mod-check" $ do - res <- checkSyntax defaultOptions "main.hs" + cradle <- findCradle Nothing + res <- checkSyntax defaultOptions cradle "main.hs" res `shouldBe` "main.hs:5:1:Warning: Top-level binding with no type signature: main :: IO ()\NUL\n" diff --git a/test/InfoSpec.hs b/test/InfoSpec.hs index 1926938..b61b524 100644 --- a/test/InfoSpec.hs +++ b/test/InfoSpec.hs @@ -1,8 +1,9 @@ module InfoSpec where -import Test.Hspec +import Cradle import Expectation import Info +import Test.Hspec import Types spec :: Spec @@ -10,5 +11,6 @@ spec = do describe "typeExpr" $ do it "shows types of the expression and its outers" $ do withDirectory "test/data/ghc-mod-check" $ do - res <- typeExpr defaultOptions "Data.Foo" 9 5 "Data/Foo.hs" + cradle <- findCradle Nothing + res <- typeExpr defaultOptions cradle "Data.Foo" 9 5 "Data/Foo.hs" res `shouldBe` "9 5 11 40 \"Int -> a -> a -> a\"\n7 1 11 40 \"Int -> Integer\"\n"