ghc-mod 0.3.0 → 0.4.0
raw patch · 14 files changed
+374/−334 lines, 14 filesdep +ghcdep +ghc-pathsdep −haskell-src-extsdep −parsec
Dependencies added: ghc, ghc-paths
Dependencies removed: haskell-src-exts, parsec
Files
- Browse.hs +12/−113
- Check.hs +81/−41
- GHCMod.hs +32/−26
- Lang.hs +3/−10
- Lint.hs +20/−0
- List.hs +12/−44
- Param.hs +0/−9
- Types.hs +19/−0
- elisp/ghc-comp.el +69/−39
- elisp/ghc-doc.el +12/−0
- elisp/ghc-flymake.el +52/−23
- elisp/ghc-func.el +40/−19
- elisp/ghc.el +18/−5
- ghc-mod.cabal +4/−5
Browse.hs view
@@ -1,124 +1,23 @@ module Browse (browseModule) where -import Control.Applicative hiding ((<|>), many)+import Control.Applicative import Data.Char import Data.List-import Language.Haskell.Exts.Extension-import Language.Haskell.Exts.Parser hiding (parse)-import Language.Haskell.Exts.Syntax-import System.IO-import System.Process-import Text.Parsec-import Text.Parsec.String-import Param+import GHC+import Name+import Types ---------------------------------------------------------------- browseModule :: Options -> String -> IO String-browseModule opt mname = convert opt . nub . sort . parseSyntax . preprocess <$> getSyntax opt mname--getSyntax :: Options -> String -> IO String-getSyntax opt mname = do- (inp,out,_,_) <- runInteractiveProcess (ghci opt) [] Nothing Nothing- mapM_ setFD [inp,out]- hPutStrLn inp ":set prompt \"\""- hPutStrLn inp "1"- hPutStrLn inp $ ":browse " ++ mname- hPutStrLn inp ":set prompt \"Prelude>\""- hPutStrLn inp ":quit"- cs <- hGetContents out- return $ unlines $ dropTailer $ dropHeader $ lines $ cs- where- isNotPrefixOf x y = not (x `isPrefixOf` y)- dropHeader xs = tail $ dropWhile (isNotPrefixOf "Prelude>") xs- dropTailer = takeWhile (isNotPrefixOf "Prelude>")- setFD h = do- hSetBinaryMode h False- hSetBuffering h LineBuffering--parseSyntax :: String -> [String]-parseSyntax xs = do- let mode = defaultParseMode { extensions = NewQualifiedOperators : ExplicitForall : glasgowExts }- res = parseModuleWithMode mode xs- case res of- ParseOk x -> identifiers x- _ -> []---------------------------------------------------------------------preprocess :: String -> String-preprocess cs = case parse remove "remove" cs of- Right a -> a- Left e -> error $ show e--modName :: Parser String-modName = (:) <$> (oneOf ['A'..'Z'])- <*> (many . oneOf $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_'#")--anyName :: Parser String-anyName = many1 . oneOf $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_'#"--manyBefore :: Show tok => GenParser tok st a -> GenParser tok st [tok] -> GenParser tok st [a]-manyBefore p anchor = manyTill p (eof <|> try anc)- where- anc = do- pos <- getPosition- s <- anchor- ss <- getInput- setInput $ s ++ ss- setPosition pos- return ()--keyword :: Parser String-keyword = (++) <$> modName <*> string "."--ghcName :: Parser String-ghcName = do - keyword- try sep <|> end+browseModule opt mdlName = convert opt . validate <$> browse mdlName where- sep = last <$> sepBy1 anyName (char '.')- end = "" <$ endBy1 anyName (char '.')--nonGhcName :: Parser String-nonGhcName = (:) <$> anyChar <*> manyBefore anyChar keyword--remove :: Parser String-remove = do- l1 <- try ghcName <|> return ""- l2 <- nonGhcName- ll <- many (do x <- ghcName- y <- nonGhcName- return $ x ++ y)- return $ concat $ l1 : l2 : ll------------------------------------------------------------------+ validate = sort . filter (isAlpha.head) -identifiers :: Module -> [String]-identifiers (Module _ _ _ _ _ _ x) = filter hid $ concatMap decl x+browse :: String -> IO [String]+browse mdlName = withGHC $ do+ initSession0+ maybeNamesToStrings <$> lookupModuleInfo where- hid = all (\c -> isAlphaNum c || elem c "_'")--decl :: Decl -> [String]-decl (TypeSig _ [x] _) = [name x]-decl (DataDecl _ _ _ x _ y _) = name x : (map qualConDecl y)-decl (ClassDecl _ _ x _ _ y) = name x : (map classDecl y)-decl (TypeDecl _ x _ _) = [name x]-decl x = [show x]--qualConDecl :: QualConDecl -> String-qualConDecl (QualConDecl _ _ _ x) = conDecl x--conDecl :: ConDecl -> String-conDecl (ConDecl (Ident x) _) = x-conDecl (InfixConDecl _ (Ident x) _) = x-conDecl x = show x--classDecl :: ClassDecl -> String-classDecl (ClsDecl x) = concat $ decl x -- xxx-classDecl x = show x--name :: Name -> String-name (Symbol x) = x-name (Ident x) = x+ lookupModuleInfo = findModule (mkModuleName mdlName) Nothing >>= getModuleInfo+ maybeNamesToStrings = maybe [] (map getOccString . modInfoExports)
Check.hs view
@@ -1,53 +1,93 @@-{-# LANGUAGE CPP #-}- module Check (checkSyntax) where +import Bag import Control.Applicative-import Control.Monad-import Data.Char-import Data.List-import Param-import System.Directory-import System.FilePath-import System.IO-import System.Process+import Data.IORef+import DynFlags+import ErrUtils+import Exception+import FastString+import GHC+import HscTypes+import Outputable hiding (showSDoc)+import Pretty+import Types+import Prelude hiding (catch) ---------------------------------------------------------------- checkSyntax :: Options -> String -> IO String-checkSyntax opt file = do- makeDirectory (outDir opt)-#if __GLASGOW_HASKELL__ >= 611- (_,_,herr,_) <- runInteractiveProcess (ghc opt) ["--make","-Wall","-fno-warn-unused-do-bind",file,"-outputdir","dist/flymake","-o","dist/flymake/a.out","-i..","-i../..","-i../../..","-i../../../..","-i../../../../.."] Nothing Nothing-#else- (_,_,herr,_) <- runInteractiveProcess (ghc opt) ["--make","-Wall",file,"-outputdir","dist/flymake","-o","dist/flymake/a.out","-i..","-i../..","-i../../..","-i../../../..","-i../../../../.."] Nothing Nothing-#endif- hSetBinaryMode herr False- refine <$> hGetContents herr- where- refine = unfoldLines . remove . lines- remove = filter (\x -> not ("Linking" `isPrefixOf` x))- . filter (\x -> not ("[" `isPrefixOf` x))- . filter (/="")+checkSyntax _ file = unlines <$> check file -unfoldLines :: [String] -> String-unfoldLines [] = ""-unfoldLines (x:xs) = x ++ unfold xs+----------------------------------------------------------------++check :: String -> IO [String]+check fileName = withGHC $ do+ ref <- liftIO $ newIORef []+ initSession+ setTargetFile fileName+ loadWithLogger (refLogger ref) LoadAllTargets `gcatch` handleParseError ref+ clearWarnings+ liftIO $ readIORef ref where- unfold [] = "\n"- unfold (l:ls)- | isAlpha (head l) = ('\n':l) ++ unfold ls- | otherwise = (drop 4 l) ++ "\0" ++ unfold ls+ -- I don't know why, but parseDynamicFlags must be used.+ initSession = do+ dflags <- getSessionDynFlags+ (dflags',_,_) <- parseDynamicFlags dflags cmdOptions+ setSessionDynFlags $ setFlags dflags'+ setTargetFile file = do+ target <- guessTarget file Nothing+ setTargets [target]+ handleParseError ref e = do+ liftIO . writeIORef ref $ errBagToStrList . srcErrorMessages $ e+ return Succeeded +-- I don't know why, but parseDynamicFlags must be used.+cmdOptions :: [Located String]+cmdOptions = map noLoc ["-Wall","-fno-warn-unused-do-bind"]+ ---------------------------------------------------------------- -makeDirectory :: FilePath -> IO ()-makeDirectory dir = makeDirectoryRecur $ normalise dir- where- makeDirectoryRecur "" = return ()- makeDirectoryRecur cur = do- exist <- doesDirectoryExist cur- let par = takeDirectory cur- unless exist $ do- makeDirectoryRecur par- createDirectory cur+refLogger :: IORef [String] -> WarnErrLogger+refLogger ref Nothing =+ (errBagToStrList <$> getWarnings) >>= liftIO . writeIORef ref+refLogger ref (Just e) =+ liftIO . writeIORef ref $ errBagToStrList . srcErrorMessages $ e++errBagToStrList :: Bag ErrMsg -> [String]+errBagToStrList = map showErrMsg . reverse . bagToList++----------------------------------------------------------------++setFlags :: DynFlags -> DynFlags+setFlags d = d {+ importPaths = importPaths d ++ importDirs+ , packageFlags = ghcPackage : packageFlags d+ , ghcLink = NoLink+-- GHC.desugarModule does not produces the pattern warnings, why?+-- , hscTarget = HscNothing+ , hscTarget = HscInterpreted+ }++importDirs :: [String]+importDirs = ["..","../..","../../..","../../../../.."]++ghcPackage :: PackageFlag+ghcPackage = ExposePackage "ghc"++----------------------------------------------------------------++showErrMsg :: ErrMsg -> String+showErrMsg err = file ++ ":" ++ line ++ ":" ++ col ++ ":" ++ msg+ where+ spn = head (errMsgSpans err)+ file = unpackFS (srcSpanFile spn)+ line = show (srcSpanStartLine spn)+ col = show (srcSpanStartCol spn)+ msg = showSDoc (errMsgShortDoc err)++style :: PprStyle+style = mkUserStyle neverQualify AllTheWay++showSDoc :: SDoc -> String+showSDoc d = Pretty.showDocWith OneLineMode (d style)
GHCMod.hs view
@@ -2,50 +2,45 @@ import Browse import Check+import Control.Applicative import Control.Exception hiding (try)-import List-import Param import Lang+import Lint+import List import Prelude hiding (catch) import System.Console.GetOpt+import System.Directory import System.Environment (getArgs)+import Types ---------------------------------------------------------------- usage :: String-usage = "ghc-mod version 0.2.0\n"+usage = "ghc-mod version 0.4.0\n" ++ "Usage:\n" ++ "\t ghc-mod list\n"- ++ "\t ghc-mod browse <module>\n"+ ++ "\t ghc-mod lang\n"+ ++ "\t ghc-mod browse <module> [<module> ...]\n" ++ "\t ghc-mod check <HaskellFile>\n"+ ++ "\t ghc-mod lint <HaskellFile>\n"+ ++ "\t ghc-mod boot\n" ++ "\t ghc-mod help\n" ---------------------------------------------------------------- defaultOptions :: Options-defaultOptions = Options { convert = toPlain- , ghc = "ghc"- , ghci = "ghci"- , ghcPkg = "ghc-pkg"- , outDir = "dist/flymake"- }+defaultOptions = Options {+ convert = toPlain+ , hlint = "hlint"+ } argspec :: [OptDescr (Options -> Options)]-argspec = [ Option ['l'] ["tolisp"]+argspec = [ Option "l" ["tolisp"] (NoArg (\opts -> opts { convert = toLisp })) "print as a list of Lisp"- , Option ['g'] ["ghc"]- (ReqArg (\str opts -> opts { ghc = str }) "ghc")- "GHC path"- , Option ['i'] ["ghci"]- (ReqArg (\str opts -> opts { ghci = str }) "ghci")- "ghci path"- , Option ['p'] ["ghc-pkg"]- (ReqArg (\str opts -> opts { ghcPkg = str }) "ghc-pkg")- "ghc-pkg path"- , Option ['o'] ["output-dir"]- (ReqArg (\str opts -> opts { outDir = str }) "dist/flymake")- "output directory"+ , Option "f" ["hlint"]+ (ReqArg (\str opts -> opts { hlint = str }) "hlint")+ "path to hlint" ] parseArgs :: [OptDescr (Options -> Options)] -> [String] -> (Options, [String])@@ -60,16 +55,27 @@ main = flip catch handler $ do args <- getArgs let (opt,cmdArg) = parseArgs argspec args- res <- case cmdArg !! 0 of- "browse" -> browseModule opt (cmdArg !! 1)+ res <- case head cmdArg of+ "browse" -> concat <$> mapM (browseModule opt) (tail cmdArg) "list" -> listModules opt- "check" -> checkSyntax opt (cmdArg !! 1)+ "check" -> withFile (checkSyntax opt) (cmdArg !! 1)+ "lint" -> withFile (lintSyntax opt) (cmdArg !! 1) "lang" -> listLanguages opt+ "boot" -> do+ mods <- listModules opt+ langs <- listLanguages opt+ pre <- browseModule opt "Prelude"+ return $ mods ++ langs ++ pre _ -> error usage putStr res where handler :: ErrorCall -> IO () handler _ = putStr usage+ withFile cmd file = do+ exist <- doesFileExist file+ if exist+ then cmd file+ else return "" ---------------------------------------------------------------- toLisp :: [String] -> String
Lang.hs view
@@ -1,14 +1,7 @@ module Lang where -import Control.Applicative-import Param-import System.IO-import System.Process+import DynFlags+import Types listLanguages :: Options -> IO String-listLanguages opt = convert opt . lines <$> getLangs opt--getLangs :: Options -> IO String-getLangs opt = do- (_,hout,_,_) <- runInteractiveProcess (ghc opt) ["--supported-languages"] Nothing Nothing- hGetContents hout+listLanguages opt = return $ convert opt supportedLanguages
+ Lint.hs view
@@ -0,0 +1,20 @@+module Lint where++import Control.Applicative+import Data.List+import System.IO+import System.Process+import Types++lintSyntax :: Options -> String -> IO String+lintSyntax cmd file = pretty <$> lint cmd file+ where+ pretty = unlines . map (concat . intersperse "\0")+ . filter (\x -> length x > 1)+ . groupBy (\a b -> a /= "" && b /= "") + . lines++lint :: Options -> String -> IO String+lint cmd file = do+ (_,hout,_,_) <- runInteractiveProcess (hlint cmd) ["-i","Use camelCase",file] Nothing Nothing+ hGetContents hout
List.hs view
@@ -2,53 +2,21 @@ import Control.Applicative import Data.List-import Param-import System.IO-import System.Process+import GHC+import Packages+import Types+import UniqFM ---------------------------------------------------------------- listModules :: Options -> IO String-listModules opt = convert opt . nub . sort . exposedModules <$> getDump opt--getDump :: Options -> IO String-getDump opt = do- (_,hout,_,_) <- runInteractiveProcess (ghcPkg opt) ["dump"] Nothing Nothing- hGetContents hout--exposedModules :: String -> [String]-exposedModules cs = results- where- ls = unfoldLines cs- ns = values "name: " ls- ms = values "exposed-modules: " ls- zs = zip ns ms- xs = filter (\(nm,_) -> nm `notElem` ["ghc", "ghc-prim", "rts", "integer"]) zs- ss = map snd xs- results = filter (\x -> not ("GHC" `isPrefixOf` x)) $ concatMap words ss--values :: String -> [String] -> [String]-values tag ls = value- where- value = map (drop len) fs- len = length tag- fs = filter (tag `isPrefixOf`) ls------------------------------------------------------------------+listModules opt = convert opt . nub . sort <$> list -unfoldLines :: String -> [String]-unfoldLines xs = self xs+list :: IO [String]+list = withGHC $ do+ initSession0+ getExposedModules <$> getSessionDynFlags where- splitNL = break (== '\n')- self "" = []- self s = let (l, s') = splitNL s- in case s' of- [] -> [l]- (_:' ':s'') -> cont s'' l- (_:s'') -> l : self s''- cont s a = let (l, s') = splitNL $ dropWhile (== ' ') s- a' = a ++ " " ++ l- in case s' of- [] -> [a']- (_:' ':s'') -> cont s'' a'- (_:s'') -> a' : self s''+ getExposedModules = map moduleNameString+ . concatMap exposedModules+ . eltsUFM . pkgIdMap . pkgState
− Param.hs
@@ -1,9 +0,0 @@-module Param where--data Options = Options { convert :: [String] -> String- , ghc :: FilePath- , ghci :: FilePath- , ghcPkg :: FilePath- , outDir :: FilePath- }-
+ Types.hs view
@@ -0,0 +1,19 @@+module Types where++import Exception+import GHC+import GHC.Paths (libdir)++data Options = Options {+ convert :: [String] -> String+ , hlint :: 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
elisp/ghc-comp.el view
@@ -47,11 +47,15 @@ (defvar ghc-loaded-module nil) (defun ghc-comp-init ()- (setq ghc-module-names (cons "hiding" (cons "qualified" (ghc-load-keyword "list"))))- (setq ghc-language-extensions (cons "LANGUAGE" (ghc-load-keyword "lang")))- (setq ghc-keyword-Prelude (ghc-load-keyword "browse" "Prelude"))- (setq ghc-loaded-module '("Prelude"))- (ghc-merge-keywords)+ (let* ((syms '(ghc-module-names+ ghc-language-extensions+ ghc-keyword-Prelude))+ (vals (ghc-boot (length syms))))+ (ghc-set syms vals))+ (ghc-add ghc-module-names "qualified")+ (ghc-add ghc-module-names "hiding")+ (ghc-add ghc-language-extensions "LANGUAGE")+ (ghc-merge-keywords '("Prelude")) (run-with-idle-timer ghc-idle-timer-interval 'repeat 'ghc-idle-timer)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;@@ -59,17 +63,27 @@ ;;; Executing command ;;; -(defun ghc-load-keyword (&rest args)+(defun ghc-boot (n) (if (not (ghc-which ghc-module-command)) (message "%s not found" ghc-module-command)- (ghc-read-lisp+ (ghc-read-lisp-list (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))- (message "Executing \"%s\"...done" msg))))))+ (message "Initializing...")+ (call-process ghc-module-command nil t nil "-l" "boot")+ (message "Initializing...done"))+ n))) +(defun ghc-load-modules (mods)+ (if (not (ghc-which ghc-module-command))+ (message "%s not found" ghc-module-command)+ (ghc-read-lisp-list+ (lambda ()+ (message "Loading names...")+ (apply 'call-process ghc-module-command nil t nil+ (cons "-l" (cons "browse" mods)))+ (message "Loading names...done"))+ (length mods))))+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Completion@@ -166,57 +180,73 @@ ;;; Loading keywords ;;; -(add-hook 'find-file-hook 'ghc-load-module-buffer)+(add-hook 'find-file-hook 'ghc-import-module) -(defun ghc-load-module-buffer ()+(defun ghc-import-module () (interactive) (when (eq major-mode 'haskell-mode)- (mapc 'ghc-load-module (ghc-gather-import-modules-buffer))))+ (ghc-load-module-buffer))) -(defun ghc-load-module (mod)- (when (and (member mod ghc-module-names)- (not (member mod ghc-loaded-module)))- (let ((keywords (ghc-load-keyword "browse" mod)))- (when (or (consp keywords) (null keywords))- (set (intern (concat ghc-keyword-prefix mod)) keywords)- (setq ghc-loaded-module (cons mod ghc-loaded-module))))))+(defun ghc-unloaded-modules (mods)+ (ghc-filter (lambda (mod)+ (and (member mod ghc-module-names)+ (not (member mod ghc-loaded-module))))+ mods)) -(defun ghc-merge-keywords ()+(defun ghc-load-module-all-buffers ()+ (ghc-load-merge-modules (ghc-gather-import-modules-all-buffers)))++(defun ghc-load-module-buffer ()+ (ghc-load-merge-modules (ghc-gather-import-modules-buffer)))++(defun ghc-load-merge-modules (mods)+ (let* ((umods (ghc-unloaded-modules mods))+ (syms (mapcar 'ghc-module-symbol umods))+ (names (ghc-load-modules umods)))+ (ghc-set syms names)+ (ghc-merge-keywords umods)))++(defun ghc-merge-keywords (mods)+ (setq ghc-loaded-module (append mods ghc-loaded-module)) (let* ((modkeys (mapcar 'ghc-module-keyword ghc-loaded-module)) (keywords (cons ghc-reserved-keyword modkeys)) (uniq-sorted (sort (ghc-uniq-lol keywords) 'string<))) (setq ghc-merged-keyword uniq-sorted))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;-;;;-;;; Background Idle Timer-;;;+(defun ghc-module-symbol (mod)+ (intern (concat ghc-keyword-prefix mod))) -(defun ghc-idle-timer ()- (dolist (mod (ghc-gather-import-modules))- (ghc-load-module mod))- (ghc-merge-keywords))+(defun ghc-module-keyword (mod)+ (symbol-value (ghc-module-symbol mod))) -(defun ghc-gather-import-modules ()++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defun ghc-gather-import-modules-all-buffers () (let ((bufs (mapcar 'buffer-name (buffer-list))) ret) (save-excursion- (dolist (buf bufs)+ (dolist (buf bufs (ghc-uniq-lol ret)) (when (string-match "\\.hs$" buf) (set-buffer buf)- (setq ret (cons (ghc-gather-import-modules-buffer) ret)))))- (ghc-uniq-lol ret)))+ (ghc-add ret (ghc-gather-import-modules-buffer))))))) (defun ghc-gather-import-modules-buffer () (let (ret) (save-excursion (goto-char (point-min))- (while (re-search-forward "^import *\\([^\n ]+\\)" nil t)- (setq ret (cons (match-string-no-properties 1) ret))+ (while (re-search-forward "^import\\( *qualified\\)? +\\([^\n ]+\\)" nil t)+ (ghc-add ret (match-string-no-properties 2)) (forward-line))) ret)) -(defun ghc-module-keyword (mod)- (symbol-value (intern (concat ghc-keyword-prefix mod))))+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;;;+;;; Background Idle Timer+;;;++(defalias 'ghc-idle-timer 'ghc-load-module-all-buffer)++(defun ghc-load-module-all-buffer () nil) (provide 'ghc-comp)
elisp/ghc-doc.el view
@@ -58,4 +58,16 @@ (make-sparse-keymap))) (define-key ghc-input-map "\t" 'ghc-complete)) +(defun ghc-read-module-name (def)+ (read-from-minibuffer "Module name: " def ghc-input-map))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defun ghc-extract-module ()+ (interactive)+ (save-excursion+ (beginning-of-line)+ (if (looking-at "^\\(import\\|module\\) +\\(qualified +\\)?\\([^ (\n]+\\)")+ (match-string-no-properties 3))))+ (provide 'ghc-doc)
elisp/ghc-flymake.el view
@@ -30,48 +30,77 @@ (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 (ghc-flymake-command file)))) +(defvar ghc-hlint (ghc-which "hlint"))++(defvar ghc-flymake-command nil) ;; nil: check, t: lint++(defun ghc-flymake-command (file)+ (if ghc-flymake-command+ (list "-f" ghc-hlint "lint" file)+ (list "check" file)))++(defun ghc-flymake-toggle-command ()+ (interactive)+ (setq ghc-flymake-command (not ghc-flymake-command))+ (if ghc-flymake-command+ (message "Syntax check with hlint")+ (message "Syntax check with GHC")))+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun ghc-display-errors ()+(defun ghc-flymake-display-errors () (interactive)- (let* ((data (ghc-flymake-data))- (buf (get-buffer-create ghc-error-buffer-name)))- (with-current-buffer buf- (erase-buffer)- (ghc-insert-errors data))- (display-buffer buf)))+ (if (not (ghc-flymake-have-errs-p))+ (message "No errors or warnings")+ (let ((buf (get-buffer-create ghc-error-buffer-name))+ (title (ghc-flymake-err-title))+ (errs (ghc-flymake-err-list)))+ (with-current-buffer buf+ (erase-buffer)+ (ghc-flymake-insert-errors title errs))+ (display-buffer buf)))) -(defun ghc-insert-errors (data)- (let ((title (nth 0 data))- (errs (nth 1 data)))+(defun ghc-flymake-insert-errors (title errs)+ (save-excursion (insert title "\n")- (dolist (err errs)- (insert (ghc-replace-character (car err) 0 10) "\n"))- (goto-char (point-min))))+ (mapc (lambda (x) (insert (ghc-replace-character x ghc-null ghc-newline) "\n")) errs))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun ghc-flymake-insert-type ()+(defun ghc-flymake-insert-from-warning () (interactive)- (let ((data (ghc-flymake-first-data)))- (if (and data- (string-match "Inferred type: \\([^:]+ :: \\)\\(forall [^.]+\\. \\)?\\([^\0]*\\)" data))- (progn+ (dolist (data (ghc-flymake-err-list))+ (save-excursion+ (cond+ ((string-match "Inferred type: \\([^:]+ :: \\)\\(forall [^.]+\\. \\)?\\([^\0]*\\)" data) (beginning-of-line) (insert (match-string 1 data) (match-string 3 data) "\n"))- (message "No inferred type"))))+ ((string-match "Not in scope: `\\([^']+\\)'" data)+ (save-match-data+ (unless (re-search-forward "^$" nil t)+ (goto-char (point-max))+ (insert "\n")))+ (insert "\n" (match-string 1 data) " = undefined\n"))))))+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun ghc-flymake-err-get-title (x) (nth 0 x))+(defun ghc-flymake-err-get-errs (x) (nth 1 x))++(defalias 'ghc-flymake-have-errs-p 'ghc-flymake-data)+ (defun ghc-flymake-data () (let* ((line-no (flymake-current-line-no)) (info (nth 0 (flymake-find-err-info flymake-err-info line-no)))) (flymake-make-err-menu-data line-no info))) -(defun ghc-flymake-first-data ()- (nth 0 (nth 0 (nth 1 (ghc-flymake-data)))))+(defun ghc-flymake-err-title ()+ (ghc-flymake-err-get-title (ghc-flymake-data)))++(defun ghc-flymake-err-list ()+ (mapcar 'car (ghc-flymake-err-get-errs (ghc-flymake-data)))) (provide 'ghc-flymake)
elisp/ghc-func.el view
@@ -8,6 +8,10 @@ ;;; Code: +(defvar ghc-module-command "ghc-mod")++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+ (defun ghc-replace-character (string from to) "Replace characters equal to FROM to TO in STRING." (let ((ret (copy-sequence string)))@@ -15,6 +19,25 @@ (if (char-equal (aref ret cnt) from) (aset ret cnt to))))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defmacro ghc-add (sym val)+ `(setq ,sym (cons ,val ,sym)))++(defun ghc-set (vars vals)+ (dolist (var vars)+ (if var (set var (car vals))) ;; var can be nil to skip+ (setq vals (cdr vals))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defun ghc-filter (pred lst)+ (let (ret)+ (dolist (x lst (reverse ret))+ (if (funcall pred x) (ghc-add ret x)))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+ (defun ghc-which (cmd) (catch 'loop (dolist (suffix '("" ".exe"))@@ -24,15 +47,19 @@ (if (file-exists-p path) (throw 'loop path)))))))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+ (defun ghc-uniq-lol (lol) (let ((hash (make-hash-table :test 'equal)) ret) (dolist (lst lol) (dolist (key lst) (puthash key key hash)))- (maphash (lambda (key val) (setq ret (cons key ret))) hash)+ (maphash (lambda (key val) (ghc-add ret key)) hash) ret)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+ (defun ghc-read-lisp (func) (with-temp-buffer (funcall func)@@ -41,26 +68,20 @@ (read (current-buffer)) (error ())))) -(defun ghc-extract-module ()- (interactive)- (save-excursion- (beginning-of-line)- (if (looking-at "^\\(import\\|module\\) +\\(qualified +\\)?\\([^ (\n]+\\)")- (match-string-no-properties 3))))--(defun ghc-read-module-name (def)- (read-from-minibuffer "Module name: " def ghc-input-map))+(defun ghc-read-lisp-list (func n)+ (with-temp-buffer+ (funcall func)+ (goto-char (point-min))+ (condition-case nil+ (let ((m (set-marker (make-marker) 1 (current-buffer)))+ ret)+ (dotimes (i n (nreverse ret))+ (ghc-add ret (read m))))+ (error ())))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar ghc-module-command "ghc-mod")-(defvar ghc-ghc-command (ghc-which "ghc"))-(defvar ghc-ghci-command (ghc-which "ghci"))-(defvar ghc-ghc-pkg-command (ghc-which "ghc-pkg"))--(defun ghc-module-command-args ()- (list "-g" ghc-ghc-command- "-i" ghc-ghci-command- "-p" ghc-ghc-pkg-command))+(defconst ghc-null 0)+(defconst ghc-newline 10) (provide 'ghc-func)
elisp/ghc.el view
@@ -16,7 +16,7 @@ ;;; Code: -(defvar ghc-version "0.2.0")+(defvar ghc-version "0.4.0") ;; (eval-when-compile ;; (require 'haskell-mode))@@ -24,6 +24,8 @@ (require 'ghc-comp) (require 'ghc-doc) (require 'ghc-flymake)+(require 'ghc-command)+(require 'dabbrev) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;@@ -36,7 +38,10 @@ (defvar ghc-previous-key "\ep") (defvar ghc-next-key "\en") (defvar ghc-help-key "\e?")-(defvar ghc-insert-type-key "\et")+(defvar ghc-insert-key "\et")+(defvar ghc-sort-key "\es")+(defvar ghc-check-key "\C-x\C-s")+(defvar ghc-toggle-key "\C-c\C-c") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;@@ -46,15 +51,23 @@ (defvar ghc-initialized nil) (defun ghc-init ()+ (ghc-abbrev-init) (unless ghc-initialized (define-key haskell-mode-map ghc-completion-key 'ghc-complete) (define-key haskell-mode-map ghc-document-key 'ghc-browse-document)- (define-key haskell-mode-map ghc-import-key 'ghc-load-module-buffer)+ (define-key haskell-mode-map ghc-import-key 'ghc-import-module) (define-key haskell-mode-map ghc-previous-key 'flymake-goto-prev-error) (define-key haskell-mode-map ghc-next-key 'flymake-goto-next-error)- (define-key haskell-mode-map ghc-help-key 'ghc-display-errors)- (define-key haskell-mode-map ghc-insert-type-key 'ghc-flymake-insert-type)+ (define-key haskell-mode-map ghc-help-key 'ghc-flymake-display-errors)+ (define-key haskell-mode-map ghc-insert-key 'ghc-insert-template)+ (define-key haskell-mode-map ghc-sort-key 'ghc-sort-lines)+ (define-key haskell-mode-map ghc-check-key 'ghc-save-buffer)+ (define-key haskell-mode-map ghc-toggle-key 'ghc-flymake-toggle-command) (ghc-comp-init) (setq ghc-initialized t)))++(defun ghc-abbrev-init ()+ (make-local-variable 'dabbrev-case-fold-search)+ (setq dabbrev-case-fold-search nil)) (provide 'ghc)
ghc-mod.cabal view
@@ -1,5 +1,5 @@ Name: ghc-mod-Version: 0.3.0+Version: 0.4.0 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> License: BSD3@@ -23,14 +23,13 @@ ghc-flymake.el Executable ghc-mod Main-Is: GHCMod.hs- Other-Modules: List Browse Check Param Lang+ Other-Modules: List Browse Check Lang Lint Types if impl(ghc >= 6.12) GHC-Options: -Wall -fno-warn-unused-do-bind else GHC-Options: -Wall- Build-Depends: base >= 4.0 && < 5,- parsec >= 3, process, haskell-src-exts,- directory, filepath+ Build-Depends: base >= 4.0 && < 5, ghc, ghc-paths,+ process, directory, filepath Source-Repository head Type: git Location: git://github.com/kazu-yamamoto/ghc-mod.git