Kazu Yamamoto
commit
1d6246a778
@ -37,6 +37,7 @@ usage = "ghc-mod version " ++ showVersion version ++ "\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 annot" ++ 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"
|
||||
@ -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
|
||||
|
||||
82
Info.hs
82
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)
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
@ -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)))
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user