--- /dev/null
+%
+% (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}
+
projects / ghc-hetmet.git / commitdiff