Using Cradle.

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]
+fromCabal :: [GHCOption]
-                               ,[IncludeDir]
+           -> Cradle
-                               ,[Package]
+           -> IO ([GHCOption]
-                               ,[LangExt])
+                 ,[IncludeDir]
-fromCabal ghcOptions = do
+                 ,[Package]
-    (owdir,cdir,cfile) <- getDirs
+                 ,[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

Check.hs

@@ -11,16 +11,16 @@ import Types
 
 ----------------------------------------------------------------
 
-checkSyntax :: Options -> String -> IO String
+checkSyntax :: Options -> Cradle -> String -> IO String
-checkSyntax opt file = unlines <$> check opt file
+checkSyntax opt cradle file = unlines <$> check opt cradle file
 
 ----------------------------------------------------------------
 
-check :: Options -> String -> IO [String]
+check :: Options -> Cradle -> String -> IO [String]
-check opt fileName = withGHC' fileName $ checkIt `gcatch` handleErrMsg
+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

Cradle.hs

@@ -13,8 +13,8 @@ import System.FilePath ((</>),takeDirectory)
 import Types
 
 -- An error would be thrown
-checkEnv :: Maybe FilePath -> IO Cradle
+findCradle :: Maybe FilePath -> IO Cradle
-checkEnv (Just sbox) = do
+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

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 :: Options -> Cradle -> FilePath -> [GHCOption] -> Bool -> Ghc LogReader
-initializeGHC opt fileName ghcOptions logging = withCabal ||> withoutCabal
+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
+    cabal = isJust $ cradleCabalFile cradle
-    withCabal = do
-        (gopts,idirs,depPkgs,hdrExts) <- liftIO $ fromCabal ghcOptions
-        initSession opt gopts idirs (Just depPkgs) (Just hdrExts) logging fileName
 
 initSession :: Options
             -> [GHCOption]

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'
+    cradle <- findCradle $ sandbox opt'
-    let mpkgopts = cradlePackageConfOpts cradle
+    let opt = ajustOpts opt' cradle
-        opt = case mpkgopts of
-            Nothing      -> opt'
-            Just pkgopts -> opt' { ghcOpts = pkgopts ++ ghcOpts opt' }
     res <- case safelist cmdArg 0 of
       "browse" -> concat <$> mapM (browseModule opt) (tail cmdArg)
       "list"   -> listModules opt
-      "check"  -> withFile (checkSyntax opt) (safelist cmdArg 1)
+      "check"  -> withFile (checkSyntax opt cradle) (safelist cmdArg 1)
-      "expand" -> withFile (checkSyntax opt { expandSplice = True })
+      "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)
+      "type"  -> withFile (typeExpr opt cradle (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)
+      "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
 
 ----------------------------------------------------------------
 

Info.hs

@@ -33,12 +33,12 @@ type ModuleString = String
 
 ----------------------------------------------------------------
 
-infoExpr :: Options -> ModuleString -> Expression -> FilePath -> IO String
+infoExpr :: Options -> Cradle -> ModuleString -> Expression -> FilePath -> IO String
-infoExpr opt modstr expr file = (++ "\n") <$> info opt file modstr expr
+infoExpr opt cradle modstr expr file = (++ "\n") <$> info opt cradle file modstr expr
 
-info :: Options -> FilePath -> ModuleString -> FilePath -> IO String
+info :: Options -> Cradle -> FilePath -> ModuleString -> FilePath -> IO String
-info opt fileName modstr expr =
+info opt cradle fileName modstr expr =
-    inModuleContext opt fileName modstr exprToInfo "Cannot show info"
+    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 :: Options -> Cradle -> ModuleString -> Int -> Int -> FilePath -> IO String
-typeExpr opt modstr lineNo colNo file = Info.typeOf opt file modstr lineNo colNo
+typeExpr opt cradle modstr lineNo colNo file = Info.typeOf opt cradle file modstr lineNo colNo
 
-typeOf :: Options -> FilePath -> ModuleString -> Int -> Int -> IO String
+typeOf :: Options -> Cradle -> FilePath -> ModuleString -> Int -> Int -> IO String
-typeOf opt fileName modstr lineNo colNo =
+typeOf opt cradle fileName modstr lineNo colNo =
-    inModuleContext opt fileName modstr exprToType errmsg
+    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 :: Options -> Cradle -> FilePath -> ModuleString -> Ghc String -> String -> IO String
-inModuleContext opt fileName modstr action errmsg =
+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

ghc-mod.cabal

@@ -76,7 +76,6 @@ Test-Suite spec
   Type:                 exitcode-stdio-1.0
   Other-Modules:        Expectation
                         BrowseSpec
-                        CabalSpec
                         CabalApiSpec
                         CheckSpec
                         FlagSpec

test/CabalSpec.hs

@@ -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"], [])

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"

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"