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