+
%
% (c) The University of Glasgow, 1992-2006
%
\begin{code}
module HsUtils where
-#include "HsVersions.h"
-
import HsBinds
import HsExpr
import HsPat
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))
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
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
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
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
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
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
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}
%************************************************************************
%* *
fun_tick = Nothing }
-mkVarBind :: SrcSpan -> id -> LHsExpr id -> LHsBind id
-mkVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
+mkHsVarBind :: SrcSpan -> id -> LHsExpr id -> LHsBind id
+mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
+
+mkVarBind :: id -> LHsExpr id -> LHsBind id
+mkVarBind var rhs = L (getLoc rhs) $
+ VarBind { var_id = var, var_rhs = rhs, var_inline = False }
------------
mk_easy_FunBind :: SrcSpan -> id -> [LPat id]
= 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}
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}