[project @ 2003-12-10 14:21:36 by simonmar]

New file of miscellaneous utility functions over HsSyn.

ghc/compiler/hsSyn/HsUtils.lhs

+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+
+	Collects a variety of helper functions that
+		construct or analyse HsSyn
+
+\begin{code}
+module HsUtils where
+
+#include "HsVersions.h"
+
+import HsBinds
+import HsExpr
+import HsPat
+import HsTypes	
+import HsLit
+
+import RdrName		( RdrName, getRdrName, mkRdrUnqual )
+import Var		( Id )
+import Type		( Type )
+import DataCon		( DataCon, dataConWrapId, dataConSourceArity )
+import BasicTypes	( RecFlag(..) )
+import OccName		( mkVarOcc )
+import Name		( Name )
+import SrcLoc
+import FastString	( mkFastString )
+import Outputable
+import Util		( nOfThem )
+import Bag
+\end{code}
+
+
+%************************************************************************
+%*									*
+	Some useful helpers for constructing expressions
+%*									*
+%************************************************************************
+
+
+\begin{code}
+mkHsPar :: LHsExpr id -> LHsExpr id
+mkHsPar e = L (getLoc e) (HsPar e)
+
+mkSimpleMatch :: [LPat id] -> LHsExpr id -> Type -> LMatch id
+mkSimpleMatch pats rhs rhs_ty
+  = addCLoc (head pats) rhs $
+    Match pats Nothing (GRHSs (unguardedRHS rhs) [] rhs_ty)
+
+unguardedRHS :: LHsExpr id -> [LGRHS id]
+unguardedRHS rhs@(L loc _) = [L loc (GRHS [L loc (ResultStmt rhs)])]
+
+mkHsAppTy :: LHsType name -> LHsType name -> LHsType name
+mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)
+
+mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
+mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)
+
+mkHsTyApp :: LHsExpr name -> [Type] -> LHsExpr name
+mkHsTyApp expr []  = expr
+mkHsTyApp expr tys = L (getLoc expr) (TyApp expr tys)
+
+mkHsDictApp expr []	 = expr
+mkHsDictApp expr dict_vars = L (getLoc expr) (DictApp expr dict_vars)
+
+mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
+mkHsLam pats body = mkHsPar (L (getLoc match) (HsLam match))
+	where
+	  match = mkSimpleMatch pats body placeHolderType
+
+mkHsTyLam []     expr = expr
+mkHsTyLam tyvars expr = L (getLoc expr) (TyLam tyvars expr)
+
+mkHsDictLam []    expr = expr
+mkHsDictLam dicts expr = L (getLoc expr) (DictLam dicts expr)
+
+mkHsLet :: Bag (LHsBind name) -> LHsExpr name -> LHsExpr name
+mkHsLet binds expr 
+  | isEmptyBag binds = expr
+  | otherwise        = L (getLoc expr) (HsLet [HsBindGroup binds [] Recursive] expr)
+
+mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
+-- Used for constructing dictinoary terms etc, so no locations 
+mkHsConApp data_con tys args 
+  = foldl mk_app (noLoc (HsVar (dataConWrapId data_con)) `mkHsTyApp` tys) args
+  where
+    mk_app f a = noLoc (HsApp f (noLoc a))
+
+mkSimpleHsAlt :: LPat id -> LHsExpr id -> LMatch id
+-- A simple lambda with a single pattern, no binds, no guards; pre-typechecking
+mkSimpleHsAlt pat expr 
+  = mkSimpleMatch [pat] expr placeHolderType
+
+glueBindsOnGRHSs :: HsBindGroup id -> GRHSs id -> GRHSs id
+glueBindsOnGRHSs binds1 (GRHSs grhss binds2 ty)
+  = GRHSs grhss (binds1 : binds2) ty
+
+-- These are the bits of syntax that contain rebindable names
+-- See RnEnv.lookupSyntaxName
+
+mkHsIntegral   i      = HsIntegral   i  placeHolderName
+mkHsFractional f      = HsFractional f  placeHolderName
+mkNPlusKPat n k       = NPlusKPatIn n k placeHolderName
+mkHsDo ctxt stmts     = HsDo ctxt stmts [] placeHolderType
+
+--- A useful function for building @OpApps@.  The operator is always a
+-- variable, and we don't know the fixity yet.
+mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2
+
+mkHsSplice e = HsSplice unqualSplice e
+
+unqualSplice = mkRdrUnqual (mkVarOcc FSLIT("splice"))
+		-- A name (uniquified later) to
+		-- identify the splice
+
+mkHsString s = HsString (mkFastString s)
+\end{code}
+
+
+%************************************************************************
+%*									*
+	These ones do not pin on useful locations
+	Used mainly for generated code
+%*									*
+%************************************************************************
+
+
+\begin{code}
+nlHsVar :: id -> LHsExpr id
+nlHsVar n = noLoc (HsVar n)
+
+nlHsLit :: HsLit -> LHsExpr id
+nlHsLit n = noLoc (HsLit n)
+
+nlVarPat :: id -> LPat id
+nlVarPat n = noLoc (VarPat n)
+
+nlLitPat :: HsLit -> LPat id
+nlLitPat l = noLoc (LitPat l)
+
+nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
+nlHsApp f x = noLoc (HsApp f x)
+
+nlHsIntLit n = noLoc (HsLit (HsInt n))
+
+nlHsApps :: id -> [LHsExpr id] -> LHsExpr id
+nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
+	     
+nlHsVarApps :: id -> [id] -> LHsExpr id
+nlHsVarApps f xs = noLoc (foldl mk (HsVar f) (map HsVar xs))
+		 where
+		   mk f a = HsApp (noLoc f) (noLoc a)
+
+nlConVarPat :: id -> [id] -> LPat id
+nlConVarPat con vars = nlConPat con (map nlVarPat vars)
+
+nlInfixConPat :: id -> LPat id -> LPat id -> LPat id
+nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))
+
+nlConPat :: id -> [LPat id] -> LPat id
+nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
+
+nlNullaryConPat :: id -> LPat id
+nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
+
+nlWildConPat :: DataCon -> LPat RdrName
+nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
+				   (PrefixCon (nOfThem (dataConSourceArity con) wildPat)))
+
+nlTuplePat pats box = noLoc (TuplePat pats box)
+wildPat  = noLoc (WildPat placeHolderType)	-- Pre-typechecking
+
+nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id
+nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)
+
+nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
+
+nlHsLam	match		= noLoc (HsLam match)
+nlHsPar e		= noLoc (HsPar e)
+nlHsIf cond true false	= noLoc (HsIf cond true false)
+nlHsCase expr matches	= noLoc (HsCase expr matches)
+nlTuple exprs box	= noLoc (ExplicitTuple exprs box)
+nlList exprs		= noLoc (ExplicitList placeHolderType exprs)
+
+nlHsAppTy f t		= noLoc (HsAppTy f t)
+nlHsTyVar x		= noLoc (HsTyVar x)
+nlHsFunTy a b		= noLoc (HsFunTy a b)
+
+nlExprStmt expr		= noLoc (ExprStmt expr placeHolderType)
+nlBindStmt pat expr	= noLoc (BindStmt pat expr)
+nlLetStmt binds	 	= noLoc (LetStmt binds)
+nlResultStmt expr	= noLoc (ResultStmt expr)
+nlParStmt stuff		= noLoc (ParStmt stuff)
+\end{code}
+
+
+
+%************************************************************************
+%*									*
+		Bindings; with a location at the top
+%*									*
+%************************************************************************
+
+\begin{code}
+mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
+mkVarBind loc var rhs = mk_easy_FunBind loc var [] emptyBag rhs
+
+mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
+		    -> LHsBinds RdrName -> LHsExpr RdrName
+		    -> LHsBind RdrName
+
+mk_easy_FunBind loc fun pats binds expr
+  = L loc (FunBind (L loc fun) False{-not infix-} 
+	[mk_easy_Match pats binds expr])
+
+mk_easy_Match pats binds expr
+  = mkMatch pats expr [HsBindGroup binds [] Recursive]
+	-- The renamer expects everything in its input to be a
+	-- "recursive" MonoBinds, and it is its job to sort things out
+	-- from there.
+
+mk_FunBind	:: SrcSpan 
+		-> RdrName
+		-> [([LPat RdrName], LHsExpr RdrName)]
+		-> LHsBind RdrName
+
+mk_FunBind loc fun [] = panic "TcGenDeriv:mk_FunBind"
+mk_FunBind loc fun pats_and_exprs
+  = L loc (FunBind (L loc fun) False{-not infix-} 
+			[mkMatch p e [] | (p,e) <-pats_and_exprs])
+
+mkMatch :: [LPat id] -> LHsExpr id -> [HsBindGroup id] -> LMatch id
+mkMatch pats expr binds
+  = noLoc (Match (map paren pats) Nothing 
+		 (GRHSs (unguardedRHS expr) binds placeHolderType))
+  where
+    paren p = case p of
+		L _ (VarPat _) -> p
+		L l _	       -> L l (ParPat p)
+\end{code}
+