ghc-mod 0.5.1 → 0.5.2
raw patch · 3 files changed
+70/−51 lines, 3 filesdep +old-time
Dependencies added: old-time
Files
- Info.hs +49/−45
- elisp/ghc-flymake.el +18/−4
- ghc-mod.cabal +3/−2
Info.hs view
@@ -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
elisp/ghc-flymake.el view
@@ -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 "^\\([^ ]+\\) *::")
ghc-mod.cabal view
@@ -1,5 +1,5 @@ Name: ghc-mod-Version: 0.5.1+Version: 0.5.2 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> 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