hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

GHC 8 readiness

Browse Source
This commit is contained in:
Jude Taylor 2016-02-04 10:54:55 -08:00
parent d77e262915
commit 8ef0f52199
10 changed files with 138 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
Language/Haskell/GhcMod/CaseSplit.hs
View File

@ -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

46
Language/Haskell/GhcMod/FillSig.hs
View File

@ -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

16
Language/Haskell/GhcMod/Gap.hs
View File

@ -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)

13
Language/Haskell/GhcMod/Logger.hs
View File

@ -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

2
Language/Haskell/GhcMod/Monad/Newtypes.hs
View File

@ -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

9
Language/Haskell/GhcMod/Target.hs
View File

@ -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)))

29
NotCPP/Declarations.hs
View File

@ -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

8
NotCPP/LookupValueName.hs
View File

@ -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 [])

6
NotCPP/Utils.hs
View File

@ -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

22
ghc-mod.cabal
View File

@ -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