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

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

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

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)

Language/Haskell/GhcMod/Logger.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP #-}
+
 module Language.Haskell.GhcMod.Logger (
     withLogger
   , withLogger'
@@ -135,12 +137,20 @@ ppErrMsg err = do
     dflags <- asks gpeDynFlags
     let unqual = errMsgContext err
         st = Gap.mkErrStyle' dflags unqual
+#if __GLASGOW_HASKELL__ >= 800
+    return $ showPage dflags st msg
+#else
     let ext = showPage dflags st (errMsgExtraInfo err)
     m <- ppMsg st spn SevError msg
     return $ m ++ (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

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
 

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
@@ -489,11 +492,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)))

NotCPP/LookupValueName.hs

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

NotCPP/Utils.hs

@@ -1,4 +1,5 @@
-{-# LANGUAGE CPP, TemplateHaskell #-}
+{-# LANGUAGE CPP             #-}
+{-# LANGUAGE TemplateHaskell #-}
 module NotCPP.Utils where
 
 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
 -- @n@, or 'Nothing' if it relates to a different sort of thing.
 infoToExp :: Info -> Maybe Exp
-
 #if __GLASGOW_HASKELL__ >= 800
-infoToExp (VarI n _ _) =
+infoToExp (VarI n _ _) = Just (VarE n)
+infoToExp (DataConI n _ _) = Just (ConE n)
 #else
-infoToExp (VarI n _ _ _) =
+infoToExp (VarI n _ _ _) = Just (VarE n)
+infoToExp (DataConI n _ _ _) = Just (ConE n)
 #endif
-    Just (VarE n)
-
-#if __GLASGOW_HASKELL__ >= 800
-infoToExp (DataConI n _ _) =
-#else
-infoToExp (DataConI n _ _ _) =
-#endif
-    Just (ConE n)
-
 infoToExp _ = Nothing

ghc-mod.cabal

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