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 -- gaw 2004
  56 mkSimpleMatch :: [LPat id] -> LHsExpr id -> LMatch id
  57 mkSimpleMatch pats rhs
  58   = L loc $
  59     Match pats Nothing (GRHSs (unguardedRHS rhs) [])
  60   where
  61     loc = case pats of
  62                 []      -> getLoc rhs
  63                 (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs)
  64
  65 unguardedRHS :: LHsExpr id -> [LGRHS id]
  66 unguardedRHS rhs@(L loc _) = [L loc (GRHS [L loc (ResultStmt rhs)])]
  67
  68 mkHsAppTy :: LHsType name -> LHsType name -> LHsType name
  69 mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)
  70
  71 mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
  72 mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)
  73
  74 mkHsTyApp :: LHsExpr name -> [Type] -> LHsExpr name
  75 mkHsTyApp expr []  = expr
  76 mkHsTyApp expr tys = L (getLoc expr) (TyApp expr tys)
  77
  78 mkHsDictApp :: LHsExpr name -> [name] -> LHsExpr name
  79 mkHsDictApp expr []      = expr
  80 mkHsDictApp expr dict_vars = L (getLoc expr) (DictApp expr dict_vars)
  81
  82 mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
  83 mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
  84         where
  85           matches = mkMatchGroup [mkSimpleMatch pats body]
  86
  87 mkMatchGroup :: [LMatch id] -> MatchGroup id
  88 mkMatchGroup matches = MatchGroup matches placeHolderType
  89
  90 mkHsTyLam []     expr = expr
  91 mkHsTyLam tyvars expr = L (getLoc expr) (TyLam tyvars expr)
  92
  93 mkHsDictLam []    expr = expr
  94 mkHsDictLam dicts expr = L (getLoc expr) (DictLam dicts expr)
  95
  96 mkHsLet :: LHsBinds name -> LHsExpr name -> LHsExpr name
  97 mkHsLet binds expr
  98   | isEmptyLHsBinds binds = expr
  99   | otherwise             = L (getLoc expr) (HsLet [HsBindGroup binds [] Recursive] expr)
 100
 101 mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
 102 -- Used for constructing dictinoary terms etc, so no locations
 103 mkHsConApp data_con tys args
 104   = foldl mk_app (noLoc (HsVar (dataConWrapId data_con)) `mkHsTyApp` tys) args
 105   where
 106     mk_app f a = noLoc (HsApp f (noLoc a))
 107
 108 mkSimpleHsAlt :: LPat id -> LHsExpr id -> LMatch id
 109 -- A simple lambda with a single pattern, no binds, no guards; pre-typechecking
 110 mkSimpleHsAlt pat expr
 111   = mkSimpleMatch [pat] expr
 112
 113 glueBindsOnGRHSs :: HsBindGroup id -> GRHSs id -> GRHSs id
 114 -- gaw 2004
 115 glueBindsOnGRHSs binds1 (GRHSs grhss binds2)
 116   = GRHSs grhss (binds1 : binds2)
 117
 118 -- These are the bits of syntax that contain rebindable names
 119 -- See RnEnv.lookupSyntaxName
 120
 121 mkHsIntegral   i      = HsIntegral   i  placeHolderName
 122 mkHsFractional f      = HsFractional f  placeHolderName
 123 mkNPlusKPat n k       = NPlusKPatIn n k placeHolderName
 124 mkHsDo ctxt stmts     = HsDo ctxt stmts [] placeHolderType
 125
 126 --- A useful function for building @OpApps@.  The operator is always a
 127 -- variable, and we don't know the fixity yet.
 128 mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2
 129
 130 mkHsSplice e = HsSplice unqualSplice e
 131
 132 unqualSplice = mkRdrUnqual (mkVarOcc FSLIT("splice"))
 133                 -- A name (uniquified later) to
 134                 -- identify the splice
 135
 136 mkHsString s = HsString (mkFastString s)
 137 \end{code}
 138
 139
 140 %************************************************************************
 141 %*                                                                      *
 142         Constructing syntax with no location info
 143 %*                                                                      *
 144 %************************************************************************
 145
 146 \begin{code}
 147 nlHsVar :: id -> LHsExpr id
 148 nlHsVar n = noLoc (HsVar n)
 149
 150 nlHsLit :: HsLit -> LHsExpr id
 151 nlHsLit n = noLoc (HsLit n)
 152
 153 nlVarPat :: id -> LPat id
 154 nlVarPat n = noLoc (VarPat n)
 155
 156 nlLitPat :: HsLit -> LPat id
 157 nlLitPat l = noLoc (LitPat l)
 158
 159 nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
 160 nlHsApp f x = noLoc (HsApp f x)
 161
 162 nlHsIntLit n = noLoc (HsLit (HsInt n))
 163
 164 nlHsApps :: id -> [LHsExpr id] -> LHsExpr id
 165 nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
 166
 167 nlHsVarApps :: id -> [id] -> LHsExpr id
 168 nlHsVarApps f xs = noLoc (foldl mk (HsVar f) (map HsVar xs))
 169                  where
 170                    mk f a = HsApp (noLoc f) (noLoc a)
 171
 172 nlConVarPat :: id -> [id] -> LPat id
 173 nlConVarPat con vars = nlConPat con (map nlVarPat vars)
 174
 175 nlInfixConPat :: id -> LPat id -> LPat id -> LPat id
 176 nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))
 177
 178 nlConPat :: id -> [LPat id] -> LPat id
 179 nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
 180
 181 nlNullaryConPat :: id -> LPat id
 182 nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
 183
 184 nlWildConPat :: DataCon -> LPat RdrName
 185 nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
 186                                    (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat)))
 187
 188 nlTuplePat pats box = noLoc (TuplePat pats box)
 189 nlWildPat  = noLoc (WildPat placeHolderType)    -- Pre-typechecking
 190
 191 nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id
 192 nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)
 193
 194 nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
 195
 196 nlHsLam match           = noLoc (HsLam (mkMatchGroup [match]))
 197 nlHsPar e               = noLoc (HsPar e)
 198 nlHsIf cond true false  = noLoc (HsIf cond true false)
 199 nlHsCase expr matches   = noLoc (HsCase expr (mkMatchGroup matches))
 200 nlTuple exprs box       = noLoc (ExplicitTuple exprs box)
 201 nlList exprs            = noLoc (ExplicitList placeHolderType exprs)
 202
 203 nlHsAppTy f t           = noLoc (HsAppTy f t)
 204 nlHsTyVar x             = noLoc (HsTyVar x)
 205 nlHsFunTy a b           = noLoc (HsFunTy a b)
 206
 207 nlExprStmt expr         = noLoc (ExprStmt expr placeHolderType)
 208 nlBindStmt pat expr     = noLoc (BindStmt pat expr)
 209 nlLetStmt binds         = noLoc (LetStmt binds)
 210 nlResultStmt expr       = noLoc (ResultStmt expr)
 211 nlParStmt stuff         = noLoc (ParStmt stuff)
 212 \end{code}
 213
 214
 215
 216 %************************************************************************
 217 %*                                                                      *
 218                 Bindings; with a location at the top
 219 %*                                                                      *
 220 %************************************************************************
 221
 222 \begin{code}
 223 mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
 224 mkVarBind loc var rhs = mk_easy_FunBind loc var [] emptyLHsBinds rhs
 225
 226 mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
 227                     -> LHsBinds RdrName -> LHsExpr RdrName
 228                     -> LHsBind RdrName
 229
 230 mk_easy_FunBind loc fun pats binds expr
 231   = L loc (FunBind (L loc fun) False{-not infix-}
 232                    (mkMatchGroup [mk_easy_Match pats binds expr]))
 233
 234 mk_easy_Match pats binds expr
 235   = mkMatch pats expr [HsBindGroup binds [] Recursive]
 236         -- The renamer expects everything in its input to be a
 237         -- "recursive" MonoBinds, and it is its job to sort things out
 238         -- from there.
 239
 240 mk_FunBind      :: SrcSpan
 241                 -> RdrName
 242                 -> [([LPat RdrName], LHsExpr RdrName)]
 243                 -> LHsBind RdrName
 244
 245 mk_FunBind loc fun [] = panic "TcGenDeriv:mk_FunBind"
 246 mk_FunBind loc fun pats_and_exprs
 247   = L loc (FunBind (L loc fun) False{-not infix-}
 248                    (mkMatchGroup [mkMatch p e [] | (p,e) <-pats_and_exprs]))
 249
 250 mkMatch :: [LPat id] -> LHsExpr id -> [HsBindGroup id] -> LMatch id
 251 mkMatch pats expr binds
 252   = noLoc (Match (map paren pats) Nothing
 253 -- gaw 2004
 254                  (GRHSs (unguardedRHS expr) binds))
 255   where
 256     paren p = case p of
 257                 L _ (VarPat _) -> p
 258                 L l _          -> L l (ParPat p)
 259 \end{code}
 260
 261
 262 %************************************************************************
 263 %*                                                                      *
 264         Collecting binders from HsBindGroups and HsBinds
 265 %*                                                                      *
 266 %************************************************************************
 267
 268 Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg.
 269
 270 ...
 271 where
 272   (x, y) = ...
 273   f i j  = ...
 274   [a, b] = ...
 275
 276 it should return [x, y, f, a, b] (remember, order important).
 277
 278 \begin{code}
 279 collectGroupBinders :: [HsBindGroup name] -> [Located name]
 280 collectGroupBinders groups = foldr collect_group [] groups
 281         where
 282           collect_group (HsBindGroup bag sigs is_rec) acc
 283                 = foldrBag (collectAcc . unLoc) acc bag
 284           collect_group (HsIPBinds _) acc = acc
 285
 286
 287 collectAcc :: HsBind name -> [Located name] -> [Located name]
 288 collectAcc (PatBind pat _ _) acc = collectLocatedPatBinders pat ++ acc
 289 collectAcc (FunBind f _ _) acc   = f : acc
 290 collectAcc (VarBind f _) acc  = noLoc f : acc
 291 collectAcc (AbsBinds _ _ dbinds _ binds) acc
 292   = [noLoc dp | (_,dp,_) <- dbinds] ++ acc
 293         -- ++ foldr collectAcc acc binds
 294         -- I don't think we want the binders from the nested binds
 295         -- The only time we collect binders from a typechecked
 296         -- binding (hence see AbsBinds) is in zonking in TcHsSyn
 297
 298 collectHsBindBinders :: Bag (LHsBind name) -> [name]
 299 collectHsBindBinders binds = map unLoc (collectHsBindLocatedBinders binds)
 300
 301 collectHsBindLocatedBinders :: Bag (LHsBind name) -> [Located name]
 302 collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds
 303 \end{code}
 304
 305
 306 %************************************************************************
 307 %*                                                                      *
 308         Getting pattern signatures out of bindings
 309 %*                                                                      *
 310 %************************************************************************
 311
 312 Get all the pattern type signatures out of a bunch of bindings
 313
 314 \begin{code}
 315 collectSigTysFromHsBinds :: [LHsBind name] -> [LHsType name]
 316 collectSigTysFromHsBinds binds = concat (map collectSigTysFromHsBind binds)
 317
 318 collectSigTysFromHsBind :: LHsBind name -> [LHsType name]
 319 collectSigTysFromHsBind bind
 320   = go (unLoc bind)
 321   where
 322     go (PatBind pat _ _)
 323         = collectSigTysFromPat pat
 324     go (FunBind f _ (MatchGroup ms _))
 325         = [sig | L _ (Match [] (Just sig) _) <- ms]
 326         -- A binding like    x :: a = f y
 327         -- is parsed as FunMonoBind, but for this purpose we
 328         -- want to treat it as a pattern binding
 329 \end{code}
 330
 331 %************************************************************************
 332 %*                                                                      *
 333         Getting binders from statements
 334 %*                                                                      *
 335 %************************************************************************
 336
 337 \begin{code}
 338 collectStmtsBinders :: [LStmt id] -> [Located id]
 339 collectStmtsBinders = concatMap collectLStmtBinders
 340
 341 collectLStmtBinders = collectStmtBinders . unLoc
 342
 343 collectStmtBinders :: Stmt id -> [Located id]
 344   -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
 345 collectStmtBinders (BindStmt pat _)   = collectLocatedPatBinders pat
 346 collectStmtBinders (LetStmt binds)    = collectGroupBinders binds
 347 collectStmtBinders (ExprStmt _ _)     = []
 348 collectStmtBinders (ResultStmt _)     = []
 349 collectStmtBinders (RecStmt ss _ _ _) = collectStmtsBinders ss
 350 collectStmtBinders other              = panic "collectStmtBinders"
 351 \end{code}
 352
 353
 354 %************************************************************************
 355 %*                                                                      *
 356 %*      Gathering stuff out of patterns
 357 %*                                                                      *
 358 %************************************************************************
 359
 360 This function @collectPatBinders@ works with the ``collectBinders''
 361 functions for @HsBinds@, etc.  The order in which the binders are
 362 collected is important; see @HsBinds.lhs@.
 363
 364 It collects the bounds *value* variables in renamed patterns; type variables
 365 are *not* collected.
 366
 367 \begin{code}
 368 collectPatBinders :: LPat a -> [a]
 369 collectPatBinders pat = map unLoc (collectLocatedPatBinders pat)
 370
 371 collectLocatedPatBinders :: LPat a -> [Located a]
 372 collectLocatedPatBinders pat = collectl pat []
 373
 374 collectPatsBinders :: [LPat a] -> [a]
 375 collectPatsBinders pats = map unLoc (collectLocatedPatsBinders pats)
 376
 377 collectLocatedPatsBinders :: [LPat a] -> [Located a]
 378 collectLocatedPatsBinders pats = foldr collectl [] pats
 379
 380 ---------------------
 381 collectl (L l (VarPat var)) bndrs = L l var : bndrs
 382 collectl (L l (VarPatOut var bs)) bndrs = L l var : collectHsBindLocatedBinders bs
 383                                           ++ bndrs
 384 collectl (L l pat) bndrs = collect pat bndrs
 385
 386 ---------------------
 387 collect (WildPat _)                bndrs = bndrs
 388 collect (LazyPat pat)              bndrs = collectl pat bndrs
 389 collect (AsPat a pat)              bndrs = a : collectl pat bndrs
 390 collect (ParPat  pat)              bndrs = collectl pat bndrs
 391
 392 collect (ListPat pats _)           bndrs = foldr collectl bndrs pats
 393 collect (PArrPat pats _)           bndrs = foldr collectl bndrs pats
 394 collect (TuplePat pats _)          bndrs = foldr collectl bndrs pats
 395
 396 collect (ConPatIn c ps)            bndrs = foldr collectl bndrs (hsConArgs ps)
 397 collect (ConPatOut c _ ds bs ps _) bndrs = map noLoc ds
 398                                            ++ collectHsBindLocatedBinders bs
 399                                            ++ foldr collectl bndrs (hsConArgs ps)
 400 collect (LitPat _)               bndrs = bndrs
 401 collect (NPatIn _ _)             bndrs = bndrs
 402 collect (NPatOut _ _ _)          bndrs = bndrs
 403
 404 collect (NPlusKPatIn n _ _)      bndrs = n : bndrs
 405 collect (NPlusKPatOut n _ _ _)   bndrs = n : bndrs
 406
 407 collect (SigPatIn pat _)         bndrs = collectl pat bndrs
 408 collect (SigPatOut pat _)        bndrs = collectl pat bndrs
 409 collect (TypePat ty)             bndrs = bndrs
 410 collect (DictPat ids1 ids2)      bndrs = map noLoc ids1 ++ map noLoc ids2
 411                                            ++ bndrs
 412 \end{code}
 413
 414 \begin{code}
 415 collectSigTysFromPats :: [InPat name] -> [LHsType name]
 416 collectSigTysFromPats pats = foldr collect_lpat [] pats
 417
 418 collectSigTysFromPat :: InPat name -> [LHsType name]
 419 collectSigTysFromPat pat = collect_lpat pat []
 420
 421 collect_lpat pat acc = collect_pat (unLoc pat) acc
 422
 423 collect_pat (SigPatIn pat ty)  acc = collect_lpat pat (ty:acc)
 424 collect_pat (TypePat ty)       acc = ty:acc
 425
 426 collect_pat (LazyPat pat)      acc = collect_lpat pat acc
 427 collect_pat (AsPat a pat)      acc = collect_lpat pat acc
 428 collect_pat (ParPat  pat)      acc = collect_lpat pat acc
 429 collect_pat (ListPat pats _)   acc = foldr collect_lpat acc pats
 430 collect_pat (PArrPat pats _)   acc = foldr collect_lpat acc pats
 431 collect_pat (TuplePat pats _)  acc = foldr collect_lpat acc pats
 432 collect_pat (ConPatIn c ps)    acc = foldr collect_lpat acc (hsConArgs ps)
 433 collect_pat other              acc = acc        -- Literals, vars, wildcard
 434 \end{code}