ghc-mod 0.4.4 → 0.5.1
raw patch · 13 files changed
+318/−59 lines, 13 files
Files
- Check.hs +7/−35
- GHCMod.hs +6/−1
- Info.hs +107/−0
- Lang.hs +6/−0
- Types.hs +41/−3
- elisp/Makefile +2/−1
- elisp/ghc-comp.el +6/−1
- elisp/ghc-doc.el +20/−10
- elisp/ghc-flymake.el +2/−2
- elisp/ghc-func.el +45/−0
- elisp/ghc-info.el +66/−0
- elisp/ghc.el +7/−3
- ghc-mod.cabal +3/−3
Check.hs view
@@ -3,7 +3,6 @@ import Bag import Control.Applicative import Data.IORef-import DynFlags import ErrUtils import Exception import FastString@@ -23,28 +22,18 @@ check :: String -> IO [String] check fileName = withGHC $ do- ref <- liftIO $ newIORef []- initSession+ ref <- newRef []+ initSession ["-Wall","-fno-warn-unused-do-bind"] setTargetFile fileName loadWithLogger (refLogger ref) LoadAllTargets `gcatch` handleParseError ref clearWarnings- liftIO $ readIORef ref+ readRef ref where- -- 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"]+ newRef = liftIO . newIORef+ readRef = liftIO . readIORef ---------------------------------------------------------------- @@ -59,24 +48,6 @@ ---------------------------------------------------------------- -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 ++ "\0" ++ ext where@@ -91,7 +62,8 @@ style = mkUserStyle neverQualify AllTheWay showSDoc :: SDoc -> String-showSDoc d = map toNull . Pretty.showDocWith ZigZagMode $ d style+--showSDoc d = map toNull . Pretty.showDocWith ZigZagMode $ d style+showSDoc d = map toNull . Pretty.showDocWith PageMode $ d style where toNull '\n' = '\0' toNull x = x
GHCMod.hs view
@@ -7,6 +7,7 @@ import Control.Applicative import Control.Exception import Data.Typeable+import Info import Lang import Lint import List@@ -20,12 +21,14 @@ ---------------------------------------------------------------- usage :: String-usage = "ghc-mod version 0.4.4\n"+usage = "ghc-mod version 0.5.1\n" ++ "Usage:\n" ++ "\t ghc-mod [-l] list\n" ++ "\t ghc-mod [-l] lang\n" ++ "\t ghc-mod [-l] browse <module> [<module> ...]\n" ++ "\t ghc-mod check <HaskellFile>\n"+ ++ "\t ghc-mod type <HaskellFile> <module> <expression>\n"+ ++ "\t ghc-mod info <HaskellFile> <module> <expression>\n" ++ "\t ghc-mod [-h opt] lint <HaskellFile>\n" ++ "\t ghc-mod boot\n" ++ "\t ghc-mod help\n"@@ -72,6 +75,8 @@ "browse" -> concat <$> mapM (browseModule opt) (tail cmdArg) "list" -> listModules opt "check" -> withFile (checkSyntax opt) (safelist cmdArg 1)+ "type" -> withFile (typeExpr opt (safelist cmdArg 2) (safelist cmdArg 3)) (safelist cmdArg 1)+ "info" -> withFile (infoExpr opt (safelist cmdArg 2) (safelist cmdArg 3)) (safelist cmdArg 1) "lint" -> withFile (lintSyntax opt) (safelist cmdArg 1) "lang" -> listLanguages opt "boot" -> do
+ Info.hs view
@@ -0,0 +1,107 @@+module Info where++import Control.Applicative hiding (empty)+import Control.Monad+import Data.Maybe+import GHC+import Outputable+import PprTyThing+import Types+import NameSet+import HscTypes+import Data.List+import Control.Exception++type Expression = String+type ModuleString = String++----------------------------------------------------------------++typeExpr :: Options -> ModuleString -> Expression -> FilePath -> IO String+typeExpr _ modstr expr file = (++ "\n") <$> typeOf file modstr expr++typeOf :: FilePath -> ModuleString-> Expression -> IO String+typeOf fileName modstr expr = withGHC $ valid `gcatch` invalid+ where+ valid = makeTypeOf LoadAllTargets+ invalid = constE invalid0+ invalid0 = makeTypeOf $ LoadDependenciesOf (mkModuleName modstr)+ makeTypeOf x = do+ initSession ["-w"]+ setTargetFile fileName+ loadWithLogger (\_ -> return ()) x+ ok <- setContextFromTarget+ if ok+ then pretty <$> exprType expr+ else return "Its type cannot be guessed"+ pretty = showSDocForUser neverQualify . pprTypeForUser False++----------------------------------------------------------------++infoExpr :: Options -> ModuleString -> Expression -> FilePath -> IO String+infoExpr _ modstr expr file = (++ "\n") <$> info file modstr expr++info :: FilePath -> ModuleString -> FilePath -> IO String+info fileName modstr expr = withGHC $ valid `gcatch` invalid+ where+ valid = makeInfo LoadAllTargets+ invalid = constE invalid0+ invalid0 = makeInfo $ LoadDependenciesOf (mkModuleName modstr)+ makeInfo x = do+ initSession ["-w"]+ setTargetFile fileName+ loadWithLogger (\_ -> return ()) x+ ok <- setContextFromTarget+ if ok+ then infoThing expr+ else return "Its info is not available"+ -- ghc/InteractiveUI.hs+ infoThing str = do+ names <- parseName str+ mb_stuffs <- mapM getInfo names+ let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)+ unqual <- getPrintUnqual+ return $ showSDocForUser unqual $ vcat (intersperse (text "") $ map (pprInfo False) filtered)++-- ghc/InteractiveUI.hs+filterOutChildren :: (a -> TyThing) -> [a] -> [a]+filterOutChildren get_thing xs+ = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]+ where+ implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]++pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc+pprInfo pefas (thing, fixity, insts)+ = pprTyThingInContextLoc pefas thing+ $$ show_fixity fixity+ $$ vcat (map pprInstance insts)+ where+ show_fixity fix+ | fix == defaultFixity = empty+ | otherwise = ppr fix <+> ppr (getName thing)++----------------------------------------------------------------++setContextFromTarget :: Ghc Bool+setContextFromTarget = do+ ms <- depanal [] False+ -- ms <- getModuleGraph -- this is the same+ top <- map ms_mod <$> filterM isTop ms+ {-+ top is a set of this module and your-defined modules.+ If this module has syntax errors, it cannot be specified.+ And if there is no your-defined modules, top is [].+ In this case, we cannot obtain the type of an expression, sigh.+ -}+ setContext top []+ return $ if top == [] then False else True+ where+ isTop ms = lookupMod `gcatch` returnFalse+ where+ lookupMod = lookupModule (ms_mod_name ms) Nothing >> return True+ returnFalse = constE $ return False++----------------------------------------------------------------++constE :: a -> (SomeException -> a)+constE func = \_ -> func
Lang.hs view
@@ -1,7 +1,13 @@+{-# LANGUAGE CPP #-}+ module Lang where import DynFlags import Types listLanguages :: Options -> IO String+#if __GLASGOW_HASKELL__ >= 700+listLanguages opt = return $ convert opt supportedLanguagesAndExtensions+#else listLanguages opt = return $ convert opt supportedLanguages+#endif
Types.hs view
@@ -1,19 +1,57 @@ module Types where +import Control.Monad+import DynFlags import Exception import GHC import GHC.Paths (libdir) +----------------------------------------------------------------+ data Options = Options { convert :: [String] -> String , hlintOpts :: [String] } -withGHC :: Ghc [String] -> IO [String]+withGHC :: (MonadPlus m) => Ghc (m a) -> IO (m a) withGHC body = ghandle ignore $ runGhc (Just libdir) body where- ignore :: SomeException -> IO [String]- ignore _ = return []+ ignore :: (MonadPlus m) => SomeException -> IO (m a)+ ignore _ = return mzero +----------------------------------------------------------------+ initSession0 :: Ghc [PackageId] initSession0 = getSessionDynFlags >>= setSessionDynFlags++initSession :: [String] -> Ghc [PackageId]+initSession cmdOpts = do+ dflags <- getSessionDynFlags+ let opts = map noLoc cmdOpts+ (dflags',_,_) <- parseDynamicFlags dflags opts+ setSessionDynFlags $ setFlags dflags'++----------------------------------------------------------------++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"++----------------------------------------------------------------++setTargetFile :: (GhcMonad m) => String -> m ()+setTargetFile file = do+ target <- guessTarget file Nothing+ setTargets [target]
elisp/Makefile view
@@ -1,4 +1,5 @@-SRCS = ghc.el ghc-func.el ghc-doc.el ghc-comp.el ghc-flymake.el ghc-command.el+SRCS = ghc.el ghc-func.el ghc-doc.el ghc-comp.el ghc-flymake.el \+ ghc-command.el ghc-info.el EMACS = emacs TEMPFILE = temp.el
elisp/ghc-comp.el view
@@ -157,9 +157,14 @@ (defun ghc-module-completion-p () (or (minibufferp)+ (let ((end (point)))+ (save-excursion+ (beginning-of-line)+ (and (looking-at "import ")+ (not (search-forward "(" end t))))) (save-excursion (beginning-of-line)- (looking-at "import "))))+ (looking-at " +module ")))) (defun ghc-select-completion-symbol () (cond
elisp/ghc-doc.el view
@@ -16,14 +16,18 @@ (let* ((mod0 (ghc-extract-module)) (mod (ghc-read-module-name mod0)) (pkg (ghc-resolve-package-name mod)))- (ghc-display-document pkg mod haskell-org)))+ (if (and pkg mod)+ (ghc-display-document pkg mod haskell-org)+ (message "No document found")))) (defun ghc-resolve-package-name (mod) (with-temp-buffer (call-process "ghc-pkg" nil t nil "find-module" "--simple-output" mod) (goto-char (point-min))- (when (looking-at "^\\([^ ]+\\)-[0-9]")- (match-string-no-properties 1))))+ (when (re-search-forward "\\([^ ]+\\)-\\([0-9]*\\(\\.[0-9]+\\)*\\)$" nil t)+ (ghc-make-pkg-ver+ :pkg (match-string-no-properties 1)+ :ver (match-string-no-properties 2))))) (defun ghc-resolve-document-path (pkg) (with-temp-buffer@@ -36,15 +40,21 @@ (defconst ghc-doc-local-format "file://%s/%s.html") (defconst ghc-doc-hackage-format- "http://hackage.haskell.org/packages/archive/%s/latest/doc/html/%s.html")+ "http://hackage.haskell.org/packages/archive/%s/%s/doc/html/%s.html") -(defun ghc-display-document (pkg mod haskell-org)- (when (and pkg mod)+(ghc-defstruct pkg-ver pkg ver)++(defun ghc-display-document (pkg-ver mod haskell-org)+ (when (and pkg-ver mod) (let* ((mod- (ghc-replace-character mod ?. ?-))- (url (if haskell-org- (format ghc-doc-hackage-format pkg mod-)- (format ghc-doc-local-format- (ghc-resolve-document-path pkg) mod-))))+ (pkg (ghc-pkg-ver-get-pkg pkg-ver))+ (ver (ghc-pkg-ver-get-ver pkg-ver))+ (pkg-with-ver (format "%s-%s" pkg ver))+ (path (ghc-resolve-document-path pkg-with-ver))+ (local (format ghc-doc-local-format path mod-))+ (remote (format ghc-doc-hackage-format pkg ver mod-))+ (file (format "%s/%s.html" path mod-))+ (url (if (or haskell-org (not (file-exists-p file))) remote local))) (browse-url url)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
elisp/ghc-flymake.el view
@@ -79,10 +79,10 @@ (dolist (data (ghc-flymake-err-list)) (save-excursion (cond- ((string-match "Inferred type: \\([^:]+ :: \\)\\(forall [^.]+\\. \\)?\\([^\0]*\\)" data)+ ((string-match "Inferred type: \\([^:]+ :: \\)\\(forall [^.]+\\.\\( \\|\0 +\\)\\)?\\([^\0]*\\)" data) (beginning-of-line) (insert (match-string 1 data)- (replace-regexp-in-string "\\[Char\\]" "String" (match-string 3 data))+ (replace-regexp-in-string "\\[Char\\]" "String" (match-string 4 data)) "\n")) ((string-match "lacks an accompanying binding" data) (beginning-of-line)
elisp/ghc-func.el view
@@ -90,4 +90,49 @@ (defconst ghc-null 0) (defconst ghc-newline 10) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defun ghc-keyword-number-pair (spec)+ (let ((len (length spec)) key ret)+ (dotimes (i len (nreverse ret))+ (setq key (intern (concat ":" (symbol-name (car spec)))))+ (setq ret (cons (cons key i) ret))+ (setq spec (cdr spec)))))++(defmacro ghc-defstruct (type &rest spec)+ `(progn+ (ghc-defstruct-constructor ,type ,@spec)+ (ghc-defstruct-s/getter ,type ,@spec)))++(defmacro ghc-defstruct-constructor (type &rest spec)+ `(defun ,(intern (concat "ghc-make-" (symbol-name type))) (&rest args)+ (let* ((alist (quote ,(ghc-keyword-number-pair spec)))+ (struct (make-list (length alist) nil))+ key val key-num)+ (while args ;; cannot use dolist+ (setq key (car args))+ (setq args (cdr args))+ (setq val (car args))+ (setq args (cdr args))+ (unless (keywordp key)+ (error "'%s' is not a keyword" key))+ (setq key-num (assoc key alist))+ (if key-num+ (setcar (nthcdr (cdr key-num) struct) val)+ (error "'%s' is unknown" key)))+ struct)))++(defmacro ghc-defstruct-s/getter (type &rest spec)+ `(let* ((type-name (symbol-name ',type))+ (keys ',spec)+ (len (length keys))+ member-name setter getter)+ (dotimes (i len)+ (setq member-name (symbol-name (car keys)))+ (setq setter (intern (format "ghc-%s-set-%s" type-name member-name)))+ (fset setter (list 'lambda '(struct value) (list 'setcar (list 'nthcdr i 'struct) 'value) 'struct))+ (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)))))+ (provide 'ghc-func)
+ elisp/ghc-info.el view
@@ -0,0 +1,66 @@+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;;;+;;; ghc-info.el+;;;++;; Author: Kazu Yamamoto <Kazu@Mew.org>+;; Created: Nov 15, 2010++;;; Code:++(require 'ghc-func)++(defun ghc-show-type (&optional ask)+ (interactive "P")+ (if (not (ghc-which ghc-module-command))+ (message "%s not found" ghc-module-command)+ (let ((modname (ghc-find-module-name)))+ (if (not modname)+ (message "module should be specified")+ (ghc-show-type0 ask modname)))))++(defun ghc-show-type0 (ask modname)+ (let* ((expr0 (thing-at-point 'symbol))+ (expr (if ask (ghc-read-expression expr0) expr0))+ (cdir default-directory)+ (file (buffer-name)))+ (with-temp-buffer+ (cd cdir)+ (call-process ghc-module-command nil t nil "type" file modname expr)+ (message (buffer-substring (point-min) (1- (point-max)))))))++(defun ghc-show-info (&optional ask)+ (interactive "P")+ (if (not (ghc-which ghc-module-command))+ (message "%s not found" ghc-module-command)+ (let ((modname (ghc-find-module-name)))+ (if (not modname)+ (message "module should be specified")+ (ghc-show-info0 ask modname)))))++(defun ghc-show-info0 (ask modname)+ (let* ((expr0 (thing-at-point 'symbol))+ (expr (if ask (ghc-read-expression expr0) expr0))+ (cdir default-directory)+ (file (buffer-name))+ (buf (get-buffer-create ghc-error-buffer-name)))+ (with-current-buffer buf+ (erase-buffer)+ (insert+ (with-temp-buffer+ (cd cdir)+ (call-process ghc-module-command nil t nil "info" file modname expr)+ (buffer-substring (point-min) (1- (point-max))))))+ (display-buffer buf)))++(defun ghc-read-expression (default)+ (let ((prompt (format "Expression (%s): " default)))+ (read-string prompt default nil)))++(defun ghc-find-module-name ()+ (save-excursion+ (goto-char (point-min))+ (if (re-search-forward "^module[ ]+\\([^ ]+\\)" nil t)+ (match-string-no-properties 1))))++(provide 'ghc-info)
elisp/ghc.el view
@@ -16,13 +16,14 @@ ;;; Code: -(defconst ghc-version "0.4.4")+(defconst ghc-version "0.5.0") ;; (eval-when-compile ;; (require 'haskell-mode)) (require 'ghc-comp) (require 'ghc-doc)+(require 'ghc-info) (require 'ghc-flymake) (require 'ghc-command) (require 'dabbrev)@@ -40,6 +41,8 @@ (defvar ghc-help-key "\e?") (defvar ghc-insert-key "\et") (defvar ghc-sort-key "\es")+(defvar ghc-type-key "\C-c\C-t")+(defvar ghc-info-key "\C-c\C-i") (defvar ghc-check-key "\C-x\C-s") (defvar ghc-toggle-key "\C-c\C-c") @@ -55,6 +58,8 @@ (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-type-key 'ghc-show-type)+ (define-key haskell-mode-map ghc-info-key 'ghc-show-info) (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)@@ -67,7 +72,6 @@ (setq ghc-initialized t))) (defun ghc-abbrev-init ()- (make-local-variable 'dabbrev-case-fold-search)- (setq dabbrev-case-fold-search nil))+ (set (make-local-variable 'dabbrev-case-fold-search) nil)) (provide 'ghc)
ghc-mod.cabal view
@@ -1,5 +1,5 @@ Name: ghc-mod-Version: 0.4.4+Version: 0.5.1 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> License: BSD3@@ -20,10 +20,10 @@ Build-Type: Simple Data-Dir: elisp Data-Files: Makefile ghc.el ghc-func.el ghc-doc.el ghc-comp.el- ghc-flymake.el ghc-command.el+ ghc-flymake.el ghc-command.el ghc-info.el Executable ghc-mod Main-Is: GHCMod.hs- Other-Modules: List Browse Check Lang Lint Types+ Other-Modules: List Browse Check Info Lang Lint Types if impl(ghc >= 6.12) GHC-Options: -Wall -fno-warn-unused-do-bind else