GHC-8.6.1/Nightly-2018-10-17

.gitmodules

@@ -0,0 +1,3 @@
+[submodule "cabal-helper"]
+	path = cabal-helper
+	url = https://github.com/DanielG/cabal-helper

GhcMod/Exe/CaseSplit.hs

@@ -30,6 +30,7 @@ import GhcMod.Types
 import GhcMod.Utils (withMappedFile)
 import GhcMod.FileMapping (fileModSummaryWithMapping)
 import Control.DeepSeq
+import qualified Outputable as G
 
 ----------------------------------------------------------------
 -- CASE SPLITTING
@@ -88,32 +89,24 @@ getSrcSpanTypeForFnSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe
 getSrcSpanTypeForFnSplit modSum lineNo colNo = do
     p@ParsedModule{pm_parsed_source = _pms} <- G.parseModule modSum
     tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p
-    let varPat = find isPatternVar $ listifySpans tcs (lineNo, colNo) :: Maybe (LPat Id)
-        match  = last $ listifySpans tcs (lineNo, colNo) :: Gap.GLMatchI
+    let varPat = find isPatternVar $ listifySpans tcs (lineNo, colNo) :: Maybe (LPat G.GhcTc)
+        match  = last $ listifySpans tcs (lineNo, colNo) :: G.LMatch G.GhcTc (G.LHsExpr G.GhcTc)
     case varPat of
       Nothing  -> return Nothing
       Just varPat' -> do
         varT <- Gap.getType tcm varPat'  -- Finally we get the type of the var
         case varT of
           Just varT' ->
-#if __GLASGOW_HASKELL__ >= 710
-            let (L matchL (G.Match _ _ _ (G.GRHSs rhsLs _))) = match
-#else
-            let (L matchL (G.Match _ _ (G.GRHSs rhsLs _))) = match
-#endif
+            let (L matchL (G.Match _ _ _ (G.GRHSs _ rhsLs _))) = match
             in return $ Just (SplitInfo (getPatternVarName varPat') matchL varT' (map G.getLoc rhsLs) )
           _ -> return Nothing
 
-isPatternVar :: LPat Id -> Bool
-isPatternVar (L _ (G.VarPat _)) = True
+isPatternVar :: LPat G.GhcTc -> Bool
+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 :: LPat G.GhcTc -> G.Name
+getPatternVarName (L _ (G.VarPat _ (L _ vName))) = G.getName vName
 getPatternVarName _                      = error "This should never happened"
 
 -- TODO: Information for a type family case split

GhcMod/Exe/Debug.hs

@@ -25,6 +25,7 @@ import Paths_ghc_mod (version)
 
 import Config (cProjectVersion)
 import Pretty
+import Safe
 
 ----------------------------------------------------------------
 
@@ -34,12 +35,14 @@ debugInfo = do
     Options {..} <- options
     Cradle {..} <- cradle
 
-    [ghcPath, ghcPkgPath] <- liftIO $
+    (ghcPath, ghcPkgPath) <- liftIO $
         case cradleProject of
-          StackProject se ->
-              catMaybes <$> sequence [getStackGhcPath se, getStackGhcPkgPath se]
+          StackProject se -> do
+              ghc <- fromJustNote "debugInfo: ghc" <$> getStackGhcPath se
+              ghcPkg <- fromJustNote "debugInfo: ghcPkg" <$> getStackGhcPkgPath se
+              return (ghc, ghcPkg)
           _ ->
-              return ["ghc", "ghc-pkg"]
+              return ("ghc", "ghc-pkg")
 
     cabal <-
         case cradleProject of
@@ -67,7 +70,8 @@ debugInfo = do
 
 stackPaths :: IOish m => GhcModT m [String]
 stackPaths = do
-    Cradle { cradleProject = StackProject senv } <- cradle
+    scradle <- cradle
+    let Cradle { cradleProject = StackProject senv } = scradle
     ghc <- getStackGhcPath senv
     ghcPkg <- getStackGhcPkgPath senv
     return $
@@ -130,7 +134,8 @@ componentInfo ts = do
               alistDoc (either text mnDoc) (setDoc gmComponentNameDoc) mdlcs)
          , "Picked Component:\n"        ++ renderGm (nest 4 $
               gmComponentNameDoc cn)
-         , "GHC Cabal options:\n"       ++ renderGm (nest 4 $ fsep $ map text opts)
+         , "GHC Cabal options:\n"       ++ renderGm (nest 4 $ fsep $ map text $ fst opts)
+                                        ++ renderGm (nest 4 $ fsep $ map text $ snd opts)
          ]
  where
    zipMap f l = l `zip` (f `map` l)

GhcMod/Exe/FillSig.hs

@@ -14,6 +14,7 @@ import Data.List (find, nub, sortBy)
 import qualified Data.Map as M
 import Data.Maybe (catMaybes)
 import Prelude
+import Safe
 
 import Exception (ghandle, SomeException(..))
 import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags,
@@ -51,7 +52,7 @@ import GHC (unLoc)
 
 -- Possible signatures we can find: function or instance
 data SigInfo
-    = Signature SrcSpan [G.RdrName] (G.HsType G.RdrName)
+    = Signature SrcSpan [G.RdrName] (G.HsType G.GhcPs)
     | InstanceDecl SrcSpan G.Class
     | TyFamDecl SrcSpan G.RdrName TyFamType {- True if closed -} [G.RdrName]
 
@@ -115,65 +116,28 @@ getSignature :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SigInfo)
 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__ >= 802
-      [L loc (G.SigD (Ty.TypeSig names (G.HsWC _ (G.HsIB _ (L _ ty) _))))] ->
-#elif __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)))] ->
-#endif
+    case listifyParsedSpans ps (lineNo, colNo) :: [G.LHsDecl G.GhcPs] of
+      [L loc (G.SigD _ (Ty.TypeSig _ names (G.HsWC _ (G.HsIB _ (L _ ty)))))] ->
         -- We found a type signature
         return $ Just $ Signature loc (map G.unLoc names) ty
-      [L _ (G.InstD _)] -> do
+      [L _ (G.InstD{})] -> do
         -- We found an instance declaration
-        TypecheckedModule{tm_renamed_source = Just tcs
+        TypecheckedModule{tm_renamed_source = mtcs
                          ,tm_checked_module_info = minfo} <- G.typecheckModule p
         let lst = listifyRenamedSpans tcs (lineNo, colNo)
+            tcs = fromJustNote "getSignature: tcs" mtcs
         case Gap.getClass lst of
             Just (clsName,loc) -> obtainClassInfo minfo clsName loc
             _                  -> return Nothing
-#if __GLASGOW_HASKELL__ >= 802
-      [L loc (G.TyClD (G.FamDecl (G.FamilyDecl info (L _ name) (G.HsQTvs _ vars _) _ _ _)))] -> do
-#elif __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
-#else
-      [L loc (G.TyClD (G.TyFamily info (L _ name) vars _))] -> do
-#endif
-#if __GLASGOW_HASKELL__ >= 708
+      [L loc (G.TyClD _ (G.FamDecl _ (G.FamilyDecl _ info (L _ name) (G.HsQTvs _ vars) _ _ _)))] -> do
         let flavour = case info of
                         G.ClosedTypeFamily _ -> Closed
                         G.OpenTypeFamily     -> Open
                         G.DataFamily         -> Data
-#else
-        let flavour = case info of  -- Closed type families where introduced in GHC 7.8
-                        G.TypeFamily -> Open
-                        G.DataFamily -> Data
-#endif
 
-#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
-#elif __GLASGOW_HASKELL__ >= 706
-            getTyFamVarName x = case x of
-                L _ (G.UserTyVar n)     -> n
-                L _ (G.KindedTyVar n _) -> n
-#else
-            getTyFamVarName x = case x of  -- In GHC 7.4, HsTyVarBndr's have an extra arg
-                L _ (G.UserTyVar n _)     -> n
-                L _ (G.KindedTyVar n _ _) -> n
-#endif
+                L _ (G.UserTyVar _ (G.L _ n))     -> n
+                L _ (G.KindedTyVar _ (G.L _ n) _) -> n
          in return $ Just (TyFamDecl loc name flavour $ map getTyFamVarName vars)
       _ -> return Nothing
   where obtainClassInfo :: GhcMonad m => G.ModuleInfo -> G.Name -> SrcSpan -> m (Maybe SigInfo)
@@ -275,36 +239,36 @@ initialBodyArgs1 args elts = take (length args) elts
 -- (so the full file doesn't have to be type correct)
 -- but for instances we need to get information about the class
 
-class FnArgsInfo ty name | ty -> name, name -> ty where
+class FnArgsInfo ty name | name -> ty, ty -> name where
   getFnName :: DynFlags -> PprStyle -> name -> String
   getFnArgs :: ty -> [FnArg]
 
-instance FnArgsInfo (G.HsType G.RdrName) (G.RdrName) where
+instance FnArgsInfo (G.HsType G.GhcPs) (G.RdrName) where
   getFnName dflag style name = showOccName dflag style $ Gap.occName name
 #if __GLASGOW_HASKELL__ >= 800
-  getFnArgs (G.HsForAllTy _ (L _ iTy))
+  getFnArgs (G.HsForAllTy _ _ (L _ iTy))
 #elif __GLASGOW_HASKELL__ >= 710
   getFnArgs (G.HsForAllTy _ _ _ _ (L _ iTy))
 #else
   getFnArgs (G.HsForAllTy _ _ _ (L _ iTy))
 #endif
     = getFnArgs iTy
 
-  getFnArgs (G.HsParTy (L _ iTy))           = getFnArgs iTy
-  getFnArgs (G.HsFunTy (L _ lTy) (L _ rTy)) =
+  getFnArgs (G.HsParTy _ (L _ iTy))           = getFnArgs iTy
+  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__ >= 800
-              (G.HsForAllTy _ (L _ iTy)) ->
+              (G.HsForAllTy _ _ (L _ iTy)) ->
 #elif __GLASGOW_HASKELL__ >= 710
               (G.HsForAllTy _ _ _ _ (L _ iTy)) ->
 #else
               (G.HsForAllTy _ _ _ (L _ iTy)) ->
 #endif
                 fnarg iTy
 
-              (G.HsParTy (L _ iTy))          -> fnarg iTy
-              (G.HsFunTy _ _)                -> True
+              (G.HsParTy _ (L _ iTy))          -> fnarg iTy
+              (G.HsFunTy _ _ _)                -> True
               _                              -> False
   getFnArgs _ = []
 
@@ -401,11 +365,7 @@ 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
+    e@(L _ (G.HsVar _ (L _ i))):others -> do
       tyInfo <- Gap.getType tcm e
       case tyInfo of
         Just (s, typ)
@@ -415,13 +375,13 @@ findVar dflag style tcm tcs lineNo colNo =
             name = getFnName dflag style i
             -- If inside an App, we need parenthesis
             b = case others of
-                  L _ (G.HsApp (L _ a1) (L _ a2)):_ ->
+                  L _ (G.HsApp _ (L _ a1) (L _ a2)):_ ->
                     isSearchedVar i a1 || isSearchedVar i a2
                   _  -> False
         _ -> return Nothing
     _ -> return Nothing
   where
-    lst :: [G.LHsExpr Id]
+    lst :: [G.LHsExpr G.GhcTc]
     lst = sortBy (cmp `on` G.getLoc) $ listifySpans tcs (lineNo, colNo)
 
 infinitePrefixSupply :: String -> [String]
@@ -432,9 +392,9 @@ doParen :: Bool -> String -> String
 doParen False s = s
 doParen True  s = if ' ' `elem` s then '(':s ++ ")" else s
 
-isSearchedVar :: Id -> G.HsExpr Id -> Bool
+isSearchedVar :: Id -> G.HsExpr G.GhcTc -> Bool
 #if __GLASGOW_HASKELL__ >= 800
-isSearchedVar i (G.HsVar (L _ i2)) = i == i2
+isSearchedVar i (G.HsVar _ (L _ i2)) = i == i2
 #else
 isSearchedVar i (G.HsVar i2) = i == i2
 #endif
@@ -516,59 +476,50 @@ tyThingsToInfo (G.AnId i : xs) =
 tyThingsToInfo (_:xs) = tyThingsToInfo xs
 
 -- Find the Id of the function and the pattern where the hole is located
-getPatsForVariable :: G.TypecheckedSource -> (Int,Int) -> (Id, [Ty.LPat Id])
+getPatsForVariable :: G.TypecheckedSource -> (Int,Int) -> (Id, [Ty.LPat G.GhcTc])
 getPatsForVariable tcs (lineNo, colNo) =
   let (L _ bnd:_) = sortBy (cmp `on` G.getLoc) $
-                      listifySpans tcs (lineNo, colNo) :: [G.LHsBind Id]
+                      listifySpans tcs (lineNo, colNo) :: [G.LHsBind G.GhcTc]
    in case bnd of
         G.PatBind { Ty.pat_lhs = L ploc pat }  -> case pat of
           Ty.ConPatIn (L _ i) _ -> (i, [L ploc pat])
           _                     -> (error "This should never happen", [])
         G.FunBind { Ty.fun_id = L _ funId } ->
-          let m = sortBy (cmp `on` G.getLoc) $ listifySpans tcs (lineNo, colNo)
-#if __GLASGOW_HASKELL__ >= 708
-                    :: [G.LMatch Id (G.LHsExpr Id)]
-#else
-                    :: [G.LMatch Id]
-#endif
-#if __GLASGOW_HASKELL__ >= 710
-              (L _ (G.Match _ pats _ _):_) = m
-#else
-              (L _ (G.Match pats _ _):_) = m
-#endif
+          let m = sortBy (cmp `on` G.getLoc) $ listifySpans tcs (lineNo, colNo) :: [G.LMatch G.GhcTc (G.LHsExpr G.GhcTc)]
+              (L _ (G.Match _ _ pats _ ):_) = m
            in (funId, pats)
         _ -> (error "This should never happen", [])
 
-getBindingsForPat :: Ty.Pat Id -> M.Map G.Name Type
+getBindingsForPat :: Ty.Pat G.GhcTc -> M.Map G.Name Type
 #if __GLASGOW_HASKELL__ >= 800
-getBindingsForPat (Ty.VarPat (L _ i)) = M.singleton (G.getName i) (Ty.varType i)
+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)) =
+getBindingsForPat (Ty.LazyPat _ (L _ l)) = getBindingsForPat l
+getBindingsForPat (Ty.BangPat _ (L _ b)) = getBindingsForPat b
+getBindingsForPat (Ty.AsPat _ (L _ a) (L _ i)) =
     M.insert (G.getName a) (Ty.varType a) (getBindingsForPat i)
 #if __GLASGOW_HASKELL__ >= 708
-getBindingsForPat (Ty.ListPat  l _ _) =
+getBindingsForPat (Ty.ListPat _ l) =
     M.unions $ map (\(L _ i) -> getBindingsForPat i) l
 #else
 getBindingsForPat (Ty.ListPat  l _)   =
     M.unions $ map (\(L _ i) -> getBindingsForPat i) l
 #endif
-getBindingsForPat (Ty.TuplePat l _ _) =
-    M.unions $ map (\(L _ i) -> getBindingsForPat i) l
-getBindingsForPat (Ty.PArrPat  l _)   =
+getBindingsForPat (Ty.TuplePat _ l _) =
     M.unions $ map (\(L _ i) -> getBindingsForPat i) l
-getBindingsForPat (Ty.ViewPat _ (L _ i) _) = getBindingsForPat i
-getBindingsForPat (Ty.SigPatIn  (L _ i) _) = getBindingsForPat i
-getBindingsForPat (Ty.SigPatOut (L _ i) _) = getBindingsForPat i
+-- getBindingsForPat (Ty.PArrPat  l _)   =
+--     M.unions $ map (\(L _ i) -> getBindingsForPat i) l
+getBindingsForPat (Ty.ViewPat _ _ (L _ i)) = getBindingsForPat i
+-- getBindingsForPat (Ty.SigPatIn  (L _ i) _) = getBindingsForPat i
+-- getBindingsForPat (Ty.SigPatOut (L _ i) _) = getBindingsForPat i
 getBindingsForPat (Ty.ConPatIn (L _ i) d) =
     M.insert (G.getName i) (Ty.varType i) (getBindingsForRecPat d)
 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 G.GhcTc -> M.Map G.Name Type
 #if __GLASGOW_HASKELL__ >= 800
 getBindingsForRecPat (G.PrefixCon args) =
 #else

GhcMod/Exe/Test.hs

@@ -15,18 +15,19 @@ import GhcMod.DynFlags
 import GHC
 import GHC.Exception
 import OccName
+import Safe
 
 test :: IOish m
       => FilePath -> GhcModT m String
 test f = runGmlT' [Left f] (fmap setHscInterpreted . deferErrors) $ do
-    mg <- getModuleGraph
+    mg <- mgModSummaries <$> getModuleGraph
     root <- cradleRootDir <$> cradle
     f' <- makeRelative root <$> liftIO (canonicalizePath f)
     let Just ms = find ((==Just f') . ml_hs_file . ms_location) mg
         mdl = ms_mod ms
         mn = moduleName mdl
 
-    Just mi <- getModuleInfo mdl
+    mi <- fromJustNote "test: mi" <$> getModuleInfo mdl
     let exs = map (occNameString . getOccName) $ modInfoExports mi
         cqs = filter ("prop_" `isPrefixOf`) exs
 

cabal.project

@@ -1,2 +1,3 @@
 packages: .
           ./core
+          ../cabal-helper

core/GhcMod/DebugLogger.hs

@@ -133,6 +133,7 @@ gmPrintDoc_ mode pprCols putS doc
 #if __GLASGOW_HASKELL__ >= 708
     put (ZStr s) next = putS (zString s) >> next
 #endif
-    put (LStr s _l) next = putS (unpackLitString s) >> next
+    put (LStr s) next = putS (unpackLitString s) >> next
+    put (RStr _ s) next = putS [s] >> next
 
     done = return () -- hPutChar hdl '\n'