diff --git a/GHCMod.hs b/GHCMod.hs index 14061f8..e134720 100644 --- a/GHCMod.hs +++ b/GHCMod.hs @@ -37,6 +37,7 @@ usage = "ghc-mod version " ++ showVersion version ++ "\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 lint [-h opt] \n" ++ "\t ghc-mod boot\n" ++ "\t ghc-mod help\n" @@ -93,6 +94,7 @@ main = flip catches handlers $ do "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) + "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 dd9f550..b96f586 100644 --- a/Info.hs +++ b/Info.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, Rank2Types, TupleSections #-} module Info where @@ -6,8 +6,12 @@ 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 Outputable import PprTyThing import StringBuffer import System.Time +import TcRnTypes import Types #if __GLASGOW_HASKELL__ >= 702 @@ -27,13 +32,15 @@ type ModuleString = String ---------------------------------------------------------------- typeExpr :: Options -> ModuleString -> Expression -> FilePath -> IO String -typeExpr opt modstr expr file = (++ "\n") <$> typeOf opt file modstr expr +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 <$> exprType expr - pretty = showSDocForUser neverQualify . pprTypeForUser False + exprToType = pretty <$> GHC.exprType expr + +pretty :: Type -> String +pretty = showSDocForUser neverQualify . pprTypeForUser False ---------------------------------------------------------------- @@ -45,6 +52,69 @@ info opt fileName modstr expr = inModuleContext opt fileName modstr exprToInfo where exprToInfo = infoThing expr +---------------------------------------------------------------- + +annotExpr :: Options -> ModuleString -> Int -> Int -> FilePath -> IO String +annotExpr opt modstr lineNo colNo file = (++ "\n") <$> annotOf opt file modstr lineNo colNo + +annotOf :: Options -> FilePath -> ModuleString -> Int -> Int -> IO String +annotOf 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 + l (RealSrcSpan spn) = ("("++) . (++")") . 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 + ---------------------------------------------------------------- -- from ghc/InteractiveUI.hs @@ -62,14 +132,14 @@ filterOutChildren get_thing xs 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/ghc-info.el b/elisp/ghc-info.el index 4fbefbf..af4172d 100644 --- a/elisp/ghc-info.el +++ b/elisp/ghc-info.el @@ -55,6 +55,61 @@ (buffer-substring (point-min) (1- (point-max)))))) (display-buffer buf))) +(defun ghc-show-annot (&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-annot0 ask modname))))) + +(defvar *annot-point* 0) +(defvar *annot-ix* 0) +(defvar *annot-ovl* (make-overlay 0 0)) +(overlay-put *annot-ovl* 'face 'region) + +(defun delete-annot-ovl (beg end len) + (delete-overlay *annot-ovl*)) + +(setq after-change-functions + (cons 'delete-annot-ovl + after-change-functions)) + +(defun ghc-show-annot0 (ask modname) + (let* ((pt (point)) + (ln (int-to-string (line-number-at-pos))) + (cn (int-to-string (current-column))) + (cdir default-directory) + (buf (current-buffer)) + (file (buffer-name))) + (if (= *annot-point* pt) + (setq *annot-ix* (+ 1 *annot-ix*)) + (progn + (setq *annot-point* pt) + (setq *annot-ix* 0))) + (save-excursion + (with-temp-buffer + (cd cdir) + (apply 'call-process ghc-module-command nil t nil + `(,@(ghc-make-ghc-options) "annot" ,file ,modname ,ln ,cn)) + (let* ((types (read (buffer-substring (point-min) (1- (point-max))))) + (cix (mod *annot-ix* (length types))) + (tinfo (nth cix 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 *annot-ovl* (- left 1) (- right 1) buf) + (message type)))))) + +(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 (let ((prompt (format "Expression (%s): " default))) diff --git a/elisp/ghc.el b/elisp/ghc.el index 086bbff..a73773f 100644 --- a/elisp/ghc.el +++ b/elisp/ghc.el @@ -49,6 +49,7 @@ (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") @@ -68,6 +69,7 @@ (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) diff --git a/ghc-mod.cabal b/ghc-mod.cabal index a4f4345..3c64d3e 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -28,7 +28,7 @@ Executable ghc-mod 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