Fix desugaring of unboxed tuples

[ghc-hetmet.git] / ghc / compiler / deSugar / DsMonad.lhs

diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs
index a188e0b..f24dee4 100644 (file)
--- a/ghc/compiler/deSugar/DsMonad.lhs
+++ b/ghc/compiler/deSugar/DsMonad.lhs
@@ -5,10 +5,11 @@
 
 \begin{code}
 module DsMonad (
-       DsM, mappM,
-       initDs, returnDs, thenDs, listDs, fixDs, mapAndUnzipDs, foldlDs,
+       DsM, mappM, mapAndUnzipM,
+       initDs, returnDs, thenDs, listDs, fixDs, mapAndUnzipDs, 
+       foldlDs, foldrDs,
 
-       newTyVarsDs, 
+       newTyVarsDs, newLocalName,
        duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
        newFailLocalDs,
        getSrcSpanDs, putSrcSpanDs,
@@ -20,14 +21,19 @@ module DsMonad (
 
        DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
 
-       dsWarn, 
-       DsWarning,
-       DsMatchContext(..)
+       -- Warnings
+       DsWarning, dsWarn, 
+
+       -- Data types
+       DsMatchContext(..),
+       EquationInfo(..), MatchResult(..), DsWrapper, idWrapper,
+       CanItFail(..), orFail
     ) where
 
 #include "HsVersions.h"
 
 import TcRnMonad
+import CoreSyn         ( CoreExpr )
 import HsSyn           ( HsExpr, HsMatchContext, Pat )
 import TcIface         ( tcIfaceGlobal )
 import RdrName         ( GlobalRdrEnv )
@@ -36,7 +42,6 @@ import HscTypes               ( TyThing(..), TypeEnv, HscEnv,
 import Bag             ( emptyBag, snocBag, Bag )
 import DataCon         ( DataCon )
 import TyCon           ( TyCon )
-import DataCon         ( DataCon )
 import Id              ( mkSysLocal, setIdUnique, Id )
 import Module          ( Module )
 import Var             ( TyVar, setTyVarUnique )
@@ -47,7 +52,7 @@ import UniqSupply     ( UniqSupply, uniqsFromSupply )
 import Name            ( Name, nameOccName )
 import NameEnv
 import OccName          ( occNameFS )
-import CmdLineOpts     ( DynFlags )
+import DynFlags        ( DynFlags )
 import ErrUtils                ( WarnMsg, mkWarnMsg )
 import Bag             ( mapBag )
 
@@ -56,6 +61,53 @@ import DATA_IOREF    ( newIORef, readIORef )
 infixr 9 `thenDs`
 \end{code}
 
+%************************************************************************
+%*                                                                     *
+               Data types for the desugarer
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+data DsMatchContext
+  = DsMatchContext (HsMatchContext Name) SrcSpan
+  | NoMatchContext
+  deriving ()
+
+data EquationInfo
+  = EqnInfo { eqn_wrap :: DsWrapper,   -- Bindings
+             eqn_pats :: [Pat Id],     -- The patterns for an eqn
+             eqn_rhs  :: MatchResult } -- What to do after match
+
+type DsWrapper = CoreExpr -> CoreExpr
+idWrapper e = e
+
+-- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult
+--     \fail. wrap (case vs of { pats -> rhs fail })
+-- where vs are not bound by wrap
+
+
+-- A MatchResult is an expression with a hole in it
+data MatchResult
+  = MatchResult
+       CanItFail       -- Tells whether the failure expression is used
+       (CoreExpr -> DsM CoreExpr)
+                       -- Takes a expression to plug in at the
+                       -- failure point(s). The expression should
+                       -- be duplicatable!
+
+data CanItFail = CanFail | CantFail
+
+orFail CantFail CantFail = CantFail
+orFail _        _       = CanFail
+\end{code}
+
+
+%************************************************************************
+%*                                                                     *
+               Monad stuff
+%*                                                                     *
+%************************************************************************
+
 Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
 a @UniqueSupply@ and some annotations, which
 presumably include source-file location information:
@@ -68,6 +120,7 @@ thenDs   = thenM
 returnDs = returnM
 listDs   = sequenceM
 foldlDs  = foldlM
+foldrDs  = foldrM
 mapAndUnzipDs = mapAndUnzipM
 
 
@@ -129,6 +182,12 @@ initDs hsc_env mod rdr_env type_env thing_inside
     mk_warn (loc,sdoc) = mkWarnMsg loc print_unqual sdoc
 \end{code}
 
+%************************************************************************
+%*                                                                     *
+               Operations in the monad
+%*                                                                     *
+%************************************************************************
+
 And all this mysterious stuff is so we can occasionally reach out and
 grab one or more names.  @newLocalDs@ isn't exported---exported
 functions are defined with it.  The difference in name-strings makes
@@ -182,8 +241,10 @@ getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) }
 putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
 putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
 
-dsWarn :: DsWarning -> DsM ()
-dsWarn (loc,warn) = do { env <- getGblEnv; updMutVar (ds_warns env) (`snocBag` (loc,msg)) }
+dsWarn :: SDoc -> DsM ()
+dsWarn warn = do { env <- getGblEnv 
+                ; loc <- getSrcSpanDs
+                ; updMutVar (ds_warns env) (`snocBag` (loc,msg)) }
            where
              msg = ptext SLIT("Warning:") <+> warn
 \end{code}
@@ -222,15 +283,3 @@ dsExtendMetaEnv menv thing_inside
 \end{code}
 
 
-%************************************************************************
-%*                                                                     *
-\subsection{Type synonym @EquationInfo@ and access functions for its pieces}
-%*                                                                     *
-%************************************************************************
-
-\begin{code}
-data DsMatchContext
-  = DsMatchContext (HsMatchContext Name) [Pat Id] SrcSpan
-  | NoMatchContext
-  deriving ()
-\end{code}