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
 230
 231 mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
 232 mkVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
 233
 234 ------------
 235 mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
 236                 -> LHsExpr RdrName -> LHsBind RdrName
 237
 238 mk_easy_FunBind loc fun pats expr
 239   = L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds]
 240
 241 ------------
 242 mk_FunBind :: SrcSpan -> RdrName
 243            -> [([LPat RdrName], LHsExpr RdrName)]
 244            -> LHsBind RdrName
 245
 246 mk_FunBind loc fun [] = panic "TcGenDeriv:mk_FunBind"
 247 mk_FunBind loc fun pats_and_exprs
 248   = L loc $ mkFunBind (L loc fun) matches
 249   where
 250     matches = [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs]
 251
 252 ------------
 253 mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id
 254 mkMatch pats expr binds
 255   = noLoc (Match (map paren pats) Nothing
 256                  (GRHSs (unguardedRHS expr) binds))
 257   where
 258     paren p = case p of
 259                 L _ (VarPat _) -> p
 260                 L l _          -> L l (ParPat p)
 261 \end{code}
 262
 263
 264 %************************************************************************
 265 %*                                                                      *
 266         Collecting binders from HsBindGroups and HsBinds
 267 %*                                                                      *
 268 %************************************************************************
 269
 270 Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg.
 271
 272 ...
 273 where
 274   (x, y) = ...
 275   f i j  = ...
 276   [a, b] = ...
 277
 278 it should return [x, y, f, a, b] (remember, order important).
 279
 280 \begin{code}
 281 collectLocalBinders :: HsLocalBinds name -> [Located name]
 282 collectLocalBinders (HsValBinds val_binds) = collectHsValBinders val_binds
 283 collectLocalBinders (HsIPBinds _)   = []
 284 collectLocalBinders EmptyLocalBinds = []
 285
 286 collectHsValBinders :: HsValBinds name -> [Located name]
 287 collectHsValBinders (ValBindsIn binds sigs)  = collectHsBindLocatedBinders binds
 288 collectHsValBinders (ValBindsOut binds sigs) = foldr collect_one [] binds
 289   where
 290    collect_one (_,binds) acc = foldrBag (collectAcc . unLoc) acc binds
 291
 292 collectAcc :: HsBind name -> [Located name] -> [Located name]
 293 collectAcc (PatBind { pat_lhs = p }) acc = collectLocatedPatBinders p ++ acc
 294 collectAcc (FunBind { fun_id = f })  acc    = f : acc
 295 collectAcc (VarBind { var_id = f })  acc    = noLoc f : acc
 296 collectAcc (AbsBinds { abs_exports = dbinds, abs_binds = binds }) acc
 297   = [noLoc dp | (_,dp,_,_) <- dbinds] ++ acc
 298         -- ++ foldr collectAcc acc binds
 299         -- I don't think we want the binders from the nested binds
 300         -- The only time we collect binders from a typechecked
 301         -- binding (hence see AbsBinds) is in zonking in TcHsSyn
 302
 303 collectHsBindBinders :: LHsBinds name -> [name]
 304 collectHsBindBinders binds = map unLoc (collectHsBindLocatedBinders binds)
 305
 306 collectHsBindLocatedBinders :: LHsBinds name -> [Located name]
 307 collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds
 308 \end{code}
 309
 310
 311 %************************************************************************
 312 %*                                                                      *
 313         Getting binders from statements
 314 %*                                                                      *
 315 %************************************************************************
 316
 317 \begin{code}
 318 collectLStmtsBinders :: [LStmt id] -> [Located id]
 319 collectLStmtsBinders = concatMap collectLStmtBinders
 320
 321 collectStmtsBinders :: [Stmt id] -> [Located id]
 322 collectStmtsBinders = concatMap collectStmtBinders
 323
 324 collectLStmtBinders :: LStmt id -> [Located id]
 325 collectLStmtBinders = collectStmtBinders . unLoc
 326
 327 collectStmtBinders :: Stmt id -> [Located id]
 328   -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
 329 collectStmtBinders (BindStmt pat _ _ _) = collectLocatedPatBinders pat
 330 collectStmtBinders (LetStmt binds)      = collectLocalBinders binds
 331 collectStmtBinders (ExprStmt _ _ _)     = []
 332 collectStmtBinders (RecStmt ss _ _ _ _) = collectLStmtsBinders ss
 333 collectStmtBinders other                = panic "collectStmtBinders"
 334 \end{code}
 335
 336
 337 %************************************************************************
 338 %*                                                                      *
 339 %*      Gathering stuff out of patterns
 340 %*                                                                      *
 341 %************************************************************************
 342
 343 This function @collectPatBinders@ works with the ``collectBinders''
 344 functions for @HsBinds@, etc.  The order in which the binders are
 345 collected is important; see @HsBinds.lhs@.
 346
 347 It collects the bounds *value* variables in renamed patterns; type variables
 348 are *not* collected.
 349
 350 \begin{code}
 351 collectPatBinders :: LPat a -> [a]
 352 collectPatBinders pat = map unLoc (collectLocatedPatBinders pat)
 353
 354 collectLocatedPatBinders :: LPat a -> [Located a]
 355 collectLocatedPatBinders pat = collectl pat []
 356
 357 collectPatsBinders :: [LPat a] -> [a]
 358 collectPatsBinders pats = map unLoc (collectLocatedPatsBinders pats)
 359
 360 collectLocatedPatsBinders :: [LPat a] -> [Located a]
 361 collectLocatedPatsBinders pats = foldr collectl [] pats
 362
 363 ---------------------
 364 collectl (L l pat) bndrs
 365   = go pat
 366   where
 367     go (VarPat var)               = L l var : bndrs
 368     go (VarPatOut var bs)         = L l var : collectHsBindLocatedBinders bs
 369                                     ++ bndrs
 370     go (WildPat _)                = bndrs
 371     go (LazyPat pat)              = collectl pat bndrs
 372     go (BangPat pat)              = collectl pat bndrs
 373     go (AsPat a pat)              = a : collectl pat bndrs
 374     go (ParPat  pat)              = collectl pat bndrs
 375
 376     go (ListPat pats _)           = foldr collectl bndrs pats
 377     go (PArrPat pats _)           = foldr collectl bndrs pats
 378     go (TuplePat pats _ _)        = foldr collectl bndrs pats
 379
 380     go (ConPatIn c ps)            = foldr collectl bndrs (hsConArgs ps)
 381     go (ConPatOut { pat_dicts = ds,
 382                     pat_binds = bs, pat_args = ps })
 383                                   = map noLoc ds
 384                                     ++ collectHsBindLocatedBinders bs
 385                                     ++ foldr collectl bndrs (hsConArgs ps)
 386     go (LitPat _)                 = bndrs
 387     go (NPat _ _ _ _)             = bndrs
 388     go (NPlusKPat n _ _ _)        = n : bndrs
 389
 390     go (SigPatIn pat _)           = collectl pat bndrs
 391     go (SigPatOut pat _)          = collectl pat bndrs
 392     go (TypePat ty)               = bndrs
 393     go (DictPat ids1 ids2)        = map noLoc ids1 ++ map noLoc ids2
 394                                     ++ bndrs
 395     go (CoPat _ pat ty)           = collectl (noLoc pat) bndrs
 396 \end{code}
 397
 398 \begin{code}
 399 collectSigTysFromPats :: [InPat name] -> [LHsType name]
 400 collectSigTysFromPats pats = foldr collect_lpat [] pats
 401
 402 collectSigTysFromPat :: InPat name -> [LHsType name]
 403 collectSigTysFromPat pat = collect_lpat pat []
 404
 405 collect_lpat pat acc = collect_pat (unLoc pat) acc
 406
 407 collect_pat (SigPatIn pat ty)   acc = collect_lpat pat (ty:acc)
 408 collect_pat (TypePat ty)        acc = ty:acc
 409
 410 collect_pat (LazyPat pat)       acc = collect_lpat pat acc
 411 collect_pat (BangPat pat)       acc = collect_lpat pat acc
 412 collect_pat (AsPat a pat)       acc = collect_lpat pat acc
 413 collect_pat (ParPat  pat)       acc = collect_lpat pat acc
 414 collect_pat (ListPat pats _)    acc = foldr collect_lpat acc pats
 415 collect_pat (PArrPat pats _)    acc = foldr collect_lpat acc pats
 416 collect_pat (TuplePat pats _ _) acc = foldr collect_lpat acc pats
 417 collect_pat (ConPatIn c ps)     acc = foldr collect_lpat acc (hsConArgs ps)
 418 collect_pat other               acc = acc       -- Literals, vars, wildcard
 419 \end{code}
 420
 421 %************************************************************************
 422 %*                                                                      *
 423 %*      Getting the main binder name of a top declaration
 424 %*                                                                      *
 425 %************************************************************************
 426
 427 \begin{code}
 428
 429 getMainDeclBinder :: HsDecl name -> Maybe name
 430 getMainDeclBinder (TyClD d) = Just (tcdName d)
 431 getMainDeclBinder (ValD d)
 432    = case collectAcc d [] of
 433         []       -> Nothing   -- see rn003
 434         (name:_) -> Just (unLoc name)
 435 getMainDeclBinder (SigD d) = sigNameNoLoc d
 436 getMainDeclBinder (ForD (ForeignImport name _ _)) = Just (unLoc name)
 437 getMainDeclBinder (ForD (ForeignExport name _ _)) = Just (unLoc name)
 438 getMainDeclBinder _ = Nothing
 439
 440 \end{code}