ghc/compiler/hsSyn/HsUtils.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4
   5         Collects a variety of helper functions that
   6                 construct or analyse HsSyn
   7
   8 \begin{code}
   9 module HsUtils where
  10
  11 #include "HsVersions.h"
  12
  13 import HsBinds
  14 import HsExpr
  15 import HsPat
  16 import HsTypes
  17 import HsLit
  18
  19 import RdrName          ( RdrName, getRdrName, mkRdrUnqual )
  20 import Var              ( Id )
  21 import Type             ( Type )
  22 import DataCon          ( DataCon, dataConWrapId, dataConSourceArity )
  23 import BasicTypes       ( RecFlag(..) )
  24 import OccName          ( mkVarOcc )
  25 import Name             ( Name )
  26 import SrcLoc
  27 import FastString       ( mkFastString )
  28 import Outputable
  29 import Util             ( nOfThem )
  30 import Bag
  31 \end{code}
  32
  33
  34 %************************************************************************
  35 %*                                                                      *
  36         Some useful helpers for constructing expressions
  37 %*                                                                      *
  38 %************************************************************************
  39
  40
  41 \begin{code}
  42 mkHsPar :: LHsExpr id -> LHsExpr id
  43 mkHsPar e = L (getLoc e) (HsPar e)
  44
  45 mkSimpleMatch :: [LPat id] -> LHsExpr id -> Type -> LMatch id
  46 mkSimpleMatch pats rhs rhs_ty
  47   = addCLoc (head pats) rhs $
  48     Match pats Nothing (GRHSs (unguardedRHS rhs) [] rhs_ty)
  49
  50 unguardedRHS :: LHsExpr id -> [LGRHS id]
  51 unguardedRHS rhs@(L loc _) = [L loc (GRHS [L loc (ResultStmt rhs)])]
  52
  53 mkHsAppTy :: LHsType name -> LHsType name -> LHsType name
  54 mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)
  55
  56 mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
  57 mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)
  58
  59 mkHsTyApp :: LHsExpr name -> [Type] -> LHsExpr name
  60 mkHsTyApp expr []  = expr
  61 mkHsTyApp expr tys = L (getLoc expr) (TyApp expr tys)
  62
  63 mkHsDictApp expr []      = expr
  64 mkHsDictApp expr dict_vars = L (getLoc expr) (DictApp expr dict_vars)
  65
  66 mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
  67 mkHsLam pats body = mkHsPar (L (getLoc match) (HsLam match))
  68         where
  69           match = mkSimpleMatch pats body placeHolderType
  70
  71 mkHsTyLam []     expr = expr
  72 mkHsTyLam tyvars expr = L (getLoc expr) (TyLam tyvars expr)
  73
  74 mkHsDictLam []    expr = expr
  75 mkHsDictLam dicts expr = L (getLoc expr) (DictLam dicts expr)
  76
  77 mkHsLet :: Bag (LHsBind name) -> LHsExpr name -> LHsExpr name
  78 mkHsLet binds expr
  79   | isEmptyBag binds = expr
  80   | otherwise        = L (getLoc expr) (HsLet [HsBindGroup binds [] Recursive] expr)
  81
  82 mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
  83 -- Used for constructing dictinoary terms etc, so no locations
  84 mkHsConApp data_con tys args
  85   = foldl mk_app (noLoc (HsVar (dataConWrapId data_con)) `mkHsTyApp` tys) args
  86   where
  87     mk_app f a = noLoc (HsApp f (noLoc a))
  88
  89 mkSimpleHsAlt :: LPat id -> LHsExpr id -> LMatch id
  90 -- A simple lambda with a single pattern, no binds, no guards; pre-typechecking
  91 mkSimpleHsAlt pat expr
  92   = mkSimpleMatch [pat] expr placeHolderType
  93
  94 glueBindsOnGRHSs :: HsBindGroup id -> GRHSs id -> GRHSs id
  95 glueBindsOnGRHSs binds1 (GRHSs grhss binds2 ty)
  96   = GRHSs grhss (binds1 : binds2) ty
  97
  98 -- These are the bits of syntax that contain rebindable names
  99 -- See RnEnv.lookupSyntaxName
 100
 101 mkHsIntegral   i      = HsIntegral   i  placeHolderName
 102 mkHsFractional f      = HsFractional f  placeHolderName
 103 mkNPlusKPat n k       = NPlusKPatIn n k placeHolderName
 104 mkHsDo ctxt stmts     = HsDo ctxt stmts [] placeHolderType
 105
 106 --- A useful function for building @OpApps@.  The operator is always a
 107 -- variable, and we don't know the fixity yet.
 108 mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2
 109
 110 mkHsSplice e = HsSplice unqualSplice e
 111
 112 unqualSplice = mkRdrUnqual (mkVarOcc FSLIT("splice"))
 113                 -- A name (uniquified later) to
 114                 -- identify the splice
 115
 116 mkHsString s = HsString (mkFastString s)
 117 \end{code}
 118
 119
 120 %************************************************************************
 121 %*                                                                      *
 122         These ones do not pin on useful locations
 123         Used mainly for generated code
 124 %*                                                                      *
 125 %************************************************************************
 126
 127
 128 \begin{code}
 129 nlHsVar :: id -> LHsExpr id
 130 nlHsVar n = noLoc (HsVar n)
 131
 132 nlHsLit :: HsLit -> LHsExpr id
 133 nlHsLit n = noLoc (HsLit n)
 134
 135 nlVarPat :: id -> LPat id
 136 nlVarPat n = noLoc (VarPat n)
 137
 138 nlLitPat :: HsLit -> LPat id
 139 nlLitPat l = noLoc (LitPat l)
 140
 141 nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
 142 nlHsApp f x = noLoc (HsApp f x)
 143
 144 nlHsIntLit n = noLoc (HsLit (HsInt n))
 145
 146 nlHsApps :: id -> [LHsExpr id] -> LHsExpr id
 147 nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
 148
 149 nlHsVarApps :: id -> [id] -> LHsExpr id
 150 nlHsVarApps f xs = noLoc (foldl mk (HsVar f) (map HsVar xs))
 151                  where
 152                    mk f a = HsApp (noLoc f) (noLoc a)
 153
 154 nlConVarPat :: id -> [id] -> LPat id
 155 nlConVarPat con vars = nlConPat con (map nlVarPat vars)
 156
 157 nlInfixConPat :: id -> LPat id -> LPat id -> LPat id
 158 nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))
 159
 160 nlConPat :: id -> [LPat id] -> LPat id
 161 nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
 162
 163 nlNullaryConPat :: id -> LPat id
 164 nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
 165
 166 nlWildConPat :: DataCon -> LPat RdrName
 167 nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
 168                                    (PrefixCon (nOfThem (dataConSourceArity con) wildPat)))
 169
 170 nlTuplePat pats box = noLoc (TuplePat pats box)
 171 wildPat  = noLoc (WildPat placeHolderType)      -- Pre-typechecking
 172
 173 nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id
 174 nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)
 175
 176 nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
 177
 178 nlHsLam match           = noLoc (HsLam match)
 179 nlHsPar e               = noLoc (HsPar e)
 180 nlHsIf cond true false  = noLoc (HsIf cond true false)
 181 nlHsCase expr matches   = noLoc (HsCase expr matches)
 182 nlTuple exprs box       = noLoc (ExplicitTuple exprs box)
 183 nlList exprs            = noLoc (ExplicitList placeHolderType exprs)
 184
 185 nlHsAppTy f t           = noLoc (HsAppTy f t)
 186 nlHsTyVar x             = noLoc (HsTyVar x)
 187 nlHsFunTy a b           = noLoc (HsFunTy a b)
 188
 189 nlExprStmt expr         = noLoc (ExprStmt expr placeHolderType)
 190 nlBindStmt pat expr     = noLoc (BindStmt pat expr)
 191 nlLetStmt binds         = noLoc (LetStmt binds)
 192 nlResultStmt expr       = noLoc (ResultStmt expr)
 193 nlParStmt stuff         = noLoc (ParStmt stuff)
 194 \end{code}
 195
 196
 197
 198 %************************************************************************
 199 %*                                                                      *
 200                 Bindings; with a location at the top
 201 %*                                                                      *
 202 %************************************************************************
 203
 204 \begin{code}
 205 mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
 206 mkVarBind loc var rhs = mk_easy_FunBind loc var [] emptyBag rhs
 207
 208 mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
 209                     -> LHsBinds RdrName -> LHsExpr RdrName
 210                     -> LHsBind RdrName
 211
 212 mk_easy_FunBind loc fun pats binds expr
 213   = L loc (FunBind (L loc fun) False{-not infix-}
 214         [mk_easy_Match pats binds expr])
 215
 216 mk_easy_Match pats binds expr
 217   = mkMatch pats expr [HsBindGroup binds [] Recursive]
 218         -- The renamer expects everything in its input to be a
 219         -- "recursive" MonoBinds, and it is its job to sort things out
 220         -- from there.
 221
 222 mk_FunBind      :: SrcSpan
 223                 -> RdrName
 224                 -> [([LPat RdrName], LHsExpr RdrName)]
 225                 -> LHsBind RdrName
 226
 227 mk_FunBind loc fun [] = panic "TcGenDeriv:mk_FunBind"
 228 mk_FunBind loc fun pats_and_exprs
 229   = L loc (FunBind (L loc fun) False{-not infix-}
 230                         [mkMatch p e [] | (p,e) <-pats_and_exprs])
 231
 232 mkMatch :: [LPat id] -> LHsExpr id -> [HsBindGroup id] -> LMatch id
 233 mkMatch pats expr binds
 234   = noLoc (Match (map paren pats) Nothing
 235                  (GRHSs (unguardedRHS expr) binds placeHolderType))
 236   where
 237     paren p = case p of
 238                 L _ (VarPat _) -> p
 239                 L l _          -> L l (ParPat p)
 240 \end{code}
 241