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 coiToHsWrapper :: CoercionI -> HsWrapper
  98 coiToHsWrapper IdCo     = idHsWrapper
  99 coiToHsWrapper (ACo co) = WpCo co
 100
 101 mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
 102 mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
 103         where
 104           matches = mkMatchGroup [mkSimpleMatch pats body]
 105
 106 mkMatchGroup :: [LMatch id] -> MatchGroup id
 107 mkMatchGroup matches = MatchGroup matches placeHolderType
 108
 109 mkHsDictLet :: LHsBinds Id -> LHsExpr Id -> LHsExpr Id
 110 -- Used for the dictionary bindings gotten from TcSimplify
 111 -- We make them recursive to be on the safe side
 112 mkHsDictLet binds expr
 113   | isEmptyLHsBinds binds = expr
 114   | otherwise             = L (getLoc expr) (HsLet (HsValBinds val_binds) expr)
 115                           where
 116                             val_binds = ValBindsOut [(Recursive, binds)] []
 117
 118 mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
 119 -- Used for constructing dictionary terms etc, so no locations
 120 mkHsConApp data_con tys args
 121   = foldl mk_app (nlHsTyApp (dataConWrapId data_con) tys) args
 122   where
 123     mk_app f a = noLoc (HsApp f (noLoc a))
 124
 125 mkSimpleHsAlt :: LPat id -> LHsExpr id -> LMatch id
 126 -- A simple lambda with a single pattern, no binds, no guards; pre-typechecking
 127 mkSimpleHsAlt pat expr
 128   = mkSimpleMatch [pat] expr
 129
 130 -------------------------------
 131 -- These are the bits of syntax that contain rebindable names
 132 -- See RnEnv.lookupSyntaxName
 133
 134 mkHsIntegral   i       = HsIntegral   i  noSyntaxExpr
 135 mkHsFractional f       = HsFractional f  noSyntaxExpr
 136 mkHsIsString   s       = HsIsString   s  noSyntaxExpr
 137 mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType
 138
 139 mkNPat lit neg     = NPat lit neg noSyntaxExpr
 140 mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr
 141
 142 mkTransformStmt   stmts usingExpr        = TransformStmt (stmts, []) usingExpr Nothing
 143 mkTransformByStmt stmts usingExpr byExpr = TransformStmt (stmts, []) usingExpr (Just byExpr)
 144
 145 mkGroupUsingStmt   stmts usingExpr        = GroupStmt (stmts, []) (GroupByNothing usingExpr)
 146 mkGroupByStmt      stmts byExpr           = GroupStmt (stmts, []) (GroupBySomething (Right noSyntaxExpr) byExpr)
 147 mkGroupByUsingStmt stmts byExpr usingExpr = GroupStmt (stmts, []) (GroupBySomething (Left usingExpr) byExpr)
 148
 149 mkExprStmt expr     = ExprStmt expr noSyntaxExpr placeHolderType
 150 mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr
 151 mkRecStmt stmts     = RecStmt stmts [] [] [] emptyLHsBinds
 152
 153 -------------------------------
 154 --- A useful function for building @OpApps@.  The operator is always a
 155 -- variable, and we don't know the fixity yet.
 156 mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2
 157
 158 mkHsSplice e = HsSplice unqualSplice e
 159
 160 unqualSplice = mkRdrUnqual (mkVarOccFS FSLIT("splice"))
 161                 -- A name (uniquified later) to
 162                 -- identify the splice
 163
 164 mkHsQuasiQuote quoter span quote = HsQuasiQuote unqualQuasiQuote quoter span quote
 165
 166 unqualQuasiQuote = mkRdrUnqual (mkVarOccFS FSLIT("quasiquote"))
 167                 -- A name (uniquified later) to
 168                 -- identify the quasi-quote
 169
 170 mkHsString s = HsString (mkFastString s)
 171
 172 -------------
 173 userHsTyVarBndrs :: [Located name] -> [Located (HsTyVarBndr name)]
 174 userHsTyVarBndrs bndrs = [ L loc (UserTyVar v) | L loc v <- bndrs ]
 175 \end{code}
 176
 177
 178 %************************************************************************
 179 %*                                                                      *
 180         Constructing syntax with no location info
 181 %*                                                                      *
 182 %************************************************************************
 183
 184 \begin{code}
 185 nlHsVar :: id -> LHsExpr id
 186 nlHsVar n = noLoc (HsVar n)
 187
 188 nlHsLit :: HsLit -> LHsExpr id
 189 nlHsLit n = noLoc (HsLit n)
 190
 191 nlVarPat :: id -> LPat id
 192 nlVarPat n = noLoc (VarPat n)
 193
 194 nlLitPat :: HsLit -> LPat id
 195 nlLitPat l = noLoc (LitPat l)
 196
 197 nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
 198 nlHsApp f x = noLoc (HsApp f x)
 199
 200 nlHsIntLit n = noLoc (HsLit (HsInt n))
 201
 202 nlHsApps :: id -> [LHsExpr id] -> LHsExpr id
 203 nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
 204
 205 nlHsVarApps :: id -> [id] -> LHsExpr id
 206 nlHsVarApps f xs = noLoc (foldl mk (HsVar f) (map HsVar xs))
 207                  where
 208                    mk f a = HsApp (noLoc f) (noLoc a)
 209
 210 nlConVarPat :: id -> [id] -> LPat id
 211 nlConVarPat con vars = nlConPat con (map nlVarPat vars)
 212
 213 nlInfixConPat :: id -> LPat id -> LPat id -> LPat id
 214 nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))
 215
 216 nlConPat :: id -> [LPat id] -> LPat id
 217 nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
 218
 219 nlNullaryConPat :: id -> LPat id
 220 nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
 221
 222 nlWildConPat :: DataCon -> LPat RdrName
 223 nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
 224                                    (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat)))
 225
 226 nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType)
 227 nlWildPat  = noLoc (WildPat placeHolderType)    -- Pre-typechecking
 228
 229 nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> LHsExpr id
 230 nlHsDo ctxt stmts body = noLoc (mkHsDo ctxt stmts body)
 231
 232 nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
 233
 234 nlHsLam match           = noLoc (HsLam (mkMatchGroup [match]))
 235 nlHsPar e               = noLoc (HsPar e)
 236 nlHsIf cond true false  = noLoc (HsIf cond true false)
 237 nlHsCase expr matches   = noLoc (HsCase expr (mkMatchGroup matches))
 238 nlTuple exprs box       = noLoc (ExplicitTuple exprs box)
 239 nlList exprs            = noLoc (ExplicitList placeHolderType exprs)
 240
 241 nlHsAppTy f t           = noLoc (HsAppTy f t)
 242 nlHsTyVar x             = noLoc (HsTyVar x)
 243 nlHsFunTy a b           = noLoc (HsFunTy a b)
 244
 245 nlHsTyConApp tycon tys  = foldl nlHsAppTy (nlHsTyVar tycon) tys
 246 \end{code}
 247
 248
 249
 250 %************************************************************************
 251 %*                                                                      *
 252                 Bindings; with a location at the top
 253 %*                                                                      *
 254 %************************************************************************
 255
 256 \begin{code}
 257 mkFunBind :: Located id -> [LMatch id] -> HsBind id
 258 -- Not infix, with place holders for coercion and free vars
 259 mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False, fun_matches = mkMatchGroup ms,
 260                             fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames,
 261                             fun_tick = Nothing }
 262
 263
 264 mkVarBind :: SrcSpan -> id -> LHsExpr id -> LHsBind id
 265 mkVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
 266
 267 ------------
 268 mk_easy_FunBind :: SrcSpan -> id -> [LPat id]
 269                 -> LHsExpr id -> LHsBind id
 270
 271 mk_easy_FunBind loc fun pats expr
 272   = L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds]
 273
 274 ------------
 275 mk_FunBind :: SrcSpan -> id
 276            -> [([LPat id], LHsExpr id)]
 277            -> LHsBind id
 278
 279 mk_FunBind loc fun [] = panic "TcGenDeriv:mk_FunBind"
 280 mk_FunBind loc fun pats_and_exprs
 281   = L loc $ mkFunBind (L loc fun) matches
 282   where
 283     matches = [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs]
 284
 285 ------------
 286 mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id
 287 mkMatch pats expr binds
 288   = noLoc (Match (map paren pats) Nothing
 289                  (GRHSs (unguardedRHS expr) binds))
 290   where
 291     paren p = case p of
 292                 L _ (VarPat _) -> p
 293                 L l _          -> L l (ParPat p)
 294 \end{code}
 295
 296
 297 %************************************************************************
 298 %*                                                                      *
 299         Collecting binders from HsBindGroups and HsBinds
 300 %*                                                                      *
 301 %************************************************************************
 302
 303 Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg.
 304
 305 ...
 306 where
 307   (x, y) = ...
 308   f i j  = ...
 309   [a, b] = ...
 310
 311 it should return [x, y, f, a, b] (remember, order important).
 312
 313 \begin{code}
 314 collectLocalBinders :: HsLocalBindsLR idL idR -> [Located idL]
 315 collectLocalBinders (HsValBinds val_binds) = collectHsValBinders val_binds
 316 collectLocalBinders (HsIPBinds _)   = []
 317 collectLocalBinders EmptyLocalBinds = []
 318
 319 collectHsValBinders :: HsValBindsLR idL idR -> [Located idL]
 320 collectHsValBinders (ValBindsIn binds sigs)  = collectHsBindLocatedBinders binds
 321 collectHsValBinders (ValBindsOut binds sigs) = foldr collect_one [] binds
 322   where
 323    collect_one (_,binds) acc = foldrBag (collectAcc . unLoc) acc binds
 324
 325 collectAcc :: HsBindLR idL idR -> [Located idL] -> [Located idL]
 326 collectAcc (PatBind { pat_lhs = p }) acc = collectLocatedPatBinders p ++ acc
 327 collectAcc (FunBind { fun_id = f })  acc    = f : acc
 328 collectAcc (VarBind { var_id = f })  acc    = noLoc f : acc
 329 collectAcc (AbsBinds { abs_exports = dbinds, abs_binds = binds }) acc
 330   = [noLoc dp | (_,dp,_,_) <- dbinds] ++ acc
 331         -- ++ foldr collectAcc acc binds
 332         -- I don't think we want the binders from the nested binds
 333         -- The only time we collect binders from a typechecked
 334         -- binding (hence see AbsBinds) is in zonking in TcHsSyn
 335
 336 collectHsBindBinders :: LHsBindsLR idL idR -> [idL]
 337 collectHsBindBinders binds = map unLoc (collectHsBindLocatedBinders binds)
 338
 339 collectHsBindLocatedBinders :: LHsBindsLR idL idR -> [Located idL]
 340 collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds
 341 \end{code}
 342
 343
 344 %************************************************************************
 345 %*                                                                      *
 346         Getting binders from statements
 347 %*                                                                      *
 348 %************************************************************************
 349
 350 \begin{code}
 351 collectLStmtsBinders :: [LStmtLR idL idR] -> [Located idL]
 352 collectLStmtsBinders = concatMap collectLStmtBinders
 353
 354 collectStmtsBinders :: [StmtLR idL idR] -> [Located idL]
 355 collectStmtsBinders = concatMap collectStmtBinders
 356
 357 collectLStmtBinders :: LStmtLR idL idR -> [Located idL]
 358 collectLStmtBinders = collectStmtBinders . unLoc
 359
 360 collectStmtBinders :: StmtLR idL idR -> [Located idL]
 361   -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
 362 collectStmtBinders (BindStmt pat _ _ _) = collectLocatedPatBinders pat
 363 collectStmtBinders (LetStmt binds)      = collectLocalBinders binds
 364 collectStmtBinders (ExprStmt _ _ _)     = []
 365 collectStmtBinders (ParStmt xs)         = collectLStmtsBinders
 366                                         $ concatMap fst xs
 367 collectStmtBinders (TransformStmt (stmts, _) _ _) = collectLStmtsBinders stmts
 368 collectStmtBinders (GroupStmt (stmts, _) _)     = collectLStmtsBinders stmts
 369 collectStmtBinders (RecStmt ss _ _ _ _) = collectLStmtsBinders ss
 370 \end{code}
 371
 372
 373 %************************************************************************
 374 %*                                                                      *
 375 %*      Gathering stuff out of patterns
 376 %*                                                                      *
 377 %************************************************************************
 378
 379 This function @collectPatBinders@ works with the ``collectBinders''
 380 functions for @HsBinds@, etc.  The order in which the binders are
 381 collected is important; see @HsBinds.lhs@.
 382
 383 It collects the bounds *value* variables in renamed patterns; type variables
 384 are *not* collected.
 385
 386 \begin{code}
 387 collectPatBinders :: LPat a -> [a]
 388 collectPatBinders pat = map unLoc (collectLocatedPatBinders pat)
 389
 390 collectLocatedPatBinders :: LPat a -> [Located a]
 391 collectLocatedPatBinders pat = collectl pat []
 392
 393 collectPatsBinders :: [LPat a] -> [a]
 394 collectPatsBinders pats = map unLoc (collectLocatedPatsBinders pats)
 395
 396 collectLocatedPatsBinders :: [LPat a] -> [Located a]
 397 collectLocatedPatsBinders pats = foldr collectl [] pats
 398
 399 ---------------------
 400 collectl (L l pat) bndrs
 401   = go pat
 402   where
 403     go (VarPat var)               = L l var : bndrs
 404     go (VarPatOut var bs)         = L l var : collectHsBindLocatedBinders bs
 405                                     ++ bndrs
 406     go (WildPat _)                = bndrs
 407     go (LazyPat pat)              = collectl pat bndrs
 408     go (BangPat pat)              = collectl pat bndrs
 409     go (AsPat a pat)              = a : collectl pat bndrs
 410     go (ViewPat exp pat _)     = collectl pat bndrs
 411     go (ParPat  pat)              = collectl pat bndrs
 412
 413     go (ListPat pats _)           = foldr collectl bndrs pats
 414     go (PArrPat pats _)           = foldr collectl bndrs pats
 415     go (TuplePat pats _ _)        = foldr collectl bndrs pats
 416
 417     go (ConPatIn c ps)            = foldr collectl bndrs (hsConPatArgs ps)
 418     go (ConPatOut {pat_args=ps})  = foldr collectl bndrs (hsConPatArgs ps)
 419         -- See Note [Dictionary binders in ConPatOut]
 420     go (LitPat _)                 = bndrs
 421     go (NPat _ _ _)               = bndrs
 422     go (NPlusKPat n _ _ _)        = n : bndrs
 423
 424     go (SigPatIn pat _)           = collectl pat bndrs
 425     go (SigPatOut pat _)          = collectl pat bndrs
 426     go (QuasiQuotePat _)          = bndrs
 427     go (TypePat ty)               = bndrs
 428     go (CoPat _ pat ty)           = collectl (noLoc pat) bndrs
 429 \end{code}
 430
 431 Note [Dictionary binders in ConPatOut]
 432 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 433 Do *not* gather (a) dictionary and (b) dictionary bindings as binders
 434 of a ConPatOut pattern.  For most calls it doesn't matter, because
 435 it's pre-typechecker and there are no ConPatOuts.  But it does matter
 436 more in the desugarer; for example, DsUtils.mkSelectorBinds uses
 437 collectPatBinders.  In a lazy pattern, for example f ~(C x y) = ...,
 438 we want to generate bindings for x,y but not for dictionaries bound by
 439 C.  (The type checker ensures they would not be used.)
 440
 441 Desugaring of arrow case expressions needs these bindings (see DsArrows
 442 and arrowcase1), but SPJ (Jan 2007) says it's safer for it to use its
 443 own pat-binder-collector:
 444
 445 Here's the problem.  Consider
 446
 447 data T a where
 448    C :: Num a => a -> Int -> T a
 449
 450 f ~(C (n+1) m) = (n,m)
 451
 452 Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a),
 453 and *also* uses that dictionary to match the (n+1) pattern.  Yet, the
 454 variables bound by the lazy pattern are n,m, *not* the dictionary d.
 455 So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound.
 456
 457 \begin{code}
 458 collectSigTysFromPats :: [InPat name] -> [LHsType name]
 459 collectSigTysFromPats pats = foldr collect_lpat [] pats
 460
 461 collectSigTysFromPat :: InPat name -> [LHsType name]
 462 collectSigTysFromPat pat = collect_lpat pat []
 463
 464 collect_lpat pat acc = collect_pat (unLoc pat) acc
 465
 466 collect_pat (SigPatIn pat ty)   acc = collect_lpat pat (ty:acc)
 467 collect_pat (TypePat ty)        acc = ty:acc
 468
 469 collect_pat (LazyPat pat)       acc = collect_lpat pat acc
 470 collect_pat (BangPat pat)       acc = collect_lpat pat acc
 471 collect_pat (AsPat a pat)       acc = collect_lpat pat acc
 472 collect_pat (ParPat  pat)       acc = collect_lpat pat acc
 473 collect_pat (ListPat pats _)    acc = foldr collect_lpat acc pats
 474 collect_pat (PArrPat pats _)    acc = foldr collect_lpat acc pats
 475 collect_pat (TuplePat pats _ _) acc = foldr collect_lpat acc pats
 476 collect_pat (ConPatIn c ps)     acc = foldr collect_lpat acc (hsConPatArgs ps)
 477 collect_pat other               acc = acc       -- Literals, vars, wildcard
 478 \end{code}