diff options
Diffstat (limited to 'compiler')
45 files changed, 1461 insertions, 1374 deletions
diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index c2cf0bfcdd..e08bc67241 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -42,12 +42,18 @@ module DataCon ( -- * Splitting product types splitProductType_maybe, splitProductType, deepSplitProductType, - deepSplitProductType_maybe + deepSplitProductType_maybe, + + -- ** Promotion related functions + promoteType, isPromotableType, isPromotableTyCon, + buildPromotedTyCon, buildPromotedDataCon, ) where #include "HsVersions.h" import Type +import TypeRep( Type(..) ) -- Used in promoteType +import Kind import Unify import Coercion import TyCon @@ -61,6 +67,7 @@ import Util import BasicTypes import FastString import Module +import VarEnv import qualified Data.Data as Data import qualified Data.Typeable @@ -959,4 +966,86 @@ computeRep stricts tys where (_tycon, _tycon_args, arg_dc, arg_tys) = deepSplitProductType "unbox_strict_arg_ty" ty -\end{code}
\ No newline at end of file +\end{code} + + +%************************************************************************ +%* * + Promoting of data types to the kind level +%* * +%************************************************************************ + +These two 'buildPromoted..' functions are here because + * They belong together + * 'buildPromotedTyCon' is used by promoteType + * 'buildPromotedTyCon' depends on DataCon stuff + +\begin{code} +buildPromotedTyCon :: TyCon -> TyCon +buildPromotedTyCon tc + = mkPromotedTyCon tc tySuperKind + +buildPromotedDataCon :: DataCon -> TyCon +buildPromotedDataCon dc + = ASSERT ( isPromotableType ty ) + mkPromotedDataTyCon dc (getName dc) (getUnique dc) kind arity + where + ty = dataConUserType dc + kind = promoteType ty + arity = dataConSourceArity dc +\end{code} + +Note [Promoting a Type to a Kind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppsoe we have a data constructor D + D :: forall (a:*). Maybe a -> T a +We promote this to be a type constructor 'D: + 'D :: forall (k:BOX). 'Maybe k -> 'T k + +The transformation from type to kind is done by promoteType + + * Convert forall (a:*) to forall (k:BOX), and substitute + + * Ensure all foralls are at the top (no higher rank stuff) + + * Ensure that all type constructors mentioned (Maybe and T + in the example) are promotable; that is, they have kind + * -> ... -> * -> * + +\begin{code} +isPromotableType :: Type -> Bool +isPromotableType ty + = all (isLiftedTypeKind . tyVarKind) tvs + && go rho + where + (tvs, rho) = splitForAllTys ty + go (TyConApp tc tys) | Just n <- isPromotableTyCon tc + = tys `lengthIs` n && all go tys + go (FunTy arg res) = go arg && go res + go (TyVarTy tvar) = tvar `elem` tvs + go _ = False + +-- If tc's kind is [ *^n -> * ] returns [ Just n ], else returns [ Nothing ] +isPromotableTyCon :: TyCon -> Maybe Int +isPromotableTyCon tc + | all isLiftedTypeKind (res:args) = Just $ length args + | otherwise = Nothing + where + (args, res) = splitKindFunTys (tyConKind tc) + +-- | Promotes a type to a kind. +-- Assumes the argument satisfies 'isPromotableType' +promoteType :: Type -> Kind +promoteType ty + = mkForAllTys kvs (go rho) + where + (tvs, rho) = splitForAllTys ty + kvs = [ mkKindVar (tyVarName tv) tySuperKind | tv <- tvs ] + env = zipVarEnv tvs kvs + + go (TyConApp tc tys) = mkTyConApp (buildPromotedTyCon tc) (map go tys) + go (FunTy arg res) = mkArrowKind (go arg) (go res) + go (TyVarTy tv) | Just kv <- lookupVarEnv env tv + = TyVarTy kv + go _ = panic "promoteType" -- Argument did not satisfy isPromotableType +\end{code} diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index 6f6e58b25b..f62d519bbb 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -664,31 +664,33 @@ lintInTy ty ; lintKind k ; return ty' } -lintInCo :: InCoercion -> LintM OutCoercion --- Check the coercion, and apply the substitution to it --- See Note [Linting type lets] -lintInCo co - = addLoc (InCo co) $ - do { co' <- applySubstCo co - ; _ <- lintCoercion co' - ; return co' } - ------------------- lintKind :: OutKind -> LintM () -- Check well-formedness of kinds: *, *->*, Either * (* -> *), etc +lintKind (TyVarTy kv) + = do { checkTyCoVarInScope kv + ; unless (isSuperKind (varType kv)) + (addErrL (hang (ptext (sLit "Badly kinded kind variable")) + 2 (ppr kv <+> dcolon <+> ppr (varType kv)))) } + lintKind (FunTy k1 k2) - = lintKind k1 >> lintKind k2 + = do { lintKind k1; lintKind k2 } lintKind kind@(TyConApp tc kis) - = do { unless (isSuperKindTyCon tc || tyConArity tc == length kis) - (addErrL malformed_kind) - ; mapM_ lintKind kis } - where - malformed_kind = hang (ptext (sLit "Malformed kind:")) 2 (quotes (ppr kind)) + | not (isSuperKind (tyConKind tc)) + = addErrL (hang (ptext (sLit "Type constructor") <+> quotes (ppr tc)) + 2 (ptext (sLit "cannot be used in a kind"))) + + | not (tyConArity tc == length kis) + = addErrL (hang (ptext (sLit "Unsaturated ype constructor in kind")) + 2 (quotes (ppr kind))) + + | otherwise + = mapM_ lintKind kis -lintKind (TyVarTy kv) = checkTyCoVarInScope kv lintKind kind - = addErrL (hang (ptext (sLit "Malformed kind:")) 2 (quotes (ppr kind))) + = addErrL (hang (ptext (sLit "Malformed kind:")) + 2 (quotes (ppr kind))) ------------------- lintTyBndrKind :: OutTyVar -> LintM () @@ -699,16 +701,128 @@ lintTyBndrKind tv = then return () -- kind forall else lintKind ki -- type forall +---------- +checkTcApp :: OutCoercion -> Int -> Type -> LintM OutType +checkTcApp co n ty + | Just tys <- tyConAppArgs_maybe ty + , n < length tys + = return (tys !! n) + | otherwise + = failWithL (hang (ptext (sLit "Bad getNth:") <+> ppr co) + 2 (ptext (sLit "Offending type:") <+> ppr ty)) + ------------------- +lintType :: OutType -> LintM Kind +-- The returned Kind has itself been linted +lintType (TyVarTy tv) + = do { checkTyCoVarInScope tv + ; let kind = tyVarKind tv + ; lintKind kind + ; WARN( isSuperKind kind, msg ) + return kind } + where msg = hang (ptext (sLit "Expecting a type, but got a kind")) + 2 (ptext (sLit "Offending kind:") <+> ppr tv) + +lintType ty@(AppTy t1 t2) + = do { k1 <- lintType t1 + ; lint_ty_app ty k1 [t2] } + +lintType ty@(FunTy t1 t2) + = lint_ty_app ty (mkArrowKinds [argTypeKind, openTypeKind] liftedTypeKind) [t1,t2] + +lintType ty@(TyConApp tc tys) + | tyConHasKind tc -- Guards for SuperKindOon + , not (isUnLiftedTyCon tc) || tys `lengthIs` tyConArity tc + -- Check that primitive types are saturated + -- See Note [The kind invariant] in TypeRep + = lint_ty_app ty (tyConKind tc) tys + | otherwise + = failWithL (hang (ptext (sLit "Malformed type:")) 2 (ppr ty)) + +lintType (ForAllTy tv ty) + = do { lintTyBndrKind tv + ; addInScopeVar tv (lintType ty) } + +lintType ty@(LitTy l) = lintTyLit l >> return (typeKind ty) + +---------------- +lint_ty_app :: Type -> Kind -> [OutType] -> LintM Kind +lint_ty_app ty k tys + = lint_kind_app (ptext (sLit "type") <+> quotes (ppr ty)) k tys + +---------------- +lint_co_app :: Coercion -> Kind -> [OutType] -> LintM () +lint_co_app ty k tys + = do { _ <- lint_kind_app (ptext (sLit "coercion") <+> quotes (ppr ty)) k tys + ; return () } + +---------------- +lintTyLit :: TyLit -> LintM () +lintTyLit (NumTyLit n) + | n >= 0 = return () + | otherwise = failWithL msg + where msg = ptext (sLit "Negative type literal:") <+> integer n +lintTyLit (StrTyLit _) = return () + +---------------- +lint_kind_app :: SDoc -> Kind -> [OutType] -> LintM Kind +-- (lint_kind_app d fun_kind arg_tys) +-- We have an application (f arg_ty1 .. arg_tyn), +-- where f :: fun_kind +-- Takes care of linting the OutTypes +lint_kind_app doc kfn tys = go kfn tys + where + fail_msg = vcat [ hang (ptext (sLit "Kind application error in")) 2 doc + , nest 2 (ptext (sLit "Function kind =") <+> ppr kfn) + , nest 2 (ptext (sLit "Arg types =") <+> ppr tys) ] + + go kfn [] = return kfn + go kfn (ty:tys) = + case splitKindFunTy_maybe kfn of + { Nothing -> + case splitForAllTy_maybe kfn of + { Nothing -> failWithL fail_msg + ; Just (kv, body) -> do + -- Something of kind (forall kv. body) gets instantiated + -- with ty. 'kv' is a kind variable and 'ty' is a kind. + { unless (isSuperKind (tyVarKind kv)) (addErrL fail_msg) + ; lintKind ty + ; go (substKiWith [kv] [ty] body) tys } } + ; Just (kfa, kfb) -> do + -- Something of kind (kfa -> kfb) is applied to ty. 'ty' is + -- a type accepting kind 'kfa'. + { k <- lintType ty + ; lintKind kfa + ; unless (k `isSubKind` kfa) (addErrL fail_msg) + ; go kfb tys } } + +\end{code} + +%************************************************************************ +%* * + Linting coercions +%* * +%************************************************************************ + +\begin{code} +lintInCo :: InCoercion -> LintM OutCoercion +-- Check the coercion, and apply the substitution to it +-- See Note [Linting type lets] +lintInCo co + = addLoc (InCo co) $ + do { co' <- applySubstCo co + ; _ <- lintCoercion co' + ; return co' } + lintKindCoercion :: OutCoercion -> LintM OutKind -- Kind coercions are only reflexivity because they mean kind -- instantiation. See Note [Kind coercions] in Coercion +lintKindCoercion (Refl k) + = do { lintKind k + ; return k } lintKindCoercion co - = do { (k1,k2) <- lintCoercion co - ; checkL (k1 `eqKind` k2) - (hang (ptext (sLit "Non-refl kind coercion")) - 2 (ppr co)) - ; return k1 } + = failWithL (hang (ptext (sLit "Non-refl kind coercion")) + 2 (ppr co)) lintCoercion :: OutCoercion -> LintM (OutType, OutType) -- Check the kind of a coercion term, returning the kind @@ -732,14 +846,14 @@ lintCoercion co@(TyConAppCo tc cos) -- kis are the kind instantiations of tc ; kis <- mapM lintKindCoercion cokis ; (ss,ts) <- mapAndUnzipM lintCoercion cotys - ; check_co_app co ki (kis ++ ss) + ; lint_co_app co ki (kis ++ ss) ; return (mkTyConApp tc (kis ++ ss), mkTyConApp tc (kis ++ ts)) } lintCoercion co@(AppCo co1 co2) = do { (s1,t1) <- lintCoercion co1 ; (s2,t2) <- lintCoercion co2 - ; check_co_app co (typeKind s1) [s2] + ; lint_co_app co (typeKind s1) [s2] ; return (mkAppTy s1 s2, mkAppTy t1 t2) } lintCoercion (ForAllCo v co) @@ -808,97 +922,6 @@ lintCoercion (InstCo co arg_ty) | otherwise -> failWithL (ptext (sLit "Kind mis-match in inst coercion")) Nothing -> failWithL (ptext (sLit "Bad argument of inst")) } - ----------- -checkTcApp :: OutCoercion -> Int -> Type -> LintM OutType -checkTcApp co n ty - | Just tys <- tyConAppArgs_maybe ty - , n < length tys - = return (tys !! n) - | otherwise - = failWithL (hang (ptext (sLit "Bad getNth:") <+> ppr co) - 2 (ptext (sLit "Offending type:") <+> ppr ty)) - -------------------- -lintType :: OutType -> LintM Kind -lintType (TyVarTy tv) - = do { checkTyCoVarInScope tv - ; let kind = tyVarKind tv - ; lintKind kind - ; WARN( isSuperKind kind, msg ) - return kind } - where msg = hang (ptext (sLit "Expecting a type, but got a kind")) - 2 (ptext (sLit "Offending kind:") <+> ppr tv) - -lintType ty@(AppTy t1 t2) - = do { k1 <- lintType t1 - ; lint_ty_app ty k1 [t2] } - -lintType ty@(FunTy t1 t2) - = lint_ty_app ty (mkArrowKinds [argTypeKind, openTypeKind] liftedTypeKind) [t1,t2] - -lintType ty@(TyConApp tc tys) - | tyConHasKind tc -- Guards for SuperKindOon - , not (isUnLiftedTyCon tc) || tys `lengthIs` tyConArity tc - -- Check that primitive types are saturated - -- See Note [The kind invariant] in TypeRep - = lint_ty_app ty (tyConKind tc) tys - | otherwise - = failWithL (hang (ptext (sLit "Malformed type:")) 2 (ppr ty)) - -lintType ty@(LitTy l) = lintTyLit l >> return (typeKind ty) - -lintType (ForAllTy tv ty) - = do { lintTyBndrKind tv - ; addInScopeVar tv (lintType ty) } - ---- - -lintTyLit :: TyLit -> LintM () -lintTyLit (NumTyLit n) - | n >= 0 = return () - | otherwise = failWithL msg - where msg = ptext (sLit "Negative type literal:") <+> integer n -lintTyLit (StrTyLit _) = return () - - ----------------- -lint_ty_app :: Type -> Kind -> [OutType] -> LintM Kind -lint_ty_app ty k tys = lint_kind_app (ptext (sLit "type") <+> quotes (ppr ty)) k tys - ----------------- -check_co_app :: Coercion -> Kind -> [OutType] -> LintM () -check_co_app ty k tys = lint_kind_app (ptext (sLit "coercion") <+> quotes (ppr ty)) k tys >> return () - ----------------- -lint_kind_app :: SDoc -> Kind -> [OutType] -> LintM Kind --- Takes care of linting the OutTypes -lint_kind_app doc kfn tys = go kfn tys - where - fail_msg = vcat [ hang (ptext (sLit "Kind application error in")) 2 doc - , nest 2 (ptext (sLit "Function kind =") <+> ppr kfn) - , nest 2 (ptext (sLit "Arg types =") <+> ppr tys) ] - - go kfn [] = return kfn - go kfn (ty:tys) = - case splitKindFunTy_maybe kfn of - { Nothing -> - case splitForAllTy_maybe kfn of - { Nothing -> failWithL fail_msg - ; Just (kv, body) -> do - -- Something of kind (forall kv. body) gets instantiated - -- with ty. 'kv' is a kind variable and 'ty' is a kind. - { unless (isSuperKind (tyVarKind kv)) (addErrL fail_msg) - ; lintKind ty - ; go (substKiWith [kv] [ty] body) tys } } - ; Just (kfa, kfb) -> do - -- Something of kind (kfa -> kfb) is applied to ty. 'ty' is - -- a type accepting kind 'kfa'. - { k <- lintType ty - ; lintKind kfa - ; unless (k `isSubKind` kfa) (addErrL fail_msg) - ; go kfb tys } } - \end{code} %************************************************************************ diff --git a/compiler/deSugar/DsExpr.lhs-boot b/compiler/deSugar/DsExpr.lhs-boot index 2a6d09b48e..03a47ed41b 100644 --- a/compiler/deSugar/DsExpr.lhs-boot +++ b/compiler/deSugar/DsExpr.lhs-boot @@ -1,16 +1,9 @@ \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module DsExpr where -import HsSyn ( HsExpr, LHsExpr, HsLocalBinds ) -import Var ( Id ) -import DsMonad ( DsM ) -import CoreSyn ( CoreExpr ) +import HsSyn ( HsExpr, LHsExpr, HsLocalBinds ) +import Var ( Id ) +import DsMonad ( DsM ) +import CoreSyn ( CoreExpr ) dsExpr :: HsExpr Id -> DsM CoreExpr dsLExpr :: LHsExpr Id -> DsM CoreExpr diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 103f70f9e7..4105a9e56c 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -129,10 +129,12 @@ repTopDs group decls <- addBinds ss (do { val_ds <- rep_val_binds (hs_valds group) ; tycl_ds <- mapM repTyClD (concat (hs_tyclds group)) ; - inst_ds <- mapM repInstD' (hs_instds group) ; + inst_ds <- mapM repInstD (hs_instds group) ; for_ds <- mapM repForD (hs_fords group) ; -- more needed - return (de_loc $ sort_by_loc $ val_ds ++ catMaybes tycl_ds ++ inst_ds ++ for_ds) }) ; + return (de_loc $ sort_by_loc $ + val_ds ++ catMaybes tycl_ds + ++ catMaybes inst_ds ++ for_ds) }) ; decl_ty <- lookupType decQTyConName ; let { core_list = coreList' decl_ty decls } ; @@ -307,8 +309,12 @@ repLAssocFamInst = liftM de_loc . mapMaybeM repTyClD -- represent instance declarations -- -repInstD' :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ) -repInstD' (L loc (InstDecl ty binds _ ats)) -- Ignore user pragmas for now +repInstD :: LInstDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ)) +repInstD (L loc (FamInstDecl fi_decl)) + = repTyClD (L loc fi_decl) + + +repInstD (L loc (ClsInstDecl ty binds _ ats)) -- Ignore user pragmas for now = do { dec <- addTyVarBinds tvs $ \_ -> -- We must bring the type variables into scope, so their -- occurrences don't fail, even though the binders don't @@ -327,7 +333,7 @@ repInstD' (L loc (InstDecl ty binds _ ats)) -- Ignore user pragmas for now ; ats1 <- repLAssocFamInst ats ; decls <- coreList decQTyConName (ats1 ++ binds1) ; repInst cxt1 inst_ty1 decls } - ; return (loc, dec) } + ; return (Just (loc, dec)) } where Just (tvs, cxt, cls, tys) = splitHsInstDeclTy_maybe (unLoc ty) diff --git a/compiler/deSugar/Match.lhs-boot b/compiler/deSugar/Match.lhs-boot index 31ee36b6e6..d10cda961e 100644 --- a/compiler/deSugar/Match.lhs-boot +++ b/compiler/deSugar/Match.lhs-boot @@ -1,42 +1,35 @@ \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module Match where -import Var ( Id ) -import TcType ( Type ) -import DsMonad ( DsM, EquationInfo, MatchResult ) -import CoreSyn ( CoreExpr ) -import HsSyn ( LPat, HsMatchContext, MatchGroup ) -import Name ( Name ) +import Var ( Id ) +import TcType ( Type ) +import DsMonad ( DsM, EquationInfo, MatchResult ) +import CoreSyn ( CoreExpr ) +import HsSyn ( LPat, HsMatchContext, MatchGroup ) +import Name ( Name ) -match :: [Id] +match :: [Id] -> Type - -> [EquationInfo] - -> DsM MatchResult + -> [EquationInfo] + -> DsM MatchResult matchWrapper - :: HsMatchContext Name + :: HsMatchContext Name -> MatchGroup Id - -> DsM ([Id], CoreExpr) + -> DsM ([Id], CoreExpr) matchSimply - :: CoreExpr - -> HsMatchContext Name - -> LPat Id - -> CoreExpr - -> CoreExpr - -> DsM CoreExpr + :: CoreExpr + -> HsMatchContext Name + -> LPat Id + -> CoreExpr + -> CoreExpr + -> DsM CoreExpr matchSinglePat - :: CoreExpr - -> HsMatchContext Name - -> LPat Id + :: CoreExpr + -> HsMatchContext Name + -> LPat Id -> Type - -> MatchResult - -> DsM MatchResult + -> MatchResult + -> DsM MatchResult \end{code} diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 51ae1542e3..3bb2f5cfc4 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -62,7 +62,7 @@ Library Build-Depends: base < 3 if flag(stage1) && impl(ghc < 7.5) - Build-Depends: old-time >= 1 && < 1.1 + Build-Depends: old-time >= 1 && < 1.2 if flag(base3) || flag(base4) Build-Depends: directory >= 1 && < 1.2, @@ -70,9 +70,9 @@ Library bytestring >= 0.9 && < 0.10, time < 1.5, containers >= 0.1 && < 0.5, - array >= 0.1 && < 0.4 + array >= 0.1 && < 0.5 - Build-Depends: filepath >= 1 && < 1.3 + Build-Depends: filepath >= 1 && < 1.4 Build-Depends: Cabal, hpc if os(windows) Build-Depends: Win32 diff --git a/compiler/ghc.mk b/compiler/ghc.mk index 8790df361e..e305b36a8e 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -150,6 +150,10 @@ $(eval $(call clean-target,compiler,config_hs,compiler/main/Config.hs)) PLATFORM_H = ghc_boot_platform.h +ifeq "$(BuildingCrossCompiler)" "YES" +compiler/stage1/$(PLATFORM_H) : compiler/stage2/$(PLATFORM_H) + cp $< $@ +else compiler/stage1/$(PLATFORM_H) : mk/config.mk mk/project.mk | $$(dir $$@)/. $(call removeFiles,$@) @echo "Creating $@..." @@ -192,6 +196,7 @@ endif @echo >> $@ @echo "#endif /* __PLATFORM_H__ */" >> $@ @echo "Done." +endif # For stage2 and above, the BUILD platform is the HOST of stage1, and # the HOST platform is the TARGET of stage1. The TARGET remains the same @@ -489,13 +494,6 @@ $(eval $(call compiler-hs-dependency,PrimOp,$(PRIMOP_BITS))) compiler/prelude/PrimOp_HC_OPTS += -fforce-recomp compiler/main/Constants_HC_OPTS += -fforce-recomp -# Workaround for #4003 in GHC 6.12.2. It didn't happen in 6.12.1, and -# will be fixed in 6.12.3. Unfortunately we don't have a way to do -# this for just stage1 in the build system. -ifeq "$(GhcVersion)" "6.12.2" -compiler/hsSyn/HsLit_HC_OPTS += -fomit-interface-pragmas -endif - # LibFFI.hs #includes ffi.h compiler/stage2/build/LibFFI.hs : $(libffi_HEADERS) # On Windows it seems we also need to link directly to libffi diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 4292a112ff..5318c5be49 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -195,7 +195,7 @@ cvtDec (InstanceD ctxt ty decs) ; ctxt' <- cvtContext ctxt ; L loc ty' <- cvtType ty ; let inst_ty' = L loc $ mkImplicitHsForAllTy ctxt' $ L loc ty' - ; returnL $ InstD (InstDecl inst_ty' binds' sigs' ats') } + ; returnL $ InstD (ClsInstDecl inst_ty' binds' sigs' ats') } cvtDec (ForeignD ford) = do { ford' <- cvtForD ford @@ -213,23 +213,25 @@ cvtDec (DataInstD ctxt tc tys constrs derivs) = do { (ctxt', tc', tvs', typats') <- cvt_tyinst_hdr ctxt tc tys ; cons' <- mapM cvtConstr constrs ; derivs' <- cvtDerivs derivs - ; returnL $ TyClD (TyData { tcdND = DataType, tcdLName = tc', tcdCtxt = ctxt' - , tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing - , tcdCons = cons', tcdDerivs = derivs' }) } + ; returnL $ InstD $ FamInstDecl $ + TyData { tcdND = DataType, tcdLName = tc', tcdCtxt = ctxt' + , tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing + , tcdCons = cons', tcdDerivs = derivs' } } cvtDec (NewtypeInstD ctxt tc tys constr derivs) = do { (ctxt', tc', tvs', typats') <- cvt_tyinst_hdr ctxt tc tys ; con' <- cvtConstr constr ; derivs' <- cvtDerivs derivs - ; returnL $ TyClD (TyData { tcdND = NewType, tcdLName = tc', tcdCtxt = ctxt' - , tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing - , tcdCons = [con'], tcdDerivs = derivs' }) - } + ; returnL $ InstD $ FamInstDecl $ + TyData { tcdND = NewType, tcdLName = tc', tcdCtxt = ctxt' + , tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing + , tcdCons = [con'], tcdDerivs = derivs' } } cvtDec (TySynInstD tc tys rhs) = do { (_, tc', tvs', tys') <- cvt_tyinst_hdr [] tc tys ; rhs' <- cvtType rhs - ; returnL $ TyClD (TySynonym tc' tvs' tys' rhs') } + ; returnL $ InstD $ FamInstDecl $ + TySynonym tc' tvs' tys' rhs' } ---------------- cvt_ci_decs :: MsgDoc -> [TH.Dec] diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index f8e6bc0e9d..e6d369c519 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -18,9 +18,11 @@ module HsDecls ( isClassDecl, isSynDecl, isDataDecl, isTypeDecl, isFamilyDecl, isFamInstDecl, tcdName, tyClDeclTyVars, countTyClDecls, + -- ** Instance declarations InstDecl(..), LInstDecl, NewOrData(..), FamilyFlavour(..), - instDeclATs, + FamInstDecl, LFamInstDecl, instDeclFamInsts, + -- ** Standalone deriving declarations DerivDecl(..), LDerivDecl, -- ** @RULE@ declarations @@ -128,12 +130,15 @@ data HsGroup id = HsGroup { hs_valds :: HsValBinds id, - hs_tyclds :: [[LTyClDecl id]], + hs_tyclds :: [[LTyClDecl id]], -- A list of mutually-recursive groups + -- No family-instances here; they are in hs_instds -- Parser generates a singleton list; -- renamer does dependency analysis - hs_instds :: [LInstDecl id], + hs_instds :: [LInstDecl id], + -- Both class and family instance declarations in here + hs_derivds :: [LDerivDecl id], hs_fixds :: [LFixitySig id], @@ -154,7 +159,8 @@ emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn } emptyRnGroup = emptyGroup { hs_valds = emptyValBindsOut } -emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [], hs_derivds = [], +emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [], + hs_derivds = [], hs_fixds = [], hs_defds = [], hs_annds = [], hs_fords = [], hs_warnds = [], hs_ruleds = [], hs_vects = [], hs_valds = error "emptyGroup hs_valds: Can't happen", @@ -430,8 +436,9 @@ Interface file code: -- In both cases, 'tcdVars' collects all variables we need to quantify over. type LTyClDecl name = Located (TyClDecl name) -type TyClGroup name = [LTyClDecl name] -- this is used in TcTyClsDecls to represent +type TyClGroup name = [LTyClDecl name] -- This is used in TcTyClsDecls to represent -- strongly connected components of decls + -- No familiy instances in here -- | A type or class declaration. data TyClDecl name @@ -504,7 +511,7 @@ data TyClDecl name tcdMeths :: LHsBinds name, -- ^ Default methods tcdATs :: [LTyClDecl name], -- ^ Associated types; ie -- only 'TyFamily' - tcdATDefs :: [LTyClDecl name], -- ^ Associated type defaults; ie + tcdATDefs :: [LFamInstDecl name], -- ^ Associated type defaults; ie -- only 'TySynonym' tcdDocs :: [LDocDecl] -- ^ Haddock docs } @@ -602,15 +609,14 @@ tyClDeclTyVars (ForeignType {}) = [] \end{code} \begin{code} -countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int, Int, Int) - -- class, synonym decls, data, newtype, family decls, family instances +countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int, Int) + -- class, synonym decls, data, newtype, family decls countTyClDecls decls = (count isClassDecl decls, count isSynDecl decls, -- excluding... count isDataTy decls, -- ...family... count isNewTy decls, -- ...instances - count isFamilyDecl decls, - count isFamInstDecl decls) + count isFamilyDecl decls) where isDataTy TyData{tcdND = DataType, tcdTyPats = Nothing} = True isDataTy _ = False @@ -833,18 +839,25 @@ pprConDecl (ConDecl {con_name = con, con_details = InfixCon {}, con_res = ResTyG \begin{code} type LInstDecl name = Located (InstDecl name) -data InstDecl name - = InstDecl (LHsType name) -- Context => Class Instance-type - -- Using a polytype means that the renamer conveniently - -- figures out the quantified type variables for us. - (LHsBinds name) - [LSig name] -- User-supplied pragmatic info - [LTyClDecl name]-- Associated types (ie, 'TyData' and - -- 'TySynonym' only) +type LFamInstDecl name = Located (FamInstDecl name) +type FamInstDecl name = TyClDecl name -- Type or data family instance + +data InstDecl name -- Both class and family instances + = ClsInstDecl + (LHsType name) -- Context => Class Instance-type + -- Using a polytype means that the renamer conveniently + -- figures out the quantified type variables for us. + (LHsBinds name) + [LSig name] -- User-supplied pragmatic info + [LFamInstDecl name] -- Family instances for associated types + + | FamInstDecl -- type/data family instance + (FamInstDecl name) + deriving (Data, Typeable) instance (OutputableBndr name) => Outputable (InstDecl name) where - ppr (InstDecl inst_ty binds sigs ats) + ppr (ClsInstDecl inst_ty binds sigs ats) | null sigs && null ats && isEmptyBag binds -- No "where" part = top_matter @@ -855,10 +868,16 @@ instance (OutputableBndr name) => Outputable (InstDecl name) where where top_matter = ptext (sLit "instance") <+> ppr inst_ty + ppr (FamInstDecl decl) = ppr decl + -- Extract the declarations of associated types from an instance --- -instDeclATs :: [LInstDecl name] -> [LTyClDecl name] -instDeclATs inst_decls = [at | L _ (InstDecl _ _ _ ats) <- inst_decls, at <- ats] + +instDeclFamInsts :: [LInstDecl name] -> [LTyClDecl name] +instDeclFamInsts inst_decls + = concatMap do_one inst_decls + where + do_one (L _ (ClsInstDecl _ _ _ fam_insts)) = fam_insts + do_one (L loc (FamInstDecl fam_inst)) = [L loc fam_inst] \end{code} %************************************************************************ diff --git a/compiler/hsSyn/HsExpr.lhs-boot b/compiler/hsSyn/HsExpr.lhs-boot index 6666243264..86032f5829 100644 --- a/compiler/hsSyn/HsExpr.lhs-boot +++ b/compiler/hsSyn/HsExpr.lhs-boot @@ -1,15 +1,8 @@ \begin{code} {-# LANGUAGE KindSignatures #-} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module HsExpr where -import SrcLoc ( Located ) +import SrcLoc ( Located ) import Outputable ( SDoc, OutputableBndr ) import {-# SOURCE #-} HsPat ( LPat ) @@ -34,17 +27,17 @@ type LHsExpr a = Located (HsExpr a) type SyntaxExpr a = HsExpr a pprLExpr :: (OutputableBndr i) => - LHsExpr i -> SDoc + LHsExpr i -> SDoc pprExpr :: (OutputableBndr i) => - HsExpr i -> SDoc + HsExpr i -> SDoc pprSplice :: (OutputableBndr i) => - HsSplice i -> SDoc + HsSplice i -> SDoc pprPatBind :: (OutputableBndr b, OutputableBndr i) => - LPat b -> GRHSs i -> SDoc + LPat b -> GRHSs i -> SDoc pprFunBind :: (OutputableBndr idL, OutputableBndr idR) => - idL -> Bool -> MatchGroup idR -> SDoc + idL -> Bool -> MatchGroup idR -> SDoc \end{code} diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 3527d9139e..293f5b05a6 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -68,7 +68,7 @@ module HsUtils( collectLStmtBinders, collectStmtBinders, collectSigTysFromPats, collectSigTysFromPat, - hsTyClDeclBinders, hsTyClDeclsBinders, + hsLTyClDeclBinders, hsTyClDeclBinders, hsTyClDeclsBinders, hsForeignDeclsBinders, hsGroupBinders, -- Collecting implicit binders @@ -619,29 +619,33 @@ hsForeignDeclsBinders foreign_decls = [n | L _ (ForeignImport (L _ n) _ _ _) <- foreign_decls] hsTyClDeclsBinders :: [[LTyClDecl Name]] -> [Located (InstDecl Name)] -> [Name] +-- We need to look at instance declarations too, +-- because their associated types may bind data constructors hsTyClDeclsBinders tycl_decls inst_decls - = [n | d <- instDeclATs inst_decls ++ concat tycl_decls - , L _ n <- hsTyClDeclBinders d] + = [n | d <- instDeclFamInsts inst_decls ++ concat tycl_decls + , L _ n <- hsLTyClDeclBinders d] -hsTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name] +hsLTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name] -- ^ Returns all the /binding/ names of the decl, along with their SrcLocs. -- The first one is guaranteed to be the name of the decl. For record fields -- mentioned in multiple constructors, the SrcLoc will be from the first -- occurence. We use the equality to filter out duplicate field names +hsLTyClDeclBinders (L _ d) = hsTyClDeclBinders d -hsTyClDeclBinders (L _ (TyFamily {tcdLName = name})) = [name] -hsTyClDeclBinders (L _ (ForeignType {tcdLName = name})) = [name] +hsTyClDeclBinders :: Eq name => TyClDecl name -> [Located name] +hsTyClDeclBinders (TyFamily {tcdLName = name}) = [name] +hsTyClDeclBinders (ForeignType {tcdLName = name}) = [name] -hsTyClDeclBinders (L _ (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats})) +hsTyClDeclBinders (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats}) = cls_name : - concatMap hsTyClDeclBinders ats ++ [n | L _ (TypeSig ns _) <- sigs, n <- ns] + concatMap hsLTyClDeclBinders ats ++ [n | L _ (TypeSig ns _) <- sigs, n <- ns] -hsTyClDeclBinders (L _ (TySynonym {tcdLName = name, tcdTyPats = mb_pats })) +hsTyClDeclBinders (TySynonym {tcdLName = name, tcdTyPats = mb_pats }) | isJust mb_pats = [] | otherwise = [name] -- See Note [Binders in family instances] -hsTyClDeclBinders (L _ (TyData {tcdLName = tc_name, tcdCons = cons, tcdTyPats = mb_pats })) +hsTyClDeclBinders (TyData {tcdLName = tc_name, tcdCons = cons, tcdTyPats = mb_pats }) | isJust mb_pats = hsConDeclsBinders cons | otherwise = tc_name : hsConDeclsBinders cons -- See Note [Binders in family instances] diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index 1ffabb4f73..75b8d91881 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -15,7 +15,6 @@ module BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, - buildPromotedDataTyCon, TcMethInfo, buildClass, distinctAbstractTyConRhs, totallyAbstractTyConRhs, mkNewTyConRhs, mkDataTyConRhs, @@ -35,13 +34,11 @@ import MkId import Class import TyCon import Type -import Kind ( promoteType, isPromotableType ) import Coercion import TcRnMonad import Util ( isSingleton ) import Outputable -import Unique ( getUnique ) \end{code} @@ -184,11 +181,6 @@ mkDataConStupidTheta tycon arg_tys univ_tvs arg_tyvars = tyVarsOfTypes arg_tys in_arg_tys pred = not $ isEmptyVarSet $ tyVarsOfType pred `intersectVarSet` arg_tyvars - -buildPromotedDataTyCon :: DataCon -> TyCon -buildPromotedDataTyCon dc = ASSERT ( isPromotableType ty ) - mkPromotedDataTyCon dc (getName dc) (getUnique dc) (promoteType ty) - where ty = dataConUserType dc \end{code} diff --git a/compiler/llvmGen/Llvm.hs b/compiler/llvmGen/Llvm.hs index b15b6f261d..32df9e3217 100644 --- a/compiler/llvmGen/Llvm.hs +++ b/compiler/llvmGen/Llvm.hs @@ -20,6 +20,9 @@ module Llvm ( LlvmBlocks, LlvmBlock(..), LlvmBlockId, LlvmParamAttr(..), LlvmParameter, + -- * Fence synchronization + LlvmSyncOrdering(..), + -- * Call Handling LlvmCallConvention(..), LlvmCallType(..), LlvmParameterListType(..), LlvmLinkageType(..), LlvmFuncAttr(..), diff --git a/compiler/llvmGen/Llvm/AbsSyn.hs b/compiler/llvmGen/Llvm/AbsSyn.hs index a28734b152..9133447331 100644 --- a/compiler/llvmGen/Llvm/AbsSyn.hs +++ b/compiler/llvmGen/Llvm/AbsSyn.hs @@ -62,8 +62,24 @@ data LlvmFunction = LlvmFunction { funcBody :: LlvmBlocks } -type LlvmFunctions = [LlvmFunction] - +type LlvmFunctions = [LlvmFunction] + +-- | LLVM ordering types for synchronization purposes. (Introduced in LLVM +-- 3.0). Please see the LLVM documentation for a better description. +data LlvmSyncOrdering + -- | Some partial order of operations exists. + = SyncUnord + -- | A single total order for operations at a single address exists. + | SyncMonotonic + -- | Acquire synchronization operation. + | SyncAcquire + -- | Release synchronization operation. + | SyncRelease + -- | Acquire + Release synchronization operation. + | SyncAcqRel + -- | Full sequential Consistency operation. + | SyncSeqCst + deriving (Show, Eq) -- | Llvm Statements data LlvmStatement @@ -75,6 +91,11 @@ data LlvmStatement = Assignment LlvmVar LlvmExpression {- | + Memory fence operation + -} + | Fence Bool LlvmSyncOrdering + + {- | Always branch to the target label -} | Branch LlvmVar diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs index 2945777f96..c2177782f2 100644 --- a/compiler/llvmGen/Llvm/PpLlvm.hs +++ b/compiler/llvmGen/Llvm/PpLlvm.hs @@ -211,6 +211,7 @@ ppLlvmStatement stmt = let ind = (text " " <>) in case stmt of Assignment dst expr -> ind $ ppAssignment dst (ppLlvmExpression expr) + Fence st ord -> ind $ ppFence st ord Branch target -> ind $ ppBranch target BranchIf cond ifT ifF -> ind $ ppBranchIf cond ifT ifF Comment comments -> ind $ ppLlvmComments comments @@ -301,6 +302,19 @@ ppCmpOp op left right = ppAssignment :: LlvmVar -> Doc -> Doc ppAssignment var expr = (text $ getName var) <+> equals <+> expr +ppFence :: Bool -> LlvmSyncOrdering -> Doc +ppFence st ord = + let singleThread = case st of True -> text "singlethread" + False -> empty + in text "fence" <+> singleThread <+> ppSyncOrdering ord + +ppSyncOrdering :: LlvmSyncOrdering -> Doc +ppSyncOrdering SyncUnord = text "unordered" +ppSyncOrdering SyncMonotonic = text "monotonic" +ppSyncOrdering SyncAcquire = text "acquire" +ppSyncOrdering SyncRelease = text "release" +ppSyncOrdering SyncAcqRel = text "acq_rel" +ppSyncOrdering SyncSeqCst = text "seq_cst" ppLoad :: LlvmVar -> Doc ppLoad var = text "load" <+> texts var diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index d5037828c7..059328f868 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -137,16 +137,15 @@ stmtToInstrs env stmt = case stmt of -> return (env, unitOL $ Return Nothing, []) --- | Foreign Calls -genCall :: LlvmEnv -> CmmCallTarget -> [HintedCmmFormal] -> [HintedCmmActual] - -> CmmReturnInfo -> UniqSM StmtData - --- Write barrier needs to be handled specially as it is implemented as an LLVM --- intrinsic function. -genCall env (CmmPrim MO_WriteBarrier) _ _ _ - | platformArch (getLlvmPlatform env) `elem` [ArchX86, ArchX86_64, ArchSPARC] - = return (env, nilOL, []) - | otherwise = do +-- | Memory barrier instruction for LLVM >= 3.0 +barrier :: LlvmEnv -> UniqSM StmtData +barrier env = do + let s = Fence False SyncSeqCst + return (env, unitOL s, []) + +-- | Memory barrier instruction for LLVM < 3.0 +oldBarrier :: LlvmEnv -> UniqSM StmtData +oldBarrier env = do let fname = fsLit "llvm.memory.barrier" let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc LMVoid FixedArgs (tysToParams [i1, i1, i1, i1, i1]) llvmFunAlign @@ -167,6 +166,18 @@ genCall env (CmmPrim MO_WriteBarrier) _ _ _ lmTrue :: LlvmVar lmTrue = mkIntLit i1 (-1) +-- | Foreign Calls +genCall :: LlvmEnv -> CmmCallTarget -> [HintedCmmFormal] -> [HintedCmmActual] + -> CmmReturnInfo -> UniqSM StmtData + +-- Write barrier needs to be handled specially as it is implemented as an LLVM +-- intrinsic function. +genCall env (CmmPrim MO_WriteBarrier) _ _ _ + | platformArch (getLlvmPlatform env) `elem` [ArchX86, ArchX86_64, ArchSPARC] + = return (env, nilOL, []) + | getLlvmVer env > 29 = barrier env + | otherwise = oldBarrier env + -- Handle popcnt function specifically since GHC only really has i32 and i64 -- types and things like Word8 are backed by an i32 and just present a logical -- i8 range. So we must handle conversions from i32 to i8 explicitly as LLVM diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index ac4df37ac8..747b0b8f71 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -1717,9 +1717,9 @@ package_flags = [ , Flag "ignore-package" (HasArg ignorePackage) , Flag "syslib" (HasArg (\s -> do exposePackage s deprecate "Use -package instead")) + , Flag "distrust-all-packages" (NoArg (setDynFlag Opt_DistrustAllPackages)) , Flag "trust" (HasArg trustPackage) , Flag "distrust" (HasArg distrustPackage) - , Flag "distrust-all-packages" (NoArg (setDynFlag Opt_DistrustAllPackages)) ] type TurnOnFlag = Bool -- True <=> we are turning the flag on diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index fc53d9d544..1fe9077046 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -84,6 +84,8 @@ import DsMeta ( templateHaskellNames ) import VarSet import VarEnv ( emptyTidyEnv ) import Panic + +import GHC.Exts #endif import Id @@ -1351,72 +1353,58 @@ myCoreToStg dflags this_mod prepd_binds = do %********************************************************************* -} {- -When the UnlinkedBCOExpr is linked you get an HValue of type - IO [HValue] -When you run it you get a list of HValues that should be -the same length as the list of names; add them to the ClosureEnv. - -A naked expression returns a singleton Name [it]. - - What you type The IO [HValue] that hscStmt returns - ------------- ------------------------------------ - let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...] - bindings: [x,y,...] - - pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...] - bindings: [x,y,...] - - expr (of IO type) ==> expr >>= \ v -> return [v] - [NB: result not printed] bindings: [it] - +When the UnlinkedBCOExpr is linked you get an HValue of type *IO [HValue]* When +you run it you get a list of HValues that should be the same length as the list +of names; add them to the ClosureEnv. - expr (of non-IO type, - result showable) ==> let v = expr in print v >> return [v] - bindings: [it] - - expr (of non-IO type, - result not showable) ==> error +A naked expression returns a singleton Name [it]. The stmt is lifted into the +IO monad as explained in Note [Interactively-bound Ids in GHCi] in TcRnDriver -} #ifdef GHCI -- | Compile a stmt all the way to an HValue, but don't run it -hscStmt :: HscEnv - -> String -- ^ The statement - -> IO (Maybe ([Id], HValue)) -- ^ 'Nothing' <==> empty statement - -- (or comment only), but no parse error +-- +-- We return Nothing to indicate an empty statement (or comment only), not a +-- parse error. +hscStmt :: HscEnv -> String -> IO (Maybe ([Id], IO [HValue])) hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<interactive>" 1 -- | Compile a stmt all the way to an HValue, but don't run it +-- +-- We return Nothing to indicate an empty statement (or comment only), not a +-- parse error. hscStmtWithLocation :: HscEnv -> String -- ^ The statement -> String -- ^ The source -> Int -- ^ Starting line - -> IO (Maybe ([Id], HValue)) -- ^ 'Nothing' <==> empty statement - -- (or comment only), but no parse error + -> IO (Maybe ([Id], IO [HValue])) hscStmtWithLocation hsc_env stmt source linenumber = runHsc hsc_env $ do maybe_stmt <- hscParseStmtWithLocation source linenumber stmt case maybe_stmt of Nothing -> return Nothing - -- The real stuff Just parsed_stmt -> do - -- Rename and typecheck it - let icontext = hsc_IC hsc_env - (ids, tc_expr) <- ioMsgMaybe $ - tcRnStmt hsc_env icontext parsed_stmt + let icntxt = hsc_IC hsc_env + rdr_env = ic_rn_gbl_env icntxt + type_env = mkTypeEnvWithImplicits (ic_tythings icntxt) + src_span = srcLocSpan interactiveSrcLoc + + -- Rename and typecheck it + -- Here we lift the stmt into the IO monad, see Note + -- [Interactively-bound Ids in GHCi] in TcRnDriver + (ids, tc_expr) <- ioMsgMaybe $ tcRnStmt hsc_env icntxt parsed_stmt + -- Desugar it - let rdr_env = ic_rn_gbl_env icontext - type_env = mkTypeEnvWithImplicits (ic_tythings icontext) ds_expr <- ioMsgMaybe $ deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr handleWarnings -- Then code-gen, and link it - let src_span = srcLocSpan interactiveSrcLoc hsc_env <- getHscEnv hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr + let hval_io = unsafeCoerce# hval :: IO [HValue] - return $ Just (ids, hval) + return $ Just (ids, hval_io) -- | Compile a decls hscDecls :: HscEnv @@ -1442,8 +1430,8 @@ hscDeclsWithLocation hsc_env str source linenumber = runHsc hsc_env $ do -- We grab the whole environment because of the overlapping that may have -- been done. See the notes at the definition of InteractiveContext -- (ic_instances) for more details. - let finsts = famInstEnvElts $ tcg_fam_inst_env tc_gblenv - insts = instEnvElts $ tcg_inst_env tc_gblenv + let finsts = tcg_fam_insts tc_gblenv + insts = tcg_insts tc_gblenv {- Desugar it -} -- We use a basically null location for iNTERACTIVE @@ -1560,7 +1548,7 @@ hscParseThingWithLocation source linenumber parser str liftIO $ showPass dflags "Parser" let buf = stringToStringBuffer str - loc = mkRealSrcLoc (fsLit source) linenumber 1 + loc = mkRealSrcLoc (fsLit source) linenumber 1 case unP parser (mkPState dflags buf loc) of PFailed span err -> do diff --git a/compiler/main/HscStats.lhs b/compiler/main/HscStats.lhs index f89903f75c..168e49af4a 100644 --- a/compiler/main/HscStats.lhs +++ b/compiler/main/HscStats.lhs @@ -52,7 +52,6 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) ("DataDecls ", data_ds), ("NewTypeDecls ", newt_ds), ("TypeFamilyDecls ", type_fam_ds), - ("FamilyInstDecls ", fam_inst_ds), ("DataConstrs ", data_constrs), ("DataDerivings ", data_derivs), ("ClassDecls ", class_ds), @@ -89,7 +88,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) -- in class decls. ToDo tycl_decls = [d | TyClD d <- decls] - (class_ds, type_ds, data_ds, newt_ds, type_fam_ds, fam_inst_ds) = + (class_ds, type_ds, data_ds, newt_ds, type_fam_ds) = countTyClDecls tycl_decls inst_decls = [d | InstD d <- decls] @@ -153,7 +152,9 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) (classops, addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList (tcdMeths decl))))) class_info _ = (0,0) - inst_info (InstDecl _ inst_meths inst_sigs ats) + inst_info (FamInstDecl d) = case countATDecl d of + (tyd, dtd) -> (0,0,0,tyd,dtd) + inst_info (ClsInstDecl _ inst_meths inst_sigs ats) = case count_sigs (map unLoc inst_sigs) of (_,_,ss,is,_) -> case foldr add2 (0, 0) (map (countATDecl . unLoc) ats) of @@ -162,9 +163,9 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) (map (count_bind.unLoc) (bagToList inst_meths))), ss, is, tyDecl, dtDecl) where - countATDecl (TyData {}) = (0, 1) - countATDecl (TySynonym {}) = (1, 0) - countATDecl d = pprPanic "countATDecl: Unhandled decl" + countATDecl (TyData {}) = (0, 1) + countATDecl (TySynonym {}) = (1, 0) + countATDecl d = pprPanic "countATDecl: Unhandled decl" (ppr d) addpr :: (Int,Int) -> Int diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 3224acf0fe..9840b407ce 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -931,7 +931,8 @@ data InteractiveContext ic_tythings :: [TyThing], -- ^ TyThings defined by the user, in reverse order of - -- definition. + -- definition. At a breakpoint, this list includes the + -- local variables in scope at that point ic_sys_vars :: [Id], -- ^ Variables defined automatically by the system (e.g. @@ -1386,8 +1387,9 @@ lookupType dflags hpt pte name lookupNameEnv (md_types (hm_details hm)) name | otherwise = lookupNameEnv pte name - where mod = ASSERT( isExternalName name ) nameModule name - this_pkg = thisPackage dflags + where + mod = ASSERT2( isExternalName name, ppr name ) nameModule name + this_pkg = thisPackage dflags -- | As 'lookupType', but with a marginally easier-to-use interface -- if you have a 'HscEnv' diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index eee5c00255..cdc2ca501a 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -198,17 +198,18 @@ runStmtWithLocation source linenumber expr step = let dflags' = wopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds hsc_env' = hsc_env{ hsc_dflags = dflags' } + -- compile to value (IO [HValue]), don't run r <- liftIO $ hscStmtWithLocation hsc_env' expr source linenumber case r of - Nothing -> return (RunOk []) -- empty statement / comment + -- empty statement / comment + Nothing -> return (RunOk []) Just (tyThings, hval) -> do status <- withVirtualCWD $ withBreakAction (isStep step) dflags' breakMVar statusMVar $ do - let thing_to_run = unsafeCoerce# hval :: IO [HValue] - liftIO $ sandboxIO dflags' statusMVar thing_to_run + liftIO $ sandboxIO dflags' statusMVar hval let ic = hsc_IC hsc_env bindings = (ic_tythings ic, ic_rn_gbl_env ic) @@ -942,20 +943,18 @@ typeKind normalise str = withSession $ \hsc_env -> do liftIO $ hscKcType hsc_env normalise str ----------------------------------------------------------------------------- --- cmCompileExpr: compile an expression and deliver an HValue +-- Compile an expression, run it and deliver the resulting HValue compileExpr :: GhcMonad m => String -> m HValue compileExpr expr = withSession $ \hsc_env -> do Just (ids, hval) <- liftIO $ hscStmt hsc_env ("let __cmCompileExpr = "++expr) - -- Run it! - hvals <- liftIO (unsafeCoerce# hval :: IO [HValue]) - + hvals <- liftIO hval case (ids,hvals) of ([_],[hv]) -> return hv - _ -> panic "compileExpr" + _ -> panic "compileExpr" -- ----------------------------------------------------------------------------- --- Compile an expression into a dynamic +-- Compile an expression, run it and return the result as a dynamic dynCompileExpr :: GhcMonad m => String -> m Dynamic dynCompileExpr expr = do @@ -977,8 +976,8 @@ dynCompileExpr expr = do setContext iis vals <- liftIO (unsafeCoerce# hvals :: IO [Dynamic]) case (ids,vals) of - (_:[], v:[]) -> return v - _ -> panic "dynCompileExpr" + (_:[], v:[]) -> return v + _ -> panic "dynCompileExpr" ----------------------------------------------------------------------------- -- show a module and it's source/object filenames diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index d1fbe2f253..1d6ad4a472 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -272,7 +272,7 @@ setBatchPackageFlags dflags pkgs = (maybeDistrustAll . maybeHideAll) pkgs | otherwise = pkgs' hide pkg = pkg{ exposed = False } - distrust pkg = pkg{ exposed = False } + distrust pkg = pkg{ trusted = False } -- TODO: This code is duplicated in utils/ghc-pkg/Main.hs mungePackagePaths :: FilePath -> FilePath -> PackageConfig -> PackageConfig diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot index 0e639a3caf..7de92cb659 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot +++ b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot @@ -1,14 +1,7 @@ -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module SPARC.CodeGen.Gen32 ( - getSomeReg, - getRegister + getSomeReg, + getRegister ) where diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index c0f5041774..61eb5748a3 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -571,10 +571,7 @@ topdecls :: { OrdList (LHsDecl RdrName) } topdecl :: { OrdList (LHsDecl RdrName) } : cl_decl { unitOL (L1 (TyClD (unLoc $1))) } | ty_decl { unitOL (L1 (TyClD (unLoc $1))) } - | 'instance' inst_type where_inst - { let (binds, sigs, ats, _) = cvBindsAndSigs (unLoc $3) - in - unitOL (L (comb3 $1 $2 $3) (InstD (InstDecl $2 binds sigs ats)))} + | inst_decl { unitOL (L1 (InstD (unLoc $1))) } | stand_alone_deriving { unitOL (LL (DerivD (unLoc $1))) } | 'default' '(' comma_types0 ')' { unitOL (LL $ DefD (DefaultDecl $3)) } | 'foreign' fdecl { unitOL (LL (unLoc $2)) } @@ -633,12 +630,6 @@ ty_decl :: { LTyClDecl RdrName } -- infix type constructors to be declared {% mkTyFamily (comb3 $1 $3 $4) TypeFamily $3 (unLoc $4) } - -- type instance declarations - | 'type' 'instance' type '=' ctype - -- Note the use of type for the head; this allows - -- infix type constructors and type patterns - {% mkTySynonym (comb2 $1 $5) True $3 $5 } - -- ordinary data type or newtype declaration | data_or_newtype tycl_hdr constrs deriving {% mkTyData (comb4 $1 $2 $3 $4) (unLoc $1) False $2 @@ -659,18 +650,32 @@ ty_decl :: { LTyClDecl RdrName } | 'data' 'family' type opt_kind_sig {% mkTyFamily (comb3 $1 $2 $4) DataFamily $3 (unLoc $4) } +inst_decl :: { LInstDecl RdrName } + : 'instance' inst_type where_inst + { let (binds, sigs, ats, _) = cvBindsAndSigs (unLoc $3) + in L (comb3 $1 $2 $3) (ClsInstDecl $2 binds sigs ats) } + + -- type instance declarations + | 'type' 'instance' type '=' ctype + -- Note the use of type for the head; this allows + -- infix type constructors and type patterns + {% do { L loc d <- mkTySynonym (comb2 $1 $5) True $3 $5 + ; return (L loc (FamInstDecl d)) } } + -- data/newtype instance declaration | data_or_newtype 'instance' tycl_hdr constrs deriving - {% mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) True $3 - Nothing (reverse (unLoc $4)) (unLoc $5) } + {% do { L loc d <- mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) True $3 + Nothing (reverse (unLoc $4)) (unLoc $5) + ; return (L loc (FamInstDecl d)) } } -- GADT instance declaration | data_or_newtype 'instance' tycl_hdr opt_kind_sig gadt_constrlist deriving - {% mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) True $3 - (unLoc $4) (unLoc $5) (unLoc $6) } - + {% do { L loc d <- mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) True $3 + (unLoc $4) (unLoc $5) (unLoc $6) + ; return (L loc (FamInstDecl d)) } } + -- Associated type family declarations -- -- * They have a different syntax than on the toplevel (no family special @@ -1071,8 +1076,8 @@ atype :: { LHsType RdrName } | SIMPLEQUOTE '(' ctype ',' comma_types1 ')' { LL $ HsExplicitTupleTy [] ($3 : $5) } | SIMPLEQUOTE '[' comma_types0 ']' { LL $ HsExplicitListTy placeHolderKind $3 } | '[' ctype ',' comma_types1 ']' { LL $ HsExplicitListTy placeHolderKind ($2 : $4) } - | INTEGER { LL $ HsTyLit $ HsNumberTy $ getINTEGER $1 } - | STRING { LL $ HsTyLit $ HsStringTy $ getSTRING $1 } + | INTEGER { LL $ HsTyLit $ HsNumTy $ getINTEGER $1 } + | STRING { LL $ HsTyLit $ HsStrTy $ getSTRING $1 } -- An inst_type is what occurs in the head of an instance decl -- e.g. (Foo a, Gaz b) => Wibble a b diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index ec760d7fae..162a7025c0 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -50,11 +50,12 @@ module TysWiredIn ( -- * List listTyCon, nilDataCon, consDataCon, listTyCon_RDR, consDataCon_RDR, listTyConName, - mkListTy, + mkListTy, mkPromotedListTy, -- * Tuples mkTupleTy, mkBoxedTupleTy, - tupleTyCon, tupleCon, + tupleTyCon, promotedTupleTyCon, + tupleCon, unitTyCon, unitDataCon, unitDataConId, pairTyCon, unboxedUnitTyCon, unboxedUnitDataCon, unboxedSingletonTyCon, unboxedSingletonDataCon, @@ -87,13 +88,14 @@ import TysPrim import Coercion import Constants ( mAX_TUPLE_SIZE ) import Module ( Module ) -import DataCon ( DataCon, mkDataCon, dataConWorkId, dataConSourceArity ) +import DataCon import Var import TyCon import TypeRep import RdrName import Name -import BasicTypes ( TupleSort(..), tupleSortBoxity, IPName(..), Arity, RecFlag(..), Boxity(..), HsBang(..) ) +import BasicTypes ( TupleSort(..), tupleSortBoxity, IPName(..), + Arity, RecFlag(..), Boxity(..), HsBang(..) ) import Unique ( incrUnique, mkTupleTyConUnique, mkTupleDataConUnique, mkPArrDataConUnique ) import Data.Array @@ -220,7 +222,6 @@ parrTyCon_RDR = nameRdrName parrTyConName eqTyCon_RDR = nameRdrName eqTyConName \end{code} - %************************************************************************ %* * \subsection{mkWiredInTyCon} @@ -322,6 +323,9 @@ tupleTyCon BoxedTuple i = fst (boxedTupleArr ! i) tupleTyCon UnboxedTuple i = fst (unboxedTupleArr ! i) tupleTyCon ConstraintTuple i = fst (factTupleArr ! i) +promotedTupleTyCon :: TupleSort -> Arity -> TyCon +promotedTupleTyCon sort i = buildPromotedTyCon (tupleTyCon sort i) + tupleCon :: TupleSort -> Arity -> DataCon tupleCon sort i | i > mAX_TUPLE_SIZE = snd (mk_tuple sort i) -- Build one specially tupleCon BoxedTuple i = snd (boxedTupleArr ! i) @@ -625,6 +629,12 @@ mkListTy ty = mkTyConApp listTyCon [ty] listTyCon :: TyCon listTyCon = pcRecDataTyCon listTyConName alpha_tyvar [nilDataCon, consDataCon] +mkPromotedListTy :: Type -> Type +mkPromotedListTy ty = mkTyConApp promotedListTyCon [ty] + +promotedListTyCon :: TyCon +promotedListTyCon = buildPromotedTyCon listTyCon + nilDataCon :: DataCon nilDataCon = pcDataCon nilDataConName alpha_tyvar [] listTyCon diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index bd424e87b8..ecd2cd3147 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -39,7 +39,7 @@ module RnEnv ( addFvRn, mapFvRn, mapMaybeFvRn, mapFvRnCPS, warnUnusedMatches, warnUnusedTopBinds, warnUnusedLocalBinds, - dataTcOccs, unknownNameErr, kindSigErr, polyKindsErr, perhapsForallMsg, + dataTcOccs, unknownNameErr, kindSigErr, dataKindsErr, perhapsForallMsg, HsDocContext(..), docOfHsDocContext ) where @@ -470,9 +470,9 @@ lookupPromotedOccRn rdr_name Nothing -> unboundName WL_Any rdr_name Just demoted_name | data_kinds -> return demoted_name - | otherwise -> unboundNameX WL_Any rdr_name suggest_pk }}} + | otherwise -> unboundNameX WL_Any rdr_name suggest_dk }}} where - suggest_pk = ptext (sLit "A data constructor of that name is in scope; did you mean -XDataKinds?") + suggest_dk = ptext (sLit "A data constructor of that name is in scope; did you mean -XDataKinds?") \end{code} Note [Demotion] @@ -507,7 +507,12 @@ lookupOccRn_maybe rdr_name { -- We allow qualified names on the command line to refer to -- *any* name exported by any module in scope, just as if there -- was an "import qualified M" declaration for every module. - allow_qual <- doptM Opt_ImplicitImportQualified + -- But we DONT allow it under Safe Haskell as we need to check + -- imports. We can and should instead check the qualified import + -- but at the moment this requires some refactoring so leave as a TODO + ; dflags <- getDynFlags + ; let allow_qual = dopt Opt_ImplicitImportQualified dflags && + not (safeDirectImpsReq dflags) ; is_ghci <- getIsGHCi -- This test is not expensive, -- and only happens for failed lookups @@ -1434,8 +1439,8 @@ kindSigErr thing = hang (ptext (sLit "Illegal kind signature for") <+> quotes (ppr thing)) 2 (ptext (sLit "Perhaps you intended to use -XKindSignatures")) -polyKindsErr :: Outputable a => a -> SDoc -polyKindsErr thing +dataKindsErr :: Outputable a => a -> SDoc +dataKindsErr thing = hang (ptext (sLit "Illegal kind:") <+> quotes (ppr thing)) 2 (ptext (sLit "Perhaps you intended to use -XDataKinds")) diff --git a/compiler/rename/RnExpr.lhs-boot b/compiler/rename/RnExpr.lhs-boot index 5ca81d6db4..70d891dcbf 100644 --- a/compiler/rename/RnExpr.lhs-boot +++ b/compiler/rename/RnExpr.lhs-boot @@ -1,24 +1,17 @@ \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module RnExpr where import HsSyn -import Name ( Name ) -import NameSet ( FreeVars ) -import RdrName ( RdrName ) +import Name ( Name ) +import NameSet ( FreeVars ) +import RdrName ( RdrName ) import TcRnTypes rnLExpr :: LHsExpr RdrName - -> RnM (LHsExpr Name, FreeVars) + -> RnM (LHsExpr Name, FreeVars) rnStmts :: --forall thing. - HsStmtContext Name -> [LStmt RdrName] + HsStmtContext Name -> [LStmt RdrName] -> ([Name] -> RnM (thing, FreeVars)) - -> RnM (([LStmt Name], thing), FreeVars) + -> RnM (([LStmt Name], thing), FreeVars) \end{code} diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 68e6d027e6..b1a61db2a2 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -486,12 +486,8 @@ getLocalNonValBinders fixity_env hs_tyclds = tycl_decls, hs_instds = inst_decls, hs_fords = foreign_decls }) - = do { -- Separate out the family instance declarations - let (tyinst_decls, tycl_decls_noinsts) - = partition (isFamInstDecl . unLoc) (concat tycl_decls) - - -- Process all type/class decls *except* family instances - ; tc_avails <- mapM new_tc tycl_decls_noinsts + = do { -- Process all type/class decls *except* family instances + ; tc_avails <- mapM new_tc (concat tycl_decls) ; envs <- extendGlobalRdrEnvRn tc_avails fixity_env ; setEnvs envs $ do { -- Bring these things into scope first @@ -499,7 +495,6 @@ getLocalNonValBinders fixity_env -- Process all family instances -- to bring new data constructors into scope - ; ti_avails <- mapM (new_ti Nothing) tyinst_decls ; nti_avails <- concatMapM new_assoc inst_decls -- Finish off with value binders: @@ -510,7 +505,7 @@ getLocalNonValBinders fixity_env | otherwise = for_hs_bndrs ; val_avails <- mapM new_simple val_bndrs - ; let avails = ti_avails ++ nti_avails ++ val_avails + ; let avails = nti_avails ++ val_avails new_bndrs = availsToNameSet avails `unionNameSets` availsToNameSet tc_avails ; envs <- extendGlobalRdrEnvRn avails fixity_env @@ -529,20 +524,25 @@ getLocalNonValBinders fixity_env ; return (Avail nm) } new_tc tc_decl -- NOT for type/data instances - = do { names@(main_name : _) <- mapM newTopSrcBinder (hsTyClDeclBinders tc_decl) + = do { let bndrs = hsTyClDeclBinders (unLoc tc_decl) + ; names@(main_name : _) <- mapM newTopSrcBinder bndrs ; return (AvailTC main_name names) } - new_ti :: Maybe Name -> LTyClDecl RdrName -> RnM AvailInfo + new_ti :: Maybe Name -> FamInstDecl RdrName -> RnM AvailInfo new_ti mb_cls ti_decl -- ONLY for type/data instances - = do { main_name <- lookupTcdName mb_cls (unLoc ti_decl) + = ASSERT( isFamInstDecl ti_decl ) + do { main_name <- lookupTcdName mb_cls ti_decl ; sub_names <- mapM newTopSrcBinder (hsTyClDeclBinders ti_decl) ; return (AvailTC (unLoc main_name) sub_names) } -- main_name is not bound here! new_assoc :: LInstDecl RdrName -> RnM [AvailInfo] - new_assoc (L _ (InstDecl inst_ty _ _ ats)) + new_assoc (L _ (FamInstDecl d)) + = do { avail <- new_ti Nothing d + ; return [avail] } + new_assoc (L _ (ClsInstDecl inst_ty _ _ ats)) = do { mb_cls_nm <- get_cls_parent inst_ty - ; mapM (new_ti mb_cls_nm) ats } + ; mapM (new_ti mb_cls_nm . unLoc) ats } where get_cls_parent inst_ty | Just (_, _, L loc cls_rdr, _) <- splitLHsInstDeclTy_maybe inst_ty @@ -551,7 +551,8 @@ getLocalNonValBinders fixity_env = return Nothing lookupTcdName :: Maybe Name -> TyClDecl RdrName -> RnM (Located Name) --- Used for TyData and TySynonym only +-- Used for TyData and TySynonym only, +-- both ordinary ones and family instances -- See Note [Family instance binders] lookupTcdName mb_cls tc_decl | not (isFamInstDecl tc_decl) -- The normal case @@ -1511,7 +1512,10 @@ warnUnusedImport (L loc decl, used, unused) <+> ptext (sLit "import") <+> pp_mod <> parens empty ] msg2 = sep [pp_herald <+> quotes (pprWithCommas ppr unused), text "from module" <+> quotes pp_mod <+> pp_not_used] - pp_herald = text "The import of" + pp_herald = text "The" <+> pp_qual <+> text "import of" + pp_qual + | ideclQualified decl = text "qualified" + | otherwise = empty pp_mod = ppr (unLoc (ideclName decl)) pp_not_used = text "is redundant" \end{code} diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 175b9a7ba4..54f95016c7 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -424,7 +424,11 @@ patchCCallTarget packageId callTarget \begin{code} rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars) -rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) +rnSrcInstDecl (FamInstDecl ty_decl) + = do { (ty_decl', fvs) <- rnTyClDecl Nothing ty_decl + ; return (FamInstDecl ty_decl', fvs) } + +rnSrcInstDecl (ClsInstDecl inst_ty mbinds uprags ats) -- Used for both source and interface file decls = do { inst_ty' <- rnLHsInstType (text "In an instance declaration") inst_ty ; let Just (inst_tyvars, _, L _ cls,_) = splitLHsInstDeclTy_maybe inst_ty' @@ -460,7 +464,7 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) renameSigs (InstDeclCtxt cls) spec_inst_prags ; let uprags' = spec_inst_prags' ++ other_sigs' - ; return (InstDecl inst_ty' mbinds' uprags' ats', + ; return (ClsInstDecl inst_ty' mbinds' uprags' ats', meth_fvs `plusFV` more_fvs `plusFV` hsSigsFVs spec_inst_prags' `plusFV` extractHsTyNames inst_ty') } @@ -764,6 +768,7 @@ rnTyClDecls extra_deps tycl_ds all_fvs = foldr (plusFV . snd) emptyFVs ds_w_fvs' + ; traceRn (text "rnTycl" <+> (ppr ds_w_fvs $$ ppr sccs)) ; return (map flattenSCC sccs, all_fvs) } @@ -995,12 +1000,16 @@ depAnalTyClDecls :: [(LTyClDecl Name, FreeVars)] -> [SCC (LTyClDecl Name)] depAnalTyClDecls ds_w_fvs = stronglyConnCompFromEdgedVertices edges where - edges = [ (d, tcdName (unLoc d), map get_assoc (nameSetToList fvs)) + edges = [ (d, tcdName (unLoc d), map get_parent (nameSetToList fvs)) | (d, fvs) <- ds_w_fvs ] - get_assoc n = lookupNameEnv assoc_env n `orElse` n + + -- We also need to consider data constructor names since + -- they may appear in types because of promotion. + get_parent n = lookupNameEnv assoc_env n `orElse` n + + assoc_env :: NameEnv Name -- Maps a data constructor back + -- to its parent type constructor assoc_env = mkNameEnv assoc_env_list - -- We also need to consider data constructor names since they may - -- appear in types because of promotion. assoc_env_list = do (L _ d, _) <- ds_w_fvs case d of @@ -1210,7 +1219,7 @@ extendRecordFieldEnv tycl_decls inst_decls all_data_cons = [con | L _ (TyData { tcdCons = cons }) <- all_tycl_decls , L _ con <- cons ] all_tycl_decls = at_tycl_decls ++ concat tycl_decls - at_tycl_decls = instDeclATs inst_decls -- Do not forget associated types! + at_tycl_decls = instDeclFamInsts inst_decls -- Do not forget associated types! get_con (ConDecl { con_name = con, con_details = RecCon flds }) (RecFields env fld_set) diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index 7840c4ab3a..5275957ce0 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -197,7 +197,7 @@ rnHsTyKi isType doc (HsFunTy ty1 ty2) = do rnHsTyKi isType doc listTy@(HsListTy ty) = do data_kinds <- xoptM Opt_DataKinds - unless (data_kinds || isType) (addErr (polyKindsErr listTy)) + unless (data_kinds || isType) (addErr (dataKindsErr listTy)) ty' <- rnLHsTyKi isType doc ty return (HsListTy ty') @@ -217,7 +217,7 @@ rnHsTyKi isType doc (HsPArrTy ty) = ASSERT ( isType ) do -- sometimes crop up as a result of CPR worker-wrappering dictionaries. rnHsTyKi isType doc tupleTy@(HsTupleTy tup_con tys) = do data_kinds <- xoptM Opt_DataKinds - unless (data_kinds || isType) (addErr (polyKindsErr tupleTy)) + unless (data_kinds || isType) (addErr (dataKindsErr tupleTy)) tys' <- mapM (rnLHsTyKi isType doc) tys return (HsTupleTy tup_con tys') @@ -225,7 +225,7 @@ rnHsTyKi isType doc tupleTy@(HsTupleTy tup_con tys) = do -- 2. Check that the integer is positive? rnHsTyKi isType _ tyLit@(HsTyLit t) = do data_kinds <- xoptM Opt_DataKinds - unless (data_kinds || isType) (addErr (polyKindsErr tyLit)) + unless (data_kinds || isType) (addErr (dataKindsErr tyLit)) return (HsTyLit t) rnHsTyKi isType doc (HsAppTy ty1 ty2) = do diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs index 98305e48a2..c873c631da 100644 --- a/compiler/typecheck/FamInst.lhs +++ b/compiler/typecheck/FamInst.lhs @@ -29,7 +29,7 @@ import Outputable import UniqFM import FastString import VarSet ( varSetElems ) - +import Util( filterOut ) import Maybes import Control.Monad import Data.Map (Map) @@ -237,35 +237,44 @@ with standalone deriving declrations. tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a tcExtendLocalFamInstEnv fam_insts thing_inside = do { env <- getGblEnv - ; inst_env' <- foldlM addLocalFamInst (tcg_fam_inst_env env) fam_insts - ; let env' = env { tcg_fam_insts = fam_insts ++ tcg_fam_insts env, - tcg_fam_inst_env = inst_env' } + ; (inst_env', fam_insts') <- foldlM addLocalFamInst + (tcg_fam_inst_env env, tcg_fam_insts env) + fam_insts + ; let env' = env { tcg_fam_insts = fam_insts' + , tcg_fam_inst_env = inst_env' } ; setGblEnv env' thing_inside } -- Check that the proposed new instance is OK, -- and then add it to the home inst env -addLocalFamInst :: FamInstEnv -> FamInst -> TcM FamInstEnv -addLocalFamInst home_fie famInst = do - -- Load imported instances, so that we report - -- overlaps correctly - eps <- getEps - let inst_envs = (eps_fam_inst_env eps, home_fie) - - -- Check for conflicting instance decls - skol_tvs <- tcInstSkolTyVars (varSetElems (famInstTyVars famInst)) - let conflicts = lookupFamInstEnvConflicts inst_envs famInst skol_tvs - -- If there are any conflicts, we should probably error - -- But, if we're allowed to overwrite and the conflict is in the home FIE, - -- then overwrite instead of error. - traceTc "checkForConflicts" (ppr conflicts $$ ppr famInst $$ ppr inst_envs) - isGHCi <- getIsGHCi - case conflicts of - dup : _ -> case (isGHCi, home_conflicts) of - (True, _ : _) -> return (overwriteFamInstEnv home_fie famInst) - (_, _) -> conflictInstErr famInst (fst dup) >> return (extendFamInstEnv home_fie famInst) - where home_conflicts = lookupFamInstEnvConflicts' home_fie famInst skol_tvs - [] -> return (extendFamInstEnv home_fie famInst) +addLocalFamInst :: (FamInstEnv,[FamInst]) -> FamInst -> TcM (FamInstEnv, [FamInst]) +addLocalFamInst (home_fie, my_fis) fam_inst + -- home_fie includes home package and this module + -- my_fies is just the ones from this module + = do { isGHCi <- getIsGHCi + + -- In GHCi, we *override* any identical instances + -- that are also defined in the interactive context + ; let (home_fie', my_fis') + | isGHCi = (deleteFromFamInstEnv home_fie fam_inst, + filterOut (identicalFamInst fam_inst) my_fis) + | otherwise = (home_fie, my_fis) + + -- Load imported instances, so that we report + -- overlaps correctly + ; eps <- getEps + ; skol_tvs <- tcInstSkolTyVars (varSetElems (famInstTyVars fam_inst)) + ; let inst_envs = (eps_fam_inst_env eps, home_fie') + conflicts = lookupFamInstEnvConflicts inst_envs fam_inst skol_tvs + home_fie'' = extendFamInstEnv home_fie fam_inst + + -- Check for conflicting instance decls + ; traceTc "checkForConflicts" (ppr conflicts $$ ppr fam_inst $$ ppr inst_envs) + ; case conflicts of + [] -> return (home_fie'', fam_inst : my_fis') + dup : _ -> do { conflictInstErr fam_inst (fst dup) + ; return (home_fie, my_fis) } + } \end{code} %************************************************************************ diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 4db96c6e3c..7751ae49d2 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -459,7 +459,7 @@ makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls all_tydata :: [(LHsType Name, LTyClDecl Name)] -- Derived predicate paired with its data type declaration - all_tydata = extractTyDataPreds (instDeclATs inst_decls ++ tycl_decls) + all_tydata = extractTyDataPreds (instDeclFamInsts inst_decls ++ tycl_decls) deriv_locs = map (getLoc . snd) all_tydata ++ map getLoc deriv_decls diff --git a/compiler/typecheck/TcExpr.lhs-boot b/compiler/typecheck/TcExpr.lhs-boot index 7bd1e6c5c6..378a012f67 100644 --- a/compiler/typecheck/TcExpr.lhs-boot +++ b/compiler/typecheck/TcExpr.lhs-boot @@ -1,35 +1,28 @@ \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module TcExpr where -import HsSyn ( HsExpr, LHsExpr ) -import Name ( Name ) -import TcType ( TcType, TcRhoType, TcSigmaType ) +import HsSyn ( HsExpr, LHsExpr ) +import Name ( Name ) +import TcType ( TcType, TcRhoType, TcSigmaType ) import TcRnTypes( TcM, TcId, CtOrigin ) tcPolyExpr :: - LHsExpr Name + LHsExpr Name -> TcSigmaType -> TcM (LHsExpr TcId) tcMonoExpr, tcMonoExprNC :: - LHsExpr Name + LHsExpr Name -> TcRhoType -> TcM (LHsExpr TcId) tcInferRho, tcInferRhoNC :: - LHsExpr Name + LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType) tcSyntaxOp :: CtOrigin - -> HsExpr Name - -> TcType - -> TcM (HsExpr TcId) + -> HsExpr Name + -> TcType + -> TcM (HsExpr TcId) tcCheckId :: Name -> TcRhoType -> TcM (HsExpr TcId) \end{code} diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 0df0a9b97c..7d6dfeb293 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -46,7 +46,7 @@ import {-# SOURCE #-} TcSplice( kcSpliceType ) import HsSyn import RnHsSyn import TcRnMonad -import RnEnv ( polyKindsErr ) +import RnEnv ( dataKindsErr ) import TcHsSyn ( mkZonkTcTyVar ) import TcEvidence( HsWrapper ) import TcEnv @@ -59,7 +59,7 @@ import Kind import Var import VarSet import TyCon -import DataCon ( DataCon, dataConUserType ) +import DataCon import TysPrim ( liftedTypeKindTyConName, constraintKindTyConName ) import Class import RdrName ( rdrNameSpace, nameRdrName ) @@ -72,7 +72,6 @@ import DynFlags ( ExtensionFlag( Opt_DataKinds ) ) import Util import UniqSupply import Outputable -import BuildTyCl ( buildPromotedDataTyCon ) import FastString import Control.Monad ( unless ) \end{code} @@ -511,12 +510,13 @@ kc_hs_type (HsDocTy ty _) exp_kind kc_hs_type ty@(HsExplicitListTy _k tys) exp_kind = do { ty_k_s <- mapM kc_lhs_type_fresh tys ; kind <- unifyKinds (ptext (sLit "In a promoted list")) ty_k_s - ; checkExpectedKind ty (mkListTy kind) exp_kind + ; checkExpectedKind ty (mkPromotedListTy kind) exp_kind ; return (HsExplicitListTy kind (map fst ty_k_s)) } kc_hs_type ty@(HsExplicitTupleTy _ tys) exp_kind = do ty_k_s <- mapM kc_lhs_type_fresh tys - let tupleKi = mkTyConApp (tupleTyCon BoxedTuple (length tys)) (map snd ty_k_s) + let tycon = promotedTupleTyCon BoxedTuple (length tys) + tupleKi = mkTyConApp tycon (map snd ty_k_s) checkExpectedKind ty tupleKi exp_kind return (HsExplicitTupleTy (map snd ty_k_s) (map fst ty_k_s)) @@ -754,14 +754,14 @@ ds_type (HsExplicitListTy kind tys) = do kind' <- zonkTcKindToKind kind ds_tys <- mapM dsHsType tys return $ - foldr (\a b -> mkTyConApp (buildPromotedDataTyCon consDataCon) [kind', a, b]) - (mkTyConApp (buildPromotedDataTyCon nilDataCon) [kind']) ds_tys + foldr (\a b -> mkTyConApp (buildPromotedDataCon consDataCon) [kind', a, b]) + (mkTyConApp (buildPromotedDataCon nilDataCon) [kind']) ds_tys ds_type (HsExplicitTupleTy kis tys) = do MASSERT( length kis == length tys ) kis' <- mapM zonkTcKindToKind kis tys' <- mapM dsHsType tys - return $ mkTyConApp (buildPromotedDataTyCon (tupleCon BoxedTuple (length kis'))) (kis' ++ tys') + return $ mkTyConApp (buildPromotedDataCon (tupleCon BoxedTuple (length kis'))) (kis' ++ tys') ds_type (HsTyLit tl) = return $ case tl of HsNumTy n -> mkNumLitTy n @@ -820,7 +820,7 @@ ds_var_app name arg_tys = do { thing <- tcLookupGlobal name ; case thing of ATyCon tc -> return (mkTyConApp tc arg_tys) - ADataCon dc -> return (mkTyConApp (buildPromotedDataTyCon dc) arg_tys) + ADataCon dc -> return (mkTyConApp (buildPromotedDataCon dc) arg_tys) _ -> wrongThingErr "type" (AGlobal thing) name } addKcTypeCtxt :: LHsType Name -> TcM a -> TcM a @@ -1316,13 +1316,14 @@ sc_ds_hs_kind (HsFunTy ki1 ki2) = sc_ds_hs_kind (HsListTy ki) = do kappa <- sc_ds_lhs_kind ki checkWiredInTyCon listTyCon - return $ mkListTy kappa + return $ mkPromotedListTy kappa sc_ds_hs_kind (HsTupleTy _ kis) = do kappas <- mapM sc_ds_lhs_kind kis checkWiredInTyCon tycon return $ mkTyConApp tycon kappas - where tycon = tupleTyCon BoxedTuple (length kis) + where + tycon = promotedTupleTyCon BoxedTuple (length kis) -- Argument not kind-shaped sc_ds_hs_kind k = panic ("sc_ds_hs_kind: " ++ showPpr k) @@ -1339,15 +1340,16 @@ sc_ds_app ki _ = failWithTc (quotes (ppr ki) <+> -- IA0_TODO: With explicit kind polymorphism I might need to add ATyVar sc_ds_var_app :: Name -> [Kind] -> TcM Kind -- Special case for * and Constraint kinds +-- They are kinds already, so we don't need to promote them sc_ds_var_app name arg_kis - | name == liftedTypeKindTyConName - || name == constraintKindTyConName = do - unless (null arg_kis) - (failWithTc (text "Kind" <+> ppr name <+> text "cannot be applied")) - thing <- tcLookup name - case thing of - AGlobal (ATyCon tc) -> return (mkTyConApp tc []) - _ -> panic "sc_ds_var_app 1" + | name == liftedTypeKindTyConName + || name == constraintKindTyConName + = do { unless (null arg_kis) + (failWithTc (text "Kind" <+> ppr name <+> text "cannot be applied")) + ; thing <- tcLookup name + ; case thing of + AGlobal (ATyCon tc) -> return (mkTyConApp tc []) + _ -> panic "sc_ds_var_app 1" } -- General case sc_ds_var_app name arg_kis = do @@ -1356,23 +1358,24 @@ sc_ds_var_app name arg_kis = do Just (AGlobal (ATyCon tc)) | isAlgTyCon tc || isTupleTyCon tc -> do data_kinds <- xoptM Opt_DataKinds - unless data_kinds $ addErr (polyKindsErr name) - let tc_kind = tyConKind tc - case isPromotableKind tc_kind of + unless data_kinds $ addErr (dataKindsErr name) + case isPromotableTyCon tc of Just n | n == length arg_kis -> - return (mkTyConApp (mkPromotedTypeTyCon tc) arg_kis) - Just _ -> err tc_kind "is not fully applied" - Nothing -> err tc_kind "is not promotable" + return (mkTyConApp (buildPromotedTyCon tc) arg_kis) + Just _ -> err tc "is not fully applied" + Nothing -> err tc "is not promotable" + -- It is in scope, but not what we expected Just thing -> wrongThingErr "promoted type" thing name + -- It is not in scope, but it passed the renamer: staging error Nothing -> ASSERT2 ( isTyConName name, ppr name ) failWithTc (ptext (sLit "Promoted kind") <+> quotes (ppr name) <+> ptext (sLit "used in a mutually recursive group")) - - where err k m = failWithTc ( quotes (ppr name) <+> ptext (sLit "of kind") - <+> quotes (ppr k) <+> ptext (sLit m)) + where + err tc msg = failWithTc (quotes (ppr tc) <+> ptext (sLit "of kind") + <+> quotes (ppr (tyConKind tc)) <+> ptext (sLit msg)) \end{code} diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 8351b7b52d..89a034ba18 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -371,17 +371,16 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls -- round) -- (1) Do class and family instance declarations - ; fam_insts <- mapAndRecoverM tcTopFamInstDecl $ - filter (isFamInstDecl . unLoc) tycl_decls - ; inst_decl_stuff <- mapAndRecoverM tcLocalInstDecl1 inst_decls + ; inst_decl_stuff <- mapAndRecoverM tcLocalInstDecl1 inst_decls - ; let { (local_info, at_fam_insts_s) = unzip inst_decl_stuff - ; all_fam_insts = concat at_fam_insts_s ++ fam_insts } + ; let { (local_infos_s, fam_insts_s) = unzip inst_decl_stuff + ; all_fam_insts = concat fam_insts_s + ; local_infos = concat local_infos_s } -- (2) Next, construct the instance environment so far, consisting of -- (a) local instance decls -- (b) local family instance decls - ; addClsInsts local_info $ + ; addClsInsts local_infos $ addFamInsts all_fam_insts $ do -- (3) Compute instances from "deriving" clauses; @@ -403,13 +402,13 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls ; when (safeLanguageOn dflags) $ mapM_ (\x -> when (typInstCheck x) (addErrAt (getSrcSpan $ iSpec x) typInstErr)) - local_info + local_infos -- As above but for Safe Inference mode. ; when (safeInferOn dflags) $ - mapM_ (\x -> when (typInstCheck x) recordUnsafeInfer) local_info + mapM_ (\x -> when (typInstCheck x) recordUnsafeInfer) local_infos ; return ( gbl_env - , (bagToList deriv_inst_info) ++ local_info + , bagToList deriv_inst_info ++ local_infos , deriv_binds) }} where @@ -437,12 +436,18 @@ addFamInsts fam_insts thing_inside \begin{code} tcLocalInstDecl1 :: LInstDecl Name - -> TcM (InstInfo Name, [FamInst]) + -> TcM ([InstInfo Name], [FamInst]) -- A source-file instance declaration -- Type-check all the stuff before the "where" -- -- We check for respectable instance type, and context -tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) +tcLocalInstDecl1 (L loc (FamInstDecl decl)) + = setSrcSpan loc $ + tcAddDeclCtxt decl $ + do { fam_inst <- tcFamInstDecl TopLevel decl + ; return ([], [fam_inst]) } + +tcLocalInstDecl1 (L loc (ClsInstDecl poly_ty binds uprags ats)) = setSrcSpan loc $ addErrCtxt (instDeclCtxt1 poly_ty) $ @@ -500,7 +505,7 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) ispec = mkLocalInstance dfun overlap_flag inst_info = InstInfo { iSpec = ispec, iBinds = VanillaInst binds uprags False } - ; return ( inst_info, fam_insts0 ++ concat fam_insts1) } + ; return ( [inst_info], fam_insts0 ++ concat fam_insts1) } \end{code} %************************************************************************ @@ -515,12 +520,6 @@ lot of kinding and type checking code with ordinary algebraic data types (and GADTs). \begin{code} -tcTopFamInstDecl :: LTyClDecl Name -> TcM FamInst -tcTopFamInstDecl (L loc decl) - = setSrcSpan loc $ - tcAddDeclCtxt decl $ - tcFamInstDecl TopLevel decl - tcFamInstDecl :: TopLevelFlag -> TyClDecl Name -> TcM FamInst tcFamInstDecl top_lvl decl = do { -- Type family instances require -XTypeFamilies diff --git a/compiler/typecheck/TcMatches.lhs-boot b/compiler/typecheck/TcMatches.lhs-boot index f898f3deb7..8c421da6da 100644 --- a/compiler/typecheck/TcMatches.lhs-boot +++ b/compiler/typecheck/TcMatches.lhs-boot @@ -1,24 +1,17 @@ \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module TcMatches where -import HsSyn ( GRHSs, MatchGroup ) +import HsSyn ( GRHSs, MatchGroup ) import TcEvidence( HsWrapper ) -import Name ( Name ) -import TcType ( TcRhoType ) +import Name ( Name ) +import TcType ( TcRhoType ) import TcRnTypes( TcM, TcId ) tcGRHSsPat :: GRHSs Name - -> TcRhoType - -> TcM (GRHSs TcId) + -> TcRhoType + -> TcM (GRHSs TcId) tcMatchesFun :: Name -> Bool - -> MatchGroup Name - -> TcRhoType - -> TcM (HsWrapper, MatchGroup TcId) + -> MatchGroup Name + -> TcRhoType + -> TcM (HsWrapper, MatchGroup TcId) \end{code} diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 908588b8f6..8a5aab5437 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -5,26 +5,19 @@ \section[TcMovectle]{Typechecking a whole module} \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module TcRnDriver ( #ifdef GHCI - tcRnStmt, tcRnExpr, tcRnType, - tcRnImportDecls, - tcRnLookupRdrName, - getModuleInterface, - tcRnDeclsi, + tcRnStmt, tcRnExpr, tcRnType, + tcRnImportDecls, + tcRnLookupRdrName, + getModuleInterface, + tcRnDeclsi, #endif - tcRnLookupName, - tcRnGetInfo, - tcRnModule, - tcTopSrcDecls, - tcRnExtCore + tcRnLookupName, + tcRnGetInfo, + tcRnModule, + tcTopSrcDecls, + tcRnExtCore ) where #ifdef GHCI @@ -47,7 +40,7 @@ import FamInstEnv import TcAnnotations import TcBinds import HeaderInfo ( mkPrelImports ) -import TcType ( tidyTopType ) +import TcType ( tidyTopType ) import TcDefaults import TcEnv import TcRules @@ -84,7 +77,7 @@ import DataCon import Type import Class import TcType ( orphNamesOfDFunHead ) -import Inst ( tcGetInstEnvs ) +import Inst ( tcGetInstEnvs ) import Data.List ( sortBy ) import Data.IORef ( readIORef ) @@ -96,7 +89,7 @@ import RnTypes import RnExpr import MkId import BasicTypes -import TidyPgm ( globaliseAndTidyId ) +import TidyPgm ( globaliseAndTidyId ) import TysWiredIn ( unitTy, mkListTy ) #endif @@ -111,25 +104,25 @@ import Control.Monad \end{code} %************************************************************************ -%* * - Typecheck and rename a module -%* * +%* * + Typecheck and rename a module +%* * %************************************************************************ \begin{code} -- | Top level entry point for typechecker and renamer -tcRnModule :: HscEnv - -> HscSource - -> Bool -- True <=> save renamed syntax +tcRnModule :: HscEnv + -> HscSource + -> Bool -- True <=> save renamed syntax -> HsParsedModule - -> IO (Messages, Maybe TcGblEnv) + -> IO (Messages, Maybe TcGblEnv) tcRnModule hsc_env hsc_src save_rn_syntax HsParsedModule { hpm_module = (L loc (HsModule maybe_mod export_ies - import_decls local_decls mod_deprec + import_decls local_decls mod_deprec maybe_doc_hdr)), hpm_src_files = src_files @@ -137,17 +130,17 @@ tcRnModule hsc_env hsc_src save_rn_syntax = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ; let { this_pkg = thisPackage (hsc_dflags hsc_env) ; - (this_mod, prel_imp_loc) + (this_mod, prel_imp_loc) = case maybe_mod of - Nothing -- 'module M where' is omitted - -> (mAIN, srcLocSpan (srcSpanStart loc)) - - Just (L mod_loc mod) -- The normal case + Nothing -- 'module M where' is omitted + -> (mAIN, srcLocSpan (srcSpanStart loc)) + + Just (L mod_loc mod) -- The normal case -> (mkModule this_pkg mod, mod_loc) } ; - - initTc hsc_env hsc_src save_rn_syntax this_mod $ + + initTc hsc_env hsc_src save_rn_syntax this_mod $ setSrcSpan loc $ - do { -- Deal with imports; first add implicit prelude + do { -- Deal with imports; first add implicit prelude implicit_prelude <- xoptM Opt_ImplicitPrelude; let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc implicit_prelude import_decls } ; @@ -155,70 +148,70 @@ tcRnModule hsc_env hsc_src save_rn_syntax ifWOptM Opt_WarnImplicitPrelude $ when (notNull prel_imports) $ addWarn (implicitPreludeWarn) ; - tcg_env <- {-# SCC "tcRnImports" #-} + tcg_env <- {-# SCC "tcRnImports" #-} tcRnImports hsc_env this_mod (prel_imports ++ import_decls) ; - setGblEnv tcg_env $ do { - - -- Load the hi-boot interface for this module, if any - -- We do this now so that the boot_names can be passed - -- to tcTyAndClassDecls, because the boot_names are - -- automatically considered to be loop breakers - -- - -- Do this *after* tcRnImports, so that we know whether - -- a module that we import imports us; and hence whether to - -- look for a hi-boot file - boot_iface <- tcHiBootIface hsc_src this_mod ; - - -- Rename and type check the declarations - traceRn (text "rn1a") ; - tcg_env <- if isHsBoot hsc_src then - tcRnHsBootDecls local_decls - else - {-# SCC "tcRnSrcDecls" #-} + setGblEnv tcg_env $ do { + + -- Load the hi-boot interface for this module, if any + -- We do this now so that the boot_names can be passed + -- to tcTyAndClassDecls, because the boot_names are + -- automatically considered to be loop breakers + -- + -- Do this *after* tcRnImports, so that we know whether + -- a module that we import imports us; and hence whether to + -- look for a hi-boot file + boot_iface <- tcHiBootIface hsc_src this_mod ; + + -- Rename and type check the declarations + traceRn (text "rn1a") ; + tcg_env <- if isHsBoot hsc_src then + tcRnHsBootDecls local_decls + else + {-# SCC "tcRnSrcDecls" #-} tcRnSrcDecls boot_iface local_decls ; - setGblEnv tcg_env $ do { - - -- Report the use of any deprecated things - -- We do this *before* processsing the export list so - -- that we don't bleat about re-exporting a deprecated - -- thing (especially via 'module Foo' export item) - -- That is, only uses in the *body* of the module are complained about - traceRn (text "rn3") ; - failIfErrsM ; -- finishWarnings crashes sometimes - -- as a result of typechecker repairs (e.g. unboundNames) - tcg_env <- finishWarnings (hsc_dflags hsc_env) mod_deprec tcg_env ; - - -- Process the export list + setGblEnv tcg_env $ do { + + -- Report the use of any deprecated things + -- We do this *before* processsing the export list so + -- that we don't bleat about re-exporting a deprecated + -- thing (especially via 'module Foo' export item) + -- That is, only uses in the *body* of the module are complained about + traceRn (text "rn3") ; + failIfErrsM ; -- finishWarnings crashes sometimes + -- as a result of typechecker repairs (e.g. unboundNames) + tcg_env <- finishWarnings (hsc_dflags hsc_env) mod_deprec tcg_env ; + + -- Process the export list traceRn (text "rn4a: before exports"); - tcg_env <- rnExports (isJust maybe_mod) export_ies tcg_env ; - traceRn (text "rn4b: after exports") ; + tcg_env <- rnExports (isJust maybe_mod) export_ies tcg_env ; + traceRn (text "rn4b: after exports") ; -- Check that main is exported (must be after rnExports) checkMainExported tcg_env ; - -- Compare the hi-boot iface (if any) with the real thing - -- Must be done after processing the exports - tcg_env <- checkHiBootIface tcg_env boot_iface ; + -- Compare the hi-boot iface (if any) with the real thing + -- Must be done after processing the exports + tcg_env <- checkHiBootIface tcg_env boot_iface ; - -- The new type env is already available to stuff slurped from - -- interface files, via TcEnv.updateGlobalTypeEnv - -- It's important that this includes the stuff in checkHiBootIface, - -- because the latter might add new bindings for boot_dfuns, - -- which may be mentioned in imported unfoldings + -- The new type env is already available to stuff slurped from + -- interface files, via TcEnv.updateGlobalTypeEnv + -- It's important that this includes the stuff in checkHiBootIface, + -- because the latter might add new bindings for boot_dfuns, + -- which may be mentioned in imported unfoldings - -- Don't need to rename the Haddock documentation, - -- it's not parsed by GHC anymore. - tcg_env <- return (tcg_env { tcg_doc_hdr = maybe_doc_hdr }) ; + -- Don't need to rename the Haddock documentation, + -- it's not parsed by GHC anymore. + tcg_env <- return (tcg_env { tcg_doc_hdr = maybe_doc_hdr }) ; - -- Report unused names - reportUnusedNames export_ies tcg_env ; + -- Report unused names + reportUnusedNames export_ies tcg_env ; -- add extra source files to tcg_dependent_files addDependentFiles src_files ; -- Dump output and return - tcDump tcg_env ; - return tcg_env + tcDump tcg_env ; + return tcg_env }}}} @@ -229,94 +222,94 @@ implicitPreludeWarn %************************************************************************ -%* * - Import declarations -%* * +%* * + Import declarations +%* * %************************************************************************ \begin{code} -tcRnImports :: HscEnv -> Module +tcRnImports :: HscEnv -> Module -> [LImportDecl RdrName] -> TcM TcGblEnv tcRnImports hsc_env this_mod import_decls - = do { (rn_imports, rdr_env, imports,hpc_info) <- rnImports import_decls ; - - ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface) - -- Make sure we record the dependencies from the DynFlags in the EPS or we - -- end up hitting the sanity check in LoadIface.loadInterface that - -- checks for unknown home-package modules being loaded. We put - -- these dependencies on the left so their (non-source) imports - -- take precedence over the (possibly-source) imports on the right. - -- We don't add them to any other field (e.g. the imp_dep_mods of - -- imports) because we don't want to load their instances etc. - ; dep_mods = listToUFM [(mod_nm, (mod_nm, False)) | mod_nm <- dynFlagDependencies (hsc_dflags hsc_env)] - `plusUFM` imp_dep_mods imports - - -- We want instance declarations from all home-package - -- modules below this one, including boot modules, except - -- ourselves. The 'except ourselves' is so that we don't - -- get the instances from this module's hs-boot file - ; want_instances :: ModuleName -> Bool - ; want_instances mod = mod `elemUFM` dep_mods - && mod /= moduleName this_mod - ; (home_insts, home_fam_insts) = hptInstances hsc_env + = do { (rn_imports, rdr_env, imports,hpc_info) <- rnImports import_decls ; + + ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface) + -- Make sure we record the dependencies from the DynFlags in the EPS or we + -- end up hitting the sanity check in LoadIface.loadInterface that + -- checks for unknown home-package modules being loaded. We put + -- these dependencies on the left so their (non-source) imports + -- take precedence over the (possibly-source) imports on the right. + -- We don't add them to any other field (e.g. the imp_dep_mods of + -- imports) because we don't want to load their instances etc. + ; dep_mods = listToUFM [(mod_nm, (mod_nm, False)) | mod_nm <- dynFlagDependencies (hsc_dflags hsc_env)] + `plusUFM` imp_dep_mods imports + + -- We want instance declarations from all home-package + -- modules below this one, including boot modules, except + -- ourselves. The 'except ourselves' is so that we don't + -- get the instances from this module's hs-boot file + ; want_instances :: ModuleName -> Bool + ; want_instances mod = mod `elemUFM` dep_mods + && mod /= moduleName this_mod + ; (home_insts, home_fam_insts) = hptInstances hsc_env want_instances - } ; + } ; - -- Record boot-file info in the EPS, so that it's - -- visible to loadHiBootInterface in tcRnSrcDecls, - -- and any other incrementally-performed imports - ; updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ; + -- Record boot-file info in the EPS, so that it's + -- visible to loadHiBootInterface in tcRnSrcDecls, + -- and any other incrementally-performed imports + ; updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ; - -- Update the gbl env - ; updGblEnv ( \ gbl -> - gbl { + -- Update the gbl env + ; updGblEnv ( \ gbl -> + gbl { tcg_rdr_env = plusOccEnv (tcg_rdr_env gbl) rdr_env, - tcg_imports = tcg_imports gbl `plusImportAvails` imports, + tcg_imports = tcg_imports gbl `plusImportAvails` imports, tcg_rn_imports = rn_imports, - tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts, - tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl) + tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts, + tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl) home_fam_insts, - tcg_hpc = hpc_info - }) $ do { - - ; traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) - -- Fail if there are any errors so far - -- The error printing (if needed) takes advantage - -- of the tcg_env we have now set --- ; traceIf (text "rdr_env: " <+> ppr rdr_env) - ; failIfErrsM - - -- Load any orphan-module and family instance-module - -- interfaces, so that their rules and instance decls will be - -- found. - ; loadModuleInterfaces (ptext (sLit "Loading orphan modules")) + tcg_hpc = hpc_info + }) $ do { + + ; traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) + -- Fail if there are any errors so far + -- The error printing (if needed) takes advantage + -- of the tcg_env we have now set +-- ; traceIf (text "rdr_env: " <+> ppr rdr_env) + ; failIfErrsM + + -- Load any orphan-module and family instance-module + -- interfaces, so that their rules and instance decls will be + -- found. + ; loadModuleInterfaces (ptext (sLit "Loading orphan modules")) (imp_orphs imports) -- Check type-family consistency - ; traceRn (text "rn1: checking family instance consistency") - ; let { dir_imp_mods = moduleEnvKeys - . imp_mods - $ imports } - ; checkFamInstConsistency (imp_finsts imports) dir_imp_mods ; + ; traceRn (text "rn1: checking family instance consistency") + ; let { dir_imp_mods = moduleEnvKeys + . imp_mods + $ imports } + ; checkFamInstConsistency (imp_finsts imports) dir_imp_mods ; - ; getGblEnv } } + ; getGblEnv } } \end{code} %************************************************************************ -%* * - Type-checking external-core modules -%* * +%* * + Type-checking external-core modules +%* * %************************************************************************ \begin{code} -tcRnExtCore :: HscEnv - -> HsExtCore RdrName - -> IO (Messages, Maybe ModGuts) - -- Nothing => some error occurred +tcRnExtCore :: HscEnv + -> HsExtCore RdrName + -> IO (Messages, Maybe ModGuts) + -- Nothing => some error occurred tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) - -- The decls are IfaceDecls; all names are original names + -- The decls are IfaceDecls; all names are original names = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ; initTc hsc_env ExtCoreFile False this_mod $ do { @@ -326,11 +319,11 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) -- Bring the type and class decls into scope -- ToDo: check that this doesn't need to extract the val binds. -- It seems that only the type and class decls need to be in scope below because - -- (a) tcTyAndClassDecls doesn't need the val binds, and + -- (a) tcTyAndClassDecls doesn't need the val binds, and -- (b) tcExtCoreBindings doesn't need anything -- (in fact, it might not even need to be in the scope of -- this tcg_env at all) - (tc_envs, _bndrs) <- getLocalNonValBinders emptyFsEnv {- no fixity decls -} + (tc_envs, _bndrs) <- getLocalNonValBinders emptyFsEnv {- no fixity decls -} (mkFakeGroup ldecls) ; setEnvs tc_envs $ do { @@ -338,35 +331,35 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) -- The empty list is for extra dependencies coming from .hs-boot files -- See Note [Extra dependencies from .hs-boot files] in RnSource - -- Dump trace of renaming part + -- Dump trace of renaming part rnDump (ppr rn_decls) ; - -- Typecheck them all together so that - -- any mutually recursive types are done right - -- Just discard the auxiliary bindings; they are generated - -- only for Haskell source code, and should already be in Core + -- Typecheck them all together so that + -- any mutually recursive types are done right + -- Just discard the auxiliary bindings; they are generated + -- only for Haskell source code, and should already be in Core tcg_env <- tcTyAndClassDecls emptyModDetails rn_decls ; dep_files <- liftIO $ readIORef (tcg_dependent_files tcg_env) ; setGblEnv tcg_env $ do { - -- Make the new type env available to stuff slurped from interface files - - -- Now the core bindings + -- Make the new type env available to stuff slurped from interface files + + -- Now the core bindings core_binds <- initIfaceExtCore (tcExtCoreBindings src_binds) ; - -- Wrap up + -- Wrap up let { - bndrs = bindersOfBinds core_binds ; - my_exports = map (Avail . idName) bndrs ; - -- ToDo: export the data types also? + bndrs = bindersOfBinds core_binds ; + my_exports = map (Avail . idName) bndrs ; + -- ToDo: export the data types also? mod_guts = ModGuts { mg_module = this_mod, - mg_boot = False, + mg_boot = False, mg_used_names = emptyNameSet, -- ToDo: compute usage mg_used_th = False, mg_dir_imps = emptyModuleEnv, -- ?? - mg_deps = noDependencies, -- ?? + mg_deps = noDependencies, -- ?? mg_exports = my_exports, mg_tcs = tcg_tcs tcg_env, mg_insts = tcg_insts tcg_env, @@ -402,43 +395,43 @@ mkFakeGroup decls -- Rather clumsy; lots of unused fields %************************************************************************ -%* * - Type-checking the top level of a module -%* * +%* * + Type-checking the top level of a module +%* * %************************************************************************ \begin{code} tcRnSrcDecls :: ModDetails -> [LHsDecl RdrName] -> TcM TcGblEnv - -- Returns the variables free in the decls - -- Reason: solely to report unused imports and bindings + -- Returns the variables free in the decls + -- Reason: solely to report unused imports and bindings tcRnSrcDecls boot_iface decls - = do { -- Do all the declarations - ((tcg_env, tcl_env), lie) <- captureConstraints $ tc_rn_src_decls boot_iface decls ; + = do { -- Do all the declarations + ((tcg_env, tcl_env), lie) <- captureConstraints $ tc_rn_src_decls boot_iface decls ; ; traceTc "Tc8" empty ; - ; setEnvs (tcg_env, tcl_env) $ - do { - - -- Finish simplifying class constraints - -- - -- simplifyTop deals with constant or ambiguous InstIds. - -- How could there be ambiguous ones? They can only arise if a - -- top-level decl falls under the monomorphism restriction - -- and no subsequent decl instantiates its type. - -- - -- We do this after checkMain, so that we use the type info - -- that checkMain adds - -- - -- We do it with both global and local env in scope: - -- * the global env exposes the instances to simplifyTop - -- * the local env exposes the local Ids to simplifyTop, - -- so that we get better error messages (monomorphism restriction) - new_ev_binds <- {-# SCC "simplifyTop" #-} + ; setEnvs (tcg_env, tcl_env) $ + do { + + -- Finish simplifying class constraints + -- + -- simplifyTop deals with constant or ambiguous InstIds. + -- How could there be ambiguous ones? They can only arise if a + -- top-level decl falls under the monomorphism restriction + -- and no subsequent decl instantiates its type. + -- + -- We do this after checkMain, so that we use the type info + -- that checkMain adds + -- + -- We do it with both global and local env in scope: + -- * the global env exposes the instances to simplifyTop + -- * the local env exposes the local Ids to simplifyTop, + -- so that we get better error messages (monomorphism restriction) + new_ev_binds <- {-# SCC "simplifyTop" #-} simplifyTop lie ; traceTc "Tc9" empty ; - failIfErrsM ; -- Don't zonk if there have been errors - -- It's a waste of time; and we may get debug warnings - -- about strangely-typed TyCons! + failIfErrsM ; -- Don't zonk if there have been errors + -- It's a waste of time; and we may get debug warnings + -- about strangely-typed TyCons! -- Zonk the final code. This must be done last. -- Even simplifyTop may do some unification. @@ -453,76 +446,76 @@ tcRnSrcDecls boot_iface decls tcg_fords = fords } = tcg_env ; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ; - (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects') + (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects') <- {-# SCC "zonkTopDecls" #-} zonkTopDecls all_ev_binds binds sig_ns rules vects imp_specs fords ; - + let { final_type_env = extendTypeEnvWithIds type_env bind_ids ; tcg_env' = tcg_env { tcg_binds = binds', tcg_ev_binds = ev_binds', tcg_imp_specs = imp_specs', - tcg_rules = rules', - tcg_vects = vects', + tcg_rules = rules', + tcg_vects = vects', tcg_fords = fords' } } ; setGlobalTypeEnv tcg_env' final_type_env } } -tc_rn_src_decls :: ModDetails - -> [LHsDecl RdrName] +tc_rn_src_decls :: ModDetails + -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv) --- Loops around dealing with each top level inter-splice group +-- Loops around dealing with each top level inter-splice group -- in turn, until it's dealt with the entire module tc_rn_src_decls boot_details ds = {-# SCC "tc_rn_src_decls" #-} do { (first_group, group_tail) <- findSplice ds ; - -- If ds is [] we get ([], Nothing) - - -- The extra_deps are needed while renaming type and class declarations + -- If ds is [] we get ([], Nothing) + + -- The extra_deps are needed while renaming type and class declarations -- See Note [Extra dependencies from .hs-boot files] in RnSource - let { extra_deps = map tyConName (typeEnvTyCons (md_types boot_details)) } ; - -- Deal with decls up to, but not including, the first splice - (tcg_env, rn_decls) <- rnTopSrcDecls extra_deps first_group ; - -- rnTopSrcDecls fails if there are any errors - - (tcg_env, tcl_env) <- setGblEnv tcg_env $ - tcTopSrcDecls boot_details rn_decls ; - - -- If there is no splice, we're nearly done - setEnvs (tcg_env, tcl_env) $ - case group_tail of { - Nothing -> do { tcg_env <- checkMain ; -- Check for `main' - return (tcg_env, tcl_env) - } ; + let { extra_deps = map tyConName (typeEnvTyCons (md_types boot_details)) } ; + -- Deal with decls up to, but not including, the first splice + (tcg_env, rn_decls) <- rnTopSrcDecls extra_deps first_group ; + -- rnTopSrcDecls fails if there are any errors + + (tcg_env, tcl_env) <- setGblEnv tcg_env $ + tcTopSrcDecls boot_details rn_decls ; + + -- If there is no splice, we're nearly done + setEnvs (tcg_env, tcl_env) $ + case group_tail of { + Nothing -> do { tcg_env <- checkMain ; -- Check for `main' + return (tcg_env, tcl_env) + } ; #ifndef GHCI - -- There shouldn't be a splice - Just (SpliceDecl {}, _) -> do { - failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler") + -- There shouldn't be a splice + Just (SpliceDecl {}, _) -> do { + failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler") #else - -- If there's a splice, we must carry on - Just (SpliceDecl splice_expr _, rest_ds) -> do { + -- If there's a splice, we must carry on + Just (SpliceDecl splice_expr _, rest_ds) -> do { - -- Rename the splice expression, and get its supporting decls - (rn_splice_expr, splice_fvs) <- checkNoErrs (rnLExpr splice_expr) ; - -- checkNoErrs: don't typecheck if renaming failed - rnDump (ppr rn_splice_expr) ; + -- Rename the splice expression, and get its supporting decls + (rn_splice_expr, splice_fvs) <- checkNoErrs (rnLExpr splice_expr) ; + -- checkNoErrs: don't typecheck if renaming failed + rnDump (ppr rn_splice_expr) ; - -- Execute the splice - spliced_decls <- tcSpliceDecls rn_splice_expr ; + -- Execute the splice + spliced_decls <- tcSpliceDecls rn_splice_expr ; - -- Glue them on the front of the remaining decls and loop - setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $ - tc_rn_src_decls boot_details (spliced_decls ++ rest_ds) + -- Glue them on the front of the remaining decls and loop + setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $ + tc_rn_src_decls boot_details (spliced_decls ++ rest_ds) #endif /* GHCI */ } } } \end{code} %************************************************************************ -%* * - Compiling hs-boot source files, and - comparing the hi-boot interface with the real thing -%* * +%* * + Compiling hs-boot source files, and + comparing the hi-boot interface with the real thing +%* * %************************************************************************ \begin{code} @@ -530,69 +523,69 @@ tcRnHsBootDecls :: [LHsDecl RdrName] -> TcM TcGblEnv tcRnHsBootDecls decls = do { (first_group, group_tail) <- findSplice decls - -- Rename the declarations - ; (tcg_env, HsGroup { - hs_tyclds = tycl_decls, - hs_instds = inst_decls, - hs_derivds = deriv_decls, - hs_fords = for_decls, - hs_defds = def_decls, - hs_ruleds = rule_decls, - hs_vects = vect_decls, - hs_annds = _, - hs_valds = val_binds }) <- rnTopSrcDecls [] first_group + -- Rename the declarations + ; (tcg_env, HsGroup { + hs_tyclds = tycl_decls, + hs_instds = inst_decls, + hs_derivds = deriv_decls, + hs_fords = for_decls, + hs_defds = def_decls, + hs_ruleds = rule_decls, + hs_vects = vect_decls, + hs_annds = _, + hs_valds = val_binds }) <- rnTopSrcDecls [] first_group -- The empty list is for extra dependencies coming from .hs-boot files -- See Note [Extra dependencies from .hs-boot files] in RnSource - ; (gbl_env, lie) <- captureConstraints $ setGblEnv tcg_env $ do { - - - -- Check for illegal declarations - ; case group_tail of - Just (SpliceDecl d _, _) -> badBootDecl "splice" d - Nothing -> return () - ; mapM_ (badBootDecl "foreign") for_decls - ; mapM_ (badBootDecl "default") def_decls - ; mapM_ (badBootDecl "rule") rule_decls - ; mapM_ (badBootDecl "vect") vect_decls - - -- Typecheck type/class decls - ; traceTc "Tc2" empty - ; tcg_env <- tcTyAndClassDecls emptyModDetails tycl_decls - ; setGblEnv tcg_env $ do { - - -- Typecheck instance decls - -- Family instance declarations are rejected here - ; traceTc "Tc3" empty - ; (tcg_env, inst_infos, _deriv_binds) + ; (gbl_env, lie) <- captureConstraints $ setGblEnv tcg_env $ do { + + + -- Check for illegal declarations + ; case group_tail of + Just (SpliceDecl d _, _) -> badBootDecl "splice" d + Nothing -> return () + ; mapM_ (badBootDecl "foreign") for_decls + ; mapM_ (badBootDecl "default") def_decls + ; mapM_ (badBootDecl "rule") rule_decls + ; mapM_ (badBootDecl "vect") vect_decls + + -- Typecheck type/class decls + ; traceTc "Tc2 (boot)" empty + ; tcg_env <- tcTyAndClassDecls emptyModDetails tycl_decls + ; setGblEnv tcg_env $ do { + + -- Typecheck instance decls + -- Family instance declarations are rejected here + ; traceTc "Tc3" empty + ; (tcg_env, inst_infos, _deriv_binds) <- tcInstDecls1 (concat tycl_decls) inst_decls deriv_decls - ; setGblEnv tcg_env $ do { - - -- Typecheck value declarations - ; traceTc "Tc5" empty - ; val_ids <- tcHsBootSigs val_binds - - -- Wrap up - -- No simplification or zonking to do - ; traceTc "Tc7a" empty - ; gbl_env <- getGblEnv - - -- Make the final type-env - -- Include the dfun_ids so that their type sigs - -- are written into the interface file. - ; let { type_env0 = tcg_type_env gbl_env - ; type_env1 = extendTypeEnvWithIds type_env0 val_ids - ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids - ; dfun_ids = map iDFunId inst_infos - } - - ; setGlobalTypeEnv gbl_env type_env2 + ; setGblEnv tcg_env $ do { + + -- Typecheck value declarations + ; traceTc "Tc5" empty + ; val_ids <- tcHsBootSigs val_binds + + -- Wrap up + -- No simplification or zonking to do + ; traceTc "Tc7a" empty + ; gbl_env <- getGblEnv + + -- Make the final type-env + -- Include the dfun_ids so that their type sigs + -- are written into the interface file. + ; let { type_env0 = tcg_type_env gbl_env + ; type_env1 = extendTypeEnvWithIds type_env0 val_ids + ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids + ; dfun_ids = map iDFunId inst_infos + } + + ; setGlobalTypeEnv gbl_env type_env2 }}} ; traceTc "boot" (ppr lie); return gbl_env } badBootDecl :: String -> Located decl -> TcM () -badBootDecl what (L loc _) - = addErrAt loc (char 'A' <+> text what +badBootDecl what (L loc _) + = addErrAt loc (char 'A' <+> text what <+> ptext (sLit "declaration is not (currently) allowed in a hs-boot file")) \end{code} @@ -607,34 +600,34 @@ checkHiBootIface :: TcGblEnv -> ModDetails -> TcM TcGblEnv -- of boot_names is empty. -- -- The bindings we return give bindings for the dfuns defined in the --- hs-boot file, such as $fbEqT = $fEqT +-- hs-boot file, such as $fbEqT = $fEqT checkHiBootIface - tcg_env@(TcGblEnv { tcg_src = hs_src, tcg_binds = binds, - tcg_insts = local_insts, - tcg_type_env = local_type_env, tcg_exports = local_exports }) - (ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_insts, - md_types = boot_type_env, md_exports = boot_exports }) - | isHsBoot hs_src -- Current module is already a hs-boot file! - = return tcg_env + tcg_env@(TcGblEnv { tcg_src = hs_src, tcg_binds = binds, + tcg_insts = local_insts, + tcg_type_env = local_type_env, tcg_exports = local_exports }) + (ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_insts, + md_types = boot_type_env, md_exports = boot_exports }) + | isHsBoot hs_src -- Current module is already a hs-boot file! + = return tcg_env | otherwise - = do { traceTc "checkHiBootIface" $ vcat + = do { traceTc "checkHiBootIface" $ vcat [ ppr boot_type_env, ppr boot_insts, ppr boot_exports] - -- Check the exports of the boot module, one by one - ; mapM_ check_export boot_exports + -- Check the exports of the boot module, one by one + ; mapM_ check_export boot_exports - -- Check for no family instances - ; unless (null boot_fam_insts) $ - panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++ - "instances in boot files yet...") + -- Check for no family instances + ; unless (null boot_fam_insts) $ + panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++ + "instances in boot files yet...") -- FIXME: Why? The actual comparison is not hard, but what would - -- be the equivalent to the dfun bindings returned for class - -- instances? We can't easily equate tycons... + -- be the equivalent to the dfun bindings returned for class + -- instances? We can't easily equate tycons... - -- Check instance declarations - ; mb_dfun_prs <- mapM check_inst boot_insts + -- Check instance declarations + ; mb_dfun_prs <- mapM check_inst boot_insts ; let dfun_prs = catMaybes mb_dfun_prs boot_dfuns = map fst dfun_prs dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun) @@ -643,34 +636,34 @@ checkHiBootIface tcg_env' = tcg_env { tcg_binds = binds `unionBags` dfun_binds } ; failIfErrsM - ; setGlobalTypeEnv tcg_env' type_env' } - -- Update the global type env *including* the knot-tied one + ; setGlobalTypeEnv tcg_env' type_env' } + -- Update the global type env *including* the knot-tied one -- so that if the source module reads in an interface unfolding -- mentioning one of the dfuns from the boot module, then it -- can "see" that boot dfun. See Trac #4003 where - check_export boot_avail -- boot_avail is exported by the boot iface - | name `elem` dfun_names = return () - | isWiredInName name = return () -- No checking for wired-in names. In particular, - -- 'error' is handled by a rather gross hack - -- (see comments in GHC.Err.hs-boot) + check_export boot_avail -- boot_avail is exported by the boot iface + | name `elem` dfun_names = return () + | isWiredInName name = return () -- No checking for wired-in names. In particular, + -- 'error' is handled by a rather gross hack + -- (see comments in GHC.Err.hs-boot) - -- Check that the actual module exports the same thing + -- Check that the actual module exports the same thing | not (null missing_names) - = addErrAt (nameSrcSpan (head missing_names)) + = addErrAt (nameSrcSpan (head missing_names)) (missingBootThing (head missing_names) "exported by") - -- If the boot module does not *define* the thing, we are done - -- (it simply re-exports it, and names match, so nothing further to do) + -- If the boot module does not *define* the thing, we are done + -- (it simply re-exports it, and names match, so nothing further to do) | isNothing mb_boot_thing = return () - -- Check that the actual module also defines the thing, and - -- then compare the definitions + -- Check that the actual module also defines the thing, and + -- then compare the definitions | Just real_thing <- lookupTypeEnv local_type_env name, Just boot_thing <- mb_boot_thing = when (not (checkBootDecl boot_thing real_thing)) $ addErrAt (nameSrcSpan (getName boot_thing)) - (let boot_decl = tyThingToIfaceDecl + (let boot_decl = tyThingToIfaceDecl (fromJust mb_boot_thing) real_decl = tyThingToIfaceDecl real_thing in bootMisMatch real_thing boot_decl real_decl) @@ -678,33 +671,33 @@ checkHiBootIface | otherwise = addErrTc (missingBootThing name "defined in") where - name = availName boot_avail - mb_boot_thing = lookupTypeEnv boot_type_env name - missing_names = case lookupNameEnv local_export_env name of - Nothing -> [name] - Just avail -> availNames boot_avail `minusList` availNames avail - + name = availName boot_avail + mb_boot_thing = lookupTypeEnv boot_type_env name + missing_names = case lookupNameEnv local_export_env name of + Nothing -> [name] + Just avail -> availNames boot_avail `minusList` availNames avail + dfun_names = map getName boot_insts local_export_env :: NameEnv AvailInfo local_export_env = availsToNameEnv local_exports check_inst :: ClsInst -> TcM (Maybe (Id, Id)) - -- Returns a pair of the boot dfun in terms of the equivalent real dfun + -- Returns a pair of the boot dfun in terms of the equivalent real dfun check_inst boot_inst - = case [dfun | inst <- local_insts, - let dfun = instanceDFunId inst, - idType dfun `eqType` boot_inst_ty ] of - [] -> do { traceTc "check_inst" (vcat [ text "local_insts" <+> vcat (map (ppr . idType . instanceDFunId) local_insts) + = case [dfun | inst <- local_insts, + let dfun = instanceDFunId inst, + idType dfun `eqType` boot_inst_ty ] of + [] -> do { traceTc "check_inst" (vcat [ text "local_insts" <+> vcat (map (ppr . idType . instanceDFunId) local_insts) , text "boot_inst" <+> ppr boot_inst , text "boot_inst_ty" <+> ppr boot_inst_ty - ]) + ]) ; addErrTc (instMisMatch boot_inst); return Nothing } - (dfun:_) -> return (Just (local_boot_dfun, dfun)) - where - boot_dfun = instanceDFunId boot_inst - boot_inst_ty = idType boot_dfun - local_boot_dfun = Id.mkExportedLocalId (idName boot_dfun) boot_inst_ty + (dfun:_) -> return (Just (local_boot_dfun, dfun)) + where + boot_dfun = instanceDFunId boot_inst + boot_inst_ty = idType boot_dfun + local_boot_dfun = Id.mkExportedLocalId (idName boot_dfun) boot_inst_ty -- This has to compare the TyThing from the .hi-boot file to the TyThing @@ -717,7 +710,7 @@ checkHiBootIface checkBootDecl :: TyThing -> TyThing -> Bool checkBootDecl (AnId id1) (AnId id2) - = ASSERT(id1 == id2) + = ASSERT(id1 == id2) (idType id1 `eqType` idType id2) checkBootDecl (ATyCon tc1) (ATyCon tc2) @@ -732,14 +725,14 @@ checkBootDecl _ _ = False -- probably shouldn't happen checkBootTyCon :: TyCon -> TyCon -> Bool checkBootTyCon tc1 tc2 | not (eqKind (tyConKind tc1) (tyConKind tc2)) - = False -- First off, check the kind + = False -- First off, check the kind | Just c1 <- tyConClass_maybe tc1 , Just c2 <- tyConClass_maybe tc2 - = let - (clas_tyvars1, clas_fds1, sc_theta1, _, ats1, op_stuff1) + = let + (clas_tyvars1, clas_fds1, sc_theta1, _, ats1, op_stuff1) = classExtraBigSig c1 - (clas_tyvars2, clas_fds2, sc_theta2, _, ats2, op_stuff2) + (clas_tyvars2, clas_fds2, sc_theta2, _, ats2, op_stuff2) = classExtraBigSig c2 env0 = mkRnEnv2 emptyInScopeSet @@ -766,7 +759,7 @@ checkBootTyCon tc1 tc2 eqTypeX env ty1 ty2 where env = rnBndrs2 env0 tvs1 tvs2 - eqFD (as1,bs1) (as2,bs2) = + eqFD (as1,bs1) (as2,bs2) = eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) && eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2) @@ -779,7 +772,7 @@ checkBootTyCon tc1 tc2 || -- Above tests for an "abstract" class eqListBy (eqPredX env) sc_theta1 sc_theta2 && eqListBy eqSig op_stuff1 op_stuff2 && - eqListBy eqAT ats1 ats2) + eqListBy eqAT ats1 ats2) | isSynTyCon tc1 && isSynTyCon tc2 = ASSERT(tc1 == tc2) @@ -806,11 +799,11 @@ checkBootTyCon tc1 tc2 tyConExtName tc1 == tyConExtName tc2 | otherwise = False - where + where env0 = mkRnEnv2 emptyInScopeSet - eqAlgRhs (AbstractTyCon dis1) rhs2 - | dis1 = isDistinctAlgRhs rhs2 --Check compatibility + eqAlgRhs (AbstractTyCon dis1) rhs2 + | dis1 = isDistinctAlgRhs rhs2 --Check compatibility | otherwise = True eqAlgRhs DataFamilyTyCon{} DataFamilyTyCon{} = True eqAlgRhs tc1@DataTyCon{} tc2@DataTyCon{} = @@ -829,14 +822,14 @@ checkBootTyCon tc1 tc2 ---------------- missingBootThing :: Name -> String -> SDoc missingBootThing name what - = ppr name <+> ptext (sLit "is exported by the hs-boot file, but not") - <+> text what <+> ptext (sLit "the module") + = ppr name <+> ptext (sLit "is exported by the hs-boot file, but not") + <+> text what <+> ptext (sLit "the module") bootMisMatch :: TyThing -> IfaceDecl -> IfaceDecl -> SDoc bootMisMatch thing boot_decl real_decl = vcat [ppr thing <+> ptext (sLit "has conflicting definitions in the module and its hs-boot file"), - ptext (sLit "Main module:") <+> ppr real_decl, - ptext (sLit "Boot file: ") <+> ppr boot_decl] + ptext (sLit "Main module:") <+> ppr real_decl, + ptext (sLit "Boot file: ") <+> ppr boot_decl] instMisMatch :: ClsInst -> SDoc instMisMatch inst @@ -846,9 +839,9 @@ instMisMatch inst %************************************************************************ -%* * - Type-checking the top level of a module -%* * +%* * + Type-checking the top level of a module +%* * %************************************************************************ tcRnGroup takes a bunch of top-level source-code declarations, and @@ -869,70 +862,70 @@ rnTopSrcDecls :: [Name] -> HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name) rnTopSrcDecls extra_deps group = do { -- Rename the source decls traceTc "rn12" empty ; - (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls extra_deps group ; + (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls extra_deps group ; traceTc "rn13" empty ; -- save the renamed syntax, if we want it - let { tcg_env' - | Just grp <- tcg_rn_decls tcg_env - = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) } - | otherwise - = tcg_env }; + let { tcg_env' + | Just grp <- tcg_rn_decls tcg_env + = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) } + | otherwise + = tcg_env }; - -- Dump trace of renaming part - rnDump (ppr rn_decls) ; + -- Dump trace of renaming part + rnDump (ppr rn_decls) ; - return (tcg_env', rn_decls) + return (tcg_env', rn_decls) } ------------------------------------------------ tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv) -tcTopSrcDecls boot_details - (HsGroup { hs_tyclds = tycl_decls, - hs_instds = inst_decls, +tcTopSrcDecls boot_details + (HsGroup { hs_tyclds = tycl_decls, + hs_instds = inst_decls, hs_derivds = deriv_decls, - hs_fords = foreign_decls, - hs_defds = default_decls, - hs_annds = annotation_decls, - hs_ruleds = rule_decls, - hs_vects = vect_decls, - hs_valds = val_binds }) - = do { -- Type-check the type and class decls, and all imported decls - -- The latter come in via tycl_decls - traceTc "Tc2" empty ; - - tcg_env <- tcTyAndClassDecls boot_details tycl_decls ; - setGblEnv tcg_env $ do { - - -- Source-language instances, including derivings, - -- and import the supporting declarations + hs_fords = foreign_decls, + hs_defds = default_decls, + hs_annds = annotation_decls, + hs_ruleds = rule_decls, + hs_vects = vect_decls, + hs_valds = val_binds }) + = do { -- Type-check the type and class decls, and all imported decls + -- The latter come in via tycl_decls + traceTc "Tc2 (src)" empty ; + + tcg_env <- tcTyAndClassDecls boot_details tycl_decls ; + setGblEnv tcg_env $ do { + + -- Source-language instances, including derivings, + -- and import the supporting declarations traceTc "Tc3" empty ; - (tcg_env, inst_infos, deriv_binds) + (tcg_env, inst_infos, deriv_binds) <- tcInstDecls1 (concat tycl_decls) inst_decls deriv_decls; - setGblEnv tcg_env $ do { + setGblEnv tcg_env $ do { - -- Foreign import declarations next. + -- Foreign import declarations next. traceTc "Tc4" empty ; - (fi_ids, fi_decls) <- tcForeignImports foreign_decls ; - tcExtendGlobalValEnv fi_ids $ do { + (fi_ids, fi_decls) <- tcForeignImports foreign_decls ; + tcExtendGlobalValEnv fi_ids $ do { - -- Default declarations + -- Default declarations traceTc "Tc4a" empty ; - default_tys <- tcDefaults default_decls ; - updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do { - - -- Now GHC-generated derived bindings, generics, and selectors - -- Do not generate warnings from compiler-generated code; - -- hence the use of discardWarnings - tc_envs <- discardWarnings (tcTopBinds deriv_binds) ; + default_tys <- tcDefaults default_decls ; + updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do { + + -- Now GHC-generated derived bindings, generics, and selectors + -- Do not generate warnings from compiler-generated code; + -- hence the use of discardWarnings + tc_envs <- discardWarnings (tcTopBinds deriv_binds) ; setEnvs tc_envs $ do { - -- Value declarations next + -- Value declarations next traceTc "Tc5" empty ; - tc_envs@(tcg_env, tcl_env) <- tcTopBinds val_binds; - setEnvs tc_envs $ do { -- Environment doesn't change now + tc_envs@(tcg_env, tcl_env) <- tcTopBinds val_binds; + setEnvs tc_envs $ do { -- Environment doesn't change now - -- Second pass over class and instance declarations, + -- Second pass over class and instance declarations, -- now using the kind-checked decls traceTc "Tc6" empty ; inst_binds <- tcInstDecls2 (concat tycl_decls) inst_infos ; @@ -952,13 +945,13 @@ tcTopSrcDecls boot_details -- Wrap up traceTc "Tc7a" empty ; - let { all_binds = inst_binds `unionBags` - foe_binds + let { all_binds = inst_binds `unionBags` + foe_binds - ; sig_names = mkNameSet (collectHsValBinders val_binds) + ; sig_names = mkNameSet (collectHsValBinders val_binds) `minusNameSet` getTypeSigNames val_binds - -- Extend the GblEnv with the (as yet un-zonked) + -- Extend the GblEnv with the (as yet un-zonked) -- bindings, rules, foreign decls ; tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds , tcg_sigs = tcg_sigs tcg_env `unionNameSets` sig_names @@ -973,18 +966,18 @@ tcTopSrcDecls boot_details %************************************************************************ -%* * - Checking for 'main' -%* * +%* * + Checking for 'main' +%* * %************************************************************************ \begin{code} checkMain :: TcM TcGblEnv -- If we are in module Main, check that 'main' is defined. -checkMain +checkMain = do { tcg_env <- getGblEnv ; - dflags <- getDynFlags ; - check_main dflags tcg_env + dflags <- getDynFlags ; + check_main dflags tcg_env } check_main :: DynFlags -> TcGblEnv -> TcM TcGblEnv @@ -994,59 +987,59 @@ check_main dflags tcg_env return tcg_env | otherwise - = do { mb_main <- lookupGlobalOccRn_maybe main_fn - -- Check that 'main' is in scope - -- It might be imported from another module! - ; case mb_main of { - Nothing -> do { traceTc "checkMain fail" (ppr main_mod <+> ppr main_fn) - ; complain_no_main - ; return tcg_env } ; - Just main_name -> do - - { traceTc "checkMain found" (ppr main_mod <+> ppr main_fn) - ; let loc = srcLocSpan (getSrcLoc main_name) - ; ioTyCon <- tcLookupTyCon ioTyConName + = do { mb_main <- lookupGlobalOccRn_maybe main_fn + -- Check that 'main' is in scope + -- It might be imported from another module! + ; case mb_main of { + Nothing -> do { traceTc "checkMain fail" (ppr main_mod <+> ppr main_fn) + ; complain_no_main + ; return tcg_env } ; + Just main_name -> do + + { traceTc "checkMain found" (ppr main_mod <+> ppr main_fn) + ; let loc = srcLocSpan (getSrcLoc main_name) + ; ioTyCon <- tcLookupTyCon ioTyConName ; res_ty <- newFlexiTyVarTy liftedTypeKind - ; main_expr - <- addErrCtxt mainCtxt $ - tcMonoExpr (L loc (HsVar main_name)) (mkTyConApp ioTyCon [res_ty]) - - -- See Note [Root-main Id] - -- Construct the binding - -- :Main.main :: IO res_ty = runMainIO res_ty main - ; run_main_id <- tcLookupId runMainIOName - ; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN - (mkVarOccFS (fsLit "main")) - (getSrcSpan main_name) - ; root_main_id = Id.mkExportedLocalId root_main_name - (mkTyConApp ioTyCon [res_ty]) - ; co = mkWpTyApps [res_ty] - ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) main_expr - ; main_bind = mkVarBind root_main_id rhs } - - ; return (tcg_env { tcg_main = Just main_name, + ; main_expr + <- addErrCtxt mainCtxt $ + tcMonoExpr (L loc (HsVar main_name)) (mkTyConApp ioTyCon [res_ty]) + + -- See Note [Root-main Id] + -- Construct the binding + -- :Main.main :: IO res_ty = runMainIO res_ty main + ; run_main_id <- tcLookupId runMainIOName + ; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN + (mkVarOccFS (fsLit "main")) + (getSrcSpan main_name) + ; root_main_id = Id.mkExportedLocalId root_main_name + (mkTyConApp ioTyCon [res_ty]) + ; co = mkWpTyApps [res_ty] + ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) main_expr + ; main_bind = mkVarBind root_main_id rhs } + + ; return (tcg_env { tcg_main = Just main_name, tcg_binds = tcg_binds tcg_env - `snocBag` main_bind, - tcg_dus = tcg_dus tcg_env - `plusDU` usesOnly (unitFV main_name) - -- Record the use of 'main', so that we don't - -- complain about it being defined but not used - }) + `snocBag` main_bind, + tcg_dus = tcg_dus tcg_env + `plusDU` usesOnly (unitFV main_name) + -- Record the use of 'main', so that we don't + -- complain about it being defined but not used + }) }}} where - mod = tcg_mod tcg_env + mod = tcg_mod tcg_env main_mod = mainModIs dflags main_fn = getMainFun dflags complain_no_main | ghcLink dflags == LinkInMemory = return () - | otherwise = failWithTc noMainMsg - -- In interactive mode, don't worry about the absence of 'main' - -- In other modes, fail altogether, so that we don't go on - -- and complain a second time when processing the export list. + | otherwise = failWithTc noMainMsg + -- In interactive mode, don't worry about the absence of 'main' + -- In other modes, fail altogether, so that we don't go on + -- and complain a second time when processing the export list. mainCtxt = ptext (sLit "When checking the type of the") <+> pp_main_fn noMainMsg = ptext (sLit "The") <+> pp_main_fn - <+> ptext (sLit "is not defined in module") <+> quotes (ppr main_mod) + <+> ptext (sLit "is not defined in module") <+> quotes (ppr main_mod) pp_main_fn = ppMainFn main_fn ppMainFn :: RdrName -> SDoc @@ -1055,7 +1048,7 @@ ppMainFn main_fn = ptext (sLit "function") <+> quotes (ppr main_fn) | otherwise = ptext (sLit "main function") <+> quotes (ppr main_fn) - + -- | Get the unqualified name of the function to use as the \"main\" for the main module. -- Either returns the default name or the one configured on the command line with -main-is getMainFun :: DynFlags -> RdrName @@ -1081,7 +1074,7 @@ The function that the RTS invokes is always :Main.main, which we call root_main_id. (Because GHC allows the user to have a module not called Main as the main module, we can't rely on the main function being called "Main.main". That's why root_main_id has a fixed module -":Main".) +":Main".) This is unusual: it's a LocalId whose Name has a Module from another module. Tiresomely, we must filter it out again in MkIface, les we @@ -1089,16 +1082,16 @@ get two defns for 'main' in the interface file! %********************************************************* -%* * - GHCi stuff -%* * +%* * + GHCi stuff +%* * %********************************************************* \begin{code} setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a -setInteractiveContext hsc_env icxt thing_inside - = let -- Initialise the tcg_inst_env with instances from all home modules. - -- This mimics the more selective call to hptInstances in tcRnModule. +setInteractiveContext hsc_env icxt thing_inside + = let -- Initialise the tcg_inst_env with instances from all home modules. + -- This mimics the more selective call to hptInstances in tcRnImports (home_insts, home_fam_insts) = hptInstances hsc_env (\_ -> True) (ic_insts, ic_finsts) = ic_instances icxt @@ -1150,9 +1143,11 @@ setInteractiveContext hsc_env icxt thing_inside (map getOccName visible_tmp_ids) -- Note [delete shadowed tcg_rdr_env entries] , tcg_type_env = type_env + , tcg_insts = ic_insts , tcg_inst_env = extendInstEnvList (extendInstEnvList (tcg_inst_env env) ic_insts) home_insts + , tcg_fam_insts = ic_finsts , tcg_fam_inst_env = extendFamInstEnvList (extendFamInstEnvList (tcg_fam_inst_env env) ic_finsts) @@ -1165,40 +1160,26 @@ setInteractiveContext hsc_env icxt thing_inside tcExtendGhciEnv visible_tmp_ids $ -- Note [GHCi temporary Ids] thing_inside -\end{code} - -\begin{code} #ifdef GHCI -tcRnStmt :: HscEnv - -> InteractiveContext - -> LStmt RdrName - -> IO (Messages, Maybe ([Id], LHsExpr Id)) - -- The returned [Id] is the list of new Ids bound by - -- this statement. It can be used to extend the - -- InteractiveContext via extendInteractiveContext. - -- - -- The returned TypecheckedHsExpr is of type IO [ () ], - -- a list of the bound values, coerced to (). - +-- | The returned [Id] is the list of new Ids bound by this statement. It can +-- be used to extend the InteractiveContext via extendInteractiveContext. +-- +-- The returned TypecheckedHsExpr is of type IO [ () ], a list of the bound +-- values, coerced to (). +tcRnStmt :: HscEnv -> InteractiveContext -> LStmt RdrName + -> IO (Messages, Maybe ([Id], LHsExpr Id)) tcRnStmt hsc_env ictxt rdr_stmt - = initTcPrintErrors hsc_env iNTERACTIVE $ + = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext hsc_env ictxt $ do { - -- Rename; use CmdLineMode because tcRnStmt is only used interactively - (([rn_stmt], _), fvs) <- rnStmts GhciStmt [rdr_stmt] $ \_ -> - return ((), emptyFVs) ; - traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ; - failIfErrsM ; - rnDump (ppr rn_stmt) ; - -- The real work is done here - (bound_ids, tc_expr) <- mkPlan rn_stmt ; + (bound_ids, tc_expr) <- tcUserStmt rdr_stmt ; zonked_expr <- zonkTopLExpr tc_expr ; zonked_ids <- zonkTopBndrs bound_ids ; - - -- None of the Ids should be of unboxed type, because we - -- cast them all to HValues in the end! + + -- None of the Ids should be of unboxed type, because we + -- cast them all to HValues in the end! mapM_ bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ; traceTc "tcs 1" empty ; @@ -1210,37 +1191,37 @@ tcRnStmt hsc_env ictxt rdr_stmt they are inaccessible but might, I suppose, cause a space leak if we leave them there. However, with Template Haskell they aren't necessarily inaccessible. Consider this GHCi session - Prelude> let f n = n * 2 :: Int - Prelude> fName <- runQ [| f |] - Prelude> $(return $ AppE fName (LitE (IntegerL 7))) - 14 - Prelude> let f n = n * 3 :: Int - Prelude> $(return $ AppE fName (LitE (IntegerL 7))) + Prelude> let f n = n * 2 :: Int + Prelude> fName <- runQ [| f |] + Prelude> $(return $ AppE fName (LitE (IntegerL 7))) + 14 + Prelude> let f n = n * 3 :: Int + Prelude> $(return $ AppE fName (LitE (IntegerL 7))) In the last line we use 'fName', which resolves to the *first* 'f' in scope. If we delete it from the type env, GHCi crashes because it doesn't expect that. - + Hence this code is commented out -------------------------------------------------- -} - dumpOptTcRn Opt_D_dump_tc - (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids, - text "Typechecked expr" <+> ppr zonked_expr]) ; + dumpOptTcRn Opt_D_dump_tc + (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids, + text "Typechecked expr" <+> ppr zonked_expr]) ; return (global_ids, zonked_expr) } where bad_unboxed id = addErr (sep [ptext (sLit "GHCi can't bind a variable of unlifted type:"), - nest 2 (ppr id <+> dcolon <+> ppr (idType id))]) + nest 2 (ppr id <+> dcolon <+> ppr (idType id))]) \end{code} Note [Interactively-bound Ids in GHCi] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The Ids bound by previous Stmts in GHCi are currently - a) GlobalIds + a) GlobalIds b) with an Internal Name (not External) - c) and a tidied type + c) and a tidied type (a) They must be GlobalIds (not LocalIds) otherwise when we come to compile an expression using these ids later, the byte code @@ -1248,163 +1229,189 @@ The Ids bound by previous Stmts in GHCi are currently global. (b) They retain their Internal names becuase we don't have a suitable - Module to name them with. We could revisit this choice. + Module to name them with. We could revisit this choice. - (c) Their types are tidied. This is important, because :info may ask + (c) Their types are tidied. This is important, because :info may ask to look at them, and :info expects the things it looks up to have tidy types - -------------------------------------------------------------------------- - Typechecking Stmts in GHCi + Typechecking Stmts in GHCi Here is the grand plan, implemented in tcUserStmt - What you type The IO [HValue] that hscStmt returns - ------------- ------------------------------------ - let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...] - bindings: [x,y,...] + What you type The IO [HValue] that hscStmt returns + ------------- ------------------------------------ + let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...] + bindings: [x,y,...] - pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...] - bindings: [x,y,...] + pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...] + bindings: [x,y,...] - expr (of IO type) ==> expr >>= \ it -> return [coerce HVal it] - [NB: result not printed] bindings: [it] - - expr (of non-IO type, ==> let it = expr in print it >> return [coerce HVal it] - result showable) bindings: [it] + expr (of IO type) ==> expr >>= \ it -> return [coerce HVal it] + [NB: result not printed] bindings: [it] - expr (of non-IO type, - result not showable) ==> error + expr (of non-IO type, ==> let it = expr in print it >> return [coerce HVal it] + result showable) bindings: [it] + expr (of non-IO type, + result not showable) ==> error \begin{code} ---------------------------- + +-- | A plan is an attempt to lift some code into the IO monad. type PlanResult = ([Id], LHsExpr Id) type Plan = TcM PlanResult -runPlans :: [Plan] -> TcM PlanResult --- Try the plans in order. If one fails (by raising an exn), try the next. +-- | Try the plans in order. If one fails (by raising an exn), try the next. -- If one succeeds, take it. +runPlans :: [Plan] -> TcM PlanResult runPlans [] = panic "runPlans" runPlans [p] = p runPlans (p:ps) = tryTcLIE_ (runPlans ps) p --------------------- -mkPlan :: LStmt Name -> TcM PlanResult -mkPlan (L loc (ExprStmt expr _ _ _)) -- An expression typed at the prompt - = do { uniq <- newUnique -- is treated very specially +-- | Typecheck (and 'lift') a stmt entered by the user in GHCi into the +-- GHCi 'environemnt'. +-- +-- By 'lift' and 'environment we mean that the code is changed to execute +-- properly in an IO monad. See Note [Interactively-bound Ids in GHCi] above +-- for more details. We do this lifting by trying different ways ('plans') of +-- lifting the code into the IO monad and type checking each plan until one +-- succeeds. +tcUserStmt :: LStmt RdrName -> TcM PlanResult + +-- An expression typed at the prompt is treated very specially +tcUserStmt (L loc (ExprStmt expr _ _ _)) + = do { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr) + -- Don't try to typecheck if the renamer fails! + ; uniq <- newUnique ; let fresh_it = itName uniq loc - the_bind = L loc $ mkTopFunBind (L loc fresh_it) matches - matches = [mkMatch [] expr emptyLocalBinds] - let_stmt = L loc $ LetStmt $ HsValBinds $ + matches = [mkMatch [] rn_expr emptyLocalBinds] + -- [it = expr] + the_bind = L loc $ (mkTopFunBind (L loc fresh_it) matches) { bind_fvs = fvs } + -- Care here! In GHCi the expression might have + -- free variables, and they in turn may have free type variables + -- (if we are at a breakpoint, say). We must put those free vars + + + -- [let it = expr] + let_stmt = L loc $ LetStmt $ HsValBinds $ ValBindsOut [(NonRecursive,unitBag the_bind)] [] - bind_stmt = L loc $ BindStmt (L loc (VarPat fresh_it)) expr - (HsVar bindIOName) noSyntaxExpr - print_it = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it)) - (HsVar thenIOName) noSyntaxExpr placeHolderType - - -- The plans are: - -- [it <- e; print it] but not if it::() - -- [it <- e] - -- [let it = e; print it] - ; runPlans [ -- Plan A - do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it] - ; it_ty <- zonkTcType (idType it_id) - ; when (isUnitTy it_ty) failM - ; return stuff }, - - -- Plan B; a naked bind statment - tcGhciStmts [bind_stmt], - - -- Plan C; check that the let-binding is typeable all by itself. - -- If not, fail; if so, try to print it. - -- The two-step process avoids getting two errors: one from - -- the expression itself, and one from the 'print it' part - -- This two-step story is very clunky, alas - do { _ <- checkNoErrs (tcGhciStmts [let_stmt]) - --- checkNoErrs defeats the error recovery of let-bindings - ; tcGhciStmts [let_stmt, print_it] } - ]} - -mkPlan stmt@(L loc (BindStmt {})) - | [v] <- collectLStmtBinders stmt -- One binder, for a bind stmt - = do { let print_v = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar v)) - (HsVar thenIOName) noSyntaxExpr placeHolderType - - ; print_bind_result <- doptM Opt_PrintBindResult - ; let print_plan = do - { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v] - ; v_ty <- zonkTcType (idType v_id) - ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM - ; return stuff } - - -- The plans are: - -- [stmt; print v] but not if v::() - -- [stmt] - ; runPlans ((if print_bind_result then [print_plan] else []) ++ - [tcGhciStmts [stmt]]) - } - -mkPlan stmt - = tcGhciStmts [stmt] - ---------------------------- + -- [it <- e] + bind_stmt = L loc $ BindStmt (L loc (VarPat fresh_it)) rn_expr + (HsVar bindIOName) noSyntaxExpr + -- [; print it] + print_it = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it)) + (HsVar thenIOName) noSyntaxExpr placeHolderType + + -- The plans are: + -- A. [it <- e; print it] but not if it::() + -- B. [it <- e] + -- C. [let it = e; print it] + ; runPlans [ -- Plan A + do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it] + ; it_ty <- zonkTcType (idType it_id) + ; when (isUnitTy it_ty) failM + ; return stuff }, + + -- Plan B; a naked bind statment + tcGhciStmts [bind_stmt], + + -- Plan C; check that the let-binding is typeable all by itself. + -- If not, fail; if so, try to print it. + -- The two-step process avoids getting two errors: one from + -- the expression itself, and one from the 'print it' part + -- This two-step story is very clunky, alas + do { _ <- checkNoErrs (tcGhciStmts [let_stmt]) + --- checkNoErrs defeats the error recovery of let-bindings + ; tcGhciStmts [let_stmt, print_it] } + ]} + +tcUserStmt rdr_stmt@(L loc _) + = do { (([rn_stmt], _), fvs) <- checkNoErrs $ + rnStmts GhciStmt [rdr_stmt] $ \_ -> + return ((), emptyFVs) ; + -- Don't try to typecheck if the renamer fails! + ; traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) + ; rnDump (ppr rn_stmt) ; + + ; opt_pr_flag <- doptM Opt_PrintBindResult + ; let print_result_plan + | opt_pr_flag -- The flag says "print result" + , [v] <- collectLStmtBinders rn_stmt -- One binder + = [mk_print_result_plan rn_stmt v] + | otherwise = [] + + -- The plans are: + -- [stmt; print v] if one binder and not v::() + -- [stmt] otherwise + ; runPlans (print_result_plan ++ [tcGhciStmts [rn_stmt]]) } + where + mk_print_result_plan rn_stmt v + = do { stuff@([v_id], _) <- tcGhciStmts [rn_stmt, print_v] + ; v_ty <- zonkTcType (idType v_id) + ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM + ; return stuff } + where + print_v = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar v)) + (HsVar thenIOName) noSyntaxExpr placeHolderType + +-- | Typecheck the statements given and then return the results of the +-- statement in the form 'IO [()]'. tcGhciStmts :: [LStmt Name] -> TcM PlanResult tcGhciStmts stmts = do { ioTyCon <- tcLookupTyCon ioTyConName ; - ret_id <- tcLookupId returnIOName ; -- return @ IO - let { - ret_ty = mkListTy unitTy ; - io_ret_ty = mkTyConApp ioTyCon [ret_ty] ; - tc_io_stmts stmts = tcStmtsAndThen GhciStmt tcDoStmt stmts io_ret_ty ; - names = collectLStmtsBinders stmts ; - } ; - - -- OK, we're ready to typecheck the stmts - traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ; - ((tc_stmts, ids), lie) <- captureConstraints $ - tc_io_stmts stmts $ \ _ -> - mapM tcLookupId names ; - -- Look up the names right in the middle, - -- where they will all be in scope - - -- Simplify the context - traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ; - const_binds <- checkNoErrs (simplifyInteractive lie) ; - -- checkNoErrs ensures that the plan fails if context redn fails - - traceTc "TcRnDriver.tcGhciStmts: done" empty ; + ret_id <- tcLookupId returnIOName ; -- return @ IO + let { + ret_ty = mkListTy unitTy ; + io_ret_ty = mkTyConApp ioTyCon [ret_ty] ; + tc_io_stmts = tcStmtsAndThen GhciStmt tcDoStmt stmts io_ret_ty ; + names = collectLStmtsBinders stmts ; + } ; + + -- OK, we're ready to typecheck the stmts + traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ; + ((tc_stmts, ids), lie) <- captureConstraints $ + tc_io_stmts $ \ _ -> + mapM tcLookupId names ; + -- Look up the names right in the middle, + -- where they will all be in scope + + -- Simplify the context + traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ; + const_binds <- checkNoErrs (simplifyInteractive lie) ; + -- checkNoErrs ensures that the plan fails if context redn fails + + traceTc "TcRnDriver.tcGhciStmts: done" empty ; let { -- mk_return builds the expression - -- returnIO @ [()] [coerce () x, .., coerce () z] - -- - -- Despite the inconvenience of building the type applications etc, - -- this *has* to be done in type-annotated post-typecheck form - -- because we are going to return a list of *polymorphic* values - -- coerced to type (). If we built a *source* stmt - -- return [coerce x, ..., coerce z] - -- then the type checker would instantiate x..z, and we wouldn't - -- get their *polymorphic* values. (And we'd get ambiguity errs - -- if they were overloaded, since they aren't applied to anything.) - ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty]) - (noLoc $ ExplicitList unitTy (map mk_item ids)) ; - mk_item id = nlHsApp (nlHsTyApp unsafeCoerceId [idType id, unitTy]) - (nlHsVar id) ; - stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)] + -- returnIO @ [()] [coerce () x, .., coerce () z] + -- + -- Despite the inconvenience of building the type applications etc, + -- this *has* to be done in type-annotated post-typecheck form + -- because we are going to return a list of *polymorphic* values + -- coerced to type (). If we built a *source* stmt + -- return [coerce x, ..., coerce z] + -- then the type checker would instantiate x..z, and we wouldn't + -- get their *polymorphic* values. (And we'd get ambiguity errs + -- if they were overloaded, since they aren't applied to anything.) + ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty]) + (noLoc $ ExplicitList unitTy (map mk_item ids)) ; + mk_item id = nlHsApp (nlHsTyApp unsafeCoerceId [idType id, unitTy]) + (nlHsVar id) ; + stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)] } ; - return (ids, mkHsDictLet (EvBinds const_binds) $ - noLoc (HsDo GhciStmt stmts io_ret_ty)) + return (ids, mkHsDictLet (EvBinds const_binds) $ + noLoc (HsDo GhciStmt stmts io_ret_ty)) } \end{code} - tcRnExpr just finds the type of an expression \begin{code} tcRnExpr :: HscEnv -> InteractiveContext - -> LHsExpr RdrName - -> IO (Messages, Maybe Type) + -> LHsExpr RdrName + -> IO (Messages, Maybe Type) tcRnExpr hsc_env ictxt rdr_expr = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext hsc_env ictxt $ do { @@ -1412,12 +1419,12 @@ tcRnExpr hsc_env ictxt rdr_expr (rn_expr, _fvs) <- rnLExpr rdr_expr ; failIfErrsM ; - -- Now typecheck the expression; - -- it might have a rank-2 type (e.g. :t runST) + -- Now typecheck the expression; + -- it might have a rank-2 type (e.g. :t runST) uniq <- newUnique ; let { fresh_it = itName uniq (getLoc rdr_expr) } ; - ((_tc_expr, res_ty), lie) <- captureConstraints (tcInferRho rn_expr) ; - ((qtvs, dicts, _, _), lie_top) <- captureConstraints $ + ((_tc_expr, res_ty), lie) <- captureConstraints (tcInferRho rn_expr) ; + ((qtvs, dicts, _, _), lie_top) <- captureConstraints $ {-# SCC "simplifyInfer" #-} simplifyInfer True {- Free vars are closed -} False {- No MR for now -} @@ -1431,10 +1438,10 @@ tcRnExpr hsc_env ictxt rdr_expr -------------------------- tcRnImportDecls :: HscEnv - -> [LImportDecl RdrName] - -> IO (Messages, Maybe GlobalRdrEnv) + -> [LImportDecl RdrName] + -> IO (Messages, Maybe GlobalRdrEnv) tcRnImportDecls hsc_env import_decls - = initTcPrintErrors hsc_env iNTERACTIVE $ + = initTcPrintErrors hsc_env iNTERACTIVE $ do { gbl_env <- tcRnImports hsc_env iNTERACTIVE import_decls ; return (tcg_rdr_env gbl_env) } \end{code} @@ -1443,28 +1450,28 @@ tcRnType just finds the kind of a type \begin{code} tcRnType :: HscEnv - -> InteractiveContext - -> Bool -- Normalise the returned type - -> LHsType RdrName - -> IO (Messages, Maybe (Type, Kind)) + -> InteractiveContext + -> Bool -- Normalise the returned type + -> LHsType RdrName + -> IO (Messages, Maybe (Type, Kind)) tcRnType hsc_env ictxt normalise rdr_type - = initTcPrintErrors hsc_env iNTERACTIVE $ + = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext hsc_env ictxt $ do { rn_type <- rnLHsType GHCiCtx rdr_type ; failIfErrsM ; - -- Now kind-check the type - -- It can have any rank or kind + -- Now kind-check the type + -- It can have any rank or kind ty <- tcHsSigType GhciCtxt rn_type ; - ty' <- if normalise - then do { fam_envs <- tcGetFamInstEnvs + ty' <- if normalise + then do { fam_envs <- tcGetFamInstEnvs ; return (snd (normaliseType fam_envs ty)) } - -- normaliseType returns a coercion - -- which we discard + -- normaliseType returns a coercion + -- which we discard else return ty ; - + return (ty', typeKind ty) } @@ -1473,16 +1480,16 @@ tcRnType hsc_env ictxt normalise rdr_type tcRnDeclsi exists to allow class, data, and other declarations in GHCi. \begin{code} -tcRnDeclsi :: HscEnv +tcRnDeclsi :: HscEnv -> InteractiveContext - -> [LHsDecl RdrName] - -> IO (Messages, Maybe TcGblEnv) + -> [LHsDecl RdrName] + -> IO (Messages, Maybe TcGblEnv) tcRnDeclsi hsc_env ictxt local_decls = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext hsc_env ictxt $ do - - ((tcg_env, tclcl_env), lie) <- + + ((tcg_env, tclcl_env), lie) <- captureConstraints $ tc_rn_src_decls emptyModDetails local_decls setEnvs (tcg_env, tclcl_env) $ do @@ -1498,16 +1505,16 @@ tcRnDeclsi hsc_env ictxt local_decls = tcg_fords = fords } = tcg_env all_ev_binds = cur_ev_binds `unionBags` new_ev_binds - (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects') + (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects') <- zonkTopDecls all_ev_binds binds sig_ns rules vects imp_specs fords - + let --global_ids = map globaliseAndTidyId bind_ids final_type_env = extendTypeEnvWithIds type_env bind_ids --global_ids tcg_env' = tcg_env { tcg_binds = binds', tcg_ev_binds = ev_binds', tcg_imp_specs = imp_specs', - tcg_rules = rules', - tcg_vects = vects', + tcg_rules = rules', + tcg_vects = vects', tcg_fords = fords' } tcg_env'' <- setGlobalTypeEnv tcg_env' final_type_env @@ -1520,9 +1527,9 @@ tcRnDeclsi hsc_env ictxt local_decls = %************************************************************************ -%* * - More GHCi stuff, to do with browsing and getting info -%* * +%* * + More GHCi stuff, to do with browsing and getting info +%* * %************************************************************************ \begin{code} @@ -1539,7 +1546,7 @@ getModuleInterface hsc_env mod tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Messages, Maybe [Name]) tcRnLookupRdrName hsc_env rdr_name = initTcPrintErrors hsc_env iNTERACTIVE $ - setInteractiveContext hsc_env (hsc_IC hsc_env) $ + setInteractiveContext hsc_env (hsc_IC hsc_env) $ lookup_rdr_name rdr_name lookup_rdr_name :: RdrName -> TcM [Name] @@ -1554,7 +1561,7 @@ lookup_rdr_name rdr_name = do traceRn (text "xx" <+> vcat [ppr rdr_names, ppr (map snd results)]) -- The successful lookups will be (Just name) - let (warns_s, good_names) = unzip [ (msgs, name) + let (warns_s, good_names) = unzip [ (msgs, name) | (msgs, Just name) <- results] errs_s = [msgs | (msgs, Nothing) <- results] @@ -1564,9 +1571,9 @@ lookup_rdr_name rdr_name = do -- No lookup succeeded, so -- pick the first error message and report it -- ToDo: If one of the errors is "could be Foo.X or Baz.X", - -- while the other is "X is not in scope", - -- we definitely want the former; but we might pick the latter - else mapM_ addMessages warns_s + -- while the other is "X is not in scope", + -- we definitely want the former; but we might pick the latter + else mapM_ addMessages warns_s -- Add deprecation warnings return good_names @@ -1579,7 +1586,7 @@ tcRnLookupName hsc_env name tcRnLookupName' name -- To look up a name we have to look in the local environment (tcl_lcl) --- as well as the global environment, which is what tcLookup does. +-- as well as the global environment, which is what tcLookup does. -- But we also want a TyThing, so we have to convert: tcRnLookupName' :: Name -> TcRn TyThing @@ -1598,8 +1605,8 @@ tcRnGetInfo :: HscEnv -- -- Look up a RdrName and return all the TyThings it might be -- A capitalised RdrName is given to us in the DataName namespace, --- but we want to treat it as *both* a data constructor --- *and* as a type or class constructor; +-- but we want to treat it as *both* a data constructor +-- *and* as a type or class constructor; -- hence the call to dataTcOccs, and we return up to two results tcRnGetInfo hsc_env name = initTcPrintErrors hsc_env iNTERACTIVE $ @@ -1612,10 +1619,10 @@ tcRnGetInfo' hsc_env name = let ictxt = hsc_IC hsc_env in setInteractiveContext hsc_env ictxt $ do - -- Load the interface for all unqualified types and classes - -- That way we will find all the instance declarations - -- (Packages have not orphan modules, and we assume that - -- in the home package all relevant modules are loaded.) + -- Load the interface for all unqualified types and classes + -- That way we will find all the instance declarations + -- (Packages have not orphan modules, and we assume that + -- in the home package all relevant modules are loaded.) loadUnqualIfaces hsc_env ictxt thing <- tcRnLookupName' name @@ -1631,22 +1638,22 @@ lookupInsts (ATyCon tc) | otherwise = do { (pkg_ie, home_ie) <- tcGetInstEnvs - -- Load all instances for all classes that are - -- in the type environment (which are all the ones - -- we've seen in any interface file so far) - ; return [ ispec -- Search all - | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie - , let dfun = instanceDFunId ispec - , relevant dfun ] } + -- Load all instances for all classes that are + -- in the type environment (which are all the ones + -- we've seen in any interface file so far) + ; return [ ispec -- Search all + | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie + , let dfun = instanceDFunId ispec + , relevant dfun ] } where relevant df = tc_name `elemNameSet` orphNamesOfDFunHead (idType df) - tc_name = tyConName tc + tc_name = tyConName tc lookupInsts _ = return [] loadUnqualIfaces :: HscEnv -> InteractiveContext -> TcM () -- Load the interface for everything that is in scope unqualified --- This is so that we can accurately report the instances for +-- This is so that we can accurately report the instances for -- something loadUnqualIfaces hsc_env ictxt = initIfaceTcRn $ do @@ -1656,18 +1663,18 @@ loadUnqualIfaces hsc_env ictxt unqual_mods = filter ((/= this_pkg) . modulePackageId) [ nameModule name - | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt), - let name = gre_name gre, + | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt), + let name = gre_name gre, not (isInternalName name), - isTcOcc (nameOccName name), -- Types and classes only - unQualOK gre ] -- In scope unqualified + isTcOcc (nameOccName name), -- Types and classes only + unQualOK gre ] -- In scope unqualified doc = ptext (sLit "Need interface for module whose export(s) are in scope unqualified") \end{code} %************************************************************************ -%* * - Degugging output -%* * +%* * + Degugging output +%* * %************************************************************************ \begin{code} @@ -1679,60 +1686,60 @@ tcDump :: TcGblEnv -> TcRn () tcDump env = do { dflags <- getDynFlags ; - -- Dump short output if -ddump-types or -ddump-tc - when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) - (dumpTcRn short_dump) ; + -- Dump short output if -ddump-types or -ddump-tc + when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) + (dumpTcRn short_dump) ; - -- Dump bindings if -ddump-tc - dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) + -- Dump bindings if -ddump-tc + dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) } where short_dump = pprTcGblEnv env full_dump = pprLHsBinds (tcg_binds env) - -- NB: foreign x-d's have undefined's in their types; - -- hence can't show the tc_fords + -- NB: foreign x-d's have undefined's in their types; + -- hence can't show the tc_fords tcCoreDump :: ModGuts -> TcM () tcCoreDump mod_guts = do { dflags <- getDynFlags ; - when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) - (dumpTcRn (pprModGuts mod_guts)) ; + when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) + (dumpTcRn (pprModGuts mod_guts)) ; - -- Dump bindings if -ddump-tc - dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) } + -- Dump bindings if -ddump-tc + dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) } where full_dump = pprCoreBindings (mg_binds mod_guts) -- It's unpleasant having both pprModGuts and pprModDetails here pprTcGblEnv :: TcGblEnv -> SDoc -pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, - tcg_insts = insts, - tcg_fam_insts = fam_insts, +pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, + tcg_insts = insts, + tcg_fam_insts = fam_insts, tcg_rules = rules, tcg_vects = vects, tcg_imports = imports }) = vcat [ ppr_types insts type_env - , ppr_tycons fam_insts type_env + , ppr_tycons fam_insts type_env , ppr_insts insts , ppr_fam_insts fam_insts , vcat (map ppr rules) , vcat (map ppr vects) - , ptext (sLit "Dependent modules:") <+> + , ptext (sLit "Dependent modules:") <+> ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports)) - , ptext (sLit "Dependent packages:") <+> - ppr (sortBy stablePackageIdCmp $ imp_dep_pkgs imports)] - where -- The two uses of sortBy are just to reduce unnecessary - -- wobbling in testsuite output + , ptext (sLit "Dependent packages:") <+> + ppr (sortBy stablePackageIdCmp $ imp_dep_pkgs imports)] + where -- The two uses of sortBy are just to reduce unnecessary + -- wobbling in testsuite output cmp_mp (mod_name1, is_boot1) (mod_name2, is_boot2) - = (mod_name1 `stableModuleNameCmp` mod_name2) - `thenCmp` - (is_boot1 `compare` is_boot2) + = (mod_name1 `stableModuleNameCmp` mod_name2) + `thenCmp` + (is_boot1 `compare` is_boot2) pprModGuts :: ModGuts -> SDoc pprModGuts (ModGuts { mg_tcs = tcs , mg_rules = rules }) = vcat [ ppr_types [] (mkTypeEnv (map ATyCon tcs)), - ppr_rules rules ] + ppr_rules rules ] ppr_types :: [ClsInst] -> TypeEnv -> SDoc ppr_types insts type_env @@ -1741,27 +1748,27 @@ ppr_types insts type_env dfun_ids = map instanceDFunId insts ids = [id | id <- typeEnvIds type_env, want_sig id] want_sig id | opt_PprStyle_Debug = True - | otherwise = isLocalId id && - isExternalName (idName id) && - not (id `elem` dfun_ids) - -- isLocalId ignores data constructors, records selectors etc. - -- The isExternalName ignores local dictionary and method bindings - -- that the type checker has invented. Top-level user-defined things - -- have External names. + | otherwise = isLocalId id && + isExternalName (idName id) && + not (id `elem` dfun_ids) + -- isLocalId ignores data constructors, records selectors etc. + -- The isExternalName ignores local dictionary and method bindings + -- that the type checker has invented. Top-level user-defined things + -- have External names. ppr_tycons :: [FamInst] -> TypeEnv -> SDoc ppr_tycons fam_insts type_env = vcat [ text "TYPE CONSTRUCTORS" , nest 2 (ppr_tydecls tycons) - , text "COERCION AXIOMS" + , text "COERCION AXIOMS" , nest 2 (vcat (map pprCoAxiom (typeEnvCoAxioms type_env))) ] where fi_tycons = famInstsRepTyCons fam_insts tycons = [tycon | tycon <- typeEnvTyCons type_env, want_tycon tycon] want_tycon tycon | opt_PprStyle_Debug = True - | otherwise = not (isImplicitTyCon tycon) && - isExternalName (tyConName tycon) && - not (tycon `elem` fi_tycons) + | otherwise = not (isImplicitTyCon tycon) && + isExternalName (tyConName tycon) && + not (tycon `elem` fi_tycons) ppr_insts :: [ClsInst] -> SDoc ppr_insts [] = empty @@ -1769,12 +1776,12 @@ ppr_insts ispecs = text "INSTANCES" $$ nest 2 (pprInstances ispecs) ppr_fam_insts :: [FamInst] -> SDoc ppr_fam_insts [] = empty -ppr_fam_insts fam_insts = +ppr_fam_insts fam_insts = text "FAMILY INSTANCES" $$ nest 2 (pprFamInsts fam_insts) ppr_sigs :: [Var] -> SDoc ppr_sigs ids - -- Print type signatures; sort by OccName + -- Print type signatures; sort by OccName = vcat (map ppr_sig (sortLe le_sig ids)) where le_sig id1 id2 = getOccName id1 <= getOccName id2 @@ -1782,7 +1789,7 @@ ppr_sigs ids ppr_tydecls :: [TyCon] -> SDoc ppr_tydecls tycons - -- Print type constructor info; sort by OccName + -- Print type constructor info; sort by OccName = vcat (map ppr_tycon (sortLe le_sig tycons)) where le_sig tycon1 tycon2 = getOccName tycon1 <= getOccName tycon2 @@ -1791,6 +1798,6 @@ ppr_tydecls tycons ppr_rules :: [CoreRule] -> SDoc ppr_rules [] = empty ppr_rules rs = vcat [ptext (sLit "{-# RULES"), - nest 2 (pprRules rs), - ptext (sLit "#-}")] + nest 2 (pprRules rs), + ptext (sLit "#-}")] \end{code} diff --git a/compiler/typecheck/TcSplice.lhs-boot b/compiler/typecheck/TcSplice.lhs-boot index 5cb871a3a1..18a31b0b93 100644 --- a/compiler/typecheck/TcSplice.lhs-boot +++ b/compiler/typecheck/TcSplice.lhs-boot @@ -1,32 +1,25 @@ \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module TcSplice where -import HsSyn ( HsSplice, HsBracket, HsQuasiQuote, +import HsSyn ( HsSplice, HsBracket, HsQuasiQuote, HsExpr, HsType, LHsType, LHsExpr, LPat, LHsDecl ) -import Name ( Name ) -import NameSet ( FreeVars ) -import RdrName ( RdrName ) +import Name ( Name ) +import NameSet ( FreeVars ) +import RdrName ( RdrName ) import TcRnTypes( TcM, TcId ) -import TcType ( TcRhoType, TcKind ) +import TcType ( TcRhoType, TcKind ) import Annotations ( Annotation, CoreAnnTarget ) import qualified Language.Haskell.TH as TH tcSpliceExpr :: HsSplice Name - -> TcRhoType - -> TcM (HsExpr TcId) + -> TcRhoType + -> TcM (HsExpr TcId) kcSpliceType :: HsSplice Name -> FreeVars - -> TcM (HsType Name, TcKind) + -> TcM (HsType Name, TcKind) tcBracket :: HsBracket Name - -> TcRhoType - -> TcM (LHsExpr TcId) + -> TcRhoType + -> TcM (LHsExpr TcId) tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName] diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 2c28655ccf..95d7d236a7 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -101,13 +101,10 @@ tcTyAndClassDecls :: ModDetails -> TcM TcGblEnv -- Input env extended by types and classes -- and their implicit Ids,DataCons -- Fails if there are any errors -tcTyAndClassDecls boot_details decls_s - = checkNoErrs $ do -- The code recovers internally, but if anything gave rise to +tcTyAndClassDecls boot_details tyclds_s + = checkNoErrs $ -- The code recovers internally, but if anything gave rise to -- an error we'd better stop now, to avoid a cascade - { let tyclds_s = map (filterOut (isFamInstDecl . unLoc)) decls_s - -- Remove family instance decls altogether - -- They are dealt with by TcInstDcls - ; fold_env tyclds_s } -- type check each group in dependency order folding the global env + fold_env tyclds_s -- type check each group in dependency order folding the global env where fold_env :: [TyClGroup Name] -> TcM TcGblEnv fold_env [] = getGblEnv @@ -379,7 +376,7 @@ kcTyClDecl decl@(TyFamily {}) = kcFamilyDecl [] decl -- the empty list signals a toplevel decl kcTyClDecl decl@(TyData {}) - = ASSERT( not . isFamInstDecl $ decl ) -- must not be a family instance + = ASSERT2( not . isFamInstDecl $ decl, ppr decl ) -- must not be a family instance kcTyClDeclBody decl $ \_ -> kcDataDecl decl kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats}) diff --git a/compiler/typecheck/TcUnify.lhs-boot b/compiler/typecheck/TcUnify.lhs-boot index f53b658f40..4d07229963 100644 --- a/compiler/typecheck/TcUnify.lhs-boot +++ b/compiler/typecheck/TcUnify.lhs-boot @@ -1,11 +1,4 @@ \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module TcUnify where import TcType ( TcTauType, TcKind, Type, Kind ) import VarEnv ( TidyEnv ) diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs index b1ab2f6101..7df64c42d2 100644 --- a/compiler/types/FamInstEnv.lhs +++ b/compiler/types/FamInstEnv.lhs @@ -20,8 +20,8 @@ module FamInstEnv ( mkSynFamInst, mkDataFamInst, mkImportedFamInst, FamInstEnvs, FamInstEnv, emptyFamInstEnv, emptyFamInstEnvs, - extendFamInstEnv, overwriteFamInstEnv, extendFamInstEnvList, - famInstEnvElts, familyInstances, + extendFamInstEnv, deleteFromFamInstEnv, extendFamInstEnvList, + identicalFamInst, famInstEnvElts, familyInstances, lookupFamInstEnv, lookupFamInstEnvConflicts, lookupFamInstEnvConflicts', @@ -38,6 +38,7 @@ import TypeRep import TyCon import Coercion import VarSet +import VarEnv import Name import UniqFM import Outputable @@ -325,41 +326,26 @@ extendFamInstEnv inst_env ins_item@(FamInst {fi_fam = cls_nm, fi_tcs = mb_tcs}) (ins_tyvar || tyvar) ins_tyvar = not (any isJust mb_tcs) -overwriteFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv -overwriteFamInstEnv inst_env ins_item@(FamInst {fi_fam = cls_nm, fi_tcs = mb_tcs}) - = addToUFM_C add inst_env cls_nm (FamIE [ins_item] ins_tyvar) +deleteFromFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv +deleteFromFamInstEnv inst_env fam_inst@(FamInst {fi_fam = fam_nm}) + = adjustUFM adjust inst_env fam_nm + where + adjust :: FamilyInstEnv -> FamilyInstEnv + adjust (FamIE items tyvars) + = FamIE (filterOut (identicalFamInst fam_inst) items) tyvars + +identicalFamInst :: FamInst -> FamInst -> Bool +-- Same LHS, *and* the instance is defined in the same module +-- Used for overriding in GHCi +identicalFamInst (FamInst { fi_axiom = ax1 }) (FamInst { fi_axiom = ax2 }) + = nameModule (coAxiomName ax1) == nameModule (coAxiomName ax2) + && eqTypeX rn_env (coAxiomLHS ax1) (coAxiomLHS ax2) where - add (FamIE items tyvar) _ = FamIE (replaceFInst items) - (ins_tyvar || tyvar) - ins_tyvar = not (any isJust mb_tcs) - match _ tpl_tvs tpl_tys tys = tcMatchTys tpl_tvs tpl_tys tys - - inst_axiom = famInstAxiom ins_item - (fam, tys) = coAxiomSplitLHS inst_axiom - arity = tyConArity fam - n_tys = length tys - match_tys - | arity > n_tys = take arity tys - | otherwise = tys - rough_tcs = roughMatchTcs match_tys - - replaceFInst [] = [ins_item] - replaceFInst (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs, - fi_tys = tpl_tys }) : rest) - -- Fast check for no match, uses the "rough match" fields - | instanceCantMatch rough_tcs mb_tcs - = item : replaceFInst rest - - -- Proper check - | Just _ <- match item tpl_tvs tpl_tys match_tys - = ins_item : rest - - -- No match => try next - | otherwise - = item : replaceFInst rest - - - + tvs1 = coAxiomTyVars ax1 + tvs2 = coAxiomTyVars ax2 + rn_env = ASSERT( equalLength tvs1 tvs2 ) + rnBndrs2 (mkRnEnv2 emptyInScopeSet) tvs1 tvs2 + \end{code} %************************************************************************ diff --git a/compiler/types/Kind.lhs b/compiler/types/Kind.lhs index 0acc967507..e129cc60bc 100644 --- a/compiler/types/Kind.lhs +++ b/compiler/types/Kind.lhs @@ -49,10 +49,7 @@ module Kind ( -- ** Functions on variables isKiVar, splitKiTyVars, partitionKiTyVars, - kiVarsOfKind, kiVarsOfKinds, - - -- ** Promotion related functions - promoteType, isPromotableType, isPromotableKind, + kiVarsOfKind, kiVarsOfKinds ) where @@ -252,8 +249,10 @@ isSubKind' duringTc k1@(TyConApp kc1 k1s) k2@(TyConApp kc2 k2s) | isSuperKindTyCon kc1 || isSuperKindTyCon kc2 -- handles BOX - = ASSERT2( isSuperKindTyCon kc2 && null k1s && null k2s, ppr kc1 <+> ppr kc2 ) - True + = WARN( not (isSuperKindTyCon kc2 && isSuperKindTyCon kc2 + && null k1s && null k2s), + ppr kc1 <+> ppr kc2 ) + kc1 == kc2 | otherwise = -- handles usual kinds (*, #, (#), etc.) ASSERT2( null k1s && null k2s, ppr k1 <+> ppr k2 ) @@ -314,54 +313,4 @@ kiVarsOfKind = tyVarsOfType kiVarsOfKinds :: [Kind] -> VarSet kiVarsOfKinds = tyVarsOfTypes - --- Datatype promotion -isPromotableType :: Type -> Bool -isPromotableType = go emptyVarSet - where - go vars (TyConApp tc tys) = ASSERT( not (isPromotedDataTyCon tc) ) all (go vars) tys - go vars (FunTy arg res) = all (go vars) [arg,res] - go vars (TyVarTy tvar) = tvar `elemVarSet` vars - go vars (ForAllTy tvar ty) = isPromotableTyVar tvar && go (vars `extendVarSet` tvar) ty - go _ _ = panic "isPromotableType" -- argument was not kind-shaped - -isPromotableTyVar :: TyVar -> Bool -isPromotableTyVar = isLiftedTypeKind . varType - --- | Promotes a type to a kind. Assumes the argument is promotable. -promoteType :: Type -> Kind -promoteType (TyConApp tc tys) = mkTyConApp (mkPromotedTypeTyCon tc) - (map promoteType tys) - -- T t1 .. tn ~~> 'T k1 .. kn where ti ~~> ki -promoteType (FunTy arg res) = mkArrowKind (promoteType arg) (promoteType res) - -- t1 -> t2 ~~> k1 -> k2 where ti ~~> ki -promoteType (TyVarTy tvar) = mkTyVarTy (promoteTyVar tvar) - -- a :: * ~~> a :: BOX -promoteType (ForAllTy tvar ty) = ForAllTy (promoteTyVar tvar) (promoteType ty) - -- forall (a :: *). t ~~> forall (a :: BOX). k where t ~~> k -promoteType _ = panic "promoteType" -- argument was not kind-shaped - -promoteTyVar :: TyVar -> KindVar -promoteTyVar tvar = mkKindVar (tyVarName tvar) tySuperKind - --- If kind is [ *^n -> * ] returns [ Just n ], else returns [ Nothing ] -isPromotableKind :: Kind -> Maybe Int -isPromotableKind kind = - let (args, res) = splitKindFunTys kind in - if all isLiftedTypeKind (res:args) - then Just $ length args - else Nothing - -{- Note [Promoting a Type to a Kind] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We only promote the followings. -- Type variables: a -- Fully applied arrow types: tau -> sigma -- Fully applied type constructors of kind: - n >= 0 - /-----------\ - * -> ... -> * -> * -- Polymorphic types over type variables of kind star: - forall (a::*). tau --} \end{code} diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index f5c05677e1..e2c192f435 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -39,7 +39,7 @@ module TyCon( mkSuperKindTyCon, mkForeignTyCon, mkPromotedDataTyCon, - mkPromotedTypeTyCon, + mkPromotedTyCon, -- ** Predicates on TyCons isAlgTyCon, @@ -94,7 +94,7 @@ module TyCon( #include "HsVersions.h" import {-# SOURCE #-} TypeRep ( Kind, Type, PredType ) -import {-# SOURCE #-} DataCon ( DataCon, isVanillaDataCon, dataConName ) +import {-# SOURCE #-} DataCon ( DataCon, isVanillaDataCon ) import {-# SOURCE #-} IParam ( ipTyConName ) import Var @@ -410,6 +410,7 @@ data TyCon | PromotedDataTyCon { -- See Note [Promoted data constructors] tyConUnique :: Unique, -- ^ Same Unique as the data constructor tyConName :: Name, -- ^ Same Name as the data constructor + tyConArity :: Arity, tc_kind :: Kind, -- ^ Translated type of the data constructor dataCon :: DataCon -- ^ Corresponding data constructor } @@ -419,6 +420,7 @@ data TyCon tyConUnique :: Unique, -- ^ Same Unique as the type constructor tyConName :: Name, -- ^ Same Name as the type constructor tyConArity :: Arity, -- ^ n if ty_con :: * -> ... -> * n times + tc_kind :: Kind, -- ^ Always tySuperKind ty_con :: TyCon -- ^ Corresponding type constructor } @@ -961,25 +963,30 @@ mkSuperKindTyCon name } -- | Create a promoted data constructor 'TyCon' -mkPromotedDataTyCon :: DataCon -> Name -> Unique -> Kind -> TyCon -mkPromotedDataTyCon con name unique kind +-- Somewhat dodgily, we give it the same Name +-- as the data constructor itself +mkPromotedDataTyCon :: DataCon -> Name -> Unique -> Kind -> Arity -> TyCon +mkPromotedDataTyCon con name unique kind arity = PromotedDataTyCon { - tyConName = name, + tyConName = name, tyConUnique = unique, - tc_kind = kind, - dataCon = con + tyConArity = arity, + tc_kind = kind, + dataCon = con } -- | Create a promoted type constructor 'TyCon' -mkPromotedTypeTyCon :: TyCon -> TyCon -mkPromotedTypeTyCon con +-- Somewhat dodgily, we give it the same Name +-- as the type constructor itself +mkPromotedTyCon :: TyCon -> Kind -> TyCon +mkPromotedTyCon tc kind = PromotedTypeTyCon { - tyConName = getName con, - tyConUnique = getUnique con, - tyConArity = tyConArity con, - ty_con = con + tyConName = getName tc, + tyConUnique = getUnique tc, + tyConArity = tyConArity tc, + tc_kind = kind, + ty_con = tc } - \end{code} \begin{code} @@ -1288,15 +1295,9 @@ expand tvs rhs tys \end{code} \begin{code} - tyConKind :: TyCon -> Kind -tyConKind (FunTyCon { tc_kind = k }) = k -tyConKind (AlgTyCon { tc_kind = k }) = k -tyConKind (TupleTyCon { tc_kind = k }) = k -tyConKind (SynTyCon { tc_kind = k }) = k -tyConKind (PrimTyCon { tc_kind = k }) = k -tyConKind (PromotedDataTyCon { tc_kind = k }) = k -tyConKind tc = pprPanic "tyConKind" (ppr tc) -- SuperKindTyCon and CoTyCon +tyConKind (SuperKindTyCon {}) = pprPanic "tyConKind" empty +tyConKind tc = tc_kind tc tyConHasKind :: TyCon -> Bool tyConHasKind (SuperKindTyCon {}) = False @@ -1499,8 +1500,7 @@ instance Uniquable TyCon where getUnique tc = tyConUnique tc instance Outputable TyCon where - ppr (PromotedDataTyCon {dataCon = dc}) = quote (ppr (dataConName dc)) - ppr tc = ppr (getName tc) + ppr tc = ppr (tyConName tc) instance NamedThing TyCon where getName = tyConName diff --git a/compiler/types/TyCon.lhs-boot b/compiler/types/TyCon.lhs-boot index dcf41dd545..d8ddff3f40 100644 --- a/compiler/types/TyCon.lhs-boot +++ b/compiler/types/TyCon.lhs-boot @@ -1,11 +1,4 @@ \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module TyCon where import Name (Name) @@ -13,9 +6,9 @@ import Unique (Unique) data TyCon -tyConName :: TyCon -> Name -tyConUnique :: TyCon -> Unique -isTupleTyCon :: TyCon -> Bool +tyConName :: TyCon -> Name +tyConUnique :: TyCon -> Unique +isTupleTyCon :: TyCon -> Bool isUnboxedTupleTyCon :: TyCon -> Bool -isFunTyCon :: TyCon -> Bool +isFunTyCon :: TyCon -> Bool \end{code} diff --git a/compiler/utils/Platform.hs b/compiler/utils/Platform.hs index 7045f4b521..66f51e64e6 100644 --- a/compiler/utils/Platform.hs +++ b/compiler/utils/Platform.hs @@ -54,6 +54,7 @@ data OS | OSSolaris2 | OSMinGW32 | OSFreeBSD + | OSDragonFly | OSOpenBSD | OSNetBSD | OSKFreeBSD @@ -81,15 +82,16 @@ target32Bit p = platformWordSize p == 4 -- | This predicates tells us whether the OS supports ELF-like shared libraries. osElfTarget :: OS -> Bool -osElfTarget OSLinux = True -osElfTarget OSFreeBSD = True -osElfTarget OSOpenBSD = True -osElfTarget OSNetBSD = True -osElfTarget OSSolaris2 = True -osElfTarget OSDarwin = False -osElfTarget OSMinGW32 = False -osElfTarget OSKFreeBSD = True -osElfTarget OSUnknown = False +osElfTarget OSLinux = True +osElfTarget OSFreeBSD = True +osElfTarget OSDragonFly = True +osElfTarget OSOpenBSD = True +osElfTarget OSNetBSD = True +osElfTarget OSSolaris2 = True +osElfTarget OSDarwin = False +osElfTarget OSMinGW32 = False +osElfTarget OSKFreeBSD = True +osElfTarget OSUnknown = False -- Defaulting to False is safe; it means don't rely on any -- ELF-specific functionality. It is important to have a default for -- portability, otherwise we have to answer this question for every |