GHC 8 readiness

2016-02-04 10:54:55 -08:00
parent d77e262915
commit 8ef0f52199
10 changed files with 138 additions and 21 deletions
--- 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
--- 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
--- 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)
--- 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
--- 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

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