Monad.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}  -- instance MonadThings is necessarily an orphan

{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998


Monadery used in desugaring
-}

module GHC.HsToCore.Monad (
        DsM, mapM, mapAndUnzipM,
        initDs, initDsTc, initTcDsForSolver, initDsWithModGuts, fixDs,
        foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM, xoptM,
        Applicative(..),(<$>),

        duplicateLocalDs, newSysLocalDs,
        newSysLocalsDs, newUniqueId,
        newFailLocalDs, newPredVarDs,
        getSrcSpanDs, putSrcSpanDs, putSrcSpanDsA,
        mkPrintUnqualifiedDs,
        newUnique,
        UniqSupply, newUniqueSupply,
        getGhcModeDs, dsGetFamInstEnvs,
        dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon,
        dsLookupDataCon, dsLookupConLike,
        getCCIndexDsM,

        DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv,

        -- Getting and setting pattern match oracle states
        getPmNablas, updPmNablas,

        -- Get COMPLETE sets of a TyCon
        dsGetCompleteMatches,

        -- Warnings and errors
        DsWarning, diagnosticDs, errDsCoreExpr,
        failWithDs, failDs, discardWarningsDs,

        -- Data types
        DsMatchContext(..),
        EquationInfo(..), MatchResult (..), runMatchResult, DsWrapper, idDsWrapper,

        -- Trace injection
        pprRuntimeTrace
    ) where

import GHC.Prelude

import GHC.Driver.Env
import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.Driver.Config.Diagnostic

import GHC.Hs

import GHC.HsToCore.Types
import GHC.HsToCore.Errors.Types
import GHC.HsToCore.Pmc.Solver.Types (Nablas, initNablas)

import GHC.Core.FamInstEnv
import GHC.Core
import GHC.Core.Make  ( unitExpr )
import GHC.Core.Utils ( exprType )
import GHC.Core.DataCon
import GHC.Core.ConLike
import GHC.Core.TyCon
import GHC.Core.Type
import GHC.Core.Multiplicity

import GHC.IfaceToCore

import GHC.Tc.Utils.Monad

import GHC.Builtin.Names

import GHC.Data.FastString

import GHC.Unit.Env
import GHC.Unit.External
import GHC.Unit.Module
import GHC.Unit.Module.ModGuts

import GHC.Types.Name.Reader
import GHC.Types.Basic ( Origin )
import GHC.Types.SourceFile
import GHC.Types.Id
import GHC.Types.SrcLoc
import GHC.Types.TypeEnv
import GHC.Types.Unique.Supply
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Name.Ppr
import GHC.Types.Literal ( mkLitString )
import GHC.Types.CostCentre.State
import GHC.Types.TyThing
import GHC.Types.Error

import GHC.Utils.Error
import GHC.Utils.Outputable
import GHC.Utils.Panic
import qualified GHC.Data.Strict as Strict

import Data.IORef
import GHC.Driver.Env.KnotVars

{-
************************************************************************
*                                                                      *
                Data types for the desugarer
*                                                                      *
************************************************************************
-}

data DsMatchContext
  = DsMatchContext (HsMatchContext GhcRn) SrcSpan
  deriving ()

instance Outputable DsMatchContext where
  ppr (DsMatchContext hs_match ss) = ppr ss <+> pprMatchContext hs_match

data EquationInfo
  = EqnInfo { eqn_pats :: [Pat GhcTc]
              -- ^ The patterns for an equation
              --
              -- NB: We have /already/ applied 'decideBangHood' to
              -- these patterns.  See Note [decideBangHood] in "GHC.HsToCore.Utils"

            , eqn_orig :: Origin
              -- ^ Was this equation present in the user source?
              --
              -- This helps us avoid warnings on patterns that GHC elaborated.
              --
              -- For instance, the pattern @-1 :: Word@ gets desugared into
              -- @W# -1## :: Word@, but we shouldn't warn about an overflowed
              -- literal for /both/ of these cases.

            , eqn_rhs  :: MatchResult CoreExpr
              -- ^ What to do after match
            }

instance Outputable EquationInfo where
    ppr (EqnInfo pats _ _) = ppr pats

type DsWrapper = CoreExpr -> CoreExpr
idDsWrapper :: DsWrapper
idDsWrapper e = e

-- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult CoreExpr
--      \fail. wrap (case vs of { pats -> rhs fail })
-- where vs are not bound by wrap

-- | This is a value of type a with potentially a CoreExpr-shaped hole in it.
-- This is used to deal with cases where we are potentially handling pattern
-- match failure, and want to later specify how failure is handled.
data MatchResult a
  -- | We represent the case where there is no hole without a function from
  -- 'CoreExpr', like this, because sometimes we have nothing to put in the
  -- hole and so want to be sure there is in fact no hole.
  = MR_Infallible (DsM a)
  | MR_Fallible (CoreExpr -> DsM a)
  deriving (Functor)

-- | Product is an "or" on falliblity---the combined match result is infallible
-- only if the left and right argument match results both were.
--
-- This is useful for combining a bunch of alternatives together and then
-- getting the overall falliblity of the entire group. See 'mkDataConCase' for
-- an example.
instance Applicative MatchResult where
  pure v = MR_Infallible (pure v)
  MR_Infallible f <*> MR_Infallible x = MR_Infallible (f <*> x)
  f <*> x = MR_Fallible $ \fail -> runMatchResult fail f <*> runMatchResult fail x

-- Given a fail expression to use, and a MatchResult CoreExpr, compute the filled CoreExpr whether
-- the MatchResult CoreExpr was failable or not.
runMatchResult :: CoreExpr -> MatchResult a -> DsM a
runMatchResult fail = \case
  MR_Infallible body -> body
  MR_Fallible body_fn -> body_fn fail

{-
************************************************************************
*                                                                      *
                Monad functions
*                                                                      *
************************************************************************
-}

-- Compatibility functions
fixDs :: (a -> DsM a) -> DsM a
fixDs    = fixM

type DsWarning = (SrcSpan, SDoc)
        -- Not quite the same as a WarnMsg, we have an SDoc here
        -- and we'll do the print_unqual stuff later on to turn it
        -- into a Doc.

-- | Run a 'DsM' action inside the 'TcM' monad.
initDsTc :: DsM a -> TcM (Messages DsMessage, Maybe a)
initDsTc thing_inside
  = do { tcg_env  <- getGblEnv
       ; msg_var  <- liftIO $ newIORef emptyMessages
       ; hsc_env  <- getTopEnv
       ; envs     <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
       ; e_result <- tryM $  -- need to tryM so that we don't discard
                             -- DsMessages
                     setEnvs envs thing_inside
       ; msgs     <- liftIO $ readIORef msg_var
       ; return (msgs, case e_result of Left _  -> Nothing
                                        Right x -> Just x)
       }

-- | Run a 'DsM' action inside the 'IO' monad.
initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages DsMessage, Maybe a)
initDs hsc_env tcg_env thing_inside
  = do { msg_var <- newIORef emptyMessages
       ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
       ; runDs hsc_env envs thing_inside
       }

-- | Build a set of desugarer environments derived from a 'TcGblEnv'.
mkDsEnvsFromTcGbl :: MonadIO m
                  => HscEnv -> IORef (Messages DsMessage) -> TcGblEnv
                  -> m (DsGblEnv, DsLclEnv)
mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
  = do { cc_st_var   <- liftIO $ newIORef newCostCentreState
       ; eps <- liftIO $ hscEPS hsc_env
       ; let unit_env = hsc_unit_env hsc_env
             this_mod = tcg_mod tcg_env
             type_env = tcg_type_env tcg_env
             rdr_env  = tcg_rdr_env tcg_env
             fam_inst_env = tcg_fam_inst_env tcg_env
             complete_matches = hptCompleteSigs hsc_env         -- from the home package
                                ++ tcg_complete_matches tcg_env -- from the current module
                                ++ eps_complete_matches eps     -- from imports
             -- re-use existing next_wrapper_num to ensure uniqueness
             next_wrapper_num_var = tcg_next_wrapper_num tcg_env
       ; return $ mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env
                           msg_var cc_st_var next_wrapper_num_var complete_matches
       }

runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages DsMessage, Maybe a)
runDs hsc_env (ds_gbl, ds_lcl) thing_inside
  = do { res    <- initTcRnIf 'd' hsc_env ds_gbl ds_lcl
                              (tryM thing_inside)
       ; msgs   <- readIORef (ds_msgs ds_gbl)
       ; let final_res
               | errorsFound msgs = Nothing
               | Right r <- res   = Just r
               | otherwise        = panic "initDs"
       ; return (msgs, final_res)
       }

-- | Run a 'DsM' action in the context of an existing 'ModGuts'
initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages DsMessage, Maybe a)
initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds
                                   , mg_tcs = tycons, mg_fam_insts = fam_insts
                                   , mg_patsyns = patsyns, mg_rdr_env = rdr_env
                                   , mg_fam_inst_env = fam_inst_env
                                   , mg_complete_matches = local_complete_matches
                          }) thing_inside
  = do { cc_st_var   <- newIORef newCostCentreState
       ; next_wrapper_num <- newIORef emptyModuleEnv
       ; msg_var <- newIORef emptyMessages
       ; eps <- liftIO $ hscEPS hsc_env
       ; let unit_env = hsc_unit_env hsc_env
             type_env = typeEnvFromEntities ids tycons patsyns fam_insts
             complete_matches = hptCompleteSigs hsc_env     -- from the home package
                                ++ local_complete_matches  -- from the current module
                                ++ eps_complete_matches eps -- from imports

             bindsToIds (NonRec v _)   = [v]
             bindsToIds (Rec    binds) = map fst binds
             ids = concatMap bindsToIds binds

             envs  = mkDsEnvs unit_env this_mod rdr_env type_env
                              fam_inst_env msg_var cc_st_var
                              next_wrapper_num complete_matches
       ; runDs hsc_env envs thing_inside
       }

initTcDsForSolver :: TcM a -> DsM a
-- Spin up a TcM context so that we can run the constraint solver
-- Returns any error messages generated by the constraint solver
-- and (Just res) if no error happened; Nothing if an error happened
--
-- Simon says: I'm not very happy about this.  We spin up a complete TcM monad
--             only to immediately refine it to a TcS monad.
-- Better perhaps to make TcS into its own monad, rather than building on TcS
-- But that may in turn interact with plugins

initTcDsForSolver thing_inside
  = do { (gbl, lcl) <- getEnvs
       ; hsc_env    <- getTopEnv

       ; let DsGblEnv { ds_mod = mod
                      , ds_fam_inst_env = fam_inst_env
                      , ds_gbl_rdr_env  = rdr_env }      = gbl
       -- This is *the* use of ds_gbl_rdr_env:
       -- Make sure the solver (used by the pattern-match overlap checker) has
       -- access to the GlobalRdrEnv and FamInstEnv for the module, so that it
       -- knows how to reduce type families, and which newtypes it can unwrap.


             DsLclEnv { dsl_loc = loc }                  = lcl

       ; (msgs, mb_ret) <- liftIO $ initTc hsc_env HsSrcFile False mod loc $
         updGblEnv (\tc_gbl -> tc_gbl { tcg_fam_inst_env = fam_inst_env
                                      , tcg_rdr_env      = rdr_env }) $
         thing_inside
       ; case mb_ret of
           Just ret -> pure ret
           Nothing  -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLoc (getErrorMessages msgs)) }

mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
         -> IORef (Messages DsMessage) -> IORef CostCentreState
         -> IORef (ModuleEnv Int) -> CompleteMatches
         -> (DsGblEnv, DsLclEnv)
mkDsEnvs unit_env mod rdr_env type_env fam_inst_env msg_var cc_st_var
         next_wrapper_num complete_matches
  = let if_genv = IfGblEnv { if_doc       = text "mkDsEnvs"
  -- Failing tests here are `ghci` and `T11985` if you get this wrong.
  -- this is very very "at a distance" because the reason for this check is that the type_env in interactive
  -- mode is the smushed together of all the interactive modules.
  -- See Note [Why is KnotVars not a ModuleEnv]
                             , if_rec_types = KnotVars [mod] (\that_mod -> if that_mod == mod || isInteractiveModule mod
                                                          then Just (return type_env)
                                                          else Nothing) }
        if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod)
                             NotBoot
        real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1)
        gbl_env = DsGblEnv { ds_mod     = mod
                           , ds_fam_inst_env = fam_inst_env
                           , ds_gbl_rdr_env  = rdr_env
                           , ds_if_env  = (if_genv, if_lenv)
                           , ds_unqual  = mkPrintUnqualified unit_env rdr_env
                           , ds_msgs    = msg_var
                           , ds_complete_matches = complete_matches
                           , ds_cc_st   = cc_st_var
                           , ds_next_wrapper_num = next_wrapper_num
                           }
        lcl_env = DsLclEnv { dsl_meta    = emptyNameEnv
                           , dsl_loc     = real_span
                           , dsl_nablas  = initNablas
                           }
    in (gbl_env, lcl_env)


{-
************************************************************************
*                                                                      *
                Operations in the monad
*                                                                      *
************************************************************************

And all this mysterious stuff is so we can occasionally reach out and
grab one or more names.  @newLocalDs@ isn't exported---exported
functions are defined with it.  The difference in name-strings makes
it easier to read debugging output.

-}

-- Make a new Id with the same print name, but different type, and new unique
newUniqueId :: Id -> Mult -> Type -> DsM Id
newUniqueId id = mkSysLocalOrCoVarM (occNameFS (nameOccName (idName id)))

duplicateLocalDs :: Id -> DsM Id
duplicateLocalDs old_local
  = do  { uniq <- newUnique
        ; return (setIdUnique old_local uniq) }

newPredVarDs :: PredType -> DsM Var
newPredVarDs
 = mkSysLocalOrCoVarM (fsLit "ds") Many  -- like newSysLocalDs, but we allow covars

newSysLocalDs, newFailLocalDs :: Mult -> Type -> DsM Id
newSysLocalDs = mkSysLocalM (fsLit "ds")
newFailLocalDs = mkSysLocalM (fsLit "fail")

newSysLocalsDs :: [Scaled Type] -> DsM [Id]
newSysLocalsDs = mapM (\(Scaled w t) -> newSysLocalDs w t)

{-
We can also reach out and either set/grab location information from
the @SrcSpan@ being carried around.
-}

getGhcModeDs :: DsM GhcMode
getGhcModeDs =  getDynFlags >>= return . ghcMode

-- | Get the current pattern match oracle state. See 'dsl_nablas'.
getPmNablas :: DsM Nablas
getPmNablas = do { env <- getLclEnv; return (dsl_nablas env) }

-- | Set the pattern match oracle state within the scope of the given action.
-- See 'dsl_nablas'.
updPmNablas :: Nablas -> DsM a -> DsM a
updPmNablas nablas = updLclEnv (\env -> env { dsl_nablas = nablas })

getSrcSpanDs :: DsM SrcSpan
getSrcSpanDs = do { env <- getLclEnv
                  ; return (RealSrcSpan (dsl_loc env) Strict.Nothing) }

putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
putSrcSpanDs (UnhelpfulSpan {}) thing_inside
  = thing_inside
putSrcSpanDs (RealSrcSpan real_span _) thing_inside
  = updLclEnv (\ env -> env {dsl_loc = real_span}) thing_inside

putSrcSpanDsA :: SrcSpanAnn' ann -> DsM a -> DsM a
putSrcSpanDsA loc = putSrcSpanDs (locA loc)

-- | Emit a diagnostic for the current source location. In case the diagnostic is a warning,
-- the latter will be ignored and discarded if the relevant 'WarningFlag' is not set in the DynFlags.
-- See Note [Discarding Messages] in 'GHC.Types.Error'.
diagnosticDs :: DsMessage -> DsM ()
diagnosticDs dsMessage
  = do { env <- getGblEnv
       ; loc <- getSrcSpanDs
       ; !diag_opts <- initDiagOpts <$> getDynFlags
       ; let msg = mkMsgEnvelope diag_opts loc (ds_unqual env) dsMessage
       ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) }

-- | Issue an error, but return the expression for (), so that we can continue
-- reporting errors.
errDsCoreExpr :: DsMessage -> DsM CoreExpr
errDsCoreExpr msg
  = do { diagnosticDs msg
       ; return unitExpr }

failWithDs :: DsMessage -> DsM a
failWithDs msg
  = do  { diagnosticDs msg
        ; failM }

failDs :: DsM a
failDs = failM

mkPrintUnqualifiedDs :: DsM PrintUnqualified
mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv

instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where
    lookupThing = dsLookupGlobal

dsLookupGlobal :: Name -> DsM TyThing
-- Very like GHC.Tc.Utils.Env.tcLookupGlobal
dsLookupGlobal name
  = do  { env <- getGblEnv
        ; setEnvs (ds_if_env env)
                  (tcIfaceGlobal name) }

dsLookupGlobalId :: Name -> DsM Id
dsLookupGlobalId name
  = tyThingId <$> dsLookupGlobal name

dsLookupTyCon :: Name -> DsM TyCon
dsLookupTyCon name
  = tyThingTyCon <$> dsLookupGlobal name

dsLookupDataCon :: Name -> DsM DataCon
dsLookupDataCon name
  = tyThingDataCon <$> dsLookupGlobal name

dsLookupConLike :: Name -> DsM ConLike
dsLookupConLike name
  = tyThingConLike <$> dsLookupGlobal name


dsGetFamInstEnvs :: DsM FamInstEnvs
-- Gets both the external-package inst-env
-- and the home-pkg inst env (includes module being compiled)
dsGetFamInstEnvs
  = do { eps <- getEps; env <- getGblEnv
       ; return (eps_fam_inst_env eps, ds_fam_inst_env env) }

dsGetMetaEnv :: DsM (NameEnv DsMetaVal)
dsGetMetaEnv = do { env <- getLclEnv; return (dsl_meta env) }

-- | The @COMPLETE@ pragmas that are in scope.
dsGetCompleteMatches :: DsM CompleteMatches
dsGetCompleteMatches = ds_complete_matches <$> getGblEnv

dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (dsl_meta env) name) }

dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
dsExtendMetaEnv menv thing_inside
  = updLclEnv (\env -> env { dsl_meta = dsl_meta env `plusNameEnv` menv }) thing_inside

discardWarningsDs :: DsM a -> DsM a
-- Ignore warnings inside the thing inside;
-- used to ignore inaccessible cases etc. inside generated code
discardWarningsDs thing_inside
  = do  { env <- getGblEnv
        ; old_msgs <- readTcRef (ds_msgs env)

        ; result <- thing_inside

        -- Revert messages to old_msgs
        ; writeTcRef (ds_msgs env) old_msgs

        ; return result }

-- | Inject a trace message into the compiled program. Whereas
-- pprTrace prints out information *while compiling*, pprRuntimeTrace
-- captures that information and causes it to be printed *at runtime*
-- using Debug.Trace.trace.
--
--   pprRuntimeTrace hdr doc expr
--
-- will produce an expression that looks like
--
--   trace (hdr + doc) expr
--
-- When using this to debug a module that Debug.Trace depends on,
-- it is necessary to import {-# SOURCE #-} Debug.Trace () in that
-- module. We could avoid this inconvenience by wiring in Debug.Trace.trace,
-- but that doesn't seem worth the effort and maintenance cost.
pprRuntimeTrace :: String   -- ^ header
                -> SDoc     -- ^ information to output
                -> CoreExpr -- ^ expression
                -> DsM CoreExpr
pprRuntimeTrace str doc expr = do
  traceId <- dsLookupGlobalId traceName
  unpackCStringId <- dsLookupGlobalId unpackCStringName
  dflags <- getDynFlags
  let message :: CoreExpr
      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