X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcExpr.lhs;h=d7118e1f816bc84c29ad472aae75a97531cdf1e0;hp=4ccd89c3a4f7eef91ad476c00d48c2be4eb3501b;hb=215ce9f15215399ce30ae55c9521087847d78646;hpb=1e436f2bb208a6c990743afaf17b7c2a93c31742

diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index 4ccd89c..d7118e1 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -247,40 +247,45 @@ tcExpr in_expr@(OpApp arg1 lop@(L loc op) fix arg2) res_ty
 -- but it's less work and kind of useful.
 
 tcExpr in_expr@(SectionL arg1 lop@(L loc op)) res_ty
-  = do dflags <- getDOpts
-       if dopt Opt_PostfixOperators dflags
-           then do (op', [arg1']) <- tcApp op 1 (tcArgs lop [arg1]) res_ty
-                   return (SectionL arg1' (L loc op'))
-           else do (co_fn, (op', arg1'))
-                       <- subFunTys doc 1 res_ty Nothing
-                        $ \ [arg2_ty'] res_ty' ->
-                              tcApp op 2 (tc_args arg2_ty') res_ty'
-                   return (mkHsWrap co_fn (SectionL arg1' (L loc op')))
+  = do { dflags <- getDOpts
+       ; if dopt Opt_PostfixOperators dflags
+         then do { (op', [arg1']) <- tcApp op 1 (tcArgs lop [arg1]) res_ty
+                 ; return (SectionL arg1' (L loc op')) }
+         else do 
+       { (co_fn, expr')
+             <- subFunTys doc 1 res_ty Nothing $ \ [arg2_ty'] res_ty' ->
+                do { (op', (arg1', co_arg2)) <- tcApp op 2 (tc_args arg2_ty') res_ty'
+		   ; let coi = mkFunTyCoI arg2_ty' co_arg2 res_ty' IdCo
+                   ; return (mkHsWrapCoI coi (SectionL arg1' (L loc op'))) }
+       ; return (mkHsWrap co_fn expr') } }
   where
     doc = ptext (sLit "The section") <+> quotes (ppr in_expr)
 		<+> ptext (sLit "takes one argument")
     tc_args arg2_ty' qtvs qtys [arg1_ty, arg2_ty] 
-	= do { boxyUnify arg2_ty' (substTyWith qtvs qtys arg2_ty)
-	     ; arg1' <- tcArg lop 2 arg1 qtvs qtys arg1_ty 
-	     ; qtys' <- mapM refineBox qtys	-- c.f. tcArgs 
-	     ; return (qtys', arg1') }
+	= do { co_arg2 <- boxyUnify (substTyWith qtvs qtys arg2_ty) arg2_ty' 
+	     ; arg1'   <- tcArg lop 1 arg1 qtvs qtys arg1_ty
+	     ; qtys'   <- mapM refineBox qtys	-- c.f. tcArgs 
+	     ; return (qtys', (arg1', co_arg2)) }
     tc_args _ _ _ _ = panic "tcExpr SectionL"
 
 -- Right sections, equivalent to \ x -> x `op` expr, or
 --	\ x -> op x expr
  
 tcExpr in_expr@(SectionR lop@(L loc op) arg2) res_ty
-  = do	{ (co_fn, (op', arg2')) <- subFunTys doc 1 res_ty Nothing $ \ [arg1_ty'] res_ty' ->
-				   tcApp op 2 (tc_args arg1_ty') res_ty'
-	; return (mkHsWrap co_fn (SectionR (L loc op') arg2')) }
+  = do	{ (co_fn, expr') 
+              <- subFunTys doc 1 res_ty Nothing $ \ [arg1_ty'] res_ty' ->
+		 do { (op', (co_arg1, arg2')) <- tcApp op 2 (tc_args arg1_ty') res_ty'
+		    ; let coi = mkFunTyCoI arg1_ty' co_arg1 res_ty' IdCo
+                    ; return (mkHsWrapCoI coi $ SectionR (L loc op') arg2') }
+	; return (mkHsWrap co_fn expr') }
   where
     doc = ptext (sLit "The section") <+> quotes (ppr in_expr)
 		<+> ptext (sLit "takes one argument")
     tc_args arg1_ty' qtvs qtys [arg1_ty, arg2_ty] 
-	= do { boxyUnify arg1_ty' (substTyWith qtvs qtys arg1_ty)
-	     ; arg2' <- tcArg lop 2 arg2 qtvs qtys arg2_ty 
-	     ; qtys' <- mapM refineBox qtys	-- c.f. tcArgs 
-	     ; return (qtys', arg2') }
+	= do { co_arg1 <- boxyUnify (substTyWith qtvs qtys arg1_ty) arg1_ty'
+	     ; arg2'   <- tcArg lop 2 arg2 qtvs qtys arg2_ty 
+	     ; qtys'   <- mapM refineBox qtys	-- c.f. tcArgs 
+	     ; return (qtys', (co_arg1, arg2')) }
     tc_args arg1_ty' _ _ _ = panic "tcExpr SectionR"
 
 -- For tuples, take care to preserve rigidity
@@ -845,12 +850,12 @@ tcId :: InstOrigin
      -> BoxyRhoType				-- Result type
      -> TcM (HsExpr TcId)
 tcId orig fun_name res_ty
-  = do	{ traceTc (text "tcId" <+> ppr fun_name <+> ppr res_ty)
-	; (fun, fun_ty) <- lookupFun orig fun_name
-
+  = do	{ (fun, fun_ty) <- lookupFun orig fun_name
+        ; traceTc (text "tcId" <+> ppr fun_name <+> (ppr fun_ty $$ ppr res_ty))
+	
 	-- Split up the function type
 	; let (tv_theta_prs, fun_tau) = tcMultiSplitSigmaTy fun_ty
-	      qtvs = concatMap fst tv_theta_prs	-- Quantified tyvars
+	      qtvs = concatMap fst tv_theta_prs  	-- Quantified tyvars
 	      tau_qtvs = exactTyVarsOfType fun_tau	-- Mentioned in the tau part
 	; qtv_tys <- preSubType qtvs tau_qtvs fun_tau res_ty
 
@@ -858,6 +863,8 @@ tcId orig fun_name res_ty
 	; let res_subst = zipTopTvSubst qtvs qtv_tys
 	      fun_tau'  = substTy res_subst fun_tau
 
+        ; traceTc (text "tcId2" <+> ppr fun_name <+> (ppr qtvs $$ ppr qtv_tys))
+
 	; co_fn <- tcSubExp orig fun_tau' res_ty
 
 	-- And pack up the results
@@ -1009,7 +1016,7 @@ tcArgs :: LHsExpr Name				-- The function (for error messages)
 type ArgChecker results
    = [TyVar] -> [TcSigmaType] 		-- Current instantiation
    -> [TcSigmaType]			-- Expected arg types (**before** applying the instantiation)
-   -> TcM ([TcSigmaType], results)	-- Resulting instaniation and args
+   -> TcM ([TcSigmaType], results)	-- Resulting instantiation and args
 
 tcArgs fun args qtvs qtys arg_tys
   = go 1 qtys args arg_tys
@@ -1273,7 +1280,7 @@ checkMissingFields :: DataCon -> HsRecordBinds Name -> TcM ()
 checkMissingFields data_con rbinds
   | null field_labels 	-- Not declared as a record;
 			-- But C{} is still valid if no strict fields
-  = if any isMarkedStrict field_strs then
+  = if any isBanged field_strs then
 	-- Illegal if any arg is strict
 	addErrTc (missingStrictFields data_con [])
     else
@@ -1290,12 +1297,12 @@ checkMissingFields data_con rbinds
   where
     missing_s_fields
 	= [ fl | (fl, str) <- field_info,
-	  	 isMarkedStrict str,
+	  	 isBanged str,
 	  	 not (fl `elem` field_names_used)
 	  ]
     missing_ns_fields
 	= [ fl | (fl, str) <- field_info,
-	  	 not (isMarkedStrict str),
+	  	 not (isBanged str),
 	  	 not (fl `elem` field_names_used)
 	  ]