ghc-mod 1.10.2 → 1.10.3
raw patch · 7 files changed
+191/−42 lines, 7 filesdep +syb
Dependencies added: syb
Files
- ErrMsg.hs +3/−3
- GHCMod.hs +2/−2
- Info.hs +80/−15
- elisp/Makefile +5/−0
- elisp/ghc-info.el +98/−20
- elisp/ghc.el +1/−0
- ghc-mod.cabal +2/−2
ErrMsg.hs view
@@ -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
GHCMod.hs view
@@ -35,8 +35,8 @@ ++ "\t ghc-mod flag [-l]\n" ++ "\t ghc-mod browse" ++ ghcOptHelp ++ "[-l] [-o] <module> [<module> ...]\n" ++ "\t ghc-mod check" ++ ghcOptHelp ++ "<HaskellFile>\n"- ++ "\t ghc-mod type" ++ ghcOptHelp ++ "<HaskellFile> <module> <expression>\n" ++ "\t ghc-mod info" ++ ghcOptHelp ++ "<HaskellFile> <module> <expression>\n"+ ++ "\t ghc-mod type" ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n" ++ "\t ghc-mod lint [-h opt] <HaskellFile>\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
Info.hs view
@@ -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) ----------------------------------------------------------------
elisp/Makefile view
@@ -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)
elisp/ghc-info.el view
@@ -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
elisp/ghc.el view
@@ -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)
ghc-mod.cabal view
@@ -1,5 +1,5 @@ Name: ghc-mod-Version: 1.10.2+Version: 1.10.3 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> 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