diff --git a/ErrMsg.hs b/ErrMsg.hs --- a/ErrMsg.hs +++ b/ErrMsg.hs @@ -57,10 +57,9 @@ ppMsg :: SrcSpan -> Message -> PprStyle -> String #if __GLASGOW_HASKELL__ >= 702 -ppMsg (UnhelpfulSpan _) _ _ = undefined ppMsg (RealSrcSpan src) msg stl #else -ppMsg src msg stl +ppMsg src msg stl | isGoodSrcSpan src #endif = file ++ ":" ++ line ++ ":" ++ col ++ ":" ++ cts ++ "\0" where @@ -68,12 +67,13 @@ line = show (srcSpanStartLine src) col = show (srcSpanStartCol src) cts = showMsg msg stl +ppMsg _ _ _ = "ghc-mod:0:0:Probably mutual module import occurred\0" ---------------------------------------------------------------- showMsg :: SDoc -> PprStyle -> String #if __GLASGOW_HASKELL__ >= 702 -showMsg d stl = map toNull $ renderWithStyle d stl +showMsg d stl = map toNull . renderWithStyle d $ stl #else showMsg d stl = map toNull . Pretty.showDocWith PageMode $ d stl #endif diff --git a/GHCMod.hs b/GHCMod.hs --- a/GHCMod.hs +++ b/GHCMod.hs @@ -35,8 +35,8 @@ ++ "\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 type" ++ ghcOptHelp ++ " \n" ++ "\t ghc-mod lint [-h opt] \n" ++ "\t ghc-mod boot\n" ++ "\t ghc-mod help\n" @@ -91,7 +91,7 @@ "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) "lint" -> withFile (lintSyntax opt) (safelist cmdArg 1) "lang" -> listLanguages opt diff --git a/Info.hs b/Info.hs --- a/Info.hs +++ b/Info.hs @@ -1,13 +1,17 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, Rank2Types, TupleSections #-} -module Info where +module Info (infoExpr, typeExpr) where import Cabal import Control.Applicative hiding (empty) import Control.Exception import Control.Monad +import CoreUtils +import Data.Generics as G import Data.List import Data.Maybe +import Data.Ord as O +import Desugar import GHC import HscTypes import NameSet @@ -15,6 +19,7 @@ import PprTyThing import StringBuffer import System.Time +import TcRnTypes import Types #if __GLASGOW_HASKELL__ >= 702 @@ -26,17 +31,6 @@ ---------------------------------------------------------------- -typeExpr :: Options -> ModuleString -> Expression -> FilePath -> IO String -typeExpr opt modstr expr file = (++ "\n") <$> 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 <$> exprType expr - pretty = showSDocForUser neverQualify . pprTypeForUser False - ----------------------------------------------------------------- - infoExpr :: Options -> ModuleString -> Expression -> FilePath -> IO String infoExpr opt modstr expr file = (++ "\n") <$> info opt file modstr expr @@ -46,6 +40,77 @@ exprToInfo = infoThing expr ---------------------------------------------------------------- + +typeExpr :: Options -> ModuleString -> Int -> Int -> FilePath -> IO String +typeExpr opt modstr lineNo colNo file = (++ "\n") <$> Info.typeOf opt file modstr lineNo colNo + +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 + p <- parseModule modSum + tcm <- typecheckModule p + es <- liftIO $ findExpr tcm lineNo colNo + ts <- catMaybes <$> mapM (getType tcm) es + let ts' = sortBy (\a b -> fst a `cmp` fst b) ts + return $ tolisp $ map (\(loc, e) -> ("(" ++ l loc ++ " " ++ show (pretty e) ++ ")")) ts' + + l :: SrcSpan -> String +#if __GLASGOW_HASKELL__ >= 702 + l (RealSrcSpan spn) +#else + l spn | isGoodSrcSpan spn +#endif + = unwords . map show $ + [ srcSpanStartLine spn, srcSpanStartCol spn + , srcSpanEndLine spn, srcSpanEndCol spn ] + l _ = "0 0 0 0" + + cmp a b + | a `isSubspanOf` b = O.LT + | b `isSubspanOf` a = O.GT + | otherwise = O.EQ + + tolisp ls = "(" ++ unwords ls ++ ")" + +findExpr :: TypecheckedModule -> Int -> Int -> IO [LHsExpr Id] +findExpr tcm line col = do + let src = tm_typechecked_source tcm + ssrc <- everywhereM' sanitize src + return $ listify f ssrc + where + -- It is for GHC's panic! + sanitize :: Data a => a -> IO a + sanitize x = do + mret <- try (evaluate x) + return $ case mret of + Left (SomeException _) -> G.empty + Right ret -> ret + + f :: LHsExpr Id -> Bool + f (L spn _) = spn `spans` (line, col) + +-- | Monadic variation on everywhere' +everywhereM' :: Monad m => GenericM m -> GenericM m +everywhereM' f x = do + x' <- f x + gmapM (everywhereM' f) x' + +getType :: GhcMonad m => TypecheckedModule -> LHsExpr Id -> m (Maybe (SrcSpan, Type)) +getType tcm e = do + hs_env <- getSession + (_, mbe) <- liftIO $ deSugarExpr hs_env modu rn_env ty_env e + return $ (getLoc e, ) <$> CoreUtils.exprType <$> mbe + where + modu = ms_mod $ pm_mod_summary $ tm_parsed_module tcm + 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 infoThing :: String -> Ghc String @@ -62,14 +127,14 @@ where implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)] -pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [Instance]) -> SDoc +pprInfo :: PrintExplicitForalls -> (TyThing, GHC.Fixity, [Instance]) -> SDoc pprInfo pefas (thing, fixity, insts) = pprTyThingInContextLoc pefas thing $$ show_fixity fixity $$ vcat (map pprInstance insts) where show_fixity fix - | fix == defaultFixity = empty + | fix == defaultFixity = Outputable.empty | otherwise = ppr fix <+> ppr (getName thing) ---------------------------------------------------------------- diff --git a/elisp/Makefile b/elisp/Makefile --- a/elisp/Makefile +++ b/elisp/Makefile @@ -1,12 +1,17 @@ SRCS = ghc.el ghc-func.el ghc-doc.el ghc-comp.el ghc-flymake.el \ ghc-command.el ghc-info.el ghc-ins-mod.el EMACS = emacs +DETECT = xemacs TEMPFILE = temp.el all: $(TEMPFILE) ghc.el $(EMACS) -batch -q -no-site-file -l ./$(TEMPFILE) -f ghc-compile rm -f $(TEMPFILE) + +detect: $(TEMPFILE) ghc.el + $(EMACS) -batch -q -no-site-file -l ./$(TEMPFILE) -f ghc-compile + rm -f $(DETECT) $(TEMPFILE): @echo '(setq load-path (cons "." load-path))' >> $(TEMPFILE) diff --git a/elisp/ghc-info.el b/elisp/ghc-info.el --- 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)) @@ -54,6 +34,104 @@ `(,@(ghc-make-ghc-options) "info" ,file ,modname ,expr)) (buffer-substring (point-min) (1- (point-max)))))) (display-buffer buf))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; type +;;; + +(defvar ghc-type-overlay nil) + +(make-variable-buffer-local 'ghc-type-overlay) + +(defun ghc-type-set-ix (n) + (overlay-put ghc-type-overlay 'ix n)) + +(defun ghc-type-get-ix () + (overlay-get ghc-type-overlay 'ix)) + +(defun ghc-type-set-point (pos) + (overlay-put ghc-type-overlay 'pos pos)) + +(defun ghc-type-get-point () + (overlay-get ghc-type-overlay 'pos)) + +(defun ghc-type-set-types (types) + (overlay-put ghc-type-overlay 'types types)) + +(defun ghc-type-get-types () + (overlay-get ghc-type-overlay 'types)) + +(ghc-defstruct tinfo beg-line beg-column end-line end-column info) + +(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-type-deleve-overlay after-change-functions))) + +(defun ghc-type-deleve-overlay (beg end len) + (when (overlayp ghc-type-overlay) + (delete-overlay ghc-type-overlay))) + +(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-type0 modname))))) + +(defun ghc-show-type0 (modname) + (let* ((buf (current-buffer)) + (tinfos (ghc-type-get-tinfos modname))) + (if (null tinfos) + (message "Cannot guess type") + (let* ((tinfo (nth (ghc-type-get-ix) tinfos)) + (type (ghc-tinfo-get-info tinfo)) + (beg-line (ghc-tinfo-get-beg-line tinfo)) + (beg-column (ghc-tinfo-get-beg-column tinfo)) + (end-line (ghc-tinfo-get-end-line tinfo)) + (end-column (ghc-tinfo-get-end-column tinfo)) + (left (ghc-get-pos buf beg-line beg-column)) + (right (ghc-get-pos buf end-line end-column))) + (move-overlay ghc-type-overlay (- left 1) (- right 1) buf) + (message type))))) + +(defun ghc-type-get-tinfos (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-type-obtain-tinfos modname)) + (ghc-type-set-point (point)) + (ghc-type-set-ix 0)) + (ghc-type-get-types)) + +(defun ghc-type-obtain-tinfos (modname) + (let* ((ln (int-to-string (line-number-at-pos))) + (cn (int-to-string (current-column))) + (cdir default-directory) + (file (buffer-name))) + (ghc-read-lisp + (lambda () + (cd cdir) + (apply 'call-process ghc-module-command nil t nil + `(,@(ghc-make-ghc-options) "type" ,file ,modname ,ln ,cn)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Misc +;;; + +(defun ghc-get-pos (buf line col) + (save-excursion + (set-buffer buf) + (goto-line line) + (forward-char col) + (point))) (defun ghc-read-expression (default) (if default diff --git a/elisp/ghc.el b/elisp/ghc.el --- a/elisp/ghc.el +++ b/elisp/ghc.el @@ -63,6 +63,7 @@ (defun ghc-init () (ghc-abbrev-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) 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: 1.10.2 +Version: 1.10.3 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -28,7 +28,7 @@ GHC-Options: -Wall -fno-warn-unused-do-bind else GHC-Options: -Wall - Build-Depends: base >= 4.0 && < 5, ghc, ghc-paths, transformers, + Build-Depends: base >= 4.0 && < 5, ghc, ghc-paths, transformers, syb, process, directory, filepath, old-time, hlint >= 1.7.1, regex-posix, Cabal Source-Repository head