Param -> Types.

This commit is contained in:
Kazu Yamamoto 2010-04-30 18:36:31 +09:00
parent 17a97aa1dd
commit 5c4ded0630
11 changed files with 36 additions and 41 deletions

View File

@ -3,11 +3,9 @@ module Browse (browseModule) where
import Control.Applicative
import Data.Char
import Data.List
import Exception
import GHC
import GHC.Paths (libdir)
import Name
import Param
import Types
----------------------------------------------------------------
@ -17,12 +15,9 @@ browseModule opt mdlName = convert opt . validate <$> browse mdlName
validate = sort . filter (isAlpha.head)
browse :: String -> IO [String]
browse mdlName = ghandle ignore $ runGhc (Just libdir) $ do
initSession
browse mdlName = withGHC $ do
initSession0
maybeNamesToStrings <$> lookupModuleInfo
where
initSession = getSessionDynFlags >>= setSessionDynFlags
lookupModuleInfo = findModule (mkModuleName mdlName) Nothing >>= getModuleInfo
maybeNamesToStrings = maybe [] (map getOccString . modInfoExports)
ignore :: SomeException -> IO [String]
ignore _ = return []

View File

@ -5,14 +5,12 @@ import Control.Applicative
import Data.IORef
import DynFlags
import ErrUtils
import Exception
import FastString
import GHC
import GHC.Paths (libdir)
import HscTypes
import Outputable hiding (showSDoc)
import Param
import Pretty
import Types
----------------------------------------------------------------
@ -22,7 +20,7 @@ checkSyntax _ file = unlines <$> check file
----------------------------------------------------------------
check :: String -> IO [String]
check fileName = ghandle ignore $ runGhc (Just libdir) $ do
check fileName = withGHC $ do
ref <- liftIO $ newIORef []
initSession
setTargetFile fileName
@ -37,8 +35,6 @@ check fileName = ghandle ignore $ runGhc (Just libdir) $ do
setTargetFile file = do
target <- guessTarget file Nothing
setTargets [target]
ignore :: SomeException -> IO [String]
ignore _ = return []
-- I don't know why, but parseDynamicFlags must be used.
cmdOptions :: [Located String]

View File

@ -6,10 +6,10 @@ import Control.Applicative
import Control.Exception hiding (try)
import Lang
import List
import Param
import Prelude hiding (catch)
import System.Console.GetOpt
import System.Environment (getArgs)
import Types
----------------------------------------------------------------

View File

@ -1,7 +1,7 @@
module Lang where
import Param
import DynFlags
import Types
listLanguages :: Options -> IO String
listLanguages opt = return $ convert opt supportedLanguages

19
List.hs
View File

@ -2,24 +2,21 @@ module List (listModules) where
import Control.Applicative
import Data.List
import Exception
import GHC
import GHC.Paths (libdir)
import Packages
import Param
import Types
import UniqFM
----------------------------------------------------------------
listModules :: Options -> IO String
listModules opt = convert opt . nub . sort <$> getModules
listModules opt = convert opt . nub . sort <$> list
getModules :: IO [String]
getModules = ghandle ignore $ runGhc (Just libdir) $ do
initSession
list :: IO [String]
list = withGHC $ do
initSession0
getExposedModules <$> getSessionDynFlags
where
initSession = getSessionDynFlags >>= setSessionDynFlags
getExposedModules = map moduleNameString . concatMap exposedModules . eltsUFM . pkgIdMap . pkgState
ignore :: SomeException -> IO [String]
ignore _ = return []
getExposedModules = map moduleNameString
. concatMap exposedModules
. eltsUFM . pkgIdMap . pkgState

View File

@ -1,5 +0,0 @@
module Param where
data Options = Options {
convert :: [String] -> String
}

18
Types.hs Normal file
View File

@ -0,0 +1,18 @@
module Types where
import Exception
import GHC
import GHC.Paths (libdir)
data Options = Options {
convert :: [String] -> String
}
withGHC :: Ghc [String] -> IO [String]
withGHC body = ghandle ignore $ runGhc (Just libdir) body
where
ignore :: SomeException -> IO [String]
ignore _ = return []
initSession0 :: Ghc [PackageId]
initSession0 = getSessionDynFlags >>= setSessionDynFlags

View File

@ -66,8 +66,7 @@
(lambda ()
(let ((msg (mapconcat 'identity (cons ghc-module-command args) " ")))
(message "Executing \"%s\"..." msg)
(apply 'call-process ghc-module-command nil t nil
(append '("-l") (ghc-module-command-args) args))
(apply 'call-process ghc-module-command nil t nil (cons "-l" args))
(message "Executing \"%s\"...done" msg))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

View File

@ -30,8 +30,7 @@
(let ((after-save-hook nil))
(save-buffer))
(let ((file (file-name-nondirectory (buffer-file-name))))
(list ghc-module-command (append (ghc-module-command-args)
(list "check" file)))))
(list ghc-module-command (list "check" file))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

View File

@ -59,9 +59,5 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar ghc-module-command "ghc-mod")
(defvar ghc-ghc-pkg-command (ghc-which "ghc-pkg"))
(defun ghc-module-command-args ()
(list "-p" ghc-ghc-pkg-command))
(provide 'ghc-func)

View File

@ -23,7 +23,7 @@ Data-Files: Makefile ghc.el ghc-func.el ghc-doc.el ghc-comp.el
ghc-flymake.el
Executable ghc-mod
Main-Is: GHCMod.hs
Other-Modules: List Browse Check Param Lang
Other-Modules: List Browse Check Lang Types
if impl(ghc >= 6.12)
GHC-Options: -Wall -fno-warn-unused-do-bind
else