diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +2013-11-20 v3.1.3 + * GHCi loading as fallback for browse. (@khorser) + * Supporting GHC 7.7. (@schell) + * Introducing the "-p" and "-q" option for browse. (@mvoidex) + +2013-10-07 v3.1.3 + * Fixing tests. (@eagletmt) + 2013-09-21 v3.1.2 * Supporting sandbox for "list" and "browse". (@eagletmt) diff --git a/Language/Haskell/GhcMod/Browse.hs b/Language/Haskell/GhcMod/Browse.hs --- a/Language/Haskell/GhcMod/Browse.hs +++ b/Language/Haskell/GhcMod/Browse.hs @@ -4,9 +4,11 @@ import Control.Monad (void) import Data.Char import Data.List -import Data.Maybe (fromMaybe) +import Data.Maybe (catMaybes) import DataCon (dataConRepType) +import FastString (mkFastString) import GHC +import Panic(throwGhcException) import Language.Haskell.GhcMod.Doc (showUnqualifiedPage) import Language.Haskell.GhcMod.GHCApi import Language.Haskell.GhcMod.Types @@ -25,19 +27,7 @@ -> Cradle -> ModuleString -- ^ A module name. (e.g. \"Data.List\") -> IO String -browseModule opt cradle mdlName = convert opt . format <$> withGHCDummyFile (browse opt cradle mdlName) - where - format - | operators opt = formatOps - | otherwise = removeOps - removeOps = sort . filter (isAlpha.head) - formatOps = sort . map formatOps' - formatOps' x@(s:_) - | isAlpha s = x - | otherwise = "(" ++ name ++ ")" ++ tail_ - where - (name, tail_) = break isSpace x - formatOps' [] = error "formatOps'" +browseModule opt cradle mdlName = convert opt . sort <$> withGHCDummyFile (browse opt cradle mdlName) -- | Getting functions, classes, etc from a module. -- If 'detailed' is 'True', their types are also obtained. @@ -50,28 +40,56 @@ void $ initializeFlagsWithCradle opt cradle [] False getModule >>= getModuleInfo >>= listExports where - getModule = findModule (mkModuleName mdlName) Nothing + getModule = findModule mdlname mpkgid `gcatch` fallback + mdlname = mkModuleName mdlName + mpkgid = mkFastString <$> packageId opt listExports Nothing = return [] - listExports (Just mdinfo) - | detailed opt = processModule mdinfo - | otherwise = return (processExports mdinfo) + listExports (Just mdinfo) = processExports opt mdinfo + -- findModule works only for package modules, moreover, + -- you cannot load a package module. On the other hand, + -- to browse a local module you need to load it first. + -- If CmdLineError is signalled, we assume the user + -- tried browsing a local module. + fallback (CmdLineError _) = loadAndFind + fallback e = throwGhcException e + loadAndFind = do + setTargetFiles [mdlName] + checkSlowAndSet + void $ load LoadAllTargets + findModule mdlname Nothing -processExports :: ModuleInfo -> [String] -processExports = map getOccString . modInfoExports +processExports :: Options -> ModuleInfo -> Ghc [String] +processExports opt minfo = mapM (showExport opt minfo) $ removeOps $ modInfoExports minfo + where + removeOps + | operators opt = id + | otherwise = filter (isAlpha . head . getOccString) -processModule :: ModuleInfo -> Ghc [String] -processModule minfo = mapM processName names +showExport :: Options -> ModuleInfo -> Name -> Ghc String +showExport opt minfo e = do + mtype' <- mtype + return $ concat $ catMaybes [mqualified, Just $ formatOp $ getOccString e, mtype'] where - names = modInfoExports minfo - processName :: Name -> Ghc String - processName nm = do - tyInfo <- modInfoLookupName minfo nm + mqualified = (moduleNameString (moduleName $ nameModule e) ++ ".") `justIf` qualified opt + mtype + | detailed opt = do + tyInfo <- modInfoLookupName minfo e -- If nothing found, load dependent module and lookup global - tyResult <- maybe (inOtherModule nm) (return . Just) tyInfo + tyResult <- maybe (inOtherModule e) (return . Just) tyInfo dflag <- getSessionDynFlags - return $ fromMaybe (getOccString nm) (tyResult >>= showThing dflag) + return $ do + typeName <- tyResult >>= showThing dflag + (" :: " ++ typeName) `justIf` detailed opt + | otherwise = return Nothing + formatOp nm@(n:_) + | isAlpha n = nm + | otherwise = "(" ++ nm ++ ")" + formatOp "" = error "formatOp" inOtherModule :: Name -> Ghc (Maybe TyThing) inOtherModule nm = getModuleInfo (nameModule nm) >> lookupGlobalName nm + justIf :: a -> Bool -> Maybe a + justIf x True = Just x + justIf _ False = Nothing showThing :: DynFlags -> TyThing -> Maybe String showThing dflag (AnId i) = Just $ formatType dflag varType i @@ -82,7 +100,7 @@ showThing _ _ = Nothing formatType :: NamedThing a => DynFlags -> (a -> Type) -> a -> String -formatType dflag f x = getOccString x ++ " :: " ++ showOutputable dflag (removeForAlls $ f x) +formatType dflag f x = showOutputable dflag (removeForAlls $ f x) tyType :: TyCon -> Maybe String tyType typ diff --git a/Language/Haskell/GhcMod/ErrMsg.hs b/Language/Haskell/GhcMod/ErrMsg.hs --- a/Language/Haskell/GhcMod/ErrMsg.hs +++ b/Language/Haskell/GhcMod/ErrMsg.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns, CPP #-} module Language.Haskell.GhcMod.ErrMsg ( LogReader @@ -55,7 +55,7 @@ ppErrMsg :: DynFlags -> LineSeparator -> ErrMsg -> String ppErrMsg dflag ls err = ppMsg spn SevError dflag ls msg ++ ext where - spn = head (errMsgSpans err) + spn = Gap.errorMsgSpan err msg = errMsgShortDoc err ext = showMsg dflag ls (errMsgExtraInfo err) diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs --- a/Language/Haskell/GhcMod/Gap.hs +++ b/Language/Haskell/GhcMod/Gap.hs @@ -19,6 +19,9 @@ , infoThing , pprInfo , HasType(..) + , errorMsgSpan + , typeForUser + , deSugar #if __GLASGOW_HASKELL__ >= 702 #else , module Pretty @@ -30,6 +33,7 @@ import Data.List import Data.Maybe import Data.Time.Clock +import Desugar (deSugarExpr) import DynFlags import ErrUtils import FastString @@ -41,6 +45,8 @@ import PprTyThing import StringBuffer import TcType +import TcRnTypes +import CoreSyn import qualified InstEnv import qualified Pretty @@ -258,9 +264,9 @@ return $ vcat (intersperse (text "") $ map (pprInfo False) filtered) #if __GLASGOW_HASKELL__ >= 707 -pprInfo :: PrintExplicitForalls -> (TyThing, GHC.Fixity, [ClsInst], [FamInst]) -> SDoc -pprInfo pefas (thing, fixity, insts, famInsts) - = pprTyThingInContextLoc pefas thing +pprInfo :: Bool -> (TyThing, GHC.Fixity, [ClsInst], [FamInst]) -> SDoc +pprInfo _ (thing, fixity, insts, famInsts) + = pprTyThingInContextLoc thing $$ show_fixity fixity $$ InstEnv.pprInstances insts $$ pprFamInsts famInsts @@ -278,4 +284,40 @@ show_fixity fx | fx == defaultFixity = Outputable.empty | otherwise = ppr fx <+> ppr (getName thing) +#endif + +---------------------------------------------------------------- +---------------------------------------------------------------- + +errorMsgSpan :: ErrMsg -> SrcSpan +#if __GLASGOW_HASKELL__ >= 707 +errorMsgSpan = errMsgSpan +#else +errorMsgSpan = head . errMsgSpans +#endif + +typeForUser :: Type -> SDoc +#if __GLASGOW_HASKELL__ >= 707 +typeForUser = pprTypeForUser +#else +typeForUser = pprTypeForUser False +#endif + +deSugar :: TypecheckedModule -> LHsExpr Id -> HscEnv + -> IO (Maybe CoreSyn.CoreExpr) +#if __GLASGOW_HASKELL__ >= 707 +deSugar tcm e hs_env = snd <$> deSugarExpr hs_env modu rn_env ty_env fi_env e + where + modu = ms_mod $ pm_mod_summary $ tm_parsed_module tcm + tcgEnv = fst $ tm_internals_ tcm + rn_env = tcg_rdr_env tcgEnv + ty_env = tcg_type_env tcgEnv + fi_env = tcg_fam_inst_env tcgEnv +#else +deSugar tcm e hs_env = snd <$> deSugarExpr hs_env modu rn_env ty_env e + where + modu = ms_mod $ pm_mod_summary $ tm_parsed_module tcm + tcgEnv = fst $ tm_internals_ tcm + rn_env = tcg_rdr_env tcgEnv + ty_env = tcg_type_env tcgEnv #endif diff --git a/Language/Haskell/GhcMod/Info.hs b/Language/Haskell/GhcMod/Info.hs --- a/Language/Haskell/GhcMod/Info.hs +++ b/Language/Haskell/GhcMod/Info.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TupleSections, FlexibleInstances, TypeSynonymInstances #-} +{-# LANGUAGE TupleSections, FlexibleInstances, TypeSynonymInstances, CPP #-} {-# LANGUAGE Rank2Types #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -18,7 +18,6 @@ import Data.Maybe import Data.Ord as O import Data.Time.Clock -import Desugar import GHC import GHC.SYB.Utils import HscTypes @@ -29,9 +28,7 @@ import Language.Haskell.GhcMod.Gap (HasType(..)) import Language.Haskell.GhcMod.Types import Outputable -import PprTyThing import TcHsSyn (hsPatType) -import TcRnTypes ---------------------------------------------------------------- @@ -68,12 +65,8 @@ instance HasType (LHsExpr Id) where getType tcm e = do hs_env <- getSession - (_, mbe) <- Gap.liftIO $ deSugarExpr hs_env modu rn_env ty_env e + mbe <- Gap.liftIO $ Gap.deSugar tcm e hs_env 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 instance HasType (LPat Id) where getType _ (L spn pat) = return $ Just (spn, hsPatType pat) @@ -137,7 +130,7 @@ listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x])) pretty :: DynFlags -> Type -> String -pretty dflag = showUnqualifiedOneLine dflag . pprTypeForUser False +pretty dflag = showUnqualifiedOneLine dflag . Gap.typeForUser ---------------------------------------------------------------- diff --git a/Language/Haskell/GhcMod/List.hs b/Language/Haskell/GhcMod/List.hs --- a/Language/Haskell/GhcMod/List.hs +++ b/Language/Haskell/GhcMod/List.hs @@ -13,14 +13,21 @@ -- | Listing installed modules. listModules :: Options -> Cradle -> IO String -listModules opt cradle = convert opt . nub . sort <$> withGHCDummyFile (listMods opt cradle) +listModules opt cradle = convert opt . nub . sort . map dropPkgs <$> withGHCDummyFile (listMods opt cradle) + where + dropPkgs (name, pkg) + | detailed opt = name ++ " " ++ pkg + | otherwise = name -- | Listing installed modules. -listMods :: Options -> Cradle -> Ghc [String] +listMods :: Options -> Cradle -> Ghc [(String, String)] listMods opt cradle = do void $ initializeFlagsWithCradle opt cradle [] False getExposedModules <$> getSessionDynFlags where - getExposedModules = map moduleNameString - . concatMap exposedModules + getExposedModules = concatMap exposedModules' . eltsUFM . pkgIdMap . pkgState + exposedModules' p = + map moduleNameString (exposedModules p) + `zip` + repeat (display $ sourcePackageId p) diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -17,10 +17,14 @@ , operators :: Bool -- | If 'True', 'browse' also returns types. , detailed :: Bool + -- | If 'True', 'browse' will return fully qualified name + , qualified :: Bool -- | Whether or not Template Haskell should be expanded. , expandSplice :: Bool -- | Line separator string. , lineSeparator :: LineSeparator + -- | Package id of module + , packageId :: Maybe String } -- | A default 'Options'. @@ -31,8 +35,10 @@ , ghcOpts = [] , operators = False , detailed = False + , qualified = False , expandSplice = False , lineSeparator = LineSeparator "\0" + , packageId = Nothing } ---------------------------------------------------------------- diff --git a/elisp/ghc-info.el b/elisp/ghc-info.el --- a/elisp/ghc-info.el +++ b/elisp/ghc-info.el @@ -111,7 +111,7 @@ (defun ghc-type-obtain-tinfos (modname) (let* ((ln (int-to-string (line-number-at-pos))) - (cn (int-to-string (current-column))) + (cn (int-to-string (1+ (current-column)))) (cdir default-directory) (file (buffer-file-name))) (ghc-read-lisp diff --git a/elisp/ghc.el b/elisp/ghc.el --- a/elisp/ghc.el +++ b/elisp/ghc.el @@ -33,9 +33,10 @@ ;;; (defun ghc-find-C-h () - (if keyboard-translate-table - (aref keyboard-translate-table ?\C-h) - ?\C-h)) + (or + (when keyboard-translate-table + (aref keyboard-translate-table ?\C-h)) + ?\C-h)) (defvar ghc-completion-key "\e\t") (defvar ghc-document-key "\e\C-d") 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: 3.1.3 +Version: 3.1.4 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -64,7 +64,6 @@ Build-Depends: base >= 4.0 && < 5 , Cabal >= 1.10 , containers - , convertible , directory , filepath , ghc @@ -77,6 +76,8 @@ , syb , time , transformers + if impl(ghc < 7.7) + Build-Depends: convertible Executable ghc-mod Default-Language: Haskell2010 @@ -117,7 +118,6 @@ Build-Depends: base >= 4.0 && < 5 , Cabal >= 1.10 , containers - , convertible , directory , filepath , ghc @@ -131,8 +131,10 @@ , time , transformers , hspec >= 1.7.1 + if impl(ghc < 7.7) + Build-Depends: convertible if impl(ghc < 7.6.0) - Build-Depends: executable-path + Build-Depends: executable-path Source-Repository head Type: git diff --git a/src/GHCMod.hs b/src/GHCMod.hs --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -24,10 +24,10 @@ usage :: String usage = "ghc-mod version " ++ showVersion version ++ "\n" ++ "Usage:\n" - ++ "\t ghc-mod list" ++ ghcOptHelp ++ "[-l]\n" + ++ "\t ghc-mod list" ++ ghcOptHelp ++ "[-l] [-d]\n" ++ "\t ghc-mod lang [-l]\n" ++ "\t ghc-mod flag [-l]\n" - ++ "\t ghc-mod browse" ++ ghcOptHelp ++ "[-l] [-o] [-d] [ ...]\n" + ++ "\t ghc-mod browse" ++ ghcOptHelp ++ "[-l] [-o] [-d] [-q] [-p package] [ ...]\n" ++ "\t ghc-mod check" ++ ghcOptHelp ++ "\n" ++ "\t ghc-mod expand" ++ ghcOptHelp ++ "\n" ++ "\t ghc-mod debug" ++ ghcOptHelp ++ "\n" @@ -55,6 +55,12 @@ , Option "d" ["detailed"] (NoArg (\opts -> opts { detailed = True })) "print detailed info" + , Option "q" ["qualified"] + (NoArg (\opts -> opts { qualified = True })) + "show qualified names" + , Option "p" ["package"] + (ReqArg (\p opts -> opts { packageId = Just p, ghcOpts = ("-package " ++ p) : ghcOpts opts }) "package-id") + "specify package of module" , Option "b" ["boundary"] (ReqArg (\s opts -> opts { lineSeparator = LineSeparator s }) "sep") "specify line separator (default is Nul string)" diff --git a/test/BrowseSpec.hs b/test/BrowseSpec.hs --- a/test/BrowseSpec.hs +++ b/test/BrowseSpec.hs @@ -2,8 +2,11 @@ import Control.Applicative import Language.Haskell.GhcMod +import Language.Haskell.GhcMod.Cradle import Test.Hspec +import Dir + spec :: Spec spec = do describe "browseModule" $ do @@ -22,3 +25,10 @@ cradle <- findCradle syms <- lines <$> browseModule defaultOptions { detailed = True} cradle "Data.Either" syms `shouldContain` ["Left :: a -> Either a b"] + + describe "browseModule local" $ do + it "lists symbols in a local module" $ do + withDirectory_ "test/data" $ do + cradle <- findCradleWithoutSandbox + syms <- lines <$> browseModule defaultOptions cradle "Baz" + syms `shouldContain` ["baz"]