Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
GHC
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Locked Files
Issues
4,251
Issues
4,251
List
Boards
Labels
Service Desk
Milestones
Iterations
Merge Requests
394
Merge Requests
394
Requirements
Requirements
List
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Security & Compliance
Security & Compliance
Dependency List
License Compliance
Operations
Operations
Incidents
Environments
Analytics
Analytics
CI / CD
Code Review
Insights
Issue
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
76465093
Commit
76465093
authored
Dec 10, 2003
by
simonmar
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
[project @ 2003-12-10 14:21:36 by simonmar]
New file of miscellaneous utility functions over HsSyn.
parent
55042138
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
with
241 additions
and
0 deletions
+241
-0
ghc/compiler/hsSyn/HsUtils.lhs
ghc/compiler/hsSyn/HsUtils.lhs
+241
-0
No files found.
ghc/compiler/hsSyn/HsUtils.lhs
0 → 100644
View file @
76465093
%
% (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}
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment