Merge remote-tracking branch 'pikajude/ghc-8'

This commit is contained in:
Daniel Gröber 2016-02-14 12:27:26 +01:00
commit be6ba3f875
9 changed files with 94 additions and 27 deletions

View File

@ -107,7 +107,11 @@ isPatternVar (L _ (G.VarPat _)) = True
isPatternVar _ = False isPatternVar _ = False
getPatternVarName :: LPat Id -> G.Name 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 getPatternVarName (L _ (G.VarPat vName)) = G.getName vName
#endif
getPatternVarName _ = error "This should never happened" getPatternVarName _ = error "This should never happened"
-- TODO: Information for a type family case split -- TODO: Information for a type family case split
@ -167,7 +171,11 @@ getDataCon dflag style vName dcon | [] <- Ty.dataConFieldLabels dcon =
-- 3. Records -- 3. Records
getDataCon dflag style vName dcon = getDataCon dflag style vName dcon =
let dName = showName dflag style $ Ty.dataConName 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 flds = Ty.dataConFieldLabels dcon
#endif
in dName ++ " { " ++ showFieldNames dflag style vName flds ++ " }" in dName ++ " { " ++ showFieldNames dflag style vName flds ++ " }"
-- Create a new variable by adjoining a number -- Create a new variable by adjoining a number

View File

@ -116,7 +116,9 @@ getSignature modSum lineNo colNo = do
p@ParsedModule{pm_parsed_source = ps} <- G.parseModule modSum p@ParsedModule{pm_parsed_source = ps} <- G.parseModule modSum
-- Inspect the parse tree to find the signature -- 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 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) _))] -> [L loc (G.SigD (Ty.TypeSig names (L _ ty) _))] ->
#else #else
[L loc (G.SigD (Ty.TypeSig names (L _ ty)))] -> [L loc (G.SigD (Ty.TypeSig names (L _ ty)))] ->
@ -131,7 +133,9 @@ getSignature modSum lineNo colNo = do
case Gap.getClass lst of case Gap.getClass lst of
Just (clsName,loc) -> obtainClassInfo minfo clsName loc Just (clsName,loc) -> obtainClassInfo minfo clsName loc
_ -> return Nothing _ -> 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 [L loc (G.TyClD (G.FamDecl (G.FamilyDecl info (L _ name) (G.HsQTvs _ vars) _)))] -> do
#elif __GLASGOW_HASKELL__ >= 706 #elif __GLASGOW_HASKELL__ >= 706
[L loc (G.TyClD (G.TyFamily info (L _ name) (G.HsQTvs _ vars) _))] -> do [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 G.DataFamily -> Data
#endif #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 getTyFamVarName x = case x of
L _ (G.UserTyVar n) -> n L _ (G.UserTyVar n) -> n
L _ (G.KindedTyVar (G.L _ 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 instance FnArgsInfo (G.HsType G.RdrName) (G.RdrName) where
getFnName dflag style name = showOccName dflag style $ Gap.occName name 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)) getFnArgs (G.HsForAllTy _ _ _ _ (L _ iTy))
#else #else
getFnArgs (G.HsForAllTy _ _ _ (L _ iTy)) 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)) = getFnArgs (G.HsFunTy (L _ lTy) (L _ rTy)) =
(if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy (if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy
where fnarg ty = case ty of 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)) -> (G.HsForAllTy _ _ _ _ (L _ iTy)) ->
#else #else
(G.HsForAllTy _ _ _ (L _ iTy)) -> (G.HsForAllTy _ _ _ (L _ iTy)) ->
@ -381,7 +393,11 @@ findVar
-> m (Maybe (SrcSpan, String, Type, Bool)) -> m (Maybe (SrcSpan, String, Type, Bool))
findVar dflag style tcm tcs lineNo colNo = findVar dflag style tcm tcs lineNo colNo =
case lst of case lst of
#if __GLASGOW_HASKELL__ >= 800
e@(L _ (G.HsVar (L _ i))):others -> do
#else
e@(L _ (G.HsVar i)):others -> do e@(L _ (G.HsVar i)):others -> do
#endif
tyInfo <- Gap.getType tcm e tyInfo <- Gap.getType tcm e
case tyInfo of case tyInfo of
Just (s, typ) Just (s, typ)
@ -409,7 +425,11 @@ doParen False s = s
doParen True s = if ' ' `elem` s then '(':s ++ ")" else s doParen True s = if ' ' `elem` s then '(':s ++ ")" else s
isSearchedVar :: Id -> G.HsExpr Id -> Bool 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 isSearchedVar i (G.HsVar i2) = i == i2
#endif
isSearchedVar _ _ = False isSearchedVar _ _ = False
@ -512,7 +532,11 @@ getPatsForVariable tcs (lineNo, colNo) =
_ -> (error "This should never happen", []) _ -> (error "This should never happen", [])
getBindingsForPat :: Ty.Pat Id -> M.Map G.Name Type 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) getBindingsForPat (Ty.VarPat i) = M.singleton (G.getName i) (Ty.varType i)
#endif
getBindingsForPat (Ty.LazyPat (L _ l)) = getBindingsForPat l getBindingsForPat (Ty.LazyPat (L _ l)) = getBindingsForPat l
getBindingsForPat (Ty.BangPat (L _ b)) = getBindingsForPat b getBindingsForPat (Ty.BangPat (L _ b)) = getBindingsForPat b
getBindingsForPat (Ty.AsPat (L _ a) (L _ i)) = getBindingsForPat (Ty.AsPat (L _ a) (L _ i)) =
@ -537,11 +561,23 @@ getBindingsForPat (Ty.ConPatOut { Ty.pat_args = d }) = getBindingsForRecPat d
getBindingsForPat _ = M.empty getBindingsForPat _ = M.empty
getBindingsForRecPat :: Ty.HsConPatDetails Id -> M.Map G.Name Type getBindingsForRecPat :: Ty.HsConPatDetails Id -> M.Map G.Name Type
#if __GLASGOW_HASKELL__ >= 800
getBindingsForRecPat (G.PrefixCon args) =
#else
getBindingsForRecPat (Ty.PrefixCon args) = getBindingsForRecPat (Ty.PrefixCon args) =
#endif
M.unions $ map (\(L _ i) -> getBindingsForPat i) args 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)) = getBindingsForRecPat (Ty.InfixCon (L _ a1) (L _ a2)) =
#endif
M.union (getBindingsForPat a1) (getBindingsForPat a2) 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 })) = getBindingsForRecPat (Ty.RecCon (Ty.HsRecFields { Ty.rec_flds = fields })) =
#endif
getBindingsForRecFields (map unLoc' fields) getBindingsForRecFields (map unLoc' fields)
where where
#if __GLASGOW_HASKELL__ >= 710 #if __GLASGOW_HASKELL__ >= 710

View File

@ -156,7 +156,10 @@ setLogAction df f =
#endif #endif
showDocWith :: DynFlags -> Pretty.Mode -> Pretty.Doc -> String 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. -- Pretty.showDocWith disappeard.
-- https://github.com/ghc/ghc/commit/08a3536e4246e323fbcd8040e0b80001950fe9bc -- https://github.com/ghc/ghc/commit/08a3536e4246e323fbcd8040e0b80001950fe9bc
showDocWith dflags mode = Pretty.showDoc mode (pprCols dflags) showDocWith dflags mode = Pretty.showDoc mode (pprCols dflags)
@ -201,7 +204,11 @@ toStringBuffer = liftIO . stringToStringBuffer . unlines
fOptions :: [String] fOptions :: [String]
#if __GLASGOW_HASKELL__ >= 710 #if __GLASGOW_HASKELL__ >= 710
fOptions = [option | (FlagSpec option _ _ _) <- fFlags] fOptions = [option | (FlagSpec option _ _ _) <- fFlags]
#if __GLASGOW_HASKELL__ >= 800
++ [option | (FlagSpec option _ _ _) <- wWarningFlags]
#else
++ [option | (FlagSpec option _ _ _) <- fWarningFlags] ++ [option | (FlagSpec option _ _ _) <- fWarningFlags]
#endif
++ [option | (FlagSpec option _ _ _) <- fLangFlags] ++ [option | (FlagSpec option _ _ _) <- fLangFlags]
#elif __GLASGOW_HASKELL__ >= 704 #elif __GLASGOW_HASKELL__ >= 704
fOptions = [option | (option,_,_) <- fFlags] fOptions = [option | (option,_,_) <- fFlags]
@ -467,7 +474,12 @@ type GLMatchI = LMatch Id
#endif #endif
getClass :: [LInstDecl Name] -> Maybe (Name, SrcSpan) 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)' -- 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) 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) -- Instance declarations of sort 'instance F G' (no variables)

View File

@ -1,3 +1,5 @@
{-# LANGUAGE CPP #-}
module Language.Haskell.GhcMod.Logger ( module Language.Haskell.GhcMod.Logger (
withLogger withLogger
, withLogger' , withLogger'
@ -135,12 +137,20 @@ ppErrMsg err = do
dflags <- asks gpeDynFlags dflags <- asks gpeDynFlags
let unqual = errMsgContext err let unqual = errMsgContext err
st = Gap.mkErrStyle' dflags unqual st = Gap.mkErrStyle' dflags unqual
#if __GLASGOW_HASKELL__ >= 800
return $ showPage dflags st msg
#else
let ext = showPage dflags st (errMsgExtraInfo err) let ext = showPage dflags st (errMsgExtraInfo err)
m <- ppMsg st spn SevError msg m <- ppMsg st spn SevError msg
return $ m ++ (if null ext then "" else "\n" ++ ext) return $ m ++ (if null ext then "" else "\n" ++ ext)
#endif
where where
spn = Gap.errorMsgSpan err spn = Gap.errorMsgSpan err
#if __GLASGOW_HASKELL__ >= 800
msg = pprLocErrMsg err
#else
msg = errMsgShortDoc err msg = errMsgShortDoc err
#endif
ppMsg :: PprStyle -> SrcSpan -> Severity -> SDoc -> GmPprEnvM String ppMsg :: PprStyle -> SrcSpan -> Severity -> SDoc -> GmPprEnvM String
ppMsg st spn sev msg = do ppMsg st spn sev msg = do

View File

@ -124,7 +124,7 @@ instance MonadTrans GmlT where
-- GmT ------------------------------------------ -- 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)) local f ma = gmLiftWithInner (\run -> local f (run ma))
ask = gmLiftInner ask ask = gmLiftInner ask

View File

@ -21,6 +21,9 @@ import Control.Arrow
import Control.Applicative import Control.Applicative
import Control.Category ((.)) import Control.Category ((.))
import GHC import GHC
#if __GLASGOW_HASKELL__ >= 800
import GHC.LanguageExtensions
#endif
import GHC.Paths (libdir) import GHC.Paths (libdir)
import SysTools import SysTools
import DynFlags import DynFlags
@ -489,11 +492,17 @@ loadTargets opts targetStrs = do
needsHscInterpreted :: ModuleGraph -> Bool needsHscInterpreted :: ModuleGraph -> Bool
needsHscInterpreted = any $ \ms -> needsHscInterpreted = any $ \ms ->
let df = ms_hspp_opts ms in 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_TemplateHaskell `xopt` df
|| Opt_QuasiQuotes `xopt` df || Opt_QuasiQuotes `xopt` df
#if __GLASGOW_HASKELL__ >= 708 #if __GLASGOW_HASKELL__ >= 708
|| (Opt_PatternSynonyms `xopt` df) || (Opt_PatternSynonyms `xopt` df)
#endif #endif
#endif
cabalResolvedComponents :: (IOish m) => cabalResolvedComponents :: (IOish m) =>
GhcModT m (Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath))) GhcModT m (Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath)))

View File

@ -1,4 +1,5 @@
{-# LANGUAGE CPP, TemplateHaskell #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
-- | This module uses scope lookup techniques to either export -- | This module uses scope lookup techniques to either export
-- 'lookupValueName' from @Language.Haskell.TH@, or define -- 'lookupValueName' from @Language.Haskell.TH@, or define
-- its own 'lookupValueName', which attempts to do the -- its own 'lookupValueName', which attempts to do the
@ -39,9 +40,5 @@ bestValueGuess s = do
err = fail . showString "NotCPP.bestValueGuess: " . unwords err = fail . showString "NotCPP.bestValueGuess: " . unwords
$(recover [d| lookupValueName = bestValueGuess |] $ do $(recover [d| lookupValueName = bestValueGuess |] $ do
#if __GLASGOW_HASKELL__ >= 800 VarI{} <- reify (mkName "lookupValueName")
VarI _ _ _ <- reify (mkName "lookupValueName")
#else
VarI _ _ _ _ <- reify (mkName "lookupValueName")
#endif
return []) return [])

View File

@ -1,4 +1,5 @@
{-# LANGUAGE CPP, TemplateHaskell #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
module NotCPP.Utils where module NotCPP.Utils where
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
@ -24,19 +25,11 @@ recoverMaybe q = recover (return Nothing) (Just <$> q)
-- | Returns @'Just' ('VarE' n)@ if the info relates to a value called -- | Returns @'Just' ('VarE' n)@ if the info relates to a value called
-- @n@, or 'Nothing' if it relates to a different sort of thing. -- @n@, or 'Nothing' if it relates to a different sort of thing.
infoToExp :: Info -> Maybe Exp infoToExp :: Info -> Maybe Exp
#if __GLASGOW_HASKELL__ >= 800 #if __GLASGOW_HASKELL__ >= 800
infoToExp (VarI n _ _) = infoToExp (VarI n _ _) = Just (VarE n)
infoToExp (DataConI n _ _) = Just (ConE n)
#else #else
infoToExp (VarI n _ _ _) = infoToExp (VarI n _ _ _) = Just (VarE n)
infoToExp (DataConI n _ _ _) = Just (ConE n)
#endif #endif
Just (VarE n)
#if __GLASGOW_HASKELL__ >= 800
infoToExp (DataConI n _ _) =
#else
infoToExp (DataConI n _ _ _) =
#endif
Just (ConE n)
infoToExp _ = Nothing infoToExp _ = Nothing

View File

@ -192,6 +192,8 @@ Library
, syb , syb
if impl(ghc < 7.8) if impl(ghc < 7.8)
Build-Depends: convertible Build-Depends: convertible
if impl(ghc >= 8.0)
Build-Depends: ghc-boot
Executable ghc-mod Executable ghc-mod
Default-Language: Haskell2010 Default-Language: Haskell2010