hhp 0.0.4 → 1.0.0
raw patch · 28 files changed
+359/−505 lines, 28 filesdep +exceptions
Dependencies added: exceptions
Files
- hhp.cabal +9/−6
- lib/Hhp.hs +2/−1
- lib/Hhp/Boot.hs +1/−1
- lib/Hhp/Browse.hs +15/−18
- lib/Hhp/CabalApi.hs +19/−66
- lib/Hhp/Check.hs +3/−3
- lib/Hhp/Debug.hs +1/−1
- lib/Hhp/Doc.hs +29/−14
- lib/Hhp/Find.hs +20/−16
- lib/Hhp/Flag.hs +1/−1
- lib/Hhp/GHCApi.hs +19/−33
- lib/Hhp/Gap.hs +92/−168
- lib/Hhp/Ghc.hs +12/−8
- lib/Hhp/GhcPkg.hs +2/−1
- lib/Hhp/Info.hs +44/−40
- lib/Hhp/Internal.hs +2/−2
- lib/Hhp/Lang.hs +1/−2
- lib/Hhp/List.hs +12/−11
- lib/Hhp/Logger.hs +34/−41
- lib/Hhp/Syb.hs +6/−4
- lib/Hhp/Things.hs +26/−25
- lib/Hhp/Types.hs +2/−2
- test/CabalApiSpec.hs +4/−18
- test/CheckSpec.hs +1/−1
- test/GhcPkgSpec.hs +1/−4
- test/Main.hs +0/−13
- test/Spec.hs +1/−1
- test/doctests.hs +0/−4
hhp.cabal view
@@ -1,5 +1,5 @@ Name: hhp-Version: 0.0.4+Version: 1.0.0 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> 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
lib/Hhp.hs view
@@ -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)
lib/Hhp/Boot.hs view
@@ -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
lib/Hhp/Browse.hs view
@@ -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
lib/Hhp/CabalApi.hs view
@@ -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
lib/Hhp/Check.hs view
@@ -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
lib/Hhp/Debug.hs view
@@ -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)
lib/Hhp/Doc.hs view
@@ -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
lib/Hhp/Find.hs view
@@ -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
lib/Hhp/Flag.hs view
@@ -1,6 +1,6 @@ module Hhp.Flag where -import DynFlags+import GHC.Driver.Session (flagSpecName, fFlags, wWarningFlags, fLangFlags) import Hhp.Types
lib/Hhp/GHCApi.hs view
@@ -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
lib/Hhp/Gap.hs view
@@ -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"
lib/Hhp/Ghc.hs view
@@ -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"
lib/Hhp/GhcPkg.hs view
@@ -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
lib/Hhp/Info.hs view
@@ -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)
lib/Hhp/Internal.hs view
@@ -22,8 +22,8 @@ , setTargetFiles -- * Logging , withLogger- , setNoWaringFlags- , setAllWaringFlags+ , setNoWarningFlags+ , setAllWarningFlags ) where import Hhp.CabalApi
lib/Hhp/Lang.hs view
@@ -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
lib/Hhp/List.hs view
@@ -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 ]
lib/Hhp/Logger.hs view
@@ -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
lib/Hhp/Syb.hs view
@@ -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
lib/Hhp/Things.hs view
@@ -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)
lib/Hhp/Types.hs view
@@ -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
test/CabalApiSpec.hs view
@@ -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
test/CheckSpec.hs view
@@ -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
test/GhcPkgSpec.hs view
@@ -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
− test/Main.hs
@@ -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
test/Spec.hs view
@@ -1,1 +1,1 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-}+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
test/doctests.hs view
@@ -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"