diff --git a/CabalDev.hs b/CabalDev.hs new file mode 100644 --- /dev/null +++ b/CabalDev.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE DoAndIfThenElse #-} + +module CabalDev (modifyOptions) where + +{- +If the directory 'cabal-dev/packages-X.X.X.conf' exists, add it to the +options ghc-mod uses to check the source. Otherwise just pass it on. +-} + +import Data.Maybe (listToMaybe) +import System.FilePath.Find +import System.FilePath.Posix (splitPath,joinPath,()) +import System.Posix.Directory (getWorkingDirectory) +import System.Directory + +import Types + +modifyOptions :: Options -> IO Options +modifyOptions opts = + fmap (has_cdev opts) findCabalDev + where + has_cdev :: Options -> Maybe String -> Options + has_cdev op Nothing = op + has_cdev op (Just path) = addPath op path + +findCabalDev :: IO (Maybe String) +findCabalDev = + getWorkingDirectory >>= searchIt . splitPath + +addPath :: Options -> String -> Options +addPath orig_opts path = do + let orig_ghcopt = ghcOpts orig_opts + orig_opts { ghcOpts = orig_ghcopt ++ ["-package-conf", path] } + +searchIt :: [FilePath] -> IO (Maybe FilePath) +searchIt [] = return Nothing +searchIt path = do + a <- doesDirectoryExist (mpath path) + if a then do + b <- find always (fileName ~~? "packages*.conf") $ mpath path + maybe (searchIt $ init path) (return . Just) $ listToMaybe b + else + return Nothing + where + mpath a = joinPath a "cabal-dev/" diff --git a/Check.hs b/Check.hs --- a/Check.hs +++ b/Check.hs @@ -12,7 +12,8 @@ ---------------------------------------------------------------- checkSyntax :: Options -> String -> IO String -checkSyntax opt file = unlines <$> check opt file +checkSyntax opt file = do + unlines <$> check opt file ---------------------------------------------------------------- @@ -24,5 +25,4 @@ setTargetFile file load LoadAllTargets liftIO readLog - options = ["-Wall","-fno-warn-unused-do-bind"] - ++ map ("-i" ++) (checkIncludes opt) + options = ["-Wall","-fno-warn-unused-do-bind"] ++ ghcOpts opt diff --git a/GHCMod.hs b/GHCMod.hs --- a/GHCMod.hs +++ b/GHCMod.hs @@ -2,6 +2,7 @@ module Main where +import CabalDev (modifyOptions) import Browse import Check import Control.Applicative @@ -20,15 +21,18 @@ ---------------------------------------------------------------- +ghcOptHelp :: String +ghcOptHelp = " [-g GHC_opt1 -g GHC_opt2 ...] " + usage :: String -usage = "ghc-mod version 0.6.2\n" +usage = "ghc-mod version 1.0.0\n" ++ "Usage:\n" - ++ "\t ghc-mod list [-l]\n" + ++ "\t ghc-mod list" ++ ghcOptHelp ++ "[-l]\n" ++ "\t ghc-mod lang [-l]\n" - ++ "\t ghc-mod browse [-l] [-o] [ ...]\n" - ++ "\t ghc-mod check [-i inc] \n" - ++ "\t ghc-mod type \n" - ++ "\t ghc-mod info \n" + ++ "\t ghc-mod browse" ++ ghcOptHelp ++ "[-l] [-o] [ ...]\n" + ++ "\t ghc-mod check" ++ ghcOptHelp ++ "\n" + ++ "\t ghc-mod type" ++ ghcOptHelp ++ " \n" + ++ "\t ghc-mod info" ++ ghcOptHelp ++ " \n" ++ "\t ghc-mod lint [-h opt] \n" ++ "\t ghc-mod boot\n" ++ "\t ghc-mod help\n" @@ -39,10 +43,8 @@ defaultOptions = Options { convert = toPlain , hlintOpts = [] - , checkIncludes = [] + , ghcOpts = [] , operators = False - , packageConfs = [] - , useUserPackageConf = True } argspec :: [OptDescr (Options -> Options)] @@ -51,19 +53,13 @@ "print as a list of Lisp" , Option "h" ["hlintOpt"] (ReqArg (\h opts -> opts { hlintOpts = h : hlintOpts opts }) "hlintOpt") - "hint to be ignored" + "hlint options" + , Option "g" ["ghcOpt"] + (ReqArg (\g opts -> opts { ghcOpts = g : ghcOpts opts }) "ghcOpt") + "GHC options" , Option "o" ["operators"] (NoArg (\opts -> opts { operators = True })) "print operators, too" - , Option "" ["package-conf"] - (ReqArg (\p opts -> opts { packageConfs = p : packageConfs opts }) "path") - "additional package database" - , Option "" ["no-user-package-conf"] - (NoArg (\opts -> opts{ useUserPackageConf = False })) - "do not read the user package database" - , Option "i" ["include"] - (ReqArg (\i opts -> opts{ checkIncludes = i : checkIncludes opts }) "include") - "directory to include in search for modules" ] parseArgs :: [OptDescr (Options -> Options)] -> [String] -> (Options, [String]) @@ -86,8 +82,8 @@ main :: IO () main = flip catches handlers $ do args <- getArgs - let (opt,cmdArg) = parseArgs argspec args - res <- case safelist cmdArg 0 of + let (opt',cmdArg) = parseArgs argspec args + res <- modifyOptions opt' >>= \opt -> case safelist cmdArg 0 of "browse" -> concat <$> mapM (browseModule opt) (tail cmdArg) "list" -> listModules opt "check" -> withFile (checkSyntax opt) (safelist cmdArg 1) diff --git a/Types.hs b/Types.hs --- a/Types.hs +++ b/Types.hs @@ -13,10 +13,8 @@ data Options = Options { convert :: [String] -> String , hlintOpts :: [String] - , checkIncludes :: [String] + , ghcOpts :: [String] , operators :: Bool - , packageConfs :: [FilePath] - , useUserPackageConf :: Bool } withGHC :: (MonadPlus m) => Ghc (m a) -> IO (m a) @@ -29,14 +27,14 @@ initSession0 :: Options -> Ghc [PackageId] initSession0 opt = getSessionDynFlags >>= - setSessionDynFlags . setPackageConfFlags opt + (>>= setSessionDynFlags) . setGhcFlags opt initSession :: Options -> [String] -> [FilePath] -> Bool -> Ghc LogReader initSession opt cmdOpts idirs logging = do dflags <- getSessionDynFlags let opts = map noLoc cmdOpts (dflags',_,_) <- parseDynamicFlags dflags opts - (dflags'',readLog) <- liftIO . setLogger logging . setPackageConfFlags opt . setFlags dflags' $ idirs + (dflags'',readLog) <- liftIO . (>>= setLogger logging) . setGhcFlags opt . setFlags dflags' $ idirs setSessionDynFlags dflags'' return readLog @@ -55,17 +53,10 @@ ghcPackage :: PackageFlag ghcPackage = ExposePackage "ghc" -setPackageConfFlags :: Options -> DynFlags -> DynFlags -setPackageConfFlags - Options { packageConfs = confs, useUserPackageConf = useUser } - flagset@DynFlags { extraPkgConfs = extra, flags = origFlags } - = flagset { extraPkgConfs = extra', flags = flags' } - where - extra' = confs ++ extra - flags' = if useUser then - origFlags - else - filter (/=Opt_ReadUserPackageConf) origFlags +setGhcFlags :: Monad m => Options -> DynFlags -> m DynFlags +setGhcFlags opt flagset = + do (flagset',_,_) <- parseDynamicFlags flagset (map noLoc (ghcOpts opt)) + return flagset' ---------------------------------------------------------------- diff --git a/elisp/ghc-comp.el b/elisp/ghc-comp.el --- a/elisp/ghc-comp.el +++ b/elisp/ghc-comp.el @@ -87,7 +87,7 @@ (lambda () (message "Loading names...") (apply 'call-process ghc-module-command nil t nil - (cons "-l" (cons "browse" mods))) + `(,@(ghc-make-ghc-options) "-l" "browse" ,@mods)) (message "Loading names...done")) (length mods)))) diff --git a/elisp/ghc-flymake.el b/elisp/ghc-flymake.el --- a/elisp/ghc-flymake.el +++ b/elisp/ghc-flymake.el @@ -9,6 +9,7 @@ ;;; Code: (require 'flymake) +(require 'ghc-func) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -16,13 +17,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defcustom ghc-flymake-check-includes nil - "list of directories to include when checking file" - :type '(repeat string) -;; :risky nil - :require 'ghc-flymake - :group 'ghc-flymake) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defconst ghc-error-buffer-name "*GHC Errors*") @@ -45,18 +39,15 @@ (let ((after-save-hook nil)) (save-buffer)) (let ((file (file-name-nondirectory (buffer-file-name)))) - (list ghc-module-command (ghc-flymake-command file ghc-hlint-options)))) + (list ghc-module-command (ghc-flymake-command file)))) (defvar ghc-flymake-command nil) ;; nil: check, t: lint -(defun ghc-flymake-command (file opts) +(defun ghc-flymake-command (file) (if ghc-flymake-command - (let ((hopts (ghc-mapconcat (lambda (x) (list "-h" x)) opts))) + (let ((hopts (ghc-mapconcat (lambda (x) (list "-h" x)) ghc-hlint-options))) `(,@hopts "lint" ,file)) - (if (null ghc-flymake-check-includes) - (list "check" file) - (let ((includes (ghc-mapconcat (lambda (x) (list "-i" x)) ghc-flymake-check-includes))) - `("check" ,@includes ,file))))) + `(,@(ghc-make-ghc-options) "check" ,file))) (defun ghc-flymake-toggle-command () (interactive) diff --git a/elisp/ghc-func.el b/elisp/ghc-func.el --- a/elisp/ghc-func.el +++ b/elisp/ghc-func.el @@ -11,6 +11,8 @@ (defvar ghc-module-command "ghc-mod" "*The command name of \"ghc-mod\"") +(defvar ghc-ghc-options nil "*GHC options") + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun ghc-replace-character (string from to) @@ -134,5 +136,8 @@ (setq getter (intern (format "ghc-%s-get-%s" type-name member-name))) (fset getter (list 'lambda '(struct) (list 'nth i 'struct))) (setq keys (cdr keys))))) + +(defun ghc-make-ghc-options () + (ghc-mapconcat (lambda (x) (list "-g" x)) ghc-ghc-options)) (provide 'ghc-func) diff --git a/elisp/ghc-info.el b/elisp/ghc-info.el --- a/elisp/ghc-info.el +++ b/elisp/ghc-info.el @@ -26,7 +26,8 @@ (file (buffer-name))) (with-temp-buffer (cd cdir) - (call-process ghc-module-command nil t nil "type" file modname expr) + (apply 'call-process ghc-module-command nil t nil + `(,@(ghc-make-ghc-options) "type" ,file ,modname ,expr)) (message (buffer-substring (point-min) (1- (point-max))))))) (defun ghc-show-info (&optional ask) @@ -49,7 +50,8 @@ (insert (with-temp-buffer (cd cdir) - (call-process ghc-module-command nil t nil "info" file modname expr) + (apply 'call-process ghc-module-command nil t nil + `(,@(ghc-make-ghc-options) "info" ,file ,modname ,expr)) (buffer-substring (point-min) (1- (point-max)))))) (display-buffer buf))) diff --git a/elisp/ghc.el b/elisp/ghc.el --- a/elisp/ghc.el +++ b/elisp/ghc.el @@ -16,7 +16,7 @@ ;;; Code: -(defconst ghc-version "0.6.1") +(defconst ghc-version "1.0.0") ;; (eval-when-compile ;; (require 'haskell-mode)) diff --git a/ghc-mod.cabal b/ghc-mod.cabal --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -1,5 +1,5 @@ Name: ghc-mod -Version: 0.6.2 +Version: 1.0.0 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -23,14 +23,14 @@ ghc-flymake.el ghc-command.el ghc-info.el Executable ghc-mod Main-Is: GHCMod.hs - Other-Modules: List Browse Cabal Check Info Lang Lint Types ErrMsg + Other-Modules: List Browse Cabal CabalDev Check Info Lang Lint Types ErrMsg if impl(ghc >= 6.12) GHC-Options: -Wall -fno-warn-unused-do-bind else GHC-Options: -Wall Build-Depends: base >= 4.0 && < 5, ghc, ghc-paths, transformers, - process, directory, filepath, old-time, - hlint >= 1.7.1, + process, directory, filepath, old-time, unix, + hlint >= 1.7.1, filemanip, attoparsec, enumerator, attoparsec-enumerator Source-Repository head Type: git