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

Using Cradle.

Browse Source
This commit is contained in:
Kazu Yamamoto 2013-03-02 16:14:55 +09:00
parent f43af4be29
commit a393f8a971
10 changed files with 62 additions and 101 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
Cabal.hs
View File

@ -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

10
Check.hs
View File

@ -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

6
Cradle.hs
View File

@ -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

16
GHCApi.hs
View File

@ -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]

20
GHCMod.hs
View File

@ -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
----------------------------------------------------------------

28
Info.hs
View File

@ -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

1
ghc-mod.cabal
View File

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

23
test/CabalSpec.hs
View File

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

6
test/CheckSpec.hs
View File

@ -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"

6
test/InfoSpec.hs
View File

@ -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"