HsUtils.hs 45.2 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2
{-
(c) The University of Glasgow, 1992-2006
3

4

5 6
Here we collect a variety of helper functions that construct or
analyse HsSyn.  All these functions deal with generic HsSyn; functions
7
which deal with the instantiated versions are located elsewhere:
8

9
   Parameterised by     Module
10
   ----------------     -------------
11 12 13
   RdrName              parser/RdrHsSyn
   Name                 rename/RnHsSyn
   Id                   typecheck/TcHsSyn
Austin Seipp's avatar
Austin Seipp committed
14
-}
15

16
{-# LANGUAGE CPP #-}
17 18
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
19
{-# LANGUAGE TypeFamilies #-}
Ian Lynagh's avatar
Ian Lynagh committed
20

21 22
module HsUtils(
  -- Terms
23
  mkHsPar, mkHsApp, mkHsAppType, mkHsAppTypeOut, mkHsConApp, mkSimpleHsAlt,
24 25
  mkSimpleMatch, unguardedGRHSs, unguardedRHS,
  mkMatchGroup, mkMatchGroupName, mkMatch, mkHsLam, mkHsIf,
26
  mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,
27
  mkHsDictLet, mkHsLams,
28
  mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo,
29
  mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap,
30

31 32
  nlHsTyApp, nlHsTyApps, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsSyntaxApps,
  nlHsIntLit, nlHsVarApps,
33
  nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
34
  mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
35
  toLHsSigWcType,
36

Simon Marlow's avatar
Simon Marlow committed
37 38 39 40
  -- * Constructing general big tuples
  -- $big_tuples
  mkChunkified, chunkify,

41
  -- Bindings
Simon Marlow's avatar
Simon Marlow committed
42 43
  mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind,
  mkPatSynBind,
44
  isInfixFunBind,
45 46

  -- Literals
47
  mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringPrimLit,
48 49

  -- Patterns
Adam Gundry's avatar
Adam Gundry committed
50
  mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat,
51 52
  nlConPatName, nlInfixConPat, nlNullaryConPat, nlWildConPat, nlWildPat,
  nlWildPatName, nlWildPatId, nlTuplePat, mkParPat,
Simon Marlow's avatar
Simon Marlow committed
53
  mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup,
54 55

  -- Types
56
  mkHsAppTy, mkHsAppTys, userHsTyVarBndrs, userHsLTyVarBndrs,
57
  mkLHsSigType, mkLHsSigWcType, mkClassOpSigs,
58
  nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp,
59 60

  -- Stmts
61 62
  mkTransformStmt, mkTransformByStmt, mkBodyStmt, mkBindStmt, mkTcBindStmt,
  mkLastStmt,
63 64
  emptyTransStmt, mkGroupUsingStmt, mkGroupByUsingStmt,
  emptyRecStmt, emptyRecStmtName, emptyRecStmtId, mkRecStmt,
65 66

  -- Template Haskell
67
  mkHsSpliceTy, mkHsSpliceE, mkHsSpliceTE, mkUntypedSplice,
68
  mkHsQuasiQuote, unqualQuasiQuote,
69 70

  -- Flags
71
  noRebindableInfo,
72 73

  -- Collecting binders
74
  collectLocalBinders, collectHsValBinders, collectHsBindListBinders,
75
  collectHsIdBinders,
76 77 78 79
  collectHsBindsBinders, collectHsBindBinders, collectMethodBinders,
  collectPatBinders, collectPatsBinders,
  collectLStmtsBinders, collectStmtsBinders,
  collectLStmtBinders, collectStmtBinders,
80

81
  hsLTyClDeclBinders, hsTyClForeignBinders, hsPatSynSelectors,
82
  hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,
83
  hsDataDefnBinders,
84

85 86
  -- Collecting implicit binders
  lStmtsImplicits, hsValBindsImplicits, lPatImplicits
87
  ) where
88

89 90
#include "HsVersions.h"

91
import HsDecls
92 93 94
import HsBinds
import HsExpr
import HsPat
95
import HsTypes
96
import HsLit
97
import PlaceHolder
98

99
import TcEvidence
100 101
import RdrName
import Var
102 103
import TyCoRep
import Type   ( filterOutInvisibleTypes )
104
import TysWiredIn ( unitTy )
105
import TcType
106 107
import DataCon
import Name
108
import NameSet
109
import BasicTypes
110
import SrcLoc
111 112
import FastString
import Util
113
import Bag
114
import Outputable
Simon Marlow's avatar
Simon Marlow committed
115
import Constants
116

117
import Data.Either
118 119
import Data.Function
import Data.List
120

Austin Seipp's avatar
Austin Seipp committed
121 122 123
{-
************************************************************************
*                                                                      *
124
        Some useful helpers for constructing syntax
Austin Seipp's avatar
Austin Seipp committed
125 126
*                                                                      *
************************************************************************
127

128 129 130
These functions attempt to construct a not-completely-useless SrcSpan
from their components, compared with the nl* functions below which
just attach noSrcSpan to everything.
Austin Seipp's avatar
Austin Seipp committed
131
-}
132 133 134 135

mkHsPar :: LHsExpr id -> LHsExpr id
mkHsPar e = L (getLoc e) (HsPar e)

136
mkSimpleMatch :: [LPat id] -> Located (body id) -> LMatch id (Located (body id))
137
mkSimpleMatch pats rhs
138
  = L loc $
139
    Match NonFunBindMatch pats Nothing (unguardedGRHSs rhs)
140 141
  where
    loc = case pats of
142 143
                []      -> getLoc rhs
                (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs)
144

145
unguardedGRHSs :: Located (body id) -> GRHSs id (Located (body id))
146 147
unguardedGRHSs rhs@(L loc _)
  = GRHSs (unguardedRHS loc rhs) (noLoc emptyLocalBinds)
148

Alan Zimmerman's avatar
Alan Zimmerman committed
149 150
unguardedRHS :: SrcSpan -> Located (body id) -> [LGRHS id (Located (body id))]
unguardedRHS loc rhs = [L loc (GRHS [] rhs)]
151

152 153
mkMatchGroup :: Origin -> [LMatch RdrName (Located (body RdrName))]
             -> MatchGroup RdrName (Located (body RdrName))
154 155
mkMatchGroup origin matches = MG { mg_alts = mkLocatedList matches
                                 , mg_arg_tys = []
156 157 158
                                 , mg_res_ty = placeHolderType
                                 , mg_origin = origin }

159 160 161 162
mkLocatedList ::  [Located a] -> Located [Located a]
mkLocatedList [] = noLoc []
mkLocatedList ms = L (combineLocs (head ms) (last ms)) ms

163 164
mkMatchGroupName :: Origin -> [LMatch Name (Located (body Name))]
             -> MatchGroup Name (Located (body Name))
165 166
mkMatchGroupName origin matches = MG { mg_alts = mkLocatedList matches
                                     , mg_arg_tys = []
167 168
                                     , mg_res_ty = placeHolderType
                                     , mg_origin = origin }
169

170 171 172
mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)

173 174 175 176 177 178
mkHsAppType :: LHsExpr name -> LHsWcType name -> LHsExpr name
mkHsAppType e t = addCLoc e (hswc_body t) (HsAppType e t)

mkHsAppTypeOut :: LHsExpr Id -> LHsWcType Name -> LHsExpr Id
mkHsAppTypeOut e t = addCLoc e (hswc_body t) (HsAppTypeOut e t)

179
mkHsLam :: [LPat RdrName] -> LHsExpr RdrName -> LHsExpr RdrName
180
mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
181
        where
182
          matches = mkMatchGroup Generated [mkSimpleMatch pats body]
183 184

mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr Id -> LHsExpr Id
185 186
mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars
                                       <.> mkWpLams dicts) expr
187 188

mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
189 190
-- Used for constructing dictionary terms etc, so no locations
mkHsConApp data_con tys args
191 192 193 194
  = foldl mk_app (nlHsTyApp (dataConWrapId data_con) tys) args
  where
    mk_app f a = noLoc (HsApp f (noLoc a))

195
mkSimpleHsAlt :: LPat id -> (Located (body id)) -> LMatch id (Located (body id))
196
-- A simple lambda with a single pattern, no binds, no guards; pre-typechecking
197
mkSimpleHsAlt pat expr
198 199
  = mkSimpleMatch [pat] expr

200
nlHsTyApp :: name -> [Type] -> LHsExpr name
201
nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar (noLoc fun_id)))
202

203 204 205
nlHsTyApps :: name -> [Type] -> [LHsExpr name] -> LHsExpr name
nlHsTyApps fun_id tys xs = foldl nlHsApp (nlHsTyApp fun_id tys) xs

206 207 208 209 210 211 212 213 214 215 216
--------- Adding parens ---------
mkLHsPar :: LHsExpr name -> LHsExpr name
-- Wrap in parens if hsExprNeedsParens says it needs them
-- So   'f x'  becomes '(f x)', but '3' stays as '3'
mkLHsPar le@(L loc e) | hsExprNeedsParens e = L loc (HsPar le)
                      | otherwise           = le

mkParPat :: LPat name -> LPat name
mkParPat lp@(L loc p) | hsPatNeedsParens p = L loc (ParPat lp)
                      | otherwise          = lp

217

218
-------------------------------
219 220 221
-- These are the bits of syntax that contain rebindable names
-- See RnEnv.lookupSyntaxName

222
mkHsIntegral   :: String -> Integer -> PostTc RdrName Type -> HsOverLit RdrName
223
mkHsFractional :: FractionalLit -> PostTc RdrName Type -> HsOverLit RdrName
224
mkHsIsString :: String -> FastString -> PostTc RdrName Type -> HsOverLit RdrName
225 226 227
mkHsDo         :: HsStmtContext Name -> [ExprLStmt RdrName] -> HsExpr RdrName
mkHsComp       :: HsStmtContext Name -> [ExprLStmt RdrName] -> LHsExpr RdrName
               -> HsExpr RdrName
twanvl's avatar
twanvl committed
228

229 230
mkNPat      :: Located (HsOverLit RdrName) -> Maybe (SyntaxExpr RdrName) -> Pat RdrName
mkNPlusKPat :: Located RdrName -> Located (HsOverLit RdrName) -> Pat RdrName
twanvl's avatar
twanvl committed
231

232
mkLastStmt :: Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR))
233 234
mkBodyStmt :: Located (bodyR RdrName)
           -> StmtLR idL RdrName (Located (bodyR RdrName))
235 236 237 238
mkBindStmt :: (PostTc idR Type ~ PlaceHolder)
           => LPat idL -> Located (bodyR idR)
           -> StmtLR idL idR (Located (bodyR idR))
mkTcBindStmt :: LPat Id -> Located (bodyR Id) -> StmtLR Id Id (Located (bodyR Id))
239

240 241 242 243
emptyRecStmt     :: StmtLR idL  RdrName bodyR
emptyRecStmtName :: StmtLR Name Name    bodyR
emptyRecStmtId   :: StmtLR Id   Id      bodyR
mkRecStmt    :: [LStmtLR idL RdrName bodyR] -> StmtLR idL RdrName bodyR
twanvl's avatar
twanvl committed
244 245


246 247 248
mkHsIntegral src i  = OverLit (HsIntegral   src i) noRebindableInfo noExpr
mkHsFractional   f  = OverLit (HsFractional     f) noRebindableInfo noExpr
mkHsIsString src s  = OverLit (HsIsString   src s) noRebindableInfo noExpr
249

250 251
noRebindableInfo :: PlaceHolder
noRebindableInfo = PlaceHolder -- Just another placeholder;
252

253
mkHsDo ctxt stmts = HsDo ctxt (mkLocatedList stmts) placeHolderType
254 255 256
mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt])
  where
    last_stmt = L (getLoc expr) $ mkLastStmt expr
257

258 259 260
mkHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> HsExpr id
mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b

261 262
mkNPat lit neg     = NPat lit neg noSyntaxExpr placeHolderType
mkNPlusKPat id lit = NPlusKPat id lit (unLoc lit) noSyntaxExpr noSyntaxExpr placeHolderType
263

264 265
mkTransformStmt    :: (PostTc idR Type ~ PlaceHolder)
                   => [ExprLStmt idL] -> LHsExpr idR
266
                   -> StmtLR idL idR (LHsExpr idL)
267 268
mkTransformByStmt  :: (PostTc idR Type ~ PlaceHolder)
                   => [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR
269
                   -> StmtLR idL idR (LHsExpr idL)
270 271
mkGroupUsingStmt   :: (PostTc idR Type ~ PlaceHolder)
                   => [ExprLStmt idL]                -> LHsExpr idR
272
                   -> StmtLR idL idR (LHsExpr idL)
273 274
mkGroupByUsingStmt :: (PostTc idR Type ~ PlaceHolder)
                   => [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR
275
                   -> StmtLR idL idR (LHsExpr idL)
276

277
emptyTransStmt :: (PostTc idR Type ~ PlaceHolder) => StmtLR idL idR (LHsExpr idR)
278
emptyTransStmt = TransStmt { trS_form = panic "emptyTransStmt: form"
279
                           , trS_stmts = [], trS_bndrs = []
280
                           , trS_by = Nothing, trS_using = noLoc noExpr
281
                           , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr
282 283
                           , trS_bind_arg_ty = PlaceHolder
                           , trS_fmap = noExpr }
284 285 286 287
mkTransformStmt    ss u   = emptyTransStmt { trS_form = ThenForm,  trS_stmts = ss, trS_using = u }
mkTransformByStmt  ss u b = emptyTransStmt { trS_form = ThenForm,  trS_stmts = ss, trS_using = u, trS_by = Just b }
mkGroupUsingStmt   ss u   = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u }
mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u, trS_by = Just b }
288

Simon Marlow's avatar
Simon Marlow committed
289
mkLastStmt body     = LastStmt body False noSyntaxExpr
290
mkBodyStmt body     = BodyStmt body noSyntaxExpr noSyntaxExpr placeHolderType
291 292 293
mkBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr PlaceHolder
mkTcBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr unitTy
  -- don't use placeHolderTypeTc above, because that panics during zonking
294

295 296 297 298 299 300 301 302
emptyRecStmt' :: forall idL idR body.
                       PostTc idR Type -> StmtLR idL idR body
emptyRecStmt' tyVal =
   RecStmt
     { recS_stmts = [], recS_later_ids = []
     , recS_rec_ids = []
     , recS_ret_fn = noSyntaxExpr
     , recS_mfix_fn = noSyntaxExpr
303 304
     , recS_bind_fn = noSyntaxExpr, recS_bind_ty = tyVal
     , recS_later_rets = []
305 306 307 308
     , recS_rec_rets = [], recS_ret_ty = tyVal }

emptyRecStmt     = emptyRecStmt' placeHolderType
emptyRecStmtName = emptyRecStmt' placeHolderType
309
emptyRecStmtId   = emptyRecStmt' unitTy -- a panic might trigger during zonking
310
mkRecStmt stmts  = emptyRecStmt { recS_stmts = stmts }
311 312

-------------------------------
313 314
--- A useful function for building @OpApps@.  The operator is always a
-- variable, and we don't know the fixity yet.
twanvl's avatar
twanvl committed
315
mkHsOpApp :: LHsExpr id -> id -> LHsExpr id -> HsExpr id
316 317
mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar (noLoc op)))
                           (error "mkOpApp:fixity") e2
318

319 320 321
unqualSplice :: RdrName
unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))

322 323 324
mkUntypedSplice :: LHsExpr RdrName -> HsSplice RdrName
mkUntypedSplice e = HsUntypedSplice unqualSplice e

325
mkHsSpliceE :: LHsExpr RdrName -> HsExpr RdrName
326
mkHsSpliceE e = HsSpliceE (mkUntypedSplice e)
327 328

mkHsSpliceTE :: LHsExpr RdrName -> HsExpr RdrName
329
mkHsSpliceTE e = HsSpliceE (HsTypedSplice unqualSplice e)
330

331
mkHsSpliceTy :: LHsExpr RdrName -> HsType RdrName
332
mkHsSpliceTy e = HsSpliceTy (HsUntypedSplice unqualSplice e) placeHolderKind
333

334 335
mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice RdrName
mkHsQuasiQuote quoter span quote = HsQuasiQuote unqualSplice quoter span quote
336

twanvl's avatar
twanvl committed
337
unqualQuasiQuote :: RdrName
Ian Lynagh's avatar
Ian Lynagh committed
338
unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
339 340
                -- A name (uniquified later) to
                -- identify the quasi-quote
341

twanvl's avatar
twanvl committed
342
mkHsString :: String -> HsLit
343
mkHsString s = HsString s (mkFastString s)
344

345 346 347 348
mkHsStringPrimLit :: FastString -> HsLit
mkHsStringPrimLit fs
  = HsStringPrim (unpackFS fs) (fastStringToByteString fs)

349
-------------
350 351 352 353 354
userHsLTyVarBndrs :: SrcSpan -> [Located name] -> [LHsTyVarBndr name]
-- Caller sets location
userHsLTyVarBndrs loc bndrs = [ L loc (UserTyVar v) | v <- bndrs ]

userHsTyVarBndrs :: SrcSpan -> [name] -> [LHsTyVarBndr name]
355
-- Caller sets location
356
userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar (L loc v)) | v <- bndrs ]
357

358

Austin Seipp's avatar
Austin Seipp committed
359 360 361
{-
************************************************************************
*                                                                      *
362
        Constructing syntax with no location info
Austin Seipp's avatar
Austin Seipp committed
363 364 365
*                                                                      *
************************************************************************
-}
366 367

nlHsVar :: id -> LHsExpr id
368
nlHsVar n = noLoc (HsVar (noLoc n))
369 370 371 372 373

nlHsLit :: HsLit -> LHsExpr id
nlHsLit n = noLoc (HsLit n)

nlVarPat :: id -> LPat id
374
nlVarPat n = noLoc (VarPat (noLoc n))
375 376 377 378 379 380 381

nlLitPat :: HsLit -> LPat id
nlLitPat l = noLoc (LitPat l)

nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
nlHsApp f x = noLoc (HsApp f x)

382 383 384 385 386 387 388 389 390 391 392 393
nlHsSyntaxApps :: SyntaxExpr id -> [LHsExpr id] -> LHsExpr id
nlHsSyntaxApps (SyntaxExpr { syn_expr      = fun
                           , syn_arg_wraps = arg_wraps
                           , syn_res_wrap  = res_wrap }) args
  | [] <- arg_wraps   -- in the noSyntaxExpr case
  = ASSERT( isIdHsWrapper res_wrap )
    foldl nlHsApp (noLoc fun) args

  | otherwise
  = mkLHsWrap res_wrap (foldl nlHsApp (noLoc fun) (zipWithEqual "nlHsSyntaxApps"
                                                     mkLHsWrap arg_wraps args))

twanvl's avatar
twanvl committed
394
nlHsIntLit :: Integer -> LHsExpr id
395
nlHsIntLit n = noLoc (HsLit (HsInt (show n) n))
396 397 398

nlHsApps :: id -> [LHsExpr id] -> LHsExpr id
nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
399

400
nlHsVarApps :: id -> [id] -> LHsExpr id
401
nlHsVarApps f xs = noLoc (foldl mk (HsVar (noLoc f)) (map (HsVar . noLoc) xs))
402 403
                 where
                   mk f a = HsApp (noLoc f) (noLoc a)
404

405
nlConVarPat :: RdrName -> [RdrName] -> LPat RdrName
406 407
nlConVarPat con vars = nlConPat con (map nlVarPat vars)

Adam Gundry's avatar
Adam Gundry committed
408 409 410
nlConVarPatName :: Name -> [Name] -> LPat Name
nlConVarPatName con vars = nlConPatName con (map nlVarPat vars)

411 412 413
nlInfixConPat :: id -> LPat id -> LPat id -> LPat id
nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))

414
nlConPat :: RdrName -> [LPat RdrName] -> LPat RdrName
415 416
nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))

417 418 419
nlConPatName :: Name -> [LPat Name] -> LPat Name
nlConPatName con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))

420 421 422 423 424
nlNullaryConPat :: id -> LPat id
nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))

nlWildConPat :: DataCon -> LPat RdrName
nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
425 426
                         (PrefixCon (nOfThem (dataConSourceArity con)
                                             nlWildPat)))
427

428 429
nlWildPat :: LPat RdrName
nlWildPat  = noLoc (WildPat placeHolderType )  -- Pre-typechecking
430

431 432 433 434 435 436 437 438
nlWildPatName :: LPat Name
nlWildPatName  = noLoc (WildPat placeHolderType )  -- Pre-typechecking

nlWildPatId :: LPat Id
nlWildPatId  = noLoc (WildPat placeHolderTypeTc )  -- Post-typechecking

nlHsDo :: HsStmtContext Name -> [LStmt RdrName (LHsExpr RdrName)]
       -> LHsExpr RdrName
439
nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)
440

twanvl's avatar
twanvl committed
441
nlHsOpApp :: LHsExpr id -> id -> LHsExpr id -> LHsExpr id
442 443
nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)

444
nlHsLam  :: LMatch RdrName (LHsExpr RdrName) -> LHsExpr RdrName
twanvl's avatar
twanvl committed
445 446
nlHsPar  :: LHsExpr id -> LHsExpr id
nlHsIf   :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id
447 448 449
nlHsCase :: LHsExpr RdrName -> [LMatch RdrName (LHsExpr RdrName)]
         -> LHsExpr RdrName
nlList   :: [LHsExpr RdrName] -> LHsExpr RdrName
twanvl's avatar
twanvl committed
450

451
nlHsLam match          = noLoc (HsLam (mkMatchGroup Generated [match]))
452 453 454 455
nlHsPar e              = noLoc (HsPar e)
nlHsIf cond true false = noLoc (mkHsIf cond true false)
nlHsCase expr matches  = noLoc (HsCase expr (mkMatchGroup Generated matches))
nlList exprs           = noLoc (ExplicitList placeHolderType Nothing exprs)
456

twanvl's avatar
twanvl committed
457 458 459 460
nlHsAppTy :: LHsType name -> LHsType name -> LHsType name
nlHsTyVar :: name                         -> LHsType name
nlHsFunTy :: LHsType name -> LHsType name -> LHsType name

461
nlHsAppTy f t           = noLoc (HsAppTy f t)
462
nlHsTyVar x             = noLoc (HsTyVar (noLoc x))
463
nlHsFunTy a b           = noLoc (HsFunTy a b)
464

twanvl's avatar
twanvl committed
465
nlHsTyConApp :: name -> [LHsType name] -> LHsType name
466
nlHsTyConApp tycon tys  = foldl nlHsAppTy (nlHsTyVar tycon) tys
467

Austin Seipp's avatar
Austin Seipp committed
468
{-
469 470
Tuples.  All these functions are *pre-typechecker* because they lack
types on the tuple.
Austin Seipp's avatar
Austin Seipp committed
471
-}
472 473 474 475

mkLHsTupleExpr :: [LHsExpr a] -> LHsExpr a
-- Makes a pre-typechecker boxed tuple, deals with 1 case
mkLHsTupleExpr [e] = e
476
mkLHsTupleExpr es  = noLoc $ ExplicitTuple (map (noLoc . Present) es) Boxed
477 478 479

mkLHsVarTuple :: [a] -> LHsExpr a
mkLHsVarTuple ids  = mkLHsTupleExpr (map nlHsVar ids)
480

481
nlTuplePat :: [LPat id] -> Boxity -> LPat id
482
nlTuplePat pats box = noLoc (TuplePat pats box [])
483

484
missingTupArg :: HsTupArg RdrName
485
missingTupArg = Missing placeHolderType
486

Simon Marlow's avatar
Simon Marlow committed
487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546
mkLHsPatTup :: [LPat id] -> LPat id
mkLHsPatTup []     = noLoc $ TuplePat [] Boxed []
mkLHsPatTup [lpat] = lpat
mkLHsPatTup lpats  = L (getLoc (head lpats)) $ TuplePat lpats Boxed []

-- The Big equivalents for the source tuple expressions
mkBigLHsVarTup :: [id] -> LHsExpr id
mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids)

mkBigLHsTup :: [LHsExpr id] -> LHsExpr id
mkBigLHsTup = mkChunkified mkLHsTupleExpr

-- The Big equivalents for the source tuple patterns
mkBigLHsVarPatTup :: [id] -> LPat id
mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs)

mkBigLHsPatTup :: [LPat id] -> LPat id
mkBigLHsPatTup = mkChunkified mkLHsPatTup

-- $big_tuples
-- #big_tuples#
--
-- GHCs built in tuples can only go up to 'mAX_TUPLE_SIZE' in arity, but
-- we might concievably want to build such a massive tuple as part of the
-- output of a desugaring stage (notably that for list comprehensions).
--
-- We call tuples above this size \"big tuples\", and emulate them by
-- creating and pattern matching on >nested< tuples that are expressible
-- by GHC.
--
-- Nesting policy: it's better to have a 2-tuple of 10-tuples (3 objects)
-- than a 10-tuple of 2-tuples (11 objects), so we want the leaves of any
-- construction to be big.
--
-- If you just use the 'mkBigCoreTup', 'mkBigCoreVarTupTy', 'mkTupleSelector'
-- and 'mkTupleCase' functions to do all your work with tuples you should be
-- fine, and not have to worry about the arity limitation at all.

-- | Lifts a \"small\" constructor into a \"big\" constructor by recursive decompositon
mkChunkified :: ([a] -> a)      -- ^ \"Small\" constructor function, of maximum input arity 'mAX_TUPLE_SIZE'
             -> [a]             -- ^ Possible \"big\" list of things to construct from
             -> a               -- ^ Constructed thing made possible by recursive decomposition
mkChunkified small_tuple as = mk_big_tuple (chunkify as)
  where
        -- Each sub-list is short enough to fit in a tuple
    mk_big_tuple [as] = small_tuple as
    mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s))

chunkify :: [a] -> [[a]]
-- ^ Split a list into lists that are small enough to have a corresponding
-- tuple arity. The sub-lists of the result all have length <= 'mAX_TUPLE_SIZE'
-- But there may be more than 'mAX_TUPLE_SIZE' sub-lists
chunkify xs
  | n_xs <= mAX_TUPLE_SIZE = [xs]
  | otherwise              = split xs
  where
    n_xs     = length xs
    split [] = []
    split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs)

Austin Seipp's avatar
Austin Seipp committed
547 548 549
{-
************************************************************************
*                                                                      *
550
        LHsSigType and LHsSigWcType
Austin Seipp's avatar
Austin Seipp committed
551
*                                                                      *
552
********************************************************************* -}
553

554 555
mkLHsSigType :: LHsType RdrName -> LHsSigType RdrName
mkLHsSigType ty = mkHsImplicitBndrs ty
556

557 558
mkLHsSigWcType :: LHsType RdrName -> LHsSigWcType RdrName
mkLHsSigWcType ty = mkHsImplicitBndrs (mkHsWildCardBndrs ty)
559

560 561 562 563 564 565
mkClassOpSigs :: [LSig RdrName] -> [LSig RdrName]
-- Convert TypeSig to ClassOpSig
-- The former is what is parsed, but the latter is
-- what we need in class/instance declarations
mkClassOpSigs sigs
  = map fiddle sigs
566
  where
567 568
    fiddle (L loc (TypeSig nms ty)) = L loc (ClassOpSig False nms (dropWildCards ty))
    fiddle sig                      = sig
569

570 571 572 573 574 575 576 577 578 579
toLHsSigWcType :: Type -> LHsSigWcType RdrName
-- ^ Converting a Type to an HsType RdrName
-- This is needed to implement GeneralizedNewtypeDeriving.
--
-- Note that we use 'getRdrName' extensively, which
-- generates Exact RdrNames rather than strings.
toLHsSigWcType ty
  = mkLHsSigWcType (go ty)
  where
    go :: Type -> LHsType RdrName
580
    go ty@(ForAllTy (Anon arg) _)
581 582 583 584
      | isPredTy arg
      , (theta, tau) <- tcSplitPhiTy ty
      = noLoc (HsQualTy { hst_ctxt = noLoc (map go theta)
                        , hst_body = go tau })
585 586 587 588 589
    go (ForAllTy (Anon arg) res) = nlHsFunTy (go arg) (go res)
    go ty@(ForAllTy {})
      | (tvs, tau) <- tcSplitForAllTys ty
      = noLoc (HsForAllTy { hst_bndrs = map go_tv tvs
                          , hst_body = go tau })
590 591 592 593 594
    go (TyVarTy tv)         = nlHsTyVar (getRdrName tv)
    go (AppTy t1 t2)        = nlHsAppTy (go t1) (go t2)
    go (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy "" n)
    go (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy "" s)
    go (TyConApp tc args)   = nlHsTyConApp (getRdrName tc) (map go args')
595
       where
596 597 598 599 600
         args' = filterOutInvisibleTypes tc args
    go (CastTy ty _)        = go ty
    go (CoercionTy co)      = pprPanic "toLHsSigWcType" (ppr co)

         -- Source-language types have _invisible_ kind arguments,
Simon Peyton Jones's avatar
Simon Peyton Jones committed
601
         -- so we must remove them here (Trac #8563)
602

603 604 605
    go_tv :: TyVar -> LHsTyVarBndr RdrName
    go_tv tv = noLoc $ KindedTyVar (noLoc (getRdrName tv))
                                   (go (tyVarKind tv))
606 607


608 609 610 611 612 613
{- *********************************************************************
*                                                                      *
    --------- HsWrappers: type args, dict args, casts ---------
*                                                                      *
********************************************************************* -}

614 615 616 617 618
mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id
mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)

mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id
mkHsWrap co_fn e | isIdHsWrapper co_fn = e
619
                 | otherwise           = HsWrap co_fn e
620

621
mkHsWrapCo :: TcCoercionN   -- A Nominal coercion  a ~N b
622
           -> HsExpr id -> HsExpr id
623
mkHsWrapCo co e = mkHsWrap (mkWpCastN co) e
624

625
mkHsWrapCoR :: TcCoercionR   -- A Representational coercion  a ~R b
626
            -> HsExpr id -> HsExpr id
627
mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e
628

629
mkLHsWrapCo :: TcCoercionN -> LHsExpr id -> LHsExpr id
Joachim Breitner's avatar
Joachim Breitner committed
630
mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e)
631

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
632 633 634 635 636 637
mkHsCmdWrap :: HsWrapper -> HsCmd id -> HsCmd id
mkHsCmdWrap w cmd | isIdHsWrapper w = cmd
                  | otherwise       = HsCmdWrap w cmd

mkLHsCmdWrap :: HsWrapper -> LHsCmd id -> LHsCmd id
mkLHsCmdWrap w (L loc c) = L loc (mkHsCmdWrap w c)
638

639 640
mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id
mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
641
                       | otherwise           = CoPat co_fn p ty
642

643
mkHsWrapPatCo :: TcCoercionN -> Pat id -> Type -> Pat id
644
mkHsWrapPatCo co pat ty | isTcReflCo co = pat
645
                        | otherwise     = CoPat (mkWpCastN co) pat ty
646 647 648

mkHsDictLet :: TcEvBinds -> LHsExpr Id -> LHsExpr Id
mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr
Austin Seipp's avatar
Austin Seipp committed
649 650

{-
651
l
Austin Seipp's avatar
Austin Seipp committed
652 653
************************************************************************
*                                                                      *
654
                Bindings; with a location at the top
Austin Seipp's avatar
Austin Seipp committed
655 656 657
*                                                                      *
************************************************************************
-}
658

659 660
mkFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)]
          -> HsBind RdrName
661
-- Not infix, with place holders for coercion and free vars
662
mkFunBind fn ms = FunBind { fun_id = fn
663 664
                          , fun_matches = mkMatchGroup Generated ms
                          , fun_co_fn = idHsWrapper
665
                          , bind_fvs = placeHolderNames
666
                          , fun_tick = [] }
667

668 669
mkTopFunBind :: Origin -> Located Name -> [LMatch Name (LHsExpr Name)]
             -> HsBind Name
670
-- In Name-land, with empty bind_fvs
671
mkTopFunBind origin fn ms = FunBind { fun_id = fn
672
                                    , fun_matches = mkMatchGroupName origin ms
673
                                    , fun_co_fn = idHsWrapper
674 675
                                    , bind_fvs = emptyNameSet -- NB: closed
                                                              --     binding
676
                                    , fun_tick = [] }
677

678
mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
679 680 681 682
mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs

mkVarBind :: id -> LHsExpr id -> LHsBind id
mkVarBind var rhs = L (getLoc rhs) $
683
                    VarBind { var_id = var, var_rhs = rhs, var_inline = False }
684

685 686
mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName)
             -> LPat RdrName -> HsPatSynDir RdrName -> HsBind RdrName
687 688 689 690 691 692 693
mkPatSynBind name details lpat dir = PatSynBind psb
  where
    psb = PSB{ psb_id = name
             , psb_args = details
             , psb_def = lpat
             , psb_dir = dir
             , psb_fvs = placeHolderNames }
cactus's avatar
cactus committed
694

695 696 697 698
-- |If any of the matches in the 'FunBind' are infix, the 'FunBind' is
-- considered infix.
isInfixFunBind :: HsBindLR id1 id2 -> Bool
isInfixFunBind (FunBind _ (MG matches _ _ _) _ _ _)
699
  = any (isInfixMatch . unLoc) (unLoc matches)
700 701 702
isInfixFunBind _ = False


703
------------
704
mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
705
                -> LHsExpr RdrName -> LHsBind RdrName
706
mk_easy_FunBind loc fun pats expr
707
  = L loc $ mkFunBind (L loc fun) [mkMatch pats expr (noLoc emptyLocalBinds)]
708

709
------------
710 711 712
mkMatch :: [LPat id] -> LHsExpr id -> Located (HsLocalBinds id)
        -> LMatch id (LHsExpr id)
mkMatch pats expr lbinds
713
  = noLoc (Match NonFunBindMatch (map paren pats) Nothing
714
                 (GRHSs (unguardedRHS noSrcSpan expr) lbinds))
715
  where
716 717
    paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp)
                     | otherwise          = lp
718

Austin Seipp's avatar
Austin Seipp committed
719 720 721
{-
************************************************************************
*                                                                      *
722
        Collecting binders
Austin Seipp's avatar
Austin Seipp committed
723 724
*                                                                      *
************************************************************************
725 726 727 728 729 730 731 732 733 734 735

Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg.

...
where
  (x, y) = ...
  f i j  = ...
  [a, b] = ...

it should return [x, y, f, a, b] (remember, order important).

736 737 738
Note [Collect binders only after renaming]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
These functions should only be used on HsSyn *after* the renamer,
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
739
to return a [Name] or [Id].  Before renaming the record punning
740 741
and wild-card mechanism makes it hard to know what is bound.
So these functions should not be applied to (HsSyn RdrName)
Austin Seipp's avatar
Austin Seipp committed
742
-}
743 744 745

----------------- Bindings --------------------------
collectLocalBinders :: HsLocalBindsLR idL idR -> [idL]
746 747 748 749
collectLocalBinders (HsValBinds binds) = collectHsIdBinders binds
                                         -- No pattern synonyms here
collectLocalBinders (HsIPBinds _)      = []
collectLocalBinders EmptyLocalBinds    = []
750

751 752 753 754
collectHsIdBinders, collectHsValBinders :: HsValBindsLR idL idR -> [idL]
-- Collect Id binders only, or Ids + pattern synonmys, respectively
collectHsIdBinders  = collect_hs_val_binders True
collectHsValBinders = collect_hs_val_binders False
755 756

collectHsBindBinders :: HsBindLR idL idR -> [idL]
757 758
-- Collect both Ids and pattern-synonym binders
collectHsBindBinders b = collect_bind False b []
759

760
collectHsBindsBinders :: LHsBindsLR idL idR -> [idL]
761
collectHsBindsBinders binds = collect_binds False binds []
762

763
collectHsBindListBinders :: [LHsBindLR idL idR] -> [idL]
764 765 766 767 768 769 770 771 772 773 774
-- Same as collectHsBindsBinders, but works over a list of bindings
collectHsBindListBinders = foldr (collect_bind False . unLoc) []

collect_hs_val_binders :: Bool -> HsValBindsLR idL idR -> [idL]
collect_hs_val_binders ps (ValBindsIn  binds _) = collect_binds     ps binds []
collect_hs_val_binders ps (ValBindsOut binds _) = collect_out_binds ps binds

collect_out_binds :: Bool -> [(RecFlag, LHsBinds id)] -> [id]
collect_out_binds ps = foldr (collect_binds ps . snd) []

collect_binds :: Bool -> LHsBindsLR idL idR -> [idL] -> [idL]
Simon Peyton Jones's avatar
Simon Peyton Jones committed
775
-- Collect Ids, or Ids + pattern synonyms, depending on boolean flag
776 777 778 779 780 781 782 783 784 785
collect_binds ps binds acc = foldrBag (collect_bind ps . unLoc) acc binds

collect_bind :: Bool -> HsBindLR idL idR -> [idL] -> [idL]
collect_bind _ (PatBind { pat_lhs = p })           acc = collect_lpat p acc
collect_bind _ (FunBind { fun_id = L _ f })        acc = f : acc
collect_bind _ (VarBind { var_id = f })            acc = f : acc
collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc
        -- I don't think we want the binders from the abe_binds
        -- The only time we collect binders from a typechecked
        -- binding (hence see AbsBinds) is in zonking in TcHsSyn
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
786
collect_bind _ (AbsBindsSig { abs_sig_export = poly }) acc = poly : acc
787 788 789
collect_bind omitPatSyn (PatSynBind (PSB { psb_id = L _ ps })) acc
  | omitPatSyn                  = acc
  | otherwise                   = ps : acc
790

791 792
collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName]
-- Used exclusively for the bindings of an instance decl which are all FunBinds
793
collectMethodBinders binds = foldrBag (get . unLoc) [] binds
794
  where
cactus's avatar
cactus committed
795
    get (FunBind { fun_id = f }) fs = f : fs
796
    get _                        fs = fs
797
       -- Someone else complains about non-FunBinds
798

799
----------------- Statements --------------------------
800
collectLStmtsBinders :: [LStmtLR idL idR body] -> [idL]
801
collectLStmtsBinders = concatMap collectLStmtBinders
802

803
collectStmtsBinders :: [StmtLR idL idR body] -> [idL]
804 805
collectStmtsBinders = concatMap collectStmtBinders

806
collectLStmtBinders :: LStmtLR idL idR body -> [idL]
807 808
collectLStmtBinders = collectStmtBinders . unLoc

809
collectStmtBinders :: StmtLR idL idR body -> [idL]
810
  -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
811
collectStmtBinders (BindStmt pat _ _ _ _)= collectPatBinders pat
812 813 814
collectStmtBinders (LetStmt (L _ binds)) = collectLocalBinders binds
collectStmtBinders (BodyStmt {})         = []
collectStmtBinders (LastStmt {})         = []
815
collectStmtBinders (ParStmt xs _ _ _) = collectLStmtsBinders
816
                                      $ [s | ParStmtBlock ss _ _ <- xs, s <- ss]
817 818
collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts
collectStmtBinders (RecStmt { recS_stmts = ss })     = collectLStmtsBinders ss
Simon Marlow's avatar
Simon Marlow committed
819
collectStmtBinders ApplicativeStmt{} = []
820 821


822
----------------- Patterns --------------------------
823
collectPatBinders :: LPat a -> [a]
824
collectPatBinders pat = collect_lpat pat []
825 826

collectPatsBinders :: [LPat a] -> [a]
827
collectPatsBinders pats = foldr collect_lpat [] pats
828

829 830 831
-------------
collect_lpat :: LPat name -> [name] -> [name]
collect_lpat (L _ pat) bndrs
832 833
  = go pat
  where
834
    go (VarPat (L _ var))         = var : bndrs