import HsSyn ( TyClDecl(..), HsConDetails(..), HsTyVarBndr(..),
ConDecl(..), Sig(..), NewOrData(..), ResType(..),
- tyClDeclTyVars, isSynDecl, isClassDecl, isIdxTyDecl,
+ tyClDeclTyVars, isSynDecl, isIdxTyDecl,
isKindSigDecl, hsConArgs, LTyClDecl, tcdName,
- hsTyVarName, LHsTyVarBndr, LHsType, HsType(..),
- mkHsAppTy
+ hsTyVarName, LHsTyVarBndr, LHsType
)
import HsTypes ( HsBang(..), getBangStrictness, hsLTyVarNames )
import BasicTypes ( RecFlag(..), StrictnessMark(..) )
tcLookupLocated, tcLookupLocatedGlobal,
tcExtendGlobalEnv, tcExtendKindEnv,
tcExtendKindEnvTvs, newFamInstTyConName,
- tcExtendRecEnv, tcLookupTyVar, InstInfo,
- tcLookupLocatedTyCon )
+ tcExtendRecEnv, tcLookupTyVar, tcLookupLocatedTyCon )
import TcTyDecls ( calcRecFlags, calcClassCycles, calcSynCycles )
import TcClassDcl ( tcClassSigs, tcAddDeclCtxt )
import TcHsType ( kcHsTyVars, kcHsLiftedSigType, kcHsType,
-- checkFreeness,
UserTypeCtxt(..), SourceTyCtxt(..) )
import TcType ( TcKind, TcType, Type, tyVarsOfType, mkPhiTy,
- mkArrowKind, liftedTypeKind, mkTyVarTys,
- tcSplitSigmaTy, tcEqTypes, tcGetTyVar_maybe )
-import Type ( PredType(..), splitTyConApp_maybe, mkTyVarTy,
- newTyConInstRhs, isLiftedTypeKind, Kind
+ mkArrowKind, liftedTypeKind,
+ tcSplitSigmaTy, tcGetTyVar_maybe )
+import Type ( splitTyConApp_maybe,
+ newTyConInstRhs, isLiftedTypeKind, Kind,
+ splitKindFunTys, mkArrowKinds
-- pprParendType, pprThetaArrow
)
import Generics ( validGenericMethodType, canDoGenerics )
OpenNewTyCon ),
SynTyConRhs( OpenSynTyCon, SynonymTyCon ),
tyConDataCons, mkForeignTyCon, isProductTyCon,
- isRecursiveTyCon, isOpenTyCon,
+ isRecursiveTyCon,
tyConStupidTheta, synTyConRhs, isSynTyCon, tyConName,
isNewTyCon, isDataTyCon, tyConKind,
setTyConArgPoss )
import DataCon ( DataCon, dataConUserType, dataConName,
dataConFieldLabels, dataConTyCon, dataConAllTyVars,
dataConFieldType, dataConResTys )
-import Var ( TyVar, idType, idName )
+import Var ( TyVar, idType, idName, tyVarName, setTyVarName )
import VarSet ( elemVarSet, mkVarSet )
-import Name ( Name, getSrcLoc )
+import Name ( Name, getSrcLoc, tidyNameOcc, getOccName )
+import OccName ( initTidyOccEnv, tidyOccName )
import Outputable
import Maybe ( isJust, fromJust, isNothing, catMaybes )
import Maybes ( expectJust )
import Monad ( unless )
import Unify ( tcMatchTys, tcMatchTyX )
-import Util ( zipLazy, isSingleton, notNull, sortLe )
+import Util ( zipLazy, isSingleton, notNull, sortLe, mapAccumL )
import List ( partition, elemIndex )
import SrcLoc ( Located(..), unLoc, getLoc, srcLocSpan,
srcSpanStart )
data types (and GADTs).
\begin{code}
-tcIdxTyInstDecl :: LTyClDecl Name
- -> TcM (Maybe InstInfo, Maybe TyThing) -- Nothing if error
+tcIdxTyInstDecl :: LTyClDecl Name -> TcM (Maybe TyThing) -- Nothing if error
tcIdxTyInstDecl (L loc decl)
= -- Prime error recovery, set source location
- recoverM (returnM (Nothing, Nothing)) $
+ recoverM (returnM Nothing) $
setSrcSpan loc $
tcAddDeclCtxt decl $
do { -- indexed data types require -findexed-types and can't be in an
; tcIdxTyInstDecl1 decl
}
-tcIdxTyInstDecl1 :: TyClDecl Name
- -> TcM (Maybe InstInfo, Maybe TyThing) -- Nothing if error
+tcIdxTyInstDecl1 :: TyClDecl Name -> TcM (Maybe TyThing) -- Nothing if error
tcIdxTyInstDecl1 (decl@TySynonym {})
= kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
; t_typats <- mappM tcHsKindedType k_typats
; t_rhs <- tcHsKindedType k_rhs
- -- construct type rewrite rule
-- !!!of the form: forall t_tvs. (tcdLName decl) t_typats = t_rhs
- ; return (Nothing, Nothing) -- !!!TODO: need InstInfo for eq axioms
+ ; return Nothing -- !!!TODO: need TyThing for indexed synonym
}}
tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
})
-- construct result
- ; return (Nothing, Just (ATyCon tycon))
+ ; return $ Just (ATyCon tycon)
}}
where
h98_syntax = case cons of -- All constructors have same shape
{ ctxt' <- tcHsKindedContext ctxt
; (univ_tvs, ex_tvs, eq_preds, data_tc) <- tcResultType tycon tc_tvs tvs' res_ty
; let
+ -- Tiresome: tidy the tyvar binders, since tc_tvs and tvs' may have the same OccNames
tc_datacon is_infix field_lbls btys
= do { let bangs = map getBangStrictness btys
; arg_tys <- mappM tcHsBangType btys
-> [TyVar] -- where MkT :: forall a b c. ...
-> ResType Name
-> TcM ([TyVar], -- Universal
- [TyVar], -- Existential
+ [TyVar], -- Existential (distinct OccNames from univs)
[(TyVar,Type)], -- Equality predicates
TyCon) -- TyCon given in the ResTy
-- We don't check that the TyCon given in the ResTy is
-- ([a,z,c], [x,y], [a:=:(x,y), c:=:z], T)
= do { (dc_tycon, res_tys) <- tcLHsConResTy res_ty
- -- NB: tc_tvs and dc_tvs are distinct
- ; let univ_tvs = choose_univs [] tc_tvs res_tys
+
+ ; let univ_tvs = choose_univs [] tidy_tc_tvs res_tys
-- Each univ_tv is either a dc_tv or a tc_tv
ex_tvs = dc_tvs `minusList` univ_tvs
eq_spec = [ (tv, ty) | (tv,ty) <- univ_tvs `zip` res_tys,
| otherwise
= tc_tv : choose_univs used tc_tvs res_tys
--------------------
+ -- NB: tc_tvs and dc_tvs are distinct, but
+ -- we want them to be *visibly* distinct, both for
+ -- interface files and general confusion. So rename
+ -- the tc_tvs, since they are not used yet (no
+ -- consequential renaming needed)
+ init_occ_env = initTidyOccEnv (map getOccName dc_tvs)
+ (_, tidy_tc_tvs) = mapAccumL tidy_one init_occ_env tc_tvs
+ tidy_one env tv = (env', setTyVarName tv (tidyNameOcc name occ'))
+ where
+ name = tyVarName tv
+ (env', occ') = tidyOccName env (getOccName name)
+
+ -------------------
argStrictness :: Bool -- True <=> -funbox-strict_fields
-> TyCon -> [HsBang]
-> [TcType] -> [StrictnessMark]
projects / ghc-hetmet.git / blobdiff