Generate Typeable info at definition sites
[ghc.git] / compiler / typecheck / TcHsSyn.hs
index 7dd38c9..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],
@@ -538,13 +537,11 @@ zonkLTcSpecPrags env ps
 zonkMatchGroup :: ZonkEnv
                -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
                -> MatchGroup TcId (Located (body TcId)) -> TcM (MatchGroup Id (Located (body Id)))
-zonkMatchGroup env zBody (MG { mg_alts = L l ms, mg_arg_tys = arg_tys
-                             , mg_res_ty = res_ty, mg_origin = origin })
+zonkMatchGroup env zBody (MG { mg_alts = ms, mg_arg_tys = arg_tys, mg_res_ty = res_ty, mg_origin = origin })
   = do  { ms' <- mapM (zonkMatch env zBody) ms
         ; arg_tys' <- zonkTcTypeToTypes env arg_tys
         ; res_ty'  <- zonkTcTypeToType env res_ty
-        ; return (MG { mg_alts = L l ms', mg_arg_tys = arg_tys'
-                     , mg_res_ty = res_ty', mg_origin = origin }) }
+        ; return (MG { mg_alts = ms', mg_arg_tys = arg_tys', mg_res_ty = res_ty', mg_origin = origin }) }
 
 zonkMatch :: ZonkEnv
           -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
@@ -559,7 +556,7 @@ zonkGRHSs :: ZonkEnv
           -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
           -> GRHSs TcId (Located (body TcId)) -> TcM (GRHSs Id (Located (body Id)))
 
-zonkGRHSs env zBody (GRHSs grhss (L l binds)) = do
+zonkGRHSs env zBody (GRHSs grhss binds) = do
     (new_env, new_binds) <- zonkLocalBinds env binds
     let
         zonk_grhs (GRHS guarded rhs)
@@ -567,7 +564,7 @@ zonkGRHSs env zBody (GRHSs grhss (L l binds)) = do
                new_rhs <- zBody env2 rhs
                return (GRHS new_guarded new_rhs)
     new_grhss <- mapM (wrapLocM zonk_grhs) grhss
-    return (GRHSs new_grhss (L l new_binds))
+    return (GRHSs new_grhss new_binds)
 
 {-
 ************************************************************************
@@ -683,15 +680,15 @@ zonkExpr env (HsMultiIf ty alts)
                ; expr'          <- zonkLExpr env' expr
                ; return $ GRHS guard' expr' }
 
-zonkExpr env (HsLet (L l binds) expr)
+zonkExpr env (HsLet binds expr)
   = do (new_env, new_binds) <- zonkLocalBinds env binds
        new_expr <- zonkLExpr new_env expr
-       return (HsLet (L l new_binds) new_expr)
+       return (HsLet new_binds new_expr)
 
-zonkExpr env (HsDo do_or_lc (L l stmts) ty)
+zonkExpr env (HsDo do_or_lc stmts ty)
   = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts
        new_ty <- zonkTcTypeToType env ty
-       return (HsDo do_or_lc (L l new_stmts) new_ty)
+       return (HsDo do_or_lc new_stmts new_ty)
 
 zonkExpr env (ExplicitList ty wit exprs)
   = do new_ty <- zonkTcTypeToType env ty
@@ -712,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
@@ -819,15 +818,15 @@ zonkCmd env (HsCmdIf eCond ePred cThen cElse)
        ; new_cElse <- zonkLCmd env cElse
        ; return (HsCmdIf new_eCond new_ePred new_cThen new_cElse) }
 
-zonkCmd env (HsCmdLet (L l binds) cmd)
+zonkCmd env (HsCmdLet binds cmd)
   = do (new_env, new_binds) <- zonkLocalBinds env binds
        new_cmd <- zonkLCmd new_env cmd
-       return (HsCmdLet (L l new_binds) new_cmd)
+       return (HsCmdLet new_binds new_cmd)
 
-zonkCmd env (HsCmdDo (L l stmts) ty)
+zonkCmd env (HsCmdDo stmts ty)
   = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts
        new_ty <- zonkTcTypeToType env ty
-       return (HsCmdDo (L l new_stmts) new_ty)
+       return (HsCmdDo new_stmts new_ty)
 
 
 
@@ -955,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
@@ -980,9 +979,9 @@ zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap
         newBinder' <- zonkIdBndr env newBinder
         return (oldBinder', newBinder')
 
-zonkStmt env _ (LetStmt (L l binds))
+zonkStmt env _ (LetStmt binds)
   = do (env1, new_binds) <- zonkLocalBinds env binds
-       return (env1, LetStmt (L l new_binds))
+       return (env1, LetStmt new_binds)
 
 zonkStmt env zBody (BindStmt pat body bind_op fail_op)
   = do  { new_body <- zBody env body
@@ -991,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)
@@ -998,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 { 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 { hsRecFieldId = new_id
+           ; return (L l (fld { hsRecFieldLbl = fmap ambiguousFieldOcc new_id
                               , hsRecFieldArg = new_expr })) }
 
 -------------------------------------------------------------------------
@@ -1249,22 +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 (EvTupleMk tms)    = return (EvTupleMk (zonkIdOccs env 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,8 +1294,6 @@ zonkEvTerm env (EvCallStack cs)
       EvCsPushCall n l tm -> do { tm' <- zonkEvTerm env tm
                                 ; return (EvCallStack (EvCsPushCall n l tm')) }
 
-zonkEvTerm env (EvTupleSel tm n)  = do { tm' <- zonkEvTerm env tm
-                                       ; return (EvTupleSel tm' n) }
 zonkEvTerm env (EvSuperClass d n) = do { d' <- zonkEvTerm env d
                                        ; return (EvSuperClass d' n) }
 zonkEvTerm env (EvDFunApp df tys tms)
@@ -1284,6 +1303,16 @@ 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')]) }
@@ -1479,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