diff --git a/hhp.cabal b/hhp.cabal --- a/hhp.cabal +++ b/hhp.cabal @@ -1,5 +1,5 @@ Name: hhp -Version: 0.0.4 +Version: 1.0.0 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -14,6 +14,8 @@ the hhpi command, the HHP library, and Emacs front-end. For more information, please see its home page. + Version 0.x.x supports GHC 8.x only whereas version + 1.x.x suports GHC 9.x only. Category: Development Cabal-Version: >= 1.10 @@ -57,8 +59,8 @@ Hhp.Doc Hhp.Find Hhp.Flag - Hhp.GHCApi Hhp.Gap + Hhp.GHCApi Hhp.GhcPkg Hhp.Logger Hhp.Info @@ -74,6 +76,7 @@ , containers , deepseq , directory + , exceptions , filepath , ghc , hlint >= 1.8.61 @@ -117,12 +120,11 @@ Test-Suite spec Default-Language: Haskell2010 - Main-Is: Main.hs + Main-Is: Spec.hs Hs-Source-Dirs: test, lib GHC-Options: -Wall Type: exitcode-stdio-1.0 Other-Modules: Dir - Spec BrowseSpec CabalApiSpec CheckSpec @@ -142,8 +144,8 @@ Hhp.Doc Hhp.Find Hhp.Flag - Hhp.GHCApi Hhp.Gap + Hhp.GHCApi Hhp.GhcPkg Hhp.Info Hhp.Lang @@ -159,6 +161,7 @@ , containers , deepseq , directory + , exceptions , extra , filepath , ghc @@ -167,7 +170,7 @@ , syb , hlint >= 1.7.1 , ghc-boot - build-tool-depends: hspec-discover:hspec-discover + build-tool-depends: hspec-discover:hspec-discover == 2.* Source-Repository head Type: git diff --git a/lib/Hhp.hs b/lib/Hhp.hs --- a/lib/Hhp.hs +++ b/lib/Hhp.hs @@ -30,6 +30,7 @@ , findSymbol -- * Misc , cProjectVersion + , cProjectVersionInt ) where import Hhp.Boot @@ -46,4 +47,4 @@ import Hhp.PkgDoc import Hhp.Types -import Config (cProjectVersion) +import GHC.Settings.Config (cProjectVersion, cProjectVersionInt) diff --git a/lib/Hhp/Boot.hs b/lib/Hhp/Boot.hs --- a/lib/Hhp/Boot.hs +++ b/lib/Hhp/Boot.hs @@ -1,7 +1,7 @@ module Hhp.Boot where -import CoreMonad (liftIO) import GHC (Ghc) +import GHC.Utils.Monad (liftIO) import Hhp.Browse import Hhp.Flag diff --git a/lib/Hhp/Browse.hs b/lib/Hhp/Browse.hs --- a/lib/Hhp/Browse.hs +++ b/lib/Hhp/Browse.hs @@ -3,23 +3,21 @@ , browse ) where -import Exception (ghandle) -import FastString (mkFastString) import GHC (Ghc, GhcException(CmdLineError), ModuleInfo, Name, TyThing, DynFlags, Type, TyCon) import qualified GHC as G -import Name (getOccString) -import Outputable (ppr, Outputable) -import TyCon (isAlgTyCon) -import Type (dropForAlls, splitFunTy_maybe, isPredTy) +import GHC.Core.TyCon (isAlgTyCon) +import GHC.Core.Type (dropForAlls, splitFunTy_maybe, isPredTy, mkVisFunTy) +import GHC.Data.FastString (mkFastString) +import GHC.Types.Name (getOccString) -import Control.Exception (SomeException(..)) +import Control.Monad.Catch (SomeException(..), handle, catch) import Data.Char (isAlpha) import Data.List (sort) import Data.Maybe (catMaybes) import Hhp.Doc (showPage, styleUnqualified) -import Hhp.Gap import Hhp.GHCApi +import Hhp.Gap import Hhp.Things import Hhp.Types @@ -55,9 +53,9 @@ -- to browse a local module you need to load it first. -- If CmdLineError is signalled, we assume the user -- tried browsing a local module. - getModule = browsePackageModule `G.gcatch` fallback `G.gcatch` handler + getModule = browsePackageModule `catch` fallback `catch` handler browsePackageModule = G.findModule mdlname mpkgid >>= G.getModuleInfo - browseLocalModule = ghandle handler $ do + browseLocalModule = handle handler $ do setTargetFiles [mdl] G.findModule mdlname Nothing >>= G.getModuleInfo fallback (CmdLineError _) = browseLocalModule @@ -118,8 +116,11 @@ showThing' _ _ = Nothing formatType :: DynFlags -> Type -> String -formatType dflag a = showOutputable dflag (removeForAlls a) +formatType dflag a = showOutputable dflag $ removeForAlls a +showOutputable :: DynFlags -> Type -> String +showOutputable dflag = unwords . lines . showPage dflag styleUnqualified . pprTypeForUser + tyType :: TyCon -> Maybe String tyType typ | isAlgTyCon typ @@ -127,7 +128,6 @@ && not (G.isClassTyCon typ) = Just "data" | G.isNewTyCon typ = Just "newtype" | G.isClassTyCon typ = Just "class" --- | G.isSynTyCon typ = Just "type" -- fixme | G.isTypeSynonymTyCon typ = Just "type" | otherwise = Nothing @@ -137,11 +137,8 @@ ty' = dropForAlls ty tty' = splitFunTy_maybe ty' -removeForAlls' :: Type -> Maybe (Type, Type) -> Type +removeForAlls' :: Type -> Maybe (Type, Type, Type) -> Type removeForAlls' ty Nothing = ty -removeForAlls' ty (Just (pre, ftype)) - | isPredTy pre = mkFunTy pre (dropForAlls ftype) +removeForAlls' ty (Just (pre, ftype, x)) + | isPredTy pre = mkVisFunTy pre (dropForAlls ftype) x | otherwise = ty - -showOutputable :: Outputable a => DynFlags -> a -> String -showOutputable dflag = unwords . lines . showPage dflag (styleUnqualified dflag) . ppr diff --git a/lib/Hhp/CabalApi.hs b/lib/Hhp/CabalApi.hs --- a/lib/Hhp/CabalApi.hs +++ b/lib/Hhp/CabalApi.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE OverloadedStrings, CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Hhp.CabalApi ( getCompilerOptions @@ -22,35 +23,19 @@ import Distribution.Text (display) import Distribution.Verbosity (silent) import Distribution.Version (Version) - -#if MIN_VERSION_Cabal(3,2,0) import Distribution.PackageDescription.Configuration (finalizePD) import Distribution.PackageDescription.Parsec (readGenericPackageDescription) import Distribution.Types.ComponentRequestedSpec (defaultComponentRequestedSpec) import Distribution.Types.Flag (mkFlagAssignment, mkFlagName) import Distribution.Types.PackageName (unPackageName) -#elif MIN_VERSION_Cabal(2,2,0) -import Distribution.PackageDescription.Configuration (finalizePD) -import Distribution.PackageDescription.Parsec (readGenericPackageDescription) -import Distribution.Types.ComponentRequestedSpec (defaultComponentRequestedSpec) -import Distribution.Types.GenericPackageDescription (mkFlagAssignment, mkFlagName) -import Distribution.Types.PackageName (unPackageName) -#elif MIN_VERSION_Cabal(2,0,0) -import Distribution.PackageDescription.Configuration (finalizePD) -import Distribution.PackageDescription.Parse (readPackageDescription) -import Distribution.Types.ComponentRequestedSpec (defaultComponentRequestedSpec) -import Distribution.Types.GenericPackageDescription (mkFlagName) -import Distribution.Types.PackageName (unPackageName) -#else -import Distribution.Package (PackageName(PackageName)) -import Distribution.PackageDescription (FlagName (FlagName)) -import Distribution.PackageDescription.Configuration (finalizePackageDescription) -import Distribution.PackageDescription.Parse (readPackageDescription) +#if MIN_VERSION_Cabal(3,6,0) +import Distribution.Utils.Path (getSymbolicPath, SymbolicPath) #endif +import GHC.Utils.Monad (liftIO) + import Control.Exception (throwIO) import Control.Monad (filterM) -import CoreMonad (liftIO) import Data.Maybe (maybeToList, mapMaybe) import Data.Set (fromList, toList) import System.Directory (doesFileExist) @@ -123,11 +108,7 @@ parseCabalFile file = do cid <- getGHCId let cid' = unknownCompilerInfo cid NoAbiTag -#if MIN_VERSION_Cabal(2,2,0) epgd <- readGenericPackageDescription silent file -#else - epgd <- readPackageDescription silent file -#endif flags <- getFlags case toPkgDesc cid' flags epgd of Left deps -> throwIO $ userError $ show deps ++ " are not installed" @@ -141,21 +122,9 @@ | c == '-' = [(mkFlagName cs, False)] | otherwise = [(mkFlagName ccs, True)] maybe [] (concatMap parseF . words) `fmap` lookupEnv "HHP_CABAL_FLAGS" -#if MIN_VERSION_Cabal(2,2,0) - getFlags = mkFlagAssignment `fmap` envFlags -#else - getFlags = envFlags -#endif -#if MIN_VERSION_Cabal(2,0,0) + getFlags = mkFlagAssignment <$> envFlags nullPkg pd = unPackageName (C.pkgName (P.package pd)) == "" toPkgDesc cid flags = finalizePD flags defaultComponentRequestedSpec (const True) buildPlatform cid [] -#else - mkFlagName = FlagName - nullPkg pd = name == "" - where - PackageName name = C.pkgName (P.package pd) - toPkgDesc cid flags = finalizePackageDescription flags (const True) buildPlatform cid [] -#endif ---------------------------------------------------------------- @@ -188,18 +157,10 @@ cabalAllBuildInfo pd = libBI ++ subBI ++ execBI ++ testBI ++ benchBI where libBI = map P.libBuildInfo $ maybeToList $ P.library pd -#if MIN_VERSION_Cabal(2,0,0) subBI = map P.libBuildInfo $ P.subLibraries pd -#else - subBI = [] -#endif execBI = map P.buildInfo $ P.executables pd testBI = map P.testBuildInfo $ P.testSuites pd -#if __GLASGOW_HASKELL__ >= 704 benchBI = map P.benchmarkBuildInfo $ P.benchmarks pd -#else - benchBI = [] -#endif ---------------------------------------------------------------- @@ -208,19 +169,13 @@ cabalDependPackages bis = uniqueAndSort pkgs where pkgs = map getDependencyPackageName $ concatMap P.targetBuildDepends bis -#if MIN_VERSION_Cabal(3,0,0) getDependencyPackageName (Dependency pkg _ _) = unPackageName pkg -#elif MIN_VERSION_Cabal(2,0,0) - getDependencyPackageName (Dependency pkg _) = unPackageName pkg -#else - getDependencyPackageName (Dependency (PackageName nm) _) = nm -#endif ---------------------------------------------------------------- -- | Extracting include directories for modules. cabalSourceDirs :: [BuildInfo] -> [IncludeDir] -cabalSourceDirs bis = uniqueAndSort $ concatMap P.hsSourceDirs bis +cabalSourceDirs bis = uniqueAndSort $ concatMap (map toPath . P.hsSourceDirs) bis ---------------------------------------------------------------- @@ -249,20 +204,10 @@ testTargets <- mapM getTestTarget $ P.testSuites pd return (libTargets,concat exeTargets,concat testTargets,benchTargets) where - lib = case P.library pd of - Nothing -> [] -#if MIN_VERSION_Cabal(2,0,0) - Just l -> P.explicitLibModules l -#else - Just l -> P.libModules l -#endif + lib = maybe [] P.explicitLibModules $ P.library pd libTargets = map toModuleString lib -#if __GLASGOW_HASKELL__ >= 704 benchTargets = map toModuleString $ concatMap P.benchmarkModules $ P.benchmarks pd -#else - benchTargets = [] -#endif toModuleString :: ModuleName -> String toModuleString mn = fromFilePath $ toFilePath mn @@ -273,12 +218,20 @@ getTestTarget ts = case P.testInterface ts of (TestSuiteExeV10 _ filePath) -> do - let maybeTests = [p e | p <- P.hsSourceDirs $ P.testBuildInfo ts, e <- [filePath]] + let maybeTests = [toPath p e | p <- P.hsSourceDirs $ P.testBuildInfo ts, e <- [filePath]] liftIO $ filterM doesFileExist maybeTests (TestSuiteLibV09 _ moduleName) -> return [toModuleString moduleName] (TestSuiteUnsupported _) -> return [] getExecutableTarget :: Executable -> IO [String] getExecutableTarget exe = do - let maybeExes = [p e | p <- P.hsSourceDirs $ P.buildInfo exe, e <- [P.modulePath exe]] + let maybeExes = [toPath p e | p <- P.hsSourceDirs $ P.buildInfo exe, e <- [P.modulePath exe]] liftIO $ filterM doesFileExist maybeExes + +#if MIN_VERSION_Cabal(3,6,0) +toPath :: SymbolicPath from to -> FilePath +toPath = getSymbolicPath +#else +toPath :: String -> String +toPath = id +#endif diff --git a/lib/Hhp/Check.hs b/lib/Hhp/Check.hs --- a/lib/Hhp/Check.hs +++ b/lib/Hhp/Check.hs @@ -5,8 +5,8 @@ , expand ) where -import DynFlags (dopt_set, DumpFlag(Opt_D_dump_splices)) import GHC (Ghc, DynFlags(..)) +import GHC.Driver.Session (dopt_set, DumpFlag(Opt_D_dump_splices)) import Hhp.GHCApi import Hhp.Logger @@ -36,7 +36,7 @@ check :: Options -> [FilePath] -- ^ The target files. -> Ghc (Either String String) -check opt fileNames = withLogger opt (setAllWaringFlags . setPartialSignatures . setDeferTypedHoles) $ +check opt fileNames = withLogger opt (setAllWarningFlags . setPartialSignatures . setDeferTypedHoles) $ setTargetFiles fileNames ---------------------------------------------------------------- @@ -61,7 +61,7 @@ expand :: Options -> [FilePath] -- ^ The target files. -> Ghc (Either String String) -expand opt fileNames = withLogger opt (setDumpSplices . setNoWaringFlags) $ +expand opt fileNames = withLogger opt (setDumpSplices . setNoWarningFlags) $ setTargetFiles fileNames setDumpSplices :: DynFlags -> DynFlags diff --git a/lib/Hhp/Debug.hs b/lib/Hhp/Debug.hs --- a/lib/Hhp/Debug.hs +++ b/lib/Hhp/Debug.hs @@ -1,6 +1,6 @@ module Hhp.Debug (debugInfo, rootInfo) where -import CoreMonad (liftIO) +import GHC.Utils.Monad (liftIO) import Control.Applicative ((<|>)) import Data.List (intercalate) diff --git a/lib/Hhp/Doc.hs b/lib/Hhp/Doc.hs --- a/lib/Hhp/Doc.hs +++ b/lib/Hhp/Doc.hs @@ -1,24 +1,39 @@ -module Hhp.Doc where +module Hhp.Doc ( + showPage + , showOneLine + , getStyle + , styleUnqualified + ) where import GHC (Ghc, DynFlags, getPrintUnqual, pprCols) -import Outputable (PprStyle, SDoc, withPprStyleDoc, neverQualify) -import Pretty (Mode(..), Doc, Style(..), renderStyle, style) +import GHC.Utils.Outputable (PprStyle, SDoc, neverQualify, runSDoc, PrintUnqualified, PprStyle, Depth(..), mkUserStyle) +import GHC.Driver.Session (initSDocContext) +import GHC.Utils.Ppr (Mode(..), Style(..), renderStyle, style) -import Hhp.Gap (makeUserStyle) +import Hhp.Gap +---------------------------------------------------------------- + showPage :: DynFlags -> PprStyle -> SDoc -> String -showPage dflag stl = showDocWith dflag PageMode . withPprStyleDoc dflag stl +showPage = showSDocWithMode pagemode showOneLine :: DynFlags -> PprStyle -> SDoc -> String -showOneLine dflag stl = showDocWith dflag OneLineMode . withPprStyleDoc dflag stl +showOneLine = showSDocWithMode OneLineMode -getStyle :: DynFlags -> Ghc PprStyle -getStyle dflags = makeUserStyle dflags <$> getPrintUnqual +showSDocWithMode :: Mode -> DynFlags -> PprStyle -> SDoc -> String +showSDocWithMode md dflags pprstyle sdoc = renderStyle style' doc + where + ctx = initSDocContext dflags pprstyle + doc = runSDoc sdoc ctx + style' = style { mode = md, lineLength = pprCols dflags } -styleUnqualified :: DynFlags -> PprStyle -styleUnqualified dflags = makeUserStyle dflags neverQualify +---------------------------------------------------------------- -showDocWith :: DynFlags -> Mode -> Doc -> String -showDocWith dflags md = renderStyle mstyle - where - mstyle = style { mode = md, lineLength = pprCols dflags } +getStyle :: Ghc PprStyle +getStyle = makeUserStyle <$> getPrintUnqual + +styleUnqualified :: PprStyle +styleUnqualified = makeUserStyle neverQualify + +makeUserStyle :: PrintUnqualified -> PprStyle +makeUserStyle pu = mkUserStyle pu AllTheWay diff --git a/lib/Hhp/Find.hs b/lib/Hhp/Find.hs --- a/lib/Hhp/Find.hs +++ b/lib/Hhp/Find.hs @@ -10,21 +10,21 @@ import GHC (Ghc, DynFlags, Module, ModuleInfo) import qualified GHC as G -import Module (Module(..)) -import Outputable (ppr) -import PackageConfig (PackageConfig, exposedModules, packageConfigId) -import Packages (listPackageConfigMap) +import GHC.Unit.Info (UnitInfo, unitExposedModules, mkUnit) +import GHC.Unit.State (listUnitInfo, UnitState) +import GHC.Utils.Outputable (ppr) import Control.DeepSeq (force) +import Control.Monad.Catch (SomeException(..), catch) import Data.Function (on) import Data.List (groupBy, sort) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, catMaybes) import Hhp.Doc (showOneLine, styleUnqualified) +import Hhp.Gap import Hhp.GHCApi -import Hhp.Gap (getModuleName) import Hhp.Types -- | Type of key for `SymMdlDb`. @@ -57,24 +57,28 @@ -- | Browsing all functions in all system/user modules. browseAll :: DynFlags -> Ghc [(String,String)] browseAll dflag = do - let ms = packageModules dflag - is <- mapM G.getModuleInfo ms + ms <- packageModules <$> getUnitState + is <- catMaybes <$> mapM getMaybeModuleInfo ms return $ concatMap (toNameModule dflag) (zip ms is) +-- ghc-bignum causes errors, sigh. +getMaybeModuleInfo :: Module -> Ghc (Maybe (Maybe ModuleInfo)) +getMaybeModuleInfo x = Just <$> G.getModuleInfo x `catch` (\(SomeException _) -> return Nothing) + toNameModule :: DynFlags -> (Module, Maybe ModuleInfo) -> [(String,String)] toNameModule _ (_,Nothing) = [] toNameModule dflag (m,Just inf) = map (\name -> (toStr name, mdl)) names where mdl = G.moduleNameString (G.moduleName m) names = G.modInfoExports inf - toStr = showOneLine dflag (styleUnqualified dflag) . ppr + toStr = showOneLine dflag styleUnqualified . ppr -packageModules :: DynFlags -> [Module] -packageModules dflag = concatMap fromPackageConfig $ listPackageConfigMap dflag +packageModules :: UnitState -> [Module] +packageModules us = concatMap fromUnitInfo $ listUnitInfo us -fromPackageConfig :: PackageConfig -> [Module] -fromPackageConfig pkgcnf = modules +fromUnitInfo :: UnitInfo -> [Module] +fromUnitInfo uinfo = modules where - uid = packageConfigId pkgcnf -- check me - moduleNames = map getModuleName $ exposedModules pkgcnf - modules = map (Module uid) moduleNames + uid = mkUnit uinfo + moduleNames = map fst $ unitExposedModules uinfo + modules = map (G.mkModule uid) moduleNames diff --git a/lib/Hhp/Flag.hs b/lib/Hhp/Flag.hs --- a/lib/Hhp/Flag.hs +++ b/lib/Hhp/Flag.hs @@ -1,6 +1,6 @@ module Hhp.Flag where -import DynFlags +import GHC.Driver.Session (flagSpecName, fFlags, wWarningFlags, fLangFlags) import Hhp.Types diff --git a/lib/Hhp/GHCApi.hs b/lib/Hhp/GHCApi.hs --- a/lib/Hhp/GHCApi.hs +++ b/lib/Hhp/GHCApi.hs @@ -9,26 +9,24 @@ , getSystemLibDir , withDynFlags , withCmdFlags - , setNoWaringFlags - , setAllWaringFlags + , setNoWarningFlags + , setAllWarningFlags , setDeferTypedHoles , setDeferTypeErrors , setPartialSignatures , setWarnTypedHoles ) where -import CoreMonad (liftIO) -import DynFlags (GeneralFlag(Opt_BuildingCabalPackage, Opt_HideAllPackages) - ,WarningFlag(Opt_WarnTypedHoles) - ,gopt_set, xopt_set, wopt_set - ,ModRenaming(..), PackageFlag(ExposePackage), PackageArg(..)) -import Exception (ghandle, SomeException(..)) -import GHC (Ghc, DynFlags(..), GhcLink(..), HscTarget(..), LoadHowMuch(..)) +import GHC (Ghc, DynFlags(..), LoadHowMuch(..)) import qualified GHC as G +import qualified GHC.Data.EnumSet as E (EnumSet, empty) +import GHC.Driver.Session (GeneralFlag(Opt_BuildingCabalPackage, Opt_HideAllPackages),WarningFlag(Opt_WarnTypedHoles),gopt_set, xopt_set, wopt_set,ModRenaming(..), PackageFlag(ExposePackage), PackageArg(..), WarningFlag, parseDynamicFlagsCmdLine) import GHC.LanguageExtensions (Extension(..)) +import GHC.Utils.Monad (liftIO) import Control.Applicative ((<|>)) import Control.Monad (forM, void) +import Control.Monad.Catch (SomeException, handle, bracket) import Data.Maybe (isJust, fromJust) import System.Exit (exitSuccess) import System.IO (hPutStr, hPrint, stderr) @@ -36,7 +34,7 @@ import System.Process (readProcess) import Hhp.CabalApi -import qualified Hhp.Gap as Gap +import Hhp.Gap import Hhp.GhcPkg import Hhp.Types @@ -56,7 +54,7 @@ withGHC :: FilePath -- ^ A target file displayed in an error message. -> Ghc a -- ^ 'Ghc' actions created by the Ghc utilities. -> IO a -withGHC file body = ghandle ignore $ withGHC' body +withGHC file body = handle ignore $ withGHC' body where ignore :: SomeException -> IO a ignore e = do @@ -111,27 +109,15 @@ -> Ghc () initSession build Options{} CompilerOptions{..} = do df <- G.getSessionDynFlags - void $ G.setSessionDynFlags =<< (addCmdOpts ghcOptions - $ setLinkerOptions + void $ G.setSessionDynFlags =<< addCmdOpts ghcOptions + ( setLinkerOptions $ setIncludeDirs includeDirs $ setBuildEnv build $ setEmptyLogger $ addPackageFlags depPackages df) -setEmptyLogger :: DynFlags -> DynFlags -setEmptyLogger df = df { G.log_action = \_ _ _ _ _ _ -> return () } - ---------------------------------------------------------------- --- we don't want to generate object code so we compile to bytecode --- (HscInterpreted) which implies LinkInMemory --- HscInterpreted -setLinkerOptions :: DynFlags -> DynFlags -setLinkerOptions df = df { - ghcLink = LinkInMemory - , hscTarget = HscInterpreted - } - setIncludeDirs :: [IncludeDir] -> DynFlags -> DynFlags setIncludeDirs idirs df = df { importPaths = idirs } @@ -153,7 +139,7 @@ -- | Parse command line ghc options and add them to the 'DynFlags' passed addCmdOpts :: [GHCOption] -> DynFlags -> Ghc DynFlags addCmdOpts cmdOpts df = - tfst <$> G.parseDynamicFlags df (map G.noLoc cmdOpts) + tfst <$> parseDynamicFlagsCmdLine df (map G.noLoc cmdOpts) where tfst (a,_,_) = a @@ -175,7 +161,7 @@ G.runGhc mlibdir G.getSessionDynFlags withDynFlags :: (DynFlags -> DynFlags) -> Ghc a -> Ghc a -withDynFlags setFlag body = G.gbracket setup teardown (\_ -> body) +withDynFlags setFlag body = bracket setup teardown (const body) where setup = do dflag <- G.getSessionDynFlags @@ -184,7 +170,7 @@ teardown = void . G.setSessionDynFlags withCmdFlags :: [GHCOption] -> Ghc a -> Ghc a -withCmdFlags flags body = G.gbracket setup teardown (\_ -> body) +withCmdFlags flags body = bracket setup teardown (const body) where setup = do dflag <- G.getSessionDynFlags >>= addCmdOpts flags @@ -211,15 +197,15 @@ setPartialSignatures df = xopt_set (xopt_set df PartialTypeSignatures) NamedWildCards -- | Set 'DynFlags' equivalent to "-w:". -setNoWaringFlags :: DynFlags -> DynFlags -setNoWaringFlags df = df { warningFlags = Gap.emptyWarnFlags} +setNoWarningFlags :: DynFlags -> DynFlags +setNoWarningFlags df = df { warningFlags = E.empty} -- | Set 'DynFlags' equivalent to "-Wall". -setAllWaringFlags :: DynFlags -> DynFlags -setAllWaringFlags df = df { warningFlags = allWarningFlags } +setAllWarningFlags :: DynFlags -> DynFlags +setAllWarningFlags df = df { warningFlags = allWarningFlags } {-# NOINLINE allWarningFlags #-} -allWarningFlags :: Gap.WarnFlags +allWarningFlags :: E.EnumSet WarningFlag allWarningFlags = unsafePerformIO $ do mlibdir <- getSystemLibDir G.runGhc mlibdir $ do diff --git a/lib/Hhp/Gap.hs b/lib/Hhp/Gap.hs --- a/lib/Hhp/Gap.hs +++ b/lib/Hhp/Gap.hs @@ -1,198 +1,122 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, CPP #-} +{-# LANGUAGE CPP #-} module Hhp.Gap ( - WarnFlags - , emptyWarnFlags - , makeUserStyle - , getModuleName - , getTyThing - , fixInfo - , getModSummaries - , LExpression - , LBinding - , LPattern - , inTypes - , outType - , HsBindLR(..) +#if __GLASGOW_HASKELL__ >= 902 + module GHC.Types.TyThing.Ppr +#else + module GHC.Core.Ppr.TyThing +#endif + , implicitTyThings + , pagemode + , getUnitState , languagesAndExtensions - , mkFunTy - , mkFunTys - , getModSummaryForMain + , setEmptyLogger + , setLinkerOptions + , setLogger + , LogAction + , SourceError + , srcErrorMessages + , pprLocErrMessage + , ErrorMessages + , locA + , LOC ) where -import Data.List (find) - -import DynFlags (DynFlags, supportedLanguagesAndExtensions) -import GHC(Ghc,getModuleGraph,moduleNameString,moduleName,ms_mod) - -import GHC (LHsBind, LHsExpr, Type) -#if __GLASGOW_HASKELL__ >= 808 -import GHC (Located, Pat) -#else -import GHC (LPat) -#endif -#if __GLASGOW_HASKELL__ >= 810 -import GHC.Hs.Expr (MatchGroup) -#else -import HsExpr (MatchGroup) -#endif -import Outputable (PrintUnqualified, PprStyle, Depth(AllTheWay), mkUserStyle) +import GHC (Ghc, DynFlags(..), GhcLink(..)) +import qualified GHC as G +import GHC.Utils.Ppr(Mode(..)) +import GHC.Unit.State (UnitState) +import GHC.Driver.Session (supportedLanguagesAndExtensions) +import GHC.Utils.Outputable (SDoc) ----------------------------------------------------------------- +#if __GLASGOW_HASKELL__ >= 902 ---------------------------------------------------------------- +import GHC (Backend(..), pushLogHookM) +import GHC.Types.TyThing.Ppr +import GHC.Types.TyThing (implicitTyThings) +import GHC.Driver.Env (hsc_units) +import GHC.Platform.Host (hostPlatformArchOS) +import GHC.Utils.Logger (LogAction) +import GHC.Utils.Error (ErrorMessages, pprLocMsgEnvelope, MsgEnvelope, DecoratedSDoc) +import GHC.Types.SourceError (SourceError, srcErrorMessages) +import GHC.Parser.Annotation (locA, LocatedA) -#if __GLASGOW_HASKELL__ >= 802 -#else -import GHC.PackageDb (ExposedModule(..)) -#endif +pagemode :: Mode +pagemode = PageMode True -#if __GLASGOW_HASKELL__ >= 804 -import DynFlags (WarningFlag) -import qualified EnumSet as E (EnumSet, empty) -import GHC (mgModSummaries, ModSummary, ModuleGraph) -#else -import qualified Data.IntSet as I (IntSet, empty) -import GHC (ModSummary) -#endif +getUnitState :: Ghc UnitState +getUnitState = hsc_units <$> G.getSession -#if __GLASGOW_HASKELL__ >= 810 -import GHC.Hs.Expr (MatchGroupTc(..)) -import GHC.Hs.Extension (GhcTc) -import GHC (mg_ext) -#elif __GLASGOW_HASKELL__ >= 806 -import HsExpr (MatchGroupTc(..)) -import HsExtension (GhcTc) -import GHC (mg_ext) -#elif __GLASGOW_HASKELL__ >= 804 -import HsExtension (GhcTc) -import GHC (mg_res_ty, mg_arg_tys) -#else -import GHC (Id, mg_res_ty, mg_arg_tys) -#endif +languagesAndExtensions :: [String] +languagesAndExtensions = supportedLanguagesAndExtensions hostPlatformArchOS -#if __GLASGOW_HASKELL__ >= 810 -import GHC.Hs.Binds (HsBindLR(..)) -import GHC.Platform.Host -import Type (mkVisFunTy, mkVisFunTys) -#else -import HsBinds (HsBindLR(..)) -import Type (mkFunTy, mkFunTys) -#endif +setEmptyLogger :: DynFlags -> DynFlags +setEmptyLogger = id ----------------------------------------------------------------- ----------------------------------------------------------------- +-- we don't want to generate object code so we compile to bytecode +-- (HscInterpreted) which implies LinkInMemory +-- HscInterpreted +setLinkerOptions :: DynFlags -> DynFlags +setLinkerOptions df = df { + ghcLink = LinkInMemory + , backend = Interpreter + } -makeUserStyle :: DynFlags -> PrintUnqualified -> PprStyle -#if __GLASGOW_HASKELL__ >= 802 -makeUserStyle dflags style = mkUserStyle dflags style AllTheWay -#else -makeUserStyle _ style = mkUserStyle style AllTheWay -#endif +setLogger :: LogAction -> Ghc () +setLogger logaction = pushLogHookM (\__defaultLogAction -> logaction) -#if __GLASGOW_HASKELL__ >= 802 -getModuleName :: (a, b) -> a -getModuleName = fst -#else -getModuleName :: ExposedModule unitid modulename -> modulename -getModuleName = exposedName -#endif +pprLocErrMessage :: MsgEnvelope DecoratedSDoc -> SDoc +pprLocErrMessage = pprLocMsgEnvelope +type LOC = LocatedA ---------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ >= 804 -type WarnFlags = E.EnumSet WarningFlag -emptyWarnFlags :: WarnFlags -emptyWarnFlags = E.empty #else -type WarnFlags = I.IntSet -emptyWarnFlags :: WarnFlags -emptyWarnFlags = I.empty -#endif - -#if __GLASGOW_HASKELL__ >= 804 -getModSummaries :: ModuleGraph -> [ModSummary] -getModSummaries = mgModSummaries - -getTyThing :: (a, b, c, d, e) -> a -getTyThing (t,_,_,_,_) = t - -fixInfo :: (a, b, c, d, e) -> (a, b, c, d) -fixInfo (t,f,cs,fs,_) = (t,f,cs,fs) -#else -getModSummaries :: a -> a -getModSummaries = id - -getTyThing :: (a, b, c, d) -> a -getTyThing (t,_,_,_) = t - -fixInfo :: (a, b, c, d) -> (a, b, c, d) -fixInfo = id -#endif - ---------------------------------------------------------------- +import GHC (HscTarget(..), getSessionDynFlags, setSessionDynFlags, Located) +import GHC.Core.Ppr.TyThing +import GHC.Driver.Session (LogAction) +import GHC.Driver.Types (implicitTyThings) +import GHC.Platform.Host (cHostPlatformMini) +import GHC.Driver.Types (SourceError, srcErrorMessages) +import GHC.Utils.Error (ErrMsg, pprLocErrMsg) +import GHC.Data.Bag (Bag) -#if __GLASGOW_HASKELL__ >= 808 -type LExpression = LHsExpr GhcTc -type LBinding = LHsBind GhcTc -type LPattern = Located (Pat GhcTc) +import Control.Monad (void) -inTypes :: MatchGroup GhcTc LExpression -> [Type] -inTypes = mg_arg_tys . mg_ext -outType :: MatchGroup GhcTc LExpression -> Type -outType = mg_res_ty . mg_ext -#elif __GLASGOW_HASKELL__ >= 806 -type LExpression = LHsExpr GhcTc -type LBinding = LHsBind GhcTc -type LPattern = LPat GhcTc +pagemode :: Mode +pagemode = PageMode -inTypes :: MatchGroup GhcTc LExpression -> [Type] -inTypes = mg_arg_tys . mg_ext -outType :: MatchGroup GhcTc LExpression -> Type -outType = mg_res_ty . mg_ext -#elif __GLASGOW_HASKELL__ >= 804 -type LExpression = LHsExpr GhcTc -type LBinding = LHsBind GhcTc -type LPattern = LPat GhcTc +getUnitState :: Ghc UnitState +getUnitState = G.unitState <$> G.getSessionDynFlags -inTypes :: MatchGroup GhcTc LExpression -> [Type] -inTypes = mg_arg_tys -outType :: MatchGroup GhcTc LExpression -> Type -outType = mg_res_ty -#else -type LExpression = LHsExpr Id -type LBinding = LHsBind Id -type LPattern = LPat Id +languagesAndExtensions :: [String] +languagesAndExtensions = supportedLanguagesAndExtensions cHostPlatformMini -inTypes :: MatchGroup Id LExpression -> [Type] -inTypes = mg_arg_tys -outType :: MatchGroup Id LExpression -> Type -outType = mg_res_ty -#endif +setEmptyLogger :: DynFlags -> DynFlags +setEmptyLogger df = df { G.log_action = \_ _ _ _ _ -> return () } ----------------------------------------------------------------- +-- we don't want to generate object code so we compile to bytecode +-- (HscInterpreted) which implies LinkInMemory +-- HscInterpreted +setLinkerOptions :: DynFlags -> DynFlags +setLinkerOptions df = df { + ghcLink = LinkInMemory + , hscTarget = HscInterpreted + } -languagesAndExtensions :: [String] -#if __GLASGOW_HASKELL__ >= 810 -languagesAndExtensions = supportedLanguagesAndExtensions cHostPlatformMini -#else -languagesAndExtensions = supportedLanguagesAndExtensions -#endif +setLogger :: LogAction -> Ghc () +setLogger logaction = do + dflag <- getSessionDynFlags + void $ setSessionDynFlags dflag { log_action = logaction } -#if __GLASGOW_HASKELL__ >= 810 -mkFunTy :: Type -> Type -> Type -mkFunTy = mkVisFunTy +pprLocErrMessage :: ErrMsg -> SDoc +pprLocErrMessage = pprLocErrMsg -mkFunTys :: [Type] -> Type -> Type -mkFunTys = mkVisFunTys -#endif +type ErrorMessages = Bag ErrMsg ----------------------------------------------------------------- +locA :: a -> a +locA = id -getModSummaryForMain :: Ghc (Maybe ModSummary) -#if __GLASGOW_HASKELL__ >= 804 -getModSummaryForMain = find isMain . mgModSummaries <$> getModuleGraph -#else -getModSummaryForMain = find isMain <$> getModuleGraph +type LOC = Located +---------------------------------------------------------------- #endif - where - isMain m = moduleNameString (moduleName (ms_mod m)) == "Main" diff --git a/lib/Hhp/Ghc.hs b/lib/Hhp/Ghc.hs --- a/lib/Hhp/Ghc.hs +++ b/lib/Hhp/Ghc.hs @@ -27,22 +27,21 @@ , Ghc ) where +import GHC (Ghc, runGhc, ModSummary, mgModSummaries, getModuleGraph,moduleNameString, moduleName, ms_mod) +import qualified GHC as G +import GHC.Utils.Monad (liftIO) + +import Data.List (find) +import Data.Maybe (fromMaybe) + import Hhp.Boot import Hhp.Browse import Hhp.Check import Hhp.Find import Hhp.GHCApi -import Hhp.Gap import Hhp.Info import Hhp.List -import GHC (runGhc) -import CoreMonad (liftIO) -import GHC (Ghc) -import qualified GHC as G - -import Data.Maybe (fromMaybe) - getMainFileToBeDeleted :: FilePath -> Ghc (Maybe FilePath) getMainFileToBeDeleted file = isSameMainFile file <$> getModSummaryForMain @@ -56,3 +55,8 @@ -- G.ms_hspp_file x is a temporary file with CPP. -- this is a just fake. mainfile = fromMaybe (G.ms_hspp_file x) mmainfile + +getModSummaryForMain :: Ghc (Maybe ModSummary) +getModSummaryForMain = find isMain . mgModSummaries <$> getModuleGraph + where + isMain m = moduleNameString (moduleName (ms_mod m)) == "Main" diff --git a/lib/Hhp/GhcPkg.hs b/lib/Hhp/GhcPkg.hs --- a/lib/Hhp/GhcPkg.hs +++ b/lib/Hhp/GhcPkg.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns, ScopedTypeVariables, TupleSections #-} + module Hhp.GhcPkg ( ghcPkgList , ghcPkgListEx @@ -10,7 +11,7 @@ , getPackageDbStack ) where -import Config (cProjectVersionInt) -- ghc version +import GHC.Settings.Config (cProjectVersionInt) -- ghc version import Control.Exception (SomeException(..)) import qualified Control.Exception as E diff --git a/lib/Hhp/Info.hs b/lib/Hhp/Info.hs --- a/lib/Hhp/Info.hs +++ b/lib/Hhp/Info.hs @@ -7,28 +7,29 @@ , types ) where -import CoreMonad (liftIO) -import CoreUtils (exprType) -import Desugar (deSugarExpr) -import Exception (ghandle, SomeException(..)) -import GHC (Ghc, TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L)) +import GHC (Ghc, TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L), ModSummary, mgModSummaries, mg_ext, LHsBind, Type, LPat, LHsExpr) import qualified GHC as G - -import HscTypes (ModSummary) -import Outputable (PprStyle) -import PprTyThing -import TcHsSyn (hsPatType) +import GHC.Core.Type (mkVisFunTys) +import GHC.Core.Utils (exprType) +import GHC.Hs.Binds (HsBindLR(..)) +import GHC.Hs.Expr (MatchGroupTc(..)) +import GHC.Hs.Extension (GhcTc) +import GHC.HsToCore (deSugarExpr) +import GHC.Tc.Utils.Zonk (hsPatType) +import GHC.Utils.Monad (liftIO) +import GHC.Utils.Outputable (PprStyle) import Control.Applicative ((<|>)) import Control.Monad (filterM) +import Control.Monad.Catch (SomeException(..), handle, bracket) import Data.Function (on) import Data.List (sortBy) import Data.Maybe (catMaybes, fromMaybe) import Data.Ord as O import Hhp.Doc (showPage, showOneLine, getStyle) -import Hhp.GHCApi import Hhp.Gap +import Hhp.GHCApi import Hhp.Logger (getSrcSpan) import Hhp.Syb import Hhp.Things @@ -51,12 +52,12 @@ -> FilePath -- ^ A target file. -> Expression -- ^ A Haskell expression. -> Ghc String -info opt file expr = convert opt <$> ghandle handler body +info opt file expr = convert opt <$> handle handler body where body = inModuleContext file $ \dflag style -> do sdoc <- infoThing expr return $ showPage dflag style sdoc - handler (SomeException _) = return "Cannot show info" + handler (SomeException _e) = return $ "Cannot show info: " ++ show _e ---------------------------------------------------------------- @@ -77,7 +78,7 @@ -> Int -- ^ Line number. -> Int -- ^ Column number. -> Ghc String -types opt file lineNo colNo = convert opt <$> ghandle handler body +types opt file lineNo colNo = convert opt <$> handle handler body where body = inModuleContext file $ \dflag style -> do modSum <- fileModSummary file @@ -85,16 +86,20 @@ return $ map (toTup dflag style) $ sortBy (cmp `on` fst) srcSpanTypes handler (SomeException _) = return [] -getSrcSpanType :: G.ModSummary -> Int -> Int -> Ghc [(SrcSpan, Type)] +type LExpression = LHsExpr GhcTc +type LBinding = LHsBind GhcTc +type LPattern = LPat GhcTc + +getSrcSpanType :: ModSummary -> Int -> Int -> Ghc [(SrcSpan, Type)] getSrcSpanType modSum lineNo colNo = do p <- G.parseModule modSum tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p let es = listifySpans tcs (lineNo, colNo) :: [LExpression] bs = listifySpans tcs (lineNo, colNo) :: [LBinding] ps = listifySpans tcs (lineNo, colNo) :: [LPattern] - ets <- mapM (getType tcm) es - bts <- mapM (getType tcm) bs - pts <- mapM (getType tcm) ps + ets <- mapM (getTypeLExpression tcm) es + bts <- mapM (getTypeLBinding tcm) bs + pts <- mapM (getTypeLPattern tcm) ps return $ catMaybes $ concat [ets, bts, pts] cmp :: SrcSpan -> SrcSpan -> Ordering @@ -116,23 +121,23 @@ inModuleContext :: FilePath -> (DynFlags -> PprStyle -> Ghc a) -> Ghc a inModuleContext file action = - withDynFlags (setWarnTypedHoles . setDeferTypeErrors . setNoWaringFlags) $ do + withDynFlags (setWarnTypedHoles . setDeferTypeErrors . setNoWarningFlags) $ do setTargetFiles [file] withContext $ do dflag <- G.getSessionDynFlags - style <- getStyle dflag + style <- getStyle action dflag style ---------------------------------------------------------------- fileModSummary :: FilePath -> Ghc ModSummary fileModSummary file = do - mss <- getModSummaries <$> G.getModuleGraph + mss <- mgModSummaries <$> G.getModuleGraph let [ms] = filter (\m -> G.ml_hs_file (G.ms_location m) == Just file) mss return ms withContext :: Ghc a -> Ghc a -withContext action = G.gbracket setup teardown body +withContext action = bracket setup teardown body where setup = G.getContext teardown = setCtx @@ -140,7 +145,7 @@ topImports >>= setCtx action topImports = do - mss <- getModSummaries <$> G.getModuleGraph + mss <- mgModSummaries <$> G.getModuleGraph map modName <$> filterM isTop mss isTop mos = lookupMod mos <|> returnFalse lookupMod mos = G.lookupModule (G.ms_mod_name mos) Nothing >> return True @@ -150,22 +155,21 @@ ---------------------------------------------------------------- -class HasType a where - getType :: TypecheckedModule -> a -> Ghc (Maybe (SrcSpan, Type)) - -instance HasType LExpression where - getType _ e = do - hs_env <- G.getSession - mbe <- liftIO $ snd <$> deSugarExpr hs_env e - return $ (G.getLoc e, ) . CoreUtils.exprType <$> mbe +getTypeLExpression :: TypecheckedModule -> LExpression -> Ghc (Maybe (SrcSpan, Type)) +getTypeLExpression _ e@(L spnA _) = do + hs_env <- G.getSession + (_, mbc) <- liftIO $ deSugarExpr hs_env e + let spn = locA spnA + return $ (spn, ) . exprType <$> mbc -instance HasType LBinding where - getType _ (L spn FunBind{fun_matches = m}) = return $ Just (spn, typ) - where - in_tys = inTypes m - out_typ = outType m - typ = mkFunTys in_tys out_typ - getType _ _ = return Nothing +getTypeLBinding :: TypecheckedModule -> LBinding -> Ghc (Maybe (SrcSpan, Type)) +getTypeLBinding _ (L spnA FunBind{fun_matches = m}) = return $ Just (spn, typ) + where + in_tys = mg_arg_tys $ mg_ext m + out_typ = mg_res_ty $ mg_ext m + typ = mkVisFunTys in_tys out_typ + spn = locA spnA +getTypeLBinding _ _ = return Nothing -instance HasType LPattern where - getType _ (G.L spn pat) = return $ Just (spn, hsPatType pat) +getTypeLPattern :: TypecheckedModule -> LPattern -> Ghc (Maybe (SrcSpan, Type)) +getTypeLPattern _ (L spnA pat) = return $ Just (locA spnA, hsPatType pat) diff --git a/lib/Hhp/Internal.hs b/lib/Hhp/Internal.hs --- a/lib/Hhp/Internal.hs +++ b/lib/Hhp/Internal.hs @@ -22,8 +22,8 @@ , setTargetFiles -- * Logging , withLogger - , setNoWaringFlags - , setAllWaringFlags + , setNoWarningFlags + , setAllWarningFlags ) where import Hhp.CabalApi diff --git a/lib/Hhp/Lang.hs b/lib/Hhp/Lang.hs --- a/lib/Hhp/Lang.hs +++ b/lib/Hhp/Lang.hs @@ -4,6 +4,5 @@ import Hhp.Types -- | Listing language extensions. - listLanguages :: Options -> IO String -listLanguages opt = return $ convert opt $ languagesAndExtensions +listLanguages opt = return $ convert opt languagesAndExtensions diff --git a/lib/Hhp/List.hs b/lib/Hhp/List.hs --- a/lib/Hhp/List.hs +++ b/lib/Hhp/List.hs @@ -1,14 +1,16 @@ module Hhp.List (listModules, modules) where -import DynFlags (DynFlags) import GHC (Ghc) import qualified GHC as G -import Module (moduleNameString, moduleName) -import Packages (lookupModuleInAllPackages, listVisibleModuleNames) -import Control.Exception (SomeException(..)) +import GHC.Unit.Module.Name (moduleNameString) +import GHC.Unit.State (lookupModuleInAllUnits, listVisibleModuleNames) +import GHC.Unit.Types (moduleName) + +import Control.Monad.Catch (SomeException(..), catch) import Data.List (nub, sort) +import Hhp.Gap import Hhp.GHCApi import Hhp.Types @@ -22,16 +24,15 @@ -- | Listing installed modules. modules :: Options -> Ghc String -modules opt = convert opt . arrange <$> (getModules `G.gcatch` handler) +modules opt = convert opt . arrange <$> (getModules `catch` handler) where - getModules = listVisibleModules <$> G.getSessionDynFlags arrange = nub . sort . map (moduleNameString . moduleName) handler (SomeException _) = return [] ---------------------------------------------------------------- -listVisibleModules :: DynFlags -> [G.Module] -listVisibleModules df = mods - where - modNames = listVisibleModuleNames df - mods = [ m | mn <- modNames, (m, _) <- lookupModuleInAllPackages df mn ] +getModules :: Ghc [G.Module] +getModules = do + us <- getUnitState + let modNames = listVisibleModuleNames us + return [ m | mn <- modNames, (m, _) <- lookupModuleInAllUnits us mn ] diff --git a/lib/Hhp/Logger.hs b/lib/Hhp/Logger.hs --- a/lib/Hhp/Logger.hs +++ b/lib/Hhp/Logger.hs @@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} module Hhp.Logger ( withLogger @@ -7,26 +6,23 @@ , getSrcSpan ) where -import Bag (Bag, bagToList) -import CoreMonad (liftIO) -import DynFlags (LogAction, dopt, DumpFlag(Opt_D_dump_splices)) -import ErrUtils -import Exception (ghandle) -import FastString (unpackFS) import GHC (Ghc, DynFlags(..), SrcSpan(..)) -#if __GLASGOW_HASKELL__ < 808 -import GHC (Severity(SevError)) -#endif import qualified GHC as G -import HscTypes (SourceError, srcErrorMessages) -import Outputable (PprStyle, SDoc) +import GHC.Data.Bag (bagToList) +import GHC.Data.FastString (unpackFS) +import GHC.Driver.Session (dopt, DumpFlag(Opt_D_dump_splices)) +import GHC.Utils.Error (Severity(..), errMsgSpan) +import GHC.Utils.Monad (liftIO) +import GHC.Utils.Outputable (PprStyle, SDoc, defaultDumpStyle) +import Control.Monad.Catch (handle) import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef) import Data.List (isPrefixOf) import Data.Maybe (fromMaybe) import System.FilePath (normalise) import Hhp.Doc (showPage, getStyle) +import Hhp.Gap import Hhp.GHCApi (withDynFlags, withCmdFlags) import Hhp.Types (Options(..), convert) @@ -45,10 +41,10 @@ writeIORef ref id return $! convert opt (b []) -appendLogRef :: DynFlags -> LogRef -> LogAction -appendLogRef df (LogRef ref) _ _ sev src style msg = do - let !l = ppMsg src sev df style msg - modifyIORef ref (\b -> b . (l:)) +appendLogRef :: LogRef -> LogAction +appendLogRef (LogRef ref) df _mc sev src msg = do + let !l = ppMsg src sev df msg + modifyIORef ref (\b -> b . (l:)) ---------------------------------------------------------------- @@ -56,14 +52,14 @@ -- executes a body. Log messages are returned as 'String'. -- Right is success and Left is failure. withLogger :: Options -> (DynFlags -> DynFlags) -> Ghc () -> Ghc (Either String String) -withLogger opt setDF body = ghandle (sourceError opt) $ do +withLogger opt setDF body = handle (sourceError opt) $ do logref <- liftIO newLogRef - withDynFlags (setLogger logref . setDF) $ do + withDynFlags setDF $ do withCmdFlags wflags $ do + setLogger $ appendLogRef logref body liftIO $ Right <$> readAndClearLogRef opt logref where - setLogger logref df = df { log_action = appendLogRef df logref } wflags = filter ("-fno-warn" `isPrefixOf`) $ ghcOpts opt ---------------------------------------------------------------- @@ -72,27 +68,24 @@ sourceError :: Options -> SourceError -> Ghc (Either String String) sourceError opt err = do dflag <- G.getSessionDynFlags - style <- getStyle dflag + style <- getStyle let ret = convert opt . errBagToStrList dflag style . srcErrorMessages $ err return (Left ret) -errBagToStrList :: DynFlags -> PprStyle -> Bag ErrMsg -> [String] -errBagToStrList dflag style = map (ppErrMsg dflag style) . reverse . bagToList - ----------------------------------------------------------------- - -ppErrMsg :: DynFlags -> PprStyle -> ErrMsg -> String -ppErrMsg dflag style err = ppMsg spn SevError dflag style msg -- ++ ext - where - spn = errMsgSpan err - msg = pprLocErrMsg err - -- fixme --- ext = showPage dflag style (pprLocErrMsg $ errMsgReason err) +errBagToStrList :: DynFlags -> PprStyle -> ErrorMessages -> [String] +errBagToStrList dflag style = map (ppErrMsg style) . reverse . bagToList + where + ppErrMsg _style_fixme err = ppMsg spn SevError dflag msg -- ++ ext + where + spn = errMsgSpan err + msg = pprLocErrMessage err + -- fixme + -- ext = showPage dflag style (pprLocErrMsg $ errMsgReason err) -ppMsg :: SrcSpan -> Severity-> DynFlags -> PprStyle -> SDoc -> String -ppMsg spn sev dflag style msg = prefix ++ cts +ppMsg :: SrcSpan -> Severity -> DynFlags -> SDoc -> String +ppMsg spn sev dflag msg = prefix ++ cts where - cts = showPage dflag style msg + cts = showPage dflag defaultDumpStyle msg defaultPrefix | isDumpSplices dflag = "" | otherwise = checkErrorPrefix @@ -110,15 +103,15 @@ showSeverityCaption _ = "" getSrcFile :: SrcSpan -> Maybe String -getSrcFile (G.RealSrcSpan spn) = Just . unpackFS . G.srcSpanFile $ spn -getSrcFile _ = Nothing +getSrcFile (G.RealSrcSpan spn _) = Just . unpackFS . G.srcSpanFile $ spn +getSrcFile _ = Nothing isDumpSplices :: DynFlags -> Bool isDumpSplices dflag = dopt Opt_D_dump_splices dflag getSrcSpan :: SrcSpan -> Maybe (Int,Int,Int,Int) -getSrcSpan (RealSrcSpan spn) = Just ( G.srcSpanStartLine spn - , G.srcSpanStartCol spn - , G.srcSpanEndLine spn - , G.srcSpanEndCol spn) +getSrcSpan (RealSrcSpan spn _) = Just ( G.srcSpanStartLine spn + , G.srcSpanStartCol spn + , G.srcSpanEndLine spn + , G.srcSpanEndCol spn) getSrcSpan _ = Nothing diff --git a/lib/Hhp/Syb.hs b/lib/Hhp/Syb.hs --- a/lib/Hhp/Syb.hs +++ b/lib/Hhp/Syb.hs @@ -4,14 +4,16 @@ listifySpans ) where -import GHC (TypecheckedSource, Located, GenLocated(L), isGoodSrcSpan, spans) +import GHC (TypecheckedSource, GenLocated(L), isGoodSrcSpan, spans) -import Data.Generics +import Data.Generics (Typeable, GenericQ, mkQ, gmapQ) -listifySpans :: Typeable a => TypecheckedSource -> (Int, Int) -> [Located a] +import Hhp.Gap + +listifySpans :: Typeable a => TypecheckedSource -> (Int, Int) -> [LOC a] listifySpans tcs lc = everything' (++) ([] `mkQ` (\x -> [x | p x])) tcs where - p (L spn _) = isGoodSrcSpan spn && spn `spans` lc + p (L spn _) = isGoodSrcSpan (locA spn) && (locA spn) `spans` lc everything' :: (r -> r -> r) -> GenericQ r -> GenericQ r everything' k f x = foldl k (f x) $ gmapQ (everything' k f) x diff --git a/lib/Hhp/Things.hs b/lib/Hhp/Things.hs --- a/lib/Hhp/Things.hs +++ b/lib/Hhp/Things.hs @@ -4,23 +4,21 @@ , infoThing ) where -import ConLike (ConLike(..)) -import FamInstEnv -import GHC -import HscTypes -import qualified InstEnv -import NameSet -import Outputable -import PatSyn -import PprTyThing -import Var (varType) +import GHC (Type, TyCon, Ghc, Fixity, TyThing) +import qualified GHC as G +import GHC.Core.ConLike (ConLike(..)) +import GHC.Core.DataCon (dataConNonlinearType) +import GHC.Core.FamInstEnv (pprFamInsts) +import qualified GHC.Core.InstEnv as InstEnv +import GHC.Core.PatSyn (PatSyn) +import GHC.Types.Name.Set (elemNameSet, mkNameSet) +import GHC.Types.Var (varType) +import GHC.Utils.Outputable as Outputable import Data.List (intersperse) import Data.Maybe (catMaybes) -import Hhp.Gap (getTyThing, fixInfo) - --- from ghc/InteractiveUI.hs +import Hhp.Gap ---------------------------------------------------------------- @@ -30,28 +28,31 @@ | GtPatSyn PatSyn fromTyThing :: TyThing -> GapThing -fromTyThing (AnId i) = GtA $ varType i -fromTyThing (AConLike (RealDataCon d)) = GtA $ dataConUserType d -fromTyThing (AConLike (PatSynCon p)) = GtPatSyn p -fromTyThing (ATyCon t) = GtT t -fromTyThing _ = GtN +fromTyThing (G.AnId i) = GtA $ varType i +fromTyThing (G.AConLike (RealDataCon d)) = GtA $ dataConNonlinearType d +fromTyThing (G.AConLike (PatSynCon p)) = GtPatSyn p +fromTyThing (G.ATyCon t) = GtT t +fromTyThing _ = GtN ---------------------------------------------------------------- infoThing :: String -> Ghc SDoc infoThing str = do - names <- parseName str - mb_stuffs <- mapM (getInfo False) names + names <- G.parseName str + mb_stuffs <- mapM (G.getInfo False) names let filtered = filterOutChildren getTyThing $ catMaybes mb_stuffs return $ vcat (intersperse (text "") $ map (pprInfo . fixInfo) filtered) + where + getTyThing (t,_,_,_,_) = t + fixInfo (t,f,cs,fs,_) = (t,f,cs,fs) filterOutChildren :: (a -> TyThing) -> [a] -> [a] filterOutChildren get_thing xs - = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)] + = [x | x <- xs, not (G.getName (get_thing x) `elemNameSet` implicits)] where - implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)] + implicits = mkNameSet [G.getName t | x <- xs, t <- implicitTyThings (get_thing x)] -pprInfo :: (TyThing, GHC.Fixity, [InstEnv.ClsInst], [FamInst]) -> SDoc +pprInfo :: (TyThing, GHC.Fixity, [InstEnv.ClsInst], [G.FamInst]) -> SDoc pprInfo (thing, fixity, insts, famInsts) = pprTyThingInContextLoc thing $$ show_fixity fixity @@ -59,5 +60,5 @@ $$ pprFamInsts famInsts where show_fixity fx - | fx == defaultFixity = Outputable.empty - | otherwise = ppr fx <+> ppr (getName thing) + | fx == G.defaultFixity = Outputable.empty + | otherwise = ppr fx <+> ppr (G.getName thing) diff --git a/lib/Hhp/Types.hs b/lib/Hhp/Types.hs --- a/lib/Hhp/Types.hs +++ b/lib/Hhp/Types.hs @@ -4,7 +4,7 @@ module Hhp.Types where -import qualified Exception as GE +import Control.Monad.Catch (catch) import GHC (Ghc) import Control.Exception (IOException) @@ -203,5 +203,5 @@ } deriving (Eq, Show) instance Alternative Ghc where - x <|> y = x `GE.gcatch` (\(_ :: IOException) -> y) + x <|> y = x `catch` (\(_ :: IOException) -> y) empty = undefined diff --git a/test/CabalApiSpec.hs b/test/CabalApiSpec.hs --- a/test/CabalApiSpec.hs +++ b/test/CabalApiSpec.hs @@ -3,47 +3,33 @@ module CabalApiSpec where import Control.Exception -import Data.Maybe -import System.Directory import System.Environment (unsetEnv, setEnv) -import System.FilePath import Test.Hspec import Hhp.CabalApi -import Hhp.Cradle -import Hhp.Types -import Dir - -import Config (cProjectVersionInt) -- ghc version - -ghcVersion :: Int -ghcVersion = read cProjectVersionInt - - spec :: Spec spec = do describe "parseCabalFile" $ do it "throws an exception if the cabal file is broken" $ do parseCabalFile "test/data/broken-cabal/broken.cabal" `shouldThrow` (\(_::IOException) -> True) +{- For success, "test/data/cabal.sandbox.config" must contain absolute paths. describe "getCompilerOptions" $ do it "gets necessary CompilerOptions" $ do - cwd <- getCurrentDirectory withDirectory "test/data/subdir1/subdir2" $ \dir -> do cradle <- findCradle pkgDesc <- parseCabalFile $ fromJust $ cradleCabalFile cradle + print cradle res <- getCompilerOptions [] cradle pkgDesc let res' = res { ghcOptions = ghcOptions res , includeDirs = map (toRelativeDir dir) (includeDirs res) } - if ghcVersion < 706 - then ghcOptions res' `shouldBe` ["-global-package-conf", "-no-user-package-conf","-package-conf",cwd "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d","-XHaskell98"] - else ghcOptions res' `shouldBe` ["-global-package-db", "-no-user-package-db","-package-db",cwd "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d","-XHaskell98"] + ghcOptions res' `shouldBe` ["-global-package-db", "-no-user-package-db","-package-db","test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d","-XHaskell98"] includeDirs res' `shouldBe` ["test/data","test/data/dist/build","test/data/dist/build/autogen","test/data/subdir1/subdir2","test/data/test"] depPackages res' `shouldSatisfy` (("Cabal", "1.18.1.3", "2b161c6bf77657aa17e1681d83cb051b")`elem`) - +-} describe "cabalDependPackages" $ do it "extracts dependent packages" $ do diff --git a/test/CheckSpec.hs b/test/CheckSpec.hs --- a/test/CheckSpec.hs +++ b/test/CheckSpec.hs @@ -22,7 +22,7 @@ withDirectory_ "test/data/check-test-subdir" $ do cradle <- findCradleWithoutSandbox 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]\n") `isSuffixOf`) + res `shouldSatisfy` (("test" "Foo.hs:3:1:Warning: Top-level binding with no type signature: foo :: String\n") `isSuffixOf`) it "can detect mutually imported modules" $ do withDirectory_ "test/data" $ do diff --git a/test/GhcPkgSpec.hs b/test/GhcPkgSpec.hs --- a/test/GhcPkgSpec.hs +++ b/test/GhcPkgSpec.hs @@ -1,7 +1,5 @@ module GhcPkgSpec where -import System.Directory -import System.FilePath (()) import Test.Hspec import Hhp.Types @@ -11,9 +9,8 @@ spec = do describe "getSandboxDb" $ do it "parses a config file and extracts sandbox package db" $ do - cwd <- getCurrentDirectory pkgDb <- getSandboxDb "test/data/" - pkgDb `shouldBe` (cwd "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d") + pkgDb `shouldBe` "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d" it "throws an error if a config file is broken" $ do getSandboxDb "test/data/broken-sandbox" `shouldThrow` anyException diff --git a/test/Main.hs b/test/Main.hs deleted file mode 100644 --- a/test/Main.hs +++ /dev/null @@ -1,13 +0,0 @@ -import Spec -import Dir - -import Test.Hspec -import System.Process - -main :: IO () -main = do - let sandboxes = [ "test/data", "test/data/check-packageid" ] - genSandboxCfg dir = withDirectory dir $ \cwdir -> do - system ("sed 's|@CWD@|" ++ cwdir ++ "|g' cabal.sandbox.config.in > cabal.sandbox.config") - genSandboxCfg `mapM_` sandboxes - hspec spec diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,1 +1,1 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-} +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/doctests.hs b/test/doctests.hs --- a/test/doctests.hs +++ b/test/doctests.hs @@ -8,10 +8,6 @@ main = doctest [ "-package" , "ghc" -#if MIN_VERSION_hlint(2,1,18) - , "-hide-package" - , "ghc-lib-parser" -#endif , "-ilib/" , "-idist/build/autogen/" , "-optP-include"