import RdrName ( GlobalRdrEnv )
import NameSet
import VarSet
-import Bag ( Bag, isEmptyBag, emptyBag )
import Rules ( roughTopNames )
import CoreLint ( showPass, endPass )
import CoreFVs ( ruleRhsFreeVars, exprsFreeNames )
-import ErrUtils ( doIfSet, dumpIfSet_dyn, printBagOfWarnings,
- errorsFound, WarnMsg )
+import ErrUtils ( doIfSet, dumpIfSet_dyn )
import ListSetOps ( insertList )
import Outputable
-import UniqSupply ( mkSplitUniqSupply )
import SrcLoc ( Located(..) )
import DATA_IOREF ( readIORef )
import Maybes ( catMaybes )
%************************************************************************
\begin{code}
-deSugar :: HscEnv -> TcGblEnv -> IO (Bag WarnMsg, Maybe ModGuts)
+deSugar :: HscEnv -> TcGblEnv -> IO (Maybe ModGuts)
-- Can modify PCS by faulting in more declarations
deSugar hsc_env
= do { showPass dflags "Desugar"
-- Desugar the program
- ; ((all_prs, ds_rules, ds_fords), warns)
- <- case ghcMode (hsc_dflags hsc_env) of
- JustTypecheck -> return (([], [], NoStubs), emptyBag)
+ ; mb_res <- case ghcMode dflags of
+ JustTypecheck -> return (Just ([], [], NoStubs))
_ -> initDs hsc_env mod rdr_env type_env $ do
{ core_prs <- dsTopLHsBinds auto_scc binds
; (ds_fords, foreign_prs) <- dsForeigns fords
; ds_rules <- mappM (dsRule mod local_bndrs) rules
; return (all_prs, catMaybes ds_rules, ds_fords)
}
-
- -- If warnings are considered errors, leave.
- ; if errorsFound dflags (warns, emptyBag)
- then return (warns, Nothing)
- else do
+ ; case mb_res of {
+ Nothing -> return Nothing ;
+ Just (all_prs, ds_rules, ds_fords) -> do
{ -- Add export flags to bindings
keep_alive <- readIORef keep_var
mg_binds = ds_binds,
mg_foreign = ds_fords }
- ; return (warns, Just mod_guts)
- }}
+ ; return (Just mod_guts)
+ }}}
where
- dflags = hsc_dflags hsc_env
- ghci_mode = ghcMode (hsc_dflags hsc_env)
+ dflags = hsc_dflags hsc_env
+ ghci_mode = ghcMode (hsc_dflags hsc_env)
auto_scc | opt_SccProfilingOn = TopLevel
| otherwise = NoSccs
deSugarExpr :: HscEnv
-> Module -> GlobalRdrEnv -> TypeEnv
-> LHsExpr Id
- -> IO CoreExpr
+ -> IO (Maybe CoreExpr)
+-- Prints its own errors; returns Nothing if error occurred
+
deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
- = do { showPass dflags "Desugar"
- ; us <- mkSplitUniqSupply 'd'
+ = do { let dflags = hsc_dflags hsc_env
+ ; showPass dflags "Desugar"
-- Do desugaring
- ; (core_expr, ds_warns) <- initDs hsc_env this_mod rdr_env type_env $
- dsLExpr tc_expr
+ ; mb_core_expr <- initDs hsc_env this_mod rdr_env type_env $
+ dsLExpr tc_expr
- -- Display any warnings
- -- Note: if -Werror is used, we don't signal an error here.
- ; doIfSet (not (isEmptyBag ds_warns))
- (printBagOfWarnings dflags ds_warns)
+ ; case mb_core_expr of {
+ Nothing -> return Nothing ;
+ Just expr -> do {
- -- Dump output
- ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr core_expr)
-
- ; return core_expr
- }
- where
- dflags = hsc_dflags hsc_env
+ -- Dump output
+ dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
+ ; return (Just expr) } } }
-- addExportFlags
-- Set the no-discard flag if either
; rhs' <- dsLExpr rhs
; case decomposeRuleLhs bndrs lhs' of {
- Nothing -> do { dsWarn msg; return Nothing } ;
+ Nothing -> do { warnDs msg; return Nothing } ;
Just (bndrs', fn_id, args) -> do
-- Substitute the dict bindings eagerly,
mb_lhs = decomposeRuleLhs (bndrs ++ const_dicts) body
; case mb_lhs of
- Nothing -> do { dsWarn msg; return Nothing }
+ Nothing -> do { warnDs msg; return Nothing }
Just (bndrs', var, args) -> return (Just (addInlineInfo inl spec_id spec_rhs, rule))
where
| HsVar funId <- fun
, idName funId `elem` [breakpointJumpName, breakpointCondJumpName]
, ids <- filter (isValidType . idType) (extractIds arg)
- = do dsWarn (text "Extracted ids:" <+> ppr ids <+> ppr (map idType ids))
+ = do warnDs (text "Extracted ids:" <+> ppr ids <+> ppr (map idType ids))
stablePtr <- ioToIOEnv $ newStablePtr ids
-- Yes, I know... I'm gonna burn in hell.
let Ptr addr# = castStablePtrToPtr stablePtr
-- Un-handled cases
repTyClD (L loc d) = putSrcSpanDs loc $
- do { dsWarn (hang ds_msg 4 (ppr d))
+ do { warnDs (hang ds_msg 4 (ppr d))
; return Nothing }
-- represent fundeps
MkC typ' <- repLTy typ
MkC cc' <- repCCallConv cc
MkC s' <- repSafety s
+ cis' <- conv_cimportspec cis
MkC str <- coreStringLit $ static
++ unpackFS ch ++ " "
++ unpackFS cn ++ " "
- ++ conv_cimportspec cis
+ ++ cis'
dec <- rep2 forImpDName [cc', s', str, name', typ']
return (loc, dec)
where
- conv_cimportspec (CLabel cls) = panic "repForD': CLabel Not handled"
- conv_cimportspec (CFunction DynamicTarget) = "dynamic"
- conv_cimportspec (CFunction (StaticTarget fs)) = unpackFS fs
- conv_cimportspec CWrapper = "wrapper"
+ conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))
+ conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
+ conv_cimportspec (CFunction (StaticTarget fs)) = return (unpackFS fs)
+ conv_cimportspec CWrapper = return "wrapper"
static = case cis of
CFunction (StaticTarget _) -> "static "
_ -> ""
+repForD decl = notHandled "Foreign declaration" (ppr decl)
repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
repCCallConv CCallConv = rep2 cCallName []
}
}
repC (L loc con_decl) -- GADTs
- = putSrcSpanDs loc $
- do { dsWarn (hang ds_msg 4 (ppr con_decl))
- ; return (panic "DsMeta:repC") }
+ = putSrcSpanDs loc $
+ notHandled "GADT declaration" (ppr con_decl)
repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
repBangTy ty= do
rep_deriv :: LHsType Name -> DsM (Core TH.Name)
-- Deriving clauses must have the simple H98 form
rep_deriv (L _ (HsPredTy (HsClassP cls []))) = lookupOcc cls
- rep_deriv other = panic "rep_deriv"
+ rep_deriv other = notHandled "Non-H98 deriving clause" (ppr other)
-------------------------------------------------------
tcon <- repTy (HsTyVar cls)
tys1 <- repLTys tys
repTapps tcon tys1
-repPred (HsIParam _ _) =
- panic "DsMeta.repTy: Can't represent predicates with implicit parameters"
+repPred p@(HsIParam _ _) = notHandled "Implicit parameter constraint" (ppr p)
-- yield the representation of a list of types
--
repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
`nlHsAppTy` ty2)
repTy (HsParTy t) = repLTy t
-repTy (HsNumTy i) =
- panic "DsMeta.repTy: Can't represent number types (for generics)"
repTy (HsPredTy pred) = repPred pred
-repTy (HsKindSig ty kind) =
- panic "DsMeta.repTy: Can't represent explicit kind signatures yet"
+repTy ty@(HsNumTy _) = notHandled "Number types (for generics)" (ppr ty)
+repTy ty = notHandled "Exotic form of type" (ppr ty)
-----------------------------------------------------------------------------
-- unless we can make sure that constructs, which are plainly not
-- supported in TH already lead to error messages at an earlier stage
repLE :: LHsExpr Name -> DsM (Core TH.ExpQ)
-repLE (L _ e) = repE e
+repLE (L loc e) = putSrcSpanDs loc (repE e)
repE :: HsExpr Name -> DsM (Core TH.ExpQ)
repE (HsVar x) =
Just (Bound y) -> repVarOrCon x (coreVar y)
Just (Splice e) -> do { e' <- dsExpr e
; return (MkC e') } }
-repE (HsIPVar x) = panic "DsMeta.repE: Can't represent implicit parameters"
+repE e@(HsIPVar x) = notHandled "Implicit parameters" (ppr e)
-- Remember, we're desugaring renamer output here, so
-- HsOverlit can definitely occur
ret <- repNoBindSt body';
e <- repComp (nonEmptyCoreList (zs ++ [ret]));
wrapGenSyns ss e }
-repE (HsDo _ _ _ _) = panic "DsMeta.repE: Can't represent mdo and [: :] yet"
+repE e@(HsDo _ _ _ _) = notHandled "mdo and [: :]" (ppr e)
repE (ExplicitList ty es) = do { xs <- repLEs es; repListExp xs }
-repE (ExplicitPArr ty es) =
- panic "DsMeta.repE: No explicit parallel arrays yet"
-repE (ExplicitTuple es boxed)
+repE e@(ExplicitPArr ty es) = notHandled "Parallel arrays" (ppr e)
+repE e@(ExplicitTuple es boxed)
| isBoxed boxed = do { xs <- repLEs es; repTup xs }
- | otherwise = panic "DsMeta.repE: Can't represent unboxed tuples"
+ | otherwise = notHandled "Unboxed tuples" (ppr e)
repE (RecordCon c _ flds)
= do { x <- lookupLOcc c;
fs <- repFields flds;
ds2 <- repLE e2
ds3 <- repLE e3
repFromThenTo ds1 ds2 ds3
-repE (PArrSeq _ aseq) = panic "DsMeta.repE: parallel array seq.s missing"
-repE (HsCoreAnn _ _) = panic "DsMeta.repE: Can't represent CoreAnn" -- hdaume: core annotations
-repE (HsSCC _ _) = panic "DsMeta.repE: Can't represent SCC"
-repE (HsBracketOut _ _) = panic "DsMeta.repE: Can't represent Oxford brackets"
repE (HsSpliceE (HsSplice n _))
= do { mb_val <- dsLookupMetaEnv n
; case mb_val of
Just (Splice e) -> do { e' <- dsExpr e
; return (MkC e') }
- other -> pprPanic "HsSplice" (ppr n) }
+ other -> pprPanic "HsSplice" (ppr n) }
+ -- Should not happen; statically checked
-repE e = pprPanic "DsMeta.repE: Illegal expression form" (ppr e)
+repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e)
+repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e)
+repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e)
+repE e@(HsBracketOut {}) = notHandled "TH brackets" (ppr e)
+repE e = notHandled "Expression form" (ppr e)
-----------------------------------------------------------------------------
-- Building representations of auxillary structures like Match, Clause, Stmt,
; gs <- repGuards guards
; match <- repMatch p1 gs ds
; wrapGenSyns (ss1++ss2) match }}}
+repMatchTup other = panic "repMatchTup: case alt with more than one arg"
repClauseTup :: LMatch Name -> DsM (Core TH.ClauseQ)
repClauseTup (L _ (Match ps ty (GRHSs guards wheres))) =
; z <- repNoBindSt e2
; (ss2,zs) <- repSts ss
; return (ss2, z : zs) }
-repSts [] = return ([],[])
-repSts other = panic "Exotic Stmt in meta brackets"
+repSts [] = return ([],[])
+repSts other = notHandled "Exotic statement" (ppr other)
-----------------------------------------------------------
= do { core_list <- coreList decQTyConName []
; return ([], core_list) }
-repBinds (HsIPBinds _)
- = panic "DsMeta:repBinds: can't do implicit parameters"
+repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b)
repBinds (HsValBinds decs)
= do { let { bndrs = map unLoc (collectHsValBinders decs) }
= do { core1 <- rep_binds' (unionManyBags (map snd binds))
; core2 <- rep_sigs' sigs
; return (core1 ++ core2) }
+rep_val_binds (ValBindsOut binds sigs)
+ = panic "rep_val_binds: ValBindsOut"
rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ]
rep_binds binds = do { binds_w_locs <- rep_binds' binds
; ans <- repVal patcore x empty_decls
; return (srcLocSpan (getSrcLoc v), ans) }
+rep_bind other = panic "rep_bind: AbsBinds"
+
-----------------------------------------------------------------------------
-- Since everything in a Bind is mutually recursive we need rename all
-- all the variables simultaneously. For example:
do { xs <- repLPs ps; body <- repLE e; repLam xs body })
; wrapGenSyns ss lam }
-repLambda z = panic "Can't represent a guarded lambda in Template Haskell"
+repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch LambdaExpr m)
-----------------------------------------------------------------------------
p2' <- repLP p2;
repPinfix p1' con_str p2' }
}
-repP (NPat l (Just _) _ _) = panic "Can't cope with negative overloaded patterns yet (repP (NPat _ (Just _)))"
repP (NPat l Nothing _ _) = do { a <- repOverloadedLiteral l; repPlit a }
-repP (SigPatIn p t) = do { p' <- repLP p; t' <- repLTy t; repPsig p' t' }
-repP other = panic "Exotic pattern inside meta brackets"
+repP p@(NPat l (Just _) _ _) = notHandled "Negative overloaded patterns" (ppr p)
+repP p@(SigPatIn {}) = notHandled "Type signatures in patterns" (ppr p)
+ -- The problem is to do with scoped type variables.
+ -- To implement them, we have to implement the scoping rules
+ -- here in DsMeta, and I don't want to do that today!
+ -- do { p' <- repLP p; t' <- repLTy t; repPsig p' t' }
+ -- repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
+ -- repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
+
+repP other = notHandled "Exotic pattern" (ppr other)
----------------------------------------------------------
-- Declaration ordering helpers
= do { mb_val <- dsLookupMetaEnv n;
case mb_val of
Just (Bound x) -> return (coreVar x)
- other -> pprPanic "DsMeta: failed binder lookup when desugaring a TH bracket:" (ppr n) }
+ other -> failWithDs msg }
+ where
+ msg = ptext SLIT("DsMeta: failed binder lookup when desugaring a TH bracket:") <+> ppr n
-- Look up a name that is either locally bound or a global name
--
repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
repPlist (MkC ps) = rep2 listPName [ps]
-repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
-repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
-
--------------- Expressions -----------------
repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
HsDoublePrim r -> mk_rational r
_ -> return lit
lit_expr <- dsLit lit'
- rep2 lit_name [lit_expr]
+ case mb_lit_name of
+ Just lit_name -> rep2 lit_name [lit_expr]
+ Nothing -> notHandled "Exotic literal" (ppr lit)
where
- lit_name = case lit of
- HsInteger _ _ -> integerLName
- HsInt _ -> integerLName
- HsIntPrim _ -> intPrimLName
- HsFloatPrim _ -> floatPrimLName
- HsDoublePrim _ -> doublePrimLName
- HsChar _ -> charLName
- HsString _ -> stringLName
- HsRat _ _ -> rationalLName
- other -> uh_oh
- uh_oh = pprPanic "DsMeta.repLiteral: trying to represent exotic literal"
- (ppr lit)
+ mb_lit_name = case lit of
+ HsInteger _ _ -> Just integerLName
+ HsInt _ -> Just integerLName
+ HsIntPrim _ -> Just intPrimLName
+ HsFloatPrim _ -> Just floatPrimLName
+ HsDoublePrim _ -> Just doublePrimLName
+ HsChar _ -> Just charLName
+ HsString _ -> Just stringLName
+ HsRat _ _ -> Just rationalLName
+ other -> Nothing
mk_integer i = do integer_ty <- lookupType integerTyConName
return $ HsInteger i integer_ty
coreVar :: Id -> Core TH.Name -- The Id has type Name
coreVar id = MkC (Var id)
+----------------- Failure -----------------------
+notHandled :: String -> SDoc -> DsM a
+notHandled what doc = failWithDs msg
+ where
+ msg = hang (text what <+> ptext SLIT("not (yet) handled by Template Haskell"))
+ 2 doc
-- %************************************************************************
\begin{code}
module DsMonad (
DsM, mappM, mapAndUnzipM,
- initDs, returnDs, thenDs, listDs, fixDs, mapAndUnzipDs,
+ initDs, initDsTc, returnDs, thenDs, listDs, fixDs, mapAndUnzipDs,
foldlDs, foldrDs,
newTyVarsDs, newLocalName,
DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
-- Warnings
- DsWarning, dsWarn,
+ DsWarning, warnDs, failWithDs,
-- Data types
DsMatchContext(..),
import HsSyn ( HsExpr, HsMatchContext, Pat )
import TcIface ( tcIfaceGlobal )
import RdrName ( GlobalRdrEnv )
-import HscTypes ( TyThing(..), TypeEnv, HscEnv,
+import HscTypes ( TyThing(..), TypeEnv, HscEnv(..),
tyThingId, tyThingTyCon, tyThingDataCon, mkPrintUnqualified )
-import Bag ( emptyBag, snocBag, Bag )
+import Bag ( emptyBag, snocBag )
import DataCon ( DataCon )
import TyCon ( TyCon )
import Id ( mkSysLocal, setIdUnique, Id )
import NameEnv
import OccName ( occNameFS )
import DynFlags ( DynFlags )
-import ErrUtils ( WarnMsg, mkWarnMsg )
-import Bag ( mapBag )
-
+import ErrUtils ( Messages, mkWarnMsg, mkErrMsg,
+ printErrorsAndWarnings, errorsFound )
import DATA_IOREF ( newIORef, readIORef )
infixr 9 `thenDs`
data DsGblEnv = DsGblEnv {
ds_mod :: Module, -- For SCC profiling
- ds_warns :: IORef (Bag DsWarning), -- Warning messages
+ ds_unqual :: PrintUnqualified,
+ ds_msgs :: IORef Messages, -- Warning messages
ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global,
-- possibly-imported things
}
| Splice (HsExpr Id) -- These bindings are introduced by
-- the PendingSplices on a HsBracketOut
--- initDs returns the UniqSupply out the end (not just the result)
-
initDs :: HscEnv
-> Module -> GlobalRdrEnv -> TypeEnv
-> DsM a
- -> IO (a, Bag WarnMsg)
+ -> IO (Maybe a)
+-- Print errors and warnings, if any arise
initDs hsc_env mod rdr_env type_env thing_inside
- = do { warn_var <- newIORef emptyBag
- ; let { if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
- ; if_lenv = mkIfLclEnv mod (ptext SLIT("GHC error in desugarer lookup in") <+> ppr mod)
- ; gbl_env = DsGblEnv { ds_mod = mod,
- ds_if_env = (if_genv, if_lenv),
- ds_warns = warn_var }
- ; lcl_env = DsLclEnv { ds_meta = emptyNameEnv,
- ds_loc = noSrcSpan } }
-
- ; res <- initTcRnIf 'd' hsc_env gbl_env lcl_env thing_inside
-
- ; warns <- readIORef warn_var
- ; return (res, mapBag mk_warn warns)
- }
- where
- print_unqual = mkPrintUnqualified rdr_env
-
- mk_warn :: (SrcSpan,SDoc) -> WarnMsg
- mk_warn (loc,sdoc) = mkWarnMsg loc print_unqual sdoc
+ = do { msg_var <- newIORef (emptyBag, emptyBag)
+ ; let (ds_gbl_env, ds_lcl_env) = mkDsEnvs mod rdr_env type_env msg_var
+
+ ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
+ tryM thing_inside -- Catch exceptions (= errors during desugaring)
+
+ -- Display any errors and warnings
+ -- Note: if -Werror is used, we don't signal an error here.
+ ; let dflags = hsc_dflags hsc_env
+ ; msgs <- readIORef msg_var
+ ; printErrorsAndWarnings dflags msgs
+
+ ; let final_res | errorsFound dflags msgs = Nothing
+ | otherwise = case either_res of
+ Right res -> Just res
+ Left exn -> pprPanic "initDs" (text (show exn))
+ -- The (Left exn) case happens when the thing_inside throws
+ -- a UserError exception. Then it should have put an error
+ -- message in msg_var, so we just discard the exception
+
+ ; return final_res }
+
+initDsTc :: DsM a -> TcM a
+initDsTc thing_inside
+ = do { this_mod <- getModule
+ ; tcg_env <- getGblEnv
+ ; msg_var <- getErrsVar
+ ; let type_env = tcg_type_env tcg_env
+ rdr_env = tcg_rdr_env tcg_env
+ ; setEnvs (mkDsEnvs this_mod rdr_env type_env msg_var) thing_inside }
+
+mkDsEnvs :: Module -> GlobalRdrEnv -> TypeEnv
+ -> IORef Messages -> (DsGblEnv, DsLclEnv)
+mkDsEnvs mod rdr_env type_env msg_var
+ = (gbl_env, lcl_env)
+ where
+ if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
+ if_lenv = mkIfLclEnv mod (ptext SLIT("GHC error in desugarer lookup in") <+> ppr mod)
+ gbl_env = DsGblEnv { ds_mod = mod,
+ ds_if_env = (if_genv, if_lenv),
+ ds_unqual = mkPrintUnqualified rdr_env,
+ ds_msgs = msg_var }
+ lcl_env = DsLclEnv { ds_meta = emptyNameEnv,
+ ds_loc = noSrcSpan }
\end{code}
%************************************************************************
putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
-dsWarn :: SDoc -> DsM ()
-dsWarn warn = do { env <- getGblEnv
+warnDs :: SDoc -> DsM ()
+warnDs warn = do { env <- getGblEnv
; loc <- getSrcSpanDs
- ; updMutVar (ds_warns env) (`snocBag` (loc,msg)) }
+ ; let msg = mkWarnMsg loc (ds_unqual env)
+ (ptext SLIT("Warning:") <+> warn)
+ ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
where
- msg = ptext SLIT("Warning:") <+> warn
+
+failWithDs :: SDoc -> DsM a
+failWithDs err
+ = do { env <- getGblEnv
+ ; loc <- getSrcSpanDs
+ ; let msg = mkErrMsg loc (ds_unqual env) err
+ ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg))
+ ; failM }
+ where
\end{code}
\begin{code}
\begin{code}
dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM ()
dsShadowWarn ctx@(DsMatchContext kind loc) qs
- = putSrcSpanDs loc (dsWarn warn)
+ = putSrcSpanDs loc (warnDs warn)
where
warn | qs `lengthExceeds` maximum_output
= pp_context ctx (ptext SLIT("are overlapped"))
dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM ()
dsIncompleteWarn ctx@(DsMatchContext kind loc) pats
- = putSrcSpanDs loc (dsWarn warn)
+ = putSrcSpanDs loc (warnDs warn)
where
warn = pp_context ctx (ptext SLIT("are non-exhaustive"))
(\f -> hang (ptext SLIT("Patterns not matched:"))
#include "HsVersions.h"
#ifdef GHCI
-import HsSyn ( Stmt(..), LHsExpr, LStmt, LHsType )
-import Module ( Module )
+import HsSyn ( Stmt(..), LStmt, LHsType )
import CodeOutput ( outputForeignStubs )
import ByteCodeGen ( byteCodeGen, coreExprToBCOs )
import Linker ( HValue, linkExpr )
+import CoreSyn ( CoreExpr )
import CoreTidy ( tidyExpr )
import CorePrep ( corePrepExpr )
import Flattening ( flattenExpr )
import Kind ( Kind )
import CoreLint ( lintUnfolding )
import DsMeta ( templateHaskellNames )
-import SrcLoc ( noSrcLoc, getLoc )
+import SrcLoc ( SrcSpan, noSrcLoc, interactiveSrcLoc, srcLocSpan )
import VarEnv ( emptyTidyEnv )
#endif
-------------------
-- DESUGAR
-------------------
- -> do (warns, maybe_ds_result) <- {-# SCC "DeSugar" #-}
- deSugar hsc_env tc_result
- printBagOfWarnings dflags warns
- return maybe_ds_result
+ -> {-# SCC "DeSugar" #-} deSugar hsc_env tc_result
--------------------------------------------------------------
-- Simplifiers
Nothing -> return Nothing ;
Just (new_ic, bound_names, tc_expr) -> do {
+
+ -- Desugar it
+ ; let rdr_env = ic_rn_gbl_env new_ic
+ type_env = ic_type_env new_ic
+ ; mb_ds_expr <- deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr
+
+ ; case mb_ds_expr of {
+ Nothing -> return Nothing ;
+ Just ds_expr -> do {
+
-- Then desugar, code gen, and link it
- ; hval <- compileExpr hsc_env iNTERACTIVE
- (ic_rn_gbl_env new_ic)
- (ic_type_env new_ic)
- tc_expr
+ ; let src_span = srcLocSpan interactiveSrcLoc
+ ; hval <- compileExpr hsc_env src_span ds_expr
; return (Just (hsc_env{ hsc_IC=new_ic }, bound_names, hval))
- }}}}}
+ }}}}}}}
hscTcExpr -- Typecheck an expression (but don't run it)
:: HscEnv
\begin{code}
#ifdef GHCI
-compileExpr :: HscEnv
- -> Module -> GlobalRdrEnv -> TypeEnv
- -> LHsExpr Id
- -> IO HValue
+compileExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
-compileExpr hsc_env this_mod rdr_env type_env tc_expr
+compileExpr hsc_env srcspan ds_expr
= do { let { dflags = hsc_dflags hsc_env ;
- lint_on = dopt Opt_DoCoreLinting dflags ;
- !srcspan = getLoc tc_expr }
+ lint_on = dopt Opt_DoCoreLinting dflags }
- -- Desugar it
- ; ds_expr <- deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
-
-- Flatten it
; flat_expr <- flattenExpr hsc_env ds_expr
Dependencies(..) )
import BasicTypes ( Fixity, RecFlag(..) )
import SrcLoc ( unLoc )
+import Data.Maybe ( isNothing )
#endif
import FastString ( mkFastString )
import Util ( sortLe )
import Bag ( unionBags, snocBag, emptyBag, unitBag, unionManyBags )
-import Data.Maybe ( isJust, isNothing )
+import Data.Maybe ( isJust )
\end{code}
import IdInfo ( GlobalIdDetails(..) )
import TysWiredIn ( mkListTy )
import DsMeta ( expQTyConName, typeQTyConName, decTyConName, qTyConName, nameTyConName )
+import DsExpr ( dsLExpr )
+import DsMonad ( initDsTc )
import ErrUtils ( Message )
import SrcLoc ( SrcSpan, noLoc, unLoc, getLoc )
import Outputable
-> LHsExpr Id -- Of type X
-> TcM hs_syn -- Of type t
runMeta convert expr
- = do { hsc_env <- getTopEnv
- ; tcg_env <- getGblEnv
- ; this_mod <- getModule
- ; let type_env = tcg_type_env tcg_env
- rdr_env = tcg_rdr_env tcg_env
+ = do { -- Desugar
+ ds_expr <- initDsTc (dsLExpr expr)
-- Compile and link it; might fail if linking fails
+ ; hsc_env <- getTopEnv
+ ; src_span <- getSrcSpanM
; either_hval <- tryM $ ioToTcRn $
- HscMain.compileExpr
- hsc_env this_mod
- rdr_env type_env expr
+ HscMain.compileExpr hsc_env src_span ds_expr
; case either_hval of {
Left exn -> failWithTc (mk_msg "compile and link" exn) ;
Right hval -> do