From 11f1341fe5d74434a120880f6572e9b3e8d5df09 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Mon, 15 Nov 2010 14:46:59 +0900 Subject: [PATCH] defining "info" for "ESC i". --- GHCMod.hs | 2 ++ Info.hs | 58 +++++++++++++++++++++++++++++++++++++++++++---- elisp/ghc-info.el | 29 ++++++++++++++++++++---- elisp/ghc.el | 4 +++- 4 files changed, 83 insertions(+), 10 deletions(-) diff --git a/GHCMod.hs b/GHCMod.hs index f658a74..8f32f15 100644 --- a/GHCMod.hs +++ b/GHCMod.hs @@ -28,6 +28,7 @@ usage = "ghc-mod version 0.5.0\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" @@ -75,6 +76,7 @@ main = flip catches handlers $ do "list" -> listModules opt "check" -> withFile (checkSyntax opt) (safelist cmdArg 1) "type" -> withFile (typeExpr opt (safelist cmdArg 2)) (safelist cmdArg 1) + "info" -> withFile (infoExpr opt (safelist cmdArg 2)) (safelist cmdArg 1) "lint" -> withFile (lintSyntax opt) (safelist cmdArg 1) "lang" -> listLanguages opt "boot" -> do diff --git a/Info.hs b/Info.hs index e7a0970..f67aaf8 100644 --- a/Info.hs +++ b/Info.hs @@ -1,10 +1,16 @@ module Info where -import Control.Applicative +import Control.Applicative hiding (empty) +import Data.Maybe import GHC import Outputable import PprTyThing import Types +import NameSet +import HscTypes +import Data.List + +---------------------------------------------------------------- typeExpr :: Options -> String -> String -> IO String typeExpr _ expr file = (++ "\n") <$> typeOf file expr @@ -17,8 +23,50 @@ typeOf fileName expr = withGHC $ do setContextFromTarget pretty <$> exprType expr where - setContextFromTarget = do - ms <- depanal [] False - mdl <- findModule (ms_mod_name (head ms)) Nothing - setContext [mdl] [] pretty = showSDocForUser neverQualify . pprTypeForUser False + +---------------------------------------------------------------- + +infoExpr :: Options -> String -> String -> IO String +infoExpr _ expr file = (++ "\n") <$> info file expr + +info :: String -> String -> IO String +info fileName expr = withGHC $ do + initSession [] + setTargetFile fileName + load LoadAllTargets + setContextFromTarget + infoThing expr + where + -- 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 () +setContextFromTarget = do + ms <- depanal [] False + mdl <- findModule (ms_mod_name (head ms)) Nothing + setContext [mdl] [] diff --git a/elisp/ghc-info.el b/elisp/ghc-info.el index 73f2b94..8dac464 100644 --- a/elisp/ghc-info.el +++ b/elisp/ghc-info.el @@ -10,14 +10,35 @@ (require 'ghc-func) -(defun ghc-show-type () - (interactive) +(defun ghc-show-type (&optional ask) + (interactive "P") (if (not (ghc-which ghc-module-command)) (message "%s not found" ghc-module-command) - (let ((expr (thing-at-point 'symbol)) - (file (buffer-name))) + (let* ((expr0 (thing-at-point 'symbol)) + (expr (if ask (ghc-read-expression expr0) expr0)) + (file (buffer-name))) (with-temp-buffer (call-process ghc-module-command nil t nil "type" file 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* ((expr0 (thing-at-point 'symbol)) + (expr (if ask (ghc-read-expression expr0) expr0)) + (file (buffer-name)) + (buf (get-buffer-create ghc-error-buffer-name))) + (with-current-buffer buf + (erase-buffer) + (insert + (with-temp-buffer + (call-process ghc-module-command nil t nil "info" file 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))) + (provide 'ghc-info) diff --git a/elisp/ghc.el b/elisp/ghc.el index 6a74e1f..c1f7c0f 100644 --- a/elisp/ghc.el +++ b/elisp/ghc.el @@ -41,7 +41,8 @@ (defvar ghc-help-key "\e?") (defvar ghc-insert-key "\et") (defvar ghc-sort-key "\es") -(defvar ghc-type-key "\e\C-t") +(defvar ghc-type-key "\ek") +(defvar ghc-info-key "\ei") (defvar ghc-check-key "\C-x\C-s") (defvar ghc-toggle-key "\C-c\C-c") @@ -58,6 +59,7 @@ (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)