From e3427d154045956af734fea71796142348fc7d37 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Sun, 11 Feb 2018 21:16:19 +0200 Subject: [PATCH 1/9] Support GHC 8.4 - Add cabal-helper local copy - Remove redundant packages, bump haskell-src-exts upper bound - Relax various upper bounds --- cabal.project | 1 + core/GhcMod/DynFlagsTH.hs | 37 +++++++++- core/GhcMod/Error.hs | 1 + core/GhcMod/Gap.hs | 85 ++++++++++++++++++---- core/GhcMod/LightGhc.hs | 8 +++ core/GhcMod/Logger.hs | 2 +- core/GhcMod/Options/Help.hs | 8 ++- core/GhcMod/Pretty.hs | 1 + core/GhcMod/SrcUtils.hs | 79 +++++++++++++++++---- core/GhcMod/Target.hs | 138 +++++++++++++++++++++++++++++++----- core/GhcMod/Types.hs | 10 +++ core/GhcModCore.hs | 4 ++ core/LICENSE | 1 + core/ghc-mod-core.cabal | 16 ++--- ghc-mod.cabal | 40 +++++------ test/CabalHelperSpec.hs | 2 +- test/CheckSpec.hs | 6 +- test/TestUtils.hs | 6 ++ 18 files changed, 363 insertions(+), 82 deletions(-) create mode 100644 core/LICENSE diff --git a/cabal.project b/cabal.project index 0d3711349..4b8b8e5f2 100644 --- a/cabal.project +++ b/cabal.project @@ -1,2 +1,3 @@ packages: . ./core + ../cabal-helper diff --git a/core/GhcMod/DynFlagsTH.hs b/core/GhcMod/DynFlagsTH.hs index 776c588f9..46827958e 100644 --- a/core/GhcMod/DynFlagsTH.hs +++ b/core/GhcMod/DynFlagsTH.hs @@ -22,7 +22,13 @@ module GhcMod.DynFlagsTH where import Language.Haskell.TH import Language.Haskell.TH.Syntax import Control.Applicative +#if __GLASGOW_HASKELL__ >= 804 +import GHC.LanguageExtensions +import qualified EnumSet as E +import qualified Data.Set as IS +#else import qualified Data.IntSet as IS +#endif import Data.Maybe import Data.Generics.Aliases import Data.Generics.Schemes @@ -83,6 +89,10 @@ deriveEqDynFlags qds = do , "FlushOut" , "FlushErr" , "Settings" -- I think these can't cange at runtime + , "LogFinaliser" -- added for ghc-8.2 + , "LogOutput" -- added for ghc-8.2 + , "OverridingBool" -- added for ghc-8.2 + , "Scheme" -- added for ghc-8.2 ] ignoredTypeOccNames = [ "OnOff" ] @@ -164,13 +174,26 @@ deriveEqDynFlags qds = do "generalFlags" -> checkIntSet "generalFlags" "warningFlags" -> checkIntSet "warningFlags" +#if __GLASGOW_HASKELL__ >= 804 + "dumpFlags" -> checkIntSet "dumpFlags" + "fatalWarningFlags" -> checkIntSet "fatalWarningFlags" + "extensionFlags" -> checkIntSet "extensionFlags" +#endif _ -> [e| [($(return fa) == $(return fb), if $(return fa) == $(return fb) then "" else ("default changed:" ++ fon) )] |] checkIntSet fieldName = do - let eqfn = [| let fn aa bb = r + let eqfn = [| let fn aa' bb' = r where +#if __GLASGOW_HASKELL__ >= 804 + aa = toSet aa' + bb = toSet bb' +#else + aa = aa' + bb = bb' +#endif + uni = IS.union aa bb dif = IS.intersection aa bb delta = IS.difference uni dif @@ -180,3 +203,15 @@ deriveEqDynFlags qds = do in fn |] [e| $(eqfn) $(return fa) $(return fb) |] + + +#if __GLASGOW_HASKELL__ >= 804 +toSet es = IS.fromList $ E.toList es + +deriving instance Ord GeneralFlag +deriving instance Ord DynFlags.WarningFlag +deriving instance Ord DynFlags.DumpFlag +deriving instance Ord DynFlags.LlvmTarget +deriving instance Ord Extension +deriving instance Eq LlvmTarget +#endif diff --git a/core/GhcMod/Error.hs b/core/GhcMod/Error.hs index 968c357b0..e04e1713a 100644 --- a/core/GhcMod/Error.hs +++ b/core/GhcMod/Error.hs @@ -49,6 +49,7 @@ import Paths_ghc_mod_core (version) import GhcMod.Types import GhcMod.Pretty +import Prelude hiding ( (<>) ) type GmError m = MonadError GhcModError m diff --git a/core/GhcMod/Gap.hs b/core/GhcMod/Gap.hs index dff6b87f3..91bed2556 100644 --- a/core/GhcMod/Gap.hs +++ b/core/GhcMod/Gap.hs @@ -47,8 +47,19 @@ module GhcMod.Gap ( , GhcMod.Gap.isSynTyCon , parseModuleHeader , mkErrStyle' +#if __GLASGOW_HASKELL__ < 804 , everythingStagedWithContext +#endif , withCleanupSession +#if __GLASGOW_HASKELL__ >= 804 + , GHC.GhcPs + , GHC.GhcRn + , GHC.GhcTc +#else + , GhcPs + , GhcRn + , GhcTc +#endif ) where import Control.Applicative hiding (empty) @@ -70,6 +81,7 @@ import NameSet import OccName import Outputable import PprTyThing +import IfaceSyn import StringBuffer import TcType import Var (varType) @@ -108,7 +120,10 @@ import TcRnTypes #endif #endif -#if MIN_VERSION_GLASGOW_HASKELL(8,0,1,20161117) +#if MIN_VERSION_GLASGOW_HASKELL(8,2,0,0) +import GHC hiding (ClsInst, withCleanupSession, setLogAction) +import qualified GHC (withCleanupSession) +#elif MIN_VERSION_GLASGOW_HASKELL(8,0,1,20161117) import GHC hiding (ClsInst, withCleanupSession) import qualified GHC (withCleanupSession) #elif __GLASGOW_HASKELL__ >= 706 @@ -125,7 +140,9 @@ import UniqFM (eltsUFM) import Module #endif -#if __GLASGOW_HASKELL__ >= 704 +#if __GLASGOW_HASKELL__ >= 804 +import qualified EnumSet as E (EnumSet, empty) +#elif __GLASGOW_HASKELL__ >= 704 import qualified Data.IntSet as I (IntSet, empty) #endif @@ -140,10 +157,12 @@ import Parser import SrcLoc import Packages import Data.Generics (GenericQ, extQ, gmapQ) +#if __GLASGOW_HASKELL__ < 804 import GHC.SYB.Utils (Stage(..)) +#endif import GhcMod.Types (Expression(..)) -import Prelude +import Prelude hiding ( (<>) ) ---------------------------------------------------------------- ---------------------------------------------------------------- @@ -284,7 +303,11 @@ fileModSummary :: GhcMonad m => FilePath -> m ModSummary fileModSummary file' = do mss <- getModuleGraph file <- liftIO $ canonicalizePath file' +#if __GLASGOW_HASKELL__ >= 804 + [ms] <- liftIO $ flip filterM (mgModSummaries mss) $ \m -> +#else [ms] <- liftIO $ flip filterM mss $ \m -> +#endif (Just file==) <$> canonicalizePath `traverse` ml_hs_file (ms_location m) return ms @@ -296,8 +319,14 @@ withInteractiveContext action = gbracket setup teardown body body _ = do topImports >>= setCtx action + topImports :: GhcMonad m => m [InteractiveImport] topImports = do +#if __GLASGOW_HASKELL__ >= 804 + mg <- getModuleGraph + ms <- filterM moduleIsInterpreted =<< map ms_mod <$> (return $ mgModSummaries mg) +#else ms <- filterM moduleIsInterpreted =<< map ms_mod <$> getModuleGraph +#endif let iis = map (IIModule . modName) ms #if __GLASGOW_HASKELL__ >= 704 return iis @@ -393,7 +422,7 @@ class HasType a where getType :: GhcMonad m => TypecheckedModule -> a -> m (Maybe (SrcSpan, Type)) -instance HasType (LHsBind Id) where +instance HasType (LHsBind GhcTc) where #if __GLASGOW_HASKELL__ >= 708 getType _ (L spn FunBind{fun_matches = m}) = return $ Just (spn, typ) where in_tys = mg_arg_tys m @@ -417,7 +446,10 @@ filterOutChildren get_thing xs infoThing :: GhcMonad m => (FilePath -> FilePath) -> Expression -> m SDoc infoThing m (Expression str) = do names <- parseName str -#if __GLASGOW_HASKELL__ >= 708 +#if __GLASGOW_HASKELL__ >= 804 + mb_stuffs <- mapM (getInfo False) names + let filtered = filterOutChildren (\(t,_f,_i,_fam,_doc) -> t) (catMaybes mb_stuffs) +#elif __GLASGOW_HASKELL__ >= 708 mb_stuffs <- mapM (getInfo False) names let filtered = filterOutChildren (\(t,_f,_i,_fam) -> t) (catMaybes mb_stuffs) #else @@ -426,7 +458,14 @@ infoThing m (Expression str) = do #endif return $ vcat (intersperse (text "") $ map (pprInfo m False) filtered) -#if __GLASGOW_HASKELL__ >= 708 +#if __GLASGOW_HASKELL__ >= 804 +pprInfo :: (FilePath -> FilePath) -> Bool -> (TyThing, GHC.Fixity, [ClsInst], [FamInst],SDoc) -> SDoc +pprInfo m _ (thing, fixity, insts, famInsts,_doc) + = pprTyThingInContextLoc' thing + $$ show_fixity fixity + $$ vcat (map pprInstance' insts) + $$ vcat (map pprFamInst' famInsts) +#elif __GLASGOW_HASKELL__ >= 708 pprInfo :: (FilePath -> FilePath) -> Bool -> (TyThing, GHC.Fixity, [ClsInst], [FamInst]) -> SDoc pprInfo m _ (thing, fixity, insts, famInsts) = pprTyThingInContextLoc' thing @@ -459,9 +498,9 @@ pprInfo m pefas (thing, fixity, insts) = showWithLoc (pprDefinedAt' (getName axiom)) $ hang (ptext (sLit "type instance") <+> pprTypeApp (coAxiomTyCon axiom) lhs_tys) 2 (equals <+> ppr rhs) -#else +# else pprFamInst' ispec = showWithLoc (pprDefinedAt' (getName ispec)) (pprFamInstHdr ispec) -#endif +# endif #else pprTyThingInContextLoc' pefas' thing' = showWithLoc (pprDefinedAt' thing') (pprTyThingInContext pefas' thing') #endif @@ -514,7 +553,7 @@ nameForUser = pprOccName . getOccName occNameForUser :: OccName -> SDoc occNameForUser = pprOccName -deSugar :: TypecheckedModule -> LHsExpr Id -> HscEnv +deSugar :: TypecheckedModule -> LHsExpr GhcTc -> HscEnv -> IO (Maybe CoreExpr) #if __GLASGOW_HASKELL__ >= 708 deSugar _ e hs_env = snd <$> deSugarExpr hs_env e @@ -555,7 +594,11 @@ fromTyThing _ = GtN ---------------------------------------------------------------- ---------------------------------------------------------------- -#if __GLASGOW_HASKELL__ >= 704 +#if __GLASGOW_HASKELL__ >= 804 +type WarnFlags = E.EnumSet WarningFlag +emptyWarnFlags :: WarnFlags +emptyWarnFlags = E.empty +#elif __GLASGOW_HASKELL__ >= 704 type WarnFlags = I.IntSet emptyWarnFlags :: WarnFlags emptyWarnFlags = I.empty @@ -568,15 +611,22 @@ emptyWarnFlags = [] ---------------------------------------------------------------- ---------------------------------------------------------------- +-- See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.4#GHCAPIchanges +#if __GLASGOW_HASKELL__ <= 802 +type GhcPs = RdrName +type GhcRn = Name +type GhcTc = Id +#endif + #if __GLASGOW_HASKELL__ >= 708 -type GLMatch = LMatch RdrName (LHsExpr RdrName) +type GLMatch = LMatch GhcPs (LHsExpr GhcPs) type GLMatchI = LMatch Id (LHsExpr Id) #else -type GLMatch = LMatch RdrName +type GLMatch = LMatch GhcPs type GLMatchI = LMatch Id #endif -getClass :: [LInstDecl Name] -> Maybe (Name, SrcSpan) +getClass :: [LInstDecl GhcRn] -> Maybe (Name, SrcSpan) #if __GLASGOW_HASKELL__ >= 802 -- Instance declarations of sort 'instance F (G a)' getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = HsIB _ (L _ (HsForAllTy _ (L _ (HsAppTy (L _ (HsTyVar _ (L _ className))) _)))) _}))] = Just (className, loc) @@ -664,7 +714,7 @@ parseModuleHeader :: String -- ^ Haskell module source text (full Unicode is supported) -> DynFlags -> FilePath -- ^ the filename (for source locations) - -> Either ErrorMessages (WarningMessages, Located (HsModule RdrName)) + -> Either ErrorMessages (WarningMessages, Located (HsModule GhcPs)) parseModuleHeader str dflags filename = let loc = mkRealSrcLoc (mkFastString filename) 1 1 @@ -672,7 +722,11 @@ parseModuleHeader str dflags filename = in case L.unP Parser.parseHeader (mkPState dflags buf loc) of +#if __GLASGOW_HASKELL__ >= 804 + PFailed _ sp err -> +#else PFailed sp err -> +#endif #if __GLASGOW_HASKELL__ >= 706 Left (unitBag (mkPlainErrMsg dflags sp err)) #else @@ -700,8 +754,10 @@ instance NFData ByteString where rnf (Chunk _ b) = rnf b #endif +#if __GLASGOW_HASKELL__ < 804 -- | Like 'everything', but avoid known potholes, based on the 'Stage' that -- generated the Ast. +-- everythingWithContext :: s -> (r -> r -> r) -> GenericQ (s -> (r, s)) -> GenericQ r everythingStagedWithContext :: Stage -> s -> (r -> r -> r) -> r -> GenericQ (s -> (r, s)) -> GenericQ r everythingStagedWithContext stage s0 f z q x | (const False @@ -716,6 +772,7 @@ everythingStagedWithContext stage s0 f z q x #endif fixity = const (stage Bool (r, s') = q x s0 +#endif withCleanupSession :: GhcMonad m => m a -> m a #if __GLASGOW_HASKELL__ >= 800 diff --git a/core/GhcMod/LightGhc.hs b/core/GhcMod/LightGhc.hs index 146f2c095..4edae7293 100644 --- a/core/GhcMod/LightGhc.hs +++ b/core/GhcMod/LightGhc.hs @@ -31,9 +31,17 @@ initStaticOpts = return () newLightEnv :: IOish m => (DynFlags -> LightGhc DynFlags) -> m HscEnv newLightEnv mdf = do df <- liftIO $ do +#if MIN_VERSION_GLASGOW_HASKELL(8,2,0,0) +#else initStaticOpts +#endif settings <- initSysTools (Just libdir) +#if __GLASGOW_HASKELL__ >= 804 + let llvmTgtList = [] -- TODO: where should this come from? + initDynFlags $ defaultDynFlags settings llvmTgtList +#else initDynFlags $ defaultDynFlags settings +#endif hsc_env <- liftIO $ newHscEnv df df' <- runLightGhc hsc_env $ mdf df diff --git a/core/GhcMod/Logger.hs b/core/GhcMod/Logger.hs index 3ccf89bdb..1affd11ea 100644 --- a/core/GhcMod/Logger.hs +++ b/core/GhcMod/Logger.hs @@ -19,7 +19,7 @@ import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef) import System.FilePath (normalise) import ErrUtils -import GHC +import GHC hiding ( convert ) import HscTypes import Outputable import qualified GHC as G diff --git a/core/GhcMod/Options/Help.hs b/core/GhcMod/Options/Help.hs index b23487cc5..5156f588f 100644 --- a/core/GhcMod/Options/Help.hs +++ b/core/GhcMod/Options/Help.hs @@ -14,6 +14,7 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . {-# LANGUAGE OverloadedStrings, FlexibleInstances, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP #-} module GhcMod.Options.Help where @@ -33,6 +34,11 @@ type MyDoc = MyDocM (Maybe Doc) () instance IsString (MyDocM (Maybe Doc) a) where fromString = append . para +#if __GLASGOW_HASKELL__ >= 804 +instance Semigroup (MyDocM (Maybe Doc) ()) where + (<>) = mappend +#endif + instance Monoid (MyDocM (Maybe Doc) ()) where mappend a b = append $ doc a <> doc b mempty = append PP.empty @@ -47,7 +53,7 @@ append s = modify m >> return undefined m Nothing = Just s m (Just old) = Just $ old PP..$. s -infixr 7 \\ +infixr 7 \\ -- comment to sort out CPP (\\) :: MyDoc -> MyDoc -> MyDoc (\\) a b = append $ doc a PP.<+> doc b diff --git a/core/GhcMod/Pretty.hs b/core/GhcMod/Pretty.hs index d2737888c..acc219e63 100644 --- a/core/GhcMod/Pretty.hs +++ b/core/GhcMod/Pretty.hs @@ -40,6 +40,7 @@ import Outputable (SDoc, withPprStyleDoc) import GhcMod.Types import GhcMod.Doc import GhcMod.Gap (renderGm) +import Prelude hiding ( (<>)) renderSDoc :: GhcMonad m => SDoc -> m Doc renderSDoc sdoc = do diff --git a/core/GhcMod/SrcUtils.hs b/core/GhcMod/SrcUtils.hs index 30999f3f1..f16d7e1d0 100644 --- a/core/GhcMod/SrcUtils.hs +++ b/core/GhcMod/SrcUtils.hs @@ -1,5 +1,7 @@ -- TODO: remove CPP once Gap(ed) {-# LANGUAGE CPP, TupleSections, FlexibleInstances, Rank2Types #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module GhcMod.SrcUtils where @@ -9,12 +11,13 @@ import CoreUtils (exprType) import Data.Generics import Data.Maybe import Data.Ord as O -import GHC (LHsExpr, LPat, Id, DynFlags, SrcSpan, Type, Located, ParsedSource, RenamedSource, TypecheckedSource, GenLocated(L)) -import Var (Var) +import GHC (LHsExpr, LPat, DynFlags, SrcSpan, Type, Located, ParsedSource, RenamedSource, TypecheckedSource, GenLocated(L)) import qualified GHC as G import qualified Var as G import qualified Type as G +#if __GLASGOW_HASKELL__ < 804 import GHC.SYB.Utils +#endif import GhcMonad import qualified Language.Haskell.Exts as HE import GhcMod.Doc @@ -31,42 +34,56 @@ import qualified Data.Map as M ---------------------------------------------------------------- -instance HasType (LHsExpr Id) where +instance HasType (LHsExpr GhcTc) where getType tcm e = do hs_env <- G.getSession mbe <- liftIO $ Gap.deSugar tcm e hs_env return $ (G.getLoc e, ) <$> CoreUtils.exprType <$> mbe -instance HasType (LPat Id) where +instance HasType (LPat GhcTc) where getType _ (G.L spn pat) = return $ Just (spn, hsPatType pat) ---------------------------------------------------------------- +#if __GLASGOW_HASKELL__ >= 804 +-- | Stores mapping from monomorphic to polymorphic types +type CstGenQS = M.Map (G.IdP GhcTc) Type +-- | Generic type to simplify SYB definition +type CstGenQT m a = a GhcTc -> CstGenQS -> (m [(SrcSpan, Type)], CstGenQS) +#else -- | Stores mapping from monomorphic to polymorphic types -type CstGenQS = M.Map Var Type +type CstGenQS = M.Map G.Var Type -- | Generic type to simplify SYB definition -type CstGenQT a = forall m. GhcMonad m => a Id -> CstGenQS -> (m [(SrcSpan, Type)], CstGenQS) +type CstGenQT a = forall m. GhcMonad m => a G.Id -> CstGenQS -> (m [(SrcSpan, Type)], CstGenQS) +#endif -collectSpansTypes :: (GhcMonad m) => Bool -> G.TypecheckedModule -> (Int, Int) -> m [(SrcSpan, Type)] +collectSpansTypes :: forall m.(GhcMonad m) => Bool -> G.TypecheckedModule -> (Int, Int) -> m [(SrcSpan, Type)] collectSpansTypes withConstraints tcs lc = -- This walks AST top-down, left-to-right, while carrying CstGenQS down the tree -- (but not left-to-right) +#if __GLASGOW_HASKELL__ >= 804 + everythingWithContext M.empty (liftM2 (++)) +#else everythingStagedWithContext TypeChecker M.empty (liftM2 (++)) (return []) +#endif ((return [],) - `mkQ` (hsBind :: CstGenQT G.LHsBind) -- matches on binds - `extQ` (genericCT :: CstGenQT G.LHsExpr) -- matches on expressions - `extQ` (genericCT :: CstGenQT G.LPat) -- matches on patterns + `mkQ` (hsBind :: G.LHsBind GhcTc -> CstGenQS -> (m [(SrcSpan, Type)], CstGenQS)) -- matches on binds + `extQ` (genericCT :: G.LHsExpr GhcTc -> CstGenQS -> (m [(SrcSpan, Type)], CstGenQS)) -- matches on expressions + `extQ` (genericCT :: G.LPat GhcTc -> CstGenQS -> (m [(SrcSpan, Type)], CstGenQS)) -- matches on patterns + ) (G.tm_typechecked_source tcs) where -- Helper function to insert mapping into CstGenQS insExp x = M.insert (G.abe_mono x) (G.varType $ G.abe_poly x) -- If there is AbsBinds here, insert mapping into CstGenQS if needed + hsBind (L _ G.AbsBinds{abs_exports = es'}) s | withConstraints = (return [], foldr insExp s es') | otherwise = (return [], s) -#if __GLASGOW_HASKELL__ >= 800 +#if __GLASGOW_HASKELL__ >= 804 +#elif __GLASGOW_HASKELL__ >= 800 -- TODO: move to Gap -- Note: this deals with bindings with explicit type signature, e.g. -- double :: Num a => a -> a @@ -83,20 +100,33 @@ collectSpansTypes withConstraints tcs lc = -- Otherwise, it's the same as other cases hsBind x s = genericCT x s -- Generic SYB function to get type + genericCT :: forall b . (Data (b GhcTc), HasType (Located (b GhcTc))) + => Located (b GhcTc) -> CstGenQS -> (m [(SrcSpan, Type)], CstGenQS) genericCT x s | withConstraints = (maybe [] (uncurry $ constrainedType (collectBinders x) s) <$> getType' x, s) | otherwise = (maybeToList <$> getType' x, s) +#if __GLASGOW_HASKELL__ >= 804 -- Collects everything with Id from LHsBind, LHsExpr, or LPat - collectBinders :: Data a => a -> [Id] + collectBinders :: Data a => a -> [G.IdP GhcTc] + collectBinders = listify (const True) +#else + -- Collects everything with Id from LHsBind, LHsExpr, or LPat + collectBinders :: Data a => a -> [G.Id] collectBinders = listifyStaged TypeChecker (const True) +#endif -- Gets monomorphic type with location + getType' :: forall t . (HasType (Located t)) => Located t -> m (Maybe (SrcSpan, Type)) getType' x@(L spn _) - | G.isGoodSrcSpan spn && spn `G.spans` lc + | G.isGoodSrcSpan spn && (spn `G.spans` lc) = getType tcs x | otherwise = return Nothing -- Gets constrained type - constrainedType :: [Var] -- ^ Binders in expression, i.e. anything with Id +#if __GLASGOW_HASKELL__ >= 804 + constrainedType :: [G.IdP GhcTc] -- ^ Binders in expression, i.e. anything with Id +#else + constrainedType :: [G.Var] -- ^ Binders in expression, i.e. anything with Id +#endif -> CstGenQS -- ^ Map from Id to polymorphic type -> SrcSpan -- ^ extent of expression, copied to result -> Type -- ^ monomorphic type @@ -112,10 +142,17 @@ collectSpansTypes withConstraints tcs lc = build x | Just cti <- x `M.lookup` s = let (preds', ctt) = getPreds cti +#if __GLASGOW_HASKELL__ >= 804 + -- list of type variables in monomorphic type + vts = listify G.isTyVar $ G.varType x + -- list of type variables in polymorphic type + tvm = listify G.isTyVarTy ctt +#else -- list of type variables in monomorphic type vts = listifyStaged TypeChecker G.isTyVar $ G.varType x -- list of type variables in polymorphic type tvm = listifyStaged TypeChecker G.isTyVarTy ctt +#endif in Just (preds', zip vts tvm) | otherwise = Nothing -- list of constraints @@ -138,22 +175,36 @@ collectSpansTypes withConstraints tcs lc = | otherwise = ([], x) listifySpans :: Typeable a => TypecheckedSource -> (Int, Int) -> [Located a] +#if __GLASGOW_HASKELL__ >= 804 +listifySpans tcs lc = listify p tcs +#else listifySpans tcs lc = listifyStaged TypeChecker p tcs +#endif where p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc listifyParsedSpans :: Typeable a => ParsedSource -> (Int, Int) -> [Located a] +#if __GLASGOW_HASKELL__ >= 804 +listifyParsedSpans pcs lc = listify p pcs +#else listifyParsedSpans pcs lc = listifyStaged Parser p pcs +#endif where p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc listifyRenamedSpans :: Typeable a => RenamedSource -> (Int, Int) -> [Located a] +#if __GLASGOW_HASKELL__ >= 804 +listifyRenamedSpans pcs lc = listify p pcs +#else listifyRenamedSpans pcs lc = listifyStaged Renamer p pcs +#endif where p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc +#if __GLASGOW_HASKELL__ < 804 listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r] listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x])) +#endif cmp :: SrcSpan -> SrcSpan -> Ordering cmp a b diff --git a/core/GhcMod/Target.hs b/core/GhcMod/Target.hs index 2294cfa8d..de39bc6e6 100644 --- a/core/GhcMod/Target.hs +++ b/core/GhcMod/Target.hs @@ -21,6 +21,9 @@ import Control.Arrow import Control.Applicative import Control.Category ((.)) import GHC +import qualified Hooks as GHC +import qualified HscTypes as GHC +import qualified GhcMonad as G #if __GLASGOW_HASKELL__ >= 800 import GHC.LanguageExtensions #endif @@ -146,16 +149,42 @@ runGmlT' :: IOish m -> GhcModT m a runGmlT' fns mdf action = runGmlTWith fns mdf id action --- | Run a GmlT action (i.e. a function in the GhcMonad) in the context --- of certain files or modules, with updated GHC flags and a final --- transformation +-- | Run a GmlT action (i.e. a function in the GhcMonad) in the context of +-- certain files or modules, with updated GHC flags, and updated ModuleGraph +runGmlTfm :: IOish m + => [Either FilePath ModuleName] + -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags) + -> Maybe (GHC.Hooks -> GHC.Hooks) + -> GmlT m a + -> GhcModT m a +runGmlTfm fns mdf mUpdateHooks action + = runGmlTWith' fns mdf mUpdateHooks id action + +-- | Run a GmlT action (i.e. a function in the GhcMonad) in the context of +-- certain files or modules, with updated GHC flags, updated ModuleGraph and a +-- final transformation runGmlTWith :: IOish m => [Either FilePath ModuleName] -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags) -> (GmlT m a -> GmlT m b) -> GmlT m a -> GhcModT m b -runGmlTWith efnmns' mdf wrapper action = do +runGmlTWith efnmns' mdf wrapper action = + runGmlTWith' efnmns' mdf Nothing wrapper action + +-- | Run a GmlT action (i.e. a function in the GhcMonad) in the context of +-- certain files or modules, with updated GHC flags, updated ModuleGraph and a +-- final transformation +runGmlTWith' :: IOish m + => [Either FilePath ModuleName] + -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags) + -> Maybe (GHC.Hooks -> GHC.Hooks) + -- ^ If a hook update is provided, force the reloading + -- of the specified targets + -> (GmlT m a -> GmlT m b) + -> GmlT m a + -> GhcModT m b +runGmlTWith' efnmns' mdf mUpdateHooks wrapper action = do crdl <- cradle Options { optGhcUserOptions } <- options @@ -163,9 +192,14 @@ runGmlTWith efnmns' mdf wrapper action = do ccfns = map (cradleCurrentDir crdl ) fns cfns <- mapM getCanonicalFileNameSafe ccfns let serfnmn = Set.fromList $ map Right mns ++ map Left cfns - opts <- targetGhcOptions crdl serfnmn + (opts, mappedStrs) <- targetGhcOptions crdl serfnmn let opts' = opts ++ ["-O0", "-fno-warn-missing-home-modules"] ++ optGhcUserOptions + gmVomit + "session-ghc-options" + (text "Using the following mapped files") + (intercalate " " $ map (("\""++) . (++"\"")) mappedStrs) + gmVomit "session-ghc-options" (text "Initializing GHC session with following options") @@ -182,28 +216,37 @@ runGmlTWith efnmns' mdf wrapper action = do mappedStrs <- getMMappedFilePaths let targetStrs = mappedStrs ++ map moduleNameString mns ++ cfns + gmVomit + "session-ghc-options" + (text "Using the following targets") + (intercalate " " $ map (("\""++) . (++"\"")) targetStrs) + unGmlT $ wrapper $ do - loadTargets opts targetStrs + loadTargets opts targetStrs mUpdateHooks action targetGhcOptions :: forall m. IOish m => Cradle -> Set (Either FilePath ModuleName) - -> GhcModT m [GHCOption] + -> GhcModT m ([GHCOption],[FilePath]) targetGhcOptions crdl sefnmn = do when (Set.null sefnmn) $ error "targetGhcOptions: no targets given" case cradleProject crdl of proj | isCabalHelperProject proj -> cabalOpts crdl - | otherwise -> sandboxOpts crdl + | otherwise -> do + opts <- sandboxOpts crdl + mappedStrs <- getMMappedFilePaths + return (opts, mappedStrs) where zipMap f l = l `zip` (f `map` l) - cabalOpts :: Cradle -> GhcModT m [String] + cabalOpts :: Cradle -> GhcModT m ([GHCOption],[FilePath]) cabalOpts Cradle{..} = do mcs <- cabalResolvedComponents - + mappedStrs <- getMMappedFilePaths + let mappedComps = zipMap (moduleComponents mcs . Left) mappedStrs let mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn candidates = findCandidates $ map snd mdlcs @@ -214,15 +257,22 @@ targetGhcOptions crdl sefnmn = do then do -- First component should be ChLibName, if no lib will take lexically first exe. let cns = filter (/= ChSetupHsName) $ Map.keys mcs + cn = head cns + mappedStrsInComp = map fst $ filter (Set.member cn . snd) mappedComps gmLog GmDebug "" $ strDoc $ "Could not find a component assignment, falling back to picking library component in cabal file." - return $ gmcGhcOpts $ fromJustNote "targetGhcOptions, no-assignment" $ Map.lookup (head cns) mcs + let opts = gmcGhcOpts (fromJustNote "targetGhcOptions, no-assignment" $ Map.lookup cn mcs) + ++ ["-Wno-missing-home-modules"] + return (opts, mappedStrsInComp) else do when noCandidates $ throwError $ GMECabalCompAssignment mdlcs let cn = pickComponent candidates - return $ gmcGhcOpts $ fromJustNote "targetGhcOptions" $ Map.lookup cn mcs + mappedStrsInComp = map fst $ filter (Set.member cn . snd) mappedComps + opts = gmcGhcOpts (fromJustNote "targetGhcOptions" $ Map.lookup cn mcs) + ++ ["-Wno-missing-home-modules"] + return (opts, mappedStrsInComp) resolvedComponentsCache :: IOish m => FilePath -> Cached (GhcModT m) GhcModState @@ -311,7 +361,7 @@ packageGhcOptions = do | otherwise -> sandboxOpts crdl -- also works for plain projects! -sandboxOpts :: (IOish m, GmEnv m) => Cradle -> m [String] +sandboxOpts :: (IOish m, GmEnv m) => Cradle -> m [GHCOption] sandboxOpts crdl = do mCusPkgDb <- getCustomPkgDbStack pkgDbStack <- liftIO $ getSandboxPackageDbStack @@ -367,8 +417,8 @@ resolveEntrypoint Cradle {..} c@GmComponent {..} = do -- ghc do the warning about it. Right now we run that module through -- resolveModule like any other resolveChEntrypoints :: FilePath -> ChEntrypoint -> IO [CompilationUnit] -resolveChEntrypoints _ (ChLibEntrypoint em om _) = - return $ map (Right . chModToMod) (em ++ om) +resolveChEntrypoints _ (ChLibEntrypoint em om sm) = + return $ map (Right . chModToMod) (em ++ om ++ sm) resolveChEntrypoints _ (ChExeEntrypoint main om) = return $ [Left main] ++ map (Right . chModToMod) om @@ -448,8 +498,8 @@ resolveGmComponents mcache cs = do same f a b = (f a) == (f b) -- | Set the files as targets and load them. -loadTargets :: IOish m => [GHCOption] -> [FilePath] -> GmlT m () -loadTargets opts targetStrs = do +loadTargets :: IOish m => [GHCOption] -> [FilePath] -> Maybe (GHC.Hooks -> GHC.Hooks) -> GmlT m () +loadTargets opts targetStrs mUpdateHooks = do targets' <- withLightHscEnv opts $ \env -> liftM (nubBy ((==) `on` targetId)) @@ -457,32 +507,51 @@ loadTargets opts targetStrs = do >>= mapM relativize let targets = map (\t -> t { targetAllowObjCode = False }) targets' + targetFileNames = concatMap filePathFromTarget targets gmLog GmDebug "loadTargets" $ text "Loading" <+>: fsep (map (text . showTargetId) targets) + + let filterModSums = isJust mUpdateHooks + gmLog GmDebug "loadTargets" $ + text "filterModSums" <+>: text (show filterModSums) + setTargets targets + when filterModSums $ updateModuleGraph setDynFlagsRecompile targetFileNames + mg <- depanal [] False let interp = needsHscInterpreted mg target <- hscTarget <$> getSessionDynFlags when (interp && target /= HscInterpreted) $ do - _ <- setSessionDynFlags . setHscInterpreted =<< getSessionDynFlags + let + setHooks :: DynFlags -> DynFlags + setHooks df = df { GHC.hooks = (fromMaybe id mUpdateHooks) (GHC.hooks df) } + _ <- setSessionDynFlags . setHscInterpreted . setHooks =<< getSessionDynFlags gmLog GmInfo "loadTargets" $ text "Target needs interpeter, switching to LinkInMemory/HscInterpreted. Perfectly normal if anything is using TemplateHaskell, QuasiQuotes or PatternSynonyms." + when filterModSums $ updateModuleGraph setDynFlagsRecompile targetFileNames + target' <- hscTarget <$> getSessionDynFlags case target' of HscNothing -> do void $ load LoadAllTargets +#if __GLASGOW_HASKELL__ >= 804 + forM_ (mgModSummaries mg) $ +#else forM_ mg $ +#endif handleSourceError (gmLog GmDebug "loadTargets" . text . show) . void . (parseModule >=> typecheckModule >=> desugarModule) HscInterpreted -> do void $ load LoadAllTargets _ -> error ("loadTargets: unsupported hscTarget") + when filterModSums $ updateModuleGraph unSetDynFlagsRecompile targetFileNames + gmLog GmDebug "loadTargets" $ text "Loading done" where @@ -496,8 +565,41 @@ loadTargets opts targetStrs = do showTargetId (Target (TargetModule s) _ _) = moduleNameString s showTargetId (Target (TargetFile s _) _ _) = s + filePathFromTarget (Target (TargetModule _) _ _) = [] + filePathFromTarget (Target (TargetFile s _) _ _) = [s] + + updateModuleGraph :: (GhcMonad m, GmState m, GmEnv m, + MonadIO m, GmLog m, GmOut m) + => (DynFlags -> DynFlags) -> [FilePath] -> m () + updateModuleGraph df fps = do + let + fpSet = Set.fromList fps + updateHooks df = df { GHC.hooks = (fromMaybe id mUpdateHooks) (GHC.hooks df)} + mustRecompile ms = case (ml_hs_file . ms_location) ms of + Nothing -> ms + Just f -> if Set.member f fpSet + then ms {ms_hspp_opts = (df . updateHooks) (ms_hspp_opts ms)} + else ms +#if __GLASGOW_HASKELL__ >= 804 + update s = s {hsc_mod_graph = mkModuleGraph $ map mustRecompile (mgModSummaries $ hsc_mod_graph s)} +#else + update s = s {hsc_mod_graph = map mustRecompile (hsc_mod_graph s)} +#endif + G.modifySession update + + setDynFlagsRecompile :: DynFlags -> DynFlags + setDynFlagsRecompile df = gopt_set df Opt_ForceRecomp + + unSetDynFlagsRecompile :: DynFlags -> DynFlags + unSetDynFlagsRecompile df = gopt_unset df Opt_ForceRecomp + needsHscInterpreted :: ModuleGraph -> Bool +#if __GLASGOW_HASKELL__ >= 804 +needsHscInterpreted mg = foo (mgModSummaries mg) + where foo = any $ \ms -> +#else needsHscInterpreted = any $ \ms -> +#endif let df = ms_hspp_opts ms in #if __GLASGOW_HASKELL__ >= 800 TemplateHaskell `xopt` df diff --git a/core/GhcMod/Types.hs b/core/GhcMod/Types.hs index 06d3a625a..a2720a94b 100644 --- a/core/GhcMod/Types.hs +++ b/core/GhcMod/Types.hs @@ -184,6 +184,11 @@ data GhcModLog = GhcModLog { gmLogMessages :: [(GmLogLevel, String, Doc)] } deriving (Show) +#if __GLASGOW_HASKELL__ >= 804 +instance Semigroup GhcModLog where + (<>) = mappend +#endif + instance Monoid GhcModLog where mempty = GhcModLog (Just GmPanic) (Last Nothing) mempty GhcModLog ml vd ls `mappend` GhcModLog ml' vd' ls' = @@ -275,6 +280,11 @@ instance Binary GmModuleGraph where swapMap :: Ord v => Map k v -> Map v k swapMap = Map.fromList . map (\(x, y) -> (y, x)) . Map.toList +#if __GLASGOW_HASKELL__ >= 804 +instance Semigroup GmModuleGraph where + (<>) = mappend +#endif + instance Monoid GmModuleGraph where mempty = GmModuleGraph mempty mappend (GmModuleGraph a) (GmModuleGraph a') = diff --git a/core/GhcModCore.hs b/core/GhcModCore.hs index a7ba32d13..ab4b54ab4 100644 --- a/core/GhcModCore.hs +++ b/core/GhcModCore.hs @@ -40,12 +40,16 @@ module GhcModCore ( , loadMappedFile , loadMappedFileSource , unloadMappedFile + -- * HIE integration utilities + , getTypecheckedModuleGhc + , getTypecheckedModuleGhc' ) where import GhcMod.Cradle import GhcMod.FileMapping import GhcMod.Logging import GhcMod.Monad +import GhcMod.ModuleLoader import GhcMod.Output import GhcMod.Target import GhcMod.Types diff --git a/core/LICENSE b/core/LICENSE new file mode 100644 index 000000000..9f26b637f --- /dev/null +++ b/core/LICENSE @@ -0,0 +1 @@ +Foo \ No newline at end of file diff --git a/core/ghc-mod-core.cabal b/core/ghc-mod-core.cabal index e077f3a61..ddc5afed7 100644 --- a/core/ghc-mod-core.cabal +++ b/core/ghc-mod-core.cabal @@ -54,6 +54,7 @@ Library GhcMod.LightGhc GhcMod.Logger GhcMod.Logging + GhcMod.ModuleLoader GhcMod.Monad GhcMod.Monad.Env GhcMod.Monad.Log @@ -88,40 +89,35 @@ Library , directory , filepath , mtl - , old-time , process , template-haskell , time , transformers - , base < 4.11 && >= 4.6.0.1 - , djinn-ghc < 0.1 && >= 0.0.2.2 + , base < 4.12 && >= 4.6.0.1 , extra < 1.7 && >= 1.4 , fclabels < 2.1 && >= 2.0 - , fingertree < 0.2 && >= 0.1.1.0 , ghc-paths < 0.2 && >= 0.1.0.9 - , ghc-syb-utils < 0.3 && >= 0.2.3 - , haskell-src-exts < 1.20 && >= 1.18 - , hlint < 3.0 && >= 2.0.8 + , haskell-src-exts < 1.21 && >= 1.18 , monad-control < 1.1 && >= 1 , monad-journal < 0.9 && >= 0.4 , optparse-applicative < 0.15 && >= 0.13.0.0 , pipes < 4.4 && >= 4.1 , safe < 0.4 && >= 0.3.9 - , semigroups < 0.19 && >= 0.10.0 , split < 0.3 && >= 0.2.2 , syb < 0.8 && >= 0.5.1 , temporary < 1.3 && >= 1.2.0.3 - , text < 1.3 && >= 1.2.1.3 , transformers-base < 0.5 && >= 0.4.4 , cabal-helper < 0.9 && >= 0.8.0.2 - , ghc < 8.4 && >= 7.6 + , ghc < 8.5 && >= 7.6 if impl(ghc >= 8.0) Build-Depends: ghc-boot if impl(ghc < 7.8) Build-Depends: convertible < 1.2 && >= 1.1.0.0 + if impl(ghc < 8.4) + Build-Depends: ghc-syb-utils < 0.3 && >= 0.2.3 Source-Repository head Type: git diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 71ebb09b4..52e8914f0 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -135,18 +135,17 @@ Library , time , transformers - , base < 4.11 && >= 4.6.0.1 + , base < 4.12 && >= 4.6.0.1 , djinn-ghc < 0.1 && >= 0.0.2.2 - , extra < 1.6 && >= 1.4 + , extra < 1.7 && >= 1.4 , fclabels < 2.1 && >= 2.0 , ghc-paths < 0.2 && >= 0.1.0.9 - , ghc-syb-utils < 0.3 && >= 0.2.3 , ghc-mod-core == 5.9.0.0 - , haskell-src-exts < 1.20 && >= 1.18 - , hlint < 2.1 && >= 2.0.8 + , haskell-src-exts < 1.21 && >= 1.18 + , hlint < 2.2 && >= 2.0.8 , monad-control < 1.1 && >= 1 - , monad-journal < 0.8 && >= 0.4 - , optparse-applicative < 0.14 && >= 0.13.0.0 + , monad-journal < 0.9 && >= 0.4 + , optparse-applicative < 0.15 && >= 0.13.0.0 , pipes < 4.4 && >= 4.1 , safe < 0.4 && >= 0.3.9 , semigroups < 0.19 && >= 0.10.0 @@ -157,11 +156,12 @@ Library , transformers-base < 0.5 && >= 0.4.4 , cabal-helper < 0.9 && >= 0.8.0.0 - , ghc < 8.4 && >= 7.8 - , ghc-mod-core + , ghc < 8.5 && >= 7.8 if impl(ghc >= 8.0) Build-Depends: ghc-boot + if impl(ghc < 8.4) + Build-Depends: ghc-syb-utils < 0.3 && >= 0.2.3 Executable ghc-mod Default-Language: Haskell2010 @@ -182,14 +182,14 @@ Executable ghc-mod , mtl , process - , base < 4.11 && >= 4.6.0.1 + , base < 4.12 && >= 4.6.0.1 , fclabels < 2.1 && >= 2.0 , monad-control < 1.1 && >= 1 - , optparse-applicative < 0.14 && >= 0.13.0.0 + , optparse-applicative < 0.15 && >= 0.13.0.0 , semigroups < 0.19 && >= 0.10.0 , split < 0.3 && >= 0.2.2 - , ghc < 8.4 && >= 7.8 + , ghc < 8.5 && >= 7.8 , ghc-mod , ghc-mod-core @@ -213,7 +213,7 @@ Executable ghc-modi , process , time - , base < 4.11 && >= 4.6.0.1 + , base < 4.12 && >= 4.6.0.1 , ghc-mod , ghc-mod-core @@ -226,7 +226,7 @@ Test-Suite doctest Ghc-Options: -Wall Default-Extensions: ConstraintKinds, FlexibleContexts Main-Is: doctests.hs - Build-Depends: base < 4.11 && >= 4.6.0.1 + Build-Depends: base < 4.12 && >= 4.6.0.1 , doctest < 0.14 && >= 0.11.3 Test-Suite spec @@ -273,10 +273,10 @@ Test-Suite spec , process , transformers - , base < 4.11 && >= 4.6.0.1 + , base < 4.12 && >= 4.6.0.1 , fclabels < 2.1 && >= 2.0 - , hspec < 2.5 && >= 2.0.0 - , monad-journal < 0.8 && >= 0.4 + , hspec < 2.6 && >= 2.0.0 + , monad-journal < 0.9 && >= 0.4 , split < 0.3 && >= 0.2.2 , temporary < 1.3 && >= 1.2.0.3 @@ -288,7 +288,7 @@ Test-Suite spec Build-Depends: cabal-helper < 0.9 && >= 0.8.0.0 - , ghc < 8.4 && >= 7.8 + , ghc < 8.5 && >= 7.8 , ghc-mod , ghc-mod-core @@ -300,7 +300,7 @@ Test-Suite shelltest Type: exitcode-stdio-1.0 if flag(shelltest) Build-Tools: shelltest - Build-Depends: base < 4.11 && >= 4.6.0.1 + Build-Depends: base < 4.12 && >= 4.6.0.1 , process < 1.5 -- , shelltestrunner >= 1.3.5 if !flag(shelltest) @@ -320,7 +320,7 @@ Benchmark criterion directory , filepath - , base < 4.11 && >= 4.6.0.1 + , base < 4.12 && >= 4.6.0.1 , criterion < 1.2 && >= 1.1.1.0 , temporary < 1.3 && >= 1.2.0.3 diff --git a/test/CabalHelperSpec.hs b/test/CabalHelperSpec.hs index f2119b024..43cd33506 100644 --- a/test/CabalHelperSpec.hs +++ b/test/CabalHelperSpec.hs @@ -86,7 +86,7 @@ spec = do opts <- map gmcGhcOpts <$> runD' tdir getComponents let ghcOpts = head opts pkgs = pkgOptions ghcOpts - pkgs `shouldBe` ["Cabal","base"] + pkgs `shouldBe` ["base","Cabal"] test diff --git a/test/CheckSpec.hs b/test/CheckSpec.hs index efe024cd2..c14d1603c 100644 --- a/test/CheckSpec.hs +++ b/test/CheckSpec.hs @@ -64,8 +64,10 @@ spec = do it "works with cabal builtin preprocessors" $ do withDirectory_ "test/data/cabal-preprocessors" $ do _ <- system "cabal clean" - _ <- system "cabal build" - res <- runD $ checkSyntax ["Main.hs"] + -- _ <- system "cabal build" + _ <- system "cabal build -v3" + -- res <- runD $ checkSyntax ["Main.hs"] + res <- runV $ checkSyntax ["Main.hs"] res `shouldBe` "Preprocessed.hsc:3:1:Warning: Top-level binding with no type signature: warning :: ()\n" it "Uses the right qualification style" $ do diff --git a/test/TestUtils.hs b/test/TestUtils.hs index 3d252f151..e487a22a5 100644 --- a/test/TestUtils.hs +++ b/test/TestUtils.hs @@ -3,6 +3,7 @@ module TestUtils ( run , runD , runD' + , runV , runE , runNullLog , runGmOutDef @@ -77,6 +78,11 @@ runD' :: FilePath -> GhcModT IO a -> IO a runD' dir = extract . runGhcModTSpec' dir (setLogLevel testLogLevel defaultOptions) +-- | Run GhcMod with default options +runV :: GhcModT IO a -> IO a +runV = + extract . runGhcModTSpec (setLogLevel GmVomit defaultOptions) + setLogLevel :: GmLogLevel -> Options -> Options setLogLevel = set (lOoptLogLevel . lOptOutput) From 9e07bc0429c59382a76cfeda21ac3d70e2a7d938 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Sun, 15 Apr 2018 16:47:13 +0200 Subject: [PATCH 2/9] Add ModuleLoader --- core/GhcMod/ModuleLoader.hs | 138 ++++++++++++++++++++++++++++++++++++ 1 file changed, 138 insertions(+) create mode 100644 core/GhcMod/ModuleLoader.hs diff --git a/core/GhcMod/ModuleLoader.hs b/core/GhcMod/ModuleLoader.hs new file mode 100644 index 000000000..8fbf0ba01 --- /dev/null +++ b/core/GhcMod/ModuleLoader.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Uses GHC hooks to load a TypecheckedModule + +module GhcMod.ModuleLoader + ( getTypecheckedModuleGhc + , getTypecheckedModuleGhc' + ) where + +import Control.Monad.IO.Class + +import qualified Data.Map as Map +import Data.IORef + +import qualified GhcMod.Monad as GM +import qualified GhcMod.Target as GM +import qualified GhcMod.Types as GM + +import GHC (TypecheckedModule) +import qualified GHC +import qualified DynFlags as GHC +import qualified GhcMonad as GHC +import qualified Hooks as GHC +import qualified HscMain as GHC +import qualified HscTypes as GHC +import qualified TcRnMonad as GHC + +import System.Directory +import System.FilePath + +-- --------------------------------------------------------------------- + +getMappedFileName :: FilePath -> GM.FileMappingMap -> FilePath +getMappedFileName fname mfs = + case Map.lookup fname mfs of + Just fm -> GM.fmPath fm + Nothing -> fname + +canonicalizeModSummary :: (MonadIO m) => + GHC.ModSummary -> m (Maybe FilePath) +canonicalizeModSummary = + traverse (liftIO . canonicalizePath) . GHC.ml_hs_file . GHC.ms_location + +tweakModSummaryDynFlags :: GHC.ModSummary -> GHC.ModSummary +tweakModSummaryDynFlags ms = + let df = GHC.ms_hspp_opts ms + in ms { GHC.ms_hspp_opts = GHC.gopt_set df GHC.Opt_KeepRawTokenStream } + +-- | Gets a TypecheckedModule from a given file +-- The `wrapper` allows arbitary data to be captured during +-- the compilation process, like errors and warnings +-- Appends the parent directories of all the mapped files +-- to the includePaths for CPP purposes. +-- Use in combination with `runActionInContext` for best results +getTypecheckedModuleGhc' :: GM.IOish m + => (GM.GmlT m () -> GM.GmlT m a) -> FilePath -> GM.GhcModT m (a, Maybe TypecheckedModule) +getTypecheckedModuleGhc' wrapper targetFile = do + cfileName <- liftIO $ canonicalizePath targetFile + mfs <- GM.getMMappedFiles + mFileName <- liftIO . canonicalizePath $ getMappedFileName cfileName mfs + ref <- liftIO $ newIORef Nothing + let keepInfo = pure . (mFileName ==) + saveModule = writeIORef ref . Just + res <- getTypecheckedModuleGhc wrapper [cfileName] keepInfo saveModule + mtm <- liftIO $ readIORef ref + return (res, mtm) + +-- | like getTypecheckedModuleGhc' but allows you to keep an arbitary number of Modules +-- `keepInfo` decides which TypecheckedModule to keep +-- `saveModule` is the callback that is passed the TypecheckedModule +getTypecheckedModuleGhc :: GM.IOish m + => (GM.GmlT m () -> GM.GmlT m a) -> [FilePath] -> (FilePath -> IO Bool) -> (TypecheckedModule -> IO ()) -> GM.GhcModT m a +getTypecheckedModuleGhc wrapper targetFiles keepInfo saveModule = do + mfs <- GM.getMMappedFiles + let ips = map takeDirectory $ Map.keys mfs + setIncludePaths df = df { GHC.includePaths = ips ++ GHC.includePaths df } + GM.runGmlTWith' (map Left targetFiles) + (return . setIncludePaths) + (Just $ updateHooks keepInfo saveModule) + wrapper + (return ()) + +updateHooks + :: (FilePath -> IO Bool) + -> (TypecheckedModule -> IO ()) + -> GHC.Hooks + -> GHC.Hooks +updateHooks fp ref hooks = hooks { +#if __GLASGOW_HASKELL__ <= 710 + GHC.hscFrontendHook = Just $ hscFrontend fp ref +#else + GHC.hscFrontendHook = Just $ fmap GHC.FrontendTypecheck . hscFrontend fp ref +#endif + } + + +-- | Warning: discards all changes to Session +runGhcInHsc :: GHC.Ghc a -> GHC.Hsc a +runGhcInHsc action = do + env <- GHC.getHscEnv + session <- liftIO $ newIORef env + liftIO $ GHC.reflectGhc action $ GHC.Session session + + +-- | Frontend hook that keeps the TypecheckedModule for its first argument +-- and stores it in the IORef passed to it +hscFrontend :: (FilePath -> IO Bool) -> (TypecheckedModule -> IO ()) -> GHC.ModSummary -> GHC.Hsc GHC.TcGblEnv +hscFrontend keepInfoFunc saveModule mod_summary = do + mfn <- canonicalizeModSummary mod_summary + -- md = GHC.moduleNameString $ GHC.moduleName $ GHC.ms_mod mod_summary + keepInfo <- case mfn of + Just fileName -> liftIO $ keepInfoFunc fileName + Nothing -> pure False + -- liftIO $ debugm $ "hscFrontend: got mod,file" ++ show (md, mfn) + if keepInfo + then runGhcInHsc $ do + let modSumWithRaw = tweakModSummaryDynFlags mod_summary + + p' <- GHC.parseModule modSumWithRaw + let p = p' {GHC.pm_mod_summary = mod_summary} + tc <- GHC.typecheckModule p + let tc_gbl_env = fst $ GHC.tm_internals_ tc + + liftIO $ saveModule tc + return tc_gbl_env + else do + hpm <- GHC.hscParse' mod_summary + hsc_env <- GHC.getHscEnv +#if __GLASGOW_HASKELL__ >= 804 + -- tcRnModule' :: ModSummary -> Bool -> HsParsedModule -> Hsc TcGblEnv + GHC.tcRnModule' mod_summary False hpm +#else + GHC.tcRnModule' hsc_env mod_summary False hpm +#endif + +-- --------------------------------------------------------------------- + From fd02f84cbcaf96a40c51b62da4aa6729561f61b5 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Tue, 24 Apr 2018 21:41:46 +0200 Subject: [PATCH 3/9] Update for GHC 8.4.2, removing auto command - As djinn-ghc is not updated. - Update for hie integration --- GhcMod.hs | 2 +- GhcMod/Exe/CaseSplit.hs | 12 ++++++---- GhcMod/Exe/Debug.hs | 2 +- GhcMod/Exe/FillSig.hs | 38 ++++++++++++++++-------------- GhcMod/Exe/Test.hs | 4 ++++ core/GhcMod/SrcUtils.hs | 13 +++++++--- ghc-mod.cabal | 6 ++--- src/GhcMod/Exe/Options/Commands.hs | 15 +++++++----- src/GhcModMain.hs | 2 +- 9 files changed, 56 insertions(+), 38 deletions(-) diff --git a/GhcMod.hs b/GhcMod.hs index 893475901..1e0b6e3f7 100644 --- a/GhcMod.hs +++ b/GhcMod.hs @@ -48,7 +48,7 @@ module GhcMod ( , splits , sig , refine - , auto + -- , auto , modules , languages , flags diff --git a/GhcMod/Exe/CaseSplit.hs b/GhcMod/Exe/CaseSplit.hs index d866fb6f2..80afd35a0 100644 --- a/GhcMod/Exe/CaseSplit.hs +++ b/GhcMod/Exe/CaseSplit.hs @@ -12,7 +12,7 @@ import System.FilePath import Prelude import qualified DataCon as Ty -import GHC (GhcMonad, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L)) +import GHC (GhcMonad, LPat, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L)) import qualified GHC as G import Outputable (PprStyle) import qualified TyCon as Ty @@ -88,7 +88,7 @@ getSrcSpanTypeForFnSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe getSrcSpanTypeForFnSplit modSum lineNo colNo = do p@ParsedModule{pm_parsed_source = _pms} <- G.parseModule modSum tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p - let varPat = find isPatternVar $ listifySpans tcs (lineNo, colNo) :: Maybe (LPat Id) + let varPat = find isPatternVar $ listifySpans tcs (lineNo, colNo) :: Maybe (LPat Gap.GhcTc) match = last $ listifySpans tcs (lineNo, colNo) :: Gap.GLMatchI case varPat of Nothing -> return Nothing @@ -96,7 +96,9 @@ getSrcSpanTypeForFnSplit modSum lineNo colNo = do varT <- Gap.getType tcm varPat' -- Finally we get the type of the var case varT of Just varT' -> -#if __GLASGOW_HASKELL__ >= 710 +#if __GLASGOW_HASKELL__ >= 804 + let (L matchL (G.Match _ _ (G.GRHSs rhsLs _))) = match +#elif __GLASGOW_HASKELL__ >= 710 let (L matchL (G.Match _ _ _ (G.GRHSs rhsLs _))) = match #else let (L matchL (G.Match _ _ (G.GRHSs rhsLs _))) = match @@ -104,11 +106,11 @@ getSrcSpanTypeForFnSplit modSum lineNo colNo = do in return $ Just (SplitInfo (getPatternVarName varPat') matchL varT' (map G.getLoc rhsLs) ) _ -> return Nothing -isPatternVar :: LPat Id -> Bool +isPatternVar :: LPat Gap.GhcTc -> Bool isPatternVar (L _ (G.VarPat _)) = True isPatternVar _ = False -getPatternVarName :: LPat Id -> G.Name +getPatternVarName :: LPat Gap.GhcTc -> G.Name #if __GLASGOW_HASKELL__ >= 800 getPatternVarName (L _ (G.VarPat (L _ vName))) = G.getName vName #else diff --git a/GhcMod/Exe/Debug.hs b/GhcMod/Exe/Debug.hs index 2ba7ac556..7005bbb48 100644 --- a/GhcMod/Exe/Debug.hs +++ b/GhcMod/Exe/Debug.hs @@ -123,7 +123,7 @@ componentInfo ts = do mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn candidates = findCandidates $ map snd mdlcs cn = pickComponent candidates - opts <- targetGhcOptions crdl sefnmn + (opts,_) <- targetGhcOptions crdl sefnmn return $ unlines $ [ "Matching Components:\n" ++ renderGm (nest 4 $ diff --git a/GhcMod/Exe/FillSig.hs b/GhcMod/Exe/FillSig.hs index c8bb9255a..e5efb84a5 100644 --- a/GhcMod/Exe/FillSig.hs +++ b/GhcMod/Exe/FillSig.hs @@ -4,15 +4,14 @@ module GhcMod.Exe.FillSig ( sig , refine - , auto + -- , auto ) where import Data.Char (isSymbol) import Data.Function (on) import Data.Functor -import Data.List (find, nub, sortBy) +import Data.List (find, sortBy) import qualified Data.Map as M -import Data.Maybe (catMaybes) import Prelude import Exception (ghandle, SomeException(..)) @@ -20,7 +19,6 @@ import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L)) import Pretty (($$), text, nest) import qualified GHC as G -import qualified Name as G import Outputable (PprStyle) import qualified Type as Ty import qualified HsBinds as Ty @@ -28,7 +26,7 @@ import qualified Class as Ty import qualified Var as Ty import qualified HsPat as Ty import qualified Language.Haskell.Exts as HE -import Djinn.GHC +-- import Djinn.GHC import qualified GhcMod.Gap as Gap import GhcMod.Convert @@ -51,7 +49,7 @@ import GHC (unLoc) -- Possible signatures we can find: function or instance data SigInfo - = Signature SrcSpan [G.RdrName] (G.HsType G.RdrName) + = Signature SrcSpan [G.RdrName] (G.HsType Gap.GhcPs) | InstanceDecl SrcSpan G.Class | TyFamDecl SrcSpan G.RdrName TyFamType {- True if closed -} [G.RdrName] @@ -115,7 +113,7 @@ getSignature :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SigInfo) getSignature modSum lineNo colNo = do p@ParsedModule{pm_parsed_source = ps} <- G.parseModule modSum -- Inspect the parse tree to find the signature - case listifyParsedSpans ps (lineNo, colNo) :: [G.LHsDecl G.RdrName] of + case listifyParsedSpans ps (lineNo, colNo) :: [G.LHsDecl Gap.GhcPs] of #if __GLASGOW_HASKELL__ >= 802 [L loc (G.SigD (Ty.TypeSig names (G.HsWC _ (G.HsIB _ (L _ ty) _))))] -> #elif __GLASGOW_HASKELL__ >= 800 @@ -279,7 +277,7 @@ class FnArgsInfo ty name | ty -> name, name -> ty where getFnName :: DynFlags -> PprStyle -> name -> String getFnArgs :: ty -> [FnArg] -instance FnArgsInfo (G.HsType G.RdrName) (G.RdrName) where +instance FnArgsInfo (G.HsType Gap.GhcPs) (G.RdrName) where getFnName dflag style name = showOccName dflag style $ Gap.occName name #if __GLASGOW_HASKELL__ >= 800 getFnArgs (G.HsForAllTy _ (L _ iTy)) @@ -421,7 +419,7 @@ findVar dflag style tcm tcs lineNo colNo = _ -> return Nothing _ -> return Nothing where - lst :: [G.LHsExpr Id] + lst :: [G.LHsExpr Gap.GhcTc] lst = sortBy (cmp `on` G.getLoc) $ listifySpans tcs (lineNo, colNo) infinitePrefixSupply :: String -> [String] @@ -432,7 +430,7 @@ doParen :: Bool -> String -> String doParen False s = s doParen True s = if ' ' `elem` s then '(':s ++ ")" else s -isSearchedVar :: Id -> G.HsExpr Id -> Bool +isSearchedVar :: Id -> G.HsExpr Gap.GhcTc -> Bool #if __GLASGOW_HASKELL__ >= 800 isSearchedVar i (G.HsVar (L _ i2)) = i == i2 #else @@ -444,7 +442,8 @@ isSearchedVar _ _ = False ---------------------------------------------------------------- -- REFINE AUTOMATICALLY ---------------------------------------------------------------- - +{- +This function needs djinn, which does not seem to be supported any more auto :: IOish m => FilePath -- ^ A target file. -> Int -- ^ Line number. @@ -516,10 +515,10 @@ tyThingsToInfo (G.AnId i : xs) = tyThingsToInfo (_:xs) = tyThingsToInfo xs -- Find the Id of the function and the pattern where the hole is located -getPatsForVariable :: G.TypecheckedSource -> (Int,Int) -> (Id, [Ty.LPat Id]) +getPatsForVariable :: G.TypecheckedSource -> (Int,Int) -> (Id, [Ty.LPat Gap.GhcTc]) getPatsForVariable tcs (lineNo, colNo) = let (L _ bnd:_) = sortBy (cmp `on` G.getLoc) $ - listifySpans tcs (lineNo, colNo) :: [G.LHsBind Id] + listifySpans tcs (lineNo, colNo) :: [G.LHsBind Gap.GhcTc] in case bnd of G.PatBind { Ty.pat_lhs = L ploc pat } -> case pat of Ty.ConPatIn (L _ i) _ -> (i, [L ploc pat]) @@ -527,19 +526,22 @@ getPatsForVariable tcs (lineNo, colNo) = G.FunBind { Ty.fun_id = L _ funId } -> let m = sortBy (cmp `on` G.getLoc) $ listifySpans tcs (lineNo, colNo) #if __GLASGOW_HASKELL__ >= 708 - :: [G.LMatch Id (G.LHsExpr Id)] + :: [G.LMatch Gap.GhcTc (G.LHsExpr Gap.GhcTc)] #else - :: [G.LMatch Id] + :: [G.LMatch Gap.GhcTc] #endif -#if __GLASGOW_HASKELL__ >= 710 +#if __GLASGOW_HASKELL__ >= 804 + (L _ (G.Match _ pats _):_) = m +#elif __GLASGOW_HASKELL__ >= 710 (L _ (G.Match _ pats _ _):_) = m #else (L _ (G.Match pats _ _):_) = m #endif in (funId, pats) _ -> (error "This should never happen", []) +-} -getBindingsForPat :: Ty.Pat Id -> M.Map G.Name Type +getBindingsForPat :: Ty.Pat Gap.GhcTc -> M.Map G.Name Type #if __GLASGOW_HASKELL__ >= 800 getBindingsForPat (Ty.VarPat (L _ i)) = M.singleton (G.getName i) (Ty.varType i) #else @@ -568,7 +570,7 @@ getBindingsForPat (Ty.ConPatIn (L _ i) d) = getBindingsForPat (Ty.ConPatOut { Ty.pat_args = d }) = getBindingsForRecPat d getBindingsForPat _ = M.empty -getBindingsForRecPat :: Ty.HsConPatDetails Id -> M.Map G.Name Type +getBindingsForRecPat :: Ty.HsConPatDetails Gap.GhcTc -> M.Map G.Name Type #if __GLASGOW_HASKELL__ >= 800 getBindingsForRecPat (G.PrefixCon args) = #else diff --git a/GhcMod/Exe/Test.hs b/GhcMod/Exe/Test.hs index d3901270f..53d1801ae 100644 --- a/GhcMod/Exe/Test.hs +++ b/GhcMod/Exe/Test.hs @@ -22,7 +22,11 @@ test f = runGmlT' [Left f] (fmap setHscInterpreted . deferErrors) $ do mg <- getModuleGraph root <- cradleRootDir <$> cradle f' <- makeRelative root <$> liftIO (canonicalizePath f) +#if __GLASGOW_HASKELL__ >= 804 + let Just ms = find ((==Just f') . ml_hs_file . ms_location) (mgModSummaries mg) +#else let Just ms = find ((==Just f') . ml_hs_file . ms_location) mg +#endif mdl = ms_mod ms mn = moduleName mdl diff --git a/core/GhcMod/SrcUtils.hs b/core/GhcMod/SrcUtils.hs index f16d7e1d0..4a5f5be4b 100644 --- a/core/GhcMod/SrcUtils.hs +++ b/core/GhcMod/SrcUtils.hs @@ -57,8 +57,15 @@ type CstGenQS = M.Map G.Var Type type CstGenQT a = forall m. GhcMonad m => a G.Id -> CstGenQS -> (m [(SrcSpan, Type)], CstGenQS) #endif -collectSpansTypes :: forall m.(GhcMonad m) => Bool -> G.TypecheckedModule -> (Int, Int) -> m [(SrcSpan, Type)] -collectSpansTypes withConstraints tcs lc = +collectSpansTypes :: (GhcMonad m) => Bool -> G.TypecheckedModule -> (Int,Int) -> m [(SrcSpan, Type)] +collectSpansTypes withConstraints tcs lc = collectSpansTypes' withConstraints tcs (`G.spans` lc) + +collectAllSpansTypes :: (GhcMonad m) => Bool -> G.TypecheckedModule -> m [(SrcSpan, Type)] +collectAllSpansTypes withConstraints tcs = collectSpansTypes' withConstraints tcs (const True) + +collectSpansTypes' :: forall m. (GhcMonad m) => Bool -> G.TypecheckedModule -> (SrcSpan -> Bool) -> m [(SrcSpan, Type)] +-- collectSpansTypes' :: forall m.(GhcMonad m) => Bool -> G.TypecheckedModule -> (Int, Int) -> m [(SrcSpan, Type)] +collectSpansTypes' withConstraints tcs f = -- This walks AST top-down, left-to-right, while carrying CstGenQS down the tree -- (but not left-to-right) #if __GLASGOW_HASKELL__ >= 804 @@ -118,7 +125,7 @@ collectSpansTypes withConstraints tcs lc = -- Gets monomorphic type with location getType' :: forall t . (HasType (Located t)) => Located t -> m (Maybe (SrcSpan, Type)) getType' x@(L spn _) - | G.isGoodSrcSpan spn && (spn `G.spans` lc) + | G.isGoodSrcSpan spn && f spn = getType tcs x | otherwise = return Nothing -- Gets constrained type diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 52e8914f0..c52d098ec 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -92,7 +92,7 @@ Extra-Source-Files: ChangeLog Custom-Setup Setup-Depends: base - , Cabal < 2.1 && >= 1.24 + , Cabal < 2.3 && >= 1.24 , cabal-doctest < 1.1 && >= 1 Library @@ -136,7 +136,7 @@ Library , transformers , base < 4.12 && >= 4.6.0.1 - , djinn-ghc < 0.1 && >= 0.0.2.2 + -- , djinn-ghc < 0.1 && >= 0.0.2.2 , extra < 1.7 && >= 1.4 , fclabels < 2.1 && >= 2.0 , ghc-paths < 0.2 && >= 0.1.0.9 @@ -227,7 +227,7 @@ Test-Suite doctest Default-Extensions: ConstraintKinds, FlexibleContexts Main-Is: doctests.hs Build-Depends: base < 4.12 && >= 4.6.0.1 - , doctest < 0.14 && >= 0.11.3 + , doctest < 0.16 && >= 0.11.3 Test-Suite spec Default-Language: Haskell2010 diff --git a/src/GhcMod/Exe/Options/Commands.hs b/src/GhcMod/Exe/Options/Commands.hs index cd8ef550a..e4929246b 100644 --- a/src/GhcMod/Exe/Options/Commands.hs +++ b/src/GhcMod/Exe/Options/Commands.hs @@ -13,12 +13,15 @@ -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} module GhcMod.Exe.Options.Commands where +#if __GLASGOW_HASKELL__ < 804 import Data.Semigroup +#endif import Options.Applicative import Options.Applicative.Types import Options.Applicative.Builder.Internal @@ -55,7 +58,7 @@ data GhcModCommands = | CmdType Bool FilePath Point | CmdSplit FilePath Point | CmdSig FilePath Point - | CmdAuto FilePath Point + -- | CmdAuto FilePath Point | CmdRefine FilePath Point Expr | CmdTest FilePath -- interactive-only commands @@ -167,9 +170,9 @@ commands = "ghc-mod would add the following on the next line:" code "func x y z f = _func_body" "(See: https://github.com/DanielG/ghc-mod/pull/274)" - <> command "auto" - $$ info autoArgSpec - $$ progDesc "Try to automatically fill the contents of a hole" + -- <> command "auto" + -- $$ info autoArgSpec + -- $$ progDesc "Try to automatically fill the contents of a hole" <> command "refine" $$ info refineArgSpec $$ progDesc "Refine the typed hole at (LINE,COL) given EXPR" @@ -229,7 +232,7 @@ locArgSpec x = x modulesArgSpec, docArgSpec, findArgSpec, lintArgSpec, browseArgSpec, checkArgSpec, expandArgSpec, - infoArgSpec, typeArgSpec, autoArgSpec, splitArgSpec, + infoArgSpec, typeArgSpec, splitArgSpec, sigArgSpec, refineArgSpec, debugComponentArgSpec, mapArgSpec, unmapArgSpec, legacyInteractiveArgSpec :: Parser GhcModCommands @@ -277,7 +280,7 @@ typeArgSpec = locArgSpec $ CmdType <$> $$ long "constraints" <=> short 'c' <=> help "Include constraints into type signature" -autoArgSpec = locArgSpec (pure CmdAuto) +-- autoArgSpec = locArgSpec (pure CmdAuto) splitArgSpec = locArgSpec (pure CmdSplit) sigArgSpec = locArgSpec (pure CmdSig) refineArgSpec = locArgSpec (pure CmdRefine) <*> strArg "SYMBOL" diff --git a/src/GhcModMain.hs b/src/GhcModMain.hs index d4c011661..e6b6bdbfd 100644 --- a/src/GhcModMain.hs +++ b/src/GhcModMain.hs @@ -151,7 +151,7 @@ ghcCommands (CmdInfo file symb) = info file $ Expression symb ghcCommands (CmdType wCon file (line, col)) = types wCon file line col ghcCommands (CmdSplit file (line, col)) = splits file line col ghcCommands (CmdSig file (line, col)) = sig file line col -ghcCommands (CmdAuto file (line, col)) = auto file line col +-- ghcCommands (CmdAuto file (line, col)) = auto file line col ghcCommands (CmdRefine file (line, col) expr) = refine file line col $ Expression expr -- interactive-only commands ghcCommands (CmdMapFile f) = From 90c7c0faac794a3b582aa794fa9f6eba5f190269 Mon Sep 17 00:00:00 2001 From: Thomas Smith Date: Sat, 21 Apr 2018 13:05:59 +0200 Subject: [PATCH 4/9] Implement splits' to return a structured restult for case splitting - Refactor splits and split' to reduce duplicate code - Make performSplit less partial - Fix error in determining SplitResult source locations. - Accommodate AST change in 8.4.1 - Fix typo in GHC version check --- GhcMod/Exe/CaseSplit.hs | 109 +++++++++++++++++++++++++++++----------- core/GhcMod/Gap.hs | 4 +- 2 files changed, 83 insertions(+), 30 deletions(-) diff --git a/GhcMod/Exe/CaseSplit.hs b/GhcMod/Exe/CaseSplit.hs index 80afd35a0..cf01159b2 100644 --- a/GhcMod/Exe/CaseSplit.hs +++ b/GhcMod/Exe/CaseSplit.hs @@ -2,6 +2,8 @@ module GhcMod.Exe.CaseSplit ( splits + , splits' + , SplitResult(..) ) where import Data.List (find, intercalate) @@ -12,7 +14,7 @@ import System.FilePath import Prelude import qualified DataCon as Ty -import GHC (GhcMonad, LPat, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L)) +import GHC (GhcMonad, LPat, TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L)) import qualified GHC as G import Outputable (PprStyle) import qualified TyCon as Ty @@ -42,8 +44,15 @@ data SplitToTextInfo = SplitToTextInfo { sVarName :: String , sVarSpan :: SrcSpan , sTycons :: [String] } +data SplitResult = SplitResult { sStartLine :: Int + , sStartCol :: Int + , sEndLine :: Int + , sEndCol :: Int + , sNewText :: T.Text } -- | Splitting a variable in a equation. +-- Unlike splits', this performs parsing an type checking on every invocation. +-- This is meant for consumption by tools that call ghc-mod as a binary. splits :: IOish m => FilePath -- ^ A target file. -> Int -- ^ Line number. @@ -53,41 +62,81 @@ splits file lineNo colNo = ghandle handler $ runGmlT' [Left file] deferErrors $ do oopts <- outputOpts crdl <- cradle - style <- getStyle - dflag <- G.getSessionDynFlags modSum <- fileModSummaryWithMapping (cradleCurrentDir crdl file) - whenFound' oopts (getSrcSpanTypeForSplit modSum lineNo colNo) $ \x -> do - let (varName, bndLoc, (varLoc,varT)) - | (SplitInfo vn bl vlvt _matches) <- x - = (vn, bl, vlvt) - | (TySplitInfo vn bl vlvt) <- x - = (vn, bl, vlvt) - varName' = showName dflag style varName -- Convert name to string - t <- withMappedFile file $ \file' -> - genCaseSplitTextFile file' (SplitToTextInfo varName' bndLoc varLoc $ - getTyCons dflag style varName varT) - return $!! (fourInts bndLoc, t) + p <- G.parseModule modSum + tcm <- G.typecheckModule p + whenFound' oopts (performSplit file tcm lineNo colNo) $ + \(SplitResult sLine sCol eLine eCol newText) -> + return $!! ((sLine, sCol, eLine, eCol), T.unpack newText) where handler (SomeException ex) = do gmLog GmException "splits" $ text "" $$ nest 4 (showToDoc ex) emptyResult =<< outputOpts +-- | Split an identifier in a function definition. +-- Meant for library-usage. +splits' :: IOish m => FilePath -> TypecheckedModule -> Int -> Int -> GhcModT m (Maybe SplitResult) +splits' file tcm lineNo colNo = + ghandle handler $ runGmlT' [Left file] deferErrors $ performSplit file tcm lineNo colNo + where + handler (SomeException ex) = do + gmLog GmException "splits'" $ + text "" $$ nest 4 (showToDoc ex) + return Nothing + +performSplit :: IOish m => FilePath -> TypecheckedModule -> Int -> Int -> GmlT m (Maybe SplitResult) +performSplit file tcm lineNo colNo = do + style <- getStyle + dflag <- G.getSessionDynFlags + maybeSplitInfo <- getSrcSpanTypeForSplit tcm lineNo colNo + sequenceA $ constructSplitResult file maybeSplitInfo dflag style + +constructSplitResult :: (IOish m) => FilePath -> Maybe SplitInfo -> DynFlags -> PprStyle -> Maybe (GmlT m SplitResult) +constructSplitResult file maybeSplitInfo dflag style = do + splitInfo <- maybeSplitInfo + let splitToTextInfo = constructSplitToTextInfo splitInfo dflag style + startLoc <- maybeSrcSpanStart $ sBindingSpan splitToTextInfo + endLoc <- maybeSrcSpanEnd $ sBindingSpan splitToTextInfo + let startLine = G.srcLocLine startLoc + startCol = G.srcLocCol startLoc + endLine = G.srcLocLine endLoc + endCol = G.srcLocCol endLoc + newText = genCaseSplitTextFile file splitToTextInfo + return $ SplitResult startLine startCol endLine endCol . T.pack <$> newText + +constructSplitToTextInfo :: SplitInfo -> DynFlags -> PprStyle -> SplitToTextInfo +constructSplitToTextInfo splitInfo dflag style = + SplitToTextInfo varName' bndLoc varLoc typeCons + where + typeCons = getTyCons dflag style varName varT + varName' = showName dflag style varName -- Convert name to string + (varName, bndLoc, varLoc, varT) = case splitInfo of + (SplitInfo vn bl (vl, vt) _matches) -> (vn, bl, vl, vt) + (TySplitInfo vn bl (vl, vt)) -> (vn, bl, vl, vt) + +maybeSrcSpanStart :: G.SrcSpan -> Maybe G.RealSrcLoc +maybeSrcSpanStart s = case G.srcSpanStart s of + (G.RealSrcLoc startLoc) -> Just startLoc + _ -> Nothing + +maybeSrcSpanEnd :: G.SrcSpan -> Maybe G.RealSrcLoc +maybeSrcSpanEnd s = case G.srcSpanEnd s of + (G.RealSrcLoc endLoc) -> Just endLoc + _ -> Nothing ---------------------------------------------------------------- -- a. Code for getting the information of the variable -getSrcSpanTypeForSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SplitInfo) -getSrcSpanTypeForSplit modSum lineNo colNo = do - fn <- getSrcSpanTypeForFnSplit modSum lineNo colNo +getSrcSpanTypeForSplit :: GhcMonad m => TypecheckedModule -> Int -> Int -> m (Maybe SplitInfo) +getSrcSpanTypeForSplit tcm lineNo colNo = do + fn <- getSrcSpanTypeForFnSplit tcm lineNo colNo if isJust fn then return fn - else getSrcSpanTypeForTypeSplit modSum lineNo colNo + else getSrcSpanTypeForTypeSplit tcm lineNo colNo -- Information for a function case split -getSrcSpanTypeForFnSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SplitInfo) -getSrcSpanTypeForFnSplit modSum lineNo colNo = do - p@ParsedModule{pm_parsed_source = _pms} <- G.parseModule modSum - tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p +getSrcSpanTypeForFnSplit :: GhcMonad m => TypecheckedModule -> Int -> Int -> m (Maybe SplitInfo) +getSrcSpanTypeForFnSplit tcm@TypecheckedModule{tm_typechecked_source = tcs} lineNo colNo = do let varPat = find isPatternVar $ listifySpans tcs (lineNo, colNo) :: Maybe (LPat Gap.GhcTc) match = last $ listifySpans tcs (lineNo, colNo) :: Gap.GLMatchI case varPat of @@ -119,8 +168,8 @@ getPatternVarName (L _ (G.VarPat vName)) = G.getName vName getPatternVarName _ = error "This should never happened" -- TODO: Information for a type family case split -getSrcSpanTypeForTypeSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SplitInfo) -getSrcSpanTypeForTypeSplit _modSum _lineNo _colNo = return Nothing +getSrcSpanTypeForTypeSplit :: GhcMonad m => TypecheckedModule -> Int -> Int -> m (Maybe SplitInfo) +getSrcSpanTypeForTypeSplit _tcm _lineNo _colNo = return Nothing ---------------------------------------------------------------- -- b. Code for getting the possible constructors @@ -209,11 +258,13 @@ showFieldNames dflag style v (x:xs) = let fName = showName dflag style x ---------------------------------------------------------------- -- c. Code for performing the case splitting -genCaseSplitTextFile :: (MonadIO m, GhcMonad m) => - FilePath -> SplitToTextInfo -> m String -genCaseSplitTextFile file info = liftIO $ do - t <- T.readFile file - return $ getCaseSplitText (T.lines t) info + +genCaseSplitTextFile :: IOish m => + FilePath -> SplitToTextInfo -> GmlT m String +genCaseSplitTextFile file info = + withMappedFile file $ \file' -> liftIO $ do + t <- T.readFile file' + return $ getCaseSplitText (T.lines t) info getCaseSplitText :: [T.Text] -> SplitToTextInfo -> String getCaseSplitText t SplitToTextInfo{ sVarName = sVN, sBindingSpan = sBS diff --git a/core/GhcMod/Gap.hs b/core/GhcMod/Gap.hs index 91bed2556..b75ae3004 100644 --- a/core/GhcMod/Gap.hs +++ b/core/GhcMod/Gap.hs @@ -618,7 +618,9 @@ type GhcRn = Name type GhcTc = Id #endif -#if __GLASGOW_HASKELL__ >= 708 +#if __GLASGOW_HASKELL__ >= 804 +type GLMatchI = LMatch GhcTc (LHsExpr GhcTc) +#elif __GLASGOW_HASKELL__ >= 708 type GLMatch = LMatch GhcPs (LHsExpr GhcPs) type GLMatchI = LMatch Id (LHsExpr Id) #else From 9ea60d5753dfabde8feb136443981d1645d7177a Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Wed, 9 May 2018 11:20:57 +0530 Subject: [PATCH 5/9] Use canonicalizePath in FileMapping - Canonicalize mapped path also - Fix compilation with GHC 8.4.3 --- core/GhcMod/FileMapping.hs | 7 ++++--- core/GhcMod/Gap.hs | 5 +++-- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/core/GhcMod/FileMapping.hs b/core/GhcMod/FileMapping.hs index e05a54066..5b9d891b8 100644 --- a/core/GhcMod/FileMapping.hs +++ b/core/GhcMod/FileMapping.hs @@ -57,11 +57,12 @@ loadMappedFileSource from src = do loadMappedFile' :: IOish m => FilePath -> FilePath -> Bool -> GhcModT m () loadMappedFile' from to isTemp = do - cfn <- getCanonicalFileNameSafe from + cfn <- liftIO $ canonicalizePath from unloadMappedFile' cfn crdl <- cradle - let to' = makeRelative (cradleRootDir crdl) to - addMMappedFile cfn (FileMapping to' isTemp) + to' <- liftIO $ canonicalizePath to + let to'' = makeRelative (cradleRootDir crdl) to' + addMMappedFile cfn (FileMapping to'' isTemp) mapFile :: (IOish m, GmState m) => HscEnv -> Target -> m Target mapFile _ (Target tid@(TargetFile filePath _) taoc _) = do diff --git a/core/GhcMod/Gap.hs b/core/GhcMod/Gap.hs index b75ae3004..a77496ff4 100644 --- a/core/GhcMod/Gap.hs +++ b/core/GhcMod/Gap.hs @@ -619,12 +619,13 @@ type GhcTc = Id #endif #if __GLASGOW_HASKELL__ >= 804 +type GLMatch = LMatch GhcPs (LHsExpr GhcPs) type GLMatchI = LMatch GhcTc (LHsExpr GhcTc) #elif __GLASGOW_HASKELL__ >= 708 -type GLMatch = LMatch GhcPs (LHsExpr GhcPs) +type GLMatch = LMatch GhcPs (LHsExpr GhcPs) type GLMatchI = LMatch Id (LHsExpr Id) #else -type GLMatch = LMatch GhcPs +type GLMatch = LMatch GhcPs type GLMatchI = LMatch Id #endif From 214fe1b9f5e604047699465ef903cb44368e205f Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Sun, 17 Jun 2018 18:50:21 +0200 Subject: [PATCH 6/9] Match code style to the existing code i.e. all GHC stuff is qualified with G. --- GhcMod/Exe/CaseSplit.hs | 59 ++++++++++++++++++++--------------------- core/GhcMod/Gap.hs | 13 --------- 2 files changed, 29 insertions(+), 43 deletions(-) diff --git a/GhcMod/Exe/CaseSplit.hs b/GhcMod/Exe/CaseSplit.hs index cf01159b2..d1deea041 100644 --- a/GhcMod/Exe/CaseSplit.hs +++ b/GhcMod/Exe/CaseSplit.hs @@ -14,7 +14,6 @@ import System.FilePath import Prelude import qualified DataCon as Ty -import GHC (GhcMonad, LPat, TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L)) import qualified GHC as G import Outputable (PprStyle) import qualified TyCon as Ty @@ -37,11 +36,11 @@ import Control.DeepSeq -- CASE SPLITTING ---------------------------------------------------------------- -data SplitInfo = SplitInfo G.Name SrcSpan (SrcSpan, Type) [SrcSpan] - | TySplitInfo G.Name SrcSpan (SrcSpan, Ty.Kind) +data SplitInfo = SplitInfo G.Name G.SrcSpan (G.SrcSpan, G.Type) [G.SrcSpan] + | TySplitInfo G.Name G.SrcSpan (G.SrcSpan, Ty.Kind) data SplitToTextInfo = SplitToTextInfo { sVarName :: String - , sBindingSpan :: SrcSpan - , sVarSpan :: SrcSpan + , sBindingSpan :: G.SrcSpan + , sVarSpan :: G.SrcSpan , sTycons :: [String] } data SplitResult = SplitResult { sStartLine :: Int @@ -76,7 +75,7 @@ splits file lineNo colNo = -- | Split an identifier in a function definition. -- Meant for library-usage. -splits' :: IOish m => FilePath -> TypecheckedModule -> Int -> Int -> GhcModT m (Maybe SplitResult) +splits' :: IOish m => FilePath -> G.TypecheckedModule -> Int -> Int -> GhcModT m (Maybe SplitResult) splits' file tcm lineNo colNo = ghandle handler $ runGmlT' [Left file] deferErrors $ performSplit file tcm lineNo colNo where @@ -85,14 +84,14 @@ splits' file tcm lineNo colNo = text "" $$ nest 4 (showToDoc ex) return Nothing -performSplit :: IOish m => FilePath -> TypecheckedModule -> Int -> Int -> GmlT m (Maybe SplitResult) +performSplit :: IOish m => FilePath -> G.TypecheckedModule -> Int -> Int -> GmlT m (Maybe SplitResult) performSplit file tcm lineNo colNo = do style <- getStyle dflag <- G.getSessionDynFlags maybeSplitInfo <- getSrcSpanTypeForSplit tcm lineNo colNo sequenceA $ constructSplitResult file maybeSplitInfo dflag style -constructSplitResult :: (IOish m) => FilePath -> Maybe SplitInfo -> DynFlags -> PprStyle -> Maybe (GmlT m SplitResult) +constructSplitResult :: (IOish m) => FilePath -> Maybe SplitInfo -> G.DynFlags -> PprStyle -> Maybe (GmlT m SplitResult) constructSplitResult file maybeSplitInfo dflag style = do splitInfo <- maybeSplitInfo let splitToTextInfo = constructSplitToTextInfo splitInfo dflag style @@ -105,7 +104,7 @@ constructSplitResult file maybeSplitInfo dflag style = do newText = genCaseSplitTextFile file splitToTextInfo return $ SplitResult startLine startCol endLine endCol . T.pack <$> newText -constructSplitToTextInfo :: SplitInfo -> DynFlags -> PprStyle -> SplitToTextInfo +constructSplitToTextInfo :: SplitInfo -> G.DynFlags -> PprStyle -> SplitToTextInfo constructSplitToTextInfo splitInfo dflag style = SplitToTextInfo varName' bndLoc varLoc typeCons where @@ -127,7 +126,7 @@ maybeSrcSpanEnd s = case G.srcSpanEnd s of ---------------------------------------------------------------- -- a. Code for getting the information of the variable -getSrcSpanTypeForSplit :: GhcMonad m => TypecheckedModule -> Int -> Int -> m (Maybe SplitInfo) +getSrcSpanTypeForSplit :: G.GhcMonad m => G.TypecheckedModule -> Int -> Int -> m (Maybe SplitInfo) getSrcSpanTypeForSplit tcm lineNo colNo = do fn <- getSrcSpanTypeForFnSplit tcm lineNo colNo if isJust fn @@ -135,10 +134,10 @@ getSrcSpanTypeForSplit tcm lineNo colNo = do else getSrcSpanTypeForTypeSplit tcm lineNo colNo -- Information for a function case split -getSrcSpanTypeForFnSplit :: GhcMonad m => TypecheckedModule -> Int -> Int -> m (Maybe SplitInfo) -getSrcSpanTypeForFnSplit tcm@TypecheckedModule{tm_typechecked_source = tcs} lineNo colNo = do - let varPat = find isPatternVar $ listifySpans tcs (lineNo, colNo) :: Maybe (LPat Gap.GhcTc) - match = last $ listifySpans tcs (lineNo, colNo) :: Gap.GLMatchI +getSrcSpanTypeForFnSplit :: G.GhcMonad m => G.TypecheckedModule -> Int -> Int -> m (Maybe SplitInfo) +getSrcSpanTypeForFnSplit tcm@G.TypecheckedModule{G.tm_typechecked_source = tcs} lineNo colNo = do + let varPat = find isPatternVar $ listifySpans tcs (lineNo, colNo) :: Maybe (G.LPat Gap.GhcTc) + match = last $ listifySpans tcs (lineNo, colNo) :: G.LMatch Gap.GhcTc (G.LHsExpr Gap.GhcTc) case varPat of Nothing -> return Nothing Just varPat' -> do @@ -146,42 +145,42 @@ getSrcSpanTypeForFnSplit tcm@TypecheckedModule{tm_typechecked_source = tcs} line case varT of Just varT' -> #if __GLASGOW_HASKELL__ >= 804 - let (L matchL (G.Match _ _ (G.GRHSs rhsLs _))) = match + let (G.L matchL (G.Match _ _ (G.GRHSs rhsLs _))) = match #elif __GLASGOW_HASKELL__ >= 710 - let (L matchL (G.Match _ _ _ (G.GRHSs rhsLs _))) = match + let (G.L matchL (G.Match _ _ _ (G.GRHSs rhsLs _))) = match #else - let (L matchL (G.Match _ _ (G.GRHSs rhsLs _))) = match + let (G.L matchL (G.Match _ _ (G.GRHSs rhsLs _))) = match #endif in return $ Just (SplitInfo (getPatternVarName varPat') matchL varT' (map G.getLoc rhsLs) ) _ -> return Nothing -isPatternVar :: LPat Gap.GhcTc -> Bool -isPatternVar (L _ (G.VarPat _)) = True +isPatternVar :: G.LPat Gap.GhcTc -> Bool +isPatternVar (G.L _ (G.VarPat _)) = True isPatternVar _ = False -getPatternVarName :: LPat Gap.GhcTc -> G.Name +getPatternVarName :: G.LPat Gap.GhcTc -> G.Name #if __GLASGOW_HASKELL__ >= 800 -getPatternVarName (L _ (G.VarPat (L _ vName))) = G.getName vName +getPatternVarName (G.L _ (G.VarPat (G.L _ vName))) = G.getName vName #else -getPatternVarName (L _ (G.VarPat vName)) = G.getName vName +getPatternVarName (G.L _ (G.VarPat vName)) = G.getName vName #endif getPatternVarName _ = error "This should never happened" -- TODO: Information for a type family case split -getSrcSpanTypeForTypeSplit :: GhcMonad m => TypecheckedModule -> Int -> Int -> m (Maybe SplitInfo) +getSrcSpanTypeForTypeSplit :: G.GhcMonad m => G.TypecheckedModule -> Int -> Int -> m (Maybe SplitInfo) getSrcSpanTypeForTypeSplit _tcm _lineNo _colNo = return Nothing ---------------------------------------------------------------- -- b. Code for getting the possible constructors -getTyCons :: DynFlags -> PprStyle -> G.Name -> G.Type -> [String] +getTyCons :: G.DynFlags -> PprStyle -> G.Name -> G.Type -> [String] getTyCons dflag style name ty | Just (tyCon, _) <- Ty.splitTyConApp_maybe ty = let name' = showName dflag style name -- Convert name to string in getTyCon dflag style name' tyCon getTyCons dflag style name _ = [showName dflag style name] -- Write cases for one type -getTyCon :: DynFlags -> PprStyle -> String -> Ty.TyCon -> [String] +getTyCon :: G.DynFlags -> PprStyle -> String -> Ty.TyCon -> [String] -- 1. Non-matcheable type constructors getTyCon _ _ name tyCon | isNotMatcheableTyCon tyCon = [name] -- 2. Special cases @@ -203,7 +202,7 @@ isNotMatcheableTyCon ty = Ty.isPrimTyCon ty -- Primitive types, such as Int# || Ty.isFunTyCon ty -- Function types -- Write case for one constructor -getDataCon :: DynFlags -> PprStyle -> String -> Ty.DataCon -> String +getDataCon :: G.DynFlags -> PprStyle -> String -> Ty.DataCon -> String -- 1. Infix constructors getDataCon dflag style vName dcon | Ty.dataConIsInfix dcon = let dName = showName dflag style $ Ty.dataConName dcon @@ -247,7 +246,7 @@ newVarsSpecialSingleton :: String -> Int -> Int -> String newVarsSpecialSingleton v _ 1 = v newVarsSpecialSingleton v start n = newVars v start n -showFieldNames :: DynFlags -> PprStyle -> String -> [G.Name] -> String +showFieldNames :: G.DynFlags -> PprStyle -> String -> [G.Name] -> String showFieldNames _ _ _ [] = "" -- This should never happen showFieldNames dflag style v (x:xs) = let fName = showName dflag style x fAcc = fName ++ " = " ++ v ++ "_" ++ fName @@ -277,7 +276,7 @@ getCaseSplitText t SplitToTextInfo{ sVarName = sVN, sBindingSpan = sBS replaced' = head replaced : map (indentBindingTo sBS) (tail replaced) in T.unpack $ T.intercalate (T.pack "\n") (concat replaced') -getBindingText :: [T.Text] -> SrcSpan -> [T.Text] +getBindingText :: [T.Text] -> G.SrcSpan -> [T.Text] getBindingText t srcSpan = let Just (sl,sc,el,ec) = Gap.getSrcSpan srcSpan lines_ = drop (sl - 1) $ take el t @@ -288,7 +287,7 @@ getBindingText t srcSpan = let (first,rest,last_) = (head lines_, tail $ init lines_, last lines_) in T.drop (sc - 1) first : rest ++ [T.take ec last_] -srcSpanDifference :: SrcSpan -> SrcSpan -> (Int,Int,Int,Int) +srcSpanDifference :: G.SrcSpan -> G.SrcSpan -> (Int,Int,Int,Int) srcSpanDifference b v = let Just (bsl,bsc,_ ,_) = Gap.getSrcSpan b Just (vsl,vsc,vel,vec) = Gap.getSrcSpan v @@ -307,7 +306,7 @@ replaceVarWithTyCon t (vsl,vsc,_,vec) varname tycon = else T.replicate spacesToAdd (T.pack " ") `T.append` line) [0 ..] t -indentBindingTo :: SrcSpan -> [T.Text] -> [T.Text] +indentBindingTo :: G.SrcSpan -> [T.Text] -> [T.Text] indentBindingTo bndLoc binds = let Just (_,sl,_,_) = Gap.getSrcSpan bndLoc indent = (T.replicate (sl - 1) (T.pack " ") `T.append`) diff --git a/core/GhcMod/Gap.hs b/core/GhcMod/Gap.hs index a77496ff4..33252b040 100644 --- a/core/GhcMod/Gap.hs +++ b/core/GhcMod/Gap.hs @@ -37,8 +37,6 @@ module GhcMod.Gap ( , fileModSummary , WarnFlags , emptyWarnFlags - , GLMatch - , GLMatchI , getClass , occName , listVisibleModuleNames @@ -618,17 +616,6 @@ type GhcRn = Name type GhcTc = Id #endif -#if __GLASGOW_HASKELL__ >= 804 -type GLMatch = LMatch GhcPs (LHsExpr GhcPs) -type GLMatchI = LMatch GhcTc (LHsExpr GhcTc) -#elif __GLASGOW_HASKELL__ >= 708 -type GLMatch = LMatch GhcPs (LHsExpr GhcPs) -type GLMatchI = LMatch Id (LHsExpr Id) -#else -type GLMatch = LMatch GhcPs -type GLMatchI = LMatch Id -#endif - getClass :: [LInstDecl GhcRn] -> Maybe (Name, SrcSpan) #if __GLASGOW_HASKELL__ >= 802 -- Instance declarations of sort 'instance F (G a)' From 66fc0980d2c731caf36215969a31bff8ef40f3e2 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Sat, 8 Jul 2017 12:57:11 +0530 Subject: [PATCH 7/9] Only load mapped files from the current component --- GhcMod/Exe/Debug.hs | 2 +- core/GhcMod/Target.hs | 2 +- core/GhcMod/Utils.hs | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/GhcMod/Exe/Debug.hs b/GhcMod/Exe/Debug.hs index 7005bbb48..3cdfd4443 100644 --- a/GhcMod/Exe/Debug.hs +++ b/GhcMod/Exe/Debug.hs @@ -123,7 +123,7 @@ componentInfo ts = do mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn candidates = findCandidates $ map snd mdlcs cn = pickComponent candidates - (opts,_) <- targetGhcOptions crdl sefnmn + opts <- fst <$> targetGhcOptions crdl sefnmn return $ unlines $ [ "Matching Components:\n" ++ renderGm (nest 4 $ diff --git a/core/GhcMod/Target.hs b/core/GhcMod/Target.hs index de39bc6e6..63d295d01 100644 --- a/core/GhcMod/Target.hs +++ b/core/GhcMod/Target.hs @@ -193,6 +193,7 @@ runGmlTWith' efnmns' mdf mUpdateHooks wrapper action = do cfns <- mapM getCanonicalFileNameSafe ccfns let serfnmn = Set.fromList $ map Right mns ++ map Left cfns (opts, mappedStrs) <- targetGhcOptions crdl serfnmn + let opts' = opts ++ ["-O0", "-fno-warn-missing-home-modules"] ++ optGhcUserOptions gmVomit @@ -213,7 +214,6 @@ runGmlTWith' efnmns' mdf mUpdateHooks wrapper action = do initSession opts' $ setHscNothing >>> setLogger >>> mdf - mappedStrs <- getMMappedFilePaths let targetStrs = mappedStrs ++ map moduleNameString mns ++ cfns gmVomit diff --git a/core/GhcMod/Utils.hs b/core/GhcMod/Utils.hs index 7c282357b..0d18ce81c 100644 --- a/core/GhcMod/Utils.hs +++ b/core/GhcMod/Utils.hs @@ -113,7 +113,7 @@ withMappedFile file action = getCanonicalFileNameSafe file >>= lookupMMappedFile runWithFile (Just to) = action $ fmPath to runWithFile _ = action file -getCanonicalFileNameSafe :: (IOish m, GmEnv m) => FilePath -> m FilePath +getCanonicalFileNameSafe :: (IOish m) => FilePath -> m FilePath getCanonicalFileNameSafe fn = do let fn' = normalise fn pl <- liftIO $ rights <$> (mapM ((try :: IO FilePath -> IO (Either SomeException FilePath)) . canonicalizePath . joinPath) $ reverse $ inits $ splitPath' fn') From 973e46c08b2512507529ff63369b8b589d9b6afe Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Tue, 28 Aug 2018 14:42:45 +0100 Subject: [PATCH 8/9] Return parsed module in getTypecheckedModuleGhc --- core/GhcMod/ModuleLoader.hs | 38 +++++++++++++++++++++---------------- 1 file changed, 22 insertions(+), 16 deletions(-) diff --git a/core/GhcMod/ModuleLoader.hs b/core/GhcMod/ModuleLoader.hs index 8fbf0ba01..f01952650 100644 --- a/core/GhcMod/ModuleLoader.hs +++ b/core/GhcMod/ModuleLoader.hs @@ -17,7 +17,7 @@ import qualified GhcMod.Monad as GM import qualified GhcMod.Target as GM import qualified GhcMod.Types as GM -import GHC (TypecheckedModule) +import GHC (TypecheckedModule, ParsedModule) import qualified GHC import qualified DynFlags as GHC import qualified GhcMonad as GHC @@ -54,43 +54,47 @@ tweakModSummaryDynFlags ms = -- to the includePaths for CPP purposes. -- Use in combination with `runActionInContext` for best results getTypecheckedModuleGhc' :: GM.IOish m - => (GM.GmlT m () -> GM.GmlT m a) -> FilePath -> GM.GhcModT m (a, Maybe TypecheckedModule) + => (GM.GmlT m () -> GM.GmlT m a) -> FilePath -> GM.GhcModT m (a, Maybe TypecheckedModule, Maybe ParsedModule) getTypecheckedModuleGhc' wrapper targetFile = do cfileName <- liftIO $ canonicalizePath targetFile mfs <- GM.getMMappedFiles mFileName <- liftIO . canonicalizePath $ getMappedFileName cfileName mfs - ref <- liftIO $ newIORef Nothing + refTypechecked <- liftIO $ newIORef Nothing + refParsed <- liftIO $ newIORef Nothing let keepInfo = pure . (mFileName ==) - saveModule = writeIORef ref . Just - res <- getTypecheckedModuleGhc wrapper [cfileName] keepInfo saveModule - mtm <- liftIO $ readIORef ref - return (res, mtm) + saveTypechecked = writeIORef refTypechecked . Just + saveParsed = writeIORef refParsed . Just + res <- getTypecheckedModuleGhc wrapper [cfileName] keepInfo saveTypechecked saveParsed + mtm <- liftIO $ readIORef refTypechecked + mpm <- liftIO $ readIORef refParsed + return (res, mtm, mpm) -- | like getTypecheckedModuleGhc' but allows you to keep an arbitary number of Modules -- `keepInfo` decides which TypecheckedModule to keep -- `saveModule` is the callback that is passed the TypecheckedModule getTypecheckedModuleGhc :: GM.IOish m - => (GM.GmlT m () -> GM.GmlT m a) -> [FilePath] -> (FilePath -> IO Bool) -> (TypecheckedModule -> IO ()) -> GM.GhcModT m a -getTypecheckedModuleGhc wrapper targetFiles keepInfo saveModule = do + => (GM.GmlT m () -> GM.GmlT m a) -> [FilePath] -> (FilePath -> IO Bool) -> (TypecheckedModule -> IO ()) -> (ParsedModule -> IO ()) -> GM.GhcModT m a +getTypecheckedModuleGhc wrapper targetFiles keepInfo saveTypechecked saveParsed = do mfs <- GM.getMMappedFiles let ips = map takeDirectory $ Map.keys mfs setIncludePaths df = df { GHC.includePaths = ips ++ GHC.includePaths df } GM.runGmlTWith' (map Left targetFiles) (return . setIncludePaths) - (Just $ updateHooks keepInfo saveModule) + (Just $ updateHooks keepInfo saveTypechecked saveParsed) wrapper (return ()) updateHooks :: (FilePath -> IO Bool) -> (TypecheckedModule -> IO ()) + -> (ParsedModule -> IO ()) -> GHC.Hooks -> GHC.Hooks -updateHooks fp ref hooks = hooks { +updateHooks fp ref refParsed hooks = hooks { #if __GLASGOW_HASKELL__ <= 710 GHC.hscFrontendHook = Just $ hscFrontend fp ref #else - GHC.hscFrontendHook = Just $ fmap GHC.FrontendTypecheck . hscFrontend fp ref + GHC.hscFrontendHook = Just $ fmap GHC.FrontendTypecheck . hscFrontend fp ref refParsed #endif } @@ -105,24 +109,26 @@ runGhcInHsc action = do -- | Frontend hook that keeps the TypecheckedModule for its first argument -- and stores it in the IORef passed to it -hscFrontend :: (FilePath -> IO Bool) -> (TypecheckedModule -> IO ()) -> GHC.ModSummary -> GHC.Hsc GHC.TcGblEnv -hscFrontend keepInfoFunc saveModule mod_summary = do +hscFrontend :: (FilePath -> IO Bool) -> (TypecheckedModule -> IO ()) -> (ParsedModule -> IO ()) -> GHC.ModSummary -> GHC.Hsc GHC.TcGblEnv +hscFrontend keepInfoFunc saveTypechecked saveParsed mod_summary = do mfn <- canonicalizeModSummary mod_summary -- md = GHC.moduleNameString $ GHC.moduleName $ GHC.ms_mod mod_summary keepInfo <- case mfn of Just fileName -> liftIO $ keepInfoFunc fileName Nothing -> pure False - -- liftIO $ debugm $ "hscFrontend: got mod,file" ++ show (md, mfn) + if keepInfo then runGhcInHsc $ do let modSumWithRaw = tweakModSummaryDynFlags mod_summary p' <- GHC.parseModule modSumWithRaw let p = p' {GHC.pm_mod_summary = mod_summary} + liftIO $ saveParsed p + tc <- GHC.typecheckModule p let tc_gbl_env = fst $ GHC.tm_internals_ tc - liftIO $ saveModule tc + liftIO $ saveTypechecked tc return tc_gbl_env else do hpm <- GHC.hscParse' mod_summary From 30f31ad61003cfc36f4de0f67aee5031cc54ba77 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Sun, 9 Sep 2018 17:29:01 +0100 Subject: [PATCH 9/9] Rename getTypecheckedModule to getModules --- core/GhcMod/ModuleLoader.hs | 23 ++++++++++++----------- core/GhcModCore.hs | 4 ++-- 2 files changed, 14 insertions(+), 13 deletions(-) diff --git a/core/GhcMod/ModuleLoader.hs b/core/GhcMod/ModuleLoader.hs index f01952650..fd36791f2 100644 --- a/core/GhcMod/ModuleLoader.hs +++ b/core/GhcMod/ModuleLoader.hs @@ -4,8 +4,8 @@ -- | Uses GHC hooks to load a TypecheckedModule module GhcMod.ModuleLoader - ( getTypecheckedModuleGhc - , getTypecheckedModuleGhc' + ( getModulesGhc + , getModulesGhc' ) where import Control.Monad.IO.Class @@ -47,15 +47,15 @@ tweakModSummaryDynFlags ms = let df = GHC.ms_hspp_opts ms in ms { GHC.ms_hspp_opts = GHC.gopt_set df GHC.Opt_KeepRawTokenStream } --- | Gets a TypecheckedModule from a given file +-- | Gets a TypecheckedModule and/or ParsedModule from a given file -- The `wrapper` allows arbitary data to be captured during -- the compilation process, like errors and warnings -- Appends the parent directories of all the mapped files -- to the includePaths for CPP purposes. -- Use in combination with `runActionInContext` for best results -getTypecheckedModuleGhc' :: GM.IOish m +getModulesGhc' :: GM.IOish m => (GM.GmlT m () -> GM.GmlT m a) -> FilePath -> GM.GhcModT m (a, Maybe TypecheckedModule, Maybe ParsedModule) -getTypecheckedModuleGhc' wrapper targetFile = do +getModulesGhc' wrapper targetFile = do cfileName <- liftIO $ canonicalizePath targetFile mfs <- GM.getMMappedFiles mFileName <- liftIO . canonicalizePath $ getMappedFileName cfileName mfs @@ -64,17 +64,18 @@ getTypecheckedModuleGhc' wrapper targetFile = do let keepInfo = pure . (mFileName ==) saveTypechecked = writeIORef refTypechecked . Just saveParsed = writeIORef refParsed . Just - res <- getTypecheckedModuleGhc wrapper [cfileName] keepInfo saveTypechecked saveParsed + res <- getModulesGhc wrapper [cfileName] keepInfo saveTypechecked saveParsed mtm <- liftIO $ readIORef refTypechecked mpm <- liftIO $ readIORef refParsed return (res, mtm, mpm) --- | like getTypecheckedModuleGhc' but allows you to keep an arbitary number of Modules --- `keepInfo` decides which TypecheckedModule to keep --- `saveModule` is the callback that is passed the TypecheckedModule -getTypecheckedModuleGhc :: GM.IOish m +-- | like getModulesGhc' but allows you to keep an arbitary number of Modules +-- `keepInfo` decides which module to keep +-- `saveTypechecked` is the callback that is passed the TypecheckedModule +-- `saveParsed` is the callback that is passed the ParsedModule +getModulesGhc :: GM.IOish m => (GM.GmlT m () -> GM.GmlT m a) -> [FilePath] -> (FilePath -> IO Bool) -> (TypecheckedModule -> IO ()) -> (ParsedModule -> IO ()) -> GM.GhcModT m a -getTypecheckedModuleGhc wrapper targetFiles keepInfo saveTypechecked saveParsed = do +getModulesGhc wrapper targetFiles keepInfo saveTypechecked saveParsed = do mfs <- GM.getMMappedFiles let ips = map takeDirectory $ Map.keys mfs setIncludePaths df = df { GHC.includePaths = ips ++ GHC.includePaths df } diff --git a/core/GhcModCore.hs b/core/GhcModCore.hs index ab4b54ab4..8ffce212a 100644 --- a/core/GhcModCore.hs +++ b/core/GhcModCore.hs @@ -41,8 +41,8 @@ module GhcModCore ( , loadMappedFileSource , unloadMappedFile -- * HIE integration utilities - , getTypecheckedModuleGhc - , getTypecheckedModuleGhc' + , getModulesGhc + , getModulesGhc' ) where import GhcMod.Cradle