From 0f800dc9f3dc695cd06d0fdd7799a52c37241752 Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Thu, 2 Mar 2006 14:16:28 +0000 Subject: [PATCH] replace several 'fromJust's with 'expectJust's --- ghc/compiler/iface/MkIface.lhs | 6 +++--- ghc/compiler/main/GHC.hs | 8 ++++---- ghc/compiler/main/HscTypes.lhs | 4 ++-- ghc/compiler/rename/RnExpr.lhs | 4 ++-- ghc/compiler/typecheck/TcBinds.lhs | 13 ++++++------- ghc/compiler/typecheck/TcTyClsDecls.lhs | 5 +++-- ghc/compiler/typecheck/TcUnify.lhs | 5 +++-- 7 files changed, 23 insertions(+), 22 deletions(-) diff --git a/ghc/compiler/iface/MkIface.lhs b/ghc/compiler/iface/MkIface.lhs index 2f15ee3..f76ac41 100644 --- a/ghc/compiler/iface/MkIface.lhs +++ b/ghc/compiler/iface/MkIface.lhs @@ -234,7 +234,7 @@ import DATA_IOREF ( writeIORef ) import Monad ( when ) import List ( insert ) import Maybes ( orElse, mapCatMaybes, isNothing, isJust, - fromJust, expectJust, MaybeErr(..) ) + expectJust, MaybeErr(..) ) \end{code} @@ -321,7 +321,7 @@ mkIface hsc_env maybe_old_iface -- Debug printing ; when (isJust pp_orphs && dopt Opt_WarnOrphans dflags) - (printDump (fromJust pp_orphs)) + (printDump (expectJust "mkIface" pp_orphs)) ; when (dopt Opt_D_dump_hi_diffs dflags) (printDump pp_diffs) ; dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE" (pprModIface new_iface) @@ -896,7 +896,7 @@ checkModUsage (Usage { usg_name = mod_name, usg_mod = old_mod_vers, -- CHECK EXPORT LIST if checkExportList maybe_old_export_vers new_export_vers then out_of_date_vers (ptext SLIT(" Export list changed")) - (fromJust maybe_old_export_vers) + (expectJust "checkModUsage" maybe_old_export_vers) new_export_vers else diff --git a/ghc/compiler/main/GHC.hs b/ghc/compiler/main/GHC.hs index d1d1e78..29e2c66 100644 --- a/ghc/compiler/main/GHC.hs +++ b/ghc/compiler/main/GHC.hs @@ -234,7 +234,7 @@ import Maybes ( expectJust, mapCatMaybes ) import Control.Concurrent import System.Directory ( getModificationTime, doesFileExist ) -import Data.Maybe ( isJust, isNothing, fromJust ) +import Data.Maybe ( isJust, isNothing ) import Data.List ( partition, nub ) import qualified Data.List as List import Control.Monad ( unless, when ) @@ -768,7 +768,7 @@ checkModule session@(Session ref) mod = do -- ml_hspp_file field, say let dflags0 = hsc_dflags hsc_env hspp_buf = expectJust "GHC.checkModule" (ms_hspp_buf ms) - filename = fromJust (ml_hs_file (ms_location ms)) + filename = expectJust "checkModule" (ml_hs_file (ms_location ms)) opts = getOptionsFromStringBuffer hspp_buf filename (dflags1,leftovers) <- parseDynamicFlags dflags0 (map snd opts) if (not (null leftovers)) @@ -1446,7 +1446,7 @@ summariseFile hsc_env old_summaries file mb_phase maybe_buf findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary findSummaryBySourceFile summaries file = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms], - fromJust (ml_hs_file (ms_location ms)) == file ] of + expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of [] -> Nothing (x:xs) -> Just x @@ -2065,6 +2065,6 @@ showModule s mod_summary = withSession s $ \hsc_env -> do Nothing -> panic "missing linkable" Just mod_info -> return (showModMsg obj_linkable mod_summary) where - obj_linkable = isObjectLinkable (fromJust (hm_linkable mod_info)) + obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info)) #endif /* GHCI */ diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 48041c0..c542d34 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -94,7 +94,7 @@ import IfaceSyn ( IfaceInst, IfaceRule, IfaceDecl(ifName) ) import FiniteMap ( FiniteMap ) import CoreSyn ( CoreRule ) -import Maybes ( orElse, fromJust, expectJust ) +import Maybes ( orElse, expectJust, expectJust ) import Outputable import SrcLoc ( SrcSpan, Located ) import UniqSupply ( UniqSupply ) @@ -277,7 +277,7 @@ hptRules hsc_env deps -- Look it up in the HPT , let mod_info = ASSERT( mod `elemModuleEnv` hpt ) - fromJust (lookupModuleEnv hpt mod) + expectJust "hptRules" (lookupModuleEnv hpt mod) -- And get its dfuns , rule <- md_rules (hm_details mod_info) ] diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index a128c35..557e1e4 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -42,7 +42,7 @@ import UniqSet ( emptyUniqSet ) import List ( nub ) import Util ( isSingleton ) import ListSetOps ( removeDups ) -import Maybes ( fromJust ) +import Maybes ( expectJust ) import Outputable import SrcLoc ( Located(..), unLoc, getLoc, cmpLocated ) import FastString @@ -678,7 +678,7 @@ rnStmt ctxt (ParStmt segs) thing_inside { -- Find the Names that are bound by stmts lcl_env <- getLocalRdrEnv ; let { rdr_bndrs = collectLStmtsBinders stmts - ; bndrs = map ( fromJust + ; bndrs = map ( expectJust "rnStmt" . lookupLocalRdrEnv lcl_env . unLoc) rdr_bndrs ; new_bndrs = nub bndrs ++ bndrs_so_far diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index c765699..cffcb9c 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -62,7 +62,7 @@ import SrcLoc ( Located(..), unLoc, getLoc ) import Bag import ErrUtils ( Message ) import Digraph ( SCC(..), stronglyConnComp ) -import Maybes ( fromJust, isJust, isNothing, orElse ) +import Maybes ( expectJust, isJust, isNothing, orElse ) import Util ( singleton ) import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel, RecFlag(..), isNonRec, InlineSpec, defaultInlineSpec ) @@ -251,10 +251,8 @@ mkEdges :: TcSigFun -> LHsBinds Name type BKey = Int -- Just number off the bindings mkEdges sig_fn binds - = [ (bind, key, [fromJust mb_key | n <- nameSetToList (bind_fvs (unLoc bind)), - let mb_key = lookupNameEnv key_map n, - isJust mb_key, - no_sig n ]) + = [ (bind, key, [key | n <- nameSetToList (bind_fvs (unLoc bind)), + Just key <- [lookupNameEnv key_map n], no_sig n ]) | (bind, key) <- keyd_binds ] where @@ -419,7 +417,8 @@ type TcPragFun = Name -> [LSig Name] mkPragFun :: [LSig Name] -> TcPragFun mkPragFun sigs = \n -> lookupNameEnv env n `orElse` [] where - prs = [(fromJust (sigName sig), sig) | sig <- sigs, isPragLSig sig] + prs = [(expectJust "mkPragFun" (sigName sig), sig) + | sig <- sigs, isPragLSig sig] env = foldl add emptyNameEnv prs add env (n,p) = extendNameEnv_Acc (:) singleton env n p @@ -958,7 +957,7 @@ mkSigFun :: [LSig Name] -> TcSigFun -- Precondition: no duplicates mkSigFun sigs = lookupNameEnv env where - env = mkNameEnv [(fromJust (sigName sig), sig) | sig <- sigs] + env = mkNameEnv [(expectJust "mkSigFun" (sigName sig), sig) | sig <- sigs] --------------- data TcSigInfo diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index d2f53de..9e0b6cc 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -52,7 +52,8 @@ import Var ( TyVar, idType, idName ) import VarSet ( elemVarSet, mkVarSet ) import Name ( Name, getSrcLoc ) import Outputable -import Maybe ( isJust, fromJust ) +import Maybe ( isJust ) +import Maybes ( expectJust ) import Unify ( tcMatchTys, tcMatchTyX ) import Util ( zipLazy, isSingleton, notNull, sortLe ) import List ( partition ) @@ -663,7 +664,7 @@ checkFieldCompat fld con1 con2 tvs1 res1 res2 fty1 fty2 ; checkTc (isJust mb_subst2) (fieldTypeMisMatch fld con1 con2) } where mb_subst1 = tcMatchTys tvs1 res1 res2 - mb_subst2 = tcMatchTyX tvs1 (fromJust mb_subst1) fty1 fty2 + mb_subst2 = tcMatchTyX tvs1 (expectJust "checkFieldCompat" mb_subst1) fty1 fty2 ------------------------------- checkValidDataCon :: TyCon -> DataCon -> TcM () diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs index 187f055..23cc9e2 100644 --- a/ghc/compiler/typecheck/TcUnify.lhs +++ b/ghc/compiler/typecheck/TcUnify.lhs @@ -67,7 +67,7 @@ import VarSet ( emptyVarSet, mkVarSet, unitVarSet, unionVarSet, elemVarSet, var import VarEnv import Name ( Name, isSystemName ) import ErrUtils ( Message ) -import Maybes ( fromJust, isNothing ) +import Maybes ( expectJust, isNothing ) import BasicTypes ( Arity ) import UniqSupply ( uniqsFromSupply ) import Util ( notNull, equalLength ) @@ -1197,7 +1197,8 @@ checkTauTvUpdate orig_tv orig_ty ; case mb_tys' of Just tys' -> return (TyConApp tc tys') -- Retain the synonym (the common case) - Nothing -> go (fromJust (tcView (TyConApp tc tys))) + Nothing -> go (expectJust "checkTauTvUpdate" + (tcView (TyConApp tc tys))) -- Try again, expanding the synonym } \end{code} -- 1.7.10.4