Move expansion of 'assert' from renamer to typechecker

This improves error messages when there is a type error,
fixing Trac #9774

5 files changed, 74 insertions, 64 deletions

diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index 79a944fb2f..b24956c85e 100644
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -79,17 +79,11 @@ rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
 finishHsVar :: Name -> RnM (HsExpr Name, FreeVars)
 -- Separated from rnExpr because it's also used
 -- when renaming infix expressions
--- See Note [Adding the implicit parameter to 'assert']
 finishHsVar name
  = do { this_mod <- getModule
       ; when (nameIsLocalOrFrom this_mod name) $
         checkThLocalName name
-
-      ; ignore_asserts <- goptM Opt_IgnoreAsserts
-      ; if ignore_asserts || not (name `hasKey` assertIdKey)
-        then return (HsVar name, unitFV name)
-        else do { e <- mkAssertErrorExpr
-                ; return (e, unitFV name) } }
+      ; return (HsVar name, unitFV name) }
 
 rnExpr (HsVar v)
   = do { mb_name <- lookupOccRn_maybe v
@@ -1143,36 +1137,6 @@ segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later
 
 %************************************************************************
 %*                                                                      *
-\subsubsection{Assertion utils}
-%*                                                                      *
-%************************************************************************
-
-\begin{code}
-srcSpanPrimLit :: DynFlags -> SrcSpan -> HsExpr Name
-srcSpanPrimLit dflags span
-    = HsLit (HsStringPrim (unsafeMkByteString (showSDocOneLine dflags (ppr span))))
-
-mkAssertErrorExpr :: RnM (HsExpr Name)
--- Return an expression for (assertError "Foo.hs:27")
-mkAssertErrorExpr
-  = do sloc <- getSrcSpanM
-       dflags <- getDynFlags
-       return (HsApp (L sloc (HsVar assertErrorName))
-                     (L sloc (srcSpanPrimLit dflags sloc)))
-\end{code}
-
-Note [Adding the implicit parameter to 'assert']
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The renamer transforms (assert e1 e2) to (assert "Foo.hs:27" e1 e2).
-By doing this in the renamer we allow the typechecker to just see the
-expanded application and do the right thing. But it's not really
-the Right Thing because there's no way to "undo" if you want to see
-the original source code.  We'll have fix this in due course, when
-we care more about being able to reconstruct the exact original
-program.
-
-%************************************************************************
-%*                                                                      *
 \subsubsection{Errors}
 %*                                                                      *
 %************************************************************************
diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index 5ebe6ee286..deda6137d0 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -48,7 +48,7 @@ import Var
 import VarSet
 import VarEnv
 import TysWiredIn
-import TysPrim( intPrimTy )
+import TysPrim( intPrimTy, addrPrimTy )
 import PrimOp( tagToEnumKey )
 import PrelNames
 import DynFlags
@@ -1063,34 +1063,54 @@ tcInferIdWithOrig :: CtOrigin -> Name -> TcM (HsExpr TcId, TcRhoType)
 -- Look up an occurrence of an Id, and instantiate it (deeply)
 
 tcInferIdWithOrig orig id_name
-  = do { id <- lookup_id
-       ; (id_expr, id_rho) <- instantiateOuter orig id
-       ; (wrap, rho) <- deeplyInstantiate orig id_rho
-       ; return (mkHsWrap wrap id_expr, rho) }
+  | id_name `hasKey` assertIdKey
+  = do { dflags <- getDynFlags
+       ; if gopt Opt_IgnoreAsserts dflags
+         then normal_case
+         else assert_case dflags }
+  | otherwise
+  = normal_case
   where
-    lookup_id :: TcM TcId
-    lookup_id
-       = do { thing <- tcLookup id_name
-            ; case thing of
-                 ATcId { tct_id = id }
-                   -> do { check_naughty id        -- Note [Local record selectors]
-                         ; checkThLocalId id
-                         ; return id }
-
-                 AGlobal (AnId id)
-                   -> do { check_naughty id; return id }
-                        -- A global cannot possibly be ill-staged
-                        -- nor does it need the 'lifting' treatment
-                        -- hence no checkTh stuff here
-
-                 AGlobal (AConLike cl) -> case cl of
-                     RealDataCon con -> return (dataConWrapId con)
-                     PatSynCon ps -> case patSynWrapper ps of
-                         Nothing -> failWithTc (bad_patsyn ps)
-                         Just id -> return id
-
-                 other -> failWithTc (bad_lookup other) }
+    normal_case
+      = do { id <- lookup_id id_name
+           ; (id_expr, id_rho) <- instantiateOuter orig id
+           ; (wrap, rho) <- deeplyInstantiate orig id_rho
+           ; return (mkHsWrap wrap id_expr, rho) }
+
+    assert_case dflags  -- See Note [Adding the implicit parameter to 'assert']
+      = do { sloc <- getSrcSpanM
+           ; assert_error_id <- lookup_id assertErrorName
+           ; (id_expr, id_rho) <- instantiateOuter orig assert_error_id
+           ; case tcSplitFunTy_maybe id_rho of {
+               Nothing -> pprPanic "assert type" (ppr id_rho) ;
+               Just (arg_ty, res_ty) -> ASSERT( arg_ty `tcEqType` addrPrimTy )
+        do { return (HsApp (L sloc id_expr)
+                           (L sloc (srcSpanPrimLit dflags sloc)), res_ty) } } }
+
+lookup_id :: Name -> TcM TcId
+lookup_id id_name
+ = do { thing <- tcLookup id_name
+      ; case thing of
+             ATcId { tct_id = id }
+               -> do { check_naughty id        -- Note [Local record selectors]
+                     ; checkThLocalId id
+                     ; return id }
+
+             AGlobal (AnId id)
+               -> do { check_naughty id; return id }
+                    -- A global cannot possibly be ill-staged
+                    -- nor does it need the 'lifting' treatment
+                    -- hence no checkTh stuff here
+
+             AGlobal (AConLike cl) -> case cl of
+                 RealDataCon con -> return (dataConWrapId con)
+                 PatSynCon ps -> case patSynWrapper ps of
+                     Nothing -> failWithTc (bad_patsyn ps)
+                     Just id -> return id
+
+             other -> failWithTc (bad_lookup other) }
 
+  where
     bad_lookup thing = ppr thing <+> ptext (sLit "used where a value identifer was expected")
 
     bad_patsyn name = ppr name <+>  ptext (sLit "used in an expression, but it's a non-bidirectional pattern synonym")
@@ -1099,6 +1119,10 @@ tcInferIdWithOrig orig id_name
       | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel id)
       | otherwise                  = return ()
 
+srcSpanPrimLit :: DynFlags -> SrcSpan -> HsExpr TcId
+srcSpanPrimLit dflags span
+    = HsLit (HsStringPrim (unsafeMkByteString (showSDocOneLine dflags (ppr span))))
+
 ------------------------
 instantiateOuter :: CtOrigin -> TcId -> TcM (HsExpr TcId, TcSigmaType)
 -- Do just the first level of instantiation of an Id
@@ -1123,6 +1147,14 @@ instantiateOuter orig id
     (tvs, theta, tau) = tcSplitSigmaTy (idType id)
 \end{code}
 
+Note [Adding the implicit parameter to 'assert']
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The typechecker transforms (assert e1 e2) to (assertError "Foo.hs:27"
+e1 e2).  This isn't really the Right Thing because there's no way to
+"undo" if you want to see the original source code in the typechecker
+output.  We'll have fix this in due course, when we care more about
+being able to reconstruct the exact original program.
+
 Note [Multiple instantiation]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We are careful never to make a MethodInst that has, as its meth_id, another MethodInst.
diff --git a/testsuite/tests/typecheck/should_fail/T9774.hs b/testsuite/tests/typecheck/should_fail/T9774.hs
new file mode 100644
index 0000000000..48df575b44
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T9774.hs
@@ -0,0 +1,5 @@
+module T9774 where
+
+import Control.Exception
+
+foo = putStrLn (assert True 'a')
diff --git a/testsuite/tests/typecheck/should_fail/T9774.stderr b/testsuite/tests/typecheck/should_fail/T9774.stderr
new file mode 100644
index 0000000000..d75942bc59
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T9774.stderr
@@ -0,0 +1,8 @@
+
+T9774.hs:5:29:
+    Couldn't match type ‘Char’ with ‘[Char]’
+    Expected type: String
+      Actual type: Char
+    In the second argument of ‘assert’, namely ‘'a'’
+    In the first argument of ‘putStrLn’, namely ‘(assert True 'a')’
+    In the expression: putStrLn (assert True 'a')
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index e9dd2890bf..f30bbb2481 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -342,3 +342,4 @@ test('T9415', normal, compile_fail, [''])
 test('T9612', normal, compile_fail, [''])
 test('T9634', normal, compile_fail, [''])
 test('T9739', normal, compile_fail, [''])
+test('T9774', normal, compile_fail, [''])