diff --git a/GHCMod.hs b/GHCMod.hs index e134720..9e246b9 100644 --- a/GHCMod.hs +++ b/GHCMod.hs @@ -35,9 +35,8 @@ usage = "ghc-mod version " ++ showVersion version ++ "\n" ++ "\t ghc-mod flag [-l]\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 annot" ++ ghcOptHelp ++ " \n" + ++ "\t ghc-mod type" ++ ghcOptHelp ++ " \n" ++ "\t ghc-mod lint [-h opt] \n" ++ "\t ghc-mod boot\n" ++ "\t ghc-mod help\n" @@ -92,9 +91,8 @@ main = flip catches handlers $ do "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) + "type" -> withFile (typeExpr opt (safelist cmdArg 2) (read $ safelist cmdArg 3) (read $ safelist cmdArg 4)) (safelist cmdArg 1) "info" -> withFile (infoExpr opt (safelist cmdArg 2) (safelist cmdArg 3)) (safelist cmdArg 1) - "annot" -> withFile (annotExpr opt (safelist cmdArg 2) (read $ safelist cmdArg 3) (read $ safelist cmdArg 4)) (safelist cmdArg 1) "lint" -> withFile (lintSyntax opt) (safelist cmdArg 1) "lang" -> listLanguages opt "flag" -> listFlags opt diff --git a/Info.hs b/Info.hs index c6c39f8..d40aff9 100644 --- a/Info.hs +++ b/Info.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP, Rank2Types, TupleSections #-} -module Info where +module Info (infoExpr, typeExpr) where import Cabal import Control.Applicative hiding (empty) @@ -31,19 +31,6 @@ type ModuleString = String ---------------------------------------------------------------- -typeExpr :: Options -> ModuleString -> Expression -> FilePath -> IO String -typeExpr opt modstr expr file = (++ "\n") <$> Info.typeOf opt file modstr expr - -typeOf :: Options -> FilePath -> ModuleString -> Expression -> IO String -typeOf opt fileName modstr expr = inModuleContext opt fileName modstr exprToType - where - exprToType = pretty <$> GHC.exprType expr - -pretty :: Type -> String -pretty = showSDocForUser neverQualify . pprTypeForUser False - ----------------------------------------------------------------- - infoExpr :: Options -> ModuleString -> Expression -> FilePath -> IO String infoExpr opt modstr expr file = (++ "\n") <$> info opt file modstr expr @@ -54,11 +41,11 @@ info opt fileName modstr expr = inModuleContext opt fileName modstr exprToInfo ---------------------------------------------------------------- -annotExpr :: Options -> ModuleString -> Int -> Int -> FilePath -> IO String -annotExpr opt modstr lineNo colNo file = (++ "\n") <$> annotOf opt file modstr lineNo colNo +typeExpr :: Options -> ModuleString -> Int -> Int -> FilePath -> IO String +typeExpr opt modstr lineNo colNo file = (++ "\n") <$> Info.typeOf opt file modstr lineNo colNo -annotOf :: Options -> FilePath -> ModuleString -> Int -> Int -> IO String -annotOf opt fileName modstr lineNo colNo = inModuleContext opt fileName modstr exprToType +typeOf :: Options -> FilePath -> ModuleString -> Int -> Int -> IO String +typeOf opt fileName modstr lineNo colNo = inModuleContext opt fileName modstr exprToType where exprToType = do modSum <- getModSummary $ mkModuleName modstr @@ -120,6 +107,9 @@ getType tcm e = do rn_env = tcg_rdr_env $ fst $ tm_internals_ tcm ty_env = tcg_type_env $ fst $ tm_internals_ tcm +pretty :: Type -> String +pretty = showSDocForUser neverQualify . pprTypeForUser False + ---------------------------------------------------------------- -- from ghc/InteractiveUI.hs diff --git a/elisp/ghc-info.el b/elisp/ghc-info.el index a516701..e5551d7 100644 --- a/elisp/ghc-info.el +++ b/elisp/ghc-info.el @@ -10,26 +10,6 @@ (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 (ghc-things-at-point)) - (expr (if ask (ghc-read-expression expr0) expr0)) - (cdir default-directory) - (file (buffer-name))) - (with-temp-buffer - (cd cdir) - (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) (interactive "P") (if (not (ghc-which ghc-module-command)) @@ -57,73 +37,73 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; annot +;;; type ;;; -(defvar ghc-annot-overlay nil) +(defvar ghc-type-overlay nil) -(make-variable-buffer-local 'ghc-annot-overlay) +(make-variable-buffer-local 'ghc-type-overlay) -(defun ghc-annot-set-ix (n) - (overlay-put ghc-annot-overlay 'ix n)) +(defun ghc-type-set-ix (n) + (overlay-put ghc-type-overlay 'ix n)) -(defun ghc-annot-get-ix () - (overlay-get ghc-annot-overlay 'ix)) +(defun ghc-type-get-ix () + (overlay-get ghc-type-overlay 'ix)) -(defun ghc-annot-set-point (pos) - (overlay-put ghc-annot-overlay 'pos pos)) +(defun ghc-type-set-point (pos) + (overlay-put ghc-type-overlay 'pos pos)) -(defun ghc-annot-get-point () - (overlay-get ghc-annot-overlay 'pos)) +(defun ghc-type-get-point () + (overlay-get ghc-type-overlay 'pos)) -(defun ghc-annot-set-types (types) - (overlay-put ghc-annot-overlay 'types types)) +(defun ghc-type-set-types (types) + (overlay-put ghc-type-overlay 'types types)) -(defun ghc-annot-get-types () - (overlay-get ghc-annot-overlay 'types)) +(defun ghc-type-get-types () + (overlay-get ghc-type-overlay 'types)) -(defun ghc-annot-init () - (setq ghc-annot-overlay (make-overlay 0 0)) - (overlay-put ghc-annot-overlay 'face 'region) - (ghc-annot-set-ix 0) - (ghc-annot-set-point 0) +(defun ghc-type-init () + (setq ghc-type-overlay (make-overlay 0 0)) + (overlay-put ghc-type-overlay 'face 'region) + (ghc-type-set-ix 0) + (ghc-type-set-point 0) (setq after-change-functions - (cons 'ghc-delete-annot-ovl after-change-functions))) + (cons 'ghc-delete-type-ovl after-change-functions))) -(defun ghc-delete-annot-ovl (beg end len) - (when (overlayp ghc-annot-overlay) - (delete-overlay ghc-annot-overlay))) +(defun ghc-delete-type-ovl (beg end len) + (when (overlayp ghc-type-overlay) + (delete-overlay ghc-type-overlay))) -(defun ghc-show-annot () +(defun ghc-show-type () (interactive) (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-annot0 modname))))) + (ghc-show-type0 modname))))) -(defun ghc-show-annot0 (modname) +(defun ghc-show-type0 (modname) (let* ((buf (current-buffer)) - (types (ghc-get-annot modname)) - (tinfo (nth (ghc-annot-get-ix) types)) + (types (ghc-get-type modname)) + (tinfo (nth (ghc-type-get-ix) types)) (pos (nth 0 tinfo)) (type (nth 1 tinfo)) (left (ghc-get-pos buf (nth 0 pos) (nth 1 pos))) (right (ghc-get-pos buf (nth 2 pos) (nth 3 pos)))) - (move-overlay ghc-annot-overlay (- left 1) (- right 1) buf) + (move-overlay ghc-type-overlay (- left 1) (- right 1) buf) (message type))) -(defun ghc-get-annot (modname) - (if (= (ghc-annot-get-point) (point)) - (ghc-annot-set-ix - (mod (1+ (ghc-annot-get-ix)) (length (ghc-annot-get-types)))) - (ghc-annot-set-types (ghc-call-annot modname)) - (ghc-annot-set-point (point)) - (ghc-annot-set-ix 0)) - (ghc-annot-get-types)) +(defun ghc-get-type (modname) + (if (= (ghc-type-get-point) (point)) + (ghc-type-set-ix + (mod (1+ (ghc-type-get-ix)) (length (ghc-type-get-types)))) + (ghc-type-set-types (ghc-call-type modname)) + (ghc-type-set-point (point)) + (ghc-type-set-ix 0)) + (ghc-type-get-types)) -(defun ghc-call-annot (modname) +(defun ghc-call-type (modname) (let* ((ln (int-to-string (line-number-at-pos))) (cn (int-to-string (current-column))) (cdir default-directory) @@ -132,7 +112,7 @@ (lambda () (cd cdir) (apply 'call-process ghc-module-command nil t nil - `(,@(ghc-make-ghc-options) "annot" ,file ,modname ,ln ,cn)))))) + `(,@(ghc-make-ghc-options) "type" ,file ,modname ,ln ,cn)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; diff --git a/elisp/ghc.el b/elisp/ghc.el index 995f15e..27bcb14 100644 --- a/elisp/ghc.el +++ b/elisp/ghc.el @@ -49,7 +49,6 @@ (defvar ghc-sort-key "\es") (defvar ghc-type-key "\C-c\C-t") (defvar ghc-info-key "\C-c\C-i") -(defvar ghc-annot-key "\C-c\C-a") (defvar ghc-check-key "\C-x\C-s") (defvar ghc-toggle-key "\C-c\C-c") (defvar ghc-module-key "\C-c\C-m") @@ -64,13 +63,12 @@ (defun ghc-init () (ghc-abbrev-init) - (ghc-annot-init) + (ghc-type-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-type-key 'ghc-show-type) (define-key haskell-mode-map ghc-info-key 'ghc-show-info) - (define-key haskell-mode-map ghc-annot-key 'ghc-show-annot) (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)