ghc/compiler/hsSyn/HsUtils.lhs

   1 %
   2 % (c) The University of Glasgow, 1992-2003
   3 %
   4
   5 Here we collect a variety of helper functions that construct or
   6 analyse HsSyn.  All these functions deal with generic HsSyn; functions
   7 which deal with the intantiated versions are located elsewhere:
   8
   9    Parameterised by     Module
  10    ----------------     -------------
  11    RdrName              parser/RdrHsSyn
  12    Name                 rename/RnHsSyn
  13    Id                   typecheck/TcHsSyn
  14
  15 \begin{code}
  16 module HsUtils where
  17
  18 #include "HsVersions.h"
  19
  20 import HsBinds
  21 import HsExpr
  22 import HsPat
  23 import HsTypes
  24 import HsLit
  25
  26 import RdrName          ( RdrName, getRdrName, mkRdrUnqual )
  27 import Var              ( Id )
  28 import Type             ( Type )
  29 import DataCon          ( DataCon, dataConWrapId, dataConSourceArity )
  30 import BasicTypes       ( RecFlag(..) )
  31 import OccName          ( mkVarOcc )
  32 import Name             ( Name )
  33 import SrcLoc
  34 import FastString       ( mkFastString )
  35 import Outputable
  36 import Util             ( nOfThem )
  37 import Bag
  38 \end{code}
  39
  40
  41 %************************************************************************
  42 %*                                                                      *
  43         Some useful helpers for constructing syntax
  44 %*                                                                      *
  45 %************************************************************************
  46
  47 These functions attempt to construct a not-completely-useless SrcSpan
  48 from their components, compared with the nl* functions below which
  49 just attach noSrcSpan to everything.
  50
  51 \begin{code}
  52 mkHsPar :: LHsExpr id -> LHsExpr id
  53 mkHsPar e = L (getLoc e) (HsPar e)
  54
  55 mkSimpleMatch :: [LPat id] -> LHsExpr id -> Type -> LMatch id
  56 mkSimpleMatch pats rhs rhs_ty
  57   = L loc $
  58     Match pats Nothing (GRHSs (unguardedRHS rhs) [] rhs_ty)
  59   where
  60     loc = case pats of
  61                 []      -> getLoc rhs
  62                 (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs)
  63
  64 unguardedRHS :: LHsExpr id -> [LGRHS id]
  65 unguardedRHS rhs@(L loc _) = [L loc (GRHS [L loc (ResultStmt rhs)])]
  66
  67 mkHsAppTy :: LHsType name -> LHsType name -> LHsType name
  68 mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)
  69
  70 mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
  71 mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)
  72
  73 mkHsTyApp :: LHsExpr name -> [Type] -> LHsExpr name
  74 mkHsTyApp expr []  = expr
  75 mkHsTyApp expr tys = L (getLoc expr) (TyApp expr tys)
  76
  77 mkHsDictApp expr []      = expr
  78 mkHsDictApp expr dict_vars = L (getLoc expr) (DictApp expr dict_vars)
  79
  80 mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
  81 mkHsLam pats body = mkHsPar (L (getLoc match) (HsLam match))
  82         where
  83           match = mkSimpleMatch pats body placeHolderType
  84
  85 mkHsTyLam []     expr = expr
  86 mkHsTyLam tyvars expr = L (getLoc expr) (TyLam tyvars expr)
  87
  88 mkHsDictLam []    expr = expr
  89 mkHsDictLam dicts expr = L (getLoc expr) (DictLam dicts expr)
  90
  91 mkHsLet :: Bag (LHsBind name) -> LHsExpr name -> LHsExpr name
  92 mkHsLet binds expr
  93   | isEmptyBag binds = expr
  94   | otherwise        = L (getLoc expr) (HsLet [HsBindGroup binds [] Recursive] expr)
  95
  96 mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
  97 -- Used for constructing dictinoary terms etc, so no locations
  98 mkHsConApp data_con tys args
  99   = foldl mk_app (noLoc (HsVar (dataConWrapId data_con)) `mkHsTyApp` tys) args
 100   where
 101     mk_app f a = noLoc (HsApp f (noLoc a))
 102
 103 mkSimpleHsAlt :: LPat id -> LHsExpr id -> LMatch id
 104 -- A simple lambda with a single pattern, no binds, no guards; pre-typechecking
 105 mkSimpleHsAlt pat expr
 106   = mkSimpleMatch [pat] expr placeHolderType
 107
 108 glueBindsOnGRHSs :: HsBindGroup id -> GRHSs id -> GRHSs id
 109 glueBindsOnGRHSs binds1 (GRHSs grhss binds2 ty)
 110   = GRHSs grhss (binds1 : binds2) ty
 111
 112 -- These are the bits of syntax that contain rebindable names
 113 -- See RnEnv.lookupSyntaxName
 114
 115 mkHsIntegral   i      = HsIntegral   i  placeHolderName
 116 mkHsFractional f      = HsFractional f  placeHolderName
 117 mkNPlusKPat n k       = NPlusKPatIn n k placeHolderName
 118 mkHsDo ctxt stmts     = HsDo ctxt stmts [] placeHolderType
 119
 120 --- A useful function for building @OpApps@.  The operator is always a
 121 -- variable, and we don't know the fixity yet.
 122 mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2
 123
 124 mkHsSplice e = HsSplice unqualSplice e
 125
 126 unqualSplice = mkRdrUnqual (mkVarOcc FSLIT("splice"))
 127                 -- A name (uniquified later) to
 128                 -- identify the splice
 129
 130 mkHsString s = HsString (mkFastString s)
 131 \end{code}
 132
 133
 134 %************************************************************************
 135 %*                                                                      *
 136         Constructing syntax with no location info
 137 %*                                                                      *
 138 %************************************************************************
 139
 140 \begin{code}
 141 nlHsVar :: id -> LHsExpr id
 142 nlHsVar n = noLoc (HsVar n)
 143
 144 nlHsLit :: HsLit -> LHsExpr id
 145 nlHsLit n = noLoc (HsLit n)
 146
 147 nlVarPat :: id -> LPat id
 148 nlVarPat n = noLoc (VarPat n)
 149
 150 nlLitPat :: HsLit -> LPat id
 151 nlLitPat l = noLoc (LitPat l)
 152
 153 nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
 154 nlHsApp f x = noLoc (HsApp f x)
 155
 156 nlHsIntLit n = noLoc (HsLit (HsInt n))
 157
 158 nlHsApps :: id -> [LHsExpr id] -> LHsExpr id
 159 nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
 160
 161 nlHsVarApps :: id -> [id] -> LHsExpr id
 162 nlHsVarApps f xs = noLoc (foldl mk (HsVar f) (map HsVar xs))
 163                  where
 164                    mk f a = HsApp (noLoc f) (noLoc a)
 165
 166 nlConVarPat :: id -> [id] -> LPat id
 167 nlConVarPat con vars = nlConPat con (map nlVarPat vars)
 168
 169 nlInfixConPat :: id -> LPat id -> LPat id -> LPat id
 170 nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))
 171
 172 nlConPat :: id -> [LPat id] -> LPat id
 173 nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
 174
 175 nlNullaryConPat :: id -> LPat id
 176 nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
 177
 178 nlWildConPat :: DataCon -> LPat RdrName
 179 nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
 180                                    (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat)))
 181
 182 nlTuplePat pats box = noLoc (TuplePat pats box)
 183 nlWildPat  = noLoc (WildPat placeHolderType)    -- Pre-typechecking
 184
 185 nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id
 186 nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)
 187
 188 nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
 189
 190 nlHsLam match           = noLoc (HsLam match)
 191 nlHsPar e               = noLoc (HsPar e)
 192 nlHsIf cond true false  = noLoc (HsIf cond true false)
 193 nlHsCase expr matches   = noLoc (HsCase expr matches)
 194 nlTuple exprs box       = noLoc (ExplicitTuple exprs box)
 195 nlList exprs            = noLoc (ExplicitList placeHolderType exprs)
 196
 197 nlHsAppTy f t           = noLoc (HsAppTy f t)
 198 nlHsTyVar x             = noLoc (HsTyVar x)
 199 nlHsFunTy a b           = noLoc (HsFunTy a b)
 200
 201 nlExprStmt expr         = noLoc (ExprStmt expr placeHolderType)
 202 nlBindStmt pat expr     = noLoc (BindStmt pat expr)
 203 nlLetStmt binds         = noLoc (LetStmt binds)
 204 nlResultStmt expr       = noLoc (ResultStmt expr)
 205 nlParStmt stuff         = noLoc (ParStmt stuff)
 206 \end{code}
 207
 208
 209
 210 %************************************************************************
 211 %*                                                                      *
 212                 Bindings; with a location at the top
 213 %*                                                                      *
 214 %************************************************************************
 215
 216 \begin{code}
 217 mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
 218 mkVarBind loc var rhs = mk_easy_FunBind loc var [] emptyBag rhs
 219
 220 mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
 221                     -> LHsBinds RdrName -> LHsExpr RdrName
 222                     -> LHsBind RdrName
 223
 224 mk_easy_FunBind loc fun pats binds expr
 225   = L loc (FunBind (L loc fun) False{-not infix-}
 226         [mk_easy_Match pats binds expr])
 227
 228 mk_easy_Match pats binds expr
 229   = mkMatch pats expr [HsBindGroup binds [] Recursive]
 230         -- The renamer expects everything in its input to be a
 231         -- "recursive" MonoBinds, and it is its job to sort things out
 232         -- from there.
 233
 234 mk_FunBind      :: SrcSpan
 235                 -> RdrName
 236                 -> [([LPat RdrName], LHsExpr RdrName)]
 237                 -> LHsBind RdrName
 238
 239 mk_FunBind loc fun [] = panic "TcGenDeriv:mk_FunBind"
 240 mk_FunBind loc fun pats_and_exprs
 241   = L loc (FunBind (L loc fun) False{-not infix-}
 242                         [mkMatch p e [] | (p,e) <-pats_and_exprs])
 243
 244 mkMatch :: [LPat id] -> LHsExpr id -> [HsBindGroup id] -> LMatch id
 245 mkMatch pats expr binds
 246   = noLoc (Match (map paren pats) Nothing
 247                  (GRHSs (unguardedRHS expr) binds placeHolderType))
 248   where
 249     paren p = case p of
 250                 L _ (VarPat _) -> p
 251                 L l _          -> L l (ParPat p)
 252 \end{code}
 253
 254
 255 %************************************************************************
 256 %*                                                                      *
 257         Collecting binders from HsBindGroups and HsBinds
 258 %*                                                                      *
 259 %************************************************************************
 260
 261 Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg.
 262
 263 ...
 264 where
 265   (x, y) = ...
 266   f i j  = ...
 267   [a, b] = ...
 268
 269 it should return [x, y, f, a, b] (remember, order important).
 270
 271 \begin{code}
 272 collectGroupBinders :: [HsBindGroup name] -> [Located name]
 273 collectGroupBinders groups = foldr collect_group [] groups
 274         where
 275           collect_group (HsBindGroup bag sigs is_rec) acc
 276                 = foldrBag (collectAcc . unLoc) acc bag
 277           collect_group (HsIPBinds _) acc = acc
 278
 279
 280 collectAcc :: HsBind name -> [Located name] -> [Located name]
 281 collectAcc (PatBind pat _) acc = collectLocatedPatBinders pat ++ acc
 282 collectAcc (FunBind f _ _) acc = f : acc
 283 collectAcc (VarBind f _) acc  = noLoc f : acc
 284 collectAcc (AbsBinds _ _ dbinds _ binds) acc
 285   = [noLoc dp | (_,dp,_) <- dbinds] ++ acc
 286         -- ++ foldr collectAcc acc binds
 287         -- I don't think we want the binders from the nested binds
 288         -- The only time we collect binders from a typechecked
 289         -- binding (hence see AbsBinds) is in zonking in TcHsSyn
 290
 291 collectHsBindBinders :: Bag (LHsBind name) -> [name]
 292 collectHsBindBinders binds = map unLoc (collectHsBindLocatedBinders binds)
 293
 294 collectHsBindLocatedBinders :: Bag (LHsBind name) -> [Located name]
 295 collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds
 296 \end{code}
 297
 298
 299 %************************************************************************
 300 %*                                                                      *
 301         Getting pattern signatures out of bindings
 302 %*                                                                      *
 303 %************************************************************************
 304
 305 Get all the pattern type signatures out of a bunch of bindings
 306
 307 \begin{code}
 308 collectSigTysFromHsBinds :: [LHsBind name] -> [LHsType name]
 309 collectSigTysFromHsBinds binds = concat (map collectSigTysFromHsBind binds)
 310
 311 collectSigTysFromHsBind :: LHsBind name -> [LHsType name]
 312 collectSigTysFromHsBind bind
 313   = go (unLoc bind)
 314   where
 315     go (PatBind pat _)  = collectSigTysFromPat pat
 316     go (FunBind f _ ms) = go_matches (map unLoc ms)
 317
 318         -- A binding like    x :: a = f y
 319         -- is parsed as FunMonoBind, but for this purpose we
 320         -- want to treat it as a pattern binding
 321     go_matches []                                = []
 322     go_matches (Match [] (Just sig) _ : matches) = sig : go_matches matches
 323     go_matches (match                 : matches) = go_matches matches
 324 \end{code}
 325
 326 %************************************************************************
 327 %*                                                                      *
 328         Getting binders from statements
 329 %*                                                                      *
 330 %************************************************************************
 331
 332 \begin{code}
 333 collectStmtsBinders :: [LStmt id] -> [Located id]
 334 collectStmtsBinders = concatMap collectLStmtBinders
 335
 336 collectLStmtBinders = collectStmtBinders . unLoc
 337
 338 collectStmtBinders :: Stmt id -> [Located id]
 339   -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
 340 collectStmtBinders (BindStmt pat _)   = collectLocatedPatBinders pat
 341 collectStmtBinders (LetStmt binds)    = collectGroupBinders binds
 342 collectStmtBinders (ExprStmt _ _)     = []
 343 collectStmtBinders (ResultStmt _)     = []
 344 collectStmtBinders (RecStmt ss _ _ _) = collectStmtsBinders ss
 345 collectStmtBinders other              = panic "collectStmtBinders"
 346 \end{code}