projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Fix the bug part of Trac #1930
[ghc-hetmet.git]
/
compiler
/
types
/
FamInstEnv.lhs
diff --git
a/compiler/types/FamInstEnv.lhs
b/compiler/types/FamInstEnv.lhs
index
12df25d
..
783ee13
100644
(file)
--- a/
compiler/types/FamInstEnv.lhs
+++ b/
compiler/types/FamInstEnv.lhs
@@
-5,13
+5,6
@@
FamInstEnv: Type checked family instance declarations
\begin{code}
FamInstEnv: Type checked family instance declarations
\begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
module FamInstEnv (
FamInst(..), famInstTyCon, famInstTyVars,
pprFamInst, pprFamInstHdr, pprFamInsts,
module FamInstEnv (
FamInst(..), famInstTyCon, famInstTyVars,
pprFamInst, pprFamInstHdr, pprFamInsts,
@@
-30,9
+23,8
@@
module FamInstEnv (
#include "HsVersions.h"
import InstEnv
#include "HsVersions.h"
import InstEnv
-import Unify
-import TcGadt
import TcType
import TcType
+import Unify
import Type
import TypeRep
import TyCon
import Type
import TypeRep
import TyCon
@@
-40,12
+32,11
@@
import Coercion
import VarSet
import Var
import Name
import VarSet
import Var
import Name
-import OccName
-import SrcLoc
import UniqFM
import Outputable
import Maybes
import Util
import UniqFM
import Outputable
import Maybes
import Util
+import FastString
import Maybe
\end{code}
import Maybe
\end{code}
@@
-82,6
+73,7
@@
data FamInst
famInstTyCon :: FamInst -> TyCon
famInstTyCon = fi_tycon
famInstTyCon :: FamInst -> TyCon
famInstTyCon = fi_tycon
+famInstTyVars :: FamInst -> TyVarSet
famInstTyVars = fi_tvs
\end{code}
famInstTyVars = fi_tvs
\end{code}
@@
-96,16
+88,16
@@
instance Outputable FamInst where
pprFamInst :: FamInst -> SDoc
pprFamInst famInst
= hang (pprFamInstHdr famInst)
pprFamInst :: FamInst -> SDoc
pprFamInst famInst
= hang (pprFamInstHdr famInst)
- 2 (ptext SLIT("--") <+> pprNameLoc (getName famInst))
+ 2 (ptext (sLit "--") <+> pprNameLoc (getName famInst))
pprFamInstHdr :: FamInst -> SDoc
pprFamInstHdr (FamInst {fi_fam = fam, fi_tys = tys, fi_tycon = tycon})
= pprTyConSort <+> pprHead
where
pprFamInstHdr :: FamInst -> SDoc
pprFamInstHdr (FamInst {fi_fam = fam, fi_tys = tys, fi_tycon = tycon})
= pprTyConSort <+> pprHead
where
- pprHead = pprTypeApp fam (ppr fam) tys
- pprTyConSort | isDataTyCon tycon = ptext SLIT("data instance")
- | isNewTyCon tycon = ptext SLIT("newtype instance")
- | isSynTyCon tycon = ptext SLIT("type instance")
+ pprHead = pprTypeApp fam tys
+ pprTyConSort | isDataTyCon tycon = ptext (sLit "data instance")
+ | isNewTyCon tycon = ptext (sLit "newtype instance")
+ | isSynTyCon tycon = ptext (sLit "type instance")
| otherwise = panic "FamInstEnv.pprFamInstHdr"
pprFamInsts :: [FamInst] -> SDoc
| otherwise = panic "FamInstEnv.pprFamInstHdr"
pprFamInsts :: [FamInst] -> SDoc
@@
-330,6
+322,7
@@
lookupFamInstEnvUnify (pkg_ie, home_ie) fam tys
-- See explanation at @InstEnv.bind_fn@.
--
-- See explanation at @InstEnv.bind_fn@.
--
+bind_fn :: TyVar -> BindFlag
bind_fn tv | isTcTyVar tv && isExistentialTyVar tv = Skolem
| otherwise = BindMe
\end{code}
bind_fn tv | isTcTyVar tv && isExistentialTyVar tv = Skolem
| otherwise = BindMe
\end{code}
@@
-382,7
+375,7
@@
topNormaliseType env ty
-- to be sure that
add_co co rec_nts ty
-- to be sure that
add_co co rec_nts ty
- go rec_nts ty = Nothing
+ go _ _ = Nothing
add_co co rec_nts ty
= case go rec_nts ty of
add_co co rec_nts ty
= case go rec_nts ty of
@@
-411,7
+404,7
@@
normaliseTcApp env tc tys
-- No unique matching family instance exists;
-- we do not do anything
-- No unique matching family instance exists;
-- we do not do anything
- other -> (tycon_coi, TyConApp tc ntys)
+ _ -> (tycon_coi, TyConApp tc ntys)
---------------
normaliseType :: FamInstEnvs -- environment with family instances
-> Type -- old type
---------------
normaliseType :: FamInstEnvs -- environment with family instances
-> Type -- old type
@@
-422,26
+415,23
@@
normaliseType :: FamInstEnvs -- environment with family instances
normaliseType env ty
| Just ty' <- coreView ty = normaliseType env ty'
normaliseType env ty
| Just ty' <- coreView ty = normaliseType env ty'
-normaliseType env ty@(TyConApp tc tys)
+normaliseType env (TyConApp tc tys)
= normaliseTcApp env tc tys
= normaliseTcApp env tc tys
-normaliseType env ty@(AppTy ty1 ty2)
+normaliseType env (AppTy ty1 ty2)
= let (coi1,nty1) = normaliseType env ty1
(coi2,nty2) = normaliseType env ty2
in (mkAppTyCoI nty1 coi1 nty2 coi2, AppTy nty1 nty2)
= let (coi1,nty1) = normaliseType env ty1
(coi2,nty2) = normaliseType env ty2
in (mkAppTyCoI nty1 coi1 nty2 coi2, AppTy nty1 nty2)
-normaliseType env ty@(FunTy ty1 ty2)
+normaliseType env (FunTy ty1 ty2)
= let (coi1,nty1) = normaliseType env ty1
(coi2,nty2) = normaliseType env ty2
in (mkFunTyCoI nty1 coi1 nty2 coi2, FunTy nty1 nty2)
= let (coi1,nty1) = normaliseType env ty1
(coi2,nty2) = normaliseType env ty2
in (mkFunTyCoI nty1 coi1 nty2 coi2, FunTy nty1 nty2)
-normaliseType env ty@(ForAllTy tyvar ty1)
+normaliseType env (ForAllTy tyvar ty1)
= let (coi,nty1) = normaliseType env ty1
in (mkForAllTyCoI tyvar coi,ForAllTy tyvar nty1)
= let (coi,nty1) = normaliseType env ty1
in (mkForAllTyCoI tyvar coi,ForAllTy tyvar nty1)
-normaliseType env ty@(NoteTy note ty1)
- = let (coi,nty1) = normaliseType env ty1
- in (coi,NoteTy note nty1)
-normaliseType env ty@(TyVarTy _)
+normaliseType _ ty@(TyVarTy _)
= (IdCo,ty)
normaliseType env (PredTy predty)
= (IdCo,ty)
normaliseType env (PredTy predty)
- = normalisePred env predty
+ = normalisePred env predty
---------------
normalisePred :: FamInstEnvs -> PredType -> (CoercionI,Type)
---------------
normalisePred :: FamInstEnvs -> PredType -> (CoercionI,Type)