diff --git a/Check.hs b/Check.hs --- a/Check.hs +++ b/Check.hs @@ -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 diff --git a/GHCMod.hs b/GHCMod.hs --- a/GHCMod.hs +++ b/GHCMod.hs @@ -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 [ ...]\n" ++ "\t ghc-mod check \n" + ++ "\t ghc-mod type \n" + ++ "\t ghc-mod info \n" ++ "\t ghc-mod [-h opt] lint \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 diff --git a/Info.hs b/Info.hs new file mode 100644 --- /dev/null +++ b/Info.hs @@ -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 diff --git a/Lang.hs b/Lang.hs --- a/Lang.hs +++ b/Lang.hs @@ -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 diff --git a/Types.hs b/Types.hs --- a/Types.hs +++ b/Types.hs @@ -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] diff --git a/elisp/Makefile b/elisp/Makefile --- a/elisp/Makefile +++ b/elisp/Makefile @@ -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 diff --git a/elisp/ghc-comp.el b/elisp/ghc-comp.el --- a/elisp/ghc-comp.el +++ b/elisp/ghc-comp.el @@ -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 diff --git a/elisp/ghc-doc.el b/elisp/ghc-doc.el --- a/elisp/ghc-doc.el +++ b/elisp/ghc-doc.el @@ -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)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/elisp/ghc-flymake.el b/elisp/ghc-flymake.el --- a/elisp/ghc-flymake.el +++ b/elisp/ghc-flymake.el @@ -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) diff --git a/elisp/ghc-func.el b/elisp/ghc-func.el --- a/elisp/ghc-func.el +++ b/elisp/ghc-func.el @@ -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) diff --git a/elisp/ghc-info.el b/elisp/ghc-info.el new file mode 100644 --- /dev/null +++ b/elisp/ghc-info.el @@ -0,0 +1,66 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; ghc-info.el +;;; + +;; Author: Kazu Yamamoto +;; 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) diff --git a/elisp/ghc.el b/elisp/ghc.el --- a/elisp/ghc.el +++ b/elisp/ghc.el @@ -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) 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.4.4 +Version: 0.5.1 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto 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