diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2014-02-07 v3.1.6 + * Testing with multi GHC versions. (@eagletmt) + * Checking package ID. (@naota) + * Supporting GHC 7.8.1 RC1. (@bartavelle) + 2014-01-14 v3.1.5 * Catching up to GHC 7.7. (@scottgw) * Testing with multi GHC versions. (@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 @@ -5,18 +5,17 @@ import Data.Char import Data.List 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.Gap import Language.Haskell.GhcMod.Types import Name import Outputable +import Panic (throwGhcException) import TyCon import Type -import Var ---------------------------------------------------------------- @@ -92,15 +91,17 @@ justIf _ False = Nothing showThing :: DynFlags -> TyThing -> Maybe String -showThing dflag (AnId i) = Just $ formatType dflag varType i -showThing dflag (ADataCon d) = Just $ formatType dflag dataConRepType d -showThing _ (ATyCon t) = unwords . toList <$> tyType t +showThing dflag tything = showThing' dflag (fromTyThing tything) + +showThing' :: DynFlags -> GapThing -> Maybe String +showThing' dflag (GtA a) = Just $ formatType dflag a +showThing' _ (GtT t) = unwords . toList <$> tyType t where toList t' = t' : getOccString t : map getOccString (tyConTyVars t) -showThing _ _ = Nothing +showThing' _ _ = Nothing -formatType :: NamedThing a => DynFlags -> (a -> Type) -> a -> String -formatType dflag f x = showOutputable dflag (removeForAlls $ f x) +formatType :: DynFlags -> Type -> String +formatType dflag a = showOutputable dflag (removeForAlls a) tyType :: TyCon -> Maybe String tyType typ diff --git a/Language/Haskell/GhcMod/CabalApi.hs b/Language/Haskell/GhcMod/CabalApi.hs --- a/Language/Haskell/GhcMod/CabalApi.hs +++ b/Language/Haskell/GhcMod/CabalApi.hs @@ -44,26 +44,34 @@ wdir = cradleCurrentDir cradle Just cdir = cradleCabalDir cradle Just cfile = cradleCabalFile cradle + pkgs = cradlePackages cradle buildInfos = cabalAllBuildInfo pkgDesc idirs = includeDirectories cdir wdir $ cabalSourceDirs buildInfos - depPkgs = removeThem problematicPackages $ removeMe cfile $ cabalDependPackages buildInfos + depPkgs = attachPackageIds pkgs $ removeThem problematicPackages $ removeMe cfile $ cabalDependPackages buildInfos ---------------------------------------------------------------- -- Dependent packages -removeMe :: FilePath -> [Package] -> [Package] +removeMe :: FilePath -> [PackageBaseName] -> [PackageBaseName] removeMe cabalfile = filter (/= me) where me = dropExtension $ takeFileName cabalfile -removeThem :: [Package] -> [Package] -> [Package] +removeThem :: [PackageBaseName] -> [PackageBaseName] -> [PackageBaseName] removeThem badpkgs = filter (`notElem` badpkgs) -problematicPackages :: [Package] +problematicPackages :: [PackageBaseName] problematicPackages = [ "base-compat" -- providing "Prelude" ] +attachPackageIds :: [Package] -> [PackageBaseName] -> [Package] +attachPackageIds pkgs = map attachId + where + attachId x = case lookup x pkgs of + Nothing -> (x, Nothing) + Just p -> (x, p) + ---------------------------------------------------------------- -- Include directories for modules @@ -138,7 +146,7 @@ ---------------------------------------------------------------- -- | Extracting package names of dependency. -cabalDependPackages :: [BuildInfo] -> [Package] +cabalDependPackages :: [BuildInfo] -> [PackageBaseName] cabalDependPackages bis = uniqueAndSort $ pkgs where pkgs = map getDependencyPackageName $ concatMap targetBuildDepends bis diff --git a/Language/Haskell/GhcMod/Cradle.hs b/Language/Haskell/GhcMod/Cradle.hs --- a/Language/Haskell/GhcMod/Cradle.hs +++ b/Language/Haskell/GhcMod/Cradle.hs @@ -4,6 +4,7 @@ findCradle , findCradleWithoutSandbox , getPackageDbDir + , getPackageDbPackages ) where import Data.Char (isSpace) @@ -32,6 +33,7 @@ , cradleCabalDir = Nothing , cradleCabalFile = Nothing , cradlePackageDbOpts = [] + , cradlePackages = [] } findCradle' :: FilePath -> IO Cradle @@ -43,13 +45,14 @@ , cradleCabalDir = Just cdir , cradleCabalFile = Just cfile , cradlePackageDbOpts = pkgDbOpts + , cradlePackages = [] } -- Just for testing findCradleWithoutSandbox :: IO Cradle findCradleWithoutSandbox = do cradle <- findCradle - return cradle { cradlePackageDbOpts = [] } + return cradle { cradlePackageDbOpts = [], cradlePackages = [] } ---------------------------------------------------------------- @@ -139,3 +142,43 @@ (verStr1,_:left) = break (== '.') $ findVer file (verStr2,_) = break (== '.') left ver = read verStr1 * 100 + read verStr2 + +-- | Obtaining packages installed in a package db directory. +getPackageDbPackages :: FilePath -> IO [Package] +getPackageDbPackages cdir = (getPkgDb >>= listDbPackages) `E.catch` handler + where + getPkgDb = getPackageDbDir (cdir configFile) + handler :: SomeException -> IO [Package] + handler _ = return [] + +listDbPackages :: FilePath -> IO [Package] +listDbPackages pkgdir = do + files <- filter (".conf" `isSuffixOf`) <$> getDirectoryContents pkgdir + mapM extractPackage $ map (pkgdir ) files + +extractPackage :: FilePath -> IO Package +extractPackage pconf = do + contents <- lines <$> readFile pconf + -- Be strict to ensure that an error can be caught. + let !name = extractName $ parseName contents + !pid = extractId $ parseId contents + return (name, Just pid) + where + parseName = parse nameKey + extractName = extract nameKeyLength + parseId = parse idKey + extractId = extract idKeyLength + parse key = head . filter (key `isPrefixOf`) + extract keylen = fst . break isSpace . dropWhile isSpace . drop keylen + +nameKey :: String +nameKey = "name:" + +idKey :: String +idKey = "id:" + +nameKeyLength :: Int +nameKeyLength = length nameKey + +idKeyLength :: Int +idKeyLength = length idKey diff --git a/Language/Haskell/GhcMod/Debug.hs b/Language/Haskell/GhcMod/Debug.hs --- a/Language/Haskell/GhcMod/Debug.hs +++ b/Language/Haskell/GhcMod/Debug.hs @@ -41,7 +41,7 @@ , "Cabal file: " ++ cabalFile , "GHC options: " ++ unwords gopts , "Include directories: " ++ unwords incDir - , "Dependent packages: " ++ intercalate ", " pkgs + , "Dependent packages: " ++ (intercalate ", " $ map fst pkgs) , "Fast check: " ++ if fast then "Yes" else "No" ] where diff --git a/Language/Haskell/GhcMod/Doc.hs b/Language/Haskell/GhcMod/Doc.hs --- a/Language/Haskell/GhcMod/Doc.hs +++ b/Language/Haskell/GhcMod/Doc.hs @@ -1,9 +1,9 @@ module Language.Haskell.GhcMod.Doc where import DynFlags (DynFlags) -import Language.Haskell.GhcMod.Gap (withStyle) +import Language.Haskell.GhcMod.Gap (withStyle, showDocWith) import Outputable -import Pretty +import Pretty (Mode(..)) ---------------------------------------------------------------- @@ -27,17 +27,17 @@ -- For "ghc-mod type" showQualifiedPage :: DynFlags -> SDoc -> String -showQualifiedPage dflag = showDocWith PageMode . withStyle dflag styleQualified +showQualifiedPage dflag = showDocWith dflag PageMode . withStyle dflag styleQualified -- For "ghc-mod browse" and show GHC's error messages. showUnqualifiedPage :: DynFlags -> SDoc -> String -showUnqualifiedPage dflag = Pretty.showDocWith Pretty.PageMode +showUnqualifiedPage dflag = showDocWith dflag PageMode . withStyle dflag styleUnqualified -- Not used showQualifiedOneLine :: DynFlags -> SDoc -> String -showQualifiedOneLine dflag = showDocWith OneLineMode . withStyle dflag styleQualified +showQualifiedOneLine dflag = showDocWith dflag OneLineMode . withStyle dflag styleQualified -- To write Haskell code in a buffer showUnqualifiedOneLine :: DynFlags -> SDoc -> String -showUnqualifiedOneLine dflag = showDocWith OneLineMode . withStyle dflag styleUnqualified +showUnqualifiedOneLine dflag = showDocWith dflag OneLineMode . withStyle dflag styleUnqualified 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 @@ -26,13 +26,18 @@ #else , module Pretty #endif + , showDocWith + , GapThing(..) + , fromTyThing ) where import Control.Applicative hiding (empty) import Control.Monad +import CoreSyn import Data.List import Data.Maybe import Data.Time.Clock +import DataCon (dataConRepType) import Desugar (deSugarExpr) import DynFlags import ErrUtils @@ -45,13 +50,15 @@ import PprTyThing import StringBuffer import TcType -import CoreSyn +import Var (varType) import qualified InstEnv import qualified Pretty import qualified StringBuffer as SB #if __GLASGOW_HASKELL__ >= 707 import FamInstEnv +import ConLike (ConLike(..)) +import PatSyn (patSynType) #else import TcRnTypes #endif @@ -110,6 +117,15 @@ df { log_action = f df } #endif +showDocWith :: DynFlags -> Pretty.Mode -> Pretty.Doc -> String +#if __GLASGOW_HASKELL__ >= 707 +-- Pretty.showDocWith disappeard. +-- https://github.com/ghc/ghc/commit/08a3536e4246e323fbcd8040e0b80001950fe9bc +showDocWith dflags mode = Pretty.showDoc mode (pprCols dflags) +#else +showDocWith _ = Pretty.showDocWith +#endif + ---------------------------------------------------------------- ---------------------------------------------------------------- @@ -161,6 +177,8 @@ ++ [option | (option,_,_) <- fLangFlags] #elif __GLASGOW_HASKELL__ == 702 fOptions = [option | (option,_,_,_) <- fFlags] + ++ [option | (option,_,_,_) <- fWarningFlags] + ++ [option | (option,_,_,_) <- fLangFlags] #else fOptions = [option | (option,_,_) <- fFlags] #endif @@ -222,8 +240,10 @@ df' = dopt_set df Opt_HideAllPackages #endif df'' = df' { - packageFlags = map ExposePackage pkgs ++ packageFlags df + packageFlags = map expose pkgs ++ packageFlags df } + expose (pkg, Nothing) = ExposePackage pkg + expose (_, Just pid) = ExposePackageId pid ---------------------------------------------------------------- ---------------------------------------------------------------- @@ -315,3 +335,19 @@ rn_env = tcg_rdr_env tcgEnv ty_env = tcg_type_env tcgEnv #endif + +---------------------------------------------------------------- +---------------------------------------------------------------- + +data GapThing = GtA Type | GtT TyCon | GtN + +fromTyThing :: TyThing -> GapThing +fromTyThing (AnId i) = GtA $ varType i +#if __GLASGOW_HASKELL__ >= 707 +fromTyThing (AConLike (RealDataCon d)) = GtA $ dataConRepType d +fromTyThing (AConLike (PatSynCon p)) = GtA $ patSynType p +#else +fromTyThing (ADataCon d) = GtA $ dataConRepType d +#endif +fromTyThing (ATyCon t) = GtT t +fromTyThing _ = GtN 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 @@ -90,6 +90,7 @@ , cradleCabalFile :: Maybe FilePath -- | The package db options. ([\"-no-user-package-db\",\"-package-db\",\"\/foo\/bar\/i386-osx-ghc-7.6.3-packages.conf.d\"]) , cradlePackageDbOpts :: [GHCOption] + , cradlePackages :: [Package] } deriving (Eq, Show) ---------------------------------------------------------------- @@ -101,7 +102,10 @@ type IncludeDir = FilePath -- | A package name. -type Package = String +type PackageBaseName = String + +-- | A package name and its ID. +type Package = (PackageBaseName, Maybe String) -- | Haskell expression. type Expression = String 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.5 +Version: 3.1.6 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 diff --git a/test/CabalApiSpec.hs b/test/CabalApiSpec.hs --- a/test/CabalApiSpec.hs +++ b/test/CabalApiSpec.hs @@ -28,7 +28,7 @@ ghcOptions = ghcOptions res , includeDirs = map (toRelativeDir dir) (includeDirs res) } - res' `shouldBe` CompilerOptions {ghcOptions = ["-no-user-package-db","-package-db","/home/me/work/ghc-mod/test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d","-XHaskell98"], includeDirs = ["test/data","test/data/dist/build","test/data/dist/build/autogen","test/data/subdir1/subdir2","test/data/test"], depPackages = ["Cabal","base","template-haskell"]} + res' `shouldBe` CompilerOptions {ghcOptions = ["-no-user-package-db","-package-db","/home/me/work/ghc-mod/test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d","-XHaskell98"], includeDirs = ["test/data","test/data/dist/build","test/data/dist/build/autogen","test/data/subdir1/subdir2","test/data/test"], depPackages = [("Cabal", Nothing), ("base", Nothing) , ("template-haskell", Nothing)]} describe "cabalDependPackages" $ do it "extracts dependent packages" $ do diff --git a/test/DebugSpec.hs b/test/DebugSpec.hs --- a/test/DebugSpec.hs +++ b/test/DebugSpec.hs @@ -7,7 +7,7 @@ checkFast :: String -> String -> IO () checkFast file ans = withDirectory_ "test/data" $ do - let cradle = Cradle "." Nothing Nothing [] + let cradle = Cradle "." Nothing Nothing [] [] res <- debugInfo defaultOptions cradle file lines res `shouldContain` [ans]