diff options
68 files changed, 1880 insertions, 1654 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} + diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index 7443abfb23..1923a7f8a8 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -2944,6 +2944,20 @@ data Counter a where As before, only one selector function is generated here, that for <literal>tag</literal>. Nevertheless, you can still use all the field names in pattern matching and record construction. </para></listitem> + +<listitem><para> +In a GADT-style data type declaration there is no obvious way to specify that a data constructor +should be infix, which makes a difference if you derive <literal>Show</literal> for the type. +(Data constructors declared infix are displayed infix by the derived <literal>show</literal>.) +So GHC implements the following design: a data constructor declared in a GADT-style data type +declaration is displayed infix by <literal>Show</literal> iff (a) it is an operator symbol, +(b) it has two arguments, (c) it has a programmer-supplied fixity declaration. For example +<programlisting> + infix 6 (:--:) + data T a where + (:--:) :: Int -> Bool -> T Int +</programlisting> +</para></listitem> </itemizedlist></para> </sect2> @@ -5300,7 +5314,8 @@ Sum k1 k2 :: BOX L :: k1 -> Sum k1 k2 R :: k2 -> Sum k1 k2 </programlisting> -Note that <literal>List</literal>, for instance, does not get kind +where <literal>BOX</literal> is the (unique) sort that classifies kinds. +Note that <literal>List</literal>, for instance, does not get sort <literal>BOX -> BOX</literal>, because we do not further classify kinds; all kinds have sort <literal>BOX</literal>. </para> diff --git a/ghc/GhciMonad.hs b/ghc/GhciMonad.hs index 55d8946c4f..be9a9f6b2f 100644 --- a/ghc/GhciMonad.hs +++ b/ghc/GhciMonad.hs @@ -1,13 +1,6 @@ {-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-} -- -fno-cse is needed for GLOBAL_VAR's to behave properly -{-# 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#TabsvsSp --- for details - ----------------------------------------------------------------------------- -- -- Monadery code used in InteractiveUI @@ -56,13 +49,13 @@ import Control.Monad.Trans as Trans type Command = (String, String -> InputT GHCi Bool, CompletionFunc GHCi) data GHCiState = GHCiState - { - progname :: String, - args :: [String], + { + progname :: String, + args :: [String], prompt :: String, - editor :: String, + editor :: String, stop :: String, - options :: [GHCiOption], + options :: [GHCiOption], line_number :: !Int, -- input line break_ctr :: !Int, breaks :: ![(Int, BreakLocation)], @@ -97,12 +90,12 @@ data GHCiState = GHCiState type TickArray = Array Int [(BreakIndex,SrcSpan)] -data GHCiOption - = ShowTiming -- show time/allocs after evaluation - | ShowType -- show the type of expressions - | RevertCAFs -- revert CAFs after every evaluation +data GHCiOption + = ShowTiming -- show time/allocs after evaluation + | ShowType -- show the type of expressions + | RevertCAFs -- revert CAFs after every evaluation | Multiline -- use multiline commands - deriving Eq + deriving Eq data BreakLocation = BreakLocation @@ -110,14 +103,14 @@ data BreakLocation , breakLoc :: !SrcSpan , breakTick :: {-# UNPACK #-} !Int , onBreakCmd :: String - } + } instance Eq BreakLocation where loc1 == loc2 = breakModule loc1 == breakModule loc2 && breakTick loc1 == breakTick loc2 prettyLocations :: [(Int, BreakLocation)] -> SDoc -prettyLocations [] = text "No active breakpoints." +prettyLocations [] = text "No active breakpoints." prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs instance Outputable BreakLocation where @@ -129,7 +122,7 @@ instance Outputable BreakLocation where recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int) recordBreak brkLoc = do st <- getGHCiState - let oldActiveBreaks = breaks st + let oldActiveBreaks = breaks st -- don't store the same break point twice case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of (nm:_) -> return (True, nm) @@ -183,10 +176,16 @@ instance MonadUtils.MonadIO GHCi where instance Trans.MonadIO Ghc where liftIO = MonadUtils.liftIO +instance HasDynFlags GHCi where + getDynFlags = getSessionDynFlags + instance GhcMonad GHCi where setSession s' = liftGhc $ setSession s' getSession = liftGhc $ getSession +instance HasDynFlags (InputT GHCi) where + getDynFlags = lift getDynFlags + instance GhcMonad (InputT GHCi) where setSession = lift . setSession getSession = lift getSession @@ -212,7 +211,7 @@ instance Haskeline.MonadException GHCi where catch = gcatch block = gblock unblock = gunblock - -- XXX when Haskeline's MonadException changes, we can drop our + -- XXX when Haskeline's MonadException changes, we can drop our -- deprecated block/unblock methods instance ExceptionMonad (InputT GHCi) where @@ -221,12 +220,8 @@ instance ExceptionMonad (InputT GHCi) where gblock = Haskeline.block gunblock = Haskeline.unblock -getDynFlags :: GhcMonad m => m DynFlags -getDynFlags = do - GHC.getSessionDynFlags - setDynFlags :: DynFlags -> GHCi [PackageId] -setDynFlags dflags = do +setDynFlags dflags = do GHC.setSessionDynFlags dflags isOptionSet :: GHCiOption -> GHCi Bool @@ -261,7 +256,7 @@ runStmt expr step = do withProgName (progname st) $ withArgs (args st) $ reflectGHCi x $ do - GHC.handleSourceError (\e -> do GHC.printException e; + GHC.handleSourceError (\e -> do GHC.printException e; return Nothing) $ do r <- GHC.runStmtWithLocation (progname st) (line_number st) expr step return (Just r) @@ -291,41 +286,41 @@ resume canLogSpan step = do timeIt :: InputT GHCi a -> InputT GHCi a timeIt action = do b <- lift $ isOptionSet ShowTiming - if not b - then action - else do allocs1 <- liftIO $ getAllocations - time1 <- liftIO $ getCPUTime - a <- action - allocs2 <- liftIO $ getAllocations - time2 <- liftIO $ getCPUTime - liftIO $ printTimes (fromIntegral (allocs2 - allocs1)) - (time2 - time1) - return a + if not b + then action + else do allocs1 <- liftIO $ getAllocations + time1 <- liftIO $ getCPUTime + a <- action + allocs2 <- liftIO $ getAllocations + time2 <- liftIO $ getCPUTime + liftIO $ printTimes (fromIntegral (allocs2 - allocs1)) + (time2 - time1) + return a foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64 - -- defined in ghc/rts/Stats.c + -- defined in ghc/rts/Stats.c printTimes :: Integer -> Integer -> IO () printTimes allocs psecs = do let secs = (fromIntegral psecs / (10^(12::Integer))) :: Float - secs_str = showFFloat (Just 2) secs - putStrLn (showSDoc ( - parens (text (secs_str "") <+> text "secs" <> comma <+> - text (show allocs) <+> text "bytes"))) + secs_str = showFFloat (Just 2) secs + putStrLn (showSDoc ( + parens (text (secs_str "") <+> text "secs" <> comma <+> + text (show allocs) <+> text "bytes"))) ----------------------------------------------------------------------------- -- reverting CAFs - + revertCAFs :: GHCi () revertCAFs = do liftIO rts_revertCAFs s <- getGHCiState when (not (ghc_e s)) $ liftIO turnOffBuffering - -- Have to turn off buffering again, because we just - -- reverted stdout, stderr & stdin to their defaults. + -- Have to turn off buffering again, because we just + -- reverted stdout, stderr & stdin to their defaults. -foreign import ccall "revertCAFs" rts_revertCAFs :: IO () - -- Make it "safe", just in case +foreign import ccall "revertCAFs" rts_revertCAFs :: IO () + -- Make it "safe", just in case ----------------------------------------------------------------------------- -- To flush buffers for the *interpreted* computation we need @@ -381,3 +376,4 @@ getHandle :: IORef (Ptr ()) -> IO Handle getHandle ref = do (Ptr addr) <- readIORef ref case addrToAny# addr of (# hval #) -> return (unsafeCoerce# hval) + diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 0525f4098c..cc4be40f44 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -1,14 +1,6 @@ {-# OPTIONS -fno-cse #-} -- -fno-cse is needed for GLOBAL_VAR's to behave properly -{-# 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#TabsvsSp --- for details - -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} ----------------------------------------------------------------------------- -- -- GHC Interactive User Interface @@ -21,84 +13,88 @@ module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where #include "HsVersions.h" -import qualified GhciMonad -import GhciMonad hiding ( runStmt ) +-- GHCi +import qualified GhciMonad ( args, runStmt ) +import GhciMonad hiding ( args, runStmt ) import GhciTags import Debugger -- The GHC interface +import DynFlags import qualified GHC import GHC ( LoadHowMuch(..), Target(..), TargetId(..), InteractiveImport(..), TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc, handleSourceError ) -import PprTyThing -import DynFlags -import qualified Lexer -import StringBuffer - -import Packages -import UniqFM - -import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, dep_pkgs ) import HsImpExp -import RdrName ( getGRE_NameQualifier_maybes ) -import Outputable hiding ( printForUser, printForUserPartWay, bold ) +import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, dep_pkgs ) import Module import Name +import Packages ( trusted, getPackageDetails, exposed, exposedModules, pkgIdMap ) +import PprTyThing +import RdrName ( getGRE_NameQualifier_maybes ) import SrcLoc +import qualified Lexer + +import StringBuffer +import UniqFM ( eltsUFM ) +import Outputable hiding ( printForUser, printForUserPartWay, bold ) -- Other random utilities -import Digraph import BasicTypes hiding ( isTopLevel ) -import Panic hiding ( showException ) import Config -import StaticFlags +import Digraph +import Encoding +import FastString import Linker -import Util( on, global, toArgs, toCmdArgs, removeSpaces, getCmd, - filterOut, seqList, looksLikeModuleName, partitionWith ) -import NameSet import Maybes ( orElse, expectJust ) -import FastString -import Encoding -import Foreign.C - -#ifndef mingw32_HOST_OS -import System.Posix hiding ( getEnv ) -#else -import qualified System.Win32 -#endif +import NameSet +import Panic hiding ( showException ) +import StaticFlags +import Util ( on, global, toArgs, toCmdArgs, removeSpaces, getCmd, + filterOut, seqList, looksLikeModuleName, partitionWith ) +-- Haskell Libraries import System.Console.Haskeline as Haskeline import qualified System.Console.Haskeline.Encoding as Encoding -import Control.Monad.Trans -import Exception hiding (catch, block, unblock) +import Control.Applicative hiding (empty) +import Control.Monad as Monad +import Control.Monad.Trans -import System.FilePath +import Data.Array import qualified Data.ByteString.Char8 as BS -import Data.List +import Data.Char +import Data.IORef ( IORef, readIORef, writeIORef ) +import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub, + partition, sort, sortBy ) import Data.Maybe + +import Exception hiding (catch, block, unblock) + +import Foreign.C +import Foreign.Safe + import System.Cmd +import System.Directory import System.Environment import System.Exit ( exitWith, ExitCode(..) ) -import System.Directory +import System.FilePath import System.IO -import System.IO.Unsafe ( unsafePerformIO ) import System.IO.Error -import Data.Char -import Data.Array -import Control.Monad as Monad +import System.IO.Unsafe ( unsafePerformIO ) import Text.Printf -import Foreign.Safe -import GHC.Exts ( unsafeCoerce# ) -import Control.Applicative hiding (empty) +#ifndef mingw32_HOST_OS +import System.Posix hiding ( getEnv ) +#else +import qualified System.Win32 +#endif + +import GHC.Exts ( unsafeCoerce# ) import GHC.IO.Exception ( IOErrorType(InvalidArgument) ) import GHC.IO.Handle ( hFlushAll ) +import GHC.TopHandler ( topHandler ) -import GHC.TopHandler - -import Data.IORef ( IORef, readIORef, writeIORef ) ----------------------------------------------------------------------------- @@ -162,12 +158,12 @@ builtin_commands = [ ] --- We initialize readline (in the interactiveUI function) to use +-- We initialize readline (in the interactiveUI function) to use -- word_break_chars as the default set of completion word break characters. -- This can be overridden for a particular command (for example, filename -- expansion shouldn't consider '/' to be a word break) by setting the third -- entry in the Command tuple above. --- +-- -- NOTE: in order for us to override the default correctly, any custom entry -- must be a SUBSET of word_break_chars. word_break_chars :: String @@ -252,7 +248,7 @@ helpText = " :stepmodule single-step restricted to the current module\n"++ " :trace trace after stopping at a breakpoint\n"++ " :trace <expr> evaluate <expr> with tracing on (see :history)\n"++ - + "\n" ++ " -- Commands for changing settings:\n" ++ "\n" ++ @@ -266,7 +262,7 @@ helpText = "\n" ++ " Options for ':set' and ':unset':\n" ++ "\n" ++ - " +m allow multiline commands\n" ++ + " +m allow multiline commands\n" ++ " +r revert top-level expressions after each evaluation\n" ++ " +s print timing/memory stats after each evaluation\n" ++ " +t print type after evaluation\n" ++ @@ -286,11 +282,11 @@ helpText = " :show languages show the currently active language flags\n" ++ " :show <setting> show value of <setting>, which is one of\n" ++ " [args, prog, prompt, editor, stop]\n" ++ - "\n" + "\n" findEditor :: IO String findEditor = do - getEnv "EDITOR" + getEnv "EDITOR" `catchIO` \_ -> do #if mingw32_HOST_OS win <- System.Win32.getWindowsDirectory @@ -316,7 +312,7 @@ interactiveUI srcs maybe_exprs = do -- compiler and interpreter don't work with profiling. So we check for -- this up front and emit a helpful error message (#2197) i <- liftIO $ isProfiled - when (i /= 0) $ + when (i /= 0) $ ghcError (InstallationError "GHCi cannot be used when compiled with -prof") -- HACK! If we happen to get into an infinite loop (eg the user @@ -355,21 +351,21 @@ interactiveUI srcs maybe_exprs = do default_editor <- liftIO $ findEditor startGHCi (runGHCi srcs maybe_exprs) - GHCiState{ progname = default_progname, - args = default_args, - prompt = default_prompt, - stop = default_stop, - editor = default_editor, - options = [], - line_number = 1, - break_ctr = 0, - breaks = [], - tickarrays = emptyModuleEnv, - last_command = Nothing, - cmdqueue = [], + GHCiState{ progname = default_progname, + GhciMonad.args = default_args, + prompt = default_prompt, + stop = default_stop, + editor = default_editor, + options = [], + line_number = 1, + break_ctr = 0, + breaks = [], + tickarrays = emptyModuleEnv, + last_command = Nothing, + cmdqueue = [], remembered_ctx = [], - transient_ctx = [], - ghc_e = isJust maybe_exprs + transient_ctx = [], + ghc_e = isJust maybe_exprs } return () @@ -465,17 +461,17 @@ runGHCi paths maybe_exprs = do Just exprs -> do -- just evaluate the expression we were given enqueueCommands exprs - let handle e = do st <- getGHCiState - -- flush the interpreter's stdout/stderr on exit (#3890) - flushInterpBuffers - -- Jump through some hoops to get the - -- current progname in the exception text: - -- <progname>: <exception> - liftIO $ withProgName (progname st) + let hdle e = do st <- getGHCiState + -- flush the interpreter's stdout/stderr on exit (#3890) + flushInterpBuffers + -- Jump through some hoops to get the + -- current progname in the exception text: + -- <progname>: <exception> + liftIO $ withProgName (progname st) + $ topHandler e -- this used to be topHandlerFastExit, see #2228 - $ topHandler e runInputTWithPrefs defaultPrefs defaultSettings $ do - runCommands' handle (return Nothing) + runCommands' hdle (return Nothing) -- and finally, exit liftIO $ when (verbosity dflags > 0) $ putStrLn "Leaving GHCi." @@ -487,15 +483,15 @@ runGHCiInput f = do then liftIO $ withGhcAppData (\dir -> return (Just (dir </> "ghci_history"))) (return Nothing) else return Nothing - let settings = setComplete ghciCompleteWord - $ defaultSettings {historyFile = histFile} - runInputT settings f + runInputT + (setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile}) + f nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String) nextInputLine show_prompt is_tty | is_tty = do - prompt <- if show_prompt then lift mkPrompt else return "" - r <- getInputLine prompt + prmpt <- if show_prompt then lift mkPrompt else return "" + r <- getInputLine prmpt incrementLineNo return r | otherwise = do @@ -503,7 +499,7 @@ nextInputLine show_prompt is_tty fileLoop stdin -- NOTE: We only read .ghci files if they are owned by the current user, --- and aren't world writable. Otherwise, we could be accidentally +-- and aren't world writable. Otherwise, we could be accidentally -- running code planted by a malicious third party. -- Furthermore, We only read ./.ghci if . is owned by the current user @@ -525,9 +521,9 @@ checkPerms name = else do let mode = System.Posix.fileMode st if (groupWriteMode == (mode `intersectFileModes` groupWriteMode)) - || (otherWriteMode == (mode `intersectFileModes` otherWriteMode)) + || (otherWriteMode == (mode `intersectFileModes` otherWriteMode)) then do - putStrLn $ "*** WARNING: " ++ name ++ + putStrLn $ "*** WARNING: " ++ name ++ " is writable by someone else, IGNORING!" return False else return True @@ -551,9 +547,9 @@ fileLoop hdl = do -- this can happen if the user closed stdin, or -- perhaps did getContents which closes stdin at -- EOF. - Right l -> do + Right l' -> do incrementLineNo - return (Just l) + return (Just l') mkPrompt :: GHCi String mkPrompt = do @@ -569,9 +565,9 @@ mkPrompt = do then return (brackets (ppr (GHC.resumeSpan r)) <> space) else do let hist = GHC.resumeHistory r !! (ix-1) - span <- GHC.getHistorySpan hist - return (brackets (ppr (negate ix) <> char ':' - <+> ppr span) <> space) + pan <- GHC.getHistorySpan hist + return (brackets (ppr (negate ix) <> char ':' + <+> ppr pan) <> space) let dots | _:rs <- resumes, not (null rs) = text "... " | otherwise = empty @@ -610,26 +606,26 @@ runCommands = runCommands' handler runCommands' :: (SomeException -> GHCi Bool) -- ^ Exception handler -> InputT GHCi (Maybe String) -> InputT GHCi () -runCommands' eh getCmd = do +runCommands' eh gCmd = do b <- ghandle (\e -> case fromException e of Just UserInterrupt -> return $ Just False _ -> case fromException e of - Just ghc_e -> - do liftIO (print (ghc_e :: GhcException)) + Just ghce -> + do liftIO (print (ghce :: GhcException)) return Nothing _other -> liftIO (Exception.throwIO e)) - (runOneCommand eh getCmd) + (runOneCommand eh gCmd) case b of Nothing -> return () - Just _ -> runCommands' eh getCmd + Just _ -> runCommands' eh gCmd runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String) -> InputT GHCi (Maybe Bool) -runOneCommand eh getCmd = do - mb_cmd <- noSpace (lift queryQueue) - mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd - case mb_cmd of +runOneCommand eh gCmd = do + mb_cmd0 <- noSpace (lift queryQueue) + mb_cmd1 <- maybe (noSpace gCmd) (return . Just) mb_cmd0 + case mb_cmd1 of Nothing -> return Nothing Just c -> ghciHandle (\e -> lift $ eh e >>= return . Just) $ handleSourceError printErrorAndKeepGoing @@ -642,32 +638,32 @@ runOneCommand eh getCmd = do return $ Just True noSpace q = q >>= maybe (return Nothing) - (\c->case removeSpaces c of - "" -> noSpace q - ":{" -> multiLineCmd q - c -> return (Just c) ) + (\c -> case removeSpaces c of + "" -> noSpace q + ":{" -> multiLineCmd q + _ -> return (Just c) ) multiLineCmd q = do st <- lift getGHCiState let p = prompt st lift $ setGHCiState st{ prompt = "%s| " } mb_cmd <- collectCommand q "" - lift $ getGHCiState >>= \st->setGHCiState st{ prompt = p } + lift $ getGHCiState >>= \st' -> setGHCiState st'{ prompt = p } return mb_cmd - -- we can't use removeSpaces for the sublines here, so + -- we can't use removeSpaces for the sublines here, so -- multiline commands are somewhat more brittle against - -- fileformat errors (such as \r in dos input on unix), - -- we get rid of any extra spaces for the ":}" test; + -- fileformat errors (such as \r in dos input on unix), + -- we get rid of any extra spaces for the ":}" test; -- we also avoid silent failure if ":}" is not found; - -- and since there is no (?) valid occurrence of \r (as + -- and since there is no (?) valid occurrence of \r (as -- opposed to its String representation, "\r") inside a -- ghci command, we replace any such with ' ' (argh:-( - collectCommand q c = q >>= + collectCommand q c = q >>= maybe (liftIO (ioError collectError)) - (\l->if removeSpaces l == ":}" - then return (Just $ removeSpaces c) + (\l->if removeSpaces l == ":}" + then return (Just $ removeSpaces c) else collectCommand q (c ++ "\n" ++ map normSpace l)) where normSpace '\r' = ' ' - normSpace c = c + normSpace x = x -- SDM (2007-11-07): is userError the one to use here? collectError = userError "unterminated multiline command :{ .. :}" doCommand (':' : cmd) = do @@ -675,11 +671,11 @@ runOneCommand eh getCmd = do case result of True -> return Nothing _ -> return $ Just True - doCommand stmt = do + doCommand stmt = do ml <- lift $ isOptionSet Multiline if ml - then do - mb_stmt <- checkInputForLayout stmt getCmd + then do + mb_stmt <- checkInputForLayout stmt gCmd case mb_stmt of Nothing -> return $ Just True Just ml_stmt -> do @@ -696,25 +692,25 @@ checkInputForLayout :: String -> InputT GHCi (Maybe String) checkInputForLayout stmt getStmt = do dflags' <- lift $ getDynFlags let dflags = xopt_set dflags' Opt_AlternativeLayoutRule - st <- lift $ getGHCiState - let buf = stringToStringBuffer stmt - loc = mkRealSrcLoc (fsLit (progname st)) (line_number st) 1 - pstate = Lexer.mkPState dflags buf loc + st0 <- lift $ getGHCiState + let buf' = stringToStringBuffer stmt + loc = mkRealSrcLoc (fsLit (progname st0)) (line_number st0) 1 + pstate = Lexer.mkPState dflags buf' loc case Lexer.unP goToEnd pstate of (Lexer.POk _ False) -> return $ Just stmt _other -> do - st <- lift getGHCiState - let p = prompt st - lift $ setGHCiState st{ prompt = "%s| " } + st1 <- lift getGHCiState + let p = prompt st1 + lift $ setGHCiState st1{ prompt = "%s| " } mb_stmt <- ghciHandle (\ex -> case fromException ex of Just UserInterrupt -> return Nothing _ -> case fromException ex of - Just ghc_e -> - do liftIO (print (ghc_e :: GhcException)) + Just ghce -> + do liftIO (print (ghce :: GhcException)) return Nothing - _other -> liftIO (Exception.throwIO ex)) + _other -> liftIO (Exception.throwIO ex)) getStmt - lift $ getGHCiState >>= \st->setGHCiState st{ prompt = p } + lift $ getGHCiState >>= \st' -> setGHCiState st'{ prompt = p } -- the recursive call does not recycle parser state -- as we use a new string buffer case mb_stmt of @@ -725,7 +721,7 @@ checkInputForLayout stmt getStmt = do checkInputForLayout (stmt++"\n"++str) getStmt where goToEnd = do eof <- Lexer.nextIsEOF - if eof + if eof then Lexer.activeContext else Lexer.lexer return >> goToEnd @@ -776,10 +772,10 @@ afterRunStmt step_here run_result = do | isNothing mb_info || step_here (GHC.resumeSpan $ head resumes) -> do mb_id_loc <- toBreakIdAndLocation mb_info - let breakCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc - if (null breakCmd) + let bCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc + if (null bCmd) then printStoppedAtBreakInfo (head resumes) names - else enqueueCommands [breakCmd] + else enqueueCommands [bCmd] -- run the command set with ":set stop <cmd>" st <- getGHCiState enqueueCommands [stop st] @@ -798,22 +794,22 @@ afterRunStmt step_here run_result = do toBreakIdAndLocation :: Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation)) toBreakIdAndLocation Nothing = return Nothing -toBreakIdAndLocation (Just info) = do - let mod = GHC.breakInfo_module info - nm = GHC.breakInfo_number info +toBreakIdAndLocation (Just inf) = do + let md = GHC.breakInfo_module inf + nm = GHC.breakInfo_number inf st <- getGHCiState return $ listToMaybe [ id_loc | id_loc@(_,loc) <- breaks st, - breakModule loc == mod, + breakModule loc == md, breakTick loc == nm ] printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi () -printStoppedAtBreakInfo resume names = do +printStoppedAtBreakInfo res names = do printForUser $ ptext (sLit "Stopped at") <+> - ppr (GHC.resumeSpan resume) + ppr (GHC.resumeSpan res) -- printTypeOfNames session names let namesSorted = sortBy compareNames names tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted - docs <- mapM pprTypeAndContents [id | AnId id <- tythings] + docs <- mapM pprTypeAndContents [i | AnId i <- tythings] printForUserPartWay $ vcat docs printTypeOfNames :: [Name] -> GHCi () @@ -895,8 +891,8 @@ getCurrentBreakSpan = do then return (Just (GHC.resumeSpan r)) else do let hist = GHC.resumeHistory r !! (ix-1) - span <- GHC.getHistorySpan hist - return (Just span) + pan <- GHC.getHistorySpan hist + return (Just pan) getCurrentBreakModule :: GHCi (Maybe Module) getCurrentBreakModule = do @@ -958,7 +954,7 @@ infoThing str = do -- example is '[]', which is both a type and data -- constructor in the same type filterOutChildren :: (a -> TyThing) -> [a] -> [a] -filterOutChildren get_thing xs +filterOutChildren get_thing xs = filterOut has_parent xs where all_names = mkNameSet (map (getName . get_thing) xs) @@ -972,7 +968,7 @@ pprInfo pefas (thing, fixity, insts) $$ show_fixity fixity $$ vcat (map GHC.pprInstance insts) where - show_fixity fix + show_fixity fix | fix == GHC.defaultFixity = empty | otherwise = ppr fix <+> ppr (GHC.getName thing) @@ -1018,8 +1014,8 @@ changeDirectory dir = do _ <- GHC.load LoadAllTargets lift $ setContextAfterLoad False [] GHC.workingDirectoryChanged - dir <- expandPath dir - liftIO $ setCurrentDirectory dir + dir' <- expandPath dir + liftIO $ setCurrentDirectory dir' trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag trySuccess act = @@ -1035,7 +1031,7 @@ editFile str = do file <- if null str then chooseEditFile else return str st <- getGHCiState let cmd = editor st - when (null cmd) + when (null cmd) $ ghcError (CmdLineError "editor not set, use :set editor") _ <- liftIO $ system (cmd ++ ' ':file) return () @@ -1063,12 +1059,12 @@ chooseEditFile = case pick (order failed_graph) of Just file -> return file - Nothing -> + Nothing -> do targets <- GHC.getTargets case msum (map fromTarget targets) of Just file -> return file Nothing -> ghcError (CmdLineError "No files to edit.") - + where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f fromTarget _ = Nothing -- when would we get a module target? @@ -1083,16 +1079,16 @@ defineMacro overwrite s = do let (macro_name, definition) = break isSpace s macros <- liftIO (readIORef macros_ref) let defined = map cmdName macros - if (null macro_name) - then if null defined + if (null macro_name) + then if null defined then liftIO $ putStrLn "no macros defined" else liftIO $ putStr ("the following macros are defined:\n" ++ unlines defined) - else do + else do if (not overwrite && macro_name `elem` defined) - then ghcError (CmdLineError - ("macro '" ++ macro_name ++ "' is already defined")) - else do + then ghcError (CmdLineError + ("macro '" ++ macro_name ++ "' is already defined")) + else do let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ] @@ -1121,13 +1117,13 @@ runMacro fun s = do -- :undef undefineMacro :: String -> GHCi () -undefineMacro str = mapM_ undef (words str) +undefineMacro str = mapM_ undef (words str) where undef macro_name = do cmds <- liftIO (readIORef macros_ref) - if (macro_name `notElem` map cmdName cmds) - then ghcError (CmdLineError - ("macro '" ++ macro_name ++ "' is not defined")) - else do + if (macro_name `notElem` map cmdName cmds) + then ghcError (CmdLineError + ("macro '" ++ macro_name ++ "' is not defined")) + else do liftIO (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds)) @@ -1154,15 +1150,15 @@ checkModule m = do ok <- handleSourceError (\e -> GHC.printException e >> return False) $ do r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl liftIO $ putStrLn $ showSDoc $ - case GHC.moduleInfo r of - cm | Just scope <- GHC.modInfoTopLevelScope cm -> - let - (local,global) = ASSERT( all isExternalName scope ) - partition ((== modl) . GHC.moduleName . GHC.nameModule) scope - in - (text "global names: " <+> ppr global) $$ - (text "local names: " <+> ppr local) - _ -> empty + case GHC.moduleInfo r of + cm | Just scope <- GHC.modInfoTopLevelScope cm -> + let + (loc, glob) = ASSERT( all isExternalName scope ) + partition ((== modl) . GHC.moduleName . GHC.nameModule) scope + in + (text "global names: " <+> ppr glob) $$ + (text "local names: " <+> ppr loc) + _ -> empty return True afterLoad (successIf ok) False @@ -1202,8 +1198,8 @@ loadModule' files = do addModule :: [FilePath] -> InputT GHCi () addModule files = do lift revertCAFs -- always revert CAFs on load/add. - files <- mapM expandPath files - targets <- mapM (\m -> GHC.guessTarget m Nothing) files + files' <- mapM expandPath files + targets <- mapM (\m -> GHC.guessTarget m Nothing) files' -- remove old targets with the same id; e.g. for :add *M mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ] mapM_ GHC.addTarget targets @@ -1215,7 +1211,7 @@ addModule files = do reloadModule :: String -> InputT GHCi () reloadModule m = do _ <- doLoad True $ - if null m then LoadAllTargets + if null m then LoadAllTargets else LoadUpTo (GHC.mkModuleName m) return () @@ -1250,23 +1246,23 @@ setContextAfterLoad keep_ctxt ms = do -- load a target if one is available, otherwise load the topmost module. targets <- GHC.getTargets case [ m | Just m <- map (findTarget ms) targets ] of - [] -> - let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in - load_this (last graph') - (m:_) -> - load_this m + [] -> + let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in + load_this (last graph') + (m:_) -> + load_this m where - findTarget ms t - = case filter (`matches` t) ms of - [] -> Nothing - (m:_) -> Just m + findTarget mds t + = case filter (`matches` t) mds of + [] -> Nothing + (m:_) -> Just m summary `matches` Target (TargetModule m) _ _ - = GHC.ms_mod_name summary == m - summary `matches` Target (TargetFile f _) _ _ - | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f' + = GHC.ms_mod_name summary == m + summary `matches` Target (TargetFile f _) _ _ + | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f' _ `matches` _ - = False + = False load_this summary | m <- GHC.ms_mod summary = do is_interp <- GHC.moduleIsInterpreted m @@ -1282,14 +1278,14 @@ setContextKeepingPackageModules -> [InteractiveImport] -- new context -> GHCi () -setContextKeepingPackageModules keep_ctx transient_ctx = do +setContextKeepingPackageModules keep_ctx trans_ctx = do st <- getGHCiState let rem_ctx = remembered_ctx st new_rem_ctx <- if keep_ctx then return rem_ctx else keepPackageImports rem_ctx setGHCiState st{ remembered_ctx = new_rem_ctx, - transient_ctx = transient_ctx } + transient_ctx = trans_ctx } setGHCContextFromGHCiState @@ -1311,10 +1307,10 @@ modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> InputT GHCi () modulesLoadedMsg ok mods = do dflags <- getDynFlags when (verbosity dflags > 0) $ do - let mod_commas - | null mods = text "none." - | otherwise = hsep ( - punctuate comma (map ppr mods)) <> text "." + let mod_commas + | null mods = text "none." + | otherwise = hsep ( + punctuate comma (map ppr mods)) <> text "." case ok of Failed -> liftIO $ putStrLn $ showSDoc (text "Failed, modules loaded: " <> mod_commas) @@ -1326,7 +1322,7 @@ modulesLoadedMsg ok mods = do -- :type typeOfExpr :: String -> InputT GHCi () -typeOfExpr str +typeOfExpr str = handleSourceError GHC.printException $ do ty <- GHC.exprType str @@ -1338,12 +1334,12 @@ typeOfExpr str -- :kind kindOfType :: Bool -> String -> InputT GHCi () -kindOfType normalise str +kindOfType norm str = handleSourceError GHC.printException $ do - (ty, kind) <- GHC.typeKind normalise str + (ty, kind) <- GHC.typeKind norm str printForUser $ vcat [ text str <+> dcolon <+> ppr kind - , ppWhen normalise $ equals <+> ppr ty ] + , ppWhen norm $ equals <+> ppr ty ] ----------------------------------------------------------------------------- @@ -1359,8 +1355,8 @@ quit _ = return True -- running a script file #1363 scriptCmd :: String -> InputT GHCi () -scriptCmd s = do - case words s of +scriptCmd ws = do + case words ws of [s] -> runScript s _ -> ghcError (CmdLineError "syntax: :script <filename>") @@ -1383,8 +1379,8 @@ runScript filename = do where scriptLoop script = do res <- runOneCommand handler $ fileLoop script case res of - Nothing -> return () - Just succ -> if succ + Nothing -> return () + Just s -> if s then scriptLoop script else return () @@ -1394,13 +1390,13 @@ runScript filename = do -- Displaying Safe Haskell properties of a module isSafeCmd :: String -> InputT GHCi () -isSafeCmd m = +isSafeCmd m = case words m of [s] | looksLikeModuleName s -> do - m <- lift $ lookupModule s - isSafeModule m - [] -> do m <- guessCurrentModule "issafe" - isSafeModule m + md <- lift $ lookupModule s + isSafeModule md + [] -> do md <- guessCurrentModule "issafe" + isSafeModule md _ -> ghcError (CmdLineError "syntax: :issafe <module>") isSafeModule :: Module -> InputT GHCi () @@ -1416,29 +1412,45 @@ isSafeModule m = do (GHC.moduleNameString $ GHC.moduleName m)) let iface' = fromJust iface - trust = showPpr $ getSafeMode $ GHC.mi_trust iface' - pkg = if packageTrusted dflags m then "trusted" else "untrusted" - (good, bad) = tallyPkgs dflags $ - map fst $ filter snd $ dep_pkgs $ GHC.mi_deps iface' + + trust = showPpr $ getSafeMode $ GHC.mi_trust iface' + pkgT = packageTrusted dflags m + pkg = if pkgT then "trusted" else "untrusted" + (good', bad') = tallyPkgs dflags $ + map fst $ filter snd $ dep_pkgs $ GHC.mi_deps iface' + (good, bad) = case GHC.mi_trust_pkg iface' of + True | pkgT -> (modulePackageId m:good', bad') + True -> (good', modulePackageId m:bad') + False -> (good', bad') liftIO $ putStrLn $ "Trust type is (Module: " ++ trust ++ ", Package: " ++ pkg ++ ")" - when (not $ null good) + liftIO $ putStrLn $ "Package Trust: " + ++ (if packageTrustOn dflags then "On" else "Off") + + when (packageTrustOn dflags && not (null good)) (liftIO $ putStrLn $ "Trusted package dependencies (trusted): " ++ (intercalate ", " $ map packageIdString good)) - if (null bad) - then liftIO $ putStrLn $ mname ++ " is trusted!" - else do + + case goodTrust (getSafeMode $ GHC.mi_trust iface') of + True | (null bad || not (packageTrustOn dflags)) -> + liftIO $ putStrLn $ mname ++ " is trusted!" + + True -> do liftIO $ putStrLn $ "Trusted package dependencies (untrusted): " ++ (intercalate ", " $ map packageIdString bad) liftIO $ putStrLn $ mname ++ " is NOT trusted!" + False -> liftIO $ putStrLn $ mname ++ " is NOT trusted!" + where + goodTrust t = t `elem` [Sf_Safe, Sf_SafeInfered, Sf_Trustworthy] + mname = GHC.moduleNameString $ GHC.moduleName m - packageTrusted dflags m - | thisPackage dflags == modulePackageId m = True + packageTrusted dflags md + | thisPackage dflags == modulePackageId md = True | otherwise = trusted $ getPackageDetails (pkgState dflags) - (modulePackageId m) + (modulePackageId md) tallyPkgs dflags deps = partition part deps where state = pkgState dflags @@ -1450,16 +1462,16 @@ isSafeModule m = do -- Browsing a module's contents browseCmd :: Bool -> String -> InputT GHCi () -browseCmd bang m = +browseCmd bang m = case words m of - ['*':s] | looksLikeModuleName s -> do - m <- lift $ wantInterpretedModule s - browseModule bang m False + ['*':s] | looksLikeModuleName s -> do + md <- lift $ wantInterpretedModule s + browseModule bang md False [s] | looksLikeModuleName s -> do - m <- lift $ lookupModule s - browseModule bang m True - [] -> do m <- guessCurrentModule ("browse" ++ if bang then "!" else "") - browseModule bang m True + md <- lift $ lookupModule s + browseModule bang md True + [] -> do md <- guessCurrentModule ("browse" ++ if bang then "!" else "") + browseModule bang md True _ -> ghcError (CmdLineError "syntax: :browse <module>") guessCurrentModule :: String -> InputT GHCi Module @@ -1494,21 +1506,20 @@ browseModule bang modl exports_only = do | otherwise = GHC.modInfoTopLevelScope mod_info `orElse` [] - -- sort alphabetically name, but putting - -- locally-defined identifiers first. - -- We would like to improve this; see #1799. + -- sort alphabetically name, but putting locally-defined + -- identifiers first. We would like to improve this; see #1799. sorted_names = loc_sort local ++ occ_sort external - where + where (local,external) = ASSERT( all isExternalName names ) - partition ((==modl) . nameModule) names - occ_sort = sortBy (compare `on` nameOccName) - -- try to sort by src location. If the first name in - -- our list has a good source location, then they all should. - loc_sort names - | n:_ <- names, isGoodSrcSpan (nameSrcSpan n) - = sortBy (compare `on` nameSrcSpan) names + partition ((==modl) . nameModule) names + occ_sort = sortBy (compare `on` nameOccName) + -- try to sort by src location. If the first name in our list + -- has a good source location, then they all should. + loc_sort ns + | n:_ <- ns, isGoodSrcSpan (nameSrcSpan n) + = sortBy (compare `on` nameSrcSpan) ns | otherwise - = occ_sort names + = occ_sort ns mb_things <- mapM GHC.lookupName sorted_names let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things) @@ -1524,25 +1535,25 @@ browseModule bang modl exports_only = do labels [] = text "-- not currently imported" labels l = text $ intercalate "\n" $ map qualifier l - qualifier :: Maybe [ModuleName] -> String - qualifier = maybe "-- defined locally" - (("-- imported via "++) . intercalate ", " + qualifier :: Maybe [ModuleName] -> String + qualifier = maybe "-- defined locally" + (("-- imported via "++) . intercalate ", " . map GHC.moduleNameString) importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env - modNames :: [[Maybe [ModuleName]]] + modNames :: [[Maybe [ModuleName]]] modNames = map (importInfo . GHC.getName) things - + -- annotate groups of imports with their import modules - -- the default ordering is somewhat arbitrary, so we group + -- the default ordering is somewhat arbitrary, so we group -- by header and sort groups; the names themselves should -- really come in order of source appearance.. (trac #1799) annotate mts = concatMap (\(m,ts)->labels m:ts) - $ sortBy cmpQualifiers $ group mts - where cmpQualifiers = + $ sortBy cmpQualifiers $ grp mts + where cmpQualifiers = compare `on` (map (fmap (map moduleNameFS)) . fst) - group [] = [] - group mts@((m,_):_) = (m,map snd g) : group ng + grp [] = [] + grp mts@((m,_):_) = (m,map snd g) : grp ng where (g,ng) = partition ((==m).fst) mts let prettyThings, prettyThings' :: [SDoc] @@ -1567,14 +1578,14 @@ moduleCmd str | otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn") where (cmd, strs) = - case str of + case str of '+':stuff -> rest addModulesToContext stuff '-':stuff -> rest remModulesFromContext stuff stuff -> rest setContext stuff - rest cmd stuff = (cmd as bs, strs) - where strs = words stuff - (as,bs) = partitionWith starred strs + rest op stuff = (op as bs, stuffs) + where (as,bs) = partitionWith starred stuffs + stuffs = words stuff sensible ('*':m) = looksLikeModuleName m sensible m = looksLikeModuleName m @@ -1596,11 +1607,11 @@ addModulesToContext as bs = do remModulesFromContext :: [String] -> [String] -> GHCi () remModulesFromContext as bs = do - mapM_ rem (as ++ bs) + mapM_ rm (as ++ bs) setGHCContextFromGHCiState where - rem :: String -> GHCi () - rem str = do + rm :: String -> GHCi () + rm str = do m <- moduleName <$> lookupModule str let filt = filter ((/=) m . iiModuleName) modifyGHCiState $ \st -> @@ -1624,12 +1635,23 @@ setContext starred not_starred = do setGHCContextFromGHCiState checkAdd :: Bool -> String -> GHCi InteractiveImport -checkAdd star mstr - | star = do m <- wantInterpretedModule mstr - return (IIModule m) - | otherwise = do m <- lookupModule mstr - return (IIDecl (simpleImportDecl (moduleName m))) +checkAdd star mstr = do + dflags <- getDynFlags + case safeLanguageOn dflags of + True | star -> ghcError $ CmdLineError "can't use * imports with Safe Haskell" + True -> do m <- lookupModule mstr + s <- GHC.isModuleTrusted m + case s of + True -> return $ IIDecl (simpleImportDecl $ moduleName m) + False -> ghcError $ CmdLineError $ "can't import " ++ mstr + ++ " as it isn't trusted." + + False | star -> do m <- wantInterpretedModule mstr + return $ IIModule m + + False -> do m <- lookupModule mstr + return $ IIDecl (simpleImportDecl $ moduleName m) -- | Sets the GHC context from the GHCi state. The GHC context is -- always set this way, we never modify it incrementally. @@ -1718,11 +1740,11 @@ setCmd "" = do st <- getGHCiState let opts = options st liftIO $ putStrLn (showSDoc ( - text "options currently set: " <> - if null opts - then text "none." - else hsep (map (\o -> char '+' <> text (optToStr o)) opts) - )) + text "options currently set: " <> + if null opts + then text "none." + else hsep (map (\o -> char '+' <> text (optToStr o)) opts) + )) dflags <- getDynFlags liftIO $ putStrLn (showSDoc ( text "GHCi-specific dynamic flag settings:" $$ @@ -1747,14 +1769,14 @@ setCmd "" fstr str = text "-f" <> text str fnostr str = text "-fno-" <> text str - (ghciFlags,others) = partition (\(_, f, _) -> f `elem` flags) + (ghciFlags,others) = partition (\(_, f, _) -> f `elem` flgs) DynFlags.fFlags - flags = [Opt_PrintExplicitForalls + flgs = [Opt_PrintExplicitForalls ,Opt_PrintBindResult ,Opt_BreakOnException ,Opt_BreakOnError ,Opt_PrintEvldWithShow - ] + ] setCmd str = case getCmd str of Right ("args", rest) -> @@ -1777,7 +1799,7 @@ setProg, setEditor, setStop, setPrompt :: String -> GHCi () setArgs args = do st <- getGHCiState - setGHCiState st{ args = args } + setGHCiState st{ GhciMonad.args = args } setProg prog = do st <- getGHCiState @@ -1825,26 +1847,26 @@ setOptions wds = newDynFlags :: [String] -> GHCi () newDynFlags minus_opts = do - dflags <- getDynFlags - let pkg_flags = packageFlags dflags - (dflags', leftovers, warns) <- liftIO $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts - liftIO $ handleFlagWarnings dflags' warns + dflags0 <- getDynFlags + let pkg_flags = packageFlags dflags0 + (dflags1, leftovers, warns) <- liftIO $ GHC.parseDynamicFlags dflags0 $ map noLoc minus_opts + liftIO $ handleFlagWarnings dflags1 warns when (not $ null leftovers) (ghcError . CmdLineError $ "Some flags have not been recognized: " ++ (concat . intersperse ", " $ map unLoc leftovers)) - new_pkgs <- setDynFlags dflags' + new_pkgs <- setDynFlags dflags1 -- if the package flags changed, we should reset the context -- and link the new packages. - dflags <- getDynFlags - when (packageFlags dflags /= pkg_flags) $ do + dflags2 <- getDynFlags + when (packageFlags dflags2 /= pkg_flags) $ do liftIO $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..." GHC.setTargets [] _ <- GHC.load LoadAllTargets - liftIO (linkPackages dflags new_pkgs) + liftIO (linkPackages dflags2 new_pkgs) -- package flags changed, we can't re-use any of the old context setContextAfterLoad False [] return () @@ -1858,7 +1880,7 @@ unsetOptions str (plus_opts, rest2) = partitionWith isPlus rest1 (other_opts, rest3) = partition (`elem` map fst defaulters) rest2 - defaulters = + defaulters = [ ("args" , setArgs default_args) , ("prog" , setProg default_progname) , ("prompt", setPrompt default_prompt) @@ -1891,13 +1913,13 @@ setOpt, unsetOpt :: String -> GHCi () setOpt str = case strToGHCiOpt str of - Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'")) - Just o -> setOption o + Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'")) + Just o -> setOption o unsetOpt str = case strToGHCiOpt str of - Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'")) - Just o -> unsetOption o + Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'")) + Just o -> unsetOption o strToGHCiOpt :: String -> (Maybe GHCiOption) strToGHCiOpt "m" = Just Multiline @@ -1920,20 +1942,20 @@ showCmd :: String -> GHCi () showCmd str = do st <- getGHCiState case words str of - ["args"] -> liftIO $ putStrLn (show (args st)) + ["args"] -> liftIO $ putStrLn (show (GhciMonad.args st)) ["prog"] -> liftIO $ putStrLn (show (progname st)) ["prompt"] -> liftIO $ putStrLn (show (prompt st)) ["editor"] -> liftIO $ putStrLn (show (editor st)) ["stop"] -> liftIO $ putStrLn (show (stop st)) ["imports"] -> showImports ["modules" ] -> showModules - ["bindings"] -> showBindings - ["linker"] -> liftIO showLinkerState + ["bindings"] -> showBindings + ["linker"] -> liftIO showLinkerState ["breaks"] -> showBkptTable ["context"] -> showContext ["packages"] -> showPackages ["languages"] -> showLanguages - _ -> ghcError (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++ + _ -> ghcError (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++ " | breaks | context | packages | languages ]")) showImports :: GHCi () @@ -1977,18 +1999,18 @@ showBindings = do fidocs = map GHC.pprFamInstHdr finsts mapM_ printForUserPartWay (docs ++ idocs ++ fidocs) where - makeDoc (AnId id) = pprTypeAndContents id + makeDoc (AnId i) = pprTypeAndContents i makeDoc tt = do dflags <- getDynFlags let pefas = dopt Opt_PrintExplicitForalls dflags mb_stuff <- GHC.getInfo (getName tt) return $ maybe (text "") (pprTT pefas) mb_stuff pprTT :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc - pprTT pefas (thing, fixity, _insts) = + pprTT pefas (thing, fixity, _insts) = pprTyThing pefas thing $$ show_fixity fixity where - show_fixity fix + show_fixity fix | fix == GHC.defaultFixity = empty | otherwise = ppr fix <+> ppr (GHC.getName thing) @@ -1996,7 +2018,7 @@ showBindings = do printTyThing :: TyThing -> GHCi () printTyThing tyth = do dflags <- getDynFlags let pefas = dopt Opt_PrintExplicitForalls dflags - printForUser (pprTyThing pefas tyth) + printForUser (pprTyThing pefas tyth) showBkptTable :: GHCi () showBkptTable = do @@ -2008,9 +2030,9 @@ showContext = do resumes <- GHC.getResumeContext printForUser $ vcat (map pp_resume (reverse resumes)) where - pp_resume resume = - ptext (sLit "--> ") <> text (GHC.resumeStmt resume) - $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan resume)) + pp_resume res = + ptext (sLit "--> ") <> text (GHC.resumeStmt res) + $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan res)) showPackages :: GHCi () showPackages = do @@ -2105,13 +2127,13 @@ listHomeModules w = do $ map (showSDoc.ppr) home_mods completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do - return (filter (w `isPrefixOf`) options) - where options = "args":"prog":"prompt":"editor":"stop":flagList + return (filter (w `isPrefixOf`) opts) + where opts = "args":"prog":"prompt":"editor":"stop":flagList flagList = map head $ group $ sort allFlags completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do - return (filter (w `isPrefixOf`) options) - where options = ["args", "prog", "prompt", "editor", "stop", + return (filter (w `isPrefixOf`) opts) + where opts = ["args", "prog", "prompt", "editor", "stop", "modules", "bindings", "linker", "breaks", "context", "packages", "languages"] @@ -2139,7 +2161,7 @@ wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing wor getModifier = find (`elem` modifChars) allExposedModules :: DynFlags -> [ModuleName] -allExposedModules dflags +allExposedModules dflags = concat (map exposedModules (filter exposed (eltsUFM pkg_db))) where pkg_db = pkgIdMap (pkgState dflags) @@ -2176,8 +2198,8 @@ stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg case mb_span of Nothing -> stepCmd [] Just loc -> do - Just mod <- getCurrentBreakModule - current_toplevel_decl <- enclosingTickSpan mod loc + Just md <- getCurrentBreakModule + current_toplevel_decl <- enclosingTickSpan md loc doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep stepModuleCmd :: String -> GHCi () @@ -2189,38 +2211,38 @@ stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg mb_span <- getCurrentBreakSpan case mb_span of Nothing -> stepCmd [] - Just span -> do - let f some_span = srcSpanFileName_maybe span == srcSpanFileName_maybe some_span + Just pan -> do + let f some_span = srcSpanFileName_maybe pan == srcSpanFileName_maybe some_span doContinue f GHC.SingleStep -- | Returns the span of the largest tick containing the srcspan given enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan" -enclosingTickSpan mod (RealSrcSpan src) = do - ticks <- getTickArray mod +enclosingTickSpan md (RealSrcSpan src) = do + ticks <- getTickArray md let line = srcSpanStartLine src ASSERT (inRange (bounds ticks) line) do let toRealSrcSpan (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan" toRealSrcSpan (RealSrcSpan s) = s - enclosing_spans = [ span | (_,span) <- ticks ! line - , realSrcSpanEnd (toRealSrcSpan span) >= realSrcSpanEnd src] + enclosing_spans = [ pan | (_,pan) <- ticks ! line + , realSrcSpanEnd (toRealSrcSpan pan) >= realSrcSpanEnd src] return . head . sortBy leftmost_largest $ enclosing_spans traceCmd :: String -> GHCi () traceCmd arg - = withSandboxOnly ":trace" $ trace arg + = withSandboxOnly ":trace" $ tr arg where - trace [] = doContinue (const True) GHC.RunAndLogSteps - trace expression = runStmt expression GHC.RunAndLogSteps >> return () + tr [] = doContinue (const True) GHC.RunAndLogSteps + tr expression = runStmt expression GHC.RunAndLogSteps >> return () continueCmd :: String -> GHCi () continueCmd = noArgs $ withSandboxOnly ":continue" $ doContinue (const True) GHC.RunToCompletion -- doContinue :: SingleStep -> GHCi () doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi () -doContinue pred step = do - runResult <- resume pred step - _ <- afterRunStmt pred runResult +doContinue pre step = do + runResult <- resume pre step + _ <- afterRunStmt pre runResult return () abandonCmd :: String -> GHCi () @@ -2238,7 +2260,7 @@ deleteCmd argLine = withSandboxOnly ":delete" $ do -- delete all break points deleteSwitch ("*":_rest) = discardActiveBreakPoints deleteSwitch idents = do - mapM_ deleteOneBreak idents + mapM_ deleteOneBreak idents where deleteOneBreak :: String -> GHCi () deleteOneBreak str @@ -2262,14 +2284,14 @@ historyCmd arg [] -> liftIO $ putStrLn $ "Empty history. Perhaps you forgot to use :trace?" _ -> do - spans <- mapM GHC.getHistorySpan took + pans <- mapM GHC.getHistorySpan took let nums = map (printf "-%-3d:") [(1::Int)..] names = map GHC.historyEnclosingDecls took - printForUser (vcat(zipWith3 - (\x y z -> x <+> y <+> z) - (map text nums) + printForUser (vcat(zipWith3 + (\x y z -> x <+> y <+> z) + (map text nums) (map (bold . hcat . punctuate colon . map text) names) - (map (parens . ppr) spans))) + (map (parens . ppr) pans))) liftIO $ putStrLn $ if null rest then "<end of history>" else "..." bold :: SDoc -> SDoc @@ -2278,8 +2300,8 @@ bold c | do_bold = text start_bold <> c <> text end_bold backCmd :: String -> GHCi () backCmd = noArgs $ withSandboxOnly ":back" $ do - (names, _, span) <- GHC.back - printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr span + (names, _, pan) <- GHC.back + printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr pan printTypeOfNames names -- run the command set with ":set stop <cmd>" st <- getGHCiState @@ -2287,10 +2309,10 @@ backCmd = noArgs $ withSandboxOnly ":back" $ do forwardCmd :: String -> GHCi () forwardCmd = noArgs $ withSandboxOnly ":forward" $ do - (names, ix, span) <- GHC.forward + (names, ix, pan) <- GHC.forward printForUser $ (if (ix == 0) then ptext (sLit "Stopped at") - else ptext (sLit "Logged breakpoint at")) <+> ppr span + else ptext (sLit "Logged breakpoint at")) <+> ppr pan printTypeOfNames names -- run the command set with ":set stop <cmd>" st <- getGHCiState @@ -2305,24 +2327,24 @@ breakSwitch [] = do liftIO $ putStrLn "The break command requires at least one argument." breakSwitch (arg1:rest) | looksLikeModuleName arg1 && not (null rest) = do - mod <- wantInterpretedModule arg1 - breakByModule mod rest + md <- wantInterpretedModule arg1 + breakByModule md rest | all isDigit arg1 = do imports <- GHC.getContext case iiModules imports of - (mod : _) -> breakByModuleLine mod (read arg1) rest - [] -> do - liftIO $ putStrLn "Cannot find default module for breakpoint." + (md : _) -> breakByModuleLine md (read arg1) rest + [] -> do + liftIO $ putStrLn "Cannot find default module for breakpoint." liftIO $ putStrLn "Perhaps no modules are loaded for debugging?" | otherwise = do -- try parsing it as an identifier wantNameFromInterpretedModule noCanDo arg1 $ \name -> do let loc = GHC.srcSpanStart (GHC.nameSrcSpan name) case loc of RealSrcLoc l -> - ASSERT( isExternalName name ) - findBreakAndSet (GHC.nameModule name) $ + ASSERT( isExternalName name ) + findBreakAndSet (GHC.nameModule name) $ findBreakByCoord (Just (GHC.srcLocFile l)) - (GHC.srcLocLine l, + (GHC.srcLocLine l, GHC.srcLocCol l) UnhelpfulLoc _ -> noCanDo name $ text "can't find its location: " <> ppr loc @@ -2330,48 +2352,48 @@ breakSwitch (arg1:rest) noCanDo n why = printForUser $ text "cannot set breakpoint on " <> ppr n <> text ": " <> why -breakByModule :: Module -> [String] -> GHCi () -breakByModule mod (arg1:rest) +breakByModule :: Module -> [String] -> GHCi () +breakByModule md (arg1:rest) | all isDigit arg1 = do -- looks like a line number - breakByModuleLine mod (read arg1) rest + breakByModuleLine md (read arg1) rest breakByModule _ _ = breakSyntax breakByModuleLine :: Module -> Int -> [String] -> GHCi () -breakByModuleLine mod line args - | [] <- args = findBreakAndSet mod $ findBreakByLine line +breakByModuleLine md line args + | [] <- args = findBreakAndSet md $ findBreakByLine line | [col] <- args, all isDigit col = - findBreakAndSet mod $ findBreakByCoord Nothing (line, read col) + findBreakAndSet md $ findBreakByCoord Nothing (line, read col) | otherwise = breakSyntax breakSyntax :: a breakSyntax = ghcError (CmdLineError "Syntax: :break [<mod>] <line> [<column>]") findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi () -findBreakAndSet mod lookupTickTree = do - tickArray <- getTickArray mod - (breakArray, _) <- getModBreak mod - case lookupTickTree tickArray of +findBreakAndSet md lookupTickTree = do + tickArray <- getTickArray md + (breakArray, _) <- getModBreak md + case lookupTickTree tickArray of Nothing -> liftIO $ putStrLn $ "No breakpoints found at that location." - Just (tick, span) -> do + Just (tick, pan) -> do success <- liftIO $ setBreakFlag True breakArray tick - if success + if success then do - (alreadySet, nm) <- + (alreadySet, nm) <- recordBreak $ BreakLocation - { breakModule = mod - , breakLoc = span + { breakModule = md + , breakLoc = pan , breakTick = tick , onBreakCmd = "" } printForUser $ text "Breakpoint " <> ppr nm <> - if alreadySet - then text " was already set at " <> ppr span - else text " activated at " <> ppr span + if alreadySet + then text " was already set at " <> ppr pan + else text " activated at " <> ppr pan else do - printForUser $ text "Breakpoint could not be activated at" - <+> ppr span + printForUser $ text "Breakpoint could not be activated at" + <+> ppr pan -- When a line number is specified, the current policy for choosing -- the best breakpoint is this: @@ -2383,18 +2405,18 @@ findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan) findBreakByLine line arr | not (inRange (bounds arr) line) = Nothing | otherwise = - listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus` - listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus` + listToMaybe (sortBy (leftmost_largest `on` snd) comp) `mplus` + listToMaybe (sortBy (leftmost_smallest `on` snd) incomp) `mplus` listToMaybe (sortBy (rightmost `on` snd) ticks) - where + where ticks = arr ! line - starts_here = [ tick | tick@(_,span) <- ticks, - GHC.srcSpanStartLine (toRealSpan span) == line ] + starts_here = [ tick | tick@(_,pan) <- ticks, + GHC.srcSpanStartLine (toRealSpan pan) == line ] - (complete,incomplete) = partition ends_here starts_here - where ends_here (_,span) = GHC.srcSpanEndLine (toRealSpan span) == line - toRealSpan (RealSrcSpan span) = span + (comp, incomp) = partition ends_here starts_here + where ends_here (_,pan) = GHC.srcSpanEndLine (toRealSpan pan) == line + toRealSpan (RealSrcSpan pan) = pan toRealSpan (UnhelpfulSpan _) = panic "findBreakByLine UnhelpfulSpan" findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray @@ -2404,23 +2426,23 @@ findBreakByCoord mb_file (line, col) arr | otherwise = listToMaybe (sortBy (rightmost `on` snd) contains ++ sortBy (leftmost_smallest `on` snd) after_here) - where + where ticks = arr ! line -- the ticks that span this coordinate - contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col), - is_correct_file span ] + contains = [ tick | tick@(_,pan) <- ticks, pan `spans` (line,col), + is_correct_file pan ] - is_correct_file span - | Just f <- mb_file = GHC.srcSpanFile (toRealSpan span) == f + is_correct_file pan + | Just f <- mb_file = GHC.srcSpanFile (toRealSpan pan) == f | otherwise = True - after_here = [ tick | tick@(_,span) <- ticks, - let span' = toRealSpan span, - GHC.srcSpanStartLine span' == line, - GHC.srcSpanStartCol span' >= col ] + after_here = [ tick | tick@(_,pan) <- ticks, + let pan' = toRealSpan pan, + GHC.srcSpanStartLine pan' == line, + GHC.srcSpanStartCol pan' >= col ] - toRealSpan (RealSrcSpan span) = span + toRealSpan (RealSrcSpan pan) = pan toRealSpan (UnhelpfulSpan _) = panic "findBreakByCoord UnhelpfulSpan" -- For now, use ANSI bold on terminals that we know support it. @@ -2451,9 +2473,9 @@ listCmd' "" = do case mb_span of Nothing -> printForUser $ text "Not stopped at a breakpoint; nothing to list" - Just (RealSrcSpan span) -> - listAround span True - Just span@(UnhelpfulSpan _) -> + Just (RealSrcSpan pan) -> + listAround pan True + Just pan@(UnhelpfulSpan _) -> do resumes <- GHC.getResumeContext case resumes of [] -> panic "No resumes" @@ -2463,7 +2485,7 @@ listCmd' "" = do _ -> empty doWhat = traceIt <+> text ":back then :list" printForUser (text "Unable to list source for" <+> - ppr span + ppr pan $$ text "Try" <+> doWhat) listCmd' str = list2 (words str) @@ -2472,31 +2494,31 @@ list2 [arg] | all isDigit arg = do imports <- GHC.getContext case iiModules imports of [] -> liftIO $ putStrLn "No module to list" - (mod : _) -> listModuleLine mod (read arg) + (md : _) -> listModuleLine md (read arg) list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do - mod <- wantInterpretedModule arg1 - listModuleLine mod (read arg2) + md <- wantInterpretedModule arg1 + listModuleLine md (read arg2) list2 [arg] = do wantNameFromInterpretedModule noCanDo arg $ \name -> do let loc = GHC.srcSpanStart (GHC.nameSrcSpan name) case loc of RealSrcLoc l -> do tickArray <- ASSERT( isExternalName name ) - lift $ getTickArray (GHC.nameModule name) + lift $ getTickArray (GHC.nameModule name) let mb_span = findBreakByCoord (Just (GHC.srcLocFile l)) (GHC.srcLocLine l, GHC.srcLocCol l) tickArray case mb_span of Nothing -> listAround (realSrcLocSpan l) False Just (_, UnhelpfulSpan _) -> panic "list2 UnhelpfulSpan" - Just (_, RealSrcSpan span) -> listAround span False + Just (_, RealSrcSpan pan) -> listAround pan False UnhelpfulLoc _ -> noCanDo name $ text "can't find its location: " <> ppr loc where noCanDo n why = printForUser $ text "cannot list source code for " <> ppr n <> text ": " <> why -list2 _other = +list2 _other = liftIO $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]" listModuleLine :: Module -> Int -> InputT GHCi () @@ -2520,31 +2542,30 @@ listModuleLine modl line = do -- It would be better if we could convert directly between UTF-8 and the -- console encoding, of course. listAround :: MonadIO m => RealSrcSpan -> Bool -> InputT m () -listAround span do_highlight = do +listAround pan do_highlight = do contents <- liftIO $ BS.readFile (unpackFS file) - let - lines = BS.split '\n' contents - these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $ - drop (line1 - 1 - pad_before) $ lines + let ls = BS.split '\n' contents + ls' = take (line2 - line1 + 1 + pad_before + pad_after) $ + drop (line1 - 1 - pad_before) $ ls fst_line = max 1 (line1 - pad_before) line_nos = [ fst_line .. ] - highlighted | do_highlight = zipWith highlight line_nos these_lines - | otherwise = [\p -> BS.concat[p,l] | l <- these_lines] + highlighted | do_highlight = zipWith highlight line_nos ls' + | otherwise = [\p -> BS.concat[p,l] | l <- ls'] bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ] prefixed = zipWith ($) highlighted bs_line_nos - -- - let output = BS.intercalate (BS.pack "\n") prefixed + output = BS.intercalate (BS.pack "\n") prefixed + utf8Decoded <- liftIO $ BS.useAsCStringLen output $ \(p,n) -> utf8DecodeString (castPtr p) n liftIO $ putStrLn utf8Decoded where - file = GHC.srcSpanFile span - line1 = GHC.srcSpanStartLine span - col1 = GHC.srcSpanStartCol span - 1 - line2 = GHC.srcSpanEndLine span - col2 = GHC.srcSpanEndCol span - 1 + file = GHC.srcSpanFile pan + line1 = GHC.srcSpanStartLine pan + col1 = GHC.srcSpanStartCol pan - 1 + line2 = GHC.srcSpanEndLine pan + col2 = GHC.srcSpanEndCol pan - 1 pad_before | line1 == 1 = 0 | otherwise = 1 @@ -2572,7 +2593,7 @@ listAround span do_highlight = do = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ', BS.replicate (col2-col1) '^'] | no == line1 - = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl, + = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl, prefix, line] | no == line2 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ', @@ -2593,7 +2614,7 @@ getTickArray modl = do case lookupModuleEnv arrmap modl of Just arr -> return arr Nothing -> do - (_breakArray, ticks) <- getModBreak modl + (_breakArray, ticks) <- getModBreak modl let arr = mkTickArray (assocs ticks) setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr} return arr @@ -2605,15 +2626,14 @@ discardTickArrays = do mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray mkTickArray ticks - = accumArray (flip (:)) [] (1, max_line) - [ (line, (nm,span)) | (nm,span) <- ticks, - let span' = toRealSpan span, - line <- srcSpanLines span' ] + = accumArray (flip (:)) [] (1, max_line) + [ (line, (nm,pan)) | (nm,pan) <- ticks, + let pan' = toRealSpan pan, + line <- srcSpanLines pan' ] where max_line = foldr max 0 (map (GHC.srcSpanEndLine . toRealSpan . snd) ticks) - srcSpanLines span = [ GHC.srcSpanStartLine span .. - GHC.srcSpanEndLine span ] - toRealSpan (RealSrcSpan span) = span + srcSpanLines pan = [ GHC.srcSpanStartLine pan .. GHC.srcSpanEndLine pan ] + toRealSpan (RealSrcSpan pan) = pan toRealSpan (UnhelpfulSpan _) = panic "mkTickArray UnhelpfulSpan" -- don't reset the counter back to zero? @@ -2628,7 +2648,7 @@ deleteBreak identity = do st <- getGHCiState let oldLocations = breaks st (this,rest) = partition (\loc -> fst loc == identity) oldLocations - if null this + if null this then printForUser (text "Breakpoint" <+> ppr identity <+> text "does not exist") else do @@ -2641,24 +2661,24 @@ turnOffBreak loc = do liftIO $ setBreakFlag False arr (breakTick loc) getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan) -getModBreak mod = do - Just mod_info <- GHC.getModuleInfo mod +getModBreak m = do + Just mod_info <- GHC.getModuleInfo m let modBreaks = GHC.modInfoModBreaks mod_info - let array = GHC.modBreaks_flags modBreaks + let arr = GHC.modBreaks_flags modBreaks let ticks = GHC.modBreaks_locs modBreaks - return (array, ticks) + return (arr, ticks) -setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool -setBreakFlag toggle array index - | toggle = GHC.setBreakOn array index - | otherwise = GHC.setBreakOff array index +setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool +setBreakFlag toggle arr i + | toggle = GHC.setBreakOn arr i + | otherwise = GHC.setBreakOff arr i -- --------------------------------------------------------------------------- -- User code exception handling -- This is the exception handler for exceptions generated by the --- user's code and exceptions coming from children sessions; +-- user's code and exceptions coming from children sessions; -- it normally just prints out the exception. The -- handler must be recursive, in case showing the exception causes -- more exceptions to be raised. @@ -2712,28 +2732,27 @@ tryBool m = do -- Utils lookupModule :: GHC.GhcMonad m => String -> m Module -lookupModule modName - = GHC.lookupModule (GHC.mkModuleName modName) Nothing +lookupModule mName = GHC.lookupModule (GHC.mkModuleName mName) Nothing isHomeModule :: Module -> Bool -isHomeModule mod = GHC.modulePackageId mod == mainPackageId +isHomeModule m = GHC.modulePackageId m == mainPackageId -- TODO: won't work if home dir is encoded. -- (changeDirectory may not work either in that case.) expandPath :: MonadIO m => String -> InputT m String -expandPath path = do - exp_path <- liftIO $ expandPathIO path - enc <- fmap BS.unpack $ Encoding.encode exp_path - return enc +expandPath p = do + exp_path <- liftIO $ expandPathIO p + e <- fmap BS.unpack $ Encoding.encode exp_path + return e expandPathIO :: String -> IO String -expandPathIO path = - case dropWhile isSpace path of +expandPathIO p = + case dropWhile isSpace p of ('~':d) -> do - tilde <- getHomeDirectory -- will fail if HOME not defined - return (tilde ++ '/':d) - other -> - return other + tilde <- getHomeDirectory -- will fail if HOME not defined + return (tilde ++ '/':d) + other -> + return other wantInterpretedModule :: GHC.GhcMonad m => String -> m Module wantInterpretedModule str = do diff --git a/ghc/Main.hs b/ghc/Main.hs index 4829a4f5a8..b9de7b1f97 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -1,12 +1,5 @@ {-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-} -{-# 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#TabsvsSp --- for details - ----------------------------------------------------------------------------- -- -- GHC Driver program @@ -19,28 +12,28 @@ module Main (main) where -- The official GHC API import qualified GHC -import GHC ( -- DynFlags(..), HscTarget(..), +import GHC ( -- DynFlags(..), HscTarget(..), -- GhcMode(..), GhcLink(..), Ghc, GhcMonad(..), - LoadHowMuch(..) ) + LoadHowMuch(..) ) import CmdLineParser -- Implementations of the various modes (--show-iface, mkdependHS. etc.) -import LoadIface ( showIface ) +import LoadIface ( showIface ) import HscMain ( newHscEnv ) -import DriverPipeline ( oneShot, compileFile ) -import DriverMkDepend ( doMkDependHS ) +import DriverPipeline ( oneShot, compileFile ) +import DriverMkDepend ( doMkDependHS ) #ifdef GHCI -import InteractiveUI ( interactiveUI, ghciWelcomeMsg ) +import InteractiveUI ( interactiveUI, ghciWelcomeMsg ) #endif -- Various other random stuff that we need import Config import HscTypes -import Packages ( dumpPackages ) -import DriverPhases ( Phase(..), isSourceFilename, anyHsc, - startPhase, isHaskellSrcFilename ) +import Packages ( dumpPackages ) +import DriverPhases ( Phase(..), isSourceFilename, anyHsc, + startPhase, isHaskellSrcFilename ) import BasicTypes ( failed ) import StaticFlags import StaticFlagParser @@ -239,12 +232,12 @@ partition_args :: [String] -> [(String, Maybe Phase)] -> [String] -> ([(String, Maybe Phase)], [String]) partition_args [] srcs objs = (reverse srcs, reverse objs) partition_args ("-x":suff:args) srcs objs - | "none" <- suff = partition_args args srcs objs - | StopLn <- phase = partition_args args srcs (slurp ++ objs) - | otherwise = partition_args rest (these_srcs ++ srcs) objs - where phase = startPhase suff - (slurp,rest) = break (== "-x") args - these_srcs = zip slurp (repeat (Just phase)) + | "none" <- suff = partition_args args srcs objs + | StopLn <- phase = partition_args args srcs (slurp ++ objs) + | otherwise = partition_args rest (these_srcs ++ srcs) objs + where phase = startPhase suff + (slurp,rest) = break (== "-x") args + these_srcs = zip slurp (repeat (Just phase)) partition_args (arg:args) srcs objs | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs | otherwise = partition_args args srcs (arg:objs) @@ -268,8 +261,8 @@ partition_args (arg:args) srcs objs -} looks_like_an_input :: String -> Bool looks_like_an_input m = isSourceFilename m - || looksLikeModuleName m - || '.' `notElem` m + || looksLikeModuleName m + || '.' `notElem` m -- ----------------------------------------------------------------------------- -- Option sanity checks @@ -288,33 +281,33 @@ checkOptions mode dflags srcs objs = do && isInterpretiveMode mode) $ hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi") - -- -prof and --interactive are not a good combination + -- -prof and --interactive are not a good combination when (notNull (filter (not . isRTSWay) (wayNames dflags)) && isInterpretiveMode mode) $ do ghcError (UsageError "--interactive can't be used with -prof or -unreg.") - -- -ohi sanity check + -- -ohi sanity check if (isJust (outputHi dflags) && (isCompManagerMode mode || srcs `lengthExceeds` 1)) - then ghcError (UsageError "-ohi can only be used when compiling a single source file") - else do + then ghcError (UsageError "-ohi can only be used when compiling a single source file") + else do - -- -o sanity checking + -- -o sanity checking if (srcs `lengthExceeds` 1 && isJust (outputFile dflags) - && not (isLinkMode mode)) - then ghcError (UsageError "can't apply -o to multiple source files") - else do + && not (isLinkMode mode)) + then ghcError (UsageError "can't apply -o to multiple source files") + else do let not_linking = not (isLinkMode mode) || isNoLink (ghcLink dflags) when (not_linking && not (null objs)) $ hPutStrLn stderr ("Warning: the following files would be used as linker inputs, but linking is not being done: " ++ unwords objs) - -- Check that there are some input files - -- (except in the interactive case) + -- Check that there are some input files + -- (except in the interactive case) if null srcs && (null objs || not_linking) && needsInputsMode mode - then ghcError (UsageError "no input files") - else do + then ghcError (UsageError "no input files") + else do -- Verify that output files point somewhere sensible. verifyOutputFiles dflags @@ -346,7 +339,7 @@ verifyOutputFiles dflags = do nonExistentDir flg dir = ghcError (CmdLineError ("error: directory portion of " ++ show dir ++ " does not exist (used with " ++ - show flg ++ " option.)")) + show flg ++ " option.)")) ----------------------------------------------------------------------------- -- GHC modes of operation @@ -446,7 +439,7 @@ isDoMakeMode _ = False #ifdef GHCI isInteractiveMode :: PostLoadMode -> Bool isInteractiveMode DoInteractive = True -isInteractiveMode _ = False +isInteractiveMode _ = False #endif -- isInterpretiveMode: byte-code compiler involved @@ -456,19 +449,19 @@ isInterpretiveMode (DoEval _) = True isInterpretiveMode _ = False needsInputsMode :: PostLoadMode -> Bool -needsInputsMode DoMkDependHS = True -needsInputsMode (StopBefore _) = True -needsInputsMode DoMake = True -needsInputsMode _ = False +needsInputsMode DoMkDependHS = True +needsInputsMode (StopBefore _) = True +needsInputsMode DoMake = True +needsInputsMode _ = False -- True if we are going to attempt to link in this mode. -- (we might not actually link, depending on the GhcLink flag) isLinkMode :: PostLoadMode -> Bool isLinkMode (StopBefore StopLn) = True -isLinkMode DoMake = True +isLinkMode DoMake = True isLinkMode DoInteractive = True isLinkMode (DoEval _) = True -isLinkMode _ = False +isLinkMode _ = False isCompManagerMode :: PostLoadMode -> Bool isCompManagerMode DoMake = True @@ -610,10 +603,10 @@ doMake :: [(String,Maybe Phase)] -> Ghc () doMake srcs = do let (hs_srcs, non_hs_srcs) = partition haskellish srcs - haskellish (f,Nothing) = - looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f - haskellish (_,Just phase) = - phase `notElem` [As, Cc, Cobjc, Cobjcpp, CmmCpp, Cmm, StopLn] + haskellish (f,Nothing) = + looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f + haskellish (_,Just phase) = + phase `notElem` [As, Cc, Cobjc, Cobjcpp, CmmCpp, Cmm, StopLn] hsc_env <- GHC.getSession @@ -705,17 +698,17 @@ dumpFastStringStats dflags = do buckets <- getFastStringTable let (entries, longest, is_z, has_z) = countFS 0 0 0 0 buckets msg = text "FastString stats:" $$ - nest 4 (vcat [text "size: " <+> int (length buckets), - text "entries: " <+> int entries, - text "longest chain: " <+> int longest, - text "z-encoded: " <+> (is_z `pcntOf` entries), - text "has z-encoding: " <+> (has_z `pcntOf` entries) - ]) - -- we usually get more "has z-encoding" than "z-encoded", because - -- when we z-encode a string it might hash to the exact same string, - -- which will is not counted as "z-encoded". Only strings whose - -- Z-encoding is different from the original string are counted in - -- the "z-encoded" total. + nest 4 (vcat [text "size: " <+> int (length buckets), + text "entries: " <+> int entries, + text "longest chain: " <+> int longest, + text "z-encoded: " <+> (is_z `pcntOf` entries), + text "has z-encoding: " <+> (has_z `pcntOf` entries) + ]) + -- we usually get more "has z-encoding" than "z-encoded", because + -- when we z-encode a string it might hash to the exact same string, + -- which will is not counted as "z-encoded". Only strings whose + -- Z-encoding is different from the original string are counted in + -- the "z-encoded" total. putMsg dflags msg where x `pcntOf` y = int ((x * 100) `quot` y) <> char '%' @@ -724,13 +717,13 @@ countFS :: Int -> Int -> Int -> Int -> [[FastString]] -> (Int, Int, Int, Int) countFS entries longest is_z has_z [] = (entries, longest, is_z, has_z) countFS entries longest is_z has_z (b:bs) = let - len = length b - longest' = max len longest - entries' = entries + len - is_zs = length (filter isZEncoded b) - has_zs = length (filter hasZEncoding b) + len = length b + longest' = max len longest + entries' = entries + len + is_zs = length (filter isZEncoded b) + has_zs = length (filter hasZEncoding b) in - countFS entries' longest' (is_z + is_zs) (has_z + has_zs) bs + countFS entries' longest' (is_z + is_zs) (has_z + has_zs) bs -- ----------------------------------------------------------------------------- -- ABI hash support diff --git a/includes/rts/prof/CCS.h b/includes/rts/prof/CCS.h index 36404aaf91..3639e49aa7 100644 --- a/includes/rts/prof/CCS.h +++ b/includes/rts/prof/CCS.h @@ -37,8 +37,8 @@ typedef struct _CostCentre { char * srcloc; // used for accumulating costs at the end of the run... - StgWord time_ticks; StgWord64 mem_alloc; // align 8 (Note [struct alignment]) + StgWord time_ticks; StgInt is_caf; // non-zero for a CAF cost centre diff --git a/rts/StgCRun.c b/rts/StgCRun.c index 7ae5bac38b..89aa0a3290 100644 --- a/rts/StgCRun.c +++ b/rts/StgCRun.c @@ -29,12 +29,24 @@ #include "PosixSource.h" #include "ghcconfig.h" +#ifdef sparc_HOST_ARCH /* include Stg.h first because we want real machine regs in here: we * have to get the value of R1 back from Stg land to C land intact. */ #define IN_STGCRUN 1 #include "Stg.h" #include "Rts.h" +#else +/* The other architectures do not require the actual register macro definitions + * here because they use hand written assembly to implement the StgRun + * function. Including Stg.h first will define the R1 values using GCC specific + * techniques, which we don't want for LLVM based C compilers. Since we don't + * actually need the real machine register definitions here, we include the + * headers in the opposite order to allow LLVM-based C compilers to work. + */ +#include "Rts.h" +#include "Stg.h" +#endif #include "StgRun.h" #include "Capability.h" @@ -438,7 +438,8 @@ sub help Usage: ./sync-all [-q] [-s] [--ignore-failure] [-r repo] [--checked-out] [--bare] - [--nofib] [--extra] [--testsuite] [--resume] cmd [git flags] + [--nofib] [--extra] [--testsuite] [--no-dph] [--resume] + cmd [git flags] Applies the command "cmd" to each repository in the tree. @@ -465,12 +466,12 @@ and then we can pull from this other tree with get Clones all sub-repositories from the same place that the ghc - repository was cloned from. See "which repos to use" below + repository was cloned from. See "which repos to use" below for details of how the subrepositories are laid out. There are various --<package-tag> options that can be given - before "get" that enable extra repositories. The full list is - given at the end of this help. For example: + before "get" that enable extra repositories. The full list is + given at the end of this help. For example: ./sync-all --testsuite get @@ -482,13 +483,13 @@ remote rm <remote-name> remote set-url [--push] <remote-name> Runs a "git remote" command on each subrepository, adjusting the - repository location in each case appropriately. For example, to + repository location in each case appropriately. For example, to add a new remote pointing to the upstream repositories: ./sync-all -r http://darcs.haskell.org/ remote add upstream The -r flag points to the root of the repository tree (see "which - repos to use" below). For a repository on the local filesystem it + repos to use" below). For a repository on the local filesystem it would point to the ghc reposiroty, and for a remote repository it points to the directory containing "ghc.git". @@ -515,30 +516,28 @@ any extra arguments to git: status -------------- Flags ------------------- - These flags are given *before* the command and modify the way - sync-all behaves. Flags given *after* the command are passed to - git. +These flags are given *before* the command and modify the way sync-all behaves. +Flags given *after* the command are passed to git. -q says to be quiet, and -s to be silent. - --resume will restart a command that failed, from the repo at which - it failed. This means you don't need to wait while, e.g., "pull" - goes through all the repos it's just pulled, and tries to pull them - again. + --resume will restart a command that failed, from the repo at which it + failed. This means you don't need to wait while, e.g., "pull" goes through + all the repos it's just pulled, and tries to pull them again. --ignore-failure says to ignore errors and move on to the next repository -r repo says to use repo as the location of package repositories - --checked-out says that the remote repo is in checked-out layout, as - opposed to the layout used for the main repo. By default a repo on - the local filesystem is assumed to be checked-out, and repos accessed - via HTTP or SSH are assumed to be in the main repo layout; use - --checked-out to override the latter. + --checked-out says that the remote repo is in checked-out layout, as opposed + to the layout used for the main repo. By default a repo on the local + filesystem is assumed to be checked-out, and repos accessed via HTTP or SSH + are assumed to be in the main repo layout; use --checked-out to override the + latter. - --bare says that the local repo is in bare layout, same as the main repo. - It also means that these repos are bare. You only have to use this flag if - you don't have a bare ghc.git in the current directory and would like to 'get' + --bare says that the local repo is in bare layout, same as the main repo. It + also means that these repos are bare. You only have to use this flag if you + don't have a bare ghc.git in the current directory and would like to 'get' all of the repos bare. Requires packages.conf to be present in the current directory (a renamed packages file from the main ghc repo). @@ -546,34 +545,49 @@ any extra arguments to git: --checked-out: describes the layout of the remote repository tree. --bare: describes the layout of the local repository tree. - --nofib, --testsuite also get the nofib and testsuite repos respectively + --nofib also clones the nofib benchmark suite + + --testsuite also clones the ghc testsuite + + --extra also clone some extra library packages + + --no-dph avoids cloning the dph pacakges + + +------------ Checking out a branch ------------- +To check out a branch you can run the following command: + + \$ ./sync-all checkout ghc-7.4 ------------ Which repos to use ------------- - sync-all uses the following algorithm to decide which remote repos to use - - It always computes the remote repos from a single base, <repo_base> - How is <repo_base> set? - If you say "-r repo", then that's <repo_base> - otherwise <repo_base> is set by asking git where the ghc repo came - from, and removing the last component (e.g. /ghc.git/ or /ghc/). - - Then sync-all iterates over the package found in the file - ./packages; see that file for a description of the contents. - - If <repo_base> looks like a local filesystem path, or if you give - the --checked-out flag, sync-all works on repos of form - <repo_base>/<local-path> - otherwise sync-all works on repos of form - <repo_base>/<remote-path> - This logic lets you say - both sync-all -r http://darcs.haskell.org/ghc-6.12 remote add ghc-6.12 - and sync-all -r ../working remote add working - The latter is called a "checked-out tree". - - NB: sync-all *ignores* the defaultrepo of all repos other than the - root one. So the remote repos must be laid out in one of the two - formats given by <local-path> and <remote-path> in the file 'packages'. +sync-all uses the following algorithm to decide which remote repos to use + +It always computes the remote repos from a single base, <repo_base> How is +<repo_base> set? If you say "-r repo", then that's <repo_base> otherwise +<repo_base> is set by asking git where the ghc repo came from, and removing the +last component (e.g. /ghc.git/ or /ghc/). + +Then sync-all iterates over the package found in the file ./packages; see that +file for a description of the contents. + +If <repo_base> looks like a local filesystem path, or if you give the +--checked-out flag, sync-all works on repos of form: + + <repo_base>/<local-path> + +otherwise sync-all works on repos of form: + + <repo_base>/<remote-path> + +This logic lets you say + both sync-all -r http://darcs.haskell.org/ghc-6.12 remote add ghc-6.12 + and sync-all -r ../working remote add working +The latter is called a "checked-out tree". + +sync-all *ignores* the defaultrepo of all repos other than the root one. So the +remote repos must be laid out in one of the two formats given by <local-path> +and <remote-path> in the file 'packages'. Available package-tags are: END |