Extract definition of DsM into GHC.HsToCore.Types

`DsM` was previously defined in `GHC.Tc.Types`, along with `TcM`. But
`GHC.Tc.Types` is in the set of transitive dependencies of `GHC.Parser`,
a set which we aim to minimise. Test case `CountParserDeps` checks for
that.

Having `DsM` in that set means the parser also depends on the innards of
the pattern-match checker in `GHC.HsToCore.PmCheck.Types`, which is the
reason we have that module in the first place.

In the previous commit, we represented the `TyState` by an `InertSet`,
but that pulls the constraint solver as well as 250 more modules into
the set of dependencies, triggering failure of `CountParserDeps`.
Clearly, we want to evolve the pattern-match checker (and the desugarer)
without being concerned by this test, so this patch includes a small
refactor that puts `DsM` into its own module.

8 files changed, 96 insertions, 76 deletions

diff --git a/compiler/GHC/Driver/Hooks.hs b/compiler/GHC/Driver/Hooks.hs
index 98259e3eee..f6aca818f9 100644
--- a/compiler/GHC/Driver/Hooks.hs
+++ b/compiler/GHC/Driver/Hooks.hs
@@ -38,6 +38,7 @@ import GHC.Hs.Binds
 import GHC.Hs.Expr
 import GHC.Data.OrdList
 import GHC.Tc.Types
+import GHC.HsToCore.Types
 import GHC.Data.Bag
 import GHC.Types.Name.Reader
 import GHC.Types.Name
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index 671e525bb1..be61777722 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -816,7 +816,7 @@ ds_prag_expr (HsPragSCC _ _ cc) expr = do
         mod_name <- getModule
         count <- goptM Opt_ProfCountEntries
         let nm = sl_fs cc
-        flavour <- ExprCC <$> getCCIndexM nm
+        flavour <- ExprCC <$> getCCIndexDsM nm
         Tick (ProfNote (mkUserCC nm mod_name (getLoc expr) flavour) count True)
                <$> dsLExpr expr
       else dsLExpr expr
diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs
index e7a820a86e..0c9717d4eb 100644
--- a/compiler/GHC/HsToCore/Monad.hs
+++ b/compiler/GHC/HsToCore/Monad.hs
@@ -30,6 +30,7 @@ module GHC.HsToCore.Monad (
         getGhcModeDs, dsGetFamInstEnvs,
         dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon,
         dsLookupDataCon, dsLookupConLike,
+        getCCIndexDsM,
 
         DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv,
 
@@ -73,6 +74,7 @@ import GHC.Types.Basic ( Origin )
 import GHC.Core.DataCon
 import GHC.Core.ConLike
 import GHC.Core.TyCon
+import GHC.HsToCore.Types
 import GHC.HsToCore.PmCheck.Types
 import GHC.Types.Id
 import GHC.Unit.Module
@@ -614,3 +616,7 @@ pprRuntimeTrace str doc expr = do
       message = App (Var unpackCStringId) $
                 Lit $ mkLitString $ showSDoc dflags (hang (text str) 4 doc)
   return $ mkApps (Var traceId) [Type (exprType expr), message, expr]
+
+-- | See 'getCCIndexM'.
+getCCIndexDsM :: FastString -> DsM CostCentreIndex
+getCCIndexDsM = getCCIndexM ds_cc_st
diff --git a/compiler/GHC/HsToCore/Types.hs b/compiler/GHC/HsToCore/Types.hs
new file mode 100644
index 0000000000..26f6a6af79
--- /dev/null
+++ b/compiler/GHC/HsToCore/Types.hs
@@ -0,0 +1,77 @@
+-- | Various types used during desugaring.
+module GHC.HsToCore.Types (
+        DsM, DsLclEnv(..), DsGblEnv(..),
+        DsMetaEnv, DsMetaVal(..), CompleteMatches
+    ) where
+
+import Data.IORef
+
+import GHC.Types.CostCentre.State
+import GHC.Types.Name.Env
+import GHC.Types.SrcLoc
+import GHC.Types.Var
+import GHC.Hs (HsExpr, GhcTc)
+import GHC.Tc.Types (TcRnIf, IfGblEnv, IfLclEnv, CompleteMatches)
+import {-# SOURCE #-} GHC.HsToCore.PmCheck.Types (Nablas)
+import GHC.Core.FamInstEnv
+import GHC.Utils.Error
+import GHC.Utils.Outputable as Outputable
+import GHC.Unit.Module
+
+{-
+************************************************************************
+*                                                                      *
+                Desugarer monad
+*                                                                      *
+************************************************************************
+
+Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
+a @UniqueSupply@ and some annotations, which
+presumably include source-file location information:
+-}
+
+-- | Global read-only context and state of the desugarer.
+-- The statefulness is implemented through 'IORef's.
+data DsGblEnv
+  = DsGblEnv
+  { ds_mod          :: Module             -- For SCC profiling
+  , ds_fam_inst_env :: FamInstEnv         -- Like tcg_fam_inst_env
+  , ds_unqual  :: PrintUnqualified
+  , ds_msgs    :: IORef Messages          -- Warning messages
+  , ds_if_env  :: (IfGblEnv, IfLclEnv)    -- Used for looking up global,
+                                          -- possibly-imported things
+  , ds_complete_matches :: CompleteMatches
+     -- Additional complete pattern matches
+  , ds_cc_st   :: IORef CostCentreState
+     -- Tracking indices for cost centre annotations
+  }
+
+instance ContainsModule DsGblEnv where
+  extractModule = ds_mod
+
+-- | Local state of the desugarer, extended as we lexically descend
+data DsLclEnv
+  = DsLclEnv
+  { dsl_meta    :: DsMetaEnv   -- ^ Template Haskell bindings
+  , dsl_loc     :: RealSrcSpan -- ^ To put in pattern-matching error msgs
+  , dsl_nablas  :: Nablas
+  -- ^ See Note [Note [Long-distance information] in "GHC.HsToCore.PmCheck".
+  -- The set of reaching values Nablas is augmented as we walk inwards, refined
+  -- through each pattern match in turn
+  }
+
+-- Inside [| |] brackets, the desugarer looks
+-- up variables in the DsMetaEnv
+type DsMetaEnv = NameEnv DsMetaVal
+
+data DsMetaVal
+  = DsBound Id         -- Bound by a pattern inside the [| |].
+                       -- Will be dynamically alpha renamed.
+                       -- The Id has type THSyntax.Var
+
+  | DsSplice (HsExpr GhcTc) -- These bindings are introduced by
+                            -- the PendingSplices on a HsBracketOut
+
+-- | Desugaring monad. See also 'TcM'.
+type DsM = TcRnIf DsGblEnv DsLclEnv
+
diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs
index af9073c87f..f2a810dbca 100644
--- a/compiler/GHC/Tc/Gen/Bind.hs
+++ b/compiler/GHC/Tc/Gen/Bind.hs
@@ -681,7 +681,7 @@ funBindTicks loc fun_id mod sigs
           = getOccFS (Var.varName fun_id)
         cc_name = moduleNameFS (moduleName mod) `appendFS` consFS '.' cc_str
   = do
-      flavour <- DeclCC <$> getCCIndexM cc_name
+      flavour <- DeclCC <$> getCCIndexTcM cc_name
       let cc = mkUserCC cc_name mod loc flavour
       return [ProfNote cc True True]
   | otherwise
diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs
index 3aea91fe7c..884e72f899 100644
--- a/compiler/GHC/Tc/Types.hs
+++ b/compiler/GHC/Tc/Types.hs
@@ -45,11 +45,7 @@ module GHC.Tc.Types(
         IdBindingInfo(..), ClosedTypeId, RhsNames,
         IsGroupClosed(..),
         SelfBootInfo(..),
-        pprTcTyThingCategory, pprPECategory, CompleteMatch,
-
-        -- Desugaring types
-        DsM, DsLclEnv(..), DsGblEnv(..),
-        DsMetaEnv, DsMetaVal(..), CompleteMatches,
+        pprTcTyThingCategory, pprPECategory, CompleteMatch, CompleteMatches,
 
         -- Template Haskell
         ThStage(..), SpliceType(..), PendingStuff(..),
@@ -105,7 +101,6 @@ import GHC.Tc.Types.Origin
 import GHC.Types.Annotations
 import GHC.Core.InstEnv
 import GHC.Core.FamInstEnv
-import {-# SOURCE #-} GHC.HsToCore.PmCheck.Types (Nablas)
 import GHC.Data.IOEnv
 import GHC.Types.Name.Reader
 import GHC.Types.Name
@@ -190,7 +185,6 @@ type TcRn       = TcRnIf TcGblEnv TcLclEnv    -- Type inference
 type IfM lcl    = TcRnIf IfGblEnv lcl         -- Iface stuff
 type IfG        = IfM ()                      --    Top level
 type IfL        = IfM IfLclEnv                --    Nested
-type DsM        = TcRnIf DsGblEnv DsLclEnv    -- Desugaring
 
 -- TcRn is the type-checking and renaming monad: the main monad that
 -- most type-checking takes place in.  The global environment is
@@ -292,58 +286,6 @@ data IfLclEnv
 {-
 ************************************************************************
 *                                                                      *
-                Desugarer monad
-*                                                                      *
-************************************************************************
-
-Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
-a @UniqueSupply@ and some annotations, which
-presumably include source-file location information:
--}
-
-data DsGblEnv
-        = DsGblEnv
-        { ds_mod          :: Module             -- For SCC profiling
-        , ds_fam_inst_env :: FamInstEnv         -- Like tcg_fam_inst_env
-        , ds_unqual  :: PrintUnqualified
-        , ds_msgs    :: IORef Messages          -- Warning messages
-        , ds_if_env  :: (IfGblEnv, IfLclEnv)    -- Used for looking up global,
-                                                -- possibly-imported things
-        , ds_complete_matches :: CompleteMatches
-           -- Additional complete pattern matches
-        , ds_cc_st   :: IORef CostCentreState
-           -- Tracking indices for cost centre annotations
-        }
-
-instance ContainsModule DsGblEnv where
-    extractModule = ds_mod
-
-data DsLclEnv = DsLclEnv {
-        dsl_meta    :: DsMetaEnv,        -- Template Haskell bindings
-        dsl_loc     :: RealSrcSpan,      -- To put in pattern-matching error msgs
-
-        -- See Note [Note [Long-distance information] in "GHC.HsToCore.PmCheck"
-        -- The set of reaching values Nablas is augmented as we walk inwards,
-        -- refined through each pattern match in turn
-        dsl_nablas  :: Nablas
-     }
-
--- Inside [| |] brackets, the desugarer looks
--- up variables in the DsMetaEnv
-type DsMetaEnv = NameEnv DsMetaVal
-
-data DsMetaVal
-   = DsBound Id         -- Bound by a pattern inside the [| |].
-                        -- Will be dynamically alpha renamed.
-                        -- The Id has type THSyntax.Var
-
-   | DsSplice (HsExpr GhcTc) -- These bindings are introduced by
-                             -- the PendingSplices on a HsBracketOut
-
-
-{-
-************************************************************************
-*                                                                      *
                 Global typechecker environment
 *                                                                      *
 ************************************************************************
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index b2c987794b..96bff3d261 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -138,7 +138,7 @@ module GHC.Tc.Utils.Monad(
   withException,
 
   -- * Stuff for cost centres.
-  ContainsCostCentreState(..), getCCIndexM,
+  getCCIndexM, getCCIndexTcM,
 
   -- * Types etc.
   module GHC.Tc.Types,
@@ -2081,23 +2081,16 @@ discussion).  We don't currently know a general solution to this problem, but
 we can use uninterruptibleMask_ to avoid the situation.
 -}
 
--- | Environments which track 'CostCentreState'
-class ContainsCostCentreState e where
-  extractCostCentreState :: e -> TcRef CostCentreState
-
-instance ContainsCostCentreState TcGblEnv where
-  extractCostCentreState = tcg_cc_st
-
-instance ContainsCostCentreState DsGblEnv where
-  extractCostCentreState = ds_cc_st
-
 -- | Get the next cost centre index associated with a given name.
-getCCIndexM :: (ContainsCostCentreState gbl)
-            => FastString -> TcRnIf gbl lcl CostCentreIndex
-getCCIndexM nm = do
+getCCIndexM :: (gbl -> TcRef CostCentreState) -> FastString -> TcRnIf gbl lcl CostCentreIndex
+getCCIndexM get_ccs nm = do
   env <- getGblEnv
-  let cc_st_ref = extractCostCentreState env
+  let cc_st_ref = get_ccs env
   cc_st <- readTcRef cc_st_ref
   let (idx, cc_st') = getCCIndex nm cc_st
   writeTcRef cc_st_ref cc_st'
   return idx
+
+-- | See 'getCCIndexM'.
+getCCIndexTcM :: FastString -> TcM CostCentreIndex
+getCCIndexTcM = getCCIndexM tcg_cc_st
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 577add44d1..f0f5a638d4 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -314,6 +314,7 @@ Library
         GHC.HsToCore.PmCheck
         GHC.HsToCore.Coverage
         GHC.HsToCore
+        GHC.HsToCore.Types
         GHC.HsToCore.Arrows
         GHC.HsToCore.Binds
         GHC.HsToCore.Foreign.Call