\section[DsExpr]{Matching expressions (Exprs)}
\begin{code}
-module DsExpr ( dsExpr, dsLet ) where
+module DsExpr ( dsExpr, dsLet, dsLit ) where
#include "HsVersions.h"
-import HsSyn ( failureFreePat,
- HsExpr(..), OutPat(..), HsLit(..), ArithSeqInfo(..),
- Stmt(..), HsMatchContext(..), HsDoContext(..),
- Match(..), HsBinds(..), MonoBinds(..),
- mkSimpleMatch
+import Match ( matchWrapper, matchSimply )
+import MatchLit ( dsLit )
+import DsBinds ( dsMonoBinds, AutoScc(..) )
+import DsGRHSs ( dsGuarded )
+import DsCCall ( dsCCall )
+import DsListComp ( dsListComp, dsPArrComp )
+import DsUtils ( mkErrorAppDs, mkStringLit, mkConsExpr, mkNilExpr, selectMatchVar )
+import DsMonad
+
+#ifdef GHCI
+ -- Template Haskell stuff iff bootstrapped
+import DsMeta ( dsBracket, dsReify )
+#endif
+
+import HsSyn ( HsExpr(..), Pat(..), HsLit(..), ArithSeqInfo(..),
+ Stmt(..), HsMatchContext(..), HsStmtContext(..),
+ Match(..), HsBinds(..), MonoBinds(..), HsConDetails(..),
+ mkSimpleMatch, isDoExpr
)
-import TcHsSyn ( TypecheckedHsExpr, TypecheckedHsBinds, TypecheckedStmt, outPatType )
+import TcHsSyn ( TypecheckedHsExpr, TypecheckedHsBinds, TypecheckedStmt, hsPatType )
-- NB: The desugarer, which straddles the source and Core worlds, sometimes
-- needs to see source types (newtypes etc), and sometimes not
-- Sigh. This is a pain.
import TcType ( tcSplitAppTy, tcSplitFunTys, tcTyConAppArgs,
- isIntegerTy, tcSplitTyConApp, isUnLiftedType, Type )
+ tcSplitTyConApp, isUnLiftedType, Type,
+ mkAppTy )
import Type ( splitFunTys )
import CoreSyn
+import Literal ( Literal(..) )
import CoreUtils ( exprType, mkIfThenElse, bindNonRec )
-import DsMonad
-import DsBinds ( dsMonoBinds, AutoScc(..) )
-import DsGRHSs ( dsGuarded )
-import DsCCall ( dsCCall, resultWrapper )
-import DsListComp ( dsListComp, dsPArrComp )
-import DsUtils ( mkErrorAppDs, mkStringLit, mkStringLitFS,
- mkConsExpr, mkNilExpr, mkIntegerLit
- )
-import Match ( matchWrapper, matchSimply )
-
import FieldLabel ( FieldLabel, fieldLabelTyCon )
import CostCentre ( mkUserCC )
-import Id ( Id, idType, recordSelectorFieldLabel )
+import Id ( Id, idType, idName, recordSelectorFieldLabel )
import PrelInfo ( rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID )
import DataCon ( DataCon, dataConWrapId, dataConFieldLabels, dataConInstOrigArgTys )
import DataCon ( isExistentialDataCon )
-import Literal ( Literal(..) )
+import Name ( Name )
import TyCon ( tyConDataCons )
-import TysWiredIn ( tupleCon, charDataCon, intDataCon )
+import TysWiredIn ( tupleCon, mkTupleTy )
import BasicTypes ( RecFlag(..), Boxity(..), ipNameName )
-import Maybes ( maybeToBool )
-import PrelNames ( hasKey, ratioTyConKey, toPName )
+import PrelNames ( toPName )
+import SrcLoc ( noSrcLoc )
import Util ( zipEqual, zipWithEqual )
import Outputable
-
-import Ratio ( numerator, denominator )
+import FastString
\end{code}
= dsLet b2 body `thenDs` \ body' ->
dsLet b1 body'
+dsLet (IPBinds binds is_with) body
+ = foldlDs dsIPBind body binds
+ where
+ dsIPBind body (n, e)
+ = dsExpr e `thenDs` \ e' ->
+ returnDs (Let (NonRec (ipNameName n) e') body)
+
-- Special case for bindings which bind unlifted variables
-- We need to do a case right away, rather than building
-- a tuple and doing selections.
-- below. Then pattern-match would fail. Urk.)
case binds of
FunMonoBind fun _ matches loc
- -> putSrcLocDs loc $
- matchWrapper (FunRhs fun) matches `thenDs` \ (args, rhs) ->
+ -> putSrcLocDs loc $
+ matchWrapper (FunRhs (idName fun)) matches `thenDs` \ (args, rhs) ->
ASSERT( null args ) -- Functions aren't lifted
returnDs (bindNonRec fun rhs body_w_exports)
\begin{code}
dsExpr :: TypecheckedHsExpr -> DsM CoreExpr
+dsExpr (HsPar x) = dsExpr x
dsExpr (HsVar var) = returnDs (Var var)
dsExpr (HsIPVar ip) = returnDs (Var (ipNameName ip))
dsExpr (HsLit lit) = dsLit lit
= dsExpr body `thenDs` \ body' ->
dsLet binds body'
-dsExpr (HsWith expr binds)
- = dsExpr expr `thenDs` \ expr' ->
- foldlDs dsIPBind expr' binds
- where
- dsIPBind body (n, e)
- = dsExpr e `thenDs` \ e' ->
- returnDs (Let (NonRec (ipNameName n) e') body)
-
-- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
-- because the interpretation of `stmts' depends on what sort of thing it is.
--
-dsExpr (HsDoOut ListComp stmts return_id then_id fail_id result_ty src_loc)
+dsExpr (HsDo ListComp stmts _ result_ty src_loc)
= -- Special case for list comprehensions
putSrcLocDs src_loc $
dsListComp stmts elt_ty
where
(_, [elt_ty]) = tcSplitTyConApp result_ty
-dsExpr (HsDoOut DoExpr stmts return_id then_id fail_id result_ty src_loc)
+dsExpr (HsDo do_or_lc stmts ids result_ty src_loc)
+ | isDoExpr do_or_lc
= putSrcLocDs src_loc $
- dsDo DoExpr stmts return_id then_id fail_id result_ty
+ dsDo do_or_lc stmts ids result_ty
-dsExpr (HsDoOut PArrComp stmts return_id then_id fail_id result_ty src_loc)
+dsExpr (HsDo PArrComp stmts _ result_ty src_loc)
= -- Special case for array comprehensions
putSrcLocDs src_loc $
dsPArrComp stmts elt_ty
-- here at compile time
--
dsExpr (ExplicitPArr ty xs)
- = dsLookupGlobalValue toPName `thenDs` \toP ->
+ = dsLookupGlobalId toPName `thenDs` \toP ->
dsExpr (ExplicitList ty xs) `thenDs` \coreList ->
returnDs (mkApps (Var toP) [Type ty, coreList])
-- hence TcType.tcSplitFunTys
mk_arg (arg_ty, lbl)
- = case [rhs | (sel_id,rhs,_) <- rbinds,
+ = case [rhs | (sel_id,rhs) <- rbinds,
lbl == recordSelectorFieldLabel sel_id] of
(rhs:rhss) -> ASSERT( null rhss )
dsExpr rhs
dictionaries.
\begin{code}
-dsExpr (RecordUpdOut record_expr record_in_ty record_out_ty dicts [])
+dsExpr (RecordUpdOut record_expr record_in_ty record_out_ty [])
= dsExpr record_expr
-dsExpr (RecordUpdOut record_expr record_in_ty record_out_ty dicts rbinds)
+dsExpr expr@(RecordUpdOut record_expr record_in_ty record_out_ty rbinds)
= getSrcLocDs `thenDs` \ src_loc ->
dsExpr record_expr `thenDs` \ record_expr' ->
out_inst_tys = tcTyConAppArgs record_out_ty -- Newtype opaque
mk_val_arg field old_arg_id
- = case [rhs | (sel_id, rhs, _) <- rbinds,
+ = case [rhs | (sel_id, rhs) <- rbinds,
field == recordSelectorFieldLabel sel_id] of
(rhs:rest) -> ASSERT(null rest) rhs
[] -> HsVar old_arg_id
let
val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
(dataConFieldLabels con) arg_ids
- rhs = foldl HsApp (DictApp (TyApp (HsVar (dataConWrapId con))
- out_inst_tys)
- dicts)
+ rhs = foldl HsApp (TyApp (HsVar (dataConWrapId con)) out_inst_tys)
val_args
in
- returnDs (mkSimpleMatch [ConPat con record_in_ty [] [] (map VarPat arg_ids)]
+ returnDs (mkSimpleMatch [ConPatOut con (PrefixCon (map VarPat arg_ids)) record_in_ty [] []]
rhs
record_out_ty
src_loc)
in
-- Record stuff doesn't work for existentials
- ASSERT( all (not . isExistentialDataCon) data_cons )
+ -- The type checker checks for this, but we need
+ -- worry only about the constructors that are to be updated
+ ASSERT2( all (not . isExistentialDataCon) cons_to_upd, ppr expr )
-- It's important to generate the match with matchWrapper,
-- and the right hand sides with applications of the wrapper Id
where
updated_fields :: [FieldLabel]
- updated_fields = [recordSelectorFieldLabel sel_id | (sel_id,_,_) <- rbinds]
+ updated_fields = [recordSelectorFieldLabel sel_id | (sel_id,_) <- rbinds]
-- Get the type constructor from the first field label,
-- so that we are sure it'll have all its DataCons
returnDs (foldl (\f d -> f `App` (Var d)) core_expr dicts)
\end{code}
+Here is where we desugar the Template Haskell brackets and escapes
+
+\begin{code}
+-- Template Haskell stuff
+
+#ifdef GHCI /* Only if bootstrapping */
+dsExpr (HsBracketOut x ps) = dsBracket x ps
+dsExpr (HsReify r) = dsReify r
+dsExpr (HsSplice n e _) = pprPanic "dsExpr:splice" (ppr e)
+#endif
+
+\end{code}
+
+
\begin{code}
#ifdef DEBUG
-- HsSyn constructs that just shouldn't be here:
-dsExpr (HsDo _ _ _) = panic "dsExpr:HsDo"
dsExpr (ExprWithTySig _ _) = panic "dsExpr:ExprWithTySig"
dsExpr (ArithSeqIn _) = panic "dsExpr:ArithSeqIn"
dsExpr (PArrSeqIn _) = panic "dsExpr:PArrSeqIn"
Basically does the translation given in the Haskell~1.3 report:
\begin{code}
-dsDo :: HsDoContext
+dsDo :: HsStmtContext Name
-> [TypecheckedStmt]
- -> Id -- id for: return m
- -> Id -- id for: (>>=) m
- -> Id -- id for: fail m
+ -> [Id] -- id for: [return,fail,>>=,>>] and possibly mfixName
-> Type -- Element type; the whole expression has type (m t)
-> DsM CoreExpr
-dsDo do_or_lc stmts return_id then_id fail_id result_ty
+dsDo do_or_lc stmts ids result_ty
= let
- (_, b_ty) = tcSplitAppTy result_ty -- result_ty must be of the form (m b)
- is_do = case do_or_lc of
- DoExpr -> True
- _ -> False
+ (return_id : fail_id : bind_id : then_id : _) = ids
+ (m_ty, b_ty) = tcSplitAppTy result_ty -- result_ty must be of the form (m b)
+ is_do = isDoExpr do_or_lc -- True for both MDo and Do
-- For ExprStmt, see the comments near HsExpr.Stmt about
-- exactly what ExprStmts mean!
--
- -- In dsDo we can only see DoStmt and ListComp (no gaurds)
+ -- In dsDo we can only see DoStmt and ListComp (no guards)
go [ResultStmt expr locn]
| is_do = do_expr expr locn
| is_do -- Do expression
= do_expr expr locn `thenDs` \ expr2 ->
go stmts `thenDs` \ rest ->
- newSysLocalDs a_ty `thenDs` \ ignored_result_id ->
- returnDs (mkApps (Var then_id) [Type a_ty, Type b_ty, expr2,
- Lam ignored_result_id rest])
+ returnDs (mkApps (Var then_id) [Type a_ty, Type b_ty, expr2, rest])
| otherwise -- List comprehension
= do_expr expr locn `thenDs` \ expr2 ->
dsLet binds rest
go (BindStmt pat expr locn : stmts)
- = putSrcLocDs locn $
- dsExpr expr `thenDs` \ expr2 ->
+ = go stmts `thenDs` \ body ->
+ putSrcLocDs locn $ -- Rest is associated with this location
+ dsExpr expr `thenDs` \ rhs ->
+ mkStringLit (mk_msg locn) `thenDs` \ core_msg ->
let
- a_ty = outPatType pat
- fail_expr = HsApp (TyApp (HsVar fail_id) [b_ty])
- (HsLit (HsString (_PK_ msg)))
- msg = "Pattern match failure in do expression, " ++ showSDoc (ppr locn)
- main_match = mkSimpleMatch [pat]
- (HsDoOut do_or_lc stmts return_id then_id
- fail_id result_ty locn)
- result_ty locn
- the_matches
- | failureFreePat pat = [main_match]
- | otherwise =
- [ main_match
- , mkSimpleMatch [WildPat a_ty] fail_expr result_ty locn
- ]
+ -- In a do expression, pattern-match failure just calls
+ -- the monadic 'fail' rather than throwing an exception
+ fail_expr = mkApps (Var fail_id) [Type b_ty, core_msg]
+ a_ty = hsPatType pat
in
- matchWrapper (DoCtxt do_or_lc) the_matches `thenDs` \ (binders, matching_code) ->
- returnDs (mkApps (Var then_id) [Type a_ty, Type b_ty, expr2,
- mkLams binders matching_code])
+ selectMatchVar pat `thenDs` \ var ->
+ matchSimply (Var var) (StmtCtxt do_or_lc) pat
+ body fail_expr `thenDs` \ match_code ->
+ returnDs (mkApps (Var bind_id) [Type a_ty, Type b_ty, rhs, Lam var match_code])
+
+ go (RecStmt rec_vars rec_stmts rec_rets : stmts)
+ = go (bind_stmt : stmts)
+ where
+ bind_stmt = dsRecStmt m_ty ids rec_vars rec_stmts rec_rets
+
in
go stmts
where
do_expr expr locn = putSrcLocDs locn (dsExpr expr)
+ mk_msg locn = "Pattern match failure in do expression at " ++ showSDoc (ppr locn)
\end{code}
-
-%************************************************************************
-%* *
-\subsection[DsExpr-literals]{Literals}
-%* *
-%************************************************************************
-
-We give int/float literals type @Integer@ and @Rational@, respectively.
-The typechecker will (presumably) have put \tr{from{Integer,Rational}s}
-around them.
-
-ToDo: put in range checks for when converting ``@i@''
-(or should that be in the typechecker?)
-
-For numeric literals, we try to detect there use at a standard type
-(@Int@, @Float@, etc.) are directly put in the right constructor.
-[NB: down with the @App@ conversion.]
-
-See also below where we look for @DictApps@ for \tr{plusInt}, etc.
+Translation for RecStmt's:
+-----------------------------
+We turn (RecStmt [v1,..vn] stmts) into:
+
+ (v1,..,vn) <- mfix (\~(v1,..vn). do stmts
+ return (v1,..vn))
\begin{code}
-dsLit :: HsLit -> DsM CoreExpr
-dsLit (HsChar c) = returnDs (mkConApp charDataCon [mkLit (MachChar c)])
-dsLit (HsCharPrim c) = returnDs (mkLit (MachChar c))
-dsLit (HsString str) = mkStringLitFS str
-dsLit (HsStringPrim s) = returnDs (mkLit (MachStr s))
-dsLit (HsInteger i) = mkIntegerLit i
-dsLit (HsInt i) = returnDs (mkConApp intDataCon [mkIntLit i])
-dsLit (HsIntPrim i) = returnDs (mkIntLit i)
-dsLit (HsFloatPrim f) = returnDs (mkLit (MachFloat f))
-dsLit (HsDoublePrim d) = returnDs (mkLit (MachDouble d))
-dsLit (HsLitLit str ty)
- = ASSERT( maybeToBool maybe_ty )
- returnDs (wrap_fn (mkLit (MachLitLit str rep_ty)))
- where
- (maybe_ty, wrap_fn) = resultWrapper ty
- Just rep_ty = maybe_ty
-
-dsLit (HsRat r ty)
- = mkIntegerLit (numerator r) `thenDs` \ num ->
- mkIntegerLit (denominator r) `thenDs` \ denom ->
- returnDs (mkConApp ratio_data_con [Type integer_ty, num, denom])
- where
- (ratio_data_con, integer_ty)
- = case tcSplitTyConApp ty of
- (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
- (head (tyConDataCons tycon), i_ty)
+dsRecStmt :: Type -- Monad type constructor :: * -> *
+ -> [Id] -- Ids for: [return,fail,>>=,>>,mfix]
+ -> [Id] -> [TypecheckedStmt] -> [TypecheckedHsExpr] -- Guts of the RecStmt
+ -> TypecheckedStmt
+dsRecStmt m_ty ids@[return_id, _, _, _, mfix_id] vars stmts rets
+ = ASSERT( length vars == length rets )
+ BindStmt tup_pat mfix_app noSrcLoc
+ where
+ (var1:rest) = vars -- Always at least one
+ (ret1:_) = rets
+ one_var = null rest
+
+ mfix_app = HsApp (TyApp (HsVar mfix_id) [tup_ty]) mfix_arg
+ mfix_arg = HsLam (mkSimpleMatch [tup_pat] body tup_ty noSrcLoc)
+
+ tup_expr | one_var = ret1
+ | otherwise = ExplicitTuple rets Boxed
+ tup_ty | one_var = idType var1
+ | otherwise = mkTupleTy Boxed (length vars) (map idType vars)
+ tup_pat | one_var = VarPat var1
+ | otherwise = LazyPat (TuplePat (map VarPat vars) Boxed)
+
+ body = HsDo DoExpr (stmts ++ [return_stmt])
+ ids -- Don't need the mfix, but it does no harm
+ (mkAppTy m_ty tup_ty)
+ noSrcLoc
+
+ return_stmt = ResultStmt return_app noSrcLoc
+ return_app = HsApp (TyApp (HsVar return_id) [tup_ty]) tup_expr
\end{code}
projects / ghc-hetmet.git / blobdiff