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