From 8ef0f5219923d9b4dd03a50c68ebfb5da043eeab Mon Sep 17 00:00:00 2001 From: Jude Taylor Date: Thu, 4 Feb 2016 10:54:55 -0800 Subject: [PATCH 1/3] GHC 8 readiness --- Language/Haskell/GhcMod/CaseSplit.hs | 8 ++++ Language/Haskell/GhcMod/FillSig.hs | 46 ++++++++++++++++++++--- Language/Haskell/GhcMod/Gap.hs | 16 +++++++- Language/Haskell/GhcMod/Logger.hs | 13 ++++++- Language/Haskell/GhcMod/Monad/Newtypes.hs | 2 +- Language/Haskell/GhcMod/Target.hs | 9 +++++ NotCPP/Declarations.hs | 29 +++++++++++++- NotCPP/LookupValueName.hs | 8 +++- NotCPP/Utils.hs | 6 +++ ghc-mod.cabal | 22 ++++++----- 10 files changed, 138 insertions(+), 21 deletions(-) diff --git a/Language/Haskell/GhcMod/CaseSplit.hs b/Language/Haskell/GhcMod/CaseSplit.hs index 7c98f6e..10f9d12 100644 --- a/Language/Haskell/GhcMod/CaseSplit.hs +++ b/Language/Haskell/GhcMod/CaseSplit.hs @@ -107,7 +107,11 @@ isPatternVar (L _ (G.VarPat _)) = True isPatternVar _ = False getPatternVarName :: LPat Id -> G.Name +#if __GLASGOW_HASKELL__ >= 800 +getPatternVarName (L _ (G.VarPat (L _ vName))) = G.getName vName +#else getPatternVarName (L _ (G.VarPat vName)) = G.getName vName +#endif getPatternVarName _ = error "This should never happened" -- TODO: Information for a type family case split @@ -167,7 +171,11 @@ getDataCon dflag style vName dcon | [] <- Ty.dataConFieldLabels dcon = -- 3. Records getDataCon dflag style vName dcon = let dName = showName dflag style $ Ty.dataConName dcon +#if __GLASGOW_HASKELL__ >= 800 + flds = map Ty.flSelector $ Ty.dataConFieldLabels dcon +#else flds = Ty.dataConFieldLabels dcon +#endif in dName ++ " { " ++ showFieldNames dflag style vName flds ++ " }" -- Create a new variable by adjoining a number diff --git a/Language/Haskell/GhcMod/FillSig.hs b/Language/Haskell/GhcMod/FillSig.hs index 6ab76c1..bd84504 100644 --- a/Language/Haskell/GhcMod/FillSig.hs +++ b/Language/Haskell/GhcMod/FillSig.hs @@ -116,7 +116,9 @@ 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 -#if __GLASGOW_HASKELL__ >= 710 +#if __GLASGOW_HASKELL__ >= 800 + [L loc (G.SigD (Ty.TypeSig names (G.HsIB _ (G.HsWC _ _ (L _ ty)))))] -> +#elif __GLASGOW_HASKELL__ >= 710 [L loc (G.SigD (Ty.TypeSig names (L _ ty) _))] -> #else [L loc (G.SigD (Ty.TypeSig names (L _ ty)))] -> @@ -131,7 +133,9 @@ getSignature modSum lineNo colNo = do case Gap.getClass lst of Just (clsName,loc) -> obtainClassInfo minfo clsName loc _ -> return Nothing -#if __GLASGOW_HASKELL__ >= 708 +#if __GLASGOW_HASKELL__ >= 800 + [L loc (G.TyClD (G.FamDecl (G.FamilyDecl info (L _ name) (G.HsQTvs _ vars) _ _)))] -> do +#elif __GLASGOW_HASKELL__ >= 708 [L loc (G.TyClD (G.FamDecl (G.FamilyDecl info (L _ name) (G.HsQTvs _ vars) _)))] -> do #elif __GLASGOW_HASKELL__ >= 706 [L loc (G.TyClD (G.TyFamily info (L _ name) (G.HsQTvs _ vars) _))] -> do @@ -149,7 +153,11 @@ getSignature modSum lineNo colNo = do G.DataFamily -> Data #endif -#if __GLASGOW_HASKELL__ >= 710 +#if __GLASGOW_HASKELL__ >= 800 + getTyFamVarName x = case x of + L _ (G.UserTyVar (G.L _ n)) -> n + L _ (G.KindedTyVar (G.L _ n) _) -> n +#elif __GLASGOW_HASKELL__ >= 710 getTyFamVarName x = case x of L _ (G.UserTyVar n) -> n L _ (G.KindedTyVar (G.L _ n) _) -> n @@ -269,7 +277,9 @@ class FnArgsInfo ty name | ty -> name, name -> ty where instance FnArgsInfo (G.HsType G.RdrName) (G.RdrName) where getFnName dflag style name = showOccName dflag style $ Gap.occName name -#if __GLASGOW_HASKELL__ >= 710 +#if __GLASGOW_HASKELL__ >= 800 + getFnArgs (G.HsForAllTy _ (L _ iTy)) +#elif __GLASGOW_HASKELL__ >= 710 getFnArgs (G.HsForAllTy _ _ _ _ (L _ iTy)) #else getFnArgs (G.HsForAllTy _ _ _ (L _ iTy)) @@ -280,7 +290,9 @@ instance FnArgsInfo (G.HsType G.RdrName) (G.RdrName) where getFnArgs (G.HsFunTy (L _ lTy) (L _ rTy)) = (if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy where fnarg ty = case ty of -#if __GLASGOW_HASKELL__ >= 710 +#if __GLASGOW_HASKELL__ >= 800 + (G.HsForAllTy _ (L _ iTy)) -> +#elif __GLASGOW_HASKELL__ >= 710 (G.HsForAllTy _ _ _ _ (L _ iTy)) -> #else (G.HsForAllTy _ _ _ (L _ iTy)) -> @@ -381,7 +393,11 @@ findVar -> m (Maybe (SrcSpan, String, Type, Bool)) findVar dflag style tcm tcs lineNo colNo = case lst of +#if __GLASGOW_HASKELL__ >= 800 + e@(L _ (G.HsVar (L _ i))):others -> do +#else e@(L _ (G.HsVar i)):others -> do +#endif tyInfo <- Gap.getType tcm e case tyInfo of Just (s, typ) @@ -409,7 +425,11 @@ doParen False s = s doParen True s = if ' ' `elem` s then '(':s ++ ")" else s isSearchedVar :: Id -> G.HsExpr Id -> Bool +#if __GLASGOW_HASKELL__ >= 800 +isSearchedVar i (G.HsVar (L _ i2)) = i == i2 +#else isSearchedVar i (G.HsVar i2) = i == i2 +#endif isSearchedVar _ _ = False @@ -512,7 +532,11 @@ getPatsForVariable tcs (lineNo, colNo) = _ -> (error "This should never happen", []) getBindingsForPat :: Ty.Pat Id -> M.Map G.Name Type +#if __GLASGOW_HASKELL__ >= 800 +getBindingsForPat (Ty.VarPat (L _ i)) = M.singleton (G.getName i) (Ty.varType i) +#else getBindingsForPat (Ty.VarPat i) = M.singleton (G.getName i) (Ty.varType i) +#endif getBindingsForPat (Ty.LazyPat (L _ l)) = getBindingsForPat l getBindingsForPat (Ty.BangPat (L _ b)) = getBindingsForPat b getBindingsForPat (Ty.AsPat (L _ a) (L _ i)) = @@ -537,11 +561,23 @@ getBindingsForPat (Ty.ConPatOut { Ty.pat_args = d }) = getBindingsForRecPat d getBindingsForPat _ = M.empty getBindingsForRecPat :: Ty.HsConPatDetails Id -> M.Map G.Name Type +#if __GLASGOW_HASKELL__ >= 800 +getBindingsForRecPat (G.PrefixCon args) = +#else getBindingsForRecPat (Ty.PrefixCon args) = +#endif M.unions $ map (\(L _ i) -> getBindingsForPat i) args +#if __GLASGOW_HASKELL__ >= 800 +getBindingsForRecPat (G.InfixCon (L _ a1) (L _ a2)) = +#else getBindingsForRecPat (Ty.InfixCon (L _ a1) (L _ a2)) = +#endif M.union (getBindingsForPat a1) (getBindingsForPat a2) +#if __GLASGOW_HASKELL__ >= 800 +getBindingsForRecPat (G.RecCon (Ty.HsRecFields { Ty.rec_flds = fields })) = +#else getBindingsForRecPat (Ty.RecCon (Ty.HsRecFields { Ty.rec_flds = fields })) = +#endif getBindingsForRecFields (map unLoc' fields) where #if __GLASGOW_HASKELL__ >= 710 diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs index 48337e0..83355d6 100644 --- a/Language/Haskell/GhcMod/Gap.hs +++ b/Language/Haskell/GhcMod/Gap.hs @@ -156,7 +156,10 @@ setLogAction df f = #endif showDocWith :: DynFlags -> Pretty.Mode -> Pretty.Doc -> String -#if __GLASGOW_HASKELL__ >= 708 +#if __GLASGOW_HASKELL__ >= 800 +showDocWith dflags mode = Pretty.renderStyle mstyle where + mstyle = Pretty.style { Pretty.mode = mode, Pretty.lineLength = pprCols dflags } +#elif __GLASGOW_HASKELL__ >= 708 -- Pretty.showDocWith disappeard. -- https://github.com/ghc/ghc/commit/08a3536e4246e323fbcd8040e0b80001950fe9bc showDocWith dflags mode = Pretty.showDoc mode (pprCols dflags) @@ -201,7 +204,11 @@ toStringBuffer = liftIO . stringToStringBuffer . unlines fOptions :: [String] #if __GLASGOW_HASKELL__ >= 710 fOptions = [option | (FlagSpec option _ _ _) <- fFlags] +#if __GLASGOW_HASKELL__ >= 800 + ++ [option | (FlagSpec option _ _ _) <- wWarningFlags] +#else ++ [option | (FlagSpec option _ _ _) <- fWarningFlags] +#endif ++ [option | (FlagSpec option _ _ _) <- fLangFlags] #elif __GLASGOW_HASKELL__ >= 704 fOptions = [option | (option,_,_) <- fFlags] @@ -467,7 +474,12 @@ type GLMatchI = LMatch Id #endif getClass :: [LInstDecl Name] -> Maybe (Name, SrcSpan) -#if __GLASGOW_HASKELL__ >= 710 +#if __GLASGOW_HASKELL__ >= 800 +-- 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) +-- Instance declarations of sort 'instance F G' (no variables) +getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = HsIB _ (L _ (HsAppTy (L _ (HsTyVar (L _ className))) _))}))] = Just (className, loc) +#elif __GLASGOW_HASKELL__ >= 710 -- Instance declarations of sort 'instance F (G a)' getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsForAllTy _ _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _))))}))] = Just (className, loc) -- Instance declarations of sort 'instance F G' (no variables) diff --git a/Language/Haskell/GhcMod/Logger.hs b/Language/Haskell/GhcMod/Logger.hs index 10ebd5b..5dfe74b 100644 --- a/Language/Haskell/GhcMod/Logger.hs +++ b/Language/Haskell/GhcMod/Logger.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + module Language.Haskell.GhcMod.Logger ( withLogger , withLogger' @@ -135,12 +137,21 @@ ppErrMsg err = do dflags <- asks gpeDynFlags let unqual = errMsgContext err st = Gap.mkErrStyle' dflags unqual +#if __GLASGOW_HASKELL__ < 800 let ext = showPage dflags st (errMsgExtraInfo err) +#endif m <- ppMsg st spn SevError msg - return $ m ++ (if null ext then "" else "\n" ++ ext) + return $ m +#if __GLASGOW_HASKELL__ < 800 + ++ (if null ext then "" else "\n" ++ ext) +#endif where spn = Gap.errorMsgSpan err +#if __GLASGOW_HASKELL__ >= 800 + msg = pprLocErrMsg err +#else msg = errMsgShortDoc err +#endif ppMsg :: PprStyle -> SrcSpan -> Severity -> SDoc -> GmPprEnvM String ppMsg st spn sev msg = do diff --git a/Language/Haskell/GhcMod/Monad/Newtypes.hs b/Language/Haskell/GhcMod/Monad/Newtypes.hs index dd7e5a6..ab3d82e 100644 --- a/Language/Haskell/GhcMod/Monad/Newtypes.hs +++ b/Language/Haskell/GhcMod/Monad/Newtypes.hs @@ -124,7 +124,7 @@ instance MonadTrans GmlT where -- GmT ------------------------------------------ -instance forall r m. MonadReader r m => MonadReader r (GmT m) where +instance MonadReader r m => MonadReader r (GmT m) where local f ma = gmLiftWithInner (\run -> local f (run ma)) ask = gmLiftInner ask diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 7985d1a..f62558f 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -21,6 +21,9 @@ import Control.Arrow import Control.Applicative import Control.Category ((.)) import GHC +#if __GLASGOW_HASKELL__ >= 800 +import GHC.LanguageExtensions +#endif import GHC.Paths (libdir) import SysTools import DynFlags @@ -477,11 +480,17 @@ loadTargets opts targetStrs = do needsHscInterpreted :: ModuleGraph -> Bool needsHscInterpreted = any $ \ms -> let df = ms_hspp_opts ms in +#if __GLASGOW_HASKELL__ >= 800 + TemplateHaskell `xopt` df + || QuasiQuotes `xopt` df + || PatternSynonyms `xopt` df +#else Opt_TemplateHaskell `xopt` df || Opt_QuasiQuotes `xopt` df #if __GLASGOW_HASKELL__ >= 708 || (Opt_PatternSynonyms `xopt` df) #endif +#endif cabalResolvedComponents :: (IOish m) => GhcModT m (Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath))) diff --git a/NotCPP/Declarations.hs b/NotCPP/Declarations.hs index 1657a68..1cb83eb 100644 --- a/NotCPP/Declarations.hs +++ b/NotCPP/Declarations.hs @@ -104,18 +104,36 @@ boundNames decl = TySynD n _ _ -> [(TcClsName, n)] ClassD _ n _ _ _ -> [(TcClsName, n)] +#if __GLASGOW_HASKELL__ < 800 FamilyD _ n _ _ -> [(TcClsName, n)] +#endif +#if __GLASGOW_HASKELL__ >= 800 + DataD _ n _ _ ctors _ -> +#else DataD _ n _ ctors _ -> +#endif [(TcClsName, n)] ++ map ((,) TcClsName) (conNames `concatMap` ctors) +#if __GLASGOW_HASKELL__ >= 800 + NewtypeD _ n _ _ ctor _ -> +#else NewtypeD _ n _ ctor _ -> +#endif [(TcClsName, n)] ++ map ((,) TcClsName) (conNames ctor) +#if __GLASGOW_HASKELL__ >= 800 + DataInstD _ _n _ _ ctors _ -> +#else DataInstD _ _n _ ctors _ -> +#endif map ((,) TcClsName) (conNames `concatMap` ctors) +#if __GLASGOW_HASKELL__ >= 800 + NewtypeInstD _ _n _ _ ctor _ -> +#else NewtypeInstD _ _n _ ctor _ -> +#endif map ((,) TcClsName) (conNames ctor) InstanceD _ _ty _ -> @@ -131,10 +149,19 @@ boundNames decl = #endif #if __GLASGOW_HASKELL__ >= 708 - ClosedTypeFamilyD n _ _ _ -> [(TcClsName, n)] RoleAnnotD _n _ -> error "notcpp: RoleAnnotD not supported yet" #endif +#if __GLASGOW_HASKELL__ >= 704 && __GLASGOW_HASKELL__ < 800 + FamilyD _ n _ _ -> [(TcClsName, n)] +#elif __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 800 + ClosedTypeFamilyD n _ _ _ -> [(TcClsName, n)] +#else + OpenTypeFamilyD (TypeFamilyHead n _ _ _) -> [(TcClsName, n)] + ClosedTypeFamilyD (TypeFamilyHead n _ _ _) _ -> [(TcClsName, n)] + +#endif + conNames :: Con -> [Name] conNames con = case con of diff --git a/NotCPP/LookupValueName.hs b/NotCPP/LookupValueName.hs index 72462c2..b12d08f 100644 --- a/NotCPP/LookupValueName.hs +++ b/NotCPP/LookupValueName.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} -- | This module uses scope lookup techniques to either export -- 'lookupValueName' from @Language.Haskell.TH@, or define @@ -25,8 +26,13 @@ bestValueGuess s = do case mi of Nothing -> no Just i -> case i of +#if __GLASGOW_HASKELL__ >= 800 + VarI n _ _ -> yes n + DataConI n _ _ -> yes n +#else VarI n _ _ _ -> yes n DataConI n _ _ _ -> yes n +#endif _ -> err ["unexpected info:", show i] where no = return Nothing @@ -34,5 +40,5 @@ bestValueGuess s = do err = fail . showString "NotCPP.bestValueGuess: " . unwords $(recover [d| lookupValueName = bestValueGuess |] $ do - VarI _ _ _ _ <- reify (mkName "lookupValueName") + VarI{} <- reify (mkName "lookupValueName") return []) diff --git a/NotCPP/Utils.hs b/NotCPP/Utils.hs index 9da7958..d25b637 100644 --- a/NotCPP/Utils.hs +++ b/NotCPP/Utils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} module NotCPP.Utils where @@ -24,6 +25,11 @@ recoverMaybe q = recover (return Nothing) (Just <$> q) -- | Returns @'Just' ('VarE' n)@ if the info relates to a value called -- @n@, or 'Nothing' if it relates to a different sort of thing. infoToExp :: Info -> Maybe Exp +#if __GLASGOW_HASKELL__ >= 800 +infoToExp (VarI n _ _) = Just (VarE n) +infoToExp (DataConI n _ _) = Just (ConE n) +#else infoToExp (VarI n _ _ _) = Just (VarE n) infoToExp (DataConI n _ _ _) = Just (ConE n) +#endif infoToExp _ = Nothing diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 01358b5..1e55479 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -158,24 +158,24 @@ Library System.Directory.ModTime Build-Depends: base < 5 && >= 4.0 , bytestring < 0.11 - , binary < 0.8 && >= 0.5.1.0 + , binary < 0.9 && >= 0.5.1.0 , containers < 0.6 , cabal-helper < 0.7 && >= 0.6.3.0 , deepseq < 1.5 , directory < 1.3 , filepath < 1.5 - , ghc < 7.11 + , ghc < 8.2 , ghc-paths < 0.2 , ghc-syb-utils < 0.3 , hlint < 1.10 && >= 1.9.26 , monad-journal < 0.8 && >= 0.4 , old-time < 1.2 , pretty < 1.2 - , process < 1.3 + , process < 1.5 , syb < 0.7 , temporary < 1.3 - , time < 1.6 - , transformers < 0.5 + , time < 1.7 + , transformers < 0.6 , transformers-base < 0.5 , mtl < 2.3 && >= 2.0 , monad-control < 1.1 && >= 1 @@ -193,6 +193,8 @@ Library -- Only used to constrain random to a version that still works with GHC 7.4 Build-Depends: random <= 1.0.1.1, ghc-prim + if impl(ghc >= 8.0) + Build-Depends: ghc-boot Executable ghc-mod Default-Language: Haskell2010 @@ -211,10 +213,10 @@ Executable ghc-mod , directory < 1.3 , filepath < 1.5 , pretty < 1.2 - , process < 1.3 + , process < 1.5 , split < 0.3 , mtl < 2.3 && >= 2.0 - , ghc < 7.11 + , ghc < 8.1 , monad-control ==1.0.* , fclabels ==2.0.* , optparse-applicative >=0.11.0 && <0.13.0 @@ -231,13 +233,13 @@ Executable ghc-modi Default-Extensions: ConstraintKinds, FlexibleContexts HS-Source-Dirs: src, . Build-Depends: base < 5 && >= 4.0 - , binary < 0.8 && >= 0.5.1.0 + , binary < 0.9 && >= 0.5.1.0 , deepseq < 1.5 , directory < 1.3 , filepath < 1.5 - , process < 1.3 + , process < 1.5 , old-time < 1.2 - , time < 1.6 + , time < 1.7 , ghc-mod Test-Suite doctest From e417d095bf54daf75cea5a04d2b2047e412f1650 Mon Sep 17 00:00:00 2001 From: Jude Taylor Date: Thu, 4 Feb 2016 11:07:51 -0800 Subject: [PATCH 2/3] remove redundant FamilyD case --- NotCPP/Declarations.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/NotCPP/Declarations.hs b/NotCPP/Declarations.hs index 1cb83eb..b57feae 100644 --- a/NotCPP/Declarations.hs +++ b/NotCPP/Declarations.hs @@ -104,9 +104,6 @@ boundNames decl = TySynD n _ _ -> [(TcClsName, n)] ClassD _ n _ _ _ -> [(TcClsName, n)] -#if __GLASGOW_HASKELL__ < 800 - FamilyD _ n _ _ -> [(TcClsName, n)] -#endif #if __GLASGOW_HASKELL__ >= 800 DataD _ n _ _ ctors _ -> From ed867fea3ec547a5077562ae8aeb9af8b061cdd3 Mon Sep 17 00:00:00 2001 From: Jude Taylor Date: Sat, 6 Feb 2016 10:02:01 -0800 Subject: [PATCH 3/3] remove double location in error message --- Language/Haskell/GhcMod/Logger.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/Language/Haskell/GhcMod/Logger.hs b/Language/Haskell/GhcMod/Logger.hs index 5dfe74b..5f578f4 100644 --- a/Language/Haskell/GhcMod/Logger.hs +++ b/Language/Haskell/GhcMod/Logger.hs @@ -137,13 +137,12 @@ ppErrMsg err = do dflags <- asks gpeDynFlags let unqual = errMsgContext err st = Gap.mkErrStyle' dflags unqual -#if __GLASGOW_HASKELL__ < 800 +#if __GLASGOW_HASKELL__ >= 800 + return $ showPage dflags st msg +#else let ext = showPage dflags st (errMsgExtraInfo err) -#endif m <- ppMsg st spn SevError msg - return $ m -#if __GLASGOW_HASKELL__ < 800 - ++ (if null ext then "" else "\n" ++ ext) + return $ m ++ (if null ext then "" else "\n" ++ ext) #endif where spn = Gap.errorMsgSpan err