compiler/hsSyn/HsUtils.lhs

   1 %
   2 % (c) The University of Glasgow, 1992-2006
   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 {-# OPTIONS -w #-}
  17 -- The above warning supression flag is a temporary kludge.
  18 -- While working on this module you are encouraged to remove it and fix
  19 -- any warnings in the module. See
  20 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  21 -- for details
  22
  23 module HsUtils where
  24
  25 #include "HsVersions.h"
  26
  27 import HsBinds
  28 import HsExpr
  29 import HsPat
  30 import HsTypes
  31 import HsLit
  32
  33 import RdrName
  34 import Var
  35 import Coercion
  36 import Type
  37 import DataCon
  38 import Name
  39 import BasicTypes
  40 import SrcLoc
  41 import FastString
  42 import Outputable
  43 import Util
  44 import Bag
  45 \end{code}
  46
  47
  48 %************************************************************************
  49 %*                                                                      *
  50         Some useful helpers for constructing syntax
  51 %*                                                                      *
  52 %************************************************************************
  53
  54 These functions attempt to construct a not-completely-useless SrcSpan
  55 from their components, compared with the nl* functions below which
  56 just attach noSrcSpan to everything.
  57
  58 \begin{code}
  59 mkHsPar :: LHsExpr id -> LHsExpr id
  60 mkHsPar e = L (getLoc e) (HsPar e)
  61
  62 mkSimpleMatch :: [LPat id] -> LHsExpr id -> LMatch id
  63 mkSimpleMatch pats rhs
  64   = L loc $
  65     Match pats Nothing (unguardedGRHSs rhs)
  66   where
  67     loc = case pats of
  68                 []      -> getLoc rhs
  69                 (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs)
  70
  71 unguardedGRHSs :: LHsExpr id -> GRHSs id
  72 unguardedGRHSs rhs = GRHSs (unguardedRHS rhs) emptyLocalBinds
  73
  74 unguardedRHS :: LHsExpr id -> [LGRHS id]
  75 unguardedRHS rhs@(L loc _) = [L loc (GRHS [] rhs)]
  76
  77 mkHsAppTy :: LHsType name -> LHsType name -> LHsType name
  78 mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)
  79
  80 mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
  81 mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)
  82
  83 nlHsTyApp :: name -> [Type] -> LHsExpr name
  84 nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar fun_id))
  85
  86 mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id
  87 mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)
  88
  89 mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id
  90 mkHsWrap co_fn e | isIdHsWrapper co_fn = e
  91                  | otherwise          = HsWrap co_fn e
  92
  93 mkHsWrapCoI :: CoercionI -> HsExpr id -> HsExpr id
  94 mkHsWrapCoI IdCo     e = e
  95 mkHsWrapCoI (ACo co) e = mkHsWrap (WpCo co) e
  96
  97 mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
  98 mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
  99         where
 100           matches = mkMatchGroup [mkSimpleMatch pats body]
 101
 102 mkMatchGroup :: [LMatch id] -> MatchGroup id
 103 mkMatchGroup matches = MatchGroup matches placeHolderType
 104
 105 mkHsDictLet :: LHsBinds Id -> LHsExpr Id -> LHsExpr Id
 106 -- Used for the dictionary bindings gotten from TcSimplify
 107 -- We make them recursive to be on the safe side
 108 mkHsDictLet binds expr
 109   | isEmptyLHsBinds binds = expr
 110   | otherwise             = L (getLoc expr) (HsLet (HsValBinds val_binds) expr)
 111                           where
 112                             val_binds = ValBindsOut [(Recursive, binds)] []
 113
 114 mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
 115 -- Used for constructing dictionary terms etc, so no locations
 116 mkHsConApp data_con tys args
 117   = foldl mk_app (nlHsTyApp (dataConWrapId data_con) tys) args
 118   where
 119     mk_app f a = noLoc (HsApp f (noLoc a))
 120
 121 mkSimpleHsAlt :: LPat id -> LHsExpr id -> LMatch id
 122 -- A simple lambda with a single pattern, no binds, no guards; pre-typechecking
 123 mkSimpleHsAlt pat expr
 124   = mkSimpleMatch [pat] expr
 125
 126 -------------------------------
 127 -- These are the bits of syntax that contain rebindable names
 128 -- See RnEnv.lookupSyntaxName
 129
 130 mkHsIntegral   i       = HsIntegral   i  noSyntaxExpr
 131 mkHsFractional f       = HsFractional f  noSyntaxExpr
 132 mkHsIsString   s       = HsIsString   s  noSyntaxExpr
 133 mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType
 134
 135 mkNPat lit neg     = NPat lit neg noSyntaxExpr placeHolderType
 136 mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr
 137
 138 mkExprStmt expr     = ExprStmt expr noSyntaxExpr placeHolderType
 139 mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr
 140 mkRecStmt stmts     = RecStmt stmts [] [] [] emptyLHsBinds
 141
 142 -------------------------------
 143 --- A useful function for building @OpApps@.  The operator is always a
 144 -- variable, and we don't know the fixity yet.
 145 mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2
 146
 147 mkHsSplice e = HsSplice unqualSplice e
 148
 149 unqualSplice = mkRdrUnqual (mkVarOccFS FSLIT("splice"))
 150                 -- A name (uniquified later) to
 151                 -- identify the splice
 152
 153 mkHsString s = HsString (mkFastString s)
 154
 155 -------------
 156 userHsTyVarBndrs :: [Located name] -> [Located (HsTyVarBndr name)]
 157 userHsTyVarBndrs bndrs = [ L loc (UserTyVar v) | L loc v <- bndrs ]
 158 \end{code}
 159
 160
 161 %************************************************************************
 162 %*                                                                      *
 163         Constructing syntax with no location info
 164 %*                                                                      *
 165 %************************************************************************
 166
 167 \begin{code}
 168 nlHsVar :: id -> LHsExpr id
 169 nlHsVar n = noLoc (HsVar n)
 170
 171 nlHsLit :: HsLit -> LHsExpr id
 172 nlHsLit n = noLoc (HsLit n)
 173
 174 nlVarPat :: id -> LPat id
 175 nlVarPat n = noLoc (VarPat n)
 176
 177 nlLitPat :: HsLit -> LPat id
 178 nlLitPat l = noLoc (LitPat l)
 179
 180 nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
 181 nlHsApp f x = noLoc (HsApp f x)
 182
 183 nlHsIntLit n = noLoc (HsLit (HsInt n))
 184
 185 nlHsApps :: id -> [LHsExpr id] -> LHsExpr id
 186 nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
 187
 188 nlHsVarApps :: id -> [id] -> LHsExpr id
 189 nlHsVarApps f xs = noLoc (foldl mk (HsVar f) (map HsVar xs))
 190                  where
 191                    mk f a = HsApp (noLoc f) (noLoc a)
 192
 193 nlConVarPat :: id -> [id] -> LPat id
 194 nlConVarPat con vars = nlConPat con (map nlVarPat vars)
 195
 196 nlInfixConPat :: id -> LPat id -> LPat id -> LPat id
 197 nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))
 198
 199 nlConPat :: id -> [LPat id] -> LPat id
 200 nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
 201
 202 nlNullaryConPat :: id -> LPat id
 203 nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
 204
 205 nlWildConPat :: DataCon -> LPat RdrName
 206 nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
 207                                    (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat)))
 208
 209 nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType)
 210 nlWildPat  = noLoc (WildPat placeHolderType)    -- Pre-typechecking
 211
 212 nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> LHsExpr id
 213 nlHsDo ctxt stmts body = noLoc (mkHsDo ctxt stmts body)
 214
 215 nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
 216
 217 nlHsLam match           = noLoc (HsLam (mkMatchGroup [match]))
 218 nlHsPar e               = noLoc (HsPar e)
 219 nlHsIf cond true false  = noLoc (HsIf cond true false)
 220 nlHsCase expr matches   = noLoc (HsCase expr (mkMatchGroup matches))
 221 nlTuple exprs box       = noLoc (ExplicitTuple exprs box)
 222 nlList exprs            = noLoc (ExplicitList placeHolderType exprs)
 223
 224 nlHsAppTy f t           = noLoc (HsAppTy f t)
 225 nlHsTyVar x             = noLoc (HsTyVar x)
 226 nlHsFunTy a b           = noLoc (HsFunTy a b)
 227
 228 nlHsTyConApp tycon tys  = foldl nlHsAppTy (nlHsTyVar tycon) tys
 229 \end{code}
 230
 231
 232
 233 %************************************************************************
 234 %*                                                                      *
 235                 Bindings; with a location at the top
 236 %*                                                                      *
 237 %************************************************************************
 238
 239 \begin{code}
 240 mkFunBind :: Located id -> [LMatch id] -> HsBind id
 241 -- Not infix, with place holders for coercion and free vars
 242 mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False, fun_matches = mkMatchGroup ms,
 243                             fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames,
 244                             fun_tick = Nothing }
 245
 246
 247 mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
 248 mkVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
 249
 250 ------------
 251 mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
 252                 -> LHsExpr RdrName -> LHsBind RdrName
 253
 254 mk_easy_FunBind loc fun pats expr
 255   = L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds]
 256
 257 ------------
 258 mk_FunBind :: SrcSpan -> RdrName
 259            -> [([LPat RdrName], LHsExpr RdrName)]
 260            -> LHsBind RdrName
 261
 262 mk_FunBind loc fun [] = panic "TcGenDeriv:mk_FunBind"
 263 mk_FunBind loc fun pats_and_exprs
 264   = L loc $ mkFunBind (L loc fun) matches
 265   where
 266     matches = [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs]
 267
 268 ------------
 269 mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id
 270 mkMatch pats expr binds
 271   = noLoc (Match (map paren pats) Nothing
 272                  (GRHSs (unguardedRHS expr) binds))
 273   where
 274     paren p = case p of
 275                 L _ (VarPat _) -> p
 276                 L l _          -> L l (ParPat p)
 277 \end{code}
 278
 279
 280 %************************************************************************
 281 %*                                                                      *
 282         Collecting binders from HsBindGroups and HsBinds
 283 %*                                                                      *
 284 %************************************************************************
 285
 286 Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg.
 287
 288 ...
 289 where
 290   (x, y) = ...
 291   f i j  = ...
 292   [a, b] = ...
 293
 294 it should return [x, y, f, a, b] (remember, order important).
 295
 296 \begin{code}
 297 collectLocalBinders :: HsLocalBinds name -> [Located name]
 298 collectLocalBinders (HsValBinds val_binds) = collectHsValBinders val_binds
 299 collectLocalBinders (HsIPBinds _)   = []
 300 collectLocalBinders EmptyLocalBinds = []
 301
 302 collectHsValBinders :: HsValBinds name -> [Located name]
 303 collectHsValBinders (ValBindsIn binds sigs)  = collectHsBindLocatedBinders binds
 304 collectHsValBinders (ValBindsOut binds sigs) = foldr collect_one [] binds
 305   where
 306    collect_one (_,binds) acc = foldrBag (collectAcc . unLoc) acc binds
 307
 308 collectAcc :: HsBind name -> [Located name] -> [Located name]
 309 collectAcc (PatBind { pat_lhs = p }) acc = collectLocatedPatBinders p ++ acc
 310 collectAcc (FunBind { fun_id = f })  acc    = f : acc
 311 collectAcc (VarBind { var_id = f })  acc    = noLoc f : acc
 312 collectAcc (AbsBinds { abs_exports = dbinds, abs_binds = binds }) acc
 313   = [noLoc dp | (_,dp,_,_) <- dbinds] ++ acc
 314         -- ++ foldr collectAcc acc binds
 315         -- I don't think we want the binders from the nested binds
 316         -- The only time we collect binders from a typechecked
 317         -- binding (hence see AbsBinds) is in zonking in TcHsSyn
 318
 319 collectHsBindBinders :: LHsBinds name -> [name]
 320 collectHsBindBinders binds = map unLoc (collectHsBindLocatedBinders binds)
 321
 322 collectHsBindLocatedBinders :: LHsBinds name -> [Located name]
 323 collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds
 324 \end{code}
 325
 326
 327 %************************************************************************
 328 %*                                                                      *
 329         Getting binders from statements
 330 %*                                                                      *
 331 %************************************************************************
 332
 333 \begin{code}
 334 collectLStmtsBinders :: OutputableBndr id => [LStmt id] -> [Located id]
 335 collectLStmtsBinders = concatMap collectLStmtBinders
 336
 337 collectStmtsBinders :: OutputableBndr id => [Stmt id] -> [Located id]
 338 collectStmtsBinders = concatMap collectStmtBinders
 339
 340 collectLStmtBinders :: OutputableBndr id => LStmt id -> [Located id]
 341 collectLStmtBinders = collectStmtBinders . unLoc
 342
 343 collectStmtBinders :: OutputableBndr id => 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)      = collectLocalBinders binds
 347 collectStmtBinders (ExprStmt _ _ _)     = []
 348 collectStmtBinders (ParStmt xs)         = collectLStmtsBinders
 349                                         $ concatMap fst xs
 350 collectStmtBinders (RecStmt ss _ _ _ _) = collectLStmtsBinders ss
 351 collectStmtBinders s                    = pprPanic "collectStmtBinders" (ppr s)
 352 \end{code}
 353
 354
 355 %************************************************************************
 356 %*                                                                      *
 357 %*      Gathering stuff out of patterns
 358 %*                                                                      *
 359 %************************************************************************
 360
 361 This function @collectPatBinders@ works with the ``collectBinders''
 362 functions for @HsBinds@, etc.  The order in which the binders are
 363 collected is important; see @HsBinds.lhs@.
 364
 365 It collects the bounds *value* variables in renamed patterns; type variables
 366 are *not* collected.
 367
 368 \begin{code}
 369 collectPatBinders :: LPat a -> [a]
 370 collectPatBinders pat = map unLoc (collectLocatedPatBinders pat)
 371
 372 collectLocatedPatBinders :: LPat a -> [Located a]
 373 collectLocatedPatBinders pat = collectl pat []
 374
 375 collectPatsBinders :: [LPat a] -> [a]
 376 collectPatsBinders pats = map unLoc (collectLocatedPatsBinders pats)
 377
 378 collectLocatedPatsBinders :: [LPat a] -> [Located a]
 379 collectLocatedPatsBinders pats = foldr collectl [] pats
 380
 381 ---------------------
 382 collectl (L l pat) bndrs
 383   = go pat
 384   where
 385     go (VarPat var)               = L l var : bndrs
 386     go (VarPatOut var bs)         = L l var : collectHsBindLocatedBinders bs
 387                                     ++ bndrs
 388     go (WildPat _)                = bndrs
 389     go (LazyPat pat)              = collectl pat bndrs
 390     go (BangPat pat)              = collectl pat bndrs
 391     go (AsPat a pat)              = a : collectl pat bndrs
 392     go (ParPat  pat)              = collectl pat bndrs
 393
 394     go (ListPat pats _)           = foldr collectl bndrs pats
 395     go (PArrPat pats _)           = foldr collectl bndrs pats
 396     go (TuplePat pats _ _)        = foldr collectl bndrs pats
 397
 398     go (ConPatIn c ps)            = foldr collectl bndrs (hsConPatArgs ps)
 399     go (ConPatOut {pat_args=ps})  = foldr collectl bndrs (hsConPatArgs ps)
 400         -- See Note [Dictionary binders in ConPatOut]
 401     go (LitPat _)                 = bndrs
 402     go (NPat _ _ _ _)             = bndrs
 403     go (NPlusKPat n _ _ _)        = n : bndrs
 404
 405     go (SigPatIn pat _)           = collectl pat bndrs
 406     go (SigPatOut pat _)          = collectl pat bndrs
 407     go (TypePat ty)               = bndrs
 408     go (CoPat _ pat ty)           = collectl (noLoc pat) bndrs
 409 \end{code}
 410
 411 Note [Dictionary binders in ConPatOut]
 412 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 413 Do *not* gather (a) dictionary and (b) dictionary bindings as binders
 414 of a ConPatOut pattern.  For most calls it doesn't matter, because
 415 it's pre-typechecker and there are no ConPatOuts.  But it does matter
 416 more in the desugarer; for example, DsUtils.mkSelectorBinds uses
 417 collectPatBinders.  In a lazy pattern, for example f ~(C x y) = ...,
 418 we want to generate bindings for x,y but not for dictionaries bound by
 419 C.  (The type checker ensures they would not be used.)
 420
 421 Desugaring of arrow case expressions needs these bindings (see DsArrows
 422 and arrowcase1), but SPJ (Jan 2007) says it's safer for it to use its
 423 own pat-binder-collector:
 424
 425 Here's the problem.  Consider
 426
 427 data T a where
 428    C :: Num a => a -> Int -> T a
 429
 430 f ~(C (n+1) m) = (n,m)
 431
 432 Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a),
 433 and *also* uses that dictionary to match the (n+1) pattern.  Yet, the
 434 variables bound by the lazy pattern are n,m, *not* the dictionary d.
 435 So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound.
 436
 437 \begin{code}
 438 collectSigTysFromPats :: [InPat name] -> [LHsType name]
 439 collectSigTysFromPats pats = foldr collect_lpat [] pats
 440
 441 collectSigTysFromPat :: InPat name -> [LHsType name]
 442 collectSigTysFromPat pat = collect_lpat pat []
 443
 444 collect_lpat pat acc = collect_pat (unLoc pat) acc
 445
 446 collect_pat (SigPatIn pat ty)   acc = collect_lpat pat (ty:acc)
 447 collect_pat (TypePat ty)        acc = ty:acc
 448
 449 collect_pat (LazyPat pat)       acc = collect_lpat pat acc
 450 collect_pat (BangPat pat)       acc = collect_lpat pat acc
 451 collect_pat (AsPat a pat)       acc = collect_lpat pat acc
 452 collect_pat (ParPat  pat)       acc = collect_lpat pat acc
 453 collect_pat (ListPat pats _)    acc = foldr collect_lpat acc pats
 454 collect_pat (PArrPat pats _)    acc = foldr collect_lpat acc pats
 455 collect_pat (TuplePat pats _ _) acc = foldr collect_lpat acc pats
 456 collect_pat (ConPatIn c ps)     acc = foldr collect_lpat acc (hsConPatArgs ps)
 457 collect_pat other               acc = acc       -- Literals, vars, wildcard
 458 \end{code}