projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Fix Trac #3346: tcSimplify for LHS of RULES with type equalities
[ghc-hetmet.git]
/
compiler
/
typecheck
/
TcTyClsDecls.lhs
diff --git
a/compiler/typecheck/TcTyClsDecls.lhs
b/compiler/typecheck/TcTyClsDecls.lhs
index
f0619d8
..
0e59f01
100644
(file)
--- a/
compiler/typecheck/TcTyClsDecls.lhs
+++ b/
compiler/typecheck/TcTyClsDecls.lhs
@@
-13,7
+13,6
@@
module TcTyClsDecls (
#include "HsVersions.h"
import HsSyn
#include "HsVersions.h"
import HsSyn
-import HsTypes
import HscTypes
import BuildTyCl
import TcUnify
import HscTypes
import BuildTyCl
import TcUnify
@@
-36,7
+35,6
@@
import IdInfo
import Var
import VarSet
import Name
import Var
import VarSet
import Name
-import OccName
import Outputable
import Maybes
import Monad
import Outputable
import Maybes
import Monad
@@
-52,7
+50,6
@@
import BasicTypes
import Bag
import Data.List
import Bag
import Data.List
-import Control.Monad ( mplus )
\end{code}
\end{code}
@@
-293,7
+290,7
@@
tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name})
; checkValidTypeInst t_typats t_rhs
-- (4) construct representation tycon
; checkValidTypeInst t_typats t_rhs
-- (4) construct representation tycon
- ; rep_tc_name <- newFamInstTyConName tc_name loc
+ ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
; buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs)
(typeKind t_rhs) (Just (family, t_typats))
}}
; buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs)
(typeKind t_rhs) (Just (family, t_typats))
}}
@@
-337,7
+334,7
@@
tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
newtypeConError tc_name (length k_cons)
-- (4) construct representation tycon
newtypeConError tc_name (length k_cons)
-- (4) construct representation tycon
- ; rep_tc_name <- newFamInstTyConName tc_name loc
+ ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
; let ex_ok = True -- Existentials ok for type families!
; fixM (\ rep_tycon -> do
{ let orig_res_ty = mkTyConApp fam_tycon t_typats
; let ex_ok = True -- Existentials ok for type families!
; fixM (\ rep_tycon -> do
{ let orig_res_ty = mkTyConApp fam_tycon t_typats
@@
-590,7
+587,8
@@
kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons})
; return (decl {tcdTyVars = tvs, tcdCtxt = ctxt', tcdCons = cons'}) }
where
-- doc comments are typechecked to Nothing here
; return (decl {tcdTyVars = tvs, tcdCtxt = ctxt', tcdCons = cons'}) }
where
-- doc comments are typechecked to Nothing here
- kc_con_decl (ConDecl name expl ex_tvs ex_ctxt details res _)
+ kc_con_decl con_decl@(ConDecl { con_name = name, con_qvars = ex_tvs
+ , con_cxt = ex_ctxt, con_details = details, con_res = res })
= addErrCtxt (dataConCtxt name) $
kcHsTyVars ex_tvs $ \ex_tvs' -> do
do { ex_ctxt' <- kcHsContext ex_ctxt
= addErrCtxt (dataConCtxt name) $
kcHsTyVars ex_tvs $ \ex_tvs' -> do
do { ex_ctxt' <- kcHsContext ex_ctxt
@@
-598,7
+596,8
@@
kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons})
; res' <- case res of
ResTyH98 -> return ResTyH98
ResTyGADT ty -> do { ty' <- kcHsSigType ty; return (ResTyGADT ty') }
; res' <- case res of
ResTyH98 -> return ResTyH98
ResTyGADT ty -> do { ty' <- kcHsSigType ty; return (ResTyGADT ty') }
- ; return (ConDecl name expl ex_tvs' ex_ctxt' details' res' Nothing) }
+ ; return (con_decl { con_qvars = ex_tvs', con_cxt = ex_ctxt'
+ , con_details = details', con_res = res' }) }
kc_con_details (PrefixCon btys)
= do { btys' <- mapM kc_larg_ty btys
kc_con_details (PrefixCon btys)
= do { btys' <- mapM kc_larg_ty btys
@@
-691,9
+690,6
@@
tcTyClDecl1 _calc_isrec
; idx_tys <- doptM Opt_TypeFamilies
; checkTc idx_tys $ badFamInstDecl tc_name
; idx_tys <- doptM Opt_TypeFamilies
; checkTc idx_tys $ badFamInstDecl tc_name
- -- Check for no type indices
- ; checkTc (not (null tvs)) (noIndexTypes tc_name)
-
; tycon <- buildSynTyCon tc_name tvs' (OpenSynTyCon kind Nothing) kind Nothing
; return [ATyCon tycon]
}
; tycon <- buildSynTyCon tc_name tvs' (OpenSynTyCon kind Nothing) kind Nothing
; return [ATyCon tycon]
}
@@
-712,9
+708,6
@@
tcTyClDecl1 _calc_isrec
; idx_tys <- doptM Opt_TypeFamilies
; checkTc idx_tys $ badFamInstDecl tc_name
; idx_tys <- doptM Opt_TypeFamilies
; checkTc idx_tys $ badFamInstDecl tc_name
- -- Check for no type indices
- ; checkTc (not (null tvs)) (noIndexTypes tc_name)
-
; tycon <- buildAlgTyCon tc_name final_tvs []
mkOpenDataTyConRhs Recursive False True Nothing
; return [ATyCon tycon]
; tycon <- buildAlgTyCon tc_name final_tvs []
mkOpenDataTyConRhs Recursive False True Nothing
; return [ATyCon tycon]
@@
-829,7
+822,8
@@
tcConDecl :: Bool -- True <=> -funbox-strict_fields
-> TcM DataCon
tcConDecl unbox_strict existential_ok rep_tycon res_tmpl -- Data types
-> TcM DataCon
tcConDecl unbox_strict existential_ok rep_tycon res_tmpl -- Data types
- (ConDecl name _ tvs ctxt details res_ty _)
+ (ConDecl {con_name =name, con_qvars = tvs, con_cxt = ctxt
+ , con_details = details, con_res = res_ty })
= addErrCtxt (dataConCtxt name) $
tcTyVarBndrs tvs $ \ tvs' -> do
{ ctxt' <- tcHsKindedContext ctxt
= addErrCtxt (dataConCtxt name) $
tcTyVarBndrs tvs $ \ tvs' -> do
{ ctxt' <- tcHsKindedContext ctxt
@@
-1497,11
+1491,6
@@
badSigTyDecl tc_name
quotes (ppr tc_name)
, nest 2 (parens $ ptext (sLit "Use -XKindSignatures to allow kind signatures")) ]
quotes (ppr tc_name)
, nest 2 (parens $ ptext (sLit "Use -XKindSignatures to allow kind signatures")) ]
-noIndexTypes :: Name -> SDoc
-noIndexTypes tc_name
- = ptext (sLit "Type family constructor") <+> quotes (ppr tc_name)
- <+> ptext (sLit "must have at least one type index parameter")
-
badFamInstDecl :: Outputable a => a -> SDoc
badFamInstDecl tc_name
= vcat [ ptext (sLit "Illegal family instance for") <+>
badFamInstDecl :: Outputable a => a -> SDoc
badFamInstDecl tc_name
= vcat [ ptext (sLit "Illegal family instance for") <+>