GHC’s renamer (Part II)

{-# COMPLETE U #-}
pattern U :: ()
pattern U = ()

foo :: Identity Char
foo = do
  U <- return ()
  return 'c'

error:
    * No instance for `MonadFail Identity'
        arising from a do statement
        with the failable pattern `U'
    * In a stmt of a 'do' block: U <- return ()

rnStmt ctxt rnBody (L loc (BindStmt _ pat (L lb body))) thing_inside
  = do  { -- ...
        ; (fail_op, fvs2) <- monadFailOp pat ctxt
        ; -- ...
        }

monadFailOp :: LPat GhcPs
            -> HsStmtContext GhcRn
            -> RnM (FailOperator GhcRn, FreeVars)
monadFailOp pat ctxt = do
    dflags <- getDynFlags
    if | isIrrefutableHsPat dflags pat -> return (Nothing, emptyFVs)
       | not (isMonadStmtContext ctxt) -> return (Nothing, emptyFVs)
       | otherwise -> getMonadFailOp ctxt

tcDoStmt ctxt (BindStmt xbsrn pat rhs) res_ty thing_inside
  = do  { -- ...
        ; fail_op' <- fmap join . forM (xbsrn_failOp xbsrn) $ \fail ->
            tcMonadFailOp (DoPatOrigin pat) pat' fail new_res_ty
        ; -- ...
        ; return (BindStmt xbstc pat' rhs', thing) }

tcMonadFailOp orig pat fail_op res_ty = do
    dflags <- getDynFlags
    if isIrrefutableHsPat dflags pat
    then return Nothing
    else Just . snd <$> (tcSyntaxOp orig fail_op [synKnownType stringTy]
                          (mkCheckExpType res_ty) $ \_ _ -> return ())

data Pat p
  = -- ...
  | ConPat {
        pat_con_ext :: XConPat p,
        pat_con     :: XRec p (ConLikeP p),
        pat_args    :: HsConPatDetails p
    }

data ConInfoType
  = ConIsData { conIsSingleDataCon :: Bool }
  | ConIsPatSyn

data TcGblEnv
  = TcGblEnv { -- ...
             , tcg_complete_matches :: !CompleteMatches
   {- NEW -} , tcg_complete_matches_rn :: !CompleteMatchesRn
             , -- ...
             }

-- NEW
type CompleteMatchesRn = [CompleteMatchRn]
data CompleteMatchRn = CompleteMatchRn
  { cmConLikesRn :: NameSet -- ^ The set of `ConLike` values
  }

rnValBindsRHS :: HsSigCtxt
              -> HsValBindsLR GhcRn GhcPs
              -> RnM (HsValBinds GhcRn, DefUses)
rnValBindsRHS ctxt (ValBinds _ mbinds sigs)
  = do { (sigs', sig_fvs) <- renameSigs ctxt sigs
       ; binds_w_dus <- mapBagM (rnLBind (mkScopedTvFn sigs')) mbinds
       -- ...
       }

isIrrefutableHsPat :: IsPass p => LPat (GhcPass p) -> TcM Bool
isIrrefutableHsPat pat
  = do { strict <- xoptM LangExt.Strict
       ; comps <- get_complete_matches_rn
       ; return $ is_irrefutable_pat comps strict pat }

get_complete_matches_rn :: TcM CompleteMatchesRn
get_complete_matches_rn
  = do { hsc_env <- getTopEnv
       ; tcg_env <- getGblEnv
       ; eps <- liftIO $ hscEPS hsc_env
       ; return $
          completeMatchesRn
            (   hptCompleteSigs hsc_env      -- from the home package
             ++ eps_complete_matches eps )   -- from imports
          ++ tcg_complete_matches_rn tcg_env -- from the current module
       }

dsHandleMonadicFailure ctx pat match m_fail_op =
  case shareFailureHandler match of
    MR_Infallible body -> body
    MR_Fallible body ->
      case m_fail_op of
-- Note that (non-monadic) list comprehension, pattern guards, etc could
-- have fallible bindings without an explicit failure op, but this is
-- handled elsewhere. See Note [Failing pattern matches in Stmts] the
-- breakdown of regular and special binds.
        Nothing -> pprPanic "missing fail op" $
          text "Pattern match:" <+> ppr pat <+>
          text "is failable, and fail_expr was left unset"
        Just fail_op -> -- ...

mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult CoreExpr
mkCoSynCaseMatchResult var ty alt = MR_Fallible $ mkPatSynCase var ty alt

dsHandleMonadicFailure ctx pat match m_fail_op body_ty =
  case shareFailureHandler match of
    MR_Infallible body -> body
    MR_Fallible body -> do
      case m_fail_op of
        Nothing ->
          do error_expr <- mkErrorAppDs pAT_ERROR_ID body_ty (ppr pat)
             body error_expr
        Just fail_op -> -- ...

pattern Bogus :: Int
pattern Bogus = 3
{-# COMPLETE Bogus #-}

bogus :: Identity Bool
bogus = do
  Bogus <- return 4
  return False