diff --git a/Info.hs b/Info.hs --- a/Info.hs +++ b/Info.hs @@ -11,6 +11,8 @@ import HscTypes import Data.List import Control.Exception +import StringBuffer +import System.Time type Expression = String type ModuleString = String @@ -20,20 +22,10 @@ typeExpr :: Options -> ModuleString -> Expression -> FilePath -> IO String typeExpr _ modstr expr file = (++ "\n") <$> typeOf file modstr expr -typeOf :: FilePath -> ModuleString-> Expression -> IO String -typeOf fileName modstr expr = withGHC $ valid `gcatch` invalid +typeOf :: FilePath -> ModuleString -> Expression -> IO String +typeOf fileName modstr expr = inModuleContext fileName modstr exprToType where - valid = makeTypeOf LoadAllTargets - invalid = constE invalid0 - invalid0 = makeTypeOf $ LoadDependenciesOf (mkModuleName modstr) - makeTypeOf x = do - initSession ["-w"] - setTargetFile fileName - loadWithLogger (\_ -> return ()) x - ok <- setContextFromTarget - if ok - then pretty <$> exprType expr - else return "Its type cannot be guessed" + exprToType = pretty <$> exprType expr pretty = showSDocForUser neverQualify . pprTypeForUser False ---------------------------------------------------------------- @@ -42,39 +34,32 @@ infoExpr _ modstr expr file = (++ "\n") <$> info file modstr expr info :: FilePath -> ModuleString -> FilePath -> IO String -info fileName modstr expr = withGHC $ valid `gcatch` invalid +info fileName modstr expr = inModuleContext fileName modstr exprToInfo where - valid = makeInfo LoadAllTargets - invalid = constE invalid0 - invalid0 = makeInfo $ LoadDependenciesOf (mkModuleName modstr) - makeInfo x = do - initSession ["-w"] - setTargetFile fileName - loadWithLogger (\_ -> return ()) x - ok <- setContextFromTarget - if ok - then infoThing expr - else return "Its info is not available" - -- ghc/InteractiveUI.hs - infoThing str = do - names <- parseName str - mb_stuffs <- mapM getInfo names - let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs) - unqual <- getPrintUnqual - return $ showSDocForUser unqual $ vcat (intersperse (text "") $ map (pprInfo False) filtered) + exprToInfo = infoThing expr --- ghc/InteractiveUI.hs +---------------------------------------------------------------- +-- from ghc/InteractiveUI.hs + +infoThing :: String -> Ghc String +infoThing str = do + names <- parseName str + mb_stuffs <- mapM getInfo names + let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs) + unqual <- getPrintUnqual + return $ showSDocForUser unqual $ vcat (intersperse (text "") $ map (pprInfo False) filtered) + filterOutChildren :: (a -> TyThing) -> [a] -> [a] filterOutChildren get_thing xs = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)] where implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)] -pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc +pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [Instance]) -> SDoc pprInfo pefas (thing, fixity, insts) - = pprTyThingInContextLoc pefas thing - $$ show_fixity fixity - $$ vcat (map pprInstance insts) + = pprTyThingInContextLoc pefas thing + $$ show_fixity fixity + $$ vcat (map pprInstance insts) where show_fixity fix | fix == defaultFixity = empty @@ -82,19 +67,38 @@ ---------------------------------------------------------------- +inModuleContext :: FilePath -> ModuleString -> Ghc String -> IO String +inModuleContext fileName modstr action = withGHC valid + where + valid = do + initSession ["-w"] + setTargetFile fileName + loadWithLogger (\_ -> return ()) LoadAllTargets + mif setContextFromTarget action invalid + invalid = do + initSession ["-w"] + setTargetBuffer + loadWithLogger defaultWarnErrLogger LoadAllTargets + mif setContextFromTarget action (return errorMessage) + setTargetBuffer = do + modgraph <- depanal [mkModuleName modstr] True + let imports = concatMap (map (showSDoc . ppr . unLoc)) $ + map ms_imps modgraph ++ map ms_srcimps modgraph + moddef = "module " ++ sanitize modstr ++ " where" + header = moddef : imports + importsBuf <- liftIO . stringToStringBuffer . unlines $ header + clkTime <- liftIO getClockTime + setTargets [Target (TargetModule $ mkModuleName modstr) True (Just (importsBuf, clkTime))] + mif m t e = m >>= \ok -> if ok then t else e + sanitize = fromMaybe "SomeModule" . listToMaybe . words + errorMessage = "Couldn't determine type" + setContextFromTarget :: Ghc Bool setContextFromTarget = do ms <- depanal [] False - -- ms <- getModuleGraph -- this is the same top <- map ms_mod <$> filterM isTop ms - {- - top is a set of this module and your-defined modules. - If this module has syntax errors, it cannot be specified. - And if there is no your-defined modules, top is []. - In this case, we cannot obtain the type of an expression, sigh. - -} setContext top [] - return $ if top == [] then False else True + return (top /= []) where isTop ms = lookupMod `gcatch` returnFalse where diff --git a/elisp/ghc-flymake.el b/elisp/ghc-flymake.el --- a/elisp/ghc-flymake.el +++ b/elisp/ghc-flymake.el @@ -74,16 +74,30 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun ghc-extract-type (str) + (with-temp-buffer + (insert str) + (goto-char (point-min)) + (when (re-search-forward "Inferred type: " nil t) + (delete-region (point-min) (point))) + (when (re-search-forward " forall [^.]+\\." nil t) + (replace-match "")) + (while (re-search-forward "\0 +" nil t) + (replace-match " ")) + (goto-char (point-min)) + (while (re-search-forward "\\[Char\\]" nil t) + (replace-match "String")) + (re-search-forward "\0" nil t) + (buffer-substring-no-properties (point-min) (1- (point))))) + (defun ghc-flymake-insert-from-warning () (interactive) (dolist (data (ghc-flymake-err-list)) (save-excursion (cond - ((string-match "Inferred type: \\([^:]+ :: \\)\\(forall [^.]+\\.\\( \\|\0 +\\)\\)?\\([^\0]*\\)" data) + ((string-match "Inferred type: " data) (beginning-of-line) - (insert (match-string 1 data) - (replace-regexp-in-string "\\[Char\\]" "String" (match-string 4 data)) - "\n")) + (insert (ghc-extract-type data) "\n")) ((string-match "lacks an accompanying binding" data) (beginning-of-line) (when (looking-at "^\\([^ ]+\\) *::") 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: 0.5.1 +Version: 0.5.2 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -29,7 +29,8 @@ else GHC-Options: -Wall Build-Depends: base >= 4.0 && < 5, ghc, ghc-paths, - process, directory, filepath, hlint >= 1.7.1 + process, directory, filepath, old-time, + hlint >= 1.7.1 Source-Repository head Type: git Location: git://github.com/kazu-yamamoto/ghc-mod.git