[project @ 2004-09-15 12:06:08 by simonmar]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcExpr.lhs

diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 1714a33..6a3c514 100644 (file)
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -166,8 +166,7 @@ tc_expr in_expr@(ExprWithTySig expr poly_ty) res_ty
  = addErrCtxt (exprCtxt in_expr)                       $
    tcHsSigType ExprSigCtxt poly_ty                     `thenM` \ sig_tc_ty ->
    tcThingWithSig sig_tc_ty (tcCheckRho expr) res_ty   `thenM` \ (co_fn, expr') ->
-   returnM (co_fn <$> unLoc expr')
-       -- ToDo: nasty unLoc
+   returnM (co_fn <$> ExprWithTySigOut expr' poly_ty)
 
 tc_expr (HsType ty) res_ty
   = failWithTc (text "Can't handle type argument:" <+> ppr ty)
@@ -327,6 +326,14 @@ tc_expr (ExplicitTuple exprs boxity) res_ty
 tc_expr (HsProc pat cmd) res_ty
   = tcProc pat cmd res_ty                      `thenM` \ (pat', cmd') ->
     returnM (HsProc pat' cmd')
+
+tc_expr e@(HsArrApp _ _ _ _ _) _
+  = failWithTc (vcat [ptext SLIT("The arrow command"), nest 2 (ppr e), 
+                      ptext SLIT("was found where an expression was expected")])
+
+tc_expr e@(HsArrForm _ _ _) _
+  = failWithTc (vcat [ptext SLIT("The arrow command"), nest 2 (ppr e), 
+                      ptext SLIT("was found where an expression was expected")])
 \end{code}
 
 %************************************************************************
@@ -831,9 +838,9 @@ tcId name   -- Look up the Id and instantiate its type
        -- the type of dataConWrapId (see note on "stupid context" in DataCon.lhs
        -- It's dual to TcPat.tcConstructor
     inst_data_con data_con
-      = tcInstDataCon orig data_con    `thenM` \ (ty_args, ex_dicts, arg_tys, result_ty, _) ->
-       extendLIEs ex_dicts             `thenM_`
-       getSrcSpanM                     `thenM` \ loc ->
+      = tcInstDataCon orig VanillaTv data_con  `thenM` \ (ty_args, ex_dicts, arg_tys, result_ty, _) ->
+       extendLIEs ex_dicts                     `thenM_`
+       getSrcSpanM                             `thenM` \ loc ->
        returnM (unLoc (mkHsDictApp (mkHsTyApp (L loc (HsVar (dataConWrapId data_con))) ty_args) 
                             (map instToId ex_dicts)), 
                 mkFunTys arg_tys result_ty)