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 OccName          ( mkVarOccFS )
  31 import Name             ( Name )
  32 import BasicTypes       ( RecFlag(..) )
  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) emptyLocalBinds)
  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 [] 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 mkHsCoerce :: ExprCoFn -> HsExpr id -> HsExpr id
  83 mkHsCoerce co_fn e | isIdCoercion co_fn = e
  84                    | otherwise          = HsCoerce co_fn e
  85
  86 mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
  87 mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
  88         where
  89           matches = mkMatchGroup [mkSimpleMatch pats body]
  90
  91 mkMatchGroup :: [LMatch id] -> MatchGroup id
  92 mkMatchGroup matches = MatchGroup matches placeHolderType
  93
  94 mkHsTyLam []     expr = expr
  95 mkHsTyLam tyvars expr = L (getLoc expr) (TyLam tyvars expr)
  96
  97 mkHsDictLam []    expr = expr
  98 mkHsDictLam dicts expr = L (getLoc expr) (DictLam dicts expr)
  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 dictinoary terms etc, so no locations
 111 mkHsConApp data_con tys args
 112   = foldl mk_app (noLoc (HsVar (dataConWrapId data_con)) `mkHsTyApp` 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 mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType
 128
 129 mkNPat lit neg     = NPat lit neg noSyntaxExpr placeHolderType
 130 mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr
 131
 132 mkExprStmt expr     = ExprStmt expr noSyntaxExpr placeHolderType
 133 mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr
 134 mkRecStmt stmts     = RecStmt stmts [] [] [] emptyLHsBinds
 135
 136 -------------------------------
 137 --- A useful function for building @OpApps@.  The operator is always a
 138 -- variable, and we don't know the fixity yet.
 139 mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2
 140
 141 mkHsSplice e = HsSplice unqualSplice e
 142
 143 unqualSplice = mkRdrUnqual (mkVarOccFS FSLIT("splice"))
 144                 -- A name (uniquified later) to
 145                 -- identify the splice
 146
 147 mkHsString s = HsString (mkFastString s)
 148
 149 -------------
 150 userHsTyVarBndrs :: [Located name] -> [Located (HsTyVarBndr name)]
 151 userHsTyVarBndrs bndrs = [ L loc (UserTyVar v) | L loc v <- bndrs ]
 152 \end{code}
 153
 154
 155 %************************************************************************
 156 %*                                                                      *
 157         Constructing syntax with no location info
 158 %*                                                                      *
 159 %************************************************************************
 160
 161 \begin{code}
 162 nlHsVar :: id -> LHsExpr id
 163 nlHsVar n = noLoc (HsVar n)
 164
 165 nlHsLit :: HsLit -> LHsExpr id
 166 nlHsLit n = noLoc (HsLit n)
 167
 168 nlVarPat :: id -> LPat id
 169 nlVarPat n = noLoc (VarPat n)
 170
 171 nlLitPat :: HsLit -> LPat id
 172 nlLitPat l = noLoc (LitPat l)
 173
 174 nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
 175 nlHsApp f x = noLoc (HsApp f x)
 176
 177 nlHsIntLit n = noLoc (HsLit (HsInt n))
 178
 179 nlHsApps :: id -> [LHsExpr id] -> LHsExpr id
 180 nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
 181
 182 nlHsVarApps :: id -> [id] -> LHsExpr id
 183 nlHsVarApps f xs = noLoc (foldl mk (HsVar f) (map HsVar xs))
 184                  where
 185                    mk f a = HsApp (noLoc f) (noLoc a)
 186
 187 nlConVarPat :: id -> [id] -> LPat id
 188 nlConVarPat con vars = nlConPat con (map nlVarPat vars)
 189
 190 nlInfixConPat :: id -> LPat id -> LPat id -> LPat id
 191 nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))
 192
 193 nlConPat :: id -> [LPat id] -> LPat id
 194 nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
 195
 196 nlNullaryConPat :: id -> LPat id
 197 nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
 198
 199 nlWildConPat :: DataCon -> LPat RdrName
 200 nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
 201                                    (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat)))
 202
 203 nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType)
 204 nlWildPat  = noLoc (WildPat placeHolderType)    -- Pre-typechecking
 205
 206 nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> LHsExpr id
 207 nlHsDo ctxt stmts body = noLoc (mkHsDo ctxt stmts body)
 208
 209 nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
 210
 211 nlHsLam match           = noLoc (HsLam (mkMatchGroup [match]))
 212 nlHsPar e               = noLoc (HsPar e)
 213 nlHsIf cond true false  = noLoc (HsIf cond true false)
 214 nlHsCase expr matches   = noLoc (HsCase expr (mkMatchGroup matches))
 215 nlTuple exprs box       = noLoc (ExplicitTuple exprs box)
 216 nlList exprs            = noLoc (ExplicitList placeHolderType exprs)
 217
 218 nlHsAppTy f t           = noLoc (HsAppTy f t)
 219 nlHsTyVar x             = noLoc (HsTyVar x)
 220 nlHsFunTy a b           = noLoc (HsFunTy a b)
 221 \end{code}
 222
 223
 224
 225 %************************************************************************
 226 %*                                                                      *
 227                 Bindings; with a location at the top
 228 %*                                                                      *
 229 %************************************************************************
 230
 231 \begin{code}
 232 mkFunBind :: Located id -> [LMatch id] -> HsBind id
 233 -- Not infix, with place holders for coercion and free vars
 234 mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False, fun_matches = mkMatchGroup ms,
 235                             fun_co_fn = idCoercion, bind_fvs = placeHolderNames }
 236
 237
 238 mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
 239 mkVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
 240
 241 ------------
 242 mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
 243                 -> LHsExpr RdrName -> LHsBind RdrName
 244
 245 mk_easy_FunBind loc fun pats expr
 246   = L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds]
 247
 248 ------------
 249 mk_FunBind :: SrcSpan -> RdrName
 250            -> [([LPat RdrName], LHsExpr RdrName)]
 251            -> LHsBind RdrName
 252
 253 mk_FunBind loc fun [] = panic "TcGenDeriv:mk_FunBind"
 254 mk_FunBind loc fun pats_and_exprs
 255   = L loc $ mkFunBind (L loc fun) matches
 256   where
 257     matches = [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs]
 258
 259 ------------
 260 mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id
 261 mkMatch pats expr binds
 262   = noLoc (Match (map paren pats) Nothing
 263                  (GRHSs (unguardedRHS expr) binds))
 264   where
 265     paren p = case p of
 266                 L _ (VarPat _) -> p
 267                 L l _          -> L l (ParPat p)
 268 \end{code}
 269
 270
 271 %************************************************************************
 272 %*                                                                      *
 273         Collecting binders from HsBindGroups and HsBinds
 274 %*                                                                      *
 275 %************************************************************************
 276
 277 Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg.
 278
 279 ...
 280 where
 281   (x, y) = ...
 282   f i j  = ...
 283   [a, b] = ...
 284
 285 it should return [x, y, f, a, b] (remember, order important).
 286
 287 \begin{code}
 288 collectLocalBinders :: HsLocalBinds name -> [Located name]
 289 collectLocalBinders (HsValBinds val_binds) = collectHsValBinders val_binds
 290 collectLocalBinders (HsIPBinds _)   = []
 291 collectLocalBinders EmptyLocalBinds = []
 292
 293 collectHsValBinders :: HsValBinds name -> [Located name]
 294 collectHsValBinders (ValBindsIn binds sigs)  = collectHsBindLocatedBinders binds
 295 collectHsValBinders (ValBindsOut binds sigs) = foldr collect_one [] binds
 296   where
 297    collect_one (_,binds) acc = foldrBag (collectAcc . unLoc) acc binds
 298
 299 collectAcc :: HsBind name -> [Located name] -> [Located name]
 300 collectAcc (PatBind { pat_lhs = p }) acc = collectLocatedPatBinders p ++ acc
 301 collectAcc (FunBind { fun_id = f })  acc    = f : acc
 302 collectAcc (VarBind { var_id = f })  acc    = noLoc f : acc
 303 collectAcc (AbsBinds { abs_exports = dbinds, abs_binds = binds }) acc
 304   = [noLoc dp | (_,dp,_,_) <- dbinds] ++ acc
 305         -- ++ foldr collectAcc acc binds
 306         -- I don't think we want the binders from the nested binds
 307         -- The only time we collect binders from a typechecked
 308         -- binding (hence see AbsBinds) is in zonking in TcHsSyn
 309
 310 collectHsBindBinders :: LHsBinds name -> [name]
 311 collectHsBindBinders binds = map unLoc (collectHsBindLocatedBinders binds)
 312
 313 collectHsBindLocatedBinders :: LHsBinds name -> [Located name]
 314 collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds
 315 \end{code}
 316
 317
 318 %************************************************************************
 319 %*                                                                      *
 320         Getting binders from statements
 321 %*                                                                      *
 322 %************************************************************************
 323
 324 \begin{code}
 325 collectLStmtsBinders :: [LStmt id] -> [Located id]
 326 collectLStmtsBinders = concatMap collectLStmtBinders
 327
 328 collectStmtsBinders :: [Stmt id] -> [Located id]
 329 collectStmtsBinders = concatMap collectStmtBinders
 330
 331 collectLStmtBinders :: LStmt id -> [Located id]
 332 collectLStmtBinders = collectStmtBinders . unLoc
 333
 334 collectStmtBinders :: Stmt id -> [Located id]
 335   -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
 336 collectStmtBinders (BindStmt pat _ _ _) = collectLocatedPatBinders pat
 337 collectStmtBinders (LetStmt binds)      = collectLocalBinders binds
 338 collectStmtBinders (ExprStmt _ _ _)     = []
 339 collectStmtBinders (RecStmt ss _ _ _ _) = collectLStmtsBinders ss
 340 collectStmtBinders other                = panic "collectStmtBinders"
 341 \end{code}
 342
 343
 344 %************************************************************************
 345 %*                                                                      *
 346 %*      Gathering stuff out of patterns
 347 %*                                                                      *
 348 %************************************************************************
 349
 350 This function @collectPatBinders@ works with the ``collectBinders''
 351 functions for @HsBinds@, etc.  The order in which the binders are
 352 collected is important; see @HsBinds.lhs@.
 353
 354 It collects the bounds *value* variables in renamed patterns; type variables
 355 are *not* collected.
 356
 357 \begin{code}
 358 collectPatBinders :: LPat a -> [a]
 359 collectPatBinders pat = map unLoc (collectLocatedPatBinders pat)
 360
 361 collectLocatedPatBinders :: LPat a -> [Located a]
 362 collectLocatedPatBinders pat = collectl pat []
 363
 364 collectPatsBinders :: [LPat a] -> [a]
 365 collectPatsBinders pats = map unLoc (collectLocatedPatsBinders pats)
 366
 367 collectLocatedPatsBinders :: [LPat a] -> [Located a]
 368 collectLocatedPatsBinders pats = foldr collectl [] pats
 369
 370 ---------------------
 371 collectl (L l pat) bndrs
 372   = go pat
 373   where
 374     go (VarPat var)               = L l var : bndrs
 375     go (VarPatOut var bs)         = L l var : collectHsBindLocatedBinders bs
 376                                     ++ bndrs
 377     go (WildPat _)                = bndrs
 378     go (LazyPat pat)              = collectl pat bndrs
 379     go (BangPat pat)              = collectl pat bndrs
 380     go (AsPat a pat)              = a : collectl pat bndrs
 381     go (ParPat  pat)              = collectl pat bndrs
 382
 383     go (ListPat pats _)           = foldr collectl bndrs pats
 384     go (PArrPat pats _)           = foldr collectl bndrs pats
 385     go (TuplePat pats _ _)        = foldr collectl bndrs pats
 386
 387     go (ConPatIn c ps)            = foldr collectl bndrs (hsConArgs ps)
 388     go (ConPatOut c _ ds bs ps _) = map noLoc ds
 389                                     ++ collectHsBindLocatedBinders bs
 390                                     ++ foldr collectl bndrs (hsConArgs ps)
 391     go (LitPat _)                 = bndrs
 392     go (NPat _ _ _ _)             = bndrs
 393     go (NPlusKPat n _ _ _)        = n : bndrs
 394
 395     go (SigPatIn pat _)           = collectl pat bndrs
 396     go (SigPatOut pat _)          = collectl pat bndrs
 397     go (TypePat ty)               = bndrs
 398     go (DictPat ids1 ids2)        = map noLoc ids1 ++ map noLoc ids2
 399                                     ++ bndrs
 400 \end{code}
 401
 402 \begin{code}
 403 collectSigTysFromPats :: [InPat name] -> [LHsType name]
 404 collectSigTysFromPats pats = foldr collect_lpat [] pats
 405
 406 collectSigTysFromPat :: InPat name -> [LHsType name]
 407 collectSigTysFromPat pat = collect_lpat pat []
 408
 409 collect_lpat pat acc = collect_pat (unLoc pat) acc
 410
 411 collect_pat (SigPatIn pat ty)   acc = collect_lpat pat (ty:acc)
 412 collect_pat (TypePat ty)        acc = ty:acc
 413
 414 collect_pat (LazyPat pat)       acc = collect_lpat pat acc
 415 collect_pat (BangPat pat)       acc = collect_lpat pat acc
 416 collect_pat (AsPat a pat)       acc = collect_lpat pat acc
 417 collect_pat (ParPat  pat)       acc = collect_lpat pat acc
 418 collect_pat (ListPat pats _)    acc = foldr collect_lpat acc pats
 419 collect_pat (PArrPat pats _)    acc = foldr collect_lpat acc pats
 420 collect_pat (TuplePat pats _ _) acc = foldr collect_lpat acc pats
 421 collect_pat (ConPatIn c ps)     acc = foldr collect_lpat acc (hsConArgs ps)
 422 collect_pat other               acc = acc       -- Literals, vars, wildcard
 423 \end{code}