diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,6 +1,14 @@ -2013-0X-XX v1.12.3 +2013-04-02 v1.12.4 + * C-M-d on Emacs now can browse functions and types. + * Checking "QuasiQuotes" as well ass "TemplateHaskell". (@eagletmt) + * "ghc-mod info" can display info of non-exported functions. + (@mvoidex) + +2013-03-16 v1.12.3 + * "ghc-mod info" and "ghc-mod type" also check Template Haskell. + (@eagletmt) 2013-03-13 v1.12.2 diff --git a/Cradle.hs b/Cradle.hs --- a/Cradle.hs +++ b/Cradle.hs @@ -38,7 +38,7 @@ , cradlePackageConf = Nothing } Just (cdir,cfile) -> do - let sbox = cdir "cabal-dev/" + let sbox = cdir "cabal-dev" pkgConf = packageConfName sbox strver exist <- doesDirectoryExist pkgConf return Cradle { diff --git a/Debug.hs b/Debug.hs --- a/Debug.hs +++ b/Debug.hs @@ -25,8 +25,7 @@ [fast] <- withGHC fileName $ do void $ initializeFlagsWithCradle opt cradle gopts True setTargetFile fileName - slow <- needsTemplateHaskell <$> depanal [] False - return [not slow] + pure . canCheckFast <$> depanal [] False return [ "GHC version: " ++ ver , "Current directory: " ++ currentDir diff --git a/GHCApi.hs b/GHCApi.hs --- a/GHCApi.hs +++ b/GHCApi.hs @@ -5,7 +5,9 @@ , initializeFlagsWithCradle , setTargetFile , getDynamicFlags + , setSlowDynFlags , checkSlowAndSet + , canCheckFast ) where import CabalApi @@ -44,25 +46,28 @@ importDirs :: [IncludeDir] importDirs = [".","..","../..","../../..","../../../..","../../../../.."] +data Build = CabalPkg | SingleFile deriving Eq + initializeFlagsWithCradle :: Options -> Cradle -> [GHCOption] -> Bool -> Ghc LogReader initializeFlagsWithCradle opt cradle ghcOptions logging | cabal = do (gopts,idirs,depPkgs) <- liftIO $ fromCabalFile ghcOptions cradle - initSession opt gopts idirs (Just depPkgs) logging + initSession CabalPkg opt gopts idirs (Just depPkgs) logging | otherwise = - initSession opt ghcOptions importDirs Nothing logging + initSession SingleFile opt ghcOptions importDirs Nothing logging where cabal = isJust $ cradleCabalFile cradle ---------------------------------------------------------------- -initSession :: Options +initSession :: Build + -> Options -> [GHCOption] -> [IncludeDir] -> Maybe [Package] -> Bool -> Ghc LogReader -initSession opt cmdOpts idirs mDepPkgs logging = do +initSession build opt cmdOpts idirs mDepPkgs logging = do dflags0 <- getSessionDynFlags (dflags1,readLog) <- setupDynamicFlags dflags0 _ <- setSessionDynFlags dflags1 @@ -70,8 +75,7 @@ where setupDynamicFlags df0 = do df1 <- modifyFlagsWithOpts df0 cmdOpts - let fast = True - let df2 = modifyFlags df1 idirs mDepPkgs fast (expandSplice opt) + let df2 = modifyFlags df1 idirs mDepPkgs (expandSplice opt) build df3 <- modifyFlagsWithOpts df2 $ ghcOpts opt liftIO $ setLogger logging df3 @@ -86,15 +90,20 @@ ---------------------------------------------------------------- -- FIXME removing Options -modifyFlags :: DynFlags -> [IncludeDir] -> Maybe [Package] -> Bool -> Bool -> DynFlags -modifyFlags d0 idirs mDepPkgs fast splice - | splice = setSplice d3 - | otherwise = d3 +modifyFlags :: DynFlags -> [IncludeDir] -> Maybe [Package] -> Bool -> Build -> DynFlags +modifyFlags d0 idirs mDepPkgs splice build + | splice = setSplice d4 + | otherwise = d4 where d1 = d0 { importPaths = idirs } - d2 = setFastOrNot d1 fast + d2 = setFastOrNot d1 Fast d3 = maybe d2 (addDevPkgs d2) mDepPkgs + d4 | build == CabalPkg = setCabalPkg d3 + | otherwise = d3 +setCabalPkg :: DynFlags -> DynFlags +setCabalPkg dflag = dopt_set dflag Opt_BuildingCabalPackage + setSplice :: DynFlags -> DynFlags setSplice dflag = dopt_set dflag Opt_D_dump_splices @@ -108,18 +117,18 @@ ---------------------------------------------------------------- -setFastOrNot :: DynFlags -> Bool -> DynFlags -setFastOrNot dflags False = dflags { +setFastOrNot :: DynFlags -> CheckSpeed -> DynFlags +setFastOrNot dflags Slow = dflags { ghcLink = LinkInMemory , hscTarget = HscInterpreted } -setFastOrNot dflags True = dflags { +setFastOrNot dflags Fast = dflags { ghcLink = NoLink , hscTarget = HscNothing } setSlowDynFlags :: Ghc () -setSlowDynFlags = (flip setFastOrNot False <$> getSessionDynFlags) +setSlowDynFlags = (flip setFastOrNot Slow <$> getSessionDynFlags) >>= void . setSessionDynFlags -- To check TH, a session module graph is necessary. @@ -128,8 +137,8 @@ -- So, this is necessary redundancy. checkSlowAndSet :: Ghc () checkSlowAndSet = do - slow <- needsTemplateHaskell <$> depanal [] False - when slow setSlowDynFlags + fast <- canCheckFast <$> depanal [] False + unless fast setSlowDynFlags ---------------------------------------------------------------- @@ -150,3 +159,9 @@ getDynamicFlags :: IO DynFlags getDynamicFlags = runGhc (Just libdir) getSessionDynFlags + +canCheckFast :: ModuleGraph -> Bool +canCheckFast = not . any (hasTHorQQ . ms_hspp_opts) + where + hasTHorQQ :: DynFlags -> Bool + hasTHorQQ dflags = any (\opt -> xopt opt dflags) [Opt_TemplateHaskell, Opt_QuasiQuotes] diff --git a/GHCMod.hs b/GHCMod.hs --- a/GHCMod.hs +++ b/GHCMod.hs @@ -21,7 +21,7 @@ import System.Console.GetOpt import System.Directory import System.Environment (getArgs) -import System.IO (hPutStr, hPutStrLn, stderr) +import System.IO (hPutStr, hPutStrLn, stdout, stderr, hSetEncoding, utf8) import Types ---------------------------------------------------------------- @@ -87,6 +87,9 @@ main :: IO () main = flip catches handlers $ do +-- #if __GLASGOW_HASKELL__ >= 611 + hSetEncoding stdout utf8 +-- #endif args <- getArgs let (opt',cmdArg) = parseArgs argspec args (strVer,ver) <- getGHCVersion diff --git a/Info.hs b/Info.hs --- a/Info.hs +++ b/Info.hs @@ -4,7 +4,7 @@ module Info (infoExpr, typeExpr) where import Control.Applicative -import Control.Monad (void) +import Control.Monad (void, when) import CoreUtils import Data.Function import Data.Generics @@ -32,14 +32,16 @@ type Expression = String type ModuleString = String +data Cmd = Info | Type deriving Eq + ---------------------------------------------------------------- infoExpr :: Options -> Cradle -> ModuleString -> Expression -> FilePath -> IO String infoExpr opt cradle modstr expr file = (++ "\n") <$> info opt cradle file modstr expr -info :: Options -> Cradle -> FilePath -> ModuleString -> FilePath -> IO String +info :: Options -> Cradle -> FilePath -> ModuleString -> Expression -> IO String info opt cradle fileName modstr expr = - inModuleContext opt cradle fileName modstr exprToInfo "Cannot show info" + inModuleContext Info opt cradle fileName modstr exprToInfo "Cannot show info" where exprToInfo = infoThing expr @@ -70,7 +72,7 @@ typeOf :: Options -> Cradle -> FilePath -> ModuleString -> Int -> Int -> IO String typeOf opt cradle fileName modstr lineNo colNo = - inModuleContext opt cradle fileName modstr exprToType errmsg + inModuleContext Type opt cradle fileName modstr exprToType errmsg where exprToType = do modSum <- getModSummary $ mkModuleName modstr @@ -139,12 +141,13 @@ ---------------------------------------------------------------- -inModuleContext :: Options -> Cradle -> FilePath -> ModuleString -> Ghc String -> String -> IO String -inModuleContext opt cradle fileName modstr action errmsg = +inModuleContext :: Cmd -> Options -> Cradle -> FilePath -> ModuleString -> Ghc String -> String -> IO String +inModuleContext cmd opt cradle fileName modstr action errmsg = withGHCDummyFile (valid ||> invalid ||> return errmsg) where valid = do void $ initializeFlagsWithCradle opt cradle ["-w:"] False + when (cmd == Info) setSlowDynFlags setTargetFile fileName checkSlowAndSet void $ load LoadAllTargets diff --git a/Types.hs b/Types.hs --- a/Types.hs +++ b/Types.hs @@ -76,3 +76,5 @@ type GHCOption = String type IncludeDir = FilePath type Package = String + +data CheckSpeed = Slow | Fast diff --git a/elisp/ghc-doc.el b/elisp/ghc-doc.el --- a/elisp/ghc-doc.el +++ b/elisp/ghc-doc.el @@ -8,17 +8,28 @@ (require 'ghc-func) (require 'ghc-comp) +(require 'ghc-info) ;;; Code: (defun ghc-browse-document (&optional haskell-org) (interactive "P") - (let* ((mod0 (ghc-extract-module)) - (mod (ghc-read-module-name mod0)) - (pkg (ghc-resolve-package-name mod))) - (if (and pkg mod) - (ghc-display-document pkg mod haskell-org) - (message "No document found")))) + (let ((mod0 (ghc-extract-module)) + (expr (ghc-things-at-point))) + (cond + ((and (not mod0) expr) + (let* ((info (ghc-get-info expr)) + (mod (ghc-extact-module-from-info info)) + (pkg (ghc-resolve-package-name mod))) + (if (and pkg mod) + (ghc-display-document pkg mod haskell-org expr) + (message "No document found")))) + (t + (let* ((mod (ghc-read-module-name mod0)) + (pkg (ghc-resolve-package-name mod))) + (if (and pkg mod) + (ghc-display-document pkg mod haskell-org) + (message "No document found"))))))) (defun ghc-resolve-package-name (mod) (with-temp-buffer @@ -44,7 +55,7 @@ (ghc-defstruct pkg-ver pkg ver) -(defun ghc-display-document (pkg-ver mod haskell-org) +(defun ghc-display-document (pkg-ver mod haskell-org &optional symbol) (when (and pkg-ver mod) (let* ((mod- (ghc-replace-character mod ?. ?-)) (pkg (ghc-pkg-ver-get-pkg pkg-ver)) @@ -54,8 +65,31 @@ (local (format ghc-doc-local-format path mod-)) (remote (format ghc-doc-hackage-format pkg ver mod-)) (file (format "%s/%s.html" path mod-)) - (url (if (or haskell-org (not (file-exists-p file))) remote local))) + (url0 (if (or haskell-org (not (file-exists-p file))) remote local)) + (url (if symbol (ghc-add-anchor url0 symbol) url0))) + ;; Mac's "open" removes the anchor from "file://", sigh. (browse-url url)))) + +(defun ghc-add-anchor (url symbol) + (let ((case-fold-search nil)) + (if (string-match "^[A-Z]" symbol) + (concat url "#t:" symbol) + (if (string-match "^[a-z]" symbol) + (concat url "#v:" symbol) + (concat url "#v:" (ghc-url-encode symbol)))))) + +(defun ghc-url-encode (symbol) + (let ((len (length symbol)) + (i 0) + acc) + (while (< i len) + (setq acc (cons (format "-%d-" (aref symbol i)) acc)) + (setq i (1+ i))) + (apply 'concat (nreverse acc)))) + +(defun ghc-extact-module-from-info (info) + (when (string-match "\`\\([^']+\\)'" info) + (match-string 1 info))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/elisp/ghc-flymake.el b/elisp/ghc-flymake.el --- a/elisp/ghc-flymake.el +++ b/elisp/ghc-flymake.el @@ -78,7 +78,7 @@ (errs (ghc-flymake-err-list))) (ghc-display nil - (lambda (&rest ignore) + (lambda () (insert title "\n\n") (mapc (lambda (x) (insert x "\n")) errs)))))) diff --git a/elisp/ghc-func.el b/elisp/ghc-func.el --- a/elisp/ghc-func.el +++ b/elisp/ghc-func.el @@ -147,11 +147,10 @@ (defconst ghc-error-buffer-name "*GHC Info*") (defun ghc-display (fontify ins-func) - (let ((cdir default-directory) - (buf (get-buffer-create ghc-error-buffer-name))) + (let ((buf (get-buffer-create ghc-error-buffer-name))) (with-current-buffer buf (erase-buffer) - (funcall ins-func cdir) + (funcall ins-func) (ghc-replace-character-buffer ghc-null ghc-newline) (goto-char (point-min)) (if (not fontify) @@ -159,5 +158,20 @@ (haskell-font-lock-defaults-create) (turn-on-haskell-font-lock))) (display-buffer buf))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun ghc-run-ghc-mod (cmds) + (cond + ((executable-find ghc-module-command) + (let ((cdir default-directory)) + (with-temp-buffer + (cd cdir) + (apply 'call-process ghc-module-command nil t nil + (append (ghc-make-ghc-options) cmds)) + (buffer-substring (point-min) (1- (point-max)))))) + (t + (message "%s not found" ghc-module-command) + nil))) (provide 'ghc-func) diff --git a/elisp/ghc-info.el b/elisp/ghc-info.el --- a/elisp/ghc-info.el +++ b/elisp/ghc-info.el @@ -12,12 +12,19 @@ (defun ghc-show-info (&optional ask) (interactive "P") - (let* ((modname (or (ghc-find-module-name) "Main")) - (expr0 (ghc-things-at-point)) + (let* ((expr0 (ghc-things-at-point)) (expr (if (or ask (not expr0)) (ghc-read-expression expr0) expr0)) + (info (ghc-get-info expr))) + (when info + (ghc-display + nil + (lambda () (insert info)))))) + +(defun ghc-get-info (expr) + (let* ((modname (or (ghc-find-module-name) "Main")) (file (buffer-file-name)) (cmds (list "info" file modname expr))) - (ghc-display-information cmds nil))) + (ghc-run-ghc-mod cmds))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -124,27 +131,12 @@ (defun ghc-expand-th () (interactive) (let* ((file (buffer-file-name)) - (cmds (list "expand" file))) - (ghc-display-information cmds t))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Display -;;; - -(defun ghc-display-information (cmds fontify) - (interactive) - (if (not (executable-find ghc-module-command)) - (message "%s not found" ghc-module-command) - (ghc-display - fontify - (lambda (cdir) - (insert - (with-temp-buffer - (cd cdir) - (apply 'call-process ghc-module-command nil t nil - (append (ghc-make-ghc-options) cmds)) - (buffer-substring (point-min) (1- (point-max))))))))) + (cmds (list "expand" file)) + (source (ghc-run-ghc-mod cmds))) + (when source + (ghc-display + 'fontify + (lambda () (insert source)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 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: 1.12.3 +Version: 1.12.4 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 diff --git a/test/CheckSpec.hs b/test/CheckSpec.hs --- a/test/CheckSpec.hs +++ b/test/CheckSpec.hs @@ -3,10 +3,11 @@ import CabalApi import Check import Cradle -import Data.List (isSuffixOf, isInfixOf) +import Data.List (isSuffixOf, isInfixOf, isPrefixOf) import Expectation import Test.Hspec import Types +import System.FilePath spec :: Spec spec = do @@ -22,7 +23,7 @@ withDirectory_ "test/data/check-test-subdir" $ do cradle <- getGHCVersion >>= findCradle Nothing . fst res <- checkSyntax defaultOptions cradle "test/Bar/Baz.hs" - res `shouldSatisfy` ("test/Foo.hs:3:1:Warning: Top-level binding with no type signature: foo :: [Char]\NUL\n" `isSuffixOf`) + res `shouldSatisfy` (("test" "Foo.hs:3:1:Warning: Top-level binding with no type signature: foo :: [Char]\NUL\n") `isSuffixOf`) it "can detect mutually imported modules" $ do withDirectory_ "test/data" $ do @@ -30,4 +31,9 @@ cradle <- findCradle Nothing strVer res <- checkSyntax defaultOptions cradle "Mutual1.hs" res `shouldSatisfy` ("Module imports form a cycle" `isInfixOf`) - + + it "can check a module using QuasiQuotes" $ do + withDirectory_ "test/data" $ do + cradle <- getGHCVersion >>= findCradle Nothing . fst + res <- checkSyntax defaultOptions cradle "Baz.hs" + res `shouldSatisfy` ("Baz.hs:5:1:Warning:" `isPrefixOf`) diff --git a/test/DebugSpec.hs b/test/DebugSpec.hs --- a/test/DebugSpec.hs +++ b/test/DebugSpec.hs @@ -21,3 +21,6 @@ checkFast "Main.hs" "Fast check: No" checkFast "Foo.hs" "Fast check: Yes" checkFast "Bar.hs" "Fast check: No" + + it "can check QuasiQuotes" $ do + checkFast "Baz.hs" "Fast check: No" diff --git a/test/InfoSpec.hs b/test/InfoSpec.hs --- a/test/InfoSpec.hs +++ b/test/InfoSpec.hs @@ -7,6 +7,8 @@ import Info import Test.Hspec import Types +import System.Process +import System.Exit spec :: Spec spec = do @@ -31,6 +33,12 @@ res `shouldBe` unlines ["3 8 3 16 \"String -> IO ()\"", "3 8 3 20 \"IO ()\"", "3 1 3 20 \"IO ()\""] describe "infoExpr" $ do + it "works for non-export functions" $ do + withDirectory_ "test/data" $ do + cradle <- getGHCVersion >>= findCradle Nothing . fst + res <- infoExpr defaultOptions cradle "Info" "fib" "Info.hs" + res `shouldSatisfy` ("fib :: Int -> Int" `isPrefixOf`) + it "works with a module using TemplateHaskell" $ do withDirectory_ "test/data" $ do cradle <- getGHCVersion >>= findCradle Nothing . fst @@ -42,3 +50,7 @@ cradle <- getGHCVersion >>= findCradle Nothing . fst res <- infoExpr defaultOptions cradle "Main" "bar" "Main.hs" res `shouldSatisfy` ("bar :: [Char]" `isPrefixOf`) + + it "doesn't fail on unicode output" $ do + code <- rawSystem "dist/build/ghc-mod/ghc-mod" ["info", "test/data/Unicode.hs", "Unicode", "unicode"] + code `shouldSatisfy` (== ExitSuccess) diff --git a/test/data/Baz.hs b/test/data/Baz.hs new file mode 100644 --- /dev/null +++ b/test/data/Baz.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE QuasiQuotes #-} +module Baz (baz) where +import Foo (fooQ) + +baz = [fooQ| foo bar baz |] diff --git a/test/data/Foo.hs b/test/data/Foo.hs --- a/test/data/Foo.hs +++ b/test/data/Foo.hs @@ -1,5 +1,9 @@ -module Foo (foo) where +module Foo (foo, fooQ) where import Language.Haskell.TH +import Language.Haskell.TH.Quote (QuasiQuoter(..)) foo :: ExpQ foo = stringE "foo" + +fooQ :: QuasiQuoter +fooQ = QuasiQuoter (litE . stringL) undefined undefined undefined diff --git a/test/data/Info.hs b/test/data/Info.hs new file mode 100644 --- /dev/null +++ b/test/data/Info.hs @@ -0,0 +1,6 @@ +module Info () where + +fib :: Int -> Int +fib 0 = 0 +fib 1 = 1 +fib n = fib (n - 1) + fib (n - 2) diff --git a/test/data/Unicode.hs b/test/data/Unicode.hs new file mode 100644 --- /dev/null +++ b/test/data/Unicode.hs @@ -0,0 +1,4 @@ +module Unicode where + +unicode :: α -> α +unicode = id