[commit: ghc] wip/type-app: Checkpoint in more undoing. (6161d23)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/type-app
Link       : http://ghc.haskell.org/trac/ghc/changeset/6161d237e0527853f51f8f693d23ccba8bbd5dce/ghc

>---------------------------------------------------------------

commit 6161d237e0527853f51f8f693d23ccba8bbd5dce
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date:   Tue Jul 7 23:39:03 2015 -0400

    Checkpoint in more undoing.


>---------------------------------------------------------------

6161d237e0527853f51f8f693d23ccba8bbd5dce
 compiler/typecheck/TcArrows.hs    | 14 +++++++-------
 compiler/typecheck/TcExpr.hs      | 21 ++++++++++++++++++---
 compiler/typecheck/TcExpr.hs-boot |  6 +++---
 3 files changed, 28 insertions(+), 13 deletions(-)

diff --git a/compiler/typecheck/TcArrows.hs b/compiler/typecheck/TcArrows.hs
index 4e89ed5..c92a6ef 100644
--- a/compiler/typecheck/TcArrows.hs
+++ b/compiler/typecheck/TcArrows.hs
@@ -9,7 +9,7 @@ Typecheck arrow notation
 
 module TcArrows ( tcProc ) where
 
-import {-# SOURCE #-}   TcExpr( tcPolyExpr, tcInferSigma, tcSyntaxOp, tcCheckId, tcPolyExpr )
+import {-# SOURCE #-}   TcExpr( tcMonoExpr, tcInferSigma, tcSyntaxOp, tcCheckId, tcPolyExpr )
 
 import HsSyn
 import TcMatches
@@ -80,7 +80,7 @@ Note that
 
 tcProc :: InPat Name -> LHsCmdTop Name          -- proc pat -> expr
        -> TcRhoType                             -- Expected type of whole proc expression
-       -> TcM (OutPat TcId, LHsCmdTop TcId, HsWrapper)
+       -> TcM (OutPat TcId, LHsCmdTop TcId, TcCoercion)
 
 tcProc pat cmd exp_ty
   = newArrowScope $
@@ -153,7 +153,7 @@ tc_cmd env in_cmd@(HsCmdCase scrut matches) (stk, res_ty)
     mc_body body res_ty' = tcCmd env body (stk, res_ty')
 
 tc_cmd env (HsCmdIf Nothing pred b1 b2) res_ty    -- Ordinary 'if'
-  = do  { pred' <- tcPolyExpr pred boolTy
+  = do  { pred' <- tcMonoExpr pred boolTy
         ; b1'   <- tcCmd env b1 res_ty
         ; b2'   <- tcCmd env b2 res_ty
         ; return (HsCmdIf Nothing pred' b1' b2')
@@ -170,7 +170,7 @@ tc_cmd env (HsCmdIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if
         ; checkTc (not (r_tv `elemVarSet` tyVarsOfType pred_ty))
                   (ptext (sLit "Predicate type of `ifThenElse' depends on result type"))
         ; fun'  <- tcSyntaxOp IfOrigin fun if_ty
-        ; pred' <- tcPolyExpr pred pred_ty
+        ; pred' <- tcMonoExpr pred pred_ty
         ; b1'   <- tcCmd env b1 res_ty
         ; b2'   <- tcCmd env b2 res_ty
         ; return (HsCmdIf (Just fun') pred' b1' b2')
@@ -196,9 +196,9 @@ tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (_, res_ty)
   = addErrCtxt (cmdCtxt cmd)    $
     do  { arg_ty <- newFlexiTyVarTy openTypeKind
         ; let fun_ty = mkCmdArrTy env arg_ty res_ty
-        ; fun' <- select_arrow_scope (tcPolyExpr fun fun_ty)
+        ; fun' <- select_arrow_scope (tcMonoExpr fun fun_ty)
 
-        ; arg' <- tcPolyExpr arg arg_ty
+        ; arg' <- tcMonoExpr arg arg_ty
 
         ; return (HsCmdArrApp fun' arg' fun_ty ho_app lr) }
   where
@@ -223,7 +223,7 @@ tc_cmd env cmd@(HsCmdApp fun arg) (cmd_stk, res_ty)
   = addErrCtxt (cmdCtxt cmd)    $
     do  { arg_ty <- newFlexiTyVarTy openTypeKind
         ; fun'   <- tcCmd env fun (mkPairTy arg_ty cmd_stk, res_ty)
-        ; arg'   <- tcPolyExpr arg arg_ty
+        ; arg'   <- tcMonoExpr arg arg_ty
         ; return (HsCmdApp fun' arg') }
 
 -------------------------------------------
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index 6103388..3040e42 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -8,8 +8,8 @@ c%
 
 {-# LANGUAGE CPP #-}
 
-module TcExpr ( tcPolyExpr, tcPolyExprNC,
-                tcInferSigma, tcInferSigmaNC,
+module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC,
+                tcInferSigma, tcInferSigmaNC, tcInferRho, tcInferRhoNC,
                 tcSyntaxOp, tcCheckId,
                 addExprErrCtxt, tcSkolemiseExpr ) where
 
@@ -92,6 +92,21 @@ tcPolyExprNC (L loc expr) res_ty
                   tcExpr expr res_ty
        ; return (L loc expr') }
 
+tcMonoExpr, tcMonoExprNC
+         :: LHsExpr Name        -- Expression to type check
+         -> TcRhoType           -- Expected type (must not be a polytype)
+         -> TcM (LHsExpr TcId)  -- Generalised expr with expected type
+
+tcMonoExpr expr res_ty
+  = addExprErrCtxt expr $
+    do { traceTc "tcMonoExpr" (ppr res_ty); tcMonoExprNC expr res_ty }
+
+tcMonoExprNC (L loc expr) res_ty
+  = setSrcSpan loc $
+    do { traceTc "tcPolyExprNC" (ppr res_ty)
+       ; expr' <- tcExpr expr res_ty
+       ; return (L loc expr') }
+
 ---------------
 tcInferSigma, tcInferSigmaNC :: LHsExpr Name -> TcM (LHsExpr TcId, TcSigmaType)
 -- Infer a *sigma*-type.
@@ -460,7 +475,7 @@ tcExpr (HsDo do_or_lc stmts _) res_ty
 
 tcExpr (HsProc pat cmd) res_ty
   = do  { (pat', cmd', coi) <- tcProc pat cmd res_ty
-        ; return $ mkHsWrap coi (HsProc pat' cmd') }
+        ; return $ mkHsWrapCo coi (HsProc pat' cmd') }
 
 tcExpr (HsStatic expr) res_ty
   = do  { staticPtrTyCon  <- tcLookupTyCon staticPtrTyConName
diff --git a/compiler/typecheck/TcExpr.hs-boot b/compiler/typecheck/TcExpr.hs-boot
index 944ac4f..7f335b6 100644
--- a/compiler/typecheck/TcExpr.hs-boot
+++ b/compiler/typecheck/TcExpr.hs-boot
@@ -1,12 +1,12 @@
 module TcExpr where
 import HsSyn    ( HsExpr, LHsExpr )
 import Name     ( Name )
-import TcType   ( TcType, TcSigmaType )
+import TcType   ( TcType, TcRhoType )
 import TcRnTypes( TcM, TcId, CtOrigin )
 
-tcPolyExpr, tcPolyExprNC ::
+tcMonoExpr, tcMonoExprNC ::
           LHsExpr Name
-       -> TcSigmaType
+       -> TcRhoType
        -> TcM (LHsExpr TcId)
 
 tcInferSigma, tcInferSigmaNC ::