Adding pushing of hpc translation status through hi files.
[ghc-hetmet.git] / compiler / typecheck / TcExpr.lhs
index fa0e419..a3ed96c 100644 (file)
@@ -29,6 +29,7 @@ import TcHsType
 import TcPat
 import TcMType
 import TcType
+import TcIface ( checkWiredInTyCon )
 import Id
 import DataCon
 import Name
@@ -129,6 +130,9 @@ tcExpr (HsPar expr)     res_ty = do { expr' <- tcMonoExpr expr res_ty
 
 tcExpr (HsSCC lbl expr) res_ty = do { expr' <- tcMonoExpr expr res_ty
                                    ; returnM (HsSCC lbl expr') }
+tcExpr (HsTickPragma info expr) res_ty 
+                                      = do { expr' <- tcMonoExpr expr res_ty
+                                   ; returnM (HsTickPragma info expr') }
 
 tcExpr (HsCoreAnn lbl expr) res_ty      -- hdaume: core annotation
   = do { expr' <- tcMonoExpr expr res_ty
@@ -291,10 +295,20 @@ tcExpr in_expr@(ExplicitPArr _ exprs) res_ty      -- maybe empty
   where
     tc_elt elt_ty expr = tcPolyExpr expr elt_ty
 
+-- For tuples, take care to preserve rigidity
+-- E.g.        case (x,y) of ....
+--        The scrutinee should have a rigid type if x,y do
+-- The general scheme is the same as in tcIdApp
 tcExpr (ExplicitTuple exprs boxity) res_ty
-  = do { arg_tys <- boxySplitTyConApp (tupleTyCon boxity (length exprs)) res_ty
-       ; exprs' <-  tcPolyExprs exprs arg_tys
-       ; return (ExplicitTuple exprs' boxity) }
+  = do { tvs <- newBoxyTyVars [argTypeKind | e <- exprs]
+       ; let tup_tc     = tupleTyCon boxity (length exprs)
+             tup_res_ty = mkTyConApp tup_tc (mkTyVarTys tvs)
+       ; checkWiredInTyCon tup_tc      -- Ensure instances are available
+       ; arg_tys  <- preSubType tvs (mkVarSet tvs) tup_res_ty res_ty
+       ; exprs'   <- tcPolyExprs exprs arg_tys
+       ; arg_tys' <- mapM refineBox arg_tys
+       ; co_fn    <- tcFunResTy (tyConName tup_tc) (mkTyConApp tup_tc arg_tys') res_ty
+       ; return (mkHsWrap co_fn (ExplicitTuple exprs' boxity)) }
 
 tcExpr (HsProc pat cmd) res_ty
   = do { (pat', cmd') <- tcProc pat cmd res_ty
@@ -370,20 +384,21 @@ tcExpr expr@(RecordCon (L loc con_name) _ rbinds) res_ty
 -- don't know how to do the update otherwise.
 
 
-tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty
+tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty
   =    -- STEP 0
        -- Check that the field names are really field names
-    ASSERT( notNull rbinds )
     let 
-       field_names = map fst rbinds
+       field_names = hsRecFields rbinds
     in
-    mappM (tcLookupField . unLoc) field_names  `thenM` \ sel_ids ->
+    ASSERT( notNull field_names )
+    mappM tcLookupField field_names    `thenM` \ sel_ids ->
        -- The renamer has already checked that they
        -- are all in scope
     let
        bad_guys = [ setSrcSpan loc $ addErrTc (notSelector field_name) 
-                  | (L loc field_name, sel_id) <- field_names `zip` sel_ids,
-                    not (isRecordSelector sel_id)      -- Excludes class ops
+                  | (fld, sel_id) <- rec_flds rbinds `zip` sel_ids,
+                    not (isRecordSelector sel_id),     -- Excludes class ops
+                    let L loc field_name = hsRecFieldId fld
                   ]
     in
     checkM (null bad_guys) (sequenceM bad_guys `thenM_` failM) `thenM_`
@@ -392,12 +407,13 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty
        -- Figure out the tycon and data cons from the first field name
     let
                -- It's OK to use the non-tc splitters here (for a selector)
-       upd_field_lbls  = recBindFields rbinds
        sel_id : _      = sel_ids
        (tycon, _)      = recordSelectorFieldLabel sel_id       -- We've failed already if
-       data_cons       = tyConDataCons tycon           -- it's not a field label
+       data_cons       = tyConDataCons tycon                   -- it's not a field label
+               -- NB: for a data type family, the tycon is the instance tycon
+
        relevant_cons   = filter is_relevant data_cons
-       is_relevant con = all (`elem` dataConFieldLabels con) upd_field_lbls
+       is_relevant con = all (`elem` dataConFieldLabels con) field_names
     in
 
        -- STEP 2
@@ -420,12 +436,11 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty
     let
                -- A constructor is only relevant to this process if
                -- it contains *all* the fields that are being updated
-       con1            = head relevant_cons    -- A representative constructor
-       con1_tyvars     = dataConUnivTyVars con1 
-       con1_flds       = dataConFieldLabels con1
-       con1_arg_tys    = dataConOrigArgTys con1
-       common_tyvars   = exactTyVarsOfTypes [ty | (fld,ty) <- con1_flds `zip` con1_arg_tys
-                                                , not (fld `elem` upd_field_lbls) ]
+       con1 = ASSERT( not (null relevant_cons) ) head relevant_cons    -- A representative constructor
+       (con1_tyvars, theta, con1_arg_tys, con1_res_ty) = dataConSig con1
+       con1_flds     = dataConFieldLabels con1
+       common_tyvars = exactTyVarsOfTypes [ty | (fld,ty) <- con1_flds `zip` con1_arg_tys
+                                              , not (fld `elem` field_names) ]
 
        is_common_tv tv = tv `elemVarSet` common_tyvars
 
@@ -433,43 +448,48 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty
          | is_common_tv tv = returnM result_inst_ty            -- Same as result type
          | otherwise       = newFlexiTyVarTy (tyVarKind tv)    -- Fresh type, of correct kind
     in
-    tcInstTyVars con1_tyvars                           `thenM` \ (_, result_inst_tys, inst_env) ->
-    zipWithM mk_inst_ty con1_tyvars result_inst_tys    `thenM` \ inst_tys ->
+    ASSERT( null theta )       -- Vanilla datacon
+    tcInstTyVars con1_tyvars                           `thenM` \ (_, result_inst_tys, result_inst_env) ->
+    zipWithM mk_inst_ty con1_tyvars result_inst_tys    `thenM` \ scrut_inst_tys ->
 
-       -- STEP 3
-       -- Typecheck the update bindings.
-       -- (Do this after checking for bad fields in case there's a field that
-       --  doesn't match the constructor.)
+       -- STEP 3: Typecheck the update bindings.
+       -- Do this after checking for bad fields in case 
+       -- there's a field that doesn't match the constructor.
     let
-       result_record_ty = mkTyConApp tycon result_inst_tys
-       con1_arg_tys'    = map (substTy inst_env) con1_arg_tys
+       result_ty     = substTy result_inst_env con1_res_ty
+       con1_arg_tys' = map (substTy result_inst_env) con1_arg_tys
     in
-    tcSubExp result_record_ty res_ty           `thenM` \ co_fn ->
+    tcSubExp result_ty res_ty                  `thenM` \ co_fn ->
     tcRecordBinds con1 con1_arg_tys' rbinds    `thenM` \ rbinds' ->
 
-       -- STEP 5
-       -- Typecheck the expression to be updated
+       -- STEP 5: Typecheck the expression to be updated
     let
-       record_ty = ASSERT( length inst_tys == tyConArity tycon )
-                   mkTyConApp tycon inst_tys
+       scrut_inst_env = zipTopTvSubst con1_tyvars scrut_inst_tys
+       scrut_ty = substTy scrut_inst_env con1_res_ty
        -- This is one place where the isVanilla check is important
-       -- So that inst_tys matches the tycon
+       -- So that inst_tys matches the con1_tyvars
     in
-    tcMonoExpr record_expr record_ty           `thenM` \ record_expr' ->
+    tcMonoExpr record_expr scrut_ty            `thenM` \ record_expr' ->
 
-       -- STEP 6
-       -- Figure out the LIE we need.  We have to generate some 
-       -- dictionaries for the data type context, since we are going to
-       -- do pattern matching over the data cons.
+       -- STEP 6: Figure out the LIE we need.  
+       -- We have to generate some dictionaries for the data type context, 
+       -- since we are going to do pattern matching over the data cons.
        --
-       -- What dictionaries do we need?  The tyConStupidTheta tells us.
+       -- What dictionaries do we need?  The dataConStupidTheta tells us.
     let
-       theta' = substTheta inst_env (tyConStupidTheta tycon)
+       theta' = substTheta scrut_inst_env (dataConStupidTheta con1)
     in
     instStupidTheta RecordUpdOrigin theta'     `thenM_`
 
+       -- Step 7: make a cast for the scrutinee, in the case that it's from a type family
+    let scrut_co | Just co_con <- tyConFamilyCoercion_maybe tycon 
+                = WpCo $ mkTyConApp co_con scrut_inst_tys
+                | otherwise
+                = idHsWrapper
+    in
        -- Phew!
-    returnM (mkHsWrap co_fn (RecordUpd record_expr' rbinds' record_ty result_record_ty))
+    returnM (mkHsWrap co_fn (RecordUpd (mkLHsWrap scrut_co record_expr') rbinds'
+                                      relevant_cons scrut_inst_tys result_inst_tys))
 \end{code}
 
 
@@ -746,7 +766,7 @@ instFun orig fun subst tv_theta_prs
        ; go True fun ty_theta_prs' }
   where
     subst_pr (tvs, theta) 
-       = (map (substTyVar subst) tvs, substTheta subst theta)
+       = (substTyVars subst tvs, substTheta subst theta)
 
     go _ fun [] = return fun
 
@@ -844,6 +864,7 @@ tcArgs fun args qtvs qtys arg_tys
             ; qtys' <- mapM refineBox qtys     -- Exploit new info
             ; (qtys'', args') <- go (n+1) qtys' args arg_tys
             ; return (qtys'', arg':args') }
+    go n qtys args arg_tys = panic "tcArgs"
 
 tcArg :: LHsExpr Name                          -- The function
       -> Int                                   --   and arg number (for error messages)
@@ -909,7 +930,7 @@ tagToEnumError tys
 
 %************************************************************************
 %*                                                                     *
-\subsection{@tcId@ typchecks an identifier occurrence}
+\subsection{@tcId@ typechecks an identifier occurrence}
 %*                                                                     *
 %************************************************************************
 
@@ -1037,18 +1058,18 @@ tcRecordBinds
        -> HsRecordBinds Name
        -> TcM (HsRecordBinds TcId)
 
-tcRecordBinds data_con arg_tys rbinds
+tcRecordBinds data_con arg_tys (HsRecFields rbinds dd)
   = do { mb_binds <- mappM do_bind rbinds
-       ; return (catMaybes mb_binds) }
+       ; return (HsRecFields (catMaybes mb_binds) dd) }
   where
     flds_w_tys = zipEqual "tcRecordBinds" (dataConFieldLabels data_con) arg_tys
-    do_bind (L loc field_lbl, rhs)
+    do_bind fld@(HsRecField { hsRecFieldId = L loc field_lbl, hsRecFieldArg = rhs })
       | Just field_ty <- assocMaybe flds_w_tys field_lbl
       = addErrCtxt (fieldCtxt field_lbl)       $
        do { rhs'   <- tcPolyExprNC rhs field_ty
           ; sel_id <- tcLookupField field_lbl
           ; ASSERT( isRecordSelector sel_id )
-            return (Just (L loc sel_id, rhs')) }
+            return (Just (fld { hsRecFieldId = L loc sel_id, hsRecFieldArg = rhs' })) }
       | otherwise
       = do { addErrTc (badFieldCon data_con field_lbl)
           ; return Nothing }
@@ -1083,7 +1104,7 @@ checkMissingFields data_con rbinds
                 not (fl `elem` field_names_used)
          ]
 
-    field_names_used = recBindFields rbinds
+    field_names_used = hsRecFields rbinds
     field_labels     = dataConFieldLabels data_con
 
     field_info = zipEqual "missingFields"
@@ -1119,12 +1140,13 @@ predCtxt expr
   = hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr)
 
 nonVanillaUpd tycon
-  = vcat [ptext SLIT("Record update for the non-Haskell-98 data type") <+> quotes (ppr tycon)
+  = vcat [ptext SLIT("Record update for the non-Haskell-98 data type") 
+               <+> quotes (pprSourceTyCon tycon)
                <+> ptext SLIT("is not (yet) supported"),
          ptext SLIT("Use pattern-matching instead")]
 badFieldsUpd rbinds
   = hang (ptext SLIT("No constructor has all these fields:"))
-        4 (pprQuotedList (recBindFields rbinds))
+        4 (pprQuotedList (hsRecFields rbinds))
 
 naughtyRecordSel sel_id
   = ptext SLIT("Cannot use record selector") <+> quotes (ppr sel_id) <+> 
@@ -1150,8 +1172,7 @@ missingFields con fields
   = ptext SLIT("Fields of") <+> quotes (ppr con) <+> ptext SLIT("not initialised:") 
        <+> pprWithCommas ppr fields
 
-callCtxt fun args
-  = ptext SLIT("In the call") <+> parens (ppr (foldl mkHsApp fun args))
+-- callCtxt fun args = ptext SLIT("In the call") <+> parens (ppr (foldl mkHsApp fun args))
 
 #ifdef GHCI
 polySpliceErr :: Id -> SDoc