From 39409f223930c5d90cd9554182dc6910f6673780 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 17 Nov 2010 17:07:33 +0900 Subject: [PATCH] "info" and "type" can display it even if the source file is broken. --- GHCMod.hs | 8 +++--- Info.hs | 62 ++++++++++++++++++++++++++++++++--------------- elisp/ghc-info.el | 60 +++++++++++++++++++++++++++++---------------- 3 files changed, 85 insertions(+), 45 deletions(-) diff --git a/GHCMod.hs b/GHCMod.hs index 8f32f15..1f2b27c 100644 --- a/GHCMod.hs +++ b/GHCMod.hs @@ -27,8 +27,8 @@ usage = "ghc-mod version 0.5.0\n" ++ "\t ghc-mod [-l] lang\n" ++ "\t ghc-mod [-l] browse [ ...]\n" ++ "\t ghc-mod check \n" - ++ "\t ghc-mod type \n" - ++ "\t ghc-mod info \n" + ++ "\t ghc-mod type \n" + ++ "\t ghc-mod info \n" ++ "\t ghc-mod [-h opt] lint \n" ++ "\t ghc-mod boot\n" ++ "\t ghc-mod help\n" @@ -75,8 +75,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 1) - "info" -> withFile (infoExpr opt (safelist cmdArg 2)) (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) "lint" -> withFile (lintSyntax opt) (safelist cmdArg 1) "lang" -> listLanguages opt "boot" -> do diff --git a/Info.hs b/Info.hs index f67aaf8..8a30be7 100644 --- a/Info.hs +++ b/Info.hs @@ -9,35 +9,47 @@ import Types import NameSet import HscTypes import Data.List +import Control.Exception + +type Expression = String +type ModuleString = String ---------------------------------------------------------------- -typeExpr :: Options -> String -> String -> IO String -typeExpr _ expr file = (++ "\n") <$> typeOf file expr +typeExpr :: Options -> ModuleString -> Expression -> FilePath -> IO String +typeExpr _ modstr expr file = (++ "\n") <$> typeOf file modstr expr -typeOf :: String -> String -> IO String -typeOf fileName expr = withGHC $ do - initSession [] - setTargetFile fileName - load LoadAllTargets - setContextFromTarget - pretty <$> exprType expr +typeOf :: FilePath -> ModuleString-> Expression -> IO String +typeOf fileName modstr expr = withGHC $ valid `gcatch` invalid where + valid = makeTypeOf LoadAllTargets + invalid = constE invalid0 + invalid0 = makeTypeOf $ LoadDependenciesOf (mkModuleName modstr) + makeTypeOf x = do + initSession ["-w"] + setTargetFile fileName + loadWithLogger (\_ -> return ()) x + setContextFromTarget + pretty <$> exprType expr pretty = showSDocForUser neverQualify . pprTypeForUser False ---------------------------------------------------------------- -infoExpr :: Options -> String -> String -> IO String -infoExpr _ expr file = (++ "\n") <$> info file expr +infoExpr :: Options -> ModuleString -> Expression -> FilePath -> IO String +infoExpr _ modstr expr file = (++ "\n") <$> info file modstr expr -info :: String -> String -> IO String -info fileName expr = withGHC $ do - initSession [] - setTargetFile fileName - load LoadAllTargets - setContextFromTarget - infoThing expr +info :: FilePath -> ModuleString -> FilePath -> IO String +info fileName modstr expr = withGHC $ valid `gcatch` invalid where + valid = makeInfo LoadAllTargets + invalid = constE invalid0 + invalid0 = makeInfo $ LoadDependenciesOf (mkModuleName modstr) + makeInfo x = do + initSession ["-w"] + setTargetFile fileName + loadWithLogger (\_ -> return ()) x + setContextFromTarget + infoThing expr -- ghc/InteractiveUI.hs infoThing str = do names <- parseName str @@ -68,5 +80,15 @@ pprInfo pefas (thing, fixity, insts) setContextFromTarget :: Ghc () setContextFromTarget = do ms <- depanal [] False - mdl <- findModule (ms_mod_name (head ms)) Nothing - setContext [mdl] [] + mdls <- mapM toModule ms + setContext (catMaybes mdls) [] + where + toModule ms = lookupMod `gcatch` nothing + where + lookupMod = lookupModule (ms_mod_name ms) Nothing >>= return . Just + nothing = constE $ return Nothing + +---------------------------------------------------------------- + +constE :: a -> (SomeException -> a) +constE func = \_ -> func diff --git a/elisp/ghc-info.el b/elisp/ghc-info.el index 2b9afb3..bb4b5d9 100644 --- a/elisp/ghc-info.el +++ b/elisp/ghc-info.el @@ -14,35 +14,53 @@ (interactive "P") (if (not (ghc-which ghc-module-command)) (message "%s not found" ghc-module-command) - (let* ((expr0 (thing-at-point 'symbol)) - (expr (if ask (ghc-read-expression expr0) expr0)) - (cdir default-directory) - (file (buffer-name))) - (with-temp-buffer - (cd cdir) - (call-process ghc-module-command nil t nil "type" file expr) - (message (buffer-substring (point-min) (1- (point-max)))))))) + (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 (thing-at-point 'symbol)) + (expr (if ask (ghc-read-expression expr0) expr0)) + (cdir default-directory) + (file (buffer-name))) + (with-temp-buffer + (cd cdir) + (call-process ghc-module-command nil t nil "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)) (message "%s not found" ghc-module-command) - (let* ((expr0 (thing-at-point 'symbol)) - (expr (if ask (ghc-read-expression expr0) expr0)) - (cdir default-directory) - (file (buffer-name)) - (buf (get-buffer-create ghc-error-buffer-name))) - (with-current-buffer buf - (erase-buffer) - (insert - (with-temp-buffer - (cd cdir) - (call-process ghc-module-command nil t nil "info" file expr) - (buffer-substring (point-min) (1- (point-max)))))) - (display-buffer buf)))) + (let ((modname (ghc-find-module-name))) + (if (not modname) + (message "module should be specified") + (ghc-show-info0 ask modname))))) + +(defun ghc-show-info0 (ask modname) + (let* ((expr0 (thing-at-point 'symbol)) + (expr (if ask (ghc-read-expression expr0) expr0)) + (cdir default-directory) + (file (buffer-name)) + (buf (get-buffer-create ghc-error-buffer-name))) + (with-current-buffer buf + (erase-buffer) + (insert + (with-temp-buffer + (cd cdir) + (call-process ghc-module-command nil t nil "info" file modname expr) + (buffer-substring (point-min) (1- (point-max)))))) + (display-buffer buf))) (defun ghc-read-expression (default) (let ((prompt (format "Expression (%s): " default))) (read-string prompt default nil))) +(defun ghc-find-module-name () + (save-excursion + (goto-char (point-min)) + (if (re-search-forward "^module[ ]+\\([^ ]+\\)" nil t) + (match-string-no-properties 1)))) + (provide 'ghc-info)