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 import HsDecls
  26
  27 import RdrName          ( RdrName, getRdrName, mkRdrUnqual )
  28 import Var              ( Id )
  29 import Type             ( Type )
  30 import DataCon          ( DataCon, dataConWrapId, dataConSourceArity )
  31 import OccName          ( mkVarOccFS )
  32 import Name             ( Name )
  33 import BasicTypes       ( RecFlag(..) )
  34 import SrcLoc
  35 import FastString       ( mkFastString )
  36 import Outputable
  37 import Util             ( nOfThem )
  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}