Add 'rec' to stmts in a 'do', and deprecate 'mdo'

[ghc-hetmet.git] / compiler / hsSyn / HsUtils.lhs

diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index ee10a42..66d9ed3 100644 (file)
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -15,8 +15,6 @@ which deal with the intantiated versions are located elsewhere:
 \begin{code}
 module HsUtils where
 
-#include "HsVersions.h"
-
 import HsBinds
 import HsExpr
 import HsPat
@@ -85,11 +83,11 @@ mkHsWrap co_fn e | isIdHsWrapper co_fn = e
 
 mkHsWrapCoI :: CoercionI -> HsExpr id -> HsExpr id
 mkHsWrapCoI IdCo     e = e
-mkHsWrapCoI (ACo co) e = mkHsWrap (WpCo co) e
+mkHsWrapCoI (ACo co) e = mkHsWrap (WpCast co) e
 
 coiToHsWrapper :: CoercionI -> HsWrapper
 coiToHsWrapper IdCo     = idHsWrapper
-coiToHsWrapper (ACo co) = WpCo co
+coiToHsWrapper (ACo co) = WpCast co
 
 mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
 mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
@@ -141,12 +139,18 @@ mkGroupByUsingStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL id
 
 mkExprStmt :: LHsExpr idR -> StmtLR idL idR
 mkBindStmt :: LPat idL -> LHsExpr idR -> StmtLR idL idR
-mkRecStmt  :: [LStmtLR idL idR] -> StmtLR idL idR
 
+emptyRecStmt :: StmtLR idL idR
+mkRecStmt    :: [LStmtLR idL idR] -> StmtLR idL idR
+
+
+mkHsIntegral   i       = OverLit (HsIntegral   i)  noRebindableInfo noSyntaxExpr
+mkHsFractional f       = OverLit (HsFractional f)  noRebindableInfo noSyntaxExpr
+mkHsIsString   s       = OverLit (HsIsString   s)  noRebindableInfo noSyntaxExpr
+
+noRebindableInfo :: Bool
+noRebindableInfo = error "noRebindableInfo"    -- Just another placeholder; 
 
-mkHsIntegral   i       = HsIntegral   i  noSyntaxExpr
-mkHsFractional f       = HsFractional f  noSyntaxExpr
-mkHsIsString   s       = HsIsString   s  noSyntaxExpr
 mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType
 
 mkNPat lit neg     = NPat lit neg noSyntaxExpr
@@ -161,7 +165,13 @@ mkGroupByUsingStmt stmts byExpr usingExpr = GroupStmt (stmts, []) (GroupBySometh
 
 mkExprStmt expr            = ExprStmt expr noSyntaxExpr placeHolderType
 mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr
-mkRecStmt stmts            = RecStmt stmts [] [] [] emptyLHsBinds
+
+emptyRecStmt = RecStmt { recS_stmts = [], recS_later_ids = [], recS_rec_ids = []
+                       , recS_ret_fn = noSyntaxExpr, recS_mfix_fn = noSyntaxExpr
+                      , recS_bind_fn = noSyntaxExpr
+                       , recS_rec_rets = [], recS_dicts = emptyLHsBinds }
+
+mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts }
 
 -------------------------------
 --- A useful function for building @OpApps@.  The operator is always a
@@ -173,7 +183,7 @@ mkHsSplice :: LHsExpr RdrName -> HsSplice RdrName
 mkHsSplice e = HsSplice unqualSplice e
 
 unqualSplice :: RdrName
-unqualSplice = mkRdrUnqual (mkVarOccFS FSLIT("splice"))
+unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))
                -- A name (uniquified later) to
                -- identify the splice
 
@@ -181,7 +191,7 @@ mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsQuasiQuote RdrName
 mkHsQuasiQuote quoter span quote = HsQuasiQuote unqualQuasiQuote quoter span quote
 
 unqualQuasiQuote :: RdrName
-unqualQuasiQuote = mkRdrUnqual (mkVarOccFS FSLIT("quasiquote"))
+unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
                -- A name (uniquified later) to
                -- identify the quasi-quote
 
@@ -243,9 +253,6 @@ nlWildConPat :: DataCon -> LPat RdrName
 nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
                                   (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat)))
 
-nlTuplePat :: [LPat id] -> Boxity -> LPat id
-nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType)
-
 nlWildPat :: LPat id
 nlWildPat  = noLoc (WildPat placeHolderType)   -- Pre-typechecking
 
@@ -259,14 +266,12 @@ nlHsLam  :: LMatch id -> LHsExpr id
 nlHsPar  :: LHsExpr id -> LHsExpr id
 nlHsIf   :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id
 nlHsCase :: LHsExpr id -> [LMatch id] -> LHsExpr id
-nlTuple  :: [LHsExpr id] -> Boxity -> LHsExpr id
 nlList   :: [LHsExpr id] -> LHsExpr id
 
 nlHsLam        match           = noLoc (HsLam (mkMatchGroup [match]))
 nlHsPar e              = noLoc (HsPar e)
 nlHsIf cond true false = noLoc (HsIf cond true false)
 nlHsCase expr matches  = noLoc (HsCase expr (mkMatchGroup matches))
-nlTuple exprs box      = noLoc (ExplicitTuple exprs box)
 nlList exprs           = noLoc (ExplicitList placeHolderType exprs)
 
 nlHsAppTy :: LHsType name -> LHsType name -> LHsType name
@@ -281,7 +286,24 @@ nlHsTyConApp :: name -> [LHsType name] -> LHsType name
 nlHsTyConApp tycon tys  = foldl nlHsAppTy (nlHsTyVar tycon) tys
 \end{code}
 
+Tuples.  All these functions are *pre-typechecker* because they lack
+types on the tuple.
+
+\begin{code}
+mkLHsTupleExpr :: [LHsExpr a] -> LHsExpr a
+-- Makes a pre-typechecker boxed tuple, deals with 1 case
+mkLHsTupleExpr [e] = e
+mkLHsTupleExpr es  = noLoc $ ExplicitTuple (map Present es) Boxed
+
+mkLHsVarTuple :: [a] -> LHsExpr a
+mkLHsVarTuple ids  = mkLHsTupleExpr (map nlHsVar ids)
 
+nlTuplePat :: [LPat id] -> Boxity -> LPat id
+nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType)
+
+missingTupArg :: HsTupArg a
+missingTupArg = Missing placeHolderType
+\end{code}
 
 %************************************************************************
 %*                                                                     *
@@ -324,9 +346,8 @@ mkMatch pats expr binds
   = noLoc (Match (map paren pats) Nothing 
                 (GRHSs (unguardedRHS expr) binds))
   where
-    paren p = case p of
-               L _ (VarPat _) -> p
-               L l _          -> L l (ParPat p)
+    paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp) 
+                    | otherwise          = lp
 \end{code}
 
 
@@ -401,8 +422,8 @@ collectStmtBinders (ExprStmt _ _ _)     = []
 collectStmtBinders (ParStmt xs)         = collectLStmtsBinders
                                         $ concatMap fst xs
 collectStmtBinders (TransformStmt (stmts, _) _ _) = collectLStmtsBinders stmts
-collectStmtBinders (GroupStmt (stmts, _) _)     = collectLStmtsBinders stmts
-collectStmtBinders (RecStmt ss _ _ _ _) = collectLStmtsBinders ss
+collectStmtBinders (GroupStmt (stmts, _) _)       = collectLStmtsBinders stmts
+collectStmtBinders (RecStmt { recS_stmts = ss })  = collectLStmtsBinders ss
 \end{code}