Fix Trac #3966: warn about useless UNPACK pragmas

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

diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index 51d6f4b..d7118e1 100644 (file)
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -12,7 +12,9 @@
 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
 -- for details
 
 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
 -- for details
 

-module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC, tcInferRho, tcInferRhoNC, tcSyntaxOp, addExprErrCtxt ) where
+module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC, 
+                tcInferRho, tcInferRhoNC, tcSyntaxOp, 
+                addExprErrCtxt ) where

 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 

@@ -245,41 +247,73 @@ 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
 -- 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] 
   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
     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] 
   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"
     tc_args arg1_ty' _ _ _ = panic "tcExpr SectionR"

+
+-- 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 in_expr@(ExplicitTuple tup_args boxity) res_ty
+  = do { let kind = case boxity of { Boxed   -> liftedTypeKind
+                                   ; Unboxed -> argTypeKind }
+             arity = length tup_args
+             tup_tc = tupleTyCon boxity arity
+             mk_tup_res_ty arg_tys 
+                 = mkFunTys [ty | (ty, Missing _) <- arg_tys `zip` tup_args]
+                            (mkTyConApp tup_tc arg_tys)
+
+       ; checkWiredInTyCon tup_tc       -- Ensure instances are available
+       ; tvs <- newBoxyTyVars (replicate arity kind)
+       ; let arg_tys1 = map mkTyVarTy tvs
+       ; arg_tys2 <- preSubType tvs (mkVarSet tvs) (mk_tup_res_ty arg_tys1) res_ty
+       
+       ; let go (Missing _,    arg_ty) = return (Missing arg_ty)
+             go (Present expr, arg_ty) = do { expr' <- tcPolyExpr expr arg_ty
+                                           ; return (Present expr') }
+       ; tup_args' <- mapM go (tup_args `zip` arg_tys2)
+       
+       ; arg_tys3 <- mapM refineBox arg_tys2
+       ; co_fn <- tcSubExp TupleOrigin (mk_tup_res_ty arg_tys3) res_ty
+       ; return (mkHsWrap co_fn (ExplicitTuple tup_args' boxity)) }

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

@@ -344,23 +378,6 @@ tcExpr in_expr@(ExplicitPArr _ exprs) res_ty       -- maybe empty
   where
     tc_elt elt_ty expr = tcPolyExpr expr elt_ty
 
   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 { let kind = case boxity of { Boxed   -> liftedTypeKind
-                                   ; Unboxed -> argTypeKind }
-       ; tvs <- newBoxyTyVars [kind | 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    <- tcSubExp TupleOrigin (mkTyConApp tup_tc arg_tys') res_ty
-       ; return (mkHsWrap co_fn (ExplicitTuple exprs' boxity)) }
-

 tcExpr (HsProc pat cmd) res_ty
   = do { (pat', cmd', coi) <- tcProc pat cmd res_ty
        ; return $ mkHsWrapCoI coi (HsProc pat' cmd') }
 tcExpr (HsProc pat cmd) res_ty
   = do { (pat', cmd', coi) <- tcProc pat cmd res_ty
        ; return $ mkHsWrapCoI coi (HsProc pat' cmd') }

@@ -408,16 +425,20 @@ Note [Type of a record update]
 The main complication with RecordUpd is that we need to explicitly
 handle the *non-updated* fields.  Consider:
 
 The main complication with RecordUpd is that we need to explicitly
 handle the *non-updated* fields.  Consider:
 

-       data T a b = MkT1 { fa :: a, fb :: b }
-                  | MkT2 { fa :: a, fc :: Int -> Int }
-                  | MkT3 { fd :: a }
+       data T a b c = MkT1 { fa :: a, fb :: (b,c) }
+                    | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c }
+                    | MkT3 { fd :: a }

        
        

-       upd :: T a b -> c -> T a c
+       upd :: T a b c -> (b',c) -> T a b' c

        upd t x = t { fb = x}
 
        upd t x = t { fb = x}
 

-The type signature on upd is correct (i.e. the result should not be (T a b))
-because upd should be equivalent to:
+The result type should be (T a b' c)
+not (T a b c),   because 'b' *is not* mentioned in a non-updated field
+not (T a b' c'), becuase 'c' *is*     mentioned in a non-updated field
+NB that it's not good enough to look at just one constructor; we must
+look at them all; cf Trac #3219

 
 

+After all, upd should be equivalent to:

        upd t x = case t of 
                        MkT1 p q -> MkT1 p x
                        MkT2 a b -> MkT2 p b
        upd t x = case t of 
                        MkT1 p q -> MkT1 p x
                        MkT2 a b -> MkT2 p b

@@ -425,9 +446,11 @@ because upd should be equivalent to:
 
 So we need to give a completely fresh type to the result record,
 and then constrain it by the fields that are *not* updated ("p" above).
 
 So we need to give a completely fresh type to the result record,
 and then constrain it by the fields that are *not* updated ("p" above).

+We call these the "fixed" type variables, and compute them in getFixedTyVars.

 
 Note that because MkT3 doesn't contain all the fields being updated,
 
 Note that because MkT3 doesn't contain all the fields being updated,

-its RHS is simply an error, so it doesn't impose any type constraints
+its RHS is simply an error, so it doesn't impose any type constraints.
+Hence the use of 'relevant_cont'.

 
 Note [Implict type sharing]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 Note [Implict type sharing]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -451,12 +474,22 @@ field isn't part of the existential. For example, this should be ok.
   data T a where { MkT { f1::a, f2::b->b } :: T a }
   f :: T a -> b -> T b
   f t b = t { f1=b }
   data T a where { MkT { f1::a, f2::b->b } :: T a }
   f :: T a -> b -> T b
   f t b = t { f1=b }

+

 The criterion we use is this:
 
   The types of the updated fields
   mention only the universally-quantified type variables
   of the data constructor
 
 The criterion we use is this:
 
   The types of the updated fields
   mention only the universally-quantified type variables
   of the data constructor
 

+NB: this is not (quite) the same as being a "naughty" record selector
+(See Note [Naughty record selectors]) in TcTyClsDecls), at least 
+in the case of GADTs. Consider
+   data T a where { MkT :: { f :: a } :: T [a] }
+Then f is not "naughty" because it has a well-typed record selector.
+But we don't allow updates for 'f'.  (One could consider trying to
+allow this, but it makes my head hurt.  Badly.  And no one has asked
+for it.)
+

 In principle one could go further, and allow
   g :: T a -> T a
   g t = t { f2 = \x -> x }
 In principle one could go further, and allow
   g :: T a -> T a
   g t = t { f2 = \x -> x }

@@ -490,11 +523,10 @@ In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys):
        
 \begin{code}
 tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty
        
 \begin{code}
 tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty

-  = do {
+  = ASSERT( notNull upd_fld_names )
+    do {

        -- STEP 0
        -- Check that the field names are really field names
        -- STEP 0
        -- Check that the field names are really field names

-         let upd_fld_names = hsRecFields rbinds
-       ; MASSERT( notNull upd_fld_names )

        ; sel_ids <- mapM tcLookupField upd_fld_names
                        -- The renamer has already checked that
                        -- selectors are all in scope
        ; sel_ids <- mapM tcLookupField upd_fld_names
                        -- The renamer has already checked that
                        -- selectors are all in scope

@@ -524,7 +556,7 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty
              con1_flds = dataConFieldLabels con1
              con1_res_ty = mkFamilyTyConApp tycon (mkTyVarTys con1_tvs)
              
              con1_flds = dataConFieldLabels con1
              con1_res_ty = mkFamilyTyConApp tycon (mkTyVarTys con1_tvs)
              

-       -- STEP 2
+       -- Step 2

        -- Check that at least one constructor has all the named fields
        -- i.e. has an empty set of bad fields returned by badFields
        ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds)
        -- Check that at least one constructor has all the named fields
        -- i.e. has an empty set of bad fields returned by badFields
        ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds)

@@ -532,11 +564,11 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty
        -- STEP 3    Note [Criteria for update]
        -- Check that each updated field is polymorphic; that is, its type
        -- mentions only the universally-quantified variables of the data con
        -- STEP 3    Note [Criteria for update]
        -- Check that each updated field is polymorphic; that is, its type
        -- mentions only the universally-quantified variables of the data con

-       ; let flds_w_tys = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys
-             (upd_flds_w_tys, fixed_flds_w_tys) = partition is_updated flds_w_tys
+       ; let flds1_w_tys = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys
+             (upd_flds1_w_tys, fixed_flds1_w_tys) = partition is_updated flds1_w_tys

              is_updated (fld,ty) = fld `elem` upd_fld_names
 
              is_updated (fld,ty) = fld `elem` upd_fld_names
 

-             bad_upd_flds = filter bad_fld upd_flds_w_tys
+             bad_upd_flds = filter bad_fld upd_flds1_w_tys

              con1_tv_set = mkVarSet con1_tvs
              bad_fld (fld, ty) = fld `elem` upd_fld_names &&
                                      not (tyVarsOfType ty `subVarSet` con1_tv_set)
              con1_tv_set = mkVarSet con1_tvs
              bad_fld (fld, ty) = fld `elem` upd_fld_names &&
                                      not (tyVarsOfType ty `subVarSet` con1_tv_set)

@@ -546,14 +578,14 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty
        -- Figure out types for the scrutinee and result
        -- Both are of form (T a b c), with fresh type variables, but with
        -- common variables where the scrutinee and result must have the same type
        -- Figure out types for the scrutinee and result
        -- Both are of form (T a b c), with fresh type variables, but with
        -- common variables where the scrutinee and result must have the same type

-       -- These are variables that appear anywhere *except* in the updated fields
-       ; let common_tvs = exactTyVarsOfTypes (map snd fixed_flds_w_tys)
-                          `unionVarSet` constrainedTyVars con1_tvs relevant_cons
-             is_common_tv tv = tv `elemVarSet` common_tvs
-
+       -- These are variables that appear in *any* arg of *any* of the
+       -- relevant constructors *except* in the updated fields
+       -- 
+       ; let fixed_tvs = getFixedTyVars con1_tvs relevant_cons
+             is_fixed_tv tv = tv `elemVarSet` fixed_tvs

              mk_inst_ty tv result_inst_ty 
              mk_inst_ty tv result_inst_ty 

-               | is_common_tv tv = return result_inst_ty           -- Same as result type
-               | otherwise       = newFlexiTyVarTy (tyVarKind tv)  -- Fresh type, of correct kind
+               | is_fixed_tv tv = return result_inst_ty            -- Same as result type
+               | otherwise      = newFlexiTyVarTy (tyVarKind tv)  -- Fresh type, of correct kind

 
        ; (_, result_inst_tys, result_inst_env) <- tcInstTyVars con1_tvs
        ; scrut_inst_tys <- zipWithM mk_inst_ty con1_tvs result_inst_tys
 
        ; (_, result_inst_tys, result_inst_env) <- tcInstTyVars con1_tvs
        ; scrut_inst_tys <- zipWithM mk_inst_ty con1_tvs result_inst_tys

@@ -585,17 +617,26 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty
        ; return (mkHsWrap co_fn (RecordUpd (mkLHsWrap scrut_co record_expr') rbinds'
                                        relevant_cons scrut_inst_tys result_inst_tys)) }
   where
        ; return (mkHsWrap co_fn (RecordUpd (mkLHsWrap scrut_co record_expr') rbinds'
                                        relevant_cons scrut_inst_tys result_inst_tys)) }
   where

-    constrainedTyVars :: [TyVar] -> [DataCon] -> TyVarSet
-    -- Universally-quantified tyvars that appear in any of the 
-    -- *implicit* arguments to the constructor
+    upd_fld_names = hsRecFields rbinds
+
+    getFixedTyVars :: [TyVar] -> [DataCon] -> TyVarSet

     -- These tyvars must not change across the updates
     -- These tyvars must not change across the updates

-    -- See Note [Implict type sharing]
-    constrainedTyVars tvs1 cons
+    getFixedTyVars tvs1 cons

       = mkVarSet [tv1 | con <- cons
       = mkVarSet [tv1 | con <- cons

-                     , let (tvs, theta, _, _) = dataConSig con
-                           bad_tvs = tyVarsOfTheta theta
+                     , let (tvs, theta, arg_tys, _) = dataConSig con
+                           flds = dataConFieldLabels con
+                           fixed_tvs = exactTyVarsOfTypes fixed_tys
+                                   -- fixed_tys: See Note [Type of a record update]
+                                       `unionVarSet` tyVarsOfTheta theta 
+                                   -- Universally-quantified tyvars that
+                                   -- appear in any of the *implicit*
+                                   -- arguments to the constructor are fixed
+                                   -- See Note [Implict type sharing]
+                                       
+                           fixed_tys = [ty | (fld,ty) <- zip flds arg_tys
+                                            , not (fld `elem` upd_fld_names)]

                       , (tv1,tv) <- tvs1 `zip` tvs     -- Discards existentials in tvs
                       , (tv1,tv) <- tvs1 `zip` tvs     -- Discards existentials in tvs

-                     , tv `elemVarSet` bad_tvs ]
+                     , tv `elemVarSet` fixed_tvs ]

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -809,12 +850,12 @@ tcId :: InstOrigin
      -> BoxyRhoType                            -- Result type
      -> TcM (HsExpr TcId)
 tcId orig fun_name res_ty
      -> 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
        -- 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
 
              tau_qtvs = exactTyVarsOfType fun_tau      -- Mentioned in the tau part
        ; qtv_tys <- preSubType qtvs tau_qtvs fun_tau res_ty
 

@@ -822,6 +863,8 @@ tcId orig fun_name res_ty
        ; let res_subst = zipTopTvSubst qtvs qtv_tys
              fun_tau'  = substTy res_subst fun_tau
 
        ; 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
        ; co_fn <- tcSubExp orig fun_tau' res_ty
 
        -- And pack up the results

@@ -856,9 +899,10 @@ tcId orig fun_name res_ty
 tcSyntaxOp :: InstOrigin -> HsExpr Name -> TcType -> TcM (HsExpr TcId)
 -- Typecheck a syntax operator, checking that it has the specified type
 -- The operator is always a variable at this stage (i.e. renamer output)
 tcSyntaxOp :: InstOrigin -> HsExpr Name -> TcType -> TcM (HsExpr TcId)
 -- Typecheck a syntax operator, checking that it has the specified type
 -- The operator is always a variable at this stage (i.e. renamer output)

+-- This version assumes ty is a monotype

 tcSyntaxOp orig (HsVar op) ty = tcId orig op ty
 tcSyntaxOp orig (HsVar op) ty = tcId orig op ty

-tcSyntaxOp orig other     ty = pprPanic "tcSyntaxOp" (ppr other)
-
+tcSyntaxOp orig other     ty = pprPanic "tcSyntaxOp" (ppr other) 
+                        

 ---------------------------
 instFun :: InstOrigin
        -> HsExpr TcId
 ---------------------------
 instFun :: InstOrigin
        -> HsExpr TcId

@@ -972,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)
 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
 
 tcArgs fun args qtvs qtys arg_tys
   = go 1 qtys args arg_tys

@@ -1069,6 +1113,9 @@ lookupFun orig id_name
                -- nor does it need the 'lifting' treatment
 
            ATcId { tct_id = id, tct_type = ty, tct_co = mb_co, tct_level = lvl }
                -- nor does it need the 'lifting' treatment
 
            ATcId { tct_id = id, tct_type = ty, tct_co = mb_co, tct_level = lvl }

+               | isNaughtyRecordSelector id -> failWithTc (naughtyRecordSel id)
+                                         -- Note [Local record selectors]
+               | otherwise

                -> do { thLocalId orig id ty lvl
                      ; case mb_co of
                          Unrefineable    -> return (HsVar id, ty)
                -> do { thLocalId orig id ty lvl
                      ; case mb_co of
                          Unrefineable    -> return (HsVar id, ty)

@@ -1082,22 +1129,31 @@ lookupFun orig id_name
 
 #ifndef GHCI  /* GHCI and TH is off */
 --------------------------------------
 
 #ifndef GHCI  /* GHCI and TH is off */
 --------------------------------------

--- thLocalId : Check for cross-stage lifting
-thLocalId orig id id_ty th_bind_lvl
+thLocalId :: InstOrigin -> Id -> TcType -> ThLevel -> TcM ()
+-- Check for cross-stage lifting
+thLocalId orig id id_ty bind_lvl

   = return ()
 
 #else        /* GHCI and TH is on */
   = return ()
 
 #else        /* GHCI and TH is on */

-thLocalId orig id id_ty th_bind_lvl 
+thLocalId orig id id_ty bind_lvl 

   = do { use_stage <- getStage -- TH case
   = do { use_stage <- getStage -- TH case

-       ; case use_stage of
-           Brack use_lvl ps_var lie_var | use_lvl > th_bind_lvl
-                 -> thBrackId orig id ps_var lie_var
-           other -> do { checkWellStaged (quotes (ppr id)) th_bind_lvl use_stage
-                       ; return id }
-       }
+       ; let use_lvl = thLevel use_stage
+       ; checkWellStaged (quotes (ppr id)) bind_lvl use_lvl
+       ; traceTc (text "thLocalId" <+> ppr id <+> ppr bind_lvl <+> ppr use_stage <+> ppr use_lvl)
+       ; when (use_lvl > bind_lvl) $
+          checkCrossStageLifting orig id id_ty bind_lvl use_stage }

 
 --------------------------------------
 
 --------------------------------------

-thBrackId orig id ps_var lie_var
+checkCrossStageLifting :: InstOrigin -> Id -> TcType -> ThLevel -> ThStage -> TcM ()
+-- We are inside brackets, and (use_lvl > bind_lvl)
+-- Now we must check whether there's a cross-stage lift to do
+-- Examples   \x -> [| x |]  
+--            [| map |]
+
+checkCrossStageLifting _ _ _ _ Comp   = return ()
+checkCrossStageLifting _ _ _ _ Splice = return ()
+
+checkCrossStageLifting orig id id_ty bind_lvl (Brack _ ps_var lie_var) 

   | thTopLevelId id
   =    -- Top-level identifiers in this module,
        -- (which have External Names)
   | thTopLevelId id
   =    -- Top-level identifiers in this module,
        -- (which have External Names)

@@ -1109,9 +1165,10 @@ thBrackId orig id ps_var lie_var
        -- But we do need to put f into the keep-alive
        -- set, because after desugaring the code will
        -- only mention f's *name*, not f itself.
        -- But we do need to put f into the keep-alive
        -- set, because after desugaring the code will
        -- only mention f's *name*, not f itself.

-    do { keepAliveTc id; return id }
+    keepAliveTc id

 
 

-  | otherwise
+  | otherwise  -- bind_lvl = outerLevel presumably,
+               -- but the Id is not bound at top level

   =    -- Nested identifiers, such as 'x' in
        -- E.g. \x -> [| h x |]
        -- We must behave as if the reference to x was
   =    -- Nested identifiers, such as 'x' in
        -- E.g. \x -> [| h x |]
        -- We must behave as if the reference to x was

@@ -1121,8 +1178,7 @@ thBrackId orig id ps_var lie_var
        -- If 'x' occurs many times we may get many identical
        -- bindings of the same splice proxy, but that doesn't
        -- matter, although it's a mite untidy.
        -- If 'x' occurs many times we may get many identical
        -- bindings of the same splice proxy, but that doesn't
        -- matter, although it's a mite untidy.

-    do         { let id_ty = idType id
-       ; checkTc (isTauTy id_ty) (polySpliceErr id)
+    do         { checkTc (isTauTy id_ty) (polySpliceErr id)

               -- If x is polymorphic, its occurrence sites might
               -- have different instantiations, so we can't use plain
               -- 'x' as the splice proxy name.  I don't know how to 
               -- If x is polymorphic, its occurrence sites might
               -- have different instantiations, so we can't use plain
               -- 'x' as the splice proxy name.  I don't know how to 

@@ -1135,18 +1191,39 @@ thBrackId orig id ps_var lie_var
                -- so we zap it to a LiftedTypeKind monotype
                -- C.f. the call in TcPat.newLitInst
 
                -- so we zap it to a LiftedTypeKind monotype
                -- C.f. the call in TcPat.newLitInst
 

-       ; setLIEVar lie_var     $ do
-       { lift <- newMethodFromName orig id_ty' DsMeta.liftName
-                  -- Put the 'lift' constraint into the right LIE
+       ; lift <- if isStringTy id_ty' then
+                    tcLookupId DsMeta.liftStringName
+                    -- See Note [Lifting strings]
+                 else
+                     setLIEVar lie_var $ do  -- Put the 'lift' constraint into the right LIE
+                     newMethodFromName orig id_ty' DsMeta.liftName

           
                   -- Update the pending splices
        ; ps <- readMutVar ps_var
        ; writeMutVar ps_var ((idName id, nlHsApp (nlHsVar lift) (nlHsVar id)) : ps)
 
           
                   -- Update the pending splices
        ; ps <- readMutVar ps_var
        ; writeMutVar ps_var ((idName id, nlHsApp (nlHsVar lift) (nlHsVar id)) : ps)
 

-       ; return id } }
+       ; return () }

 #endif /* GHCI */
 \end{code}
 
 #endif /* GHCI */
 \end{code}
 

+Note [Lifting strings]
+~~~~~~~~~~~~~~~~~~~~~~
+If we see $(... [| s |] ...) where s::String, we don't want to
+generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc.
+So this conditional short-circuits the lifting mechanism to generate
+(liftString "xy") in that case.  I didn't want to use overlapping instances
+for the Lift class in TH.Syntax, because that can lead to overlapping-instance
+errors in a polymorphic situation.  
+
+If this check fails (which isn't impossible) we get another chance; see
+Note [Converting strings] in Convert.lhs 
+
+Local record selectors
+~~~~~~~~~~~~~~~~~~~~~~
+Record selectors for TyCons in this module are ordinary local bindings,
+which show up as ATcIds rather than AGlobals.  So we need to check for
+naughtiness in both branches.  c.f. TcTyClsBindings.mkAuxBinds.
+

 
 %************************************************************************
 %*                                                                     *
 
 %************************************************************************
 %*                                                                     *

@@ -1203,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
 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
        -- Illegal if any arg is strict
        addErrTc (missingStrictFields data_con [])
     else

@@ -1220,12 +1297,12 @@ checkMissingFields data_con rbinds
   where
     missing_s_fields
        = [ fl | (fl, str) <- field_info,
   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 (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)
          ]
 
                 not (fl `elem` field_names_used)
          ]