diff options
Diffstat (limited to 'compiler')
61 files changed, 1249 insertions, 1072 deletions
diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs index 64ca362d54..e4a9c7d82a 100644 --- a/compiler/basicTypes/Name.lhs +++ b/compiler/basicTypes/Name.lhs @@ -430,6 +430,9 @@ instance Outputable Name where instance OutputableBndr Name where pprBndr _ name = pprName name + pprInfixOcc = pprInfixName + pprPrefixOcc = pprPrefixName + pprName :: Name -> SDoc pprName n@(Name {n_sort = sort, n_uniq = u, n_occ = occ}) diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs index 0353e65d04..de0ff56222 100644 --- a/compiler/basicTypes/RdrName.lhs +++ b/compiler/basicTypes/RdrName.lhs @@ -273,6 +273,9 @@ instance OutputableBndr RdrName where | isTvOcc (rdrNameOcc n) = char '@' <+> ppr n | otherwise = ppr n + pprInfixOcc rdr = pprInfixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) + pprPrefixOcc rdr = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) + showRdrName :: RdrName -> String showRdrName r = showSDoc (ppr r) @@ -503,6 +506,7 @@ pickGREs :: RdrName -> [GlobalRdrElt] -> [GlobalRdrElt] -- ^ Take a list of GREs which have the right OccName -- Pick those GREs that are suitable for this RdrName -- And for those, keep only only the Provenances that are suitable +-- Only used for Qual and Unqual, not Orig or Exact -- -- Consider: -- @@ -519,7 +523,8 @@ pickGREs :: RdrName -> [GlobalRdrElt] -> [GlobalRdrElt] -- the locally-defined @f@, and a GRE for the imported @f@, with a /single/ -- provenance, namely the one for @Baz(f)@. pickGREs rdr_name gres - = mapCatMaybes pick gres + = ASSERT2( isSrcRdrName rdr_name, ppr rdr_name ) + mapCatMaybes pick gres where rdr_is_unqual = isUnqual rdr_name rdr_is_qual = isQual_maybe rdr_name diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 4e315ddbdf..e0d3da8a62 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -21,7 +21,7 @@ module CmmParse ( parseCmmFile ) where -import CgMonad hiding (getDynFlags) +import CgMonad import CgExtCode import CgHeapery import CgUtils diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs index 302d8ac652..6636e24ec1 100644 --- a/compiler/codeGen/CgMonad.lhs +++ b/compiler/codeGen/CgMonad.lhs @@ -502,8 +502,8 @@ newUnique = do getInfoDown :: FCode CgInfoDownwards getInfoDown = FCode $ \info_down state -> (info_down,state) -getDynFlags :: FCode DynFlags -getDynFlags = liftM cgd_dflags getInfoDown +instance HasDynFlags FCode where + getDynFlags = liftM cgd_dflags getInfoDown getThisPackage :: FCode PackageId getThisPackage = liftM thisPackage getDynFlags diff --git a/compiler/codeGen/CgProf.hs b/compiler/codeGen/CgProf.hs index a2e40d0f78..296dd62818 100644 --- a/compiler/codeGen/CgProf.hs +++ b/compiler/codeGen/CgProf.hs @@ -178,8 +178,8 @@ emitCostCentreDecl cc = do label, -- char *label, modl, -- char *module, loc, -- char *srcloc, + zero64, -- StgWord64 mem_alloc zero, -- StgWord time_ticks - zero64, -- StgWord64 mem_alloc is_caf, -- StgInt is_caf zero -- struct _CostCentre *link ] diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index cab0897fe8..71457c530c 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -379,8 +379,8 @@ newUnique = do getInfoDown :: FCode CgInfoDownwards getInfoDown = FCode $ \info_down state -> (info_down,state) -getDynFlags :: FCode DynFlags -getDynFlags = liftM cgd_dflags getInfoDown +instance HasDynFlags FCode where + getDynFlags = liftM cgd_dflags getInfoDown getThisPackage :: FCode PackageId getThisPackage = liftM thisPackage getDynFlags diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs index 88031dce48..6d16f012b3 100644 --- a/compiler/codeGen/StgCmmProf.hs +++ b/compiler/codeGen/StgCmmProf.hs @@ -223,14 +223,14 @@ emitCostCentreDecl cc = do -- All cost centres will be in the main package, since we -- don't normally use -auto-all or add SCCs to other packages. -- Hence don't emit the package name in the module here. - ; let lits = [ zero, -- StgInt ccID, - label, -- char *label, - modl, -- char *module, - loc, -- char *srcloc, - zero, -- StgWord time_ticks - zero64, -- StgWord64 mem_alloc - is_caf, -- StgInt is_caf - zero -- struct _CostCentre *link + ; let lits = [ zero, -- StgInt ccID, + label, -- char *label, + modl, -- char *module, + loc, -- char *srcloc, + zero64, -- StgWord64 mem_alloc + zero, -- StgWord time_ticks + is_caf, -- StgInt is_caf + zero -- struct _CostCentre *link ] ; emitDataLits (mkCCLabel cc) lits } diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index 04bb9d4a68..310a05e1a9 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -992,6 +992,8 @@ instance Outputable b => Outputable (TaggedBndr b) where instance Outputable b => OutputableBndr (TaggedBndr b) where pprBndr _ b = ppr b -- Simple + pprInfixOcc b = ppr b + pprPrefixOcc b = ppr b \end{code} diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index d3a2ca5cbb..47e31fa5cb 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -1284,10 +1284,10 @@ data CoreStats = CS { cs_tm, cs_ty, cs_co :: Int } instance Outputable CoreStats where - ppr (CS { cs_tm = i1, cs_ty = i2, cs_co = i3 }) = - text "size of" <+> vcat [ text "terms =" <+> int i1 - , text "types =" <+> int i2 - , text "coercions =" <+> int i3 ] + ppr (CS { cs_tm = i1, cs_ty = i2, cs_co = i3 }) + = braces (sep [ptext (sLit "terms:") <+> intWithCommas i1 <> comma, + ptext (sLit "types:") <+> intWithCommas i2 <> comma, + ptext (sLit "coercions:") <+> intWithCommas i3]) plusCS :: CoreStats -> CoreStats -> CoreStats plusCS (CS { cs_tm = p1, cs_ty = q1, cs_co = r1 }) diff --git a/compiler/coreSyn/MkCore.lhs b/compiler/coreSyn/MkCore.lhs index dd41184994..ae6b095f99 100644 --- a/compiler/coreSyn/MkCore.lhs +++ b/compiler/coreSyn/MkCore.lhs @@ -288,7 +288,7 @@ mkIPUnbox ipx = Var x `Cast` mkAxInstCo (ipCoAxiom ip) [ty] \begin{code} mkEqBox :: Coercion -> CoreExpr -mkEqBox co = ASSERT( typeKind ty2 `eqKind` k ) +mkEqBox co = ASSERT2( typeKind ty2 `eqKind` k, ppr co $$ ppr ty1 $$ ppr ty2 $$ ppr (typeKind ty1) $$ ppr (typeKind ty2) ) Var (dataConWorkId eqBoxDataCon) `mkTyApps` [k, ty1, ty2] `App` Coercion co where Pair ty1 ty2 = coercionKind co k = typeKind ty1 diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs index 9def8e8ca7..7487c66025 100644 --- a/compiler/coreSyn/PprCore.lhs +++ b/compiler/coreSyn/PprCore.lhs @@ -21,6 +21,7 @@ module PprCore ( import CoreSyn import Literal( pprLiteral ) +import Name( pprInfixName, pprPrefixName ) import Var import Id import IdInfo @@ -268,6 +269,8 @@ and @pprCoreExpr@ functions. \begin{code} instance OutputableBndr Var where pprBndr = pprCoreBinder + pprInfixOcc = pprInfixName . varName + pprPrefixOcc = pprPrefixName . varName pprCoreBinder :: BindingSite -> Var -> SDoc pprCoreBinder LetBind binder diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs index 1748ce7cac..663c289d3c 100644 --- a/compiler/deSugar/DsArrows.lhs +++ b/compiler/deSugar/DsArrows.lhs @@ -21,7 +21,7 @@ import Match import DsUtils import DsMonad -import HsSyn hiding (collectPatBinders, collectPatsBinders ) +import HsSyn hiding (collectPatBinders, collectPatsBinders, collectLStmtsBinders, collectLStmtBinders, collectStmtBinders ) import TcHsSyn -- NB: The desugarer, which straddles the source and Core worlds, sometimes @@ -265,21 +265,21 @@ Translation of command judgements of the form A | xs |- c :: [ts] t \begin{code} -dsLCmd :: DsCmdEnv -> IdSet -> [Id] -> [Type] -> Type -> LHsCmd Id +dsLCmd :: DsCmdEnv -> IdSet -> [Type] -> Type -> LHsCmd Id -> [Id] -> DsM (CoreExpr, IdSet) -dsLCmd ids local_vars env_ids stack res_ty cmd - = dsCmd ids local_vars env_ids stack res_ty (unLoc cmd) +dsLCmd ids local_vars stack res_ty cmd env_ids + = dsCmd ids local_vars stack res_ty (unLoc cmd) env_ids dsCmd :: DsCmdEnv -- arrow combinators -> IdSet -- set of local vars available to this command - -> [Id] -- list of vars in the input to this command - -- This is typically fed back, - -- so don't pull on it too early -> [Type] -- type of the stack -> Type -- return type of the command -> HsCmd Id -- command to desugar + -> [Id] -- list of vars in the input to this command + -- This is typically fed back, + -- so don't pull on it too early -> DsM (CoreExpr, -- desugared expression - IdSet) -- set of local vars that occur free + IdSet) -- subset of local vars that occur free -- A |- f :: a (t*ts) t' -- A, xs |- arg :: t @@ -288,8 +288,9 @@ dsCmd :: DsCmdEnv -- arrow combinators -- -- ---> arr (\ ((xs)*ts) -> (arg*ts)) >>> f -dsCmd ids local_vars env_ids stack res_ty - (HsArrApp arrow arg arrow_ty HsFirstOrderApp _)= do +dsCmd ids local_vars stack res_ty + (HsArrApp arrow arg arrow_ty HsFirstOrderApp _) + env_ids = do let (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty @@ -304,7 +305,7 @@ dsCmd ids local_vars env_ids stack res_ty res_ty core_make_arg core_arrow, - exprFreeVars core_arg `intersectVarSet` local_vars) + exprFreeIds core_arg `intersectVarSet` local_vars) -- A, xs |- f :: a (t*ts) t' -- A, xs |- arg :: t @@ -313,8 +314,9 @@ dsCmd ids local_vars env_ids stack res_ty -- -- ---> arr (\ ((xs)*ts) -> (f,(arg*ts))) >>> app -dsCmd ids local_vars env_ids stack res_ty - (HsArrApp arrow arg arrow_ty HsHigherOrderApp _) = do +dsCmd ids local_vars stack res_ty + (HsArrApp arrow arg arrow_ty HsHigherOrderApp _) + env_ids = do let (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty @@ -332,7 +334,7 @@ dsCmd ids local_vars env_ids stack res_ty res_ty core_make_pair (do_app ids arg_ty res_ty), - (exprFreeVars core_arrow `unionVarSet` exprFreeVars core_arg) + (exprFreeIds core_arrow `unionVarSet` exprFreeIds core_arg) `intersectVarSet` local_vars) -- A | ys |- c :: [t:ts] t' @@ -342,7 +344,7 @@ dsCmd ids local_vars env_ids stack res_ty -- -- ---> arr (\ ((xs)*ts) -> let z = e in (((ys),z)*ts)) >>> c -dsCmd ids local_vars env_ids stack res_ty (HsApp cmd arg) = do +dsCmd ids local_vars stack res_ty (HsApp cmd arg) env_ids = do core_arg <- dsLExpr arg let arg_ty = exprType core_arg @@ -363,8 +365,8 @@ dsCmd ids local_vars env_ids stack res_ty (HsApp cmd arg) = do res_ty core_map core_cmd, - (exprFreeVars core_arg `intersectVarSet` local_vars) - `unionVarSet` free_vars) + free_vars `unionVarSet` + (exprFreeIds core_arg `intersectVarSet` local_vars)) -- A | ys |- c :: [ts] t' -- ----------------------------------------------- @@ -372,11 +374,12 @@ dsCmd ids local_vars env_ids stack res_ty (HsApp cmd arg) = do -- -- ---> arr (\ ((((xs), p1), ... pk)*ts) -> ((ys)*ts)) >>> c -dsCmd ids local_vars env_ids stack res_ty - (HsLam (MatchGroup [L _ (Match pats _ (GRHSs [L _ (GRHS [] body)] _ ))] _)) = do +dsCmd ids local_vars stack res_ty + (HsLam (MatchGroup [L _ (Match pats _ (GRHSs [L _ (GRHS [] body)] _ ))] _)) + env_ids = do let pat_vars = mkVarSet (collectPatsBinders pats) - local_vars' = local_vars `unionVarSet` pat_vars + local_vars' = pat_vars `unionVarSet` local_vars stack' = drop (length pats) stack (core_body, free_vars, env_ids') <- dsfixCmd ids local_vars' stack' res_ty body stack_ids <- mapM newSysLocalDs stack @@ -399,8 +402,8 @@ dsCmd ids local_vars env_ids stack res_ty return (do_map_arrow ids in_ty in_ty' res_ty select_code core_body, free_vars `minusVarSet` pat_vars) -dsCmd ids local_vars env_ids stack res_ty (HsPar cmd) - = dsLCmd ids local_vars env_ids stack res_ty cmd +dsCmd ids local_vars stack res_ty (HsPar cmd) env_ids + = dsLCmd ids local_vars stack res_ty cmd env_ids -- A, xs |- e :: Bool -- A | xs1 |- c1 :: [ts] t @@ -412,7 +415,8 @@ dsCmd ids local_vars env_ids stack res_ty (HsPar cmd) -- if e then Left ((xs1)*ts) else Right ((xs2)*ts)) >>> -- c1 ||| c2 -dsCmd ids local_vars env_ids stack res_ty (HsIf mb_fun cond then_cmd else_cmd) = do +dsCmd ids local_vars stack res_ty (HsIf mb_fun cond then_cmd else_cmd) + env_ids = do core_cond <- dsLExpr cond (core_then, fvs_then, then_ids) <- dsfixCmd ids local_vars stack res_ty then_cmd (core_else, fvs_else, else_ids) <- dsfixCmd ids local_vars stack res_ty else_cmd @@ -428,7 +432,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsIf mb_fun cond then_cmd else_cmd) = then_ty = envStackType then_ids stack else_ty = envStackType else_ids stack sum_ty = mkTyConApp either_con [then_ty, else_ty] - fvs_cond = exprFreeVars core_cond `intersectVarSet` local_vars + fvs_cond = exprFreeIds core_cond `intersectVarSet` local_vars core_left = mk_left_expr then_ty else_ty (buildEnvStack then_ids stack_ids) core_right = mk_right_expr then_ty else_ty (buildEnvStack else_ids stack_ids) @@ -472,7 +476,8 @@ case bodies, containing the following fields: bodies with |||. \begin{code} -dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_ty)) = do +dsCmd ids local_vars stack res_ty (HsCase exp (MatchGroup matches match_ty)) + env_ids = do stack_ids <- mapM newSysLocalDs stack -- Extract and desugar the leaf commands in the case, building tuple @@ -482,7 +487,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_ leaves = concatMap leavesMatch matches make_branch (leaf, bound_vars) = do (core_leaf, _fvs, leaf_ids) <- - dsfixCmd ids (local_vars `unionVarSet` bound_vars) stack res_ty leaf + dsfixCmd ids (bound_vars `unionVarSet` local_vars) stack res_ty leaf return ([mkHsEnvStackExpr leaf_ids stack_ids], envStackType leaf_ids stack, core_leaf) @@ -522,7 +527,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_ core_body <- dsExpr (HsCase exp (MatchGroup matches' match_ty')) core_matches <- matchEnvStack env_ids stack_ids core_body return (do_map_arrow ids in_ty sum_ty res_ty core_matches core_choices, - exprFreeVars core_body `intersectVarSet` local_vars) + exprFreeIds core_body `intersectVarSet` local_vars) -- A | ys |- c :: [ts] t -- ---------------------------------- @@ -530,10 +535,10 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_ -- -- ---> arr (\ ((xs)*ts) -> let binds in ((ys)*ts)) >>> c -dsCmd ids local_vars env_ids stack res_ty (HsLet binds body) = do +dsCmd ids local_vars stack res_ty (HsLet binds body) env_ids = do let defined_vars = mkVarSet (collectLocalBinders binds) - local_vars' = local_vars `unionVarSet` defined_vars + local_vars' = defined_vars `unionVarSet` local_vars (core_body, _free_vars, env_ids') <- dsfixCmd ids local_vars' stack res_ty body stack_ids <- mapM newSysLocalDs stack @@ -547,26 +552,25 @@ dsCmd ids local_vars env_ids stack res_ty (HsLet binds body) = do res_ty core_map core_body, - exprFreeVars core_binds `intersectVarSet` local_vars) + exprFreeIds core_binds `intersectVarSet` local_vars) -dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts _) - = dsCmdDo ids local_vars env_ids res_ty stmts +dsCmd ids local_vars [] res_ty (HsDo _ctxt stmts _) env_ids + = dsCmdDo ids local_vars res_ty stmts env_ids -- A |- e :: forall e. a1 (e*ts1) t1 -> ... an (e*tsn) tn -> a (e*ts) t -- A | xs |- ci :: [tsi] ti -- ----------------------------------- -- A | xs |- (|e c1 ... cn|) :: [ts] t ---> e [t_xs] c1 ... cn -dsCmd _ids local_vars env_ids _stack _res_ty (HsArrForm op _ args) = do +dsCmd _ids local_vars _stack _res_ty (HsArrForm op _ args) env_ids = do let env_ty = mkBigCoreVarTupTy env_ids core_op <- dsLExpr op (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args return (mkApps (App core_op (Type env_ty)) core_args, unionVarSets fv_sets) - -dsCmd ids local_vars env_ids stack res_ty (HsTick tickish expr) = do - (expr1,id_set) <- dsLCmd ids local_vars env_ids stack res_ty expr +dsCmd ids local_vars stack res_ty (HsTick tickish expr) env_ids = do + (expr1,id_set) <- dsLCmd ids local_vars stack res_ty expr env_ids return (Tick tickish expr1, id_set) dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c) @@ -578,9 +582,9 @@ dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c) dsTrimCmdArg :: IdSet -- set of local vars available to this command -> [Id] -- list of vars in the input to this command - -> LHsCmdTop Id -- command argument to desugar + -> LHsCmdTop Id -- command argument to desugar -> DsM (CoreExpr, -- desugared expression - IdSet) -- set of local vars that occur free + IdSet) -- subset of local vars that occur free dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack cmd_ty ids)) = do meth_ids <- mkCmdEnv ids (core_cmd, free_vars, env_ids') <- dsfixCmd meth_ids local_vars stack cmd_ty cmd @@ -603,11 +607,24 @@ dsfixCmd -> Type -- return type of the command -> LHsCmd Id -- command to desugar -> DsM (CoreExpr, -- desugared expression - IdSet, -- set of local vars that occur free - [Id]) -- set as a list, fed back + IdSet, -- subset of local vars that occur free + [Id]) -- the same local vars as a list, fed back dsfixCmd ids local_vars stack cmd_ty cmd - = fixDs (\ ~(_,_,env_ids') -> do - (core_cmd, free_vars) <- dsLCmd ids local_vars env_ids' stack cmd_ty cmd + = trimInput (dsLCmd ids local_vars stack cmd_ty cmd) + +-- Feed back the list of local variables actually used a command, +-- for use as the input tuple of the generated arrow. + +trimInput + :: ([Id] -> DsM (CoreExpr, IdSet)) + -> DsM (CoreExpr, -- desugared expression + IdSet, -- subset of local vars that occur free + [Id]) -- same local vars as a list, fed back to + -- the inner function to form the tuple of + -- inputs to the arrow. +trimInput build_arrow + = fixDs (\ ~(_,_,env_ids) -> do + (core_cmd, free_vars) <- build_arrow env_ids return (core_cmd, free_vars, varSetElems free_vars)) \end{code} @@ -620,31 +637,29 @@ Translation of command judgements of the form dsCmdDo :: DsCmdEnv -- arrow combinators -> IdSet -- set of local vars available to this statement + -> Type -- return type of the statement + -> [LStmt Id] -- statements to desugar -> [Id] -- list of vars in the input to this statement -- This is typically fed back, -- so don't pull on it too early - -> Type -- return type of the statement - -> [LStmt Id] -- statements to desugar -> DsM (CoreExpr, -- desugared expression - IdSet) -- set of local vars that occur free + IdSet) -- subset of local vars that occur free -- A | xs |- c :: [] t -- -------------------------- -- A | xs |- do { c } :: [] t -dsCmdDo _ _ _ _ [] = panic "dsCmdDo" +dsCmdDo _ _ _ [] _ = panic "dsCmdDo" -dsCmdDo ids local_vars env_ids res_ty [L _ (LastStmt body _)] - = dsLCmd ids local_vars env_ids [] res_ty body +dsCmdDo ids local_vars res_ty [L _ (LastStmt body _)] env_ids + = dsLCmd ids local_vars [] res_ty body env_ids -dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) = do +dsCmdDo ids local_vars res_ty (stmt:stmts) env_ids = do let bound_vars = mkVarSet (collectLStmtBinders stmt) - local_vars' = local_vars `unionVarSet` bound_vars - (core_stmts, _, env_ids') <- fixDs (\ ~(_,_,env_ids') -> do - (core_stmts, fv_stmts) <- dsCmdDo ids local_vars' env_ids' res_ty stmts - return (core_stmts, fv_stmts, varSetElems fv_stmts)) - (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids env_ids' stmt + local_vars' = bound_vars `unionVarSet` local_vars + (core_stmts, _, env_ids') <- trimInput (dsCmdDo ids local_vars' res_ty stmts) + (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids return (do_compose ids (mkBigCoreVarTupTy env_ids) (mkBigCoreVarTupTy env_ids') @@ -658,21 +673,21 @@ A statement maps one local environment to another, and is represented as an arrow from one tuple type to another. A statement sequence is translated to a composition of such arrows. \begin{code} -dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> [Id] -> LStmt Id +dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> LStmt Id -> [Id] -> DsM (CoreExpr, IdSet) -dsCmdLStmt ids local_vars env_ids out_ids cmd - = dsCmdStmt ids local_vars env_ids out_ids (unLoc cmd) +dsCmdLStmt ids local_vars out_ids cmd env_ids + = dsCmdStmt ids local_vars out_ids (unLoc cmd) env_ids dsCmdStmt :: DsCmdEnv -- arrow combinators -> IdSet -- set of local vars available to this statement + -> [Id] -- list of vars in the output of this statement + -> Stmt Id -- statement to desugar -> [Id] -- list of vars in the input to this statement -- This is typically fed back, -- so don't pull on it too early - -> [Id] -- list of vars in the output of this statement - -> Stmt Id -- statement to desugar -> DsM (CoreExpr, -- desugared expression - IdSet) -- set of local vars that occur free + IdSet) -- subset of local vars that occur free -- A | xs1 |- c :: [] t -- A | xs' |- do { ss } :: [] t' @@ -682,7 +697,7 @@ dsCmdStmt -- ---> arr (\ (xs) -> ((xs1),(xs'))) >>> first c >>> -- arr snd >>> ss -dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd _ _ c_ty) = do +dsCmdStmt ids local_vars out_ids (ExprStmt cmd _ _ c_ty) env_ids = do (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars [] c_ty cmd core_mux <- matchEnvStack env_ids [] (mkCorePairExpr (mkBigCoreVarTup env_ids1) (mkBigCoreVarTup out_ids)) @@ -711,7 +726,7 @@ dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd _ _ c_ty) = do -- It would be simpler and more consistent to do this using second, -- but that's likely to be defined in terms of first. -dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _ _) = do +dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _) env_ids = do (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars [] (hsLPatType pat) cmd let pat_ty = hsLPatType pat @@ -760,7 +775,7 @@ dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _ _) = do -- -- ---> arr (\ (xs) -> let binds in (xs')) >>> ss -dsCmdStmt ids local_vars env_ids out_ids (LetStmt binds) = do +dsCmdStmt ids local_vars out_ids (LetStmt binds) env_ids = do -- build a new environment using the let bindings core_binds <- dsLocalBinds binds (mkBigCoreVarTup out_ids) -- match the old environment against the input @@ -769,7 +784,7 @@ dsCmdStmt ids local_vars env_ids out_ids (LetStmt binds) = do (mkBigCoreVarTupTy env_ids) (mkBigCoreVarTupTy out_ids) core_map, - exprFreeVars core_binds `intersectVarSet` local_vars) + exprFreeIds core_binds `intersectVarSet` local_vars) -- A | ys |- do { ss; returnA -< ((xs1), (ys2)) } :: [] ... -- A | xs' |- do { ss' } :: [] t @@ -785,9 +800,11 @@ dsCmdStmt ids local_vars env_ids out_ids (LetStmt binds) = do -- first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>> -- arr (\((xs1),(xs2)) -> (xs')) >>> ss' -dsCmdStmt ids local_vars env_ids out_ids - (RecStmt { recS_stmts = stmts, recS_later_ids = later_ids, recS_rec_ids = rec_ids - , recS_rec_rets = rhss }) = do +dsCmdStmt ids local_vars out_ids + (RecStmt { recS_stmts = stmts + , recS_later_ids = later_ids, recS_rec_ids = rec_ids + , recS_later_rets = later_rets, recS_rec_rets = rec_rets }) + env_ids = do let env2_id_set = mkVarSet out_ids `minusVarSet` mkVarSet later_ids env2_ids = varSetElems env2_id_set @@ -807,7 +824,7 @@ dsCmdStmt ids local_vars env_ids out_ids --- loop (...) (core_loop, env1_id_set, env1_ids) - <- dsRecCmd ids local_vars stmts later_ids rec_ids rhss + <- dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets -- pre_loop_fn = \(env_ids) -> ((env1_ids),(env2_ids)) @@ -838,25 +855,41 @@ dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s) -- loop (arr (\ ((env1_ids), ~(rec_ids)) -> (env_ids)) >>> -- ss >>> --- arr (\ (out_ids) -> ((later_ids),(rhss))) >>> - -dsRecCmd :: DsCmdEnv -> VarSet -> [LStmt Id] -> [Var] -> [Var] -> [HsExpr Id] - -> DsM (CoreExpr, VarSet, [Var]) -dsRecCmd ids local_vars stmts later_ids rec_ids rhss = do +-- arr (\ (out_ids) -> ((later_rets),(rec_rets))) >>> + +dsRecCmd + :: DsCmdEnv -- arrow combinators + -> IdSet -- set of local vars available to this statement + -> [LStmt Id] -- list of statements inside the RecCmd + -> [Id] -- list of vars defined here and used later + -> [HsExpr Id] -- expressions corresponding to later_ids + -> [Id] -- list of vars fed back through the loop + -> [HsExpr Id] -- expressions corresponding to rec_ids + -> DsM (CoreExpr, -- desugared statement + IdSet, -- subset of local vars that occur free + [Id]) -- same local vars as a list + +dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do let + later_id_set = mkVarSet later_ids rec_id_set = mkVarSet rec_ids - out_ids = varSetElems (mkVarSet later_ids `unionVarSet` rec_id_set) - out_ty = mkBigCoreVarTupTy out_ids - local_vars' = local_vars `unionVarSet` rec_id_set + local_vars' = rec_id_set `unionVarSet` later_id_set `unionVarSet` local_vars - -- mk_pair_fn = \ (out_ids) -> ((later_ids),(rhss)) + -- mk_pair_fn = \ (out_ids) -> ((later_rets),(rec_rets)) - core_rhss <- mapM dsExpr rhss + core_later_rets <- mapM dsExpr later_rets + core_rec_rets <- mapM dsExpr rec_rets let - later_tuple = mkBigCoreVarTup later_ids + -- possibly polymorphic version of vars of later_ids and rec_ids + out_ids = varSetElems (unionVarSets (map exprFreeIds (core_later_rets ++ core_rec_rets))) + out_ty = mkBigCoreVarTupTy out_ids + + later_tuple = mkBigCoreTup core_later_rets later_ty = mkBigCoreVarTupTy later_ids - rec_tuple = mkBigCoreTup core_rhss + + rec_tuple = mkBigCoreTup core_rec_rets rec_ty = mkBigCoreVarTupTy rec_ids + out_pair = mkCorePairExpr later_tuple rec_tuple out_pair_ty = mkCorePairTy later_ty rec_ty @@ -905,34 +938,32 @@ dsfixCmdStmts :: DsCmdEnv -- arrow combinators -> IdSet -- set of local vars available to this statement -> [Id] -- output vars of these statements - -> [LStmt Id] -- statements to desugar + -> [LStmt Id] -- statements to desugar -> DsM (CoreExpr, -- desugared expression - IdSet, -- set of local vars that occur free - [Id]) -- input vars + IdSet, -- subset of local vars that occur free + [Id]) -- same local vars as a list dsfixCmdStmts ids local_vars out_ids stmts - = fixDs (\ ~(_,_,env_ids) -> do - (core_stmts, fv_stmts) <- dsCmdStmts ids local_vars env_ids out_ids stmts - return (core_stmts, fv_stmts, varSetElems fv_stmts)) + = trimInput (dsCmdStmts ids local_vars out_ids stmts) dsCmdStmts :: DsCmdEnv -- arrow combinators -> IdSet -- set of local vars available to this statement - -> [Id] -- list of vars in the input to these statements -> [Id] -- output vars of these statements - -> [LStmt Id] -- statements to desugar + -> [LStmt Id] -- statements to desugar + -> [Id] -- list of vars in the input to these statements -> DsM (CoreExpr, -- desugared expression - IdSet) -- set of local vars that occur free + IdSet) -- subset of local vars that occur free -dsCmdStmts ids local_vars env_ids out_ids [stmt] - = dsCmdLStmt ids local_vars env_ids out_ids stmt +dsCmdStmts ids local_vars out_ids [stmt] env_ids + = dsCmdLStmt ids local_vars out_ids stmt env_ids -dsCmdStmts ids local_vars env_ids out_ids (stmt:stmts) = do +dsCmdStmts ids local_vars out_ids (stmt:stmts) env_ids = do let bound_vars = mkVarSet (collectLStmtBinders stmt) - local_vars' = local_vars `unionVarSet` bound_vars + local_vars' = bound_vars `unionVarSet` local_vars (core_stmts, _fv_stmts, env_ids') <- dsfixCmdStmts ids local_vars' out_ids stmts - (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids env_ids' stmt + (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids return (do_compose ids (mkBigCoreVarTupTy env_ids) (mkBigCoreVarTupTy env_ids') @@ -941,7 +972,7 @@ dsCmdStmts ids local_vars env_ids out_ids (stmt:stmts) = do core_stmts, fv_stmt) -dsCmdStmts _ _ _ _ [] = panic "dsCmdStmts []" +dsCmdStmts _ _ _ [] _ = panic "dsCmdStmts []" \end{code} @@ -1081,4 +1112,21 @@ add_ev_bndr :: EvBind -> [Id] -> [Id] add_ev_bndr (EvBind b _) bs | isId b = b:bs | otherwise = bs -- A worry: what about coercion variable binders?? + +collectLStmtsBinders :: [LStmt Id] -> [Id] +collectLStmtsBinders = concatMap collectLStmtBinders + +collectLStmtBinders :: LStmt Id -> [Id] +collectLStmtBinders = collectStmtBinders . unLoc + +collectStmtBinders :: Stmt Id -> [Id] +collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat +collectStmtBinders (LetStmt binds) = collectLocalBinders binds +collectStmtBinders (ExprStmt {}) = [] +collectStmtBinders (LastStmt {}) = [] +collectStmtBinders (ParStmt xs _ _ _) = collectLStmtsBinders + $ concatMap fst xs +collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts +collectStmtBinders (RecStmt { recS_later_ids = later_ids }) = later_ids + \end{code} diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index d44943c347..7cc58583dd 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -683,7 +683,9 @@ dsEvTerm (EvId v) = Var v dsEvTerm (EvCast v co) = dsTcCoercion co $ mkCast (Var v) -- 'v' is always a lifted evidence variable so it is - -- unnecessary to call varToCoreExpr v here. + -- unnecessary to call varToCoreExpr v here. +dsEvTerm (EvKindCast v co) + = dsTcCoercion co $ (\_ -> Var v) dsEvTerm (EvDFunApp df tys vars) = Var df `mkTyApps` tys `mkVarApps` vars dsEvTerm (EvCoercion co) = dsTcCoercion co mkEqBox diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs index 626b6ee795..5473edf216 100644 --- a/compiler/deSugar/DsUtils.lhs +++ b/compiler/deSugar/DsUtils.lhs @@ -558,7 +558,7 @@ we are going to make EITHER EITHER (A) v = e (where v is fresh) x = case v of p -> x - y = case v of p -> x + y = case v of p -> y OR (B) t = case e of p -> (x,y) x = case t of (x,_) -> x diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index d4463632af..772a3ebee7 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -802,8 +802,8 @@ pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs , con_res = ResTyH98, con_doc = doc }) = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details details] where - ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprHsInfix con, ppr t2] - ppr_details (PrefixCon tys) = hsep (pprHsVar con : map ppr tys) + ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc (unLoc con), ppr t2] + ppr_details (PrefixCon tys) = hsep (pprPrefixOcc (unLoc con) : map ppr tys) ppr_details (RecCon fields) = ppr con <+> pprConDeclFields fields pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index 5a18fc6574..1dd3c83f31 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -379,7 +379,7 @@ ppr_lexpr :: OutputableBndr id => LHsExpr id -> SDoc ppr_lexpr e = ppr_expr (unLoc e) ppr_expr :: forall id. OutputableBndr id => HsExpr id -> SDoc -ppr_expr (HsVar v) = pprHsVar v +ppr_expr (HsVar v) = pprPrefixOcc v ppr_expr (HsIPVar v) = ppr v ppr_expr (HsLit lit) = ppr lit ppr_expr (HsOverLit lit) = ppr lit @@ -407,7 +407,7 @@ ppr_expr (OpApp e1 op _ e2) = hang (ppr op) 2 (sep [pp_e1, pp_e2]) pp_infixly v - = sep [pp_e1, sep [pprHsInfix v, nest 2 pp_e2]] + = sep [pp_e1, sep [pprInfixOcc v, nest 2 pp_e2]] ppr_expr (NegApp e _) = char '-' <+> pprDebugParendExpr e @@ -420,7 +420,7 @@ ppr_expr (SectionL expr op) pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op]) 4 (hsep [pp_expr, ptext (sLit "x_ )")]) - pp_infixly v = (sep [pp_expr, pprHsInfix v]) + pp_infixly v = (sep [pp_expr, pprInfixOcc v]) ppr_expr (SectionR op expr) = case unLoc op of @@ -431,7 +431,7 @@ ppr_expr (SectionR op expr) pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, ptext (sLit "x_")]) 4 ((<>) pp_expr rparen) - pp_infixly v = sep [pprHsInfix v, pp_expr] + pp_infixly v = sep [pprInfixOcc v, pp_expr] ppr_expr (ExplicitTuple exprs boxity) = tupleParens (boxityNormalTupleSort boxity) (fcat (ppr_tup_args exprs)) @@ -541,7 +541,7 @@ ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False) = hsep [ppr_lexpr arg, ptext (sLit ">>-"), ppr_lexpr arrow] ppr_expr (HsArrForm (L _ (HsVar v)) (Just _) [arg1, arg2]) - = sep [pprCmdArg (unLoc arg1), hsep [pprHsInfix v, pprCmdArg (unLoc arg2)]] + = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]] ppr_expr (HsArrForm op _ args) = hang (ptext (sLit "(|") <> ppr_lexpr op) 4 (sep (map (pprCmdArg.unLoc) args) <> ptext (sLit "|)")) @@ -928,10 +928,11 @@ data StmtLR idL idR , recS_mfix_fn :: SyntaxExpr idR -- The mfix function -- These fields are only valid after typechecking - , recS_rec_rets :: [PostTcExpr] -- These expressions correspond 1-to-1 with - -- recS_rec_ids, and are the - -- expressions that should be returned by - -- the recursion. + , recS_later_rets :: [PostTcExpr] -- (only used in the arrow version) + , recS_rec_rets :: [PostTcExpr] -- These expressions correspond 1-to-1 + -- with recS_later_ids and recS_rec_ids, + -- and are the expressions that should be + -- returned by the recursion. -- They may not quite be the Ids themselves, -- because the Id may be *polymorphic*, but -- the returned thing has to be *monomorphic*, diff --git a/compiler/hsSyn/HsImpExp.lhs b/compiler/hsSyn/HsImpExp.lhs index 01890b6c95..ee75414d4c 100644 --- a/compiler/hsSyn/HsImpExp.lhs +++ b/compiler/hsSyn/HsImpExp.lhs @@ -57,7 +57,7 @@ simpleImportDecl mn = ImportDecl { \end{code} \begin{code} -instance (Outputable name) => Outputable (ImportDecl name) where +instance (OutputableBndr name) => Outputable (ImportDecl name) where ppr (ImportDecl { ideclName = mod', ideclPkgQual = pkg , ideclSource = from, ideclSafe = safe , ideclQualified = qual, ideclImplicit = implicit @@ -134,12 +134,12 @@ ieNames (IEDocNamed _ ) = [] \end{code} \begin{code} -instance (Outputable name) => Outputable (IE name) where - ppr (IEVar var) = pprHsVar var +instance (OutputableBndr name, Outputable name) => Outputable (IE name) where + ppr (IEVar var) = pprPrefixOcc var ppr (IEThingAbs thing) = ppr thing ppr (IEThingAll thing) = hcat [ppr thing, text "(..)"] ppr (IEThingWith thing withs) - = pprHsVar thing <> parens (fsep (punctuate comma (map pprHsVar withs))) + = pprPrefixOcc thing <> parens (fsep (punctuate comma (map pprPrefixOcc withs))) ppr (IEModuleContents mod') = ptext (sLit "module") <+> ppr mod' ppr (IEGroup n _) = text ("<IEGroup: " ++ (show n) ++ ">") diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index f4b3bc0c6e..aa96ed9f5e 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -197,6 +197,19 @@ mkHsOpTy :: LHsType name -> Located name -> LHsType name -> HsType name mkHsOpTy ty1 op ty2 = HsOpTy ty1 (WpKiApps [], op) ty2 \end{code} +Note [Unit tuples] +~~~~~~~~~~~~~~~~~~ +Consider the type + type instance F Int = () +We want to parse that "()" + as HsTupleTy HsBoxedOrConstraintTuple [], +NOT as HsTyVar unitTyCon + +Why? Because F might have kind (* -> Constraint), so we when parsing we +don't know if that tuple is going to be a constraint tuple or an ordinary +unit tuple. The HsTupleSort flag is specifically designed to deal with +that, but it has to work for unit tuples too. + Note [Promotions (HsTyVar)] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ HsTyVar: A name in a type or kind. diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 234791d9fc..3527d9139e 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -233,7 +233,7 @@ mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr emptyRecStmt = RecStmt { recS_stmts = [], recS_later_ids = [], recS_rec_ids = [] , recS_ret_fn = noSyntaxExpr, recS_mfix_fn = noSyntaxExpr - , recS_bind_fn = noSyntaxExpr + , recS_bind_fn = noSyntaxExpr, recS_later_rets = [] , recS_rec_rets = [], recS_ret_ty = placeHolderType } mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts } diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index bb6430e02a..e981995bd4 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -561,7 +561,7 @@ tcIfaceDataCons tycon_name tycon _ if_cons ; let orig_res_ty = mkFamilyTyConApp tycon (substTyVars (mkTopTvSubst eq_spec) univ_tyvars) - ; buildDataCon name is_infix {- Not infix -} + ; buildDataCon name is_infix stricts lbl_names univ_tyvars ex_tyvars eq_spec theta diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 2230f3fa40..0e8990777b 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -137,10 +137,7 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler) -- We add the directory in which the .hs files resides) to the import path. -- This is needed when we try to compile the .hc file later, if it -- imports a _stub.h file that we created here. - let current_dir = case takeDirectory basename of - "" -> "." -- XXX Hack required for filepath-1.1 and earlier - -- (GHC 6.12 and earlier) - d -> d + let current_dir = takeDirectory basename old_paths = includePaths dflags0 dflags = dflags0 { includePaths = current_dir : old_paths } hsc_env = hsc_env0 {hsc_dflags = dflags} @@ -598,8 +595,8 @@ getPipeEnv = P $ \env state -> return (state, env) getPipeState :: CompPipeline PipeState getPipeState = P $ \_env state -> return (state, state) -getDynFlags :: CompPipeline DynFlags -getDynFlags = P $ \_env state -> return (state, hsc_dflags (hsc_env state)) +instance HasDynFlags CompPipeline where + getDynFlags = P $ \_env state -> return (state, hsc_dflags (hsc_env state)) setDynFlags :: DynFlags -> CompPipeline () setDynFlags dflags = P $ \_env state -> @@ -849,11 +846,7 @@ runPhase (Hsc src_flavour) input_fn dflags0 -- we add the current directory (i.e. the directory in which -- the .hs files resides) to the include path, since this is -- what gcc does, and it's probably what you want. - let current_dir = case takeDirectory basename of - "" -> "." -- XXX Hack required for filepath-1.1 and earlier - -- (GHC 6.12 and earlier) - d -> d - + let current_dir = takeDirectory basename paths = includePaths dflags0 dflags = dflags0 { includePaths = current_dir : paths } diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index de844ea3b5..1bd4fcef8a 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -29,6 +29,7 @@ module DynFlags ( xopt_set, xopt_unset, DynFlags(..), + HasDynFlags(..), RtsOptsEnabled(..), HscTarget(..), isObjectTarget, defaultObjectTarget, GhcMode(..), isOneShot, @@ -563,11 +564,12 @@ data DynFlags = DynFlags { language :: Maybe Language, -- | Safe Haskell mode safeHaskell :: SafeHaskellMode, - -- We store the location of where template haskell and newtype deriving were - -- turned on so we can produce accurate error messages when Safe Haskell turns - -- them off. + -- We store the location of where some extension and flags were turned on so + -- we can produce accurate error messages when Safe Haskell fails due to + -- them. thOnLoc :: SrcSpan, newDerivOnLoc :: SrcSpan, + pkgTrustOnLoc :: SrcSpan, warnSafeOnLoc :: SrcSpan, warnUnsafeOnLoc :: SrcSpan, -- Don't change this without updating extensionFlags: @@ -585,6 +587,9 @@ data DynFlags = DynFlags { profAuto :: ProfAuto } +class HasDynFlags m where + getDynFlags :: m DynFlags + data ProfAuto = NoProfAuto -- ^ no SCC annotations added | ProfAutoAll -- ^ top-level and nested functions are annotated @@ -907,6 +912,7 @@ defaultDynFlags mySettings = safeHaskell = Sf_SafeInfered, thOnLoc = noSrcSpan, newDerivOnLoc = noSrcSpan, + pkgTrustOnLoc = noSrcSpan, warnSafeOnLoc = noSrcSpan, warnUnsafeOnLoc = noSrcSpan, extensions = [], @@ -1302,19 +1308,28 @@ parseDynamicFlags dflags0 args cmdline = do when (not (null errs)) $ ghcError $ errorsToGhcException errs -- check for disabled flags in safe haskell - let (dflags2, sh_warns) = safeFlagCheck dflags1 + let (dflags2, sh_warns) = safeFlagCheck cmdline dflags1 return (dflags2, leftover, sh_warns ++ warns) -- | Check (and potentially disable) any extensions that aren't allowed -- in safe mode. -safeFlagCheck :: DynFlags -> (DynFlags, [Located String]) -safeFlagCheck dflags | not (safeLanguageOn dflags || safeInferOn dflags) - = (dflags, []) -safeFlagCheck dflags = +safeFlagCheck :: Bool -> DynFlags -> (DynFlags, [Located String]) +safeFlagCheck _ dflags | not (safeLanguageOn dflags || safeInferOn dflags) + = (dflags, []) + +safeFlagCheck cmdl dflags = case safeLanguageOn dflags of True -> (dflags', warns) + -- throw error if -fpackage-trust by itself with no safe haskell flag + False | not cmdl && safeInferOn dflags && packageTrustOn dflags + -> (dopt_unset dflags' Opt_PackageTrust, + [L (pkgTrustOnLoc dflags') $ + "Warning: -fpackage-trust ignored;" ++ + " must be specified with a Safe Haskell flag"] + ) + False | null warns && safeInfOk -> (dflags', []) @@ -1660,7 +1675,7 @@ dynamic_flags = [ , Flag "fno-glasgow-exts" (NoArg (disableGlasgowExts >> deprecate "Use individual extensions instead")) ------ Safe Haskell flags ------------------------------------------- - , Flag "fpackage-trust" (NoArg (setDynFlag Opt_PackageTrust)) + , Flag "fpackage-trust" (NoArg setPackageTrust) , Flag "fno-safe-infer" (NoArg (setSafeHaskell Sf_None)) ] ++ map (mkFlag turnOn "f" setDynFlag ) fFlags @@ -2173,6 +2188,12 @@ setWarnUnsafe :: Bool -> DynP () setWarnUnsafe True = getCurLoc >>= \l -> upd (\d -> d { warnUnsafeOnLoc = l }) setWarnUnsafe False = return () +setPackageTrust :: DynP () +setPackageTrust = do + setDynFlag Opt_PackageTrust + l <- getCurLoc + upd $ \d -> d { pkgTrustOnLoc = l } + setGenDeriving :: Bool -> DynP () setGenDeriving True = getCurLoc >>= \l -> upd (\d -> d { newDerivOnLoc = l }) setGenDeriving False = return () diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 9665c60f2f..df670f1d63 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -6,17 +6,10 @@ -- -- ----------------------------------------------------------------------------- -{-# 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 GHC ( - -- * Initialisation - defaultErrorHandler, - defaultCleanupHandler, + -- * Initialisation + defaultErrorHandler, + defaultCleanupHandler, -- * GHC Monad Ghc, GhcT, GhcMonad(..), HscEnv, @@ -27,31 +20,31 @@ module GHC ( handleSourceError, needsTemplateHaskell, - -- * Flags and settings - DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt, + -- * Flags and settings + DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt, GhcMode(..), GhcLink(..), defaultObjectTarget, - parseDynamicFlags, - getSessionDynFlags, - setSessionDynFlags, - parseStaticFlags, - - -- * Targets - Target(..), TargetId(..), Phase, - setTargets, - getTargets, - addTarget, - removeTarget, - guessTarget, - - -- * Loading\/compiling the program - depanal, + parseDynamicFlags, + getSessionDynFlags, + setSessionDynFlags, + parseStaticFlags, + + -- * Targets + Target(..), TargetId(..), Phase, + setTargets, + getTargets, + addTarget, + removeTarget, + guessTarget, + + -- * Loading\/compiling the program + depanal, load, LoadHowMuch(..), InteractiveImport(..), - SuccessFlag(..), succeeded, failed, + SuccessFlag(..), succeeded, failed, defaultWarnErrLogger, WarnErrLogger, - workingDirectoryChanged, + workingDirectoryChanged, parseModule, typecheckModule, desugarModule, loadModule, ParsedModule(..), TypecheckedModule(..), DesugaredModule(..), - TypecheckedSource, ParsedSource, RenamedSource, -- ditto + TypecheckedSource, ParsedSource, RenamedSource, -- ditto TypecheckedMod, ParsedMod, moduleInfo, renamedSource, typecheckedSource, parsedSource, coreModule, @@ -61,50 +54,50 @@ module GHC ( compileToCoreModule, compileToCoreSimplified, compileCoreToObj, - -- * Inspecting the module structure of the program - ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..), + -- * Inspecting the module structure of the program + ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..), getModSummary, getModuleGraph, - isLoaded, - topSortModuleGraph, - - -- * Inspecting modules - ModuleInfo, - getModuleInfo, - modInfoTyThings, - modInfoTopLevelScope, + isLoaded, + topSortModuleGraph, + + -- * Inspecting modules + ModuleInfo, + getModuleInfo, + modInfoTyThings, + modInfoTopLevelScope, modInfoExports, - modInfoInstances, - modInfoIsExportedName, - modInfoLookupName, + modInfoInstances, + modInfoIsExportedName, + modInfoLookupName, modInfoIface, - lookupGlobalName, - findGlobalAnns, + lookupGlobalName, + findGlobalAnns, mkPrintUnqualifiedForModule, ModIface(..), -- * Querying the environment packageDbModules, - -- * Printing - PrintUnqualified, alwaysQualify, + -- * Printing + PrintUnqualified, alwaysQualify, - -- * Interactive evaluation - getBindings, getInsts, getPrintUnqual, - findModule, - lookupModule, + -- * Interactive evaluation + getBindings, getInsts, getPrintUnqual, + findModule, lookupModule, #ifdef GHCI - setContext, getContext, - getNamesInScope, - getRdrNamesInScope, + isModuleTrusted, + setContext, getContext, + getNamesInScope, + getRdrNamesInScope, getGRE, - moduleIsInterpreted, - getInfo, - exprType, - typeKind, - parseName, - RunResult(..), - runStmt, runStmtWithLocation, runDecls, runDeclsWithLocation, + moduleIsInterpreted, + getInfo, + exprType, + typeKind, + parseName, + RunResult(..), + runStmt, runStmtWithLocation, runDecls, runDeclsWithLocation, parseImportDecl, SingleStep(..), resume, Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan, @@ -115,9 +108,9 @@ module GHC ( abandon, abandonAll, InteractiveEval.back, InteractiveEval.forward, - showModule, + showModule, isModuleInterpreted, - InteractiveEval.compileExpr, HValue, dynCompileExpr, + InteractiveEval.compileExpr, HValue, dynCompileExpr, GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType, modInfoModBreaks, ModBreaks(..), BreakIndex, @@ -126,106 +119,106 @@ module GHC ( #endif lookupName, - -- * Abstract syntax elements + -- * Abstract syntax elements -- ** Packages PackageId, - -- ** Modules - Module, mkModule, pprModule, moduleName, modulePackageId, + -- ** Modules + Module, mkModule, pprModule, moduleName, modulePackageId, ModuleName, mkModuleName, moduleNameString, - -- ** Names - Name, - isExternalName, nameModule, pprParenSymName, nameSrcSpan, - NamedThing(..), - RdrName(Qual,Unqual), - - -- ** Identifiers - Id, idType, - isImplicitId, isDeadBinder, - isExportedId, isLocalId, isGlobalId, - isRecordSelector, - isPrimOpId, isFCallId, isClassOpId_maybe, - isDataConWorkId, idDataCon, - isBottomingId, isDictonaryId, - recordSelectorFieldLabel, - - -- ** Type constructors - TyCon, - tyConTyVars, tyConDataCons, tyConArity, - isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon, - isFamilyTyCon, tyConClass_maybe, - synTyConDefn, synTyConType, synTyConResKind, - - -- ** Type variables - TyVar, - alphaTyVars, - - -- ** Data constructors - DataCon, - dataConSig, dataConType, dataConTyCon, dataConFieldLabels, - dataConIsInfix, isVanillaDataCon, dataConUserType, - dataConStrictMarks, - StrictnessMark(..), isMarkedStrict, - - -- ** Classes - Class, - classMethods, classSCTheta, classTvsFds, classATs, - pprFundeps, - - -- ** Instances - Instance, - instanceDFunId, + -- ** Names + Name, + isExternalName, nameModule, pprParenSymName, nameSrcSpan, + NamedThing(..), + RdrName(Qual,Unqual), + + -- ** Identifiers + Id, idType, + isImplicitId, isDeadBinder, + isExportedId, isLocalId, isGlobalId, + isRecordSelector, + isPrimOpId, isFCallId, isClassOpId_maybe, + isDataConWorkId, idDataCon, + isBottomingId, isDictonaryId, + recordSelectorFieldLabel, + + -- ** Type constructors + TyCon, + tyConTyVars, tyConDataCons, tyConArity, + isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon, + isFamilyTyCon, tyConClass_maybe, + synTyConDefn, synTyConType, synTyConResKind, + + -- ** Type variables + TyVar, + alphaTyVars, + + -- ** Data constructors + DataCon, + dataConSig, dataConType, dataConTyCon, dataConFieldLabels, + dataConIsInfix, isVanillaDataCon, dataConUserType, + dataConStrictMarks, + StrictnessMark(..), isMarkedStrict, + + -- ** Classes + Class, + classMethods, classSCTheta, classTvsFds, classATs, + pprFundeps, + + -- ** Instances + Instance, + instanceDFunId, pprInstance, pprInstanceHdr, pprFamInst, pprFamInstHdr, - -- ** Types and Kinds - Type, splitForAllTys, funResultTy, - pprParendType, pprTypeApp, - Kind, - PredType, - ThetaType, pprForAll, pprThetaArrowTy, + -- ** Types and Kinds + Type, splitForAllTys, funResultTy, + pprParendType, pprTypeApp, + Kind, + PredType, + ThetaType, pprForAll, pprThetaArrowTy, - -- ** Entities - TyThing(..), + -- ** Entities + TyThing(..), - -- ** Syntax - module HsSyn, -- ToDo: remove extraneous bits + -- ** Syntax + module HsSyn, -- ToDo: remove extraneous bits - -- ** Fixities - FixityDirection(..), - defaultFixity, maxPrecedence, - negateFixity, - compareFixity, + -- ** Fixities + FixityDirection(..), + defaultFixity, maxPrecedence, + negateFixity, + compareFixity, - -- ** Source locations - SrcLoc(..), RealSrcLoc, + -- ** Source locations + SrcLoc(..), RealSrcLoc, mkSrcLoc, noSrcLoc, - srcLocFile, srcLocLine, srcLocCol, + srcLocFile, srcLocLine, srcLocCol, SrcSpan(..), RealSrcSpan, mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan, srcSpanStart, srcSpanEnd, - srcSpanFile, + srcSpanFile, srcSpanStartLine, srcSpanEndLine, srcSpanStartCol, srcSpanEndCol, -- ** Located - GenLocated(..), Located, + GenLocated(..), Located, - -- *** Constructing Located - noLoc, mkGeneralLocated, + -- *** Constructing Located + noLoc, mkGeneralLocated, - -- *** Deconstructing Located - getLoc, unLoc, + -- *** Deconstructing Located + getLoc, unLoc, - -- *** Combining and comparing Located values - eqLocated, cmpLocated, combineLocs, addCLoc, + -- *** Combining and comparing Located values + eqLocated, cmpLocated, combineLocs, addCLoc, leftmost_smallest, leftmost_largest, rightmost, spans, isSubspanOf, - -- * Exceptions - GhcException(..), showGhcException, + -- * Exceptions + GhcException(..), showGhcException, -- * Token stream manipulations Token, @@ -235,9 +228,9 @@ module GHC ( -- * Pure interface to the parser parser, - -- * Miscellaneous - --sessionHscEnv, - cyclicModuleErr, + -- * Miscellaneous + --sessionHscEnv, + cyclicModuleErr, ) where {- @@ -258,7 +251,7 @@ import InteractiveEval import HscMain import GhcMake -import DriverPipeline ( compile' ) +import DriverPipeline ( compile' ) import GhcMonad import TcRnTypes import Packages @@ -267,10 +260,10 @@ import RdrName import qualified HsSyn -- hack as we want to reexport the whole module import HsSyn import Type hiding( typeKind ) -import Kind ( synTyConResKind ) -import TcType hiding( typeKind ) +import Kind ( synTyConResKind ) +import TcType hiding( typeKind ) import Id -import TysPrim ( alphaTyVars ) +import TysPrim ( alphaTyVars ) import TyCon import Class import DataCon @@ -292,26 +285,26 @@ import Annotations import Module import UniqFM import Panic -import Bag ( unitBag ) +import Bag ( unitBag ) import ErrUtils import MonadUtils import Util import StringBuffer import Outputable import BasicTypes -import Maybes ( expectJust ) +import Maybes ( expectJust ) import FastString import qualified Parser import Lexer import System.Directory ( doesFileExist, getCurrentDirectory ) import Data.Maybe -import Data.List ( find ) +import Data.List ( find ) import Data.Typeable ( Typeable ) import Data.Word ( Word8 ) import Control.Monad -import System.Exit ( exitWith, ExitCode(..) ) -import System.Time ( getClockTime ) +import System.Exit ( exitWith, ExitCode(..) ) +import System.Time ( getClockTime ) import Exception import Data.IORef import System.FilePath @@ -320,9 +313,9 @@ import Prelude hiding (init) -- %************************************************************************ --- %* * +-- %* * -- Initialisation: exception handlers --- %* * +-- %* * -- %************************************************************************ @@ -340,7 +333,7 @@ defaultErrorHandler la inner = Just (ioe :: IOException) -> fatalErrorMsg' la (text (show ioe)) _ -> case fromException exception of - Just UserInterrupt -> exitWith (ExitFailure 1) + Just UserInterrupt -> exitWith (ExitFailure 1) Just StackOverflow -> fatalErrorMsg' la (text "stack overflow: use +RTS -K<size> to increase it") _ -> case fromException exception of @@ -354,13 +347,13 @@ defaultErrorHandler la inner = -- error messages propagated as exceptions handleGhcException (\ge -> liftIO $ do - hFlush stdout - case ge of - PhaseFailed _ code -> exitWith code - Signal _ -> exitWith (ExitFailure 1) - _ -> do fatalErrorMsg' la (text (show ge)) - exitWith (ExitFailure 1) - ) $ + hFlush stdout + case ge of + PhaseFailed _ code -> exitWith code + Signal _ -> exitWith (ExitFailure 1) + _ -> do fatalErrorMsg' la (text (show ge)) + exitWith (ExitFailure 1) + ) $ inner -- | Install a default cleanup handler to remove temporary files deposited by @@ -382,9 +375,9 @@ defaultCleanupHandler dflags inner = -- %************************************************************************ --- %* * +-- %* * -- The Ghc Monad --- %* * +-- %* * -- %************************************************************************ -- | Run function for the 'Ghc' monad. @@ -450,9 +443,9 @@ initGhcMonad mb_top_dir = do -- %************************************************************************ --- %* * +-- %* * -- Flags & settings --- %* * +-- %* * -- %************************************************************************ -- | Updates the DynFlags in a Session. This also reads @@ -480,9 +473,9 @@ parseDynamicFlags = parseDynamicFlagsCmdLine -- %************************************************************************ --- %* * +-- %* * -- Setting, getting, and modifying the targets --- %* * +-- %* * -- %************************************************************************ -- ToDo: think about relative vs. absolute file paths. And what @@ -530,13 +523,13 @@ guessTarget str Nothing = return (target (TargetFile file Nothing)) | otherwise = do exists <- liftIO $ doesFileExist hs_file - if exists - then return (target (TargetFile hs_file Nothing)) - else do - exists <- liftIO $ doesFileExist lhs_file - if exists - then return (target (TargetFile lhs_file Nothing)) - else do + if exists + then return (target (TargetFile hs_file Nothing)) + else do + exists <- liftIO $ doesFileExist lhs_file + if exists + then return (target (TargetFile lhs_file Nothing)) + else do if looksLikeModuleName file then return (target (TargetModule (mkModuleName file))) else do @@ -549,8 +542,8 @@ guessTarget str Nothing | '*':rest <- str = (rest, False) | otherwise = (str, True) - hs_file = file <.> "hs" - lhs_file = file <.> "lhs" + hs_file = file <.> "hs" + lhs_file = file <.> "lhs" target tid = Target tid obj_allowed Nothing @@ -567,9 +560,9 @@ workingDirectoryChanged = withSession $ (liftIO . flushFinderCaches) -- %************************************************************************ --- %* * +-- %* * -- Running phases one at a time --- %* * +-- %* * -- %************************************************************************ class ParsedMod m where @@ -581,11 +574,11 @@ class ParsedMod m => TypecheckedMod m where typecheckedSource :: m -> TypecheckedSource moduleInfo :: m -> ModuleInfo tm_internals :: m -> (TcGblEnv, ModDetails) - -- ToDo: improvements that could be made here: - -- if the module succeeded renaming but not typechecking, - -- we can still get back the GlobalRdrEnv and exports, so - -- perhaps the ModuleInfo should be split up into separate - -- fields. + -- ToDo: improvements that could be made here: + -- if the module succeeded renaming but not typechecking, + -- we can still get back the GlobalRdrEnv and exports, so + -- perhaps the ModuleInfo should be split up into separate + -- fields. class TypecheckedMod m => DesugaredMod m where coreModule :: m -> ModGuts @@ -768,9 +761,9 @@ loadModule tcm = do -- %************************************************************************ --- %* * +-- %* * -- Dealing with Core --- %* * +-- %* * -- %************************************************************************ -- | A CoreModule consists of just the fields of a 'ModGuts' that are needed for @@ -893,9 +886,9 @@ compileCore simplify fn = do } -- %************************************************************************ --- %* * +-- %* * -- Inspecting the session --- %* * +-- %* * -- %************************************************************************ -- | Get the module dependency graph. @@ -932,28 +925,28 @@ getPrintUnqual = withSession $ \hsc_env -> -- | Container for information about a 'Module'. data ModuleInfo = ModuleInfo { - minf_type_env :: TypeEnv, - minf_exports :: NameSet, -- ToDo, [AvailInfo] like ModDetails? - minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod - minf_instances :: [Instance], + minf_type_env :: TypeEnv, + minf_exports :: NameSet, -- ToDo, [AvailInfo] like ModDetails? + minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod + minf_instances :: [Instance], minf_iface :: Maybe ModIface #ifdef GHCI ,minf_modBreaks :: ModBreaks #endif } - -- We don't want HomeModInfo here, because a ModuleInfo applies - -- to package modules too. + -- We don't want HomeModInfo here, because a ModuleInfo applies + -- to package modules too. -- | Request information about a loaded 'Module' getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo) -- XXX: Maybe X getModuleInfo mdl = withSession $ \hsc_env -> do let mg = hsc_mod_graph hsc_env if mdl `elem` map ms_mod mg - then liftIO $ getHomeModuleInfo hsc_env mdl - else do + then liftIO $ getHomeModuleInfo hsc_env mdl + else do {- if isHomeModule (hsc_dflags hsc_env) mdl - then return Nothing - else -} liftIO $ getPackageModuleInfo hsc_env mdl + then return Nothing + else -} liftIO $ getPackageModuleInfo hsc_env mdl -- ToDo: we don't understand what the following comment means. -- (SDM, 19/7/2011) -- getPackageModuleInfo will attempt to find the interface, so @@ -964,23 +957,23 @@ getModuleInfo mdl = withSession $ \hsc_env -> do getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) #ifdef GHCI getPackageModuleInfo hsc_env mdl - = do eps <- hscEPS hsc_env + = do eps <- hscEPS hsc_env iface <- hscGetModuleInterface hsc_env mdl - let - avails = mi_exports iface + let + avails = mi_exports iface names = availsToNameSet avails - pte = eps_PTE eps - tys = [ ty | name <- concatMap availNames avails, - Just ty <- [lookupTypeEnv pte name] ] - -- - return (Just (ModuleInfo { - minf_type_env = mkTypeEnv tys, - minf_exports = names, - minf_rdr_env = Just $! availsToGlobalRdrEnv (moduleName mdl) avails, - minf_instances = error "getModuleInfo: instances for package module unimplemented", + pte = eps_PTE eps + tys = [ ty | name <- concatMap availNames avails, + Just ty <- [lookupTypeEnv pte name] ] + -- + return (Just (ModuleInfo { + minf_type_env = mkTypeEnv tys, + minf_exports = names, + minf_rdr_env = Just $! availsToGlobalRdrEnv (moduleName mdl) avails, + minf_instances = error "getModuleInfo: instances for package module unimplemented", minf_iface = Just iface, minf_modBreaks = emptyModBreaks - })) + })) #else -- bogusly different for non-GHCI (ToDo) getPackageModuleInfo _hsc_env _mdl = do @@ -995,15 +988,15 @@ getHomeModuleInfo hsc_env mdl = let details = hm_details hmi iface = hm_iface hmi return (Just (ModuleInfo { - minf_type_env = md_types details, - minf_exports = availsToNameSet (md_exports details), - minf_rdr_env = mi_globals $! hm_iface hmi, - minf_instances = md_insts details, + minf_type_env = md_types details, + minf_exports = availsToNameSet (md_exports details), + minf_rdr_env = mi_globals $! hm_iface hmi, + minf_instances = md_insts details, minf_iface = Just iface #ifdef GHCI ,minf_modBreaks = getModBreaks hmi #endif - })) + })) -- | The list of top-level entities defined in a module modInfoTyThings :: ModuleInfo -> [TyThing] @@ -1039,7 +1032,7 @@ modInfoLookupName minf name = withSession $ \hsc_env -> do Nothing -> do eps <- liftIO $ readIORef (hsc_EPS hsc_env) return $! lookupType (hsc_dflags hsc_env) - (hsc_HPT hsc_env) (eps_PTE eps) name + (hsc_HPT hsc_env) (eps_PTE eps) name modInfoIface :: ModuleInfo -> Maybe ModIface modInfoIface = minf_iface @@ -1252,28 +1245,34 @@ lookupModule mod_name Nothing = withSession $ \hsc_env -> do res <- findExposedPackageModule hsc_env mod_name Nothing case res of Found _ m -> return m - err -> noModError (hsc_dflags hsc_env) noSrcSpan mod_name err + err -> noModError (hsc_dflags hsc_env) noSrcSpan mod_name err -lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module) +lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module) lookupLoadedHomeModule mod_name = withSession $ \hsc_env -> case lookupUFM (hsc_HPT hsc_env) mod_name of Just mod_info -> return (Just (mi_module (hm_iface mod_info))) _not_a_home_module -> return Nothing #ifdef GHCI +-- | Check that a module is safe to import (according to Safe Haskell). +-- +-- We return True to indicate the import is safe and False otherwise +-- although in the False case an error may be thrown first. +isModuleTrusted :: GhcMonad m => Module -> m Bool +isModuleTrusted m = withSession $ \hsc_env -> + liftIO $ hscCheckSafe hsc_env m noSrcSpan + getHistorySpan :: GhcMonad m => History -> m SrcSpan getHistorySpan h = withSession $ \hsc_env -> - return$ InteractiveEval.getHistorySpan hsc_env h + return $ InteractiveEval.getHistorySpan hsc_env h obtainTermFromVal :: GhcMonad m => Int -> Bool -> Type -> a -> m Term -obtainTermFromVal bound force ty a = - withSession $ \hsc_env -> - liftIO $ InteractiveEval.obtainTermFromVal hsc_env bound force ty a +obtainTermFromVal bound force ty a = withSession $ \hsc_env -> + liftIO $ InteractiveEval.obtainTermFromVal hsc_env bound force ty a obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term -obtainTermFromId bound force id = - withSession $ \hsc_env -> - liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id +obtainTermFromId bound force id = withSession $ \hsc_env -> + liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id #endif @@ -1307,3 +1306,4 @@ parser str dflags filename = POk pst rdr_module -> let (warns,_) = getMessages pst in Right (warns, rdr_module) + diff --git a/compiler/main/GhcMonad.hs b/compiler/main/GhcMonad.hs index 816cc4b922..6b8c7bacdf 100644 --- a/compiler/main/GhcMonad.hs +++ b/compiler/main/GhcMonad.hs @@ -46,11 +46,10 @@ import Data.IORef -- If you do not use 'Ghc' or 'GhcT', make sure to call 'GHC.initGhcMonad' -- before any call to the GHC API functions can occur. -- -class (Functor m, MonadIO m, ExceptionMonad m) => GhcMonad m where +class (Functor m, MonadIO m, ExceptionMonad m, HasDynFlags m) => GhcMonad m where getSession :: m HscEnv setSession :: HscEnv -> m () - -- | Call the argument with the current session. withSession :: GhcMonad m => (HscEnv -> m a) -> m a withSession f = getSession >>= f @@ -120,6 +119,9 @@ instance ExceptionMonad Ghc where in unGhc (f g_restore) s +instance HasDynFlags Ghc where + getDynFlags = getSessionDynFlags + instance GhcMonad Ghc where getSession = Ghc $ \(Session r) -> readIORef r setSession s' = Ghc $ \(Session r) -> writeIORef r s' @@ -176,6 +178,9 @@ instance ExceptionMonad m => ExceptionMonad (GhcT m) where in unGhcT (f g_restore) s +instance (Functor m, ExceptionMonad m, MonadIO m) => HasDynFlags (GhcT m) where + getDynFlags = getSessionDynFlags + instance (Functor m, ExceptionMonad m, MonadIO m) => GhcMonad (GhcT m) where getSession = GhcT $ \(Session r) -> liftIO $ readIORef r setSession s' = GhcT $ \(Session r) -> liftIO $ writeIORef r s' diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index b4cfbf403f..2882816c0b 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -60,6 +60,7 @@ module HscMain , hscParseIdentifier , hscTcRcLookupName , hscTcRnGetInfo + , hscCheckSafe #ifdef GHCI , hscGetModuleInterface , hscRnImportDecls @@ -93,7 +94,7 @@ import HsSyn import CoreSyn import StringBuffer import Parser -import Lexer hiding (getDynFlags) +import Lexer import SrcLoc import TcRnDriver import TcIface ( typecheckIface ) @@ -205,6 +206,9 @@ instance Monad Hsc where instance MonadIO Hsc where liftIO io = Hsc $ \_ w -> do a <- io; return (a, w) +instance Functor Hsc where + fmap f m = m >>= \a -> return $ f a + runHsc :: HscEnv -> Hsc a -> IO a runHsc hsc_env (Hsc hsc) = do (a, w) <- hsc hsc_env emptyBag @@ -223,8 +227,8 @@ logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w) getHscEnv :: Hsc HscEnv getHscEnv = Hsc $ \e w -> return (e, w) -getDynFlags :: Hsc DynFlags -getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w) +instance HasDynFlags Hsc where + getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w) handleWarnings :: Hsc () handleWarnings = do @@ -886,9 +890,8 @@ hscFileFrontEnd mod_summary = do -- inference mode. hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv hscCheckSafeImports tcg_env = do - hsc_env <- getHscEnv dflags <- getDynFlags - tcg_env' <- checkSafeImports dflags hsc_env tcg_env + tcg_env' <- checkSafeImports dflags tcg_env case safeLanguageOn dflags of True -> do -- we nuke user written RULES in -XSafe @@ -911,22 +914,20 @@ hscCheckSafeImports tcg_env = do text "Rule \"" <> ftext n <> text "\" ignored" $+$ text "User defined rules are disabled under Safe Haskell" --- | Validate that safe imported modules are actually safe. --- For modules in the HomePackage (the package the module we --- are compiling in resides) this just involves checking its --- trust type is 'Safe' or 'Trustworthy'. For modules that --- reside in another package we also must check that the --- external pacakge is trusted. See the Note [Safe Haskell --- Trust Check] above for more information. +-- | Validate that safe imported modules are actually safe. For modules in the +-- HomePackage (the package the module we are compiling in resides) this just +-- involves checking its trust type is 'Safe' or 'Trustworthy'. For modules +-- that reside in another package we also must check that the external pacakge +-- is trusted. See the Note [Safe Haskell Trust Check] above for more +-- information. -- --- The code for this is quite tricky as the whole algorithm --- is done in a few distinct phases in different parts of the --- code base. See RnNames.rnImportDecl for where package trust --- dependencies for a module are collected and unioned. --- Specifically see the Note [RnNames . Tracking Trust Transitively] --- and the Note [RnNames . Trust Own Package]. -checkSafeImports :: DynFlags -> HscEnv -> TcGblEnv -> Hsc TcGblEnv -checkSafeImports dflags hsc_env tcg_env +-- The code for this is quite tricky as the whole algorithm is done in a few +-- distinct phases in different parts of the code base. See +-- RnNames.rnImportDecl for where package trust dependencies for a module are +-- collected and unioned. Specifically see the Note [RnNames . Tracking Trust +-- Transitively] and the Note [RnNames . Trust Own Package]. +checkSafeImports :: DynFlags -> TcGblEnv -> Hsc TcGblEnv +checkSafeImports dflags tcg_env = do -- We want to use the warning state specifically for detecting if safe -- inference has failed, so store and clear any existing warnings. @@ -941,7 +942,7 @@ checkSafeImports dflags hsc_env tcg_env clearWarnings logWarnings oldErrs - -- See the Note [ Safe Haskell Inference] + -- See the Note [Safe Haskell Inference] case (not $ isEmptyBag errs) of -- We have errors! @@ -953,7 +954,7 @@ checkSafeImports dflags hsc_env tcg_env -- All good matey! False -> do - when (packageTrustOn dflags) $ checkPkgTrust pkg_reqs + when (packageTrustOn dflags) $ checkPkgTrust dflags pkg_reqs -- add in trusted package requirements for this module let new_trust = emptyImportAvails { imp_trust_pkgs = catMaybes pkgs } return tcg_env { tcg_imports = imp_info `plusImportAvails` new_trust } @@ -981,41 +982,36 @@ checkSafeImports dflags hsc_env tcg_env (text $ "is imported both as a safe and unsafe import!")) | otherwise = return v1 + + -- easier interface to work with + checkSafe (_, _, False) = return Nothing + checkSafe (m, l, True ) = fst `fmap` hscCheckSafe' dflags m l - lookup' :: Module -> Hsc (Maybe ModIface) - lookup' m = do - hsc_eps <- liftIO $ hscEPS hsc_env - let pkgIfaceT = eps_PIT hsc_eps - homePkgT = hsc_HPT hsc_env - iface = lookupIfaceByModule dflags homePkgT pkgIfaceT m - return iface - - isHomePkg :: Module -> Bool - isHomePkg m - | thisPackage dflags == modulePackageId m = True - | otherwise = False - - -- | Check the package a module resides in is trusted. - -- Safe compiled modules are trusted without requiring - -- that their package is trusted. For trustworthy modules, - -- modules in the home package are trusted but otherwise - -- we check the package trust flag. - packageTrusted :: SafeHaskellMode -> Bool -> Module -> Bool - packageTrusted _ _ _ - | not (packageTrustOn dflags) = True - packageTrusted Sf_Safe False _ = True - packageTrusted Sf_SafeInfered False _ = True - packageTrusted _ _ m - | isHomePkg m = True - | otherwise = trusted $ getPackageDetails (pkgState dflags) - (modulePackageId m) - - -- Is a module trusted? Return Nothing if True, or a String - -- if it isn't, containing the reason it isn't. Also return - -- if the module trustworthy (true) or safe (false) so we know - -- if we should check if the package itself is trusted in the - -- future. - isModSafe :: Module -> SrcSpan -> Hsc (Bool) +-- | Check that a module is safe to import. +-- +-- We return True to indicate the import is safe and False otherwise +-- although in the False case an exception may be thrown first. +hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool +hscCheckSafe hsc_env m l = runHsc hsc_env $ do + dflags <- getDynFlags + pkgs <- snd `fmap` hscCheckSafe' dflags m l + when (packageTrustOn dflags) $ checkPkgTrust dflags pkgs + errs <- getWarnings + return $ isEmptyBag errs + +hscCheckSafe' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe PackageId, [PackageId]) +hscCheckSafe' dflags m l = do + (tw, pkgs) <- isModSafe m l + case tw of + False -> return (Nothing, pkgs) + True | isHomePkg m -> return (Nothing, pkgs) + | otherwise -> return (Just $ modulePackageId m, pkgs) + where + -- Is a module trusted? If not, throw or log errors depending on the type. + -- Return (regardless of trusted or not) if the trust type requires the + -- modules own package be trusted and a list of other packages required to + -- be trusted (these later ones haven't been checked) + isModSafe :: Module -> SrcSpan -> Hsc (Bool, [PackageId]) isModSafe m l = do iface <- lookup' m case iface of @@ -1032,11 +1028,14 @@ checkSafeImports dflags hsc_env tcg_env safeM = trust `elem` [Sf_SafeInfered, Sf_Safe, Sf_Trustworthy] -- check package is trusted safeP = packageTrusted trust trust_own_pkg m + -- pkg trust reqs + pkgRs = map fst $ filter snd $ dep_pkgs $ mi_deps iface' case (safeM, safeP) of -- General errors we throw but Safe errors we log - (True, True ) -> return $ trust == Sf_Trustworthy + (True, True ) -> return (trust == Sf_Trustworthy, pkgRs) (True, False) -> liftIO . throwIO $ pkgTrustErr - (False, _ ) -> logWarnings modTrustErr >> return (trust == Sf_Trustworthy) + (False, _ ) -> logWarnings modTrustErr >> + return (trust == Sf_Trustworthy, pkgRs) where pkgTrustErr = mkSrcErr $ unitBag $ mkPlainErrMsg l $ ppr m @@ -1047,30 +1046,60 @@ checkSafeImports dflags hsc_env tcg_env <+> text "can't be safely imported!" <+> text "The module itself isn't safe." - -- Here we check the transitive package trust requirements are OK still. - checkPkgTrust :: [PackageId] -> Hsc () - checkPkgTrust pkgs = - case errors of - [] -> return () - _ -> (liftIO . throwIO . mkSrcErr . listToBag) errors - where - errors = catMaybes $ map go pkgs - go pkg - | trusted $ getPackageDetails (pkgState dflags) pkg - = Nothing - | otherwise - = Just $ mkPlainErrMsg noSrcSpan - $ text "The package (" <> ppr pkg <> text ") is required" - <> text " to be trusted but it isn't!" - - checkSafe :: (Module, SrcSpan, IsSafeImport) -> Hsc (Maybe PackageId) - checkSafe (_, _, False) = return Nothing - checkSafe (m, l, True ) = do - tw <- isModSafe m l - return $ pkg tw - where pkg False = Nothing - pkg True | isHomePkg m = Nothing - | otherwise = Just (modulePackageId m) + -- | Check the package a module resides in is trusted. Safe compiled + -- modules are trusted without requiring that their package is trusted. For + -- trustworthy modules, modules in the home package are trusted but + -- otherwise we check the package trust flag. + packageTrusted :: SafeHaskellMode -> Bool -> Module -> Bool + packageTrusted _ _ _ + | not (packageTrustOn dflags) = True + packageTrusted Sf_Safe False _ = True + packageTrusted Sf_SafeInfered False _ = True + packageTrusted _ _ m + | isHomePkg m = True + | otherwise = trusted $ getPackageDetails (pkgState dflags) + (modulePackageId m) + + lookup' :: Module -> Hsc (Maybe ModIface) + lookup' m = do + hsc_env <- getHscEnv + hsc_eps <- liftIO $ hscEPS hsc_env + let pkgIfaceT = eps_PIT hsc_eps + homePkgT = hsc_HPT hsc_env + iface = lookupIfaceByModule dflags homePkgT pkgIfaceT m +#ifdef GHCI + -- the 'lookupIfaceByModule' method will always fail when calling from GHCi + -- as the compiler hasn't filled in the various module tables + -- so we need to call 'getModuleInterface' to load from disk + iface' <- case iface of + Just _ -> return iface + Nothing -> snd `fmap` (liftIO $ getModuleInterface hsc_env m) + return iface' +#else + return iface +#endif + + + isHomePkg :: Module -> Bool + isHomePkg m + | thisPackage dflags == modulePackageId m = True + | otherwise = False + +-- | Check the list of packages are trusted. +checkPkgTrust :: DynFlags -> [PackageId] -> Hsc () +checkPkgTrust dflags pkgs = + case errors of + [] -> return () + _ -> (liftIO . throwIO . mkSrcErr . listToBag) errors + where + errors = catMaybes $ map go pkgs + go pkg + | trusted $ getPackageDetails (pkgState dflags) pkg + = Nothing + | otherwise + = Just $ mkPlainErrMsg noSrcSpan + $ text "The package (" <> ppr pkg <> text ") is required" + <> text " to be trusted but it isn't!" -- | Set module to unsafe and wipe trust information. -- diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index b4cf6b8197..3439231aa6 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -6,17 +6,10 @@ -- -- ----------------------------------------------------------------------------- -{-# 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 InteractiveEval ( #ifdef GHCI RunResult(..), Status(..), Resume(..), History(..), - runStmt, runStmtWithLocation, runDecls, runDeclsWithLocation, + runStmt, runStmtWithLocation, runDecls, runDeclsWithLocation, parseImportDecl, SingleStep(..), resume, abandon, abandonAll, @@ -25,18 +18,18 @@ module InteractiveEval ( getModBreaks, getHistoryModule, back, forward, - setContext, getContext, + setContext, getContext, availsToGlobalRdrEnv, - getNamesInScope, - getRdrNamesInScope, - moduleIsInterpreted, - getInfo, - exprType, - typeKind, - parseName, - showModule, + getNamesInScope, + getRdrNamesInScope, + moduleIsInterpreted, + getInfo, + exprType, + typeKind, + parseName, + showModule, isModuleInterpreted, - compileExpr, dynCompileExpr, + compileExpr, dynCompileExpr, Term(..), obtainTermFromId, obtainTermFromVal, reconstructType #endif ) where @@ -51,7 +44,7 @@ import HsSyn import HscTypes import InstEnv import Type hiding( typeKind ) -import TcType hiding( typeKind ) +import TcType hiding( typeKind ) import Var import Id import Name hiding ( varName ) @@ -98,7 +91,7 @@ import System.IO.Unsafe -- running a statement interactively data RunResult - = RunOk [Name] -- ^ names bound by this evaluation + = RunOk [Name] -- ^ names bound by this evaluation | RunException SomeException -- ^ statement raised an exception | RunBreak ThreadId [Name] (Maybe BreakInfo) @@ -112,13 +105,13 @@ data Resume = Resume { resumeStmt :: String, -- the original statement resumeThreadId :: ThreadId, -- thread running the computation - resumeBreakMVar :: MVar (), + resumeBreakMVar :: MVar (), resumeStatMVar :: MVar Status, resumeBindings :: ([TyThing], GlobalRdrEnv), resumeFinalIds :: [Id], -- [Id] to bind on completion resumeApStack :: HValue, -- The object from which we can get -- value of the free variables. - resumeBreakInfo :: Maybe BreakInfo, + resumeBreakInfo :: Maybe BreakInfo, -- the breakpoint we stopped at -- (Nothing <=> exception) resumeSpan :: SrcSpan, -- just a cache, otherwise it's a pain @@ -191,8 +184,8 @@ runStmt = runStmtWithLocation "<interactive>" 1 -- | Run a statement in the current interactive context. Passing debug information -- Statement may bind multple values. -runStmtWithLocation :: GhcMonad m => String -> Int -> - String -> SingleStep -> m RunResult +runStmtWithLocation :: GhcMonad m => String -> Int -> + String -> SingleStep -> m RunResult runStmtWithLocation source linenumber expr step = do hsc_env <- getSession @@ -216,7 +209,7 @@ runStmtWithLocation source linenumber expr step = withBreakAction (isStep step) dflags' breakMVar statusMVar $ do let thing_to_run = unsafeCoerce# hval :: IO [HValue] liftIO $ sandboxIO dflags' statusMVar thing_to_run - + let ic = hsc_IC hsc_env bindings = (ic_tythings ic, ic_rn_gbl_env ic) @@ -242,7 +235,7 @@ runDeclsWithLocation source linenumber expr = hsc_env' = hsc_env{ hsc_dflags = dflags' } (tyThings, ic) <- liftIO $ hscDeclsWithLocation hsc_env' expr source linenumber - + setSession $ hsc_env { hsc_IC = ic } hsc_env <- getSession hsc_env' <- liftIO $ rttiEnvironment hsc_env @@ -257,7 +250,7 @@ withVirtualCWD m = do let set_cwd = do dir <- liftIO $ getCurrentDirectory - case ic_cwd ic of + case ic_cwd ic of Just dir -> liftIO $ setCurrentDirectory dir Nothing -> return () return dir @@ -283,7 +276,7 @@ handleRunStatus :: GhcMonad m => -> m RunResult handleRunStatus expr bindings final_ids breakMVar statusMVar status history = - case status of + case status of -- did we hit a breakpoint or did we complete? (Break is_exception apStack info tid) -> do hsc_env <- getSession @@ -293,9 +286,9 @@ handleRunStatus expr bindings final_ids breakMVar statusMVar status mb_info let resume = Resume { resumeStmt = expr, resumeThreadId = tid - , resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar + , resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar , resumeBindings = bindings, resumeFinalIds = final_ids - , resumeApStack = apStack, resumeBreakInfo = mb_info + , resumeApStack = apStack, resumeBreakInfo = mb_info , resumeSpan = span, resumeHistory = toListBL history , resumeHistoryIx = 0 } hsc_env2 = pushResume hsc_env1 resume @@ -303,9 +296,9 @@ handleRunStatus expr bindings final_ids breakMVar statusMVar status modifySession (\_ -> hsc_env2) return (RunBreak tid names mb_info) (Complete either_hvals) -> - case either_hvals of - Left e -> return (RunException e) - Right hvals -> do + case either_hvals of + Left e -> return (RunException e) + Right hvals -> do hsc_env <- getSession let final_ic = extendInteractiveContext (hsc_IC hsc_env) (map AnId final_ids) @@ -369,8 +362,8 @@ resetStepFlag :: IO () resetStepFlag = poke stepFlag 0 -- this points to the IO action that is executed when a breakpoint is hit -foreign import ccall "&rts_breakpoint_io_action" - breakPointIOAction :: Ptr (StablePtr (Bool -> BreakInfo -> HValue -> IO ())) +foreign import ccall "&rts_breakpoint_io_action" + breakPointIOAction :: Ptr (StablePtr (Bool -> BreakInfo -> HValue -> IO ())) -- When running a computation, we redirect ^C exceptions to the running -- thread. ToDo: we might want a way to continue even if the target @@ -407,7 +400,7 @@ sandboxIO dflags statusMVar thing = rethrow :: DynFlags -> IO a -> IO a rethrow dflags io = Exception.catch io $ \se -> do -- If -fbreak-on-error, we break unconditionally, - -- but with care of not breaking twice + -- but with care of not breaking twice if dopt Opt_BreakOnError dflags && not (dopt Opt_BreakOnException dflags) then poke exceptionFlag 1 @@ -481,28 +474,28 @@ resume canLogSpan step ic_rn_gbl_env = resume_rdr_env, ic_resume = rs } modifySession (\_ -> hsc_env{ hsc_IC = ic' }) - - -- remove any bindings created since the breakpoint from the + + -- remove any bindings created since the breakpoint from the -- linker's environment let new_names = map getName (filter (`notElem` resume_tmp_te) (ic_tythings ic)) liftIO $ Linker.deleteFromLinkEnv new_names - + when (isStep step) $ liftIO setStepFlag - case r of + case r of Resume { resumeStmt = expr, resumeThreadId = tid , resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar , resumeBindings = bindings, resumeFinalIds = final_ids , resumeApStack = apStack, resumeBreakInfo = info, resumeSpan = span , resumeHistory = hist } -> do withVirtualCWD $ do - withBreakAction (isStep step) (hsc_dflags hsc_env) + withBreakAction (isStep step) (hsc_dflags hsc_env) breakMVar statusMVar $ do status <- liftIO $ withInterruptsSentTo tid $ do putMVar breakMVar () -- this awakens the stopped thread... takeMVar statusMVar - -- and wait for the result + -- and wait for the result let prevHistoryLst = fromListBL 50 hist hist' = case info of Nothing -> prevHistoryLst @@ -511,7 +504,7 @@ resume canLogSpan step | otherwise -> mkHistory hsc_env apStack i `consBL` fromListBL 50 hist case step of - RunAndLogSteps -> + RunAndLogSteps -> traceRunStatus expr bindings final_ids breakMVar statusMVar status hist' _other -> @@ -543,23 +536,23 @@ moveHist fn = do update_ic apStack mb_info = do (hsc_env1, names, span) <- liftIO $ bindLocalsAtBreakpoint hsc_env apStack mb_info - let ic = hsc_IC hsc_env1 + let ic = hsc_IC hsc_env1 r' = r { resumeHistoryIx = new_ix } ic' = ic { ic_resume = r':rs } - + modifySession (\_ -> hsc_env1{ hsc_IC = ic' }) - + return (names, new_ix, span) -- careful: we want apStack to be the AP_STACK itself, not a thunk -- around it, hence the cases are carefully constructed below to -- make this the case. ToDo: this is v. fragile, do something better. if new_ix == 0 - then case r of - Resume { resumeApStack = apStack, + then case r of + Resume { resumeApStack = apStack, resumeBreakInfo = mb_info } -> update_ic apStack mb_info - else case history !! (new_ix - 1) of + else case history !! (new_ix - 1) of History apStack info _ -> update_ic apStack (Just info) @@ -598,9 +591,9 @@ bindLocalsAtBreakpoint hsc_env apStack Nothing = do -- of the breakpoint and the free variables of the expression. bindLocalsAtBreakpoint hsc_env apStack (Just info) = do - let + let mod_name = moduleName (breakInfo_module info) - hmi = expectJust "bindLocalsAtBreakpoint" $ + hmi = expectJust "bindLocalsAtBreakpoint" $ lookupUFM (hsc_HPT hsc_env) mod_name breaks = getModBreaks hmi index = breakInfo_number info @@ -628,7 +621,7 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do let filtered_ids = [ id | (id, Just _hv) <- zip ids mb_hValues ] when (any isNothing mb_hValues) $ debugTraceMsg (hsc_dflags hsc_env) 1 $ - text "Warning: _result has been evaluated, some bindings have been lost" + text "Warning: _result has been evaluated, some bindings have been lost" us <- mkSplitUniqSupply 'I' let (us1, us2) = splitUniqSupply us @@ -683,10 +676,10 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do | (tv, uniq) <- varSetElems tvs `zip` uniqsFromSupply us , let name = setNameUnique (tyVarName tv) uniq ] -rttiEnvironment :: HscEnv -> IO HscEnv +rttiEnvironment :: HscEnv -> IO HscEnv rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do let tmp_ids = [id | AnId id <- ic_tythings ic] - incompletelyTypedIds = + incompletelyTypedIds = [id | id <- tmp_ids , not $ noSkolems id , (occNameFS.nameOccName.idName) id /= result_fs] @@ -744,7 +737,7 @@ abandon = do resume = ic_resume ic case resume of [] -> return False - r:rs -> do + r:rs -> do modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = rs } } liftIO $ abandon_ r return True @@ -756,13 +749,13 @@ abandonAll = do resume = ic_resume ic case resume of [] -> return False - rs -> do + rs -> do modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = [] } } liftIO $ mapM_ abandon_ rs return True --- when abandoning a computation we have to --- (a) kill the thread with an async exception, so that the +-- when abandoning a computation we have to +-- (a) kill the thread with an async exception, so that the -- computation itself is stopped, and -- (b) fill in the MVar. This step is necessary because any -- thunks that were under evaluation will now be updated @@ -773,7 +766,7 @@ abandonAll = do abandon_ :: Resume -> IO () abandon_ r = do killThread (resumeThreadId r) - putMVar (resumeBreakMVar r) () + putMVar (resumeBreakMVar r) () -- ----------------------------------------------------------------------------- -- Bounded list, optimised for repeated cons @@ -821,7 +814,7 @@ findGlobalRdrEnv :: HscEnv -> [InteractiveImport] -> IO GlobalRdrEnv -- Compute the GlobalRdrEnv for the interactive context findGlobalRdrEnv hsc_env imports = do { idecls_env <- hscRnImportDecls hsc_env idecls - -- This call also loads any orphan modules + -- This call also loads any orphan modules ; imods_env <- mapM (mkTopLevEnv (hsc_HPT hsc_env)) imods ; return (foldr plusGlobalRdrEnv idecls_env imods_env) } where @@ -838,21 +831,21 @@ availsToGlobalRdrEnv mod_name avails -- We're building a GlobalRdrEnv as if the user imported -- all the specified modules into the global interactive module imp_prov = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}] - decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name, - is_qual = False, - is_dloc = srcLocSpan interactiveSrcLoc } + decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name, + is_qual = False, + is_dloc = srcLocSpan interactiveSrcLoc } mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv mkTopLevEnv hpt modl = case lookupUFM hpt (moduleName modl) of - Nothing -> ghcError (ProgramError ("mkTopLevEnv: not a home module " ++ + Nothing -> ghcError (ProgramError ("mkTopLevEnv: not a home module " ++ showSDoc (ppr modl))) Just details -> - case mi_globals (hm_iface details) of - Nothing -> - ghcError (ProgramError ("mkTopLevEnv: not interpreted " - ++ showSDoc (ppr modl))) - Just env -> return env + case mi_globals (hm_iface details) of + Nothing -> + ghcError (ProgramError ("mkTopLevEnv: not interpreted " + ++ showSDoc (ppr modl))) + Just env -> return env -- | Get the interactive evaluation context, consisting of a pair of the -- set of modules from which we take the full top-level scope, and the set @@ -872,10 +865,10 @@ moduleIsInterpreted modl = withSession $ \h -> _not_a_home_module -> return False -- | Looks up an identifier in the current interactive context (for :info) --- Filter the instances by the ones whose tycons (or clases resp) +-- Filter the instances by the ones whose tycons (or clases resp) -- are in scope (qualified or otherwise). Otherwise we list a whole lot too many! -- The exact choice of which ones to show, and which to hide, is a judgement call. --- (see Trac #1581) +-- (see Trac #1581) getInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[Instance])) getInfo name = withSession $ \hsc_env -> @@ -886,15 +879,15 @@ getInfo name let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env) return (Just (thing, fixity, filter (plausible rdr_env) ispecs)) where - plausible rdr_env ispec -- Dfun involving only names that are in ic_rn_glb_env - = all ok $ nameSetToList $ orphNamesOfType $ idType $ instanceDFunId ispec - where -- A name is ok if it's in the rdr_env, - -- whether qualified or not - ok n | n == name = True -- The one we looked for in the first place! - | isBuiltInSyntax n = True - | isExternalName n = any ((== n) . gre_name) - (lookupGRE_Name rdr_env n) - | otherwise = True + plausible rdr_env ispec -- Dfun involving only names that are in ic_rn_glb_env + = all ok $ nameSetToList $ orphNamesOfType $ idType $ instanceDFunId ispec + where -- A name is ok if it's in the rdr_env, + -- whether qualified or not + ok n | n == name = True -- The one we looked for in the first place! + | isBuiltInSyntax n = True + | isExternalName n = any ((== n) . gre_name) + (lookupGRE_Name rdr_env n) + | otherwise = True -- | Returns all names in scope in the current interactive context getNamesInScope :: GhcMonad m => m [Name] @@ -903,7 +896,7 @@ getNamesInScope = withSession $ \hsc_env -> do getRdrNamesInScope :: GhcMonad m => m [RdrName] getRdrNamesInScope = withSession $ \hsc_env -> do - let + let ic = hsc_IC hsc_env gbl_rdrenv = ic_rn_gbl_env ic gbl_names = concatMap greToRdrNames $ globalRdrEnvElts gbl_rdrenv @@ -920,9 +913,9 @@ greToRdrNames GRE{ gre_name = name, gre_prov = prov } occ = nameOccName name unqual = Unqual occ do_spec decl_spec - | is_qual decl_spec = [qual] - | otherwise = [unqual,qual] - where qual = Qual (is_as decl_spec) occ + | is_qual decl_spec = [qual] + | otherwise = [unqual,qual] + where qual = Qual (is_as decl_spec) occ -- | Parses a string as an identifier, and returns the list of 'Name's that -- the identifier can refer to in the current interactive context. @@ -954,12 +947,12 @@ typeKind normalise str = withSession $ \hsc_env -> do compileExpr :: GhcMonad m => String -> m HValue compileExpr expr = withSession $ \hsc_env -> do Just (ids, hval) <- liftIO $ hscStmt hsc_env ("let __cmCompileExpr = "++expr) - -- Run it! + -- Run it! hvals <- liftIO (unsafeCoerce# hval :: IO [HValue]) case (ids,hvals) of ([_],[hv]) -> return hv - _ -> panic "compileExpr" + _ -> panic "compileExpr" -- ----------------------------------------------------------------------------- -- Compile an expression into a dynamic @@ -979,7 +972,7 @@ dynCompileExpr expr = do } setContext (IIDecl importDecl : iis) let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")" - Just (ids, hvals) <- withSession $ \hsc_env -> + Just (ids, hvals) <- withSession $ \hsc_env -> liftIO $ hscStmt hsc_env stmt setContext iis vals <- liftIO (unsafeCoerce# hvals :: IO [Dynamic]) @@ -999,10 +992,10 @@ showModule mod_summary = isModuleInterpreted :: GhcMonad m => ModSummary -> m Bool isModuleInterpreted mod_summary = withSession $ \hsc_env -> case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of - Nothing -> panic "missing linkable" - Just mod_info -> return (not obj_linkable) - where - obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info)) + Nothing -> panic "missing linkable" + Just mod_info -> return (not obj_linkable) + where + obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info)) ---------------------------------------------------------------------------- -- RTTI primitives @@ -1019,7 +1012,7 @@ obtainTermFromId hsc_env bound force id = do -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type) reconstructType hsc_env bound id = do - hv <- Linker.getHValue hsc_env (varName id) + hv <- Linker.getHValue hsc_env (varName id) cvReconstructType hsc_env bound (idType id) hv mkRuntimeUnkTyVar :: Name -> Kind -> TyVar diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index bdb411e5f4..f56238fd12 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -843,8 +843,8 @@ instance Monad CmmOptM where addImportCmmOpt :: CLabel -> CmmOptM () addImportCmmOpt lbl = CmmOptM $ \(imports, _dflags) -> (# (), lbl:imports #) -getDynFlagsCmmOpt :: CmmOptM DynFlags -getDynFlagsCmmOpt = CmmOptM $ \(imports, dflags) -> (# dflags, imports #) +instance HasDynFlags CmmOptM where + getDynFlags = CmmOptM $ \(imports, dflags) -> (# dflags, imports #) runCmmOpt :: DynFlags -> CmmOptM a -> (a, [CLabel]) runCmmOpt dflags (CmmOptM f) = case f ([], dflags) of @@ -895,7 +895,7 @@ cmmStmtConFold stmt CmmCondBranch test dest -> do test' <- cmmExprConFold DataReference test - dflags <- getDynFlagsCmmOpt + dflags <- getDynFlags let platform = targetPlatform dflags return $ case test' of CmmLit (CmmInt 0 _) -> @@ -914,7 +914,7 @@ cmmStmtConFold stmt cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr cmmExprConFold referenceKind expr = do - dflags <- getDynFlagsCmmOpt + dflags <- getDynFlags -- Skip constant folding if new code generator is running -- (this optimization is done in Hoopl) let expr' = if dopt Opt_TryNewCodeGen dflags @@ -932,7 +932,7 @@ cmmExprCon _ other = other -- of things to do. cmmExprNative :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr cmmExprNative referenceKind expr = do - dflags <- getDynFlagsCmmOpt + dflags <- getDynFlags let platform = targetPlatform dflags arch = platformArch platform case expr of diff --git a/compiler/nativeGen/NCGMonad.hs b/compiler/nativeGen/NCGMonad.hs index 71250a2452..eb59d2b82a 100644 --- a/compiler/nativeGen/NCGMonad.hs +++ b/compiler/nativeGen/NCGMonad.hs @@ -29,7 +29,7 @@ module NCGMonad ( getNewRegPairNat, getPicBaseMaybeNat, getPicBaseNat, - getDynFlagsNat + getDynFlags ) where @@ -100,11 +100,9 @@ getUniqueNat = NatM $ \ (NatM_State us delta imports pic dflags) -> case takeUniqFromSupply us of (uniq, us') -> (uniq, (NatM_State us' delta imports pic dflags)) - -getDynFlagsNat :: NatM DynFlags -getDynFlagsNat - = NatM $ \ (NatM_State us delta imports pic dflags) -> - (dflags, (NatM_State us delta imports pic dflags)) +instance HasDynFlags NatM where + getDynFlags = NatM $ \ (NatM_State us delta imports pic dflags) -> + (dflags, (NatM_State us delta imports pic dflags)) getDeltaNat :: NatM Int @@ -139,14 +137,14 @@ getNewLabelNat getNewRegNat :: Size -> NatM Reg getNewRegNat rep = do u <- getUniqueNat - dflags <- getDynFlagsNat + dflags <- getDynFlags return (RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep) getNewRegPairNat :: Size -> NatM (Reg,Reg) getNewRegPairNat rep = do u <- getUniqueNat - dflags <- getDynFlagsNat + dflags <- getDynFlags let vLo = targetMkVirtualReg (targetPlatform dflags) u rep let lo = RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep let hi = RegVirtual $ getHiVirtualRegFromLo vLo diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index a043af01f8..2fd11bc35a 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -73,7 +73,7 @@ cmmTopCodeGen cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks picBaseMb <- getPicBaseMaybeNat - dflags <- getDynFlagsNat + dflags <- getDynFlags let proc = CmmProc info lab (ListGraph $ concat nat_blocks) tops = proc : concat statics os = platformOS $ targetPlatform dflags @@ -114,7 +114,7 @@ stmtsToInstrs stmts stmtToInstrs :: CmmStmt -> NatM InstrBlock stmtToInstrs stmt = do - dflags <- getDynFlagsNat + dflags <- getDynFlags case stmt of CmmNop -> return nilOL CmmComment s -> return (unitOL (COMMENT s)) @@ -357,13 +357,13 @@ iselExpr64 (CmmMachOp (MO_UU_Conv W32 W64) [expr]) = do return $ ChildCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi) rlo iselExpr64 expr - = do dflags <- getDynFlagsNat + = do dflags <- getDynFlags pprPanic "iselExpr64(powerpc)" (pprPlatform (targetPlatform dflags) expr) getRegister :: CmmExpr -> NatM Register -getRegister e = do dflags <- getDynFlagsNat +getRegister e = do dflags <- getDynFlags getRegister' dflags e getRegister' :: DynFlags -> CmmExpr -> NatM Register @@ -555,7 +555,7 @@ getRegister' _ (CmmLit (CmmInt i rep)) getRegister' _ (CmmLit (CmmFloat f frep)) = do lbl <- getNewLabelNat - dflags <- getDynFlagsNat + dflags <- getDynFlags dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl Amode addr addr_code <- getAmode dynRef let size = floatSize frep @@ -845,7 +845,7 @@ genCCall :: CmmCallTarget -- function to call -> [HintedCmmActual] -- arguments (of mixed type) -> NatM InstrBlock genCCall target dest_regs argsAndHints - = do dflags <- getDynFlagsNat + = do dflags <- getDynFlags case platformOS (targetPlatform dflags) of OSLinux -> genCCall' GCPLinux target dest_regs argsAndHints OSDarwin -> genCCall' GCPDarwin target dest_regs argsAndHints @@ -1098,7 +1098,7 @@ genCCall' gcp target dest_regs argsAndHints outOfLineMachOp mop = do - dflags <- getDynFlagsNat + dflags <- getDynFlags mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference $ mkForeignLabel functionName Nothing ForeignLabelInThisPackage IsFunction let mopLabelOrExpr = case mopExpr of @@ -1162,7 +1162,7 @@ genSwitch expr ids (reg,e_code) <- getSomeReg expr tmp <- getNewRegNat II32 lbl <- getNewLabelNat - dflags <- getDynFlagsNat + dflags <- getDynFlags dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl (tableReg,t_code) <- getSomeReg $ dynRef let code = e_code `appOL` t_code `appOL` toOL [ @@ -1364,7 +1364,7 @@ coerceInt2FP fromRep toRep x = do lbl <- getNewLabelNat itmp <- getNewRegNat II32 ftmp <- getNewRegNat FF64 - dflags <- getDynFlagsNat + dflags <- getDynFlags dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl Amode addr addr_code <- getAmode dynRef let diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs index 663b95b236..ff1e9f2eb2 100644 --- a/compiler/nativeGen/SPARC/CodeGen.hs +++ b/compiler/nativeGen/SPARC/CodeGen.hs @@ -63,7 +63,7 @@ cmmTopCodeGen :: RawCmmDecl cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do - dflags <- getDynFlagsNat + dflags <- getDynFlags let platform = targetPlatform dflags (nat_blocks,statics) <- mapAndUnzipM (basicBlockCodeGen platform) blocks diff --git a/compiler/nativeGen/SPARC/CodeGen/CCall.hs b/compiler/nativeGen/SPARC/CodeGen/CCall.hs index 48c766f8e0..91351a2e18 100644 --- a/compiler/nativeGen/SPARC/CodeGen/CCall.hs +++ b/compiler/nativeGen/SPARC/CodeGen/CCall.hs @@ -141,7 +141,7 @@ genCCall target dest_regs argsAndHints let transfer_code = toOL (move_final vregs allArgRegs extraStackArgsHere) - dflags <- getDynFlagsNat + dflags <- getDynFlags return $ argcode `appOL` move_sp_down `appOL` @@ -276,7 +276,7 @@ outOfLineMachOp mop = do let functionName = outOfLineMachOp_table mop - dflags <- getDynFlagsNat + dflags <- getDynFlags mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference $ mkForeignLabel functionName Nothing ForeignLabelInExternalPackage IsFunction diff --git a/compiler/nativeGen/SPARC/CodeGen/CondCode.hs b/compiler/nativeGen/SPARC/CodeGen/CondCode.hs index 215a565ba6..f02b7a45a8 100644 --- a/compiler/nativeGen/SPARC/CodeGen/CondCode.hs +++ b/compiler/nativeGen/SPARC/CodeGen/CondCode.hs @@ -62,10 +62,10 @@ getCondCode (CmmMachOp mop [x, y]) MO_U_Lt _ -> condIntCode LU x y MO_U_Le _ -> condIntCode LEU x y - _ -> do dflags <- getDynFlagsNat + _ -> do dflags <- getDynFlags pprPanic "SPARC.CodeGen.CondCode.getCondCode" (pprPlatform (targetPlatform dflags) (CmmMachOp mop [x,y])) -getCondCode other = do dflags <- getDynFlagsNat +getCondCode other = do dflags <- getDynFlags pprPanic "SPARC.CodeGen.CondCode.getCondCode" (pprPlatform (targetPlatform dflags) other) diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen64.hs b/compiler/nativeGen/SPARC/CodeGen/Gen64.hs index 5bcab2cb10..5352281296 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Gen64.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Gen64.hs @@ -190,7 +190,7 @@ iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) -- compute expr and load it into r_dst_lo (a_reg, a_code) <- getSomeReg expr - dflags <- getDynFlagsNat + dflags <- getDynFlags let platform = targetPlatform dflags code = a_code `appOL` toOL @@ -201,7 +201,7 @@ iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) iselExpr64 expr - = do dflags <- getDynFlagsNat + = do dflags <- getDynFlags pprPanic "iselExpr64(sparc)" (pprPlatform (targetPlatform dflags) expr) diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index 5f0f716281..2ade04d36f 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -63,12 +63,12 @@ import Data.Word is32BitPlatform :: NatM Bool is32BitPlatform = do - dflags <- getDynFlagsNat + dflags <- getDynFlags return $ target32Bit (targetPlatform dflags) sse2Enabled :: NatM Bool sse2Enabled = do - dflags <- getDynFlagsNat + dflags <- getDynFlags case platformArch (targetPlatform dflags) of ArchX86_64 -> -- SSE2 is fixed on for x86_64. It would be -- possible to make it optional, but we'd need to @@ -81,7 +81,7 @@ sse2Enabled = do sse4_2Enabled :: NatM Bool sse4_2Enabled = do - dflags <- getDynFlagsNat + dflags <- getDynFlags return (dopt Opt_SSE4_2 dflags) if_sse2 :: NatM a -> NatM a -> NatM a @@ -96,7 +96,7 @@ cmmTopCodeGen cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks picBaseMb <- getPicBaseMaybeNat - dflags <- getDynFlagsNat + dflags <- getDynFlags let proc = CmmProc info lab (ListGraph $ concat nat_blocks) tops = proc : concat statics os = platformOS $ targetPlatform dflags @@ -400,7 +400,7 @@ iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) = do ) iselExpr64 expr - = do dflags <- getDynFlagsNat + = do dflags <- getDynFlags pprPanic "iselExpr64(i386)" (pprPlatform (targetPlatform dflags) expr) @@ -887,7 +887,7 @@ getRegister' _ (CmmLit lit) in return (Any size code) -getRegister' _ other = do dflags <- getDynFlagsNat +getRegister' _ other = do dflags <- getDynFlags pprPanic "getRegister(x86)" (pprPlatform (targetPlatform dflags) other) @@ -1131,7 +1131,7 @@ isOperand _ _ = False memConstant :: Int -> CmmLit -> NatM Amode memConstant align lit = do lbl <- getNewLabelNat - dflags <- getDynFlagsNat + dflags <- getDynFlags (addr, addr_code) <- if target32Bit (targetPlatform dflags) then do dynRef <- cmmMakeDynamicReference dflags @@ -1228,10 +1228,10 @@ getCondCode (CmmMachOp mop [x, y]) MO_U_Lt _ -> condIntCode LU x y MO_U_Le _ -> condIntCode LEU x y - _other -> do dflags <- getDynFlagsNat + _other -> do dflags <- getDynFlags pprPanic "getCondCode(x86,x86_64,sparc)" (pprPlatform (targetPlatform dflags) (CmmMachOp mop [x,y])) -getCondCode other = do dflags <- getDynFlagsNat +getCondCode other = do dflags <- getDynFlags pprPanic "getCondCode(2)(x86,sparc)" (pprPlatform (targetPlatform dflags) other) @@ -1621,7 +1621,7 @@ genCCall is32Bit (CmmPrim (MO_PopCnt width)) dest_regs@[CmmHinted dst _] unitOL (POPCNT size (OpReg src_r) (getRegisterReg False (CmmLocal dst)))) else do - dflags <- getDynFlagsNat + dflags <- getDynFlags targetExpr <- cmmMakeDynamicReference dflags addImportNat CallReference lbl let target = CmmCallee targetExpr CCallConv @@ -1959,7 +1959,7 @@ genCCall64 target dest_regs args = (arg_reg, arg_code) <- getSomeReg arg delta <- getDeltaNat setDeltaNat (delta-arg_size) - dflags <- getDynFlagsNat + dflags <- getDynFlags let platform = targetPlatform dflags code' = code `appOL` arg_code `appOL` toOL [ SUB (intSize wordWidth) (OpImm (ImmInt arg_size)) (OpReg rsp) , @@ -1992,7 +1992,7 @@ maxInlineSizeThreshold = 128 outOfLineCmmOp :: CallishMachOp -> Maybe HintedCmmFormal -> [HintedCmmActual] -> NatM InstrBlock outOfLineCmmOp mop res args = do - dflags <- getDynFlagsNat + dflags <- getDynFlags targetExpr <- cmmMakeDynamicReference dflags addImportNat CallReference lbl let target = CmmCallee targetExpr CCallConv @@ -2063,7 +2063,7 @@ genSwitch expr ids = do (reg,e_code) <- getSomeReg expr lbl <- getNewLabelNat - dflags <- getDynFlagsNat + dflags <- getDynFlags dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl (tableReg,t_code) <- getSomeReg $ dynRef let op = OpAddr (AddrBaseIndex (EABaseReg tableReg) diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index f235465758..21984eced9 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -1562,8 +1562,8 @@ failSpanMsgP span msg = P $ \_ -> PFailed span msg getPState :: P PState getPState = P $ \s -> POk s s -getDynFlags :: P DynFlags -getDynFlags = P $ \s -> POk s (dflags s) +instance HasDynFlags P where + getDynFlags = P $ \s -> POk s (dflags s) withThisPackage :: (PackageId -> a) -> P a withThisPackage f diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 33ddd28c8c..6e75793962 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -35,7 +35,7 @@ import RdrName import TcEvidence ( emptyTcEvBinds ) import TysPrim ( liftedTypeKindTyConName, eqPrimTyCon ) import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataCon, - unboxedSingletonTyCon, unboxedSingletonDataCon, + unboxedUnitTyCon, unboxedUnitDataCon, listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR, eqTyCon_RDR ) import Type ( funTyCon ) import ForeignCall ( Safety(..), CExportSpec(..), CLabelString, @@ -1047,20 +1047,22 @@ btype :: { LHsType RdrName } | atype { $1 } atype :: { LHsType RdrName } - : gtycon { L1 (HsTyVar (unLoc $1)) } - | tyvar { L1 (HsTyVar (unLoc $1)) } - | strict_mark atype { LL (HsBangTy (unLoc $1) $2) } -- Constructor sigs only - | '{' fielddecls '}' {% checkRecordSyntax (LL $ HsRecTy $2) } -- Constructor sigs only - | '(' ctype ',' comma_types1 ')' { LL $ HsTupleTy HsBoxedOrConstraintTuple ($2:$4) } - | '(#' comma_types1 '#)' { LL $ HsTupleTy HsUnboxedTuple $2 } - | '[' ctype ']' { LL $ HsListTy $2 } - | '[:' ctype ':]' { LL $ HsPArrTy $2 } - | '(' ctype ')' { LL $ HsParTy $2 } - | '(' ctype '::' kind ')' { LL $ HsKindSig $2 $4 } - | quasiquote { L1 (HsQuasiQuoteTy (unLoc $1)) } - | '$(' exp ')' { LL $ mkHsSpliceTy $2 } - | TH_ID_SPLICE { LL $ mkHsSpliceTy $ L1 $ HsVar $ - mkUnqual varName (getTH_ID_SPLICE $1) } + : ntgtycon { L1 (HsTyVar (unLoc $1)) } -- Not including unit tuples + | tyvar { L1 (HsTyVar (unLoc $1)) } -- (See Note [Unit tuples]) + | strict_mark atype { LL (HsBangTy (unLoc $1) $2) } -- Constructor sigs only + | '{' fielddecls '}' {% checkRecordSyntax (LL $ HsRecTy $2) } -- Constructor sigs only + | '(' ')' { LL $ HsTupleTy HsBoxedOrConstraintTuple [] } + | '(' ctype ',' comma_types1 ')' { LL $ HsTupleTy HsBoxedOrConstraintTuple ($2:$4) } + | '(#' '#)' { LL $ HsTupleTy HsUnboxedTuple [] } + | '(#' comma_types1 '#)' { LL $ HsTupleTy HsUnboxedTuple $2 } + | '[' ctype ']' { LL $ HsListTy $2 } + | '[:' ctype ':]' { LL $ HsPArrTy $2 } + | '(' ctype ')' { LL $ HsParTy $2 } + | '(' ctype '::' kind ')' { LL $ HsKindSig $2 $4 } + | quasiquote { L1 (HsQuasiQuoteTy (unLoc $1)) } + | '$(' exp ')' { LL $ mkHsSpliceTy $2 } + | TH_ID_SPLICE { LL $ mkHsSpliceTy $ L1 $ HsVar $ + mkUnqual varName (getTH_ID_SPLICE $1) } -- see Note [Promotion] for the followings | SIMPLEQUOTE qconid { LL $ HsTyVar $ unLoc $2 } | SIMPLEQUOTE '(' ')' { LL $ HsTyVar $ getRdrName unitDataCon } @@ -1780,7 +1782,7 @@ con_list : con { L1 [$1] } sysdcon :: { Located DataCon } -- Wired in data constructors : '(' ')' { LL unitDataCon } | '(' commas ')' { LL $ tupleCon BoxedTuple ($2 + 1) } - | '(#' '#)' { LL $ unboxedSingletonDataCon } + | '(#' '#)' { LL $ unboxedUnitDataCon } | '(#' commas '#)' { LL $ tupleCon UnboxedTuple ($2 + 1) } | '[' ']' { LL nilDataCon } @@ -1792,24 +1794,31 @@ qconop :: { Located RdrName } : qconsym { $1 } | '`' qconid '`' { LL (unLoc $2) } ------------------------------------------------------------------------------ +---------------------------------------------------------------------------- -- Type constructors -gtycon :: { Located RdrName } -- A "general" qualified tycon - : oqtycon { $1 } + +-- See Note [Unit tuples] in HsTypes for the distinction +-- between gtycon and ntgtycon +gtycon :: { Located RdrName } -- A "general" qualified tycon, including unit tuples + : ntgtycon { $1 } | '(' ')' { LL $ getRdrName unitTyCon } + | '(#' '#)' { LL $ getRdrName unboxedUnitTyCon } + +ntgtycon :: { Located RdrName } -- A "general" qualified tycon, excluding unit tuples + : oqtycon { $1 } | '(' commas ')' { LL $ getRdrName (tupleTyCon BoxedTuple ($2 + 1)) } - | '(#' '#)' { LL $ getRdrName unboxedSingletonTyCon } | '(#' commas '#)' { LL $ getRdrName (tupleTyCon UnboxedTuple ($2 + 1)) } | '(' '->' ')' { LL $ getRdrName funTyCon } | '[' ']' { LL $ listTyCon_RDR } | '[:' ':]' { LL $ parrTyCon_RDR } | '(' '~#' ')' { LL $ getRdrName eqPrimTyCon } -oqtycon :: { Located RdrName } -- An "ordinary" qualified tycon +oqtycon :: { Located RdrName } -- An "ordinary" qualified tycon; + -- These can appear in export lists : qtycon { $1 } | '(' qtyconsym ')' { LL (unLoc $2) } - | '(' '~' ')' { LL $ eqTyCon_RDR } -- In here rather than gtycon because I want to write it in the GHC.Types export list + | '(' '~' ')' { LL $ eqTyCon_RDR } qtyconop :: { Located RdrName } -- Qualified or unqualified : qtyconsym { $1 } diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 30f5a47c74..928eb03647 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -56,7 +56,7 @@ import BasicTypes ( maxPrecedence, Activation(..), RuleMatchInfo, InlinePragma(..), InlineSpec(..) ) import TcEvidence ( idHsWrapper ) import Lexer -import TysWiredIn ( unitTyCon ) +import TysWiredIn ( unitTyCon, unitDataCon ) import ForeignCall import OccName ( srcDataName, varName, isDataOcc, isTcOcc, occNameString ) @@ -361,10 +361,12 @@ splitCon :: LHsType RdrName splitCon ty = split ty [] where - split (L _ (HsAppTy t u)) ts = split t (u : ts) - split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc - return (data_con, mk_rest ts) - split (L l _) _ = parseErrorSDoc l (text "parse error in constructor in data/newtype declaration:" <+> ppr ty) + split (L _ (HsAppTy t u)) ts = split t (u : ts) + split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc + return (data_con, mk_rest ts) + split (L l (HsTupleTy _ [])) [] = return (L l (getRdrName unitDataCon), PrefixCon []) + -- See Note [Unit tuples] in HsTypes + split (L l _) _ = parseErrorSDoc l (text "parse error in constructor in data/newtype declaration:" <+> ppr ty) mk_rest [L _ (HsRecTy flds)] = RecCon flds mk_rest ts = PrefixCon ts @@ -536,12 +538,13 @@ checkTyClHdr ty goL (L l ty) acc = go l ty acc go l (HsTyVar tc) acc - | isRdrTc tc = return (L l tc, acc) - + | isRdrTc tc = return (L l tc, acc) go _ (HsOpTy t1 (_, ltc@(L _ tc)) t2) acc | isRdrTc tc = return (ltc, t1:t2:acc) go _ (HsParTy ty) acc = goL ty acc go _ (HsAppTy t1 t2) acc = goL t1 (t2:acc) + go l (HsTupleTy _ []) [] = return (L l (getRdrName unitTyCon), []) + -- See Note [Unit tuples] in HsTypes go l _ _ = parseErrorSDoc l (text "Malformed head of type or class declaration:" <+> ppr ty) -- Check that associated type declarations of a class are all kind signatures. @@ -561,14 +564,11 @@ checkContext (L l orig_t) = check orig_t where check (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type - = return (L l ts) + = return (L l ts) -- Ditto () check (HsParTy ty) -- to be sure HsParTy doesn't get into the way = check (unLoc ty) - check (HsTyVar t) -- Empty context shows up as a unit type () - | t == getRdrName unitTyCon = return (L l []) - check _ = return (L l [L l orig_t]) diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index c6991e1591..ec760d7fae 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -56,7 +56,8 @@ module TysWiredIn ( mkTupleTy, mkBoxedTupleTy, tupleTyCon, tupleCon, unitTyCon, unitDataCon, unitDataConId, pairTyCon, - unboxedSingletonTyCon, unboxedSingletonDataCon, + unboxedUnitTyCon, unboxedUnitDataCon, + unboxedSingletonTyCon, unboxedSingletonDataCon, unboxedPairTyCon, unboxedPairDataCon, -- * Unit @@ -367,6 +368,11 @@ unitDataConId = dataConWorkId unitDataCon pairTyCon :: TyCon pairTyCon = tupleTyCon BoxedTuple 2 +unboxedUnitTyCon :: TyCon +unboxedUnitTyCon = tupleTyCon UnboxedTuple 0 +unboxedUnitDataCon :: DataCon +unboxedUnitDataCon = tupleCon UnboxedTuple 0 + unboxedSingletonTyCon :: TyCon unboxedSingletonTyCon = tupleTyCon UnboxedTuple 1 unboxedSingletonDataCon :: DataCon diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index c919e46972..4f36d03254 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -20,7 +20,7 @@ module RnEnv ( HsSigCtxt(..), lookupLocalDataTcNames, lookupSigOccRn, lookupFixityRn, lookupTyFixityRn, - lookupInstDeclBndr, lookupSubBndr, greRdrName, + lookupInstDeclBndr, lookupSubBndrOcc, greRdrName, lookupSubBndrGREs, lookupConstructorFields, lookupSyntaxName, lookupSyntaxTable, lookupIfThenElse, lookupGreRn, lookupGreLocalRn, lookupGreRn_maybe, @@ -267,7 +267,7 @@ lookupInstDeclBndr cls what rdr -- In an instance decl you aren't allowed -- to use a qualified name for the method -- (Although it'd make perfect sense.) - ; lookupSubBndr (ParentIs cls) doc rdr } + ; lookupSubBndrOcc (ParentIs cls) doc rdr } where doc = what <+> ptext (sLit "of class") <+> quotes (ppr cls) @@ -304,11 +304,11 @@ lookupConstructorFields con_name -- unambiguous because there is only one field id 'fld' in scope. -- But currently it's rejected. -lookupSubBndr :: Parent -- NoParent => just look it up as usual - -- ParentIs p => use p to disambiguate - -> SDoc -> RdrName - -> RnM Name -lookupSubBndr parent doc rdr_name +lookupSubBndrOcc :: Parent -- NoParent => just look it up as usual + -- ParentIs p => use p to disambiguate + -> SDoc -> RdrName + -> RnM Name +lookupSubBndrOcc parent doc rdr_name | Just n <- isExact_maybe rdr_name -- This happens in derived code = lookupExactOcc n @@ -323,6 +323,7 @@ lookupSubBndr parent doc rdr_name -- The latter does pickGREs, but we want to allow 'x' -- even if only 'M.x' is in scope [gre] -> do { addUsedRdrName gre (used_rdr_name gre) + -- Add a usage; this is an *occurrence* site ; return (gre_name gre) } [] -> do { addErr (unknownSubordinateErr doc rdr_name) ; return (mkUnboundName rdr_name) } @@ -669,6 +670,11 @@ lookupBindGroupOcc ctxt what rdr_name ; return (Right n') } -- Maybe we should check the side conditions -- but it's a pain, and Exact things only show -- up when you know what you are doing + + | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name + = do { n' <- lookupOrig rdr_mod rdr_occ + ; return (Right n') } + | otherwise = case ctxt of HsBootCtxt -> lookup_top diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 090a17747f..a09509754e 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -60,12 +60,14 @@ and packages. Doing this without caching any trust information would be very slow as we would need to touch all packages and interface files a module depends on. To avoid this we make use of the property that if a modules Safe Haskell mode changes, this triggers a recompilation from that module in the dependcy -graph. So we can just worry mostly about direct imports. There is one trust -property that can change for a package though without recompliation being -triggered, package trust. So we must check that all packages a module -tranitively depends on to be trusted are still trusted when we are compiling -this module (as due to recompilation avoidance some modules below may not be -considered trusted any more without recompilation being triggered). +graph. So we can just worry mostly about direct imports. + +There is one trust property that can change for a package though without +recompliation being triggered: package trust. So we must check that all +packages a module tranitively depends on to be trusted are still trusted when +we are compiling this module (as due to recompilation avoidance some modules +below may not be considered trusted any more without recompilation being +triggered). We handle this by augmenting the existing transitive list of packages a module M depends on with a bool for each package that says if it must be trusted when the @@ -110,7 +112,7 @@ haskell at all and simply imports B, should A inherit all the the trust requirements from B? Should A now also require that a package p is trusted since B required it? -We currently say no but I saying yes also makes sense. The difference is, if a +We currently say no but saying yes also makes sense. The difference is, if a module M that doesn't use Safe Haskell imports a module N that does, should all the trusted package requirements be dropped since M didn't declare that it cares about Safe Haskell (so -XSafe is more strongly associated with the module doing diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index 740acc42c5..7dd76bd4e6 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -487,7 +487,7 @@ rnHsRecFields1 ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot } rn_fld pun_ok parent (HsRecField { hsRecFieldId = fld , hsRecFieldArg = arg , hsRecPun = pun }) - = do { fld'@(L loc fld_nm) <- wrapLocM (lookupSubBndr parent doc) fld + = do { fld'@(L loc fld_nm) <- wrapLocM (lookupSubBndrOcc parent doc) fld ; arg' <- if pun then do { checkErr pun_ok (badPun fld) ; return (L loc (mk_arg (mkRdrUnqual (nameOccName fld_nm)))) } diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 31c7c336be..197f2b2554 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -1055,9 +1055,9 @@ rnConDecls condecls rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name) rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs - , con_cxt = cxt, con_details = details - , con_res = res_ty, con_doc = mb_doc - , con_old_rec = old_rec, con_explicit = expl }) + , con_cxt = cxt, con_details = details + , con_res = res_ty, con_doc = mb_doc + , con_old_rec = old_rec, con_explicit = expl }) = do { addLocM checkConName name ; when old_rec (addWarn (deprecRecSyntax decl)) ; new_name <- lookupLocatedTopBndrRn name @@ -1084,35 +1084,43 @@ rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs ; bindTyVarsRn doc new_tvs $ \new_tyvars -> do { new_context <- rnContext doc cxt ; new_details <- rnConDeclDetails doc details - ; (new_details', new_res_ty) <- rnConResult doc new_details res_ty + ; (new_details', new_res_ty) <- rnConResult doc (unLoc new_name) new_details res_ty ; return (decl { con_name = new_name, con_qvars = new_tyvars, con_cxt = new_context , con_details = new_details', con_res = new_res_ty, con_doc = mb_doc' }) }} where doc = ConDeclCtx name get_rdr_tvs tys = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy HsBoxedTuple tys)) -rnConResult :: HsDocContext +rnConResult :: HsDocContext -> Name -> HsConDetails (LHsType Name) [ConDeclField Name] -> ResType RdrName -> RnM (HsConDetails (LHsType Name) [ConDeclField Name], ResType Name) -rnConResult _ details ResTyH98 = return (details, ResTyH98) -rnConResult doc details (ResTyGADT ty) +rnConResult _ _ details ResTyH98 = return (details, ResTyH98) +rnConResult doc con details (ResTyGADT ty) = do { ty' <- rnLHsType doc ty ; let (arg_tys, res_ty) = splitHsFunType ty' -- We can finally split it up, -- now the renamer has dealt with fixities -- See Note [Sorting out the result type] in RdrHsSyn - details' = case details of - RecCon {} -> details - PrefixCon {} -> PrefixCon arg_tys - InfixCon {} -> pprPanic "rnConResult" (ppr ty) - -- See Note [Sorting out the result type] in RdrHsSyn - - ; when (not (null arg_tys) && case details of { RecCon {} -> True; _ -> False }) - (addErr (badRecResTy (docOfHsDocContext doc))) - ; return (details', ResTyGADT res_ty) } + ; case details of + InfixCon {} -> pprPanic "rnConResult" (ppr ty) + -- See Note [Sorting out the result type] in RdrHsSyn + + RecCon {} -> do { unless (null arg_tys) + (addErr (badRecResTy (docOfHsDocContext doc))) + ; return (details, ResTyGADT res_ty) } + + PrefixCon {} | isSymOcc (getOccName con) -- See Note [Infix GADT cons] + , [ty1,ty2] <- arg_tys + -> do { fix_env <- getFixityEnv + ; return (if con `elemNameEnv` fix_env + then InfixCon ty1 ty2 + else PrefixCon arg_tys + , ResTyGADT res_ty) } + | otherwise + -> return (PrefixCon arg_tys, ResTyGADT res_ty) } rnConDeclDetails :: HsDocContext -> HsConDetails (LHsType RdrName) [ConDeclField RdrName] @@ -1161,6 +1169,18 @@ badDataCon name = hsep [ptext (sLit "Illegal data constructor name"), quotes (ppr name)] \end{code} +Note [Infix GADT constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do not currently have syntax to declare an infix constructor in GADT syntax, +but it makes a (small) difference to the Show instance. So as a slightly +ad-hoc solution, we regard a GADT data constructor as infix if + a) it is an operator symbol + b) it has two arguments + c) there is a fixity declaration for it +For example: + infix 6 (:--:) + data T a where + (:--:) :: t1 -> t2 -> T Int %********************************************************* %* * diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs index 1e4def3f14..c82a5577c6 100644 --- a/compiler/simplCore/CoreMonad.lhs +++ b/compiler/simplCore/CoreMonad.lhs @@ -162,7 +162,7 @@ dumpPassResult dflags mb_flag hdr extra_info binds rules | otherwise = Err.debugTraceMsg dflags 2 $ - (text "Result size of" <+> hdr <+> equals <+> int (coreBindsSize binds)) + (sep [text "Result size of" <+> hdr, nest 2 (equals <+> ppr (coreBindsStats binds))]) -- Report result size -- This has the side effect of forcing the intermediate to be evaluated @@ -865,8 +865,8 @@ addSimplCount count = write (CoreWriter { cw_simpl_count = count }) -- Convenience accessors for useful fields of HscEnv -getDynFlags :: CoreM DynFlags -getDynFlags = fmap hsc_dflags getHscEnv +instance HasDynFlags CoreM where + getDynFlags = fmap hsc_dflags getHscEnv -- | The original name cache is the current mapping from 'Module' and -- 'OccName' to a compiler-wide unique 'Name' diff --git a/compiler/typecheck/TcArrows.lhs b/compiler/typecheck/TcArrows.lhs index f58c566369..2934cda94b 100644 --- a/compiler/typecheck/TcArrows.lhs +++ b/compiler/typecheck/TcArrows.lhs @@ -348,25 +348,32 @@ tcArrDoStmt env ctxt (BindStmt pat rhs _ _) res_ty thing_inside thing_inside res_ty ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) } -tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = laterNames - , recS_rec_ids = recNames }) res_ty thing_inside - = do { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind - ; let rec_ids = zipWith mkLocalId recNames rec_tys - ; tcExtendIdEnv rec_ids $ do - { (stmts', (later_ids, rec_rets)) +tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names + , recS_rec_ids = rec_names }) res_ty thing_inside + = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names + ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind + ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys + ; tcExtendIdEnv tup_ids $ do + { (stmts', tup_rets) <- tcStmtsAndThen ctxt (tcArrDoStmt env) stmts res_ty $ \ _res_ty' -> -- ToDo: res_ty not really right - do { rec_rets <- zipWithM tcCheckId recNames rec_tys - ; later_ids <- tcLookupLocalIds laterNames - ; return (later_ids, rec_rets) } + zipWithM tcCheckId tup_names tup_elt_tys - ; thing <- tcExtendIdEnv later_ids (thing_inside res_ty) + ; thing <- thing_inside res_ty -- NB: The rec_ids for the recursive things -- already scope over this part. This binding may shadow -- some of them with polymorphic things with the same Name -- (see note [RecStmt] in HsExpr) + ; let rec_ids = takeList rec_names tup_ids + ; later_ids <- tcLookupLocalIds later_names + + ; let rec_rets = takeList rec_names tup_rets + ; let ret_table = zip tup_ids tup_rets + ; let later_rets = [r | i <- later_ids, (j, r) <- ret_table, i == j] + ; return (emptyRecStmt { recS_stmts = stmts', recS_later_ids = later_ids + , recS_later_rets = later_rets , recS_rec_ids = rec_ids, recS_rec_rets = rec_rets , recS_ret_ty = res_ty }, thing) }} diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index c1b40c7595..480c1b16d9 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -8,9 +8,6 @@ module TcCanonical( canonicalize, - canOccursCheck, canEq, canEvVar, - rewriteWithFunDeps, - emitFDWorkAsWanted, emitFDWorkAsDerived, StopOrContinue (..) ) where @@ -19,8 +16,6 @@ module TcCanonical( import BasicTypes ( IPName ) import TcErrors import TcRnTypes -import FunDeps -import qualified TcMType as TcM import TcType import Type import Kind @@ -32,7 +27,7 @@ import Name ( Name ) import Var import VarEnv import Outputable -import Control.Monad ( when, unless, zipWithM, foldM ) +import Control.Monad ( when, unless, zipWithM ) import MonadUtils import Control.Applicative ( (<|>) ) @@ -42,7 +37,6 @@ import TcSMonad import FastString import Data.Maybe ( isNothing ) -import Pair ( pSnd ) \end{code} @@ -204,11 +198,13 @@ canonicalize (CIrredEvCan { cc_id = ev, cc_flavor = fl canEvVar :: EvVar -> PredTree -> SubGoalDepth -> CtFlavor -> TcS StopOrContinue +-- Called only for non-canonical EvVars canEvVar ev pred_classifier d fl = case pred_classifier of ClassPred cls tys -> canClass d fl ev cls tys `andWhenContinue` emit_superclasses - EqPred ty1 ty2 -> canEq d fl ev ty1 ty2 + EqPred ty1 ty2 -> canEq d fl ev ty1 ty2 + `andWhenContinue` emit_kind_constraint IPPred nm ty -> canIP d fl ev nm ty IrredPred ev_ty -> canIrred d fl ev ev_ty TuplePred tys -> canTuple d fl ev tys @@ -219,9 +215,58 @@ canEvVar ev pred_classifier d fl = do { sctxt <- getTcSContext ; unless (simplEqsOnly sctxt) $ newSCWorkFromFlavored d v_new fl cls xis_new + -- Arguably we should "seq" the coercions if they are derived, + -- as we do below for emit_kind_constraint, to allow errors in + -- superclasses to be executed if deferred to runtime! ; continueWith ct } emit_superclasses _ = panic "emit_superclasses of non-class!" + emit_kind_constraint ct@(CTyEqCan { cc_id = ev, cc_depth = d + , cc_flavor = fl, cc_tyvar = tv + , cc_rhs = ty }) + = do_emit_kind_constraint ct ev d fl (mkTyVarTy tv) ty + + emit_kind_constraint ct@(CFunEqCan { cc_id = ev, cc_depth = d + , cc_flavor = fl + , cc_fun = fn, cc_tyargs = xis1 + , cc_rhs = xi2 }) + = do_emit_kind_constraint ct ev d fl (mkTyConApp fn xis1) xi2 + emit_kind_constraint ct = continueWith ct + + do_emit_kind_constraint ct eqv d fl ty1 ty2 + | compatKind k1 k2 = continueWith ct + | otherwise + = do { keqv <- forceNewEvVar kind_co_fl (mkEqPred (k1,k2)) + ; eqv' <- forceNewEvVar fl (mkEqPred (ty1,ty2)) + ; _fl <- case fl of + Wanted {}-> setEvBind eqv + (mkEvKindCast eqv' (mkTcCoVarCo keqv)) fl + Given {} -> setEvBind eqv' + (mkEvKindCast eqv (mkTcCoVarCo keqv)) fl + Derived {} -> return fl + + ; canEq_ d kind_co_fl keqv k1 k2 -- Emit kind equality + ; continueWith (ct { cc_id = eqv' }) } + where k1 = typeKind ty1 + k2 = typeKind ty2 + ctxt = mkKindErrorCtxtTcS ty1 k1 ty2 k2 + -- Always create a Wanted kind equality even if + -- you are decomposing a given constraint. + -- NB: DV finds this reasonable for now. Maybe we + -- have to revisit. + kind_co_fl + | Given (CtLoc _sk_info src_span err_ctxt) _ <- fl + = let orig = TypeEqOrigin (UnifyOrigin ty1 ty2) + ctloc = pushErrCtxtSameOrigin ctxt $ + CtLoc orig src_span err_ctxt + in Wanted ctloc + | Wanted ctloc <- fl + = Wanted (pushErrCtxtSameOrigin ctxt ctloc) + | Derived ctloc <- fl + = Derived (pushErrCtxtSameOrigin ctxt ctloc) + | otherwise + = panic "do_emit_kind_constraint: non-CtLoc inside!" + -- Tuple canonicalisation -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -555,29 +600,30 @@ flatten :: SubGoalDepth -- Depth flatten d ctxt ty | Just ty' <- tcView ty = do { (xi, co) <- flatten d ctxt ty' - ; return (xi,co) } - - -- DV: The following is tedious to do but maybe we should return to this - -- Preserve type synonyms if possible - -- ; if no_flattening - -- then return (xi, mkTcReflCo xi,no_flattening) -- Importantly, not xi! - -- else return (xi,co,no_flattening) - -- } - + ; return (xi,co) } flatten _ _ xi@(LiteralTy _) = return (xi, mkTcReflCo xi) -flatten d ctxt v@(TyVarTy _) +flatten d ctxt (TyVarTy tv) = do { ieqs <- getInertEqs - ; let co = liftInertEqsTy ieqs ctxt v -- co : v ~ ty - ty = pSnd (tcCoercionKind co) - ; if v `eqType` ty then - return (ty,mkTcReflCo ty) - else -- NB recursive call. Why? See Note [Non-idempotent inert substitution] - -- Actually I believe that applying the substition only *twice* will suffice - - do { (ty_final,co') <- flatten d ctxt ty -- co' : ty_final ~ ty - ; return (ty_final,co' `mkTcTransCo` mkTcSymCo co) } } + ; let mco = tv_eq_subst (fst ieqs) tv -- co : v ~ ty + ; case mco of -- Done, but make sure the kind is zonked + Nothing -> + do { let knd = tyVarKind tv + ; (new_knd,_kind_co) <- flatten d ctxt knd + ; let ty = mkTyVarTy (setVarType tv new_knd) + ; return (ty, mkTcReflCo ty) } + -- NB recursive call. + -- Why? See Note [Non-idempotent inert substitution] + -- Actually, I think applying the substition just twice will suffice + Just (co,ty) -> + do { (ty_final,co') <- flatten d ctxt ty + ; return (ty_final, co' `mkTcTransCo` mkTcSymCo co) } } + where tv_eq_subst subst tv + | Just (ct,co) <- lookupVarEnv subst tv + , cc_flavor ct `canRewrite` ctxt + = Just (co,cc_rhs ct) + | otherwise = Nothing \end{code} @@ -1110,28 +1156,17 @@ canEqLeafOriented :: SubGoalDepth -- Depth -> TcType -> TcType -> TcS StopOrContinue -- By now s1 will either be a variable or a type family application canEqLeafOriented d fl eqv s1 s2 - | let k1 = typeKind s1 - , let k2 = typeKind s2 - -- Establish kind invariants for CFunEqCan and CTyEqCan - = do { are_compat <- compatKindTcS k1 k2 - ; can_unify <- if not are_compat - then unifyKindTcS s1 s2 k1 k2 - else return False - -- If the kinds cannot be unified or are not compatible, don't fail - -- right away; instead, emit a frozen error - ; if (not are_compat && not can_unify) then - canEqFailure d fl eqv - else can_eq_kinds_ok d fl eqv s1 s2 } - - where can_eq_kinds_ok d fl eqv s1 s2 + = can_eq_split_lhs d fl eqv s1 s2 + where can_eq_split_lhs d fl eqv s1 s2 | Just (fn,tys1) <- splitTyConApp_maybe s1 = canEqLeafFunEqLeftRec d fl eqv (fn,tys1) s2 | Just tv <- getTyVar_maybe s1 = canEqLeafTyVarLeftRec d fl eqv tv s2 | otherwise = pprPanic "canEqLeafOriented" $ - text "Non-variable or non-family equality LHS" <+> ppr eqv <+> - dcolon <+> ppr (evVarPred eqv) + text "Non-variable or non-family equality LHS" <+> + ppr eqv <+> dcolon <+> ppr (evVarPred eqv) + canEqLeafFunEqLeftRec :: SubGoalDepth -> CtFlavor -> EqVar @@ -1477,117 +1512,3 @@ we first try expanding each of the ti to types which no longer contain a. If this turns out to be impossible, we next try expanding F itself, and so on. - -%************************************************************************ -%* * -%* Functional dependencies, instantiation of equations -%* * -%************************************************************************ - -When we spot an equality arising from a functional dependency, -we now use that equality (a "wanted") to rewrite the work-item -constraint right away. This avoids two dangers - - Danger 1: If we send the original constraint on down the pipeline - it may react with an instance declaration, and in delicate - situations (when a Given overlaps with an instance) that - may produce new insoluble goals: see Trac #4952 - - Danger 2: If we don't rewrite the constraint, it may re-react - with the same thing later, and produce the same equality - again --> termination worries. - -To achieve this required some refactoring of FunDeps.lhs (nicer -now!). - -\begin{code} -rewriteWithFunDeps :: [Equation] - -> [Xi] - -> WantedLoc - -> TcS (Maybe ([Xi], [TcCoercion], [(EvVar,WantedLoc)])) - -- Not quite a WantedEvVar unfortunately - -- Because our intention could be to make - -- it derived at the end of the day --- NB: The flavor of the returned EvVars will be decided by the caller --- Post: returns no trivial equalities (identities) and all EvVars returned are fresh -rewriteWithFunDeps eqn_pred_locs xis wloc - = do { fd_ev_poss <- mapM (instFunDepEqn wloc) eqn_pred_locs - ; let fd_ev_pos :: [(Int,(EqVar,WantedLoc))] - fd_ev_pos = concat fd_ev_poss - (rewritten_xis, cos) = unzip (rewriteDictParams fd_ev_pos xis) - ; if null fd_ev_pos then return Nothing - else return (Just (rewritten_xis, cos, map snd fd_ev_pos)) } - -instFunDepEqn :: WantedLoc -> Equation -> TcS [(Int,(EvVar,WantedLoc))] --- Post: Returns the position index as well as the corresponding FunDep equality -instFunDepEqn wl (FDEqn { fd_qtvs = qtvs, fd_eqs = eqs - , fd_pred1 = d1, fd_pred2 = d2 }) - = do { let tvs = varSetElems qtvs - ; tvs' <- mapM instFlexiTcS tvs -- IA0_TODO: we might need to do kind substitution - ; let subst = zipTopTvSubst tvs (mkTyVarTys tvs') - ; foldM (do_one subst) [] eqs } - where - do_one subst ievs (FDEq { fd_pos = i, fd_ty_left = ty1, fd_ty_right = ty2 }) - = let sty1 = Type.substTy subst ty1 - sty2 = Type.substTy subst ty2 - in if eqType sty1 sty2 then return ievs -- Return no trivial equalities - else do { eqv <- newEqVar (Derived wl) sty1 sty2 -- Create derived or cached by deriveds - ; let wl' = push_ctx wl - ; if isNewEvVar eqv then - return $ (i,(evc_the_evvar eqv,wl')):ievs - else -- We are eventually going to emit FD work back in the work list so - -- it is important that we only return the /freshly created/ and not - -- some existing equality! - return ievs } - - push_ctx :: WantedLoc -> WantedLoc - push_ctx loc = pushErrCtxt FunDepOrigin (False, mkEqnMsg d1 d2) loc - -mkEqnMsg :: (TcPredType, SDoc) - -> (TcPredType, SDoc) -> TidyEnv -> TcM (TidyEnv, SDoc) -mkEqnMsg (pred1,from1) (pred2,from2) tidy_env - = do { zpred1 <- TcM.zonkTcPredType pred1 - ; zpred2 <- TcM.zonkTcPredType pred2 - ; let { tpred1 = tidyType tidy_env zpred1 - ; tpred2 = tidyType tidy_env zpred2 } - ; let msg = vcat [ptext (sLit "When using functional dependencies to combine"), - nest 2 (sep [ppr tpred1 <> comma, nest 2 from1]), - nest 2 (sep [ppr tpred2 <> comma, nest 2 from2])] - ; return (tidy_env, msg) } - -rewriteDictParams :: [(Int,(EqVar,WantedLoc))] -- A set of coercions : (pos, ty' ~ ty) - -> [Type] -- A sequence of types: tys - -> [(Type, TcCoercion)] -- Returns: [(ty', co : ty' ~ ty)] -rewriteDictParams param_eqs tys - = zipWith do_one tys [0..] - where - do_one :: Type -> Int -> (Type, TcCoercion) - do_one ty n = case lookup n param_eqs of - Just wev -> (get_fst_ty wev, mkTcCoVarCo (fst wev)) - Nothing -> (ty, mkTcReflCo ty) -- Identity - - get_fst_ty (wev,_wloc) - | Just (ty1, _) <- getEqPredTys_maybe (evVarPred wev ) - = ty1 - | otherwise - = panic "rewriteDictParams: non equality fundep!?" - - -emitFDWork :: Bool - -> [(EvVar,WantedLoc)] - -> SubGoalDepth -> TcS () -emitFDWork as_wanted evlocs d - = updWorkListTcS $ appendWorkListEqs fd_cts - where fd_cts = map mk_fd_ct evlocs - mk_fl wl = if as_wanted then (Wanted wl) else (Derived wl) - mk_fd_ct (v,wl) = CNonCanonical { cc_id = v - , cc_flavor = mk_fl wl - , cc_depth = d } - -emitFDWorkAsDerived, emitFDWorkAsWanted :: [(EvVar,WantedLoc)] - -> SubGoalDepth - -> TcS () -emitFDWorkAsDerived = emitFDWork False -emitFDWorkAsWanted = emitFDWork True - -\end{code} diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index d35670dda1..5a24419ad2 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -23,6 +23,7 @@ import TcSMonad import TcType import TypeRep import Type +import Kind ( isKind ) import Class import Unify ( tcMatchTys ) import Inst @@ -465,8 +466,12 @@ addExtraInfo ctxt ty1 ty2 extra2 = typeExtraInfoMsg (cec_encl ctxt) ty2 misMatchMsg :: TcType -> TcType -> SDoc -- Types are already tidy -misMatchMsg ty1 ty2 = sep [ ptext (sLit "Couldn't match type") <+> quotes (ppr ty1) - , nest 15 $ ptext (sLit "with") <+> quotes (ppr ty2)] +misMatchMsg ty1 ty2 + = sep [ ptext cm_ty_or_knd <+> quotes (ppr ty1) + , nest 15 $ ptext (sLit "with") <+> quotes (ppr ty2)] + where cm_ty_or_knd + | isKind ty1 = sLit "Couldn't match kind" + | otherwise = sLit "Couldn't match type" kindErrorMsg :: TcType -> TcType -> SDoc -- Types are already tidy kindErrorMsg ty1 ty2 diff --git a/compiler/typecheck/TcEvidence.lhs b/compiler/typecheck/TcEvidence.lhs index e1781439f6..cb4c75cc6e 100644 --- a/compiler/typecheck/TcEvidence.lhs +++ b/compiler/typecheck/TcEvidence.lhs @@ -16,7 +16,7 @@ module TcEvidence ( EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds,
- EvTerm(..), mkEvCast, evVarsOfTerm,
+ EvTerm(..), mkEvCast, evVarsOfTerm, mkEvKindCast,
-- TcCoercion
TcCoercion(..),
@@ -448,27 +448,43 @@ evBindMapBinds bs data EvBind = EvBind EvVar EvTerm
data EvTerm
- = EvId EvId -- Term-level variable-to-variable bindings
- -- (no coercion variables! they come via EvCoercion)
+ = EvId EvId -- Term-level variable-to-variable bindings
+ -- (no coercion variables! they come via EvCoercion)
- | EvCoercion TcCoercion -- (Boxed) coercion bindings
+ | EvCoercion TcCoercion -- (Boxed) coercion bindings
- | EvCast EvVar TcCoercion -- d |> co
+ | EvCast EvVar TcCoercion -- d |> co
- | EvDFunApp DFunId -- Dictionary instance application
+ | EvDFunApp DFunId -- Dictionary instance application
[Type] [EvVar]
- | EvTupleSel EvId Int -- n'th component of the tuple
+ | EvTupleSel EvId Int -- n'th component of the tuple
- | EvTupleMk [EvId] -- tuple built from this stuff
-
- | EvSuperClass DictId Int -- n'th superclass. Used for both equalities and
- -- dictionaries, even though the former have no
- -- selector Id. We count up from _0_
+ | EvTupleMk [EvId] -- tuple built from this stuff
+ | EvSuperClass DictId Int -- n'th superclass. Used for both equalities and
+ -- dictionaries, even though the former have no
+ -- selector Id. We count up from _0_
+ | EvKindCast EvVar TcCoercion -- See Note [EvKindCast]
+
deriving( Data.Data, Data.Typeable)
\end{code}
+Note [EvKindCast]
+~~~~~~~~~~~~~~~~~
+
+EvKindCast g kco is produced when we have a constraint (g : s1 ~ s2)
+but the kinds of s1 and s2 (k1 and k2 respectively) don't match but
+are rather equal by a coercion. You may think that this coercion will
+always turn out to be ReflCo, so why is this needed? Because sometimes
+we will want to defer kind errors until the runtime and in these cases
+that coercion will be an 'error' term, which we want to evaluate rather
+than silently forget about!
+
+The relevant (and only) place where such a coercion is produced in
+the simplifier is in emit_kind_constraint in TcCanonical.
+
+
Note [EvBinds/EvTerm]
~~~~~~~~~~~~~~~~~~~~~
How evidence is created and updated. Bindings for dictionaries,
@@ -493,6 +509,11 @@ mkEvCast ev lco | isTcReflCo lco = EvId ev
| otherwise = EvCast ev lco
+mkEvKindCast :: EvVar -> TcCoercion -> EvTerm
+mkEvKindCast ev lco
+ | isTcReflCo lco = EvId ev
+ | otherwise = EvKindCast ev lco
+
emptyTcEvBinds :: TcEvBinds
emptyTcEvBinds = EvBinds emptyBag
@@ -509,6 +530,7 @@ evVarsOfTerm (EvTupleSel v _) = [v] evVarsOfTerm (EvSuperClass v _) = [v]
evVarsOfTerm (EvCast v co) = v : varSetElems (coVarsOfTcCo co)
evVarsOfTerm (EvTupleMk evs) = evs
+evVarsOfTerm (EvKindCast v co) = v : varSetElems (coVarsOfTcCo co)
\end{code}
@@ -562,6 +584,7 @@ instance Outputable EvBind where instance Outputable EvTerm where
ppr (EvId v) = ppr v
ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendTcCo co
+ ppr (EvKindCast v co) = ppr v <+> (ptext (sLit "`kind-cast`")) <+> pprParendTcCo co
ppr (EvCoercion co) = ptext (sLit "CO") <+> ppr co
ppr (EvTupleSel v n) = ptext (sLit "tupsel") <> parens (ppr (v,n))
ppr (EvTupleMk vs) = ptext (sLit "tupmk") <+> ppr vs
diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index c1f425b2e6..3e18da52cc 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -424,7 +424,7 @@ warnMissingSig msg id ; let (env1, tidy_ty) = tidyOpenType env0 (idType id) ; addWarnTcM (env1, mk_msg tidy_ty) } where - mk_msg ty = sep [ msg, nest 2 $ pprHsVar (idName id) <+> dcolon <+> ppr ty ] + mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ] --------------------------------------------- zonkMonoBinds :: ZonkEnv -> SigWarn -> LHsBinds TcId -> TcM (LHsBinds Id) @@ -792,7 +792,8 @@ zonkStmt env (ParStmt stmts_w_bndrs mzip_op bind_op return_op) zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id, recS_bind_fn = bind_id - , recS_rec_rets = rets, recS_ret_ty = ret_ty }) + , recS_later_rets = later_rets, recS_rec_rets = rec_rets + , recS_ret_ty = ret_ty }) = do { new_rvs <- zonkIdBndrs env rvs ; new_lvs <- zonkIdBndrs env lvs ; new_ret_ty <- zonkTcTypeToType env ret_ty @@ -803,12 +804,14 @@ zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_id ; (env2, new_segStmts) <- zonkStmts env1 segStmts -- Zonk the ret-expressions in an envt that -- has the polymorphic bindings in the envt - ; new_rets <- mapM (zonkExpr env2) rets + ; new_later_rets <- mapM (zonkExpr env2) later_rets + ; new_rec_rets <- mapM (zonkExpr env2) rec_rets ; return (extendIdZonkEnv env new_lvs, -- Only the lvs are needed RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id - , recS_rec_rets = new_rets, recS_ret_ty = new_ret_ty }) } + , recS_later_rets = new_later_rets + , recS_rec_rets = new_rec_rets, recS_ret_ty = new_ret_ty }) } zonkStmt env (ExprStmt expr then_op guard_op ty) = zonkLExpr env expr `thenM` \ new_expr -> @@ -930,14 +933,23 @@ zonk_pat env (TuplePat pats boxed ty) ; (env', pats') <- zonkPats env pats ; return (env', TuplePat pats' boxed ty') } -zonk_pat env p@(ConPatOut { pat_ty = ty, pat_dicts = evs, pat_binds = binds, pat_args = args }) - = ASSERT( all isImmutableTyVar (pat_tvs p) ) +zonk_pat env p@(ConPatOut { pat_ty = ty, pat_tvs = tyvars + , pat_dicts = evs, pat_binds = binds + , pat_args = args }) + = ASSERT( all isImmutableTyVar tyvars ) do { new_ty <- zonkTcTypeToType env ty - ; (env1, new_evs) <- zonkEvBndrsX env evs + ; (env0, new_tyvars) <- zonkTyBndrsX env tyvars + -- Must zonk the existential variables, because their + -- /kind/ need potential zonking. + -- cf typecheck/should_compile/tc221.hs + ; (env1, new_evs) <- zonkEvBndrsX env0 evs ; (env2, new_binds) <- zonkTcEvBinds env1 binds ; (env', new_args) <- zonkConStuff env2 args - ; returnM (env', p { pat_ty = new_ty, pat_dicts = new_evs, - pat_binds = new_binds, pat_args = new_args }) } + ; returnM (env', p { pat_ty = new_ty, + pat_tvs = new_tyvars, + pat_dicts = new_evs, + pat_binds = new_binds, + pat_args = new_args }) } zonk_pat env (LitPat lit) = return (env, LitPat lit) @@ -1035,15 +1047,22 @@ zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs) (varSetElemsKvsFirst unbound_tkvs) ++ new_bndrs - ; return (HsRule name act final_bndrs new_lhs fv_lhs new_rhs fv_rhs) } + ; return $ + HsRule name act final_bndrs new_lhs fv_lhs new_rhs fv_rhs } where zonk_bndr env (RuleBndr (L loc v)) - = do { (env', v') <- zonk_it env v; return (env', RuleBndr (L loc v')) } + = do { (env', v') <- zonk_it env v + ; return (env', RuleBndr (L loc v')) } zonk_bndr _ (RuleBndrSig {}) = panic "zonk_bndr RuleBndrSig" zonk_it env v - | isId v = do { v' <- zonkIdBndr env v; return (extendIdZonkEnv1 env v', v') } - | otherwise = ASSERT( isImmutableTyVar v) return (env, v) + | isId v = do { v' <- zonkIdBndr env v + ; return (extendIdZonkEnv1 env v', v') } + | otherwise = ASSERT( isImmutableTyVar v) + zonkTyBndrX env v + -- DV: used to be return (env,v) but that is plain + -- wrong because we may need to go inside the kind + -- of v and zonk there! \end{code} \begin{code} @@ -1086,6 +1105,11 @@ zonkEvTerm env (EvCoercion co) = do { co' <- zonkTcLCoToLCo env co zonkEvTerm env (EvCast v co) = ASSERT( isId v) do { co' <- zonkTcLCoToLCo env co ; return (mkEvCast (zonkIdOcc env v) co') } + +zonkEvTerm env (EvKindCast v co) = ASSERT( isId v) + do { co' <- zonkTcLCoToLCo env co + ; return (mkEvKindCast (zonkIdOcc env v) co') } + zonkEvTerm env (EvTupleSel v n) = return (EvTupleSel (zonkIdOcc env v) n) zonkEvTerm env (EvTupleMk vs) = return (EvTupleMk (map (zonkIdOcc env) vs)) zonkEvTerm env (EvSuperClass d n) = return (EvSuperClass (zonkIdOcc env d) n) diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index f9e7d48dec..6efc1028e2 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -349,14 +349,10 @@ kc_hs_type (HsParTy ty) exp_kind = do ty' <- kc_lhs_type ty exp_kind return (HsParTy ty') -kc_hs_type (HsTyVar name) exp_kind - -- Special case for the unit tycon so it benefits from kind overloading - | name == tyConName unitTyCon - = kc_hs_type (HsTupleTy HsBoxedOrConstraintTuple []) exp_kind - | otherwise = do - (ty, k) <- kcTyVar name - checkExpectedKind ty k exp_kind - return ty +kc_hs_type (HsTyVar name) exp_kind = do + (ty, k) <- kcTyVar name + checkExpectedKind ty k exp_kind + return ty kc_hs_type (HsListTy ty) exp_kind = do ty' <- kcLiftedType ty diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 1eaf927ffd..11ec17546b 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -42,7 +42,7 @@ import DataCon import Class import Var import VarEnv -import VarSet ( mkVarSet, varSetElems ) +import VarSet ( mkVarSet, subVarSet, varSetElems ) import Pair import CoreUnfold ( mkDFunUnfolding ) import CoreSyn ( Expr(Var), CoreExpr, varToCoreExpr ) @@ -61,7 +61,6 @@ import SrcLoc import Util import Control.Monad -import Data.Maybe import Maybes ( orElse ) \end{code} @@ -453,8 +452,9 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) badBootDeclErr ; (tyvars, theta, clas, inst_tys) <- tcHsInstHead InstDeclCtxt poly_ty - ; let mini_env = mkVarEnv (classTyVars clas `zip` inst_tys) - + ; let mini_env = mkVarEnv (classTyVars clas `zip` inst_tys) + mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env + -- Next, process any associated types. ; traceTc "tcLocalInstDecl" (ppr poly_ty) ; idx_tycons0 <- tcExtendTyVarEnv tyvars $ @@ -463,30 +463,37 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) -- Check for missing associated types and build them -- from their defaults (if available) ; let defined_ats = mkNameSet $ map (tcdName . unLoc) ats - check_at_instance (fam_tc, defs) + + mk_deflt_at_instances :: ClassATItem -> TcM [TyCon] + mk_deflt_at_instances (fam_tc, defs) -- User supplied instances ==> everything is OK - | tyConName fam_tc `elemNameSet` defined_ats = return (Nothing, []) + | tyConName fam_tc `elemNameSet` defined_ats + = return [] + -- No defaults ==> generate a warning - | null defs = return (Just (tyConName fam_tc), []) + | null defs + = do { warnMissingMethodOrAT "associated type" (tyConName fam_tc) + ; return [] } + -- No user instance, have defaults ==> instatiate them - | otherwise = do - defs' <- forM defs $ \(ATD tvs pat_tys rhs _loc) -> do - let mini_env_subst = mkTvSubst (mkInScopeSet (mkVarSet tvs)) mini_env - tvs' = varSetElems (tyVarsOfType rhs') - pat_tys' = substTys mini_env_subst pat_tys - rhs' = substTy mini_env_subst rhs - rep_tc_name <- newFamInstTyConName (noLoc (tyConName fam_tc)) pat_tys' - buildSynTyCon rep_tc_name tvs' - (SynonymTyCon rhs') - (mkArrowKinds (map tyVarKind tvs') (typeKind rhs')) - NoParentTyCon (Just (fam_tc, pat_tys')) - return (Nothing, defs') - ; missing_at_stuff <- mapM check_at_instance (classATItems clas) + -- Example: class C a where { type F a b :: *; type F a b = () } + -- instance C [x] + -- Then we want to generate the decl: type F [x] b = () + | otherwise + = forM defs $ \(ATD _tvs pat_tys rhs _loc) -> + do { let pat_tys' = substTys mini_subst pat_tys + rhs' = substTy mini_subst rhs + tv_set' = tyVarsOfTypes pat_tys' + tvs' = varSetElems tv_set' + ; rep_tc_name <- newFamInstTyConName (noLoc (tyConName fam_tc)) pat_tys' + ; ASSERT( tyVarsOfType rhs' `subVarSet` tv_set' ) + buildSynTyCon rep_tc_name tvs' + (SynonymTyCon rhs') + (typeKind rhs') + NoParentTyCon (Just (fam_tc, pat_tys')) } + + ; idx_tycons1 <- mapM mk_deflt_at_instances (classATItems clas) - ; let (omitted, idx_tycons1) = unzip missing_at_stuff - ; warn <- woptM Opt_WarnMissingMethods - ; mapM_ (warnTc warn . omittedATWarn) (catMaybes omitted) - -- Finally, construct the Core representation of the instance. -- (This no longer includes the associated types.) ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty) @@ -1007,7 +1014,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys tc_default sel_id NoDefMeth -- No default method at all = do { traceTc "tc_def: warn" (ppr sel_id) - ; warnMissingMethod sel_id + ; warnMissingMethodOrAT "method" (idName sel_id) ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id ; return (meth_id, mkVarBind meth_id $ @@ -1194,18 +1201,15 @@ derivBindCtxt sel_id clas tys _bind <+> quotes (pprClassPred clas tys) <> colon) , nest 2 $ ptext (sLit "To see the code I am typechecking, use -ddump-deriv") ] --- Too voluminous --- , nest 2 $ pprSetDepth AllTheWay $ ppr bind ] - -warnMissingMethod :: Id -> TcM () -warnMissingMethod sel_id +warnMissingMethodOrAT :: String -> Name -> TcM () +warnMissingMethodOrAT what name = do { warn <- woptM Opt_WarnMissingMethods - ; traceTc "warn" (ppr sel_id <+> ppr warn <+> ppr (not (startsWithUnderscore (getOccName sel_id)))) + ; traceTc "warn" (ppr name <+> ppr warn <+> ppr (not (startsWithUnderscore (getOccName name)))) ; warnTc (warn -- Warn only if -fwarn-missing-methods - && not (startsWithUnderscore (getOccName sel_id))) + && not (startsWithUnderscore (getOccName name))) -- Don't warn about _foo methods - (ptext (sLit "No explicit method nor default method for") - <+> quotes (ppr sel_id)) } + (ptext (sLit "No explicit") <+> text what <+> ptext (sLit "or default declaration for") + <+> quotes (ppr name)) } \end{code} Note [Export helper functions] @@ -1331,10 +1335,6 @@ instDeclCtxt2 dfun_ty inst_decl_ctxt :: SDoc -> SDoc inst_decl_ctxt doc = ptext (sLit "In the instance declaration for") <+> quotes doc -omittedATWarn :: Name -> SDoc -omittedATWarn at - = ptext (sLit "No explicit AT declaration for") <+> quotes (ppr at) - badBootFamInstDeclErr :: SDoc badBootFamInstDeclErr = ptext (sLit "Illegal family instance in hs-boot file") diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index 45e89a8274..b0eca45ebf 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -37,6 +37,8 @@ import FunDeps import TcEvidence import Outputable +import TcMType ( zonkTcPredType ) + import TcRnTypes import TcErrors import TcSMonad @@ -431,7 +433,16 @@ kick_out_rewritable ct (IS { inert_eqs = eqmap (fro_out, fro_in) = partitionBag rewritable frozen rewritable ct = (fl `canRewrite` cc_flavor ct) && - (tv `elemVarSet` tyVarsOfCt ct) + (tv `elemVarSet` tyVarsOfCt ct) + -- NB: tyVarsOfCt will return the type + -- variables /and the kind variables/ that are + -- directly visible in the type. Hence we will + -- have exposed all the rewriting we care about + -- to make the most precise kinds visible for + -- matching classes etc. No need to kick out + -- constraints that mention type variables whose + -- kinds could contain this variable! + \end{code} Note [Delicate equality kick-out] @@ -500,15 +511,9 @@ trySpontaneousSolve _ = return SPCantSolve trySpontaneousEqOneWay :: SubGoalDepth -> EqVar -> CtFlavor -> TcTyVar -> Xi -> TcS SPSolveResult -- tv is a MetaTyVar, not untouchable -trySpontaneousEqOneWay d eqv gw tv xi - | not (isSigTyVar tv) || isTyVarTy xi - = do { let kxi = typeKind xi -- NB: 'xi' is fully rewritten according to the inerts - -- so we have its more specific kind in our hands - ; is_sub_kind <- kxi `isSubKindTcS` tyVarKind tv - ; if is_sub_kind then - solveWithIdentity d eqv gw tv xi - else return SPCantSolve - } +trySpontaneousEqOneWay d eqv gw tv xi + | not (isSigTyVar tv) || isTyVarTy xi + = solveWithIdentity d eqv gw tv xi | otherwise -- Still can't solve, sig tyvar and non-variable rhs = return SPCantSolve @@ -518,13 +523,10 @@ trySpontaneousEqTwoWay :: SubGoalDepth -- Both tyvars are *touchable* MetaTyvars so there is only a chance for kind error here trySpontaneousEqTwoWay d eqv gw tv1 tv2 - = do { k1_sub_k2 <- k1 `isSubKindTcS` k2 + = do { let k1_sub_k2 = k1 `isSubKind` k2 ; if k1_sub_k2 && nicer_to_update_tv2 then solveWithIdentity d eqv gw tv2 (mkTyVarTy tv1) - else do - { k2_sub_k1 <- k2 `isSubKindTcS` k1 - ; MASSERT( k2_sub_k1 ) -- they were unified in TcCanonical - ; solveWithIdentity d eqv gw tv1 (mkTyVarTy tv2) } } + else solveWithIdentity d eqv gw tv1 (mkTyVarTy tv2) } where k1 = tyVarKind tv1 k2 = tyVarKind tv2 @@ -771,7 +773,6 @@ doInteractWithInert , text "Inert item=" <+> ppr inertItem ] - -- Two pieces of irreducible evidence: if their types are *exactly identical* we can -- rewrite them. We can never improve using this: if we want ty1 :: Constraint and have -- ty2 :: Constraint it clearly does not mean that (ty1 ~ ty2) @@ -1262,6 +1263,116 @@ When we react a family instance with a type family equation in the work list we keep the synonym-using RHS without expansion. +%************************************************************************ +%* * +%* Functional dependencies, instantiation of equations +%* * +%************************************************************************ + +When we spot an equality arising from a functional dependency, +we now use that equality (a "wanted") to rewrite the work-item +constraint right away. This avoids two dangers + + Danger 1: If we send the original constraint on down the pipeline + it may react with an instance declaration, and in delicate + situations (when a Given overlaps with an instance) that + may produce new insoluble goals: see Trac #4952 + + Danger 2: If we don't rewrite the constraint, it may re-react + with the same thing later, and produce the same equality + again --> termination worries. + +To achieve this required some refactoring of FunDeps.lhs (nicer +now!). + +\begin{code} +rewriteWithFunDeps :: [Equation] + -> [Xi] + -> WantedLoc + -> TcS (Maybe ([Xi], [TcCoercion], [(EvVar,WantedLoc)])) + -- Not quite a WantedEvVar unfortunately + -- Because our intention could be to make + -- it derived at the end of the day +-- NB: The flavor of the returned EvVars will be decided by the caller +-- Post: returns no trivial equalities (identities) and all EvVars returned are fresh +rewriteWithFunDeps eqn_pred_locs xis wloc + = do { fd_ev_poss <- mapM (instFunDepEqn wloc) eqn_pred_locs + ; let fd_ev_pos :: [(Int,(EqVar,WantedLoc))] + fd_ev_pos = concat fd_ev_poss + (rewritten_xis, cos) = unzip (rewriteDictParams fd_ev_pos xis) + ; if null fd_ev_pos then return Nothing + else return (Just (rewritten_xis, cos, map snd fd_ev_pos)) } + +instFunDepEqn :: WantedLoc -> Equation -> TcS [(Int,(EvVar,WantedLoc))] +-- Post: Returns the position index as well as the corresponding FunDep equality +instFunDepEqn wl (FDEqn { fd_qtvs = qtvs, fd_eqs = eqs + , fd_pred1 = d1, fd_pred2 = d2 }) + = do { let tvs = varSetElems qtvs + ; tvs' <- mapM instFlexiTcS tvs -- IA0_TODO: we might need to do kind substitution + ; let subst = zipTopTvSubst tvs (mkTyVarTys tvs') + ; foldM (do_one subst) [] eqs } + where + do_one subst ievs (FDEq { fd_pos = i, fd_ty_left = ty1, fd_ty_right = ty2 }) + = let sty1 = Type.substTy subst ty1 + sty2 = Type.substTy subst ty2 + in if eqType sty1 sty2 then return ievs -- Return no trivial equalities + else do { eqv <- newEqVar (Derived wl) sty1 sty2 -- Create derived or cached by deriveds + ; let wl' = push_ctx wl + ; if isNewEvVar eqv then + return $ (i,(evc_the_evvar eqv,wl')):ievs + else -- We are eventually going to emit FD work back in the work list so + -- it is important that we only return the /freshly created/ and not + -- some existing equality! + return ievs } + + push_ctx :: WantedLoc -> WantedLoc + push_ctx loc = pushErrCtxt FunDepOrigin (False, mkEqnMsg d1 d2) loc + +mkEqnMsg :: (TcPredType, SDoc) + -> (TcPredType, SDoc) -> TidyEnv -> TcM (TidyEnv, SDoc) +mkEqnMsg (pred1,from1) (pred2,from2) tidy_env + = do { zpred1 <- zonkTcPredType pred1 + ; zpred2 <- zonkTcPredType pred2 + ; let { tpred1 = tidyType tidy_env zpred1 + ; tpred2 = tidyType tidy_env zpred2 } + ; let msg = vcat [ptext (sLit "When using functional dependencies to combine"), + nest 2 (sep [ppr tpred1 <> comma, nest 2 from1]), + nest 2 (sep [ppr tpred2 <> comma, nest 2 from2])] + ; return (tidy_env, msg) } + +rewriteDictParams :: [(Int,(EqVar,WantedLoc))] -- A set of coercions : (pos, ty' ~ ty) + -> [Type] -- A sequence of types: tys + -> [(Type, TcCoercion)] -- Returns: [(ty', co : ty' ~ ty)] +rewriteDictParams param_eqs tys + = zipWith do_one tys [0..] + where + do_one :: Type -> Int -> (Type, TcCoercion) + do_one ty n = case lookup n param_eqs of + Just wev -> (get_fst_ty wev, mkTcCoVarCo (fst wev)) + Nothing -> (ty, mkTcReflCo ty) -- Identity + + get_fst_ty (wev,_wloc) + | Just (ty1, _) <- getEqPredTys_maybe (evVarPred wev ) + = ty1 + | otherwise + = panic "rewriteDictParams: non equality fundep!?" + + +emitFDWorkAsDerived :: [(EvVar,WantedLoc)] + -> SubGoalDepth -> TcS () +emitFDWorkAsDerived evlocs d + = updWorkListTcS $ appendWorkListEqs fd_cts + where fd_cts = map mk_fd_ct evlocs + mk_fd_ct (v,wl) = CNonCanonical { cc_id = v + , cc_flavor = Derived wl + , cc_depth = d } + + +\end{code} + + + + ********************************************************************************* * * The top-reaction Stage @@ -1500,6 +1611,7 @@ Then it is solvable, but its very hard to detect this on the spot. It's exactly the same with implicit parameters, except that the "aggressive" approach would be much easier to implement. + Note [When improvement happens] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We fire an improvement rule when diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs index d09e384834..1474686c15 100644 --- a/compiler/typecheck/TcMatches.lhs +++ b/compiler/typecheck/TcMatches.lhs @@ -832,7 +832,8 @@ tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names ; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids , recS_rec_ids = rec_ids, recS_ret_fn = ret_op' , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op' - , recS_rec_rets = tup_rets, recS_ret_ty = stmts_ty }, thing) + , recS_later_rets = [], recS_rec_rets = tup_rets + , recS_ret_ty = stmts_ty }, thing) }} tcDoStmt _ stmt _ _ diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 381d5355d1..08125d75d0 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -23,6 +23,8 @@ import Module import RdrName import Name import Type +import Kind ( isSuperKind ) + import TcType import InstEnv import FamInstEnv @@ -1042,8 +1044,13 @@ captureUntouchables thing_inside ; return (res, TouchableRange low_meta high_meta) } isUntouchable :: TcTyVar -> TcM Bool -isUntouchable tv = do { env <- getLclEnv - ; return (varUnique tv < tcl_untch env) } +isUntouchable tv + -- Kind variables are always touchable + | isSuperKind (tyVarKind tv) + = return False + | otherwise + = do { env <- getLclEnv + ; return (varUnique tv < tcl_untch env) } getLclTypeEnv :: TcM TcTypeEnv getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) } diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index ab26fa1e09..b85a892651 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -66,7 +66,8 @@ module TcRnTypes( Implication(..), CtLoc(..), ctLocSpan, ctLocOrigin, setCtLocOrigin, CtOrigin(..), EqOrigin(..), - WantedLoc, GivenLoc, GivenKind(..), pushErrCtxt, + WantedLoc, GivenLoc, GivenKind(..), pushErrCtxt, + pushErrCtxtSameOrigin, SkolemInfo(..), @@ -1296,6 +1297,10 @@ setCtLocOrigin (CtLoc _ s c) o = CtLoc o s c pushErrCtxt :: orig -> ErrCtxt -> CtLoc orig -> CtLoc orig pushErrCtxt o err (CtLoc _ s errs) = CtLoc o s (err:errs) +pushErrCtxtSameOrigin :: ErrCtxt -> CtLoc orig -> CtLoc orig +-- Just add information w/o updating the origin! +pushErrCtxtSameOrigin err (CtLoc o s errs) = CtLoc o s (err:errs) + pprArising :: CtOrigin -> SDoc -- Used for the main, top-level error message -- We've done special processing for TypeEq and FunDep origins diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index 87b2da1cbb..aabc7372e1 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -60,7 +60,7 @@ module TcSMonad ( -- Inerts InertSet(..), - getInertEqs, liftInertEqsTy, getCtCoercion, + getInertEqs, getCtCoercion, emptyInert, getTcSInerts, updInertSet, extractUnsolved, extractUnsolvedTcS, modifyInertTcS, updInertSetTcS, partitionCCanMap, partitionEqMap, @@ -72,7 +72,7 @@ module TcSMonad ( instDFunConstraints, newFlexiTcSTy, instFlexiTcS, - compatKind, compatKindTcS, isSubKindTcS, unifyKindTcS, + compatKind, mkKindErrorCtxtTcS, TcsUntouchables, isTouchableMetaTyVar, @@ -104,7 +104,7 @@ import qualified TcRnMonad as TcM import qualified TcMType as TcM import qualified TcEnv as TcM ( checkWellStaged, topIdLvl, tcGetDefaultTys ) -import {-# SOURCE #-} qualified TcUnify as TcM ( unifyKindEq, mkKindErrorCtxt ) +import {-# SOURCE #-} qualified TcUnify as TcM ( mkKindErrorCtxt ) import Kind import TcType import DynFlags @@ -113,7 +113,6 @@ import Type import TcEvidence import Class import TyCon -import TypeRep import Name import Var @@ -145,23 +144,12 @@ import TrieMap compatKind :: Kind -> Kind -> Bool compatKind k1 k2 = k1 `isSubKind` k2 || k2 `isSubKind` k1 -compatKindTcS :: Kind -> Kind -> TcS Bool --- Because kind unification happens during constraint solving, we have --- to make sure that two kinds are zonked before we compare them. -compatKindTcS k1 k2 = wrapTcS (TcM.compatKindTcM k1 k2) - -isSubKindTcS :: Kind -> Kind -> TcS Bool -isSubKindTcS k1 k2 = wrapTcS (TcM.isSubKindTcM k1 k2) - -unifyKindTcS :: Type -> Type -- Context - -> Kind -> Kind -- Corresponding kinds - -> TcS Bool -unifyKindTcS ty1 ty2 ki1 ki2 - = wrapTcS $ TcM.addErrCtxtM ctxt $ do - (_errs, mb_r) <- TcM.tryTc (TcM.unifyKindEq ki1 ki2) - return (maybe False (const True) mb_r) - where - ctxt = TcM.mkKindErrorCtxt ty1 ki1 ty2 ki2 +mkKindErrorCtxtTcS :: Type -> Kind + -> Type -> Kind + -> ErrCtxt +mkKindErrorCtxtTcS ty1 ki1 ty2 ki2 + = (False,TcM.mkKindErrorCtxt ty1 ty2 ki1 ki2) + \end{code} %************************************************************************ @@ -1010,8 +998,8 @@ emitFrozenError fl ev depth inerts_new = inerts { inert_frozen = extendCts (inert_frozen inerts) ct } ; wrapTcS (TcM.writeTcRef inert_ref inerts_new) } -getDynFlags :: TcS DynFlags -getDynFlags = wrapTcS TcM.getDOpts +instance HasDynFlags TcS where + getDynFlags = wrapTcS TcM.getDOpts getTcSContext :: TcS SimplContext getTcSContext = TcS (return . tcs_context) @@ -1506,68 +1494,5 @@ getCtCoercion ct -- Instead we use the most accurate type, given by ctPred c where maybe_given = isGiven_maybe (cc_flavor ct) --- See Note [LiftInertEqs] -liftInertEqsTy :: (TyVarEnv (Ct, TcCoercion),InScopeSet) - -> CtFlavor - -> PredType -> TcCoercion -liftInertEqsTy (subst,inscope) fl pty - = ty_cts_subst subst inscope fl pty - - -ty_cts_subst :: TyVarEnv (Ct, TcCoercion) - -> InScopeSet -> CtFlavor -> Type -> TcCoercion -ty_cts_subst subst inscope fl ty - = go ty - where - go ty = go' ty - - go' (TyVarTy tv) = tyvar_cts_subst tv `orElse` mkTcReflCo (TyVarTy tv) - go' (AppTy ty1 ty2) = mkTcAppCo (go ty1) (go ty2) - go' (TyConApp tc tys) = mkTcTyConAppCo tc (map go tys) - go' ty@(LiteralTy _) = mkTcReflCo ty - - go' (ForAllTy v ty) = mkTcForAllCo v' $! co - where - (subst',inscope',v') = upd_tyvar_bndr subst inscope v - co = ty_cts_subst subst' inscope' fl ty - - go' (FunTy ty1 ty2) = mkTcFunCo (go ty1) (go ty2) - - - tyvar_cts_subst tv - | Just (ct,co) <- lookupVarEnv subst tv, cc_flavor ct `canRewrite` fl - = Just co -- Warn: use cached, not cc_id directly, because of alpha-renamings! - | otherwise = Nothing - - upd_tyvar_bndr subst inscope v - = (new_subst, (inscope `extendInScopeSet` new_v), new_v) - where new_subst - | no_change = delVarEnv subst v - -- Otherwise we have to extend the environment with /something/. - -- But we do not want to monadically create a new EvVar. So, we - -- create an 'unused_ct' but we cache reflexivity as the - -- associated coercion. - | otherwise = extendVarEnv subst v (unused_ct, mkTcReflCo (TyVarTy new_v)) - - no_change = new_v == v - new_v = uniqAway inscope v - - unused_ct = CTyEqCan { cc_id = unused_evvar - , cc_flavor = fl -- canRewrite is reflexive. - , cc_tyvar = v - , cc_rhs = mkTyVarTy new_v - , cc_depth = unused_depth } - unused_depth = panic "ty_cts_subst: This depth should not be accessed!" - unused_evvar = panic "ty_cts_subst: This var is just an alpha-renaming!" -\end{code} - -Note [LiftInertEqsTy] -~~~~~~~~~~~~~~~~~~~~~~~ -The function liftInertEqPred behaves almost like liftCoSubst (in -Coercion), but accepts a map TyVarEnv (Ct,Coercion) instead of a -LiftCoSubst. This data structure is more convenient to use since we -must apply the inert substitution /only/ if the inert equality -`canRewrite` the work item. There's admittedly some duplication of -functionality but it would be more tedious to cache and maintain -different flavors of LiftCoSubst structures in the inerts. +\end{code}
\ No newline at end of file diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 46bc7e1145..5653a153ce 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -369,14 +369,15 @@ tc_bracket :: ThStage -> HsBracket Name -> TcM TcType tc_bracket outer_stage br@(VarBr _ name) -- Note [Quoting names] = do { thing <- tcLookup name ; case thing of - AGlobal _ -> return () + AGlobal {} -> return () + ATyVar {} -> return () ATcId { tct_level = bind_lvl, tct_id = id } | thTopLevelId id -- C.f TcExpr.checkCrossStageLifting -> keepAliveTc id | otherwise -> do { checkTc (thLevel outer_stage + 1 == bind_lvl) (quotedNameStageErr br) } - _ -> pprPanic "th_bracket" (ppr name) + _ -> pprPanic "th_bracket" (ppr name $$ ppr thing) ; tcMetaTy nameTyConName -- Result type is Var (not Q-monadic) } diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index 0ac5f14be8..808d538443 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -185,6 +185,7 @@ import Maybes import ListSetOps import Outputable import FastString + import Data.List( mapAccumL ) import Data.IORef \end{code} diff --git a/compiler/types/Class.lhs b/compiler/types/Class.lhs index cda98de45e..992fde7920 100644 --- a/compiler/types/Class.lhs +++ b/compiler/types/Class.lhs @@ -105,7 +105,7 @@ type ClassATItem = (TyCon, [ATDefault]) -- Each associated type default template is a triple of: data ATDefault = ATD { -- TyVars of the RHS and family arguments - -- (including the class TVs) + -- (including, but perhaps more than, the class TVs) atDefaultTys :: [TyVar], -- The instantiated family arguments atDefaultPats :: [Type], diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index 9f5b6b1d75..c830a12ac3 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -284,7 +284,7 @@ isLiftedTypeKind _ = False \begin{code} tyVarsOfType :: Type -> VarSet -- ^ NB: for type synonyms tyVarsOfType does /not/ expand the synonym --- tyVarsOfType returns only the free *type* variables of a type +-- tyVarsOfType returns only the free variables of a type -- For example, tyVarsOfType (a::k) returns {a}, not including the -- kind variable {k} tyVarsOfType (TyVarTy v) = unitVarSet v @@ -528,7 +528,9 @@ instance Outputable TyLit where ppr = pprTyLit instance Outputable name => OutputableBndr (IPName name) where - pprBndr _ n = ppr n -- Simple for now + pprBndr _ n = ppr n -- Simple for now + pprInfixOcc n = ppr n + pprPrefixOcc n = ppr n ------------------ -- OK, here's the main printer diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index 5263081c9a..248f549aa3 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -22,7 +22,7 @@ module Outputable ( empty, nest, char, text, ftext, ptext, - int, integer, float, double, rational, + int, intWithCommas, integer, float, double, rational, parens, cparen, brackets, braces, quotes, quote, doubleQuotes, angleBrackets, semi, comma, colon, dcolon, space, equals, dot, arrow, darrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, @@ -48,7 +48,7 @@ module Outputable ( renderWithStyle, pprInfixVar, pprPrefixVar, - pprHsChar, pprHsString, pprHsInfix, pprHsVar, + pprHsChar, pprHsString, pprFastFilePath, -- * Controlling the style in which output is printed @@ -743,6 +743,11 @@ data BindingSite = LambdaBind | CaseBind | LetBind class Outputable a => OutputableBndr a where pprBndr :: BindingSite -> a -> SDoc pprBndr _b x = ppr x + + pprPrefixOcc, pprInfixOcc :: a -> SDoc + -- Print an occurrence of the name, suitable either in the + -- prefix position of an application, thus (f a b) or ((+) x) + -- or infix position, thus (a `f` b) or (x + y) \end{code} %************************************************************************ @@ -777,27 +782,6 @@ pprInfixVar is_operator pp_v | otherwise = char '`' <> pp_v <> char '`' --------------------- --- pprHsVar and pprHsInfix use the gruesome isOperator, which --- in turn uses (showSDoc (ppr v)), rather than isSymOcc (getOccName v). --- Reason: it means that pprHsVar doesn't need a NamedThing context, --- which none of the HsSyn printing functions do -pprHsVar, pprHsInfix :: Outputable name => name -> SDoc -pprHsVar v = pprPrefixVar (isOperator pp_v) pp_v - where pp_v = ppr v -pprHsInfix v = pprInfixVar (isOperator pp_v) pp_v - where pp_v = ppr v - -isOperator :: SDoc -> Bool -isOperator ppr_v - = case showSDocUnqual ppr_v of - ('(':_) -> False -- (), (,) etc - ('[':_) -> False -- [] - ('$':c:_) -> not (isAlpha c) -- Don't treat $d as an operator - (':':c:_) -> not (isAlpha c) -- Don't treat :T as an operator - ('_':_) -> False -- Not an operator - (c:_) -> not (isAlpha c) -- Starts with non-alpha - _ -> False - pprFastFilePath :: FastString -> SDoc pprFastFilePath path = text $ normalise $ unpackFS path \end{code} @@ -846,6 +830,15 @@ quotedListWithOr xs = quotedList xs %************************************************************************ \begin{code} +intWithCommas :: Integral a => a -> SDoc +-- Prints a big integer with commas, eg 345,821 +intWithCommas n + | n < 0 = char '-' <> intWithCommas (-n) + | q == 0 = int (fromIntegral r) + | otherwise = intWithCommas q <> comma <> int (fromIntegral r) + where + (q,r) = n `quotRem` 1000 + -- | Converts an integer to a verbal index: -- -- > speakNth 1 = text "first" diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs index 0720eae113..93800b0399 100644 --- a/compiler/utils/Util.lhs +++ b/compiler/utils/Util.lhs @@ -1,17 +1,11 @@ % % (c) The University of Glasgow 2006 -% (c) The University of Glasgow 1992-2002 % \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 -- | Highly random utility functions +-- module Util ( -- * Flags dependent on the compiler build ghciSupported, debugIsOn, ncgDebugIsOn, @@ -21,13 +15,13 @@ module Util ( -- * General list processing zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal, zipLazy, stretchZipWith, - + unzipWith, - + mapFst, mapSnd, mapAndUnzip, mapAndUnzip3, nOfThem, filterOut, partitionWith, splitEithers, - + foldl1', foldl2, count, all2, lengthExceeds, lengthIs, lengthAtLeast, @@ -51,13 +45,13 @@ module Util ( nTimes, -- * Sorting - sortLe, sortWith, minWith, on, + sortLe, sortWith, minWith, on, -- * Comparisons isEqual, eqListBy, eqMaybeBy, thenCmp, cmpList, removeSpaces, - + -- * Edit distance fuzzyMatch, fuzzyLookup, @@ -219,9 +213,9 @@ nTimes n f = f . nTimes (n-1) f \end{code} \begin{code} -fstOf3 :: (a,b,c) -> a -sndOf3 :: (a,b,c) -> b -thirdOf3 :: (a,b,c) -> c +fstOf3 :: (a,b,c) -> a +sndOf3 :: (a,b,c) -> b +thirdOf3 :: (a,b,c) -> c fstOf3 (a,_,_) = a sndOf3 (_,b,_) = b thirdOf3 (_,_,c) = c @@ -760,7 +754,7 @@ restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2 restrictedDamerauLevenshteinDistance' :: (Bits bv) => bv -> Int -> Int -> String -> String -> Int -restrictedDamerauLevenshteinDistance' _bv_dummy m n str1 str2 +restrictedDamerauLevenshteinDistance' _bv_dummy m n str1 str2 | [] <- str1 = n | otherwise = extractAnswer $ foldl' (restrictedDamerauLevenshteinDistanceWorker @@ -782,19 +776,19 @@ restrictedDamerauLevenshteinDistanceWorker str1_mvs top_bit_mask vector_mask (pm', d0', vp', vn', distance'') where pm' = IM.findWithDefault 0 (ord char2) str1_mvs - + d0' = ((((sizedComplement vector_mask d0) .&. pm') `shiftL` 1) .&. pm) .|. ((((pm' .&. vp) + vp) .&. vector_mask) `xor` vp) .|. pm' .|. vn -- No need to mask the shiftL because of the restricted range of pm hp' = vn .|. sizedComplement vector_mask (d0' .|. vp) hn' = d0' .&. vp - + hp'_shift = ((hp' `shiftL` 1) .|. 1) .&. vector_mask hn'_shift = (hn' `shiftL` 1) .&. vector_mask vp' = hn'_shift .|. sizedComplement vector_mask (d0' .|. hp'_shift) vn' = d0' .&. hp'_shift - + distance' = if hp' .&. top_bit_mask /= 0 then distance + 1 else distance distance'' = if hn' .&. top_bit_mask /= 0 then distance' - 1 else distance' @@ -843,16 +837,16 @@ fuzzyLookup user_entered possibilites poss_str user_entered , distance <= fuzzy_threshold ] where - -- Work out an approriate match threshold: - -- We report a candidate if its edit distance is <= the threshold, + -- Work out an approriate match threshold: + -- We report a candidate if its edit distance is <= the threshold, -- The threshhold is set to about a quarter of the # of characters the user entered - -- Length Threshold - -- 1 0 -- Don't suggest *any* candidates - -- 2 1 -- for single-char identifiers - -- 3 1 - -- 4 1 - -- 5 1 - -- 6 2 + -- Length Threshold + -- 1 0 -- Don't suggest *any* candidates + -- 2 1 -- for single-char identifiers + -- 3 1 + -- 4 1 + -- 5 1 + -- 6 2 -- fuzzy_threshold = truncate $ fromIntegral (length user_entered + 2) / (4 :: Rational) mAX_RESULTS = 3 @@ -1129,14 +1123,15 @@ abstractDataType n = mkDataType n [abstractConstr n] \begin{code} charToC :: Word8 -> String -charToC w = +charToC w = case chr (fromIntegral w) of - '\"' -> "\\\"" - '\'' -> "\\\'" - '\\' -> "\\\\" - c | c >= ' ' && c <= '~' -> [c] + '\"' -> "\\\"" + '\'' -> "\\\'" + '\\' -> "\\\\" + c | c >= ' ' && c <= '~' -> [c] | otherwise -> ['\\', chr (ord '0' + ord c `div` 64), chr (ord '0' + ord c `div` 8 `mod` 8), chr (ord '0' + ord c `mod` 8)] \end{code} + |