hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

refactoring for testing.

Browse Source
This commit is contained in:
Kazu Yamamoto 2013-03-04 18:11:09 +09:00
parent 69cc0f8ce4
commit 1047c76906
6 changed files with 47 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

46
Cradle.hs
View File

@ -1,6 +1,5 @@
module Cradle where module Cradle where
import CabalApi (getGHCVersion)
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Control.Exception (throwIO) import Control.Exception (throwIO)
import Control.Monad import Control.Monad
@ -10,11 +9,9 @@ import System.FilePath ((</>),takeDirectory)
import Types import Types
-- An error would be thrown -- An error would be thrown
findCradle :: Maybe FilePath -> IO Cradle findCradle :: Maybe FilePath -> String -> IO Cradle
findCradle (Just sbox) = do findCradle (Just sbox) strver = do
(strver, ver) <- getGHCVersion pkgConf <- checkPackageConf sbox strver
conf <- checkPackageConf sbox strver
let confOpts = ghcPackageConfOptions ver conf
wdir <- getCurrentDirectory wdir <- getCurrentDirectory
cfiles <- cabalDir wdir cfiles <- cabalDir wdir
return $ case cfiles of return $ case cfiles of
@ -22,39 +19,33 @@ findCradle (Just sbox) = do
cradleCurrentDir = wdir cradleCurrentDir = wdir
, cradleCabalDir = Nothing , cradleCabalDir = Nothing
, cradleCabalFile = Nothing , cradleCabalFile = Nothing
, cradlePackageConfOpts = Just confOpts , cradlePackageConf = Just pkgConf
, cradleGHCVersion = strver
} }
Just (cdir,cfile) -> Cradle { Just (cdir,cfile) -> Cradle {
cradleCurrentDir = wdir cradleCurrentDir = wdir
, cradleCabalDir = Just cdir , cradleCabalDir = Just cdir
, cradleCabalFile = Just cfile , cradleCabalFile = Just cfile
, cradlePackageConfOpts = Just confOpts , cradlePackageConf = Just pkgConf
, cradleGHCVersion = strver
} }
findCradle Nothing = do findCradle Nothing strver = do
(strver, ver) <- getGHCVersion
wdir <- getCurrentDirectory wdir <- getCurrentDirectory
cfiles <- cabalDir wdir cfiles <- cabalDir wdir
case cfiles of case cfiles of
Nothing -> return Cradle { Nothing -> return Cradle {
cradleCurrentDir = wdir cradleCurrentDir = wdir
, cradleCabalDir = Nothing , cradleCabalDir = Nothing
, cradleCabalFile = Nothing , cradleCabalFile = Nothing
, cradlePackageConfOpts = Nothing , cradlePackageConf = Nothing
, cradleGHCVersion = strver
} }
Just (cdir,cfile) -> do Just (cdir,cfile) -> do
let sbox = cdir </> "cabal-dev/" let sbox = cdir </> "cabal-dev/"
conf = packageConfName sbox strver pkgConf = packageConfName sbox strver
confOpts = ghcPackageConfOptions ver conf exist <- doesFileExist pkgConf
exist <- doesFileExist conf
return Cradle { return Cradle {
cradleCurrentDir = wdir cradleCurrentDir = wdir
, cradleCabalDir = Just cdir , cradleCabalDir = Just cdir
, cradleCabalFile = Just cfile , cradleCabalFile = Just cfile
, cradlePackageConfOpts = if exist then Just confOpts else Nothing , cradlePackageConf = if exist then Just pkgConf else Nothing
, cradleGHCVersion = strver
} }
cabalDir :: FilePath -> IO (Maybe (FilePath,FilePath)) cabalDir :: FilePath -> IO (Maybe (FilePath,FilePath))
@ -80,8 +71,3 @@ checkPackageConf path ver = do
return conf return conf
else else
throwIO $ userError $ conf ++ " not found" throwIO $ userError $ conf ++ " not found"
ghcPackageConfOptions :: Int -> String -> [String]
ghcPackageConfOptions ver file
| ver >= 706 = ["-package-db", file, "-no-user-package-conf"]
| otherwise = ["-package-conf", file, "-no-user-package-conf"]

11
Debug.hs
View File

@ -10,11 +10,11 @@ import Types
---------------------------------------------------------------- ----------------------------------------------------------------
debugInfo :: Options -> Cradle -> String -> IO String debugInfo :: Options -> Cradle -> String -> String -> IO String
debugInfo opt cradle fileName = unlines <$> debug opt cradle fileName debugInfo opt cradle ver fileName = unlines <$> debug opt cradle ver fileName
debug :: Options -> Cradle -> String -> IO [String] debug :: Options -> Cradle -> String -> String -> IO [String]
debug opt cradle fileName = do debug opt cradle ver fileName = do
(gopts, incDir, pkgs, langext) <- (gopts, incDir, pkgs, langext) <-
if cabal then if cabal then
fromCabalFile (ghcOpts opt) cradle fromCabalFile (ghcOpts opt) cradle
@ -23,7 +23,7 @@ debug opt cradle fileName = do
dflags <- getDynamicFlags dflags <- getDynamicFlags
fast <- getFastCheck dflags fileName (Just langext) fast <- getFastCheck dflags fileName (Just langext)
return [ return [
"GHC version: " ++ ghcVer "GHC version: " ++ ver
, "Current directory: " ++ currentDir , "Current directory: " ++ currentDir
, "Cabal file: " ++ cabalFile , "Cabal file: " ++ cabalFile
, "GHC options: " ++ intercalate " " gopts , "GHC options: " ++ intercalate " " gopts
@ -32,7 +32,6 @@ debug opt cradle fileName = do
, "Fast check: " ++ if fast then "Yes" else "No" , "Fast check: " ++ if fast then "Yes" else "No"
] ]
where where
ghcVer = cradleGHCVersion cradle
currentDir = cradleCurrentDir cradle currentDir = cradleCurrentDir cradle
cabal = isJust $ cradleCabalFile cradle cabal = isJust $ cradleCabalFile cradle
cabalFile = fromMaybe "" $ cradleCabalFile cradle cabalFile = fromMaybe "" $ cradleCabalFile cradle

22
GHCMod.hs
View File

@ -3,6 +3,7 @@
module Main where module Main where
import Browse import Browse
import CabalApi
import Check import Check
import Control.Applicative import Control.Applicative
import Control.Exception import Control.Exception
@ -87,8 +88,9 @@ main :: IO ()
main = flip catches handlers $ do main = flip catches handlers $ do
args <- getArgs args <- getArgs
let (opt',cmdArg) = parseArgs argspec args let (opt',cmdArg) = parseArgs argspec args
cradle <- findCradle $ sandbox opt' (strVer,ver) <- getGHCVersion
let opt = ajustOpts opt' cradle cradle <- findCradle (sandbox opt') strVer
let opt = adjustOpts opt' cradle ver
cmdArg0 = cmdArg !. 0 cmdArg0 = cmdArg !. 0
cmdArg1 = cmdArg !. 1 cmdArg1 = cmdArg !. 1
cmdArg2 = cmdArg !. 2 cmdArg2 = cmdArg !. 2
@ -99,7 +101,7 @@ main = flip catches handlers $ do
"list" -> listModules opt "list" -> listModules opt
"check" -> withFile (checkSyntax opt cradle) cmdArg1 "check" -> withFile (checkSyntax opt cradle) cmdArg1
"expand" -> withFile (checkSyntax opt { expandSplice = True } cradle) cmdArg1 "expand" -> withFile (checkSyntax opt { expandSplice = True } cradle) cmdArg1
"debug" -> withFile (debugInfo opt cradle) cmdArg1 "debug" -> withFile (debugInfo opt cradle strVer) cmdArg1
"type" -> withFile (typeExpr opt cradle cmdArg2 (read cmdArg3) (read cmdArg4)) cmdArg1 "type" -> withFile (typeExpr opt cradle cmdArg2 (read cmdArg3) (read cmdArg4)) cmdArg1
"info" -> withFile (infoExpr opt cradle cmdArg2 cmdArg3) cmdArg1 "info" -> withFile (infoExpr opt cradle cmdArg2 cmdArg3) cmdArg1
"lint" -> withFile (lintSyntax opt) cmdArg1 "lint" -> withFile (lintSyntax opt) cmdArg1
@ -137,11 +139,13 @@ main = flip catches handlers $ do
xs !. idx xs !. idx
| length xs <= idx = throw SafeList | length xs <= idx = throw SafeList
| otherwise = xs !! idx | otherwise = xs !! idx
ajustOpts opt cradle = case mpkgopts of adjustOpts opt cradle ver = case mPkgConf of
Nothing -> opt Nothing -> opt
Just pkgopts -> opt { ghcOpts = pkgopts ++ ghcOpts opt } Just pkgConf -> opt {
ghcOpts = ghcPackageConfOptions ver pkgConf ++ ghcOpts opt
}
where where
mpkgopts = cradlePackageConfOpts cradle mPkgConf = cradlePackageConf cradle
---------------------------------------------------------------- ----------------------------------------------------------------
@ -156,3 +160,9 @@ preBrowsedModules = [
, "Data.Maybe" , "Data.Maybe"
, "System.IO" , "System.IO"
] ]
ghcPackageConfOptions :: Int -> String -> [String]
ghcPackageConfOptions ver file
| ver >= 706 = ["-package-db", file, "-no-user-package-conf"]
| otherwise = ["-package-conf", file, "-no-user-package-conf"]

9
Types.hs
View File

@ -65,11 +65,10 @@ addNewLine = (++ "\n")
---------------------------------------------------------------- ----------------------------------------------------------------
data Cradle = Cradle { data Cradle = Cradle {
cradleCurrentDir :: FilePath cradleCurrentDir :: FilePath
, cradleCabalDir :: Maybe FilePath , cradleCabalDir :: Maybe FilePath
, cradleCabalFile :: Maybe FilePath , cradleCabalFile :: Maybe FilePath
, cradlePackageConfOpts :: Maybe [String] , cradlePackageConf :: Maybe FilePath
, cradleGHCVersion :: String
} deriving Show } deriving Show
---------------------------------------------------------------- ----------------------------------------------------------------

4
test/CheckSpec.hs
View File

@ -1,5 +1,6 @@
module CheckSpec where module CheckSpec where
import CabalApi
import Check import Check
import Cradle import Cradle
import Expectation import Expectation
@ -11,6 +12,7 @@ spec = do
describe "checkSyntax" $ do describe "checkSyntax" $ do
it "can check even if an executable depends on its library" $ do it "can check even if an executable depends on its library" $ do
withDirectory "test/data/ghc-mod-check" $ do withDirectory "test/data/ghc-mod-check" $ do
cradle <- findCradle Nothing (strVer,_) <- getGHCVersion
cradle <- findCradle Nothing strVer
res <- checkSyntax defaultOptions cradle "main.hs" res <- checkSyntax defaultOptions cradle "main.hs"
res `shouldBe` "main.hs:5:1:Warning: Top-level binding with no type signature: main :: IO ()\NUL\n" res `shouldBe` "main.hs:5:1:Warning: Top-level binding with no type signature: main :: IO ()\NUL\n"

4
test/InfoSpec.hs
View File

@ -1,5 +1,6 @@
module InfoSpec where module InfoSpec where
import CabalApi
import Cradle import Cradle
import Expectation import Expectation
import Info import Info
@ -11,6 +12,7 @@ spec = do
describe "typeExpr" $ do describe "typeExpr" $ do
it "shows types of the expression and its outers" $ do it "shows types of the expression and its outers" $ do
withDirectory "test/data/ghc-mod-check" $ do withDirectory "test/data/ghc-mod-check" $ do
cradle <- findCradle Nothing (strVer,_) <- getGHCVersion
cradle <- findCradle Nothing strVer
res <- typeExpr defaultOptions cradle "Data.Foo" 9 5 "Data/Foo.hs" 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" res `shouldBe` "9 5 11 40 \"Int -> a -> a -> a\"\n7 1 11 40 \"Int -> Integer\"\n"