Generate Typeable info at definition sites
[ghc.git] / compiler / typecheck / TcHsSyn.hs
index 45f384a..ddf9c4f 100644 (file)
@@ -45,7 +45,6 @@ import TysWiredIn
 import Type
 import ConLike
 import DataCon
-import PatSyn( patSynInstResTy )
 import Name
 import NameSet
 import Var
@@ -90,7 +89,7 @@ hsPatType (ViewPat _ _ ty)            = ty
 hsPatType (ListPat _ ty Nothing)      = mkListTy ty
 hsPatType (ListPat _ _ (Just (ty,_))) = ty
 hsPatType (PArrPat _ ty)              = mkPArrTy ty
-hsPatType (TuplePat _ bx tys)         = mkTupleTy (boxityNormalTupleSort bx) tys
+hsPatType (TuplePat _ bx tys)         = mkTupleTy bx tys
 hsPatType (ConPatOut { pat_con = L _ con, pat_arg_tys = tys })
                                       = conLikeResTy con tys
 hsPatType (SigPatOut _ ty)            = ty
@@ -99,9 +98,6 @@ hsPatType (NPlusKPat id _ _ _)        = idType (unLoc id)
 hsPatType (CoPat _ _ ty)              = ty
 hsPatType p                           = pprPanic "hsPatType" (ppr p)
 
-conLikeResTy :: ConLike -> [Type] -> Type
-conLikeResTy (RealDataCon con) tys = mkTyConApp (dataConTyCon con) tys
-conLikeResTy (PatSynCon ps)    tys = patSynInstResTy ps tys
 
 hsLitType :: HsLit -> TcType
 hsLitType (HsChar _ _)       = charTy
@@ -259,6 +255,9 @@ zonkIdBndrs env ids = mapM (zonkIdBndr env) ids
 zonkTopBndrs :: [TcId] -> TcM [Id]
 zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids
 
+zonkFieldOcc :: ZonkEnv -> FieldOcc TcId -> TcM (FieldOcc Id)
+zonkFieldOcc env (FieldOcc lbl sel) = fmap (FieldOcc lbl) $ zonkIdBndr env sel
+
 zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var])
 zonkEvBndrsX = mapAccumLM zonkEvBndrX
 
@@ -299,8 +298,8 @@ zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id)
 zonkTopLExpr e = zonkLExpr emptyZonkEnv e
 
 zonkTopDecls :: Bag EvBind
-             -> LHsBinds TcId 
-             -> Maybe (Located [LIE RdrName]) 
+             -> LHsBinds TcId
+             -> Maybe (Located [LIE RdrName])
              -> NameSet
              -> [LRuleDecl TcId] -> [LVectDecl TcId] -> [LTcSpecPrag] -> [LForeignDecl TcId]
              -> TcM ([Id],
@@ -710,12 +709,14 @@ zonkExpr env (RecordCon data_con con_expr rbinds)
         ; new_rbinds   <- zonkRecFields env rbinds
         ; return (RecordCon data_con new_con_expr new_rbinds) }
 
-zonkExpr env (RecordUpd expr rbinds cons in_tys out_tys)
+zonkExpr env (RecordUpd expr rbinds cons in_tys out_tys req_wrap)
   = do  { new_expr    <- zonkLExpr env expr
         ; new_in_tys  <- mapM (zonkTcTypeToType env) in_tys
         ; new_out_tys <- mapM (zonkTcTypeToType env) out_tys
-        ; new_rbinds  <- zonkRecFields env rbinds
-        ; return (RecordUpd new_expr new_rbinds cons new_in_tys new_out_tys) }
+        ; new_rbinds  <- zonkRecUpdFields env rbinds
+        ; (_, new_recwrap) <- zonkCoFn env req_wrap
+        ; return (RecordUpd new_expr new_rbinds cons new_in_tys new_out_tys
+                              new_recwrap) }
 
 zonkExpr env (ExprWithTySigOut e ty)
   = do { e' <- zonkLExpr env e
@@ -953,10 +954,10 @@ zonkStmt env zBody (BodyStmt body then_op guard_op ty)
        new_ty <- zonkTcTypeToType env ty
        return (env, BodyStmt new_body new_then new_guard new_ty)
 
-zonkStmt env zBody (LastStmt body ret_op)
+zonkStmt env zBody (LastStmt body noret ret_op)
   = do new_body <- zBody env body
        new_ret <- zonkExpr env ret_op
-       return (env, LastStmt new_body new_ret)
+       return (env, LastStmt new_body noret new_ret)
 
 zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap
                               , trS_by = by, trS_form = form, trS_using = using
@@ -989,6 +990,29 @@ zonkStmt env zBody (BindStmt pat body bind_op fail_op)
         ; new_fail <- zonkExpr env fail_op
         ; return (env1, BindStmt new_pat new_body new_bind new_fail) }
 
+zonkStmt env _zBody (ApplicativeStmt args mb_join body_ty)
+  = do  { (env', args') <- zonk_args env args
+        ; new_mb_join <- traverse (zonkExpr env) mb_join
+        ; new_body_ty <- zonkTcTypeToType env' body_ty
+        ; return (env', ApplicativeStmt args' new_mb_join new_body_ty) }
+  where
+   zonk_args env [] = return (env, [])
+   zonk_args env ((op, arg) : groups)
+      = do { (env1, arg') <- zonk_arg env arg
+           ; op' <- zonkExpr env1 op
+           ; (env2, ss) <- zonk_args env1 groups
+           ; return (env2, (op', arg') : ss) }
+
+   zonk_arg env (ApplicativeArgOne pat expr)
+     = do { (env1, new_pat) <- zonkPat env pat
+          ; new_expr <- zonkLExpr env expr
+          ; return (env1, ApplicativeArgOne new_pat new_expr) }
+   zonk_arg env (ApplicativeArgMany stmts ret pat)
+     = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts
+          ; new_ret <- zonkExpr env1 ret
+          ; (env2, new_pat) <- zonkPat env pat
+          ; return (env2, ApplicativeArgMany new_stmts new_ret new_pat) }
+
 -------------------------------------------------------------------------
 zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId)
 zonkRecFields env (HsRecFields flds dd)
@@ -996,9 +1020,18 @@ zonkRecFields env (HsRecFields flds dd)
         ; return (HsRecFields flds' dd) }
   where
     zonk_rbind (L l fld)
-      = do { new_id   <- wrapLocM (zonkIdBndr env) (hsRecFieldId fld)
+      = do { new_id   <- wrapLocM (zonkFieldOcc env) (hsRecFieldLbl fld)
            ; new_expr <- zonkLExpr env (hsRecFieldArg fld)
-           ; return (L l (fld { hsRecFieldId = new_id
+           ; return (L l (fld { hsRecFieldLbl = new_id
+                              , hsRecFieldArg = new_expr })) }
+
+zonkRecUpdFields :: ZonkEnv -> [LHsRecUpdField TcId] -> TcM [LHsRecUpdField TcId]
+zonkRecUpdFields env = mapM zonk_rbind
+  where
+    zonk_rbind (L l fld)
+      = do { new_id   <- wrapLocM (zonkFieldOcc env) (hsRecUpdFieldOcc fld)
+           ; new_expr <- zonkLExpr env (hsRecFieldArg fld)
+           ; return (L l (fld { hsRecFieldLbl = fmap ambiguousFieldOcc new_id
                               , hsRecFieldArg = new_expr })) }
 
 -------------------------------------------------------------------------
@@ -1247,25 +1280,12 @@ zonkEvTerm env (EvCoercion co)    = do { co' <- zonkTcCoToCo env co
 zonkEvTerm env (EvCast tm co)     = do { tm' <- zonkEvTerm env tm
                                        ; co' <- zonkTcCoToCo env co
                                        ; return (mkEvCast tm' co') }
-zonkEvTerm env (EvTupleSel tm n)  = do { tm' <- zonkEvTerm env tm
-                                       ; return (EvTupleSel tm' n) }
-zonkEvTerm env (EvTupleMk tms)    = do { tms' <- mapM (zonkEvTerm env) tms
-                                       ; return (EvTupleMk tms') }
 zonkEvTerm _   (EvLit l)          = return (EvLit l)
 
-zonkEvTerm env (EvTypeable ev) =
-  fmap EvTypeable $
-  case ev of
-    EvTypeableTyCon tc ks    -> return (EvTypeableTyCon tc ks)
-    EvTypeableTyApp t1 t2    -> do e1 <- zonk t1
-                                   e2 <- zonk t2
-                                   return (EvTypeableTyApp e1 e2)
-    EvTypeableTyLit t        -> EvTypeableTyLit `fmap` zonkTcTypeToType env t
-  where
-  zonk (ev,t) = do ev' <- zonkEvTerm env ev
-                   t'  <- zonkTcTypeToType env t
-                   return (ev',t')
-
+zonkEvTerm env (EvTypeable ty ev) =
+  do { ev' <- zonkEvTypeable env ev
+     ; ty' <- zonkTcTypeToType env ty
+     ; return (EvTypeable ty' ev') }
 zonkEvTerm env (EvCallStack cs)
   = case cs of
       EvCsEmpty -> return (EvCallStack cs)
@@ -1273,16 +1293,26 @@ zonkEvTerm env (EvCallStack cs)
                            ; return (EvCallStack (EvCsTop n l tm')) }
       EvCsPushCall n l tm -> do { tm' <- zonkEvTerm env tm
                                 ; return (EvCallStack (EvCsPushCall n l tm')) }
+
 zonkEvTerm env (EvSuperClass d n) = do { d' <- zonkEvTerm env d
                                        ; return (EvSuperClass d' n) }
 zonkEvTerm env (EvDFunApp df tys tms)
   = do { tys' <- zonkTcTypeToTypes env tys
-       ; tms' <- mapM (zonkEvTerm env) tms
-       ; return (EvDFunApp (zonkIdOcc env df) tys' tms') }
+       ; return (EvDFunApp (zonkIdOcc env df) tys' (zonkIdOccs env tms)) }
 zonkEvTerm env (EvDelayedError ty msg)
   = do { ty' <- zonkTcTypeToType env ty
        ; return (EvDelayedError ty' msg) }
 
+zonkEvTypeable :: ZonkEnv -> EvTypeable -> TcM EvTypeable
+zonkEvTypeable _ EvTypeableTyCon
+  = return EvTypeableTyCon
+zonkEvTypeable env (EvTypeableTyApp t1 t2)
+  = do { t1' <- zonkEvTerm env t1
+       ; t2' <- zonkEvTerm env t2
+       ; return (EvTypeableTyApp t1' t2') }
+zonkEvTypeable _ (EvTypeableTyLit t1)
+  = return (EvTypeableTyLit t1)
+
 zonkTcEvBinds_s :: ZonkEnv -> [TcEvBinds] -> TcM (ZonkEnv, [TcEvBinds])
 zonkTcEvBinds_s env bs = do { (env, bs') <- mapAccumLM zonk_tc_ev_binds env bs
                             ; return (env, [EvBinds (unionManyBags bs')]) }
@@ -1478,7 +1508,7 @@ zonkCoToCo env co
                                    do { (env', tv') <- zonkTyBndrX env tv
                                       ; co' <- zonkCoToCo env' co
                                       ; return (mkForAllCo tv' co') }
-                                   
+
 zonkTvCollecting :: TcRef TyVarSet -> UnboundTyVarZonker
 -- This variant collects unbound type variables in a mutable variable
 -- Works on both types and kinds