diff options
author | Carter Tazio Schonwald <carter.schonwald@gmail.com> | 2019-12-31 19:12:39 -0500 |
---|---|---|
committer | Carter Tazio Schonwald <carter.schonwald@gmail.com> | 2020-01-04 14:55:50 -0500 |
commit | e76d43e5c07346109006cc579cf3cf9c9ddd937c (patch) | |
tree | fbf32abba463bff47e5a57bbd9e43b1817a9c8ec | |
parent | 20066cb14ca10265881392f4ac87e48ffd7e15df (diff) | |
download | haskell-e76d43e5c07346109006cc579cf3cf9c9ddd937c.tar.gz |
more late to catching type errors and typos
-rw-r--r-- | compiler/coreSyn/CoreFVs.hs | 3 | ||||
-rw-r--r-- | compiler/iface/IfaceSyn.hs | 2 | ||||
-rw-r--r-- | compiler/iface/IfaceType.hs | 16 | ||||
-rw-r--r-- | compiler/types/Coercion.hs | 5 | ||||
-rw-r--r-- | compiler/types/OptCoercion.hs | 2 | ||||
-rw-r--r-- | compiler/types/TyCoFVs.hs | 2 | ||||
-rw-r--r-- | compiler/types/TyCoRep.hs | 2 | ||||
-rw-r--r-- | compiler/types/TyCoSubst.hs | 2 | ||||
-rw-r--r-- | compiler/types/Type.hs | 12 |
9 files changed, 26 insertions, 20 deletions
diff --git a/compiler/coreSyn/CoreFVs.hs b/compiler/coreSyn/CoreFVs.hs index daeeaf4b66..36fcfef43a 100644 --- a/compiler/coreSyn/CoreFVs.hs +++ b/compiler/coreSyn/CoreFVs.hs @@ -372,7 +372,8 @@ orphNamesOfMCo MRefl = emptyNameSet orphNamesOfMCo (MCo co) = orphNamesOfCo co orphNamesOfCo :: Coercion -> NameSet -orphNamesOfCo (ErasedCoercion _r lty rty ) = orphNamesOfType lty `unionNameSet` rty +orphNamesOfCo (ErasedCoercion _r lty rty ) + = orphNamesOfType lty `unionNameSet` orphNamesOfType rty orphNamesOfCo (Refl ty) = orphNamesOfType ty orphNamesOfCo (GRefl _ ty mco) = orphNamesOfType ty `unionNameSet` orphNamesOfMCo mco orphNamesOfCo (TyConAppCo _ tc cos) = unitNameSet (getName tc) `unionNameSet` orphNamesOfCos cos diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs index 02050868aa..0859ef5f96 100644 --- a/compiler/iface/IfaceSyn.hs +++ b/compiler/iface/IfaceSyn.hs @@ -1579,7 +1579,7 @@ freeNamesIfMCoercion (IfaceMCo co) = freeNamesIfCoercion co freeNamesIfCoercion :: IfaceCoercion -> NameSet freeNamesIfCoercion (IfaceErased _role ltyp rtyp) - = freeNamesIfType ltyp && freeNamesIfType rtyp + = freeNamesIfType ltyp &&& freeNamesIfType rtyp freeNamesIfCoercion (IfaceReflCo t) = freeNamesIfType t freeNamesIfCoercion (IfaceGReflCo _ t mco) = freeNamesIfType t &&& freeNamesIfMCoercion mco diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs index 39e748eff1..78aa479ba3 100644 --- a/compiler/iface/IfaceType.hs +++ b/compiler/iface/IfaceType.hs @@ -523,7 +523,7 @@ substIfaceType env ty go_co (IfaceKindCo co) = IfaceKindCo (go_co co) go_co (IfaceSubCo co) = IfaceSubCo (go_co co) go_co (IfaceAxiomRuleCo n cos) = IfaceAxiomRuleCo n (go_cos cos) - go_co (IfaceErased role lty rty) = IfaceErased role (go_co lty rty) + go_co (IfaceErased role lty rty) = IfaceErased role (go lty) (go rty) go_cos = map go_co go_prov IfaceUnsafeCoerceProv = IfaceUnsafeCoerceProv @@ -1596,7 +1596,7 @@ ppr_co ctxt_prec (IfaceSubCo co) = ppr_special_co ctxt_prec (text "Sub") [co] ppr_co ctxt_prec (IfaceKindCo co) = ppr_special_co ctxt_prec (text "Kind") [co] -ppr_co ctxt_prec (IfaceErased role lty rtyp) +ppr_co ctxt_prec (IfaceErased role lty rty) = maybeParen ctxt_prec appPrec $ text "ErasedCoercion" <+> ppr role <+> pprParendIfaceType lty <+> pprParendIfaceType rty @@ -1894,10 +1894,10 @@ instance Binary IfaceCoercion where put_ bh a put_ bh b put_ bh (IfaceErased r lty rty) = do - putByte bh 18 - putByte bh r - putByte bh lty - putByte bh rty + putByte bh 18 + put_ bh r + put_ bh lty + put_ bh rty put_ _ (IfaceFreeCoVar cv) = pprPanic "Can't serialise IfaceFreeCoVar" (ppr cv) put_ _ (IfaceHoleCo cv) @@ -1964,7 +1964,7 @@ instance Binary IfaceCoercion where role <- get bh lty <- get bh rty <- get bh - return $ IfaceErased r lty rty + return $ IfaceErased role lty rty _ -> panic ("get IfaceCoercion " ++ show tag) instance Binary IfaceUnivCoProv where @@ -2040,7 +2040,7 @@ instance NFData IfaceCoercion where IfaceSubCo f1 -> rnf f1 IfaceFreeCoVar f1 -> f1 `seq` () IfaceHoleCo f1 -> f1 `seq` () - IfaceErased rl lty rty-> rnf r `seq` rn lty `seq` rnf rty + IfaceErased rl lty rty-> rl `seq` rnf lty `seq` rnf rty instance NFData IfaceUnivCoProv where rnf x = seq x () diff --git a/compiler/types/Coercion.hs b/compiler/types/Coercion.hs index 45445c55f0..a1d1820bf6 100644 --- a/compiler/types/Coercion.hs +++ b/compiler/types/Coercion.hs @@ -2190,7 +2190,7 @@ coercionLKind :: Coercion -> Type coercionLKind co = go co where - go (ErasedCoercion _role ltyp _rtyp) = ltype + go (ErasedCoercion _role ltyp _rtyp) = ltyp go (Refl ty) = ty go (GRefl _ ty _) = ty go (TyConAppCo _ tc cos) = mkTyConApp tc (map go cos) @@ -2245,7 +2245,8 @@ go_nth d ty coercionRKind :: Coercion -> Type coercionRKind co = go co - go (ErasedCoercion _role _ltyp rtype) = k + where + go (ErasedCoercion _role _ltyp rtype) = rtype go (Refl ty) = ty go (GRefl _ ty MRefl) = ty go (GRefl _ ty (MCo co1)) = mkCastTy ty co1 diff --git a/compiler/types/OptCoercion.hs b/compiler/types/OptCoercion.hs index ca83a297fc..46a4196e4e 100644 --- a/compiler/types/OptCoercion.hs +++ b/compiler/types/OptCoercion.hs @@ -191,7 +191,7 @@ opt_co4_wrap env sym rep r co pprTrace "opt_co4_wrap }" (ppr co $$ text "---" $$ ppr result) $ result -} -opt_co4 _lc _sym _rp _role e@(ErasedCoercion) = e +opt_co4 _lc _sym _rp _role e@(ErasedCoercion _ _ _) = e opt_co4 env _ rep r (Refl ty) = ASSERT2( r == Nominal, text "Expected role:" <+> ppr r $$ text "Found role:" <+> ppr Nominal $$ diff --git a/compiler/types/TyCoFVs.hs b/compiler/types/TyCoFVs.hs index 442b37c5fd..58068c0c29 100644 --- a/compiler/types/TyCoFVs.hs +++ b/compiler/types/TyCoFVs.hs @@ -210,7 +210,7 @@ ty_co_vars_of_co :: Coercion -> TyCoVarSet -> TyCoVarSet -> TyCoVarSet ty_co_vars_of_co (ErasedCoercion _r lty rty) is acc = ty_co_vars_of_type rty is $ ty_co_vars_of_type lty is acc ty_co_vars_of_co (Refl ty) is acc = ty_co_vars_of_type ty is acc -ty_co_vars_of_co (GRefl _ ty mco) is acc = ty_co_vars_of_type ty is acc $ +ty_co_vars_of_co (GRefl _ ty mco) is acc = ty_co_vars_of_type ty is $ ty_co_vars_of_mco mco is acc ty_co_vars_of_co (TyConAppCo _ _ cos) is acc = ty_co_vars_of_cos cos is acc ty_co_vars_of_co (AppCo co arg) is acc = ty_co_vars_of_co co is $ diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs index d5c7b647ea..484e776a6d 100644 --- a/compiler/types/TyCoRep.hs +++ b/compiler/types/TyCoRep.hs @@ -1068,7 +1068,7 @@ data Coercion | HoleCo CoercionHole -- ^ See Note [Coercion holes] -- Only present during typechecking - | ErasedCoercion -- ^ optimization hack because cast terms blowup fusion heavy + | ErasedCoercion Role Type Type-- ^ optimization hack because cast terms blowup fusion heavy -- code, implied whenever corelint isn't enabled deriving Data.Data diff --git a/compiler/types/TyCoSubst.hs b/compiler/types/TyCoSubst.hs index 8d37d1c24f..3b6535091f 100644 --- a/compiler/types/TyCoSubst.hs +++ b/compiler/types/TyCoSubst.hs @@ -791,7 +791,7 @@ subst_co subst co go_mco (MCo co) = MCo (go co) go :: Coercion -> Coercion - go (ErasedCoercion r lty rty ) = ErasedCoercion r $! (go_ty lty) $! (go_ty rty) + go (ErasedCoercion r lty rty ) = (ErasedCoercion r $! (go_ty lty)) $! (go_ty rty) go (Refl ty) = mkNomReflCo $! (go_ty ty) go (GRefl r ty mco) = (mkGReflCo r $! (go_ty ty)) $! (go_mco mco) go (TyConAppCo r tc args)= let args' = map go args diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs index e95d93bfac..22100d1756 100644 --- a/compiler/types/Type.hs +++ b/compiler/types/Type.hs @@ -424,7 +424,8 @@ expandTypeSynonyms ty go_mco _ MRefl = MRefl go_mco subst (MCo co) = MCo (go_co subst co) - go_co _ ErasedCoercion = panic "go_co for expand type synonyms pandic on erased coercions" + go_co subst (ErasedCoercion r lty rty) + = ErasedCoercion r (go subst lty) (go subst rty) go_co subst (Refl ty) = mkNomReflCo (go subst ty) go_co subst (GRefl r ty mco) @@ -658,7 +659,8 @@ mapCoercion mapper@(TyCoMapper { tcm_covar = covar go_mco MRefl = return MRefl go_mco (MCo co) = MCo <$> (go co) - go (ErasedCoercion) = return ErasedCoercion + go (ErasedCoercion r lty rty ) + = ErasedCoercion r <$> mapType mapper env lty <*> mapType mapper env rty go (Refl ty) = Refl <$> mapType mapper env ty go (GRefl r ty mco) = mkGReflCo r <$> mapType mapper env ty <*> (go_mco mco) go (TyConAppCo r tc args) @@ -2683,7 +2685,9 @@ occCheckExpand vs_to_avoid ty go_mco ctx (MCo co) = MCo <$> go_co ctx co ------------------ - go_co _ ErasedCoercion = Nothing + go_co ctx (ErasedCoercion r lty rty ) = do { lty' <- go ctx lty + ; rty' <- go ctx rty + ; return $ ErasedCoercion r lty' rty' } go_co cxt (Refl ty) = do { ty' <- go cxt ty ; return (mkNomReflCo ty') } go_co cxt (GRefl r ty mco) = do { mco' <- go_mco cxt mco @@ -2771,7 +2775,7 @@ tyConsOfType ty go (CastTy ty co) = go ty `unionUniqSets` go_co co go (CoercionTy co) = go_co co - go_co (ErasedCoercion) = emptyUniqSet + go_co (ErasedCoercion r lty rty ) = go lty `unionUniqSets` go rty go_co (Refl ty) = go ty go_co (GRefl _ ty mco) = go ty `unionUniqSets` go_mco mco go_co (TyConAppCo _ tc args) = go_tc tc `unionUniqSets` go_cos args |