ghc/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          ( mkVarOcc )
  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 mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
  83 mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
  84         where
  85           matches = mkMatchGroup [mkSimpleMatch pats body]
  86
  87 mkMatchGroup :: [LMatch id] -> MatchGroup id
  88 mkMatchGroup matches = MatchGroup matches placeHolderType
  89
  90 mkHsTyLam []     expr = expr
  91 mkHsTyLam tyvars expr = L (getLoc expr) (TyLam tyvars expr)
  92
  93 mkHsDictLam []    expr = expr
  94 mkHsDictLam dicts expr = L (getLoc expr) (DictLam dicts expr)
  95
  96 mkHsDictLet :: LHsBinds Id -> LHsExpr Id -> LHsExpr Id
  97 -- Used for the dictionary bindings gotten from TcSimplify
  98 -- We make them recursive to be on the safe side
  99 mkHsDictLet binds expr
 100   | isEmptyLHsBinds binds = expr
 101   | otherwise             = L (getLoc expr) (HsLet (HsValBinds val_binds) expr)
 102                           where
 103                             val_binds = ValBindsOut [(Recursive, binds)]
 104
 105 mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
 106 -- Used for constructing dictinoary terms etc, so no locations
 107 mkHsConApp data_con tys args
 108   = foldl mk_app (noLoc (HsVar (dataConWrapId data_con)) `mkHsTyApp` tys) args
 109   where
 110     mk_app f a = noLoc (HsApp f (noLoc a))
 111
 112 mkSimpleHsAlt :: LPat id -> LHsExpr id -> LMatch id
 113 -- A simple lambda with a single pattern, no binds, no guards; pre-typechecking
 114 mkSimpleHsAlt pat expr
 115   = mkSimpleMatch [pat] expr
 116
 117 -------------------------------
 118 -- These are the bits of syntax that contain rebindable names
 119 -- See RnEnv.lookupSyntaxName
 120
 121 mkHsIntegral   i       = HsIntegral   i  noSyntaxExpr
 122 mkHsFractional f       = HsFractional f  noSyntaxExpr
 123 mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType
 124
 125 mkNPat lit neg     = NPat lit neg noSyntaxExpr placeHolderType
 126 mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr
 127
 128 mkExprStmt expr     = ExprStmt expr noSyntaxExpr placeHolderType
 129 mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr
 130 mkRecStmt stmts     = RecStmt stmts [] [] [] emptyLHsBinds
 131
 132 -------------------------------
 133 --- A useful function for building @OpApps@.  The operator is always a
 134 -- variable, and we don't know the fixity yet.
 135 mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2
 136
 137 mkHsSplice e = HsSplice unqualSplice e
 138
 139 unqualSplice = mkRdrUnqual (mkVarOcc FSLIT("splice"))
 140                 -- A name (uniquified later) to
 141                 -- identify the splice
 142
 143 mkHsString s = HsString (mkFastString s)
 144 \end{code}
 145
 146
 147 %************************************************************************
 148 %*                                                                      *
 149         Constructing syntax with no location info
 150 %*                                                                      *
 151 %************************************************************************
 152
 153 \begin{code}
 154 nlHsVar :: id -> LHsExpr id
 155 nlHsVar n = noLoc (HsVar n)
 156
 157 nlHsLit :: HsLit -> LHsExpr id
 158 nlHsLit n = noLoc (HsLit n)
 159
 160 nlVarPat :: id -> LPat id
 161 nlVarPat n = noLoc (VarPat n)
 162
 163 nlLitPat :: HsLit -> LPat id
 164 nlLitPat l = noLoc (LitPat l)
 165
 166 nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
 167 nlHsApp f x = noLoc (HsApp f x)
 168
 169 nlHsIntLit n = noLoc (HsLit (HsInt n))
 170
 171 nlHsApps :: id -> [LHsExpr id] -> LHsExpr id
 172 nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
 173
 174 nlHsVarApps :: id -> [id] -> LHsExpr id
 175 nlHsVarApps f xs = noLoc (foldl mk (HsVar f) (map HsVar xs))
 176                  where
 177                    mk f a = HsApp (noLoc f) (noLoc a)
 178
 179 nlConVarPat :: id -> [id] -> LPat id
 180 nlConVarPat con vars = nlConPat con (map nlVarPat vars)
 181
 182 nlInfixConPat :: id -> LPat id -> LPat id -> LPat id
 183 nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))
 184
 185 nlConPat :: id -> [LPat id] -> LPat id
 186 nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
 187
 188 nlNullaryConPat :: id -> LPat id
 189 nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
 190
 191 nlWildConPat :: DataCon -> LPat RdrName
 192 nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
 193                                    (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat)))
 194
 195 nlTuplePat pats box = noLoc (TuplePat pats box)
 196 nlWildPat  = noLoc (WildPat placeHolderType)    -- Pre-typechecking
 197
 198 nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> LHsExpr id
 199 nlHsDo ctxt stmts body = noLoc (mkHsDo ctxt stmts body)
 200
 201 nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
 202
 203 nlHsLam match           = noLoc (HsLam (mkMatchGroup [match]))
 204 nlHsPar e               = noLoc (HsPar e)
 205 nlHsIf cond true false  = noLoc (HsIf cond true false)
 206 nlHsCase expr matches   = noLoc (HsCase expr (mkMatchGroup matches))
 207 nlTuple exprs box       = noLoc (ExplicitTuple exprs box)
 208 nlList exprs            = noLoc (ExplicitList placeHolderType exprs)
 209
 210 nlHsAppTy f t           = noLoc (HsAppTy f t)
 211 nlHsTyVar x             = noLoc (HsTyVar x)
 212 nlHsFunTy a b           = noLoc (HsFunTy a b)
 213 \end{code}
 214
 215
 216
 217 %************************************************************************
 218 %*                                                                      *
 219                 Bindings; with a location at the top
 220 %*                                                                      *
 221 %************************************************************************
 222
 223 \begin{code}
 224 mkVarBind :: SrcSpan -> name -> LHsExpr name -> LHsBind name
 225 mkVarBind loc var rhs = mk_easy_FunBind loc var [] emptyLHsBinds rhs
 226
 227 ------------
 228 mk_easy_FunBind :: SrcSpan -> name -> [LPat name]
 229                 -> LHsBinds name -> LHsExpr name
 230                 -> LHsBind name
 231
 232 mk_easy_FunBind loc fun pats binds expr
 233   = L loc (FunBind (L loc fun) False{-not infix-} matches placeHolderNames)
 234   where
 235     matches = mkMatchGroup [mk_easy_Match pats binds expr]
 236
 237 ------------
 238 mk_FunBind :: SrcSpan -> RdrName
 239            -> [([LPat RdrName], LHsExpr RdrName)]
 240            -> LHsBind RdrName
 241
 242 mk_FunBind loc fun [] = panic "TcGenDeriv:mk_FunBind"
 243 mk_FunBind loc fun pats_and_exprs
 244   = L loc (FunBind (L loc fun) False{-not infix-} matches placeHolderNames)
 245   where
 246     matches = mkMatchGroup [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs]
 247
 248 ------------
 249 mk_easy_Match pats binds expr
 250   = mkMatch pats expr (HsValBinds (ValBindsIn binds []))
 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)     = panic "collectHsValBinders"
 289
 290 collectAcc :: HsBind name -> [Located name] -> [Located name]
 291 collectAcc (PatBind pat _ _ _) acc = collectLocatedPatBinders pat ++ acc
 292 collectAcc (FunBind f _ _ _) acc   = f : acc
 293 collectAcc (VarBind f _) acc       = noLoc f : acc
 294 collectAcc (AbsBinds _ _ dbinds binds) acc
 295   = [noLoc dp | (_,dp,_,_) <- dbinds] ++ acc
 296         -- ++ foldr collectAcc acc binds
 297         -- I don't think we want the binders from the nested binds
 298         -- The only time we collect binders from a typechecked
 299         -- binding (hence see AbsBinds) is in zonking in TcHsSyn
 300
 301 collectHsBindBinders :: LHsBinds name -> [name]
 302 collectHsBindBinders binds = map unLoc (collectHsBindLocatedBinders binds)
 303
 304 collectHsBindLocatedBinders :: LHsBinds name -> [Located name]
 305 collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds
 306 \end{code}
 307
 308
 309 %************************************************************************
 310 %*                                                                      *
 311         Getting pattern signatures out of bindings
 312 %*                                                                      *
 313 %************************************************************************
 314
 315 Get all the pattern type signatures out of a bunch of bindings
 316
 317 \begin{code}
 318 collectSigTysFromHsBinds :: [LHsBind name] -> [LHsType name]
 319 collectSigTysFromHsBinds binds = concat (map collectSigTysFromHsBind binds)
 320
 321 collectSigTysFromHsBind :: LHsBind name -> [LHsType name]
 322 collectSigTysFromHsBind bind
 323   = go (unLoc bind)
 324   where
 325     go (PatBind pat _ _ _)
 326         = collectSigTysFromPat pat
 327     go (FunBind f _ (MatchGroup ms _) _)
 328         = [sig | L _ (Match [] (Just sig) _) <- ms]
 329         -- A binding like    x :: a = f y
 330         -- is parsed as FunMonoBind, but for this purpose we
 331         -- want to treat it as a pattern binding
 332     go out_bind = panic "collectSigTysFromHsBind"
 333 \end{code}
 334
 335 %************************************************************************
 336 %*                                                                      *
 337         Getting binders from statements
 338 %*                                                                      *
 339 %************************************************************************
 340
 341 \begin{code}
 342 collectLStmtsBinders :: [LStmt id] -> [Located id]
 343 collectLStmtsBinders = concatMap collectLStmtBinders
 344
 345 collectStmtsBinders :: [Stmt id] -> [Located id]
 346 collectStmtsBinders = concatMap collectStmtBinders
 347
 348 collectLStmtBinders :: LStmt id -> [Located id]
 349 collectLStmtBinders = collectStmtBinders . unLoc
 350
 351 collectStmtBinders :: Stmt id -> [Located id]
 352   -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
 353 collectStmtBinders (BindStmt pat _ _ _) = collectLocatedPatBinders pat
 354 collectStmtBinders (LetStmt binds)      = collectLocalBinders binds
 355 collectStmtBinders (ExprStmt _ _ _)     = []
 356 collectStmtBinders (RecStmt ss _ _ _ _) = collectLStmtsBinders ss
 357 collectStmtBinders other                = panic "collectStmtBinders"
 358 \end{code}
 359
 360
 361 %************************************************************************
 362 %*                                                                      *
 363 %*      Gathering stuff out of patterns
 364 %*                                                                      *
 365 %************************************************************************
 366
 367 This function @collectPatBinders@ works with the ``collectBinders''
 368 functions for @HsBinds@, etc.  The order in which the binders are
 369 collected is important; see @HsBinds.lhs@.
 370
 371 It collects the bounds *value* variables in renamed patterns; type variables
 372 are *not* collected.
 373
 374 \begin{code}
 375 collectPatBinders :: LPat a -> [a]
 376 collectPatBinders pat = map unLoc (collectLocatedPatBinders pat)
 377
 378 collectLocatedPatBinders :: LPat a -> [Located a]
 379 collectLocatedPatBinders pat = collectl pat []
 380
 381 collectPatsBinders :: [LPat a] -> [a]
 382 collectPatsBinders pats = map unLoc (collectLocatedPatsBinders pats)
 383
 384 collectLocatedPatsBinders :: [LPat a] -> [Located a]
 385 collectLocatedPatsBinders pats = foldr collectl [] pats
 386
 387 ---------------------
 388 collectl (L l pat) bndrs
 389   = go pat
 390   where
 391     go (VarPat var)               = L l var : bndrs
 392     go (VarPatOut var bs)         = L l var : collectHsBindLocatedBinders bs
 393                                     ++ bndrs
 394     go (WildPat _)                = bndrs
 395     go (LazyPat pat)              = collectl pat bndrs
 396     go (AsPat a pat)              = a : collectl pat bndrs
 397     go (ParPat  pat)              = collectl pat bndrs
 398
 399     go (ListPat pats _)           = foldr collectl bndrs pats
 400     go (PArrPat pats _)           = foldr collectl bndrs pats
 401     go (TuplePat pats _)          = foldr collectl bndrs pats
 402
 403     go (ConPatIn c ps)            = foldr collectl bndrs (hsConArgs ps)
 404     go (ConPatOut c _ ds bs ps _) = map noLoc ds
 405                                     ++ collectHsBindLocatedBinders bs
 406                                     ++ foldr collectl bndrs (hsConArgs ps)
 407     go (LitPat _)                 = bndrs
 408     go (NPat _ _ _ _)             = bndrs
 409     go (NPlusKPat n _ _ _)        = n : bndrs
 410
 411     go (SigPatIn pat _)           = collectl pat bndrs
 412     go (SigPatOut pat _)          = collectl pat bndrs
 413     go (TypePat ty)               = bndrs
 414     go (DictPat ids1 ids2)        = map noLoc ids1 ++ map noLoc ids2
 415                                     ++ bndrs
 416 \end{code}
 417
 418 \begin{code}
 419 collectSigTysFromPats :: [InPat name] -> [LHsType name]
 420 collectSigTysFromPats pats = foldr collect_lpat [] pats
 421
 422 collectSigTysFromPat :: InPat name -> [LHsType name]
 423 collectSigTysFromPat pat = collect_lpat pat []
 424
 425 collect_lpat pat acc = collect_pat (unLoc pat) acc
 426
 427 collect_pat (SigPatIn pat ty)  acc = collect_lpat pat (ty:acc)
 428 collect_pat (TypePat ty)       acc = ty:acc
 429
 430 collect_pat (LazyPat pat)      acc = collect_lpat pat acc
 431 collect_pat (AsPat a pat)      acc = collect_lpat pat acc
 432 collect_pat (ParPat  pat)      acc = collect_lpat pat acc
 433 collect_pat (ListPat pats _)   acc = foldr collect_lpat acc pats
 434 collect_pat (PArrPat pats _)   acc = foldr collect_lpat acc pats
 435 collect_pat (TuplePat pats _)  acc = foldr collect_lpat acc pats
 436 collect_pat (ConPatIn c ps)    acc = foldr collect_lpat acc (hsConArgs ps)
 437 collect_pat other              acc = acc        -- Literals, vars, wildcard
 438 \end{code}