Commit 76465093 authored by simonmar's avatar simonmar

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

New file of miscellaneous utility functions over HsSyn.
parent 55042138
%
% (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}
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment