HsUtils.hs 50.1 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 10 11 12 13
   Parameterised by          Module
   ----------------          -------------
   GhcPs/RdrName             parser/RdrHsSyn
   GhcRn/Name                rename/RnHsSyn
   GhcTc/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, mkHsCaseAlt,
24
  mkSimpleMatch, unguardedGRHSs, unguardedRHS,
Ben Gamari's avatar
Ben Gamari committed
25
  mkMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf,
26
  mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,
27
  mkHsDictLet, mkHsLams,
28
  mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo,
29
  mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap,
30

Richard Eisenberg's avatar
Richard Eisenberg committed
31 32
  nlHsTyApp, nlHsTyApps, nlHsVar, nlHsDataCon,
  nlHsLit, nlHsApp, nlHsApps, nlHsSyntaxApps,
33
  nlHsIntLit, nlHsVarApps,
34
  nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
35
  mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
36
  typeToLHsType,
37

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

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

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

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

  -- Types
57
  mkHsAppTy, mkHsAppTys, userHsTyVarBndrs, userHsLTyVarBndrs,
58
  mkLHsSigType, mkLHsSigWcType, mkClassOpSigs, mkHsSigEnv,
Alan Zimmerman's avatar
Alan Zimmerman committed
59
  nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsParTy, nlHsTyConApp,
60 61

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

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

  -- Flags
72
  noRebindableInfo,
73 74

  -- Collecting binders
75
  isUnliftedHsBind, isBangedHsBind,
Richard Eisenberg's avatar
Richard Eisenberg committed
76

77
  collectLocalBinders, collectHsValBinders, collectHsBindListBinders,
78
  collectHsIdBinders,
79 80 81 82
  collectHsBindsBinders, collectHsBindBinders, collectMethodBinders,
  collectPatBinders, collectPatsBinders,
  collectLStmtsBinders, collectStmtsBinders,
  collectLStmtBinders, collectStmtBinders,
83

84 85
  hsLTyClDeclBinders, hsTyClForeignBinders,
  hsPatSynSelectors, getPatSynBinds,
86
  hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,
87
  hsDataDefnBinders,
88

89 90
  -- Collecting implicit binders
  lStmtsImplicits, hsValBindsImplicits, lPatImplicits
91
  ) where
92

93 94
#include "HsVersions.h"

95
import HsDecls
96 97 98
import HsBinds
import HsExpr
import HsPat
99
import HsTypes
100
import HsLit
101
import PlaceHolder
102
import HsExtension
103

104
import TcEvidence
105 106
import RdrName
import Var
107 108
import TyCoRep
import Type   ( filterOutInvisibleTypes )
109
import TysWiredIn ( unitTy )
110
import TcType
111
import DataCon
Richard Eisenberg's avatar
Richard Eisenberg committed
112 113
import ConLike
import Id
114
import Name
115
import NameSet
116
import NameEnv
117
import BasicTypes
118
import SrcLoc
119 120
import FastString
import Util
121
import Bag
122
import Outputable
Simon Marlow's avatar
Simon Marlow committed
123
import Constants
124

125
import Data.Either
126 127
import Data.Function
import Data.List
128

Austin Seipp's avatar
Austin Seipp committed
129 130 131
{-
************************************************************************
*                                                                      *
132
        Some useful helpers for constructing syntax
Austin Seipp's avatar
Austin Seipp committed
133 134
*                                                                      *
************************************************************************
135

136 137 138
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
139
-}
140 141 142 143

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

144
mkSimpleMatch :: HsMatchContext (NameOrRdrName (IdP id))
145 146 147
              -> [LPat id] -> Located (body id)
              -> LMatch id (Located (body id))
mkSimpleMatch ctxt pats rhs
148
  = L loc $
149 150
    Match { m_ctxt = ctxt, m_pats = pats, m_type = Nothing
          , m_grhss = unguardedGRHSs rhs }
151 152
  where
    loc = case pats of
153 154
                []      -> getLoc rhs
                (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs)
155

156
unguardedGRHSs :: Located (body id) -> GRHSs id (Located (body id))
157 158
unguardedGRHSs rhs@(L loc _)
  = GRHSs (unguardedRHS loc rhs) (noLoc emptyLocalBinds)
159

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

163 164 165
mkMatchGroup :: (PostTc name Type ~ PlaceHolder)
             => Origin -> [LMatch name (Located (body name))]
             -> MatchGroup name (Located (body name))
166 167
mkMatchGroup origin matches = MG { mg_alts = mkLocatedList matches
                                 , mg_arg_tys = []
168 169 170
                                 , mg_res_ty = placeHolderType
                                 , mg_origin = origin }

171 172 173 174
mkLocatedList ::  [Located a] -> Located [Located a]
mkLocatedList [] = noLoc []
mkLocatedList ms = L (combineLocs (head ms) (last ms)) ms

175 176 177
mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)

178 179 180
mkHsAppType :: LHsExpr name -> LHsWcType name -> LHsExpr name
mkHsAppType e t = addCLoc e (hswc_body t) (HsAppType e t)

181
mkHsAppTypeOut :: LHsExpr GhcTc -> LHsWcType GhcRn -> LHsExpr GhcTc
182 183
mkHsAppTypeOut e t = addCLoc e (hswc_body t) (HsAppTypeOut e t)

184
mkHsLam :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
185
mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
186 187 188
  where
    matches = mkMatchGroup Generated
                           [mkSimpleMatch LambdaExpr pats body]
189

190
mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc
191 192
mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars
                                       <.> mkWpLams dicts) expr
193

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

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

203
nlHsTyApps :: IdP name -> [Type] -> [LHsExpr name] -> LHsExpr name
204 205
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

Alan Zimmerman's avatar
Alan Zimmerman committed
217 218
nlParPat :: LPat name -> LPat name
nlParPat p = noLoc (ParPat p)
219

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

224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241
mkHsIntegral   :: IntegralLit -> PostTc GhcPs Type
               -> HsOverLit GhcPs
mkHsFractional :: FractionalLit -> PostTc GhcPs Type -> HsOverLit GhcPs
mkHsIsString :: SourceText -> FastString -> PostTc GhcPs Type
             -> HsOverLit GhcPs
mkHsDo         :: HsStmtContext Name -> [ExprLStmt GhcPs] -> HsExpr GhcPs
mkHsComp       :: HsStmtContext Name -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
               -> HsExpr GhcPs

mkNPat      :: Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs)
            -> Pat GhcPs
mkNPlusKPat :: Located RdrName -> Located (HsOverLit GhcPs) -> Pat GhcPs

mkLastStmt :: SourceTextX idR
           => Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR))
mkBodyStmt :: Located (bodyR GhcPs)
           -> StmtLR idL GhcPs (Located (bodyR GhcPs))
mkBindStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
242 243
           => LPat idL -> Located (bodyR idR)
           -> StmtLR idL idR (Located (bodyR idR))
244 245
mkTcBindStmt :: LPat GhcTc -> Located (bodyR GhcTc)
             -> StmtLR GhcTc GhcTc (Located (bodyR GhcTc))
246

247 248 249 250
emptyRecStmt     :: StmtLR idL  GhcPs bodyR
emptyRecStmtName :: StmtLR GhcRn GhcRn bodyR
emptyRecStmtId   :: StmtLR GhcTc GhcTc bodyR
mkRecStmt    :: [LStmtLR idL GhcPs bodyR] -> StmtLR idL GhcPs bodyR
twanvl's avatar
twanvl committed
251 252


253
mkHsIntegral     i  = OverLit (HsIntegral       i) noRebindableInfo noExpr
254 255
mkHsFractional   f  = OverLit (HsFractional     f) noRebindableInfo noExpr
mkHsIsString src s  = OverLit (HsIsString   src s) noRebindableInfo noExpr
256

257 258
noRebindableInfo :: PlaceHolder
noRebindableInfo = PlaceHolder -- Just another placeholder;
259

260
mkHsDo ctxt stmts = HsDo ctxt (mkLocatedList stmts) placeHolderType
261 262 263
mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt])
  where
    last_stmt = L (getLoc expr) $ mkLastStmt expr
264

265
mkHsIf :: SourceTextX p => LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
266 267
mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b

268 269
mkNPat lit neg     = NPat lit neg noSyntaxExpr placeHolderType
mkNPlusKPat id lit = NPlusKPat id lit (unLoc lit) noSyntaxExpr noSyntaxExpr placeHolderType
270

271
mkTransformStmt    :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
272
                   => [ExprLStmt idL] -> LHsExpr idR
273
                   -> StmtLR idL idR (LHsExpr idL)
274
mkTransformByStmt  :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
275
                   => [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR
276
                   -> StmtLR idL idR (LHsExpr idL)
277
mkGroupUsingStmt   :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
278
                   => [ExprLStmt idL]                -> LHsExpr idR
279
                   -> StmtLR idL idR (LHsExpr idL)
280
mkGroupByUsingStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
281
                   => [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR
282
                   -> StmtLR idL idR (LHsExpr idL)
283

284 285
emptyTransStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
               => StmtLR idL idR (LHsExpr idR)
286
emptyTransStmt = TransStmt { trS_form = panic "emptyTransStmt: form"
287
                           , trS_stmts = [], trS_bndrs = []
288
                           , trS_by = Nothing, trS_using = noLoc noExpr
289
                           , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr
290 291
                           , trS_bind_arg_ty = PlaceHolder
                           , trS_fmap = noExpr }
292 293 294 295
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 }
296

Simon Marlow's avatar
Simon Marlow committed
297
mkLastStmt body     = LastStmt body False noSyntaxExpr
298
mkBodyStmt body     = BodyStmt body noSyntaxExpr noSyntaxExpr placeHolderType
299 300 301
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
302

303
emptyRecStmt' :: forall idL idR body. SourceTextX idR =>
304 305 306 307 308 309 310
                       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
311 312
     , recS_bind_fn = noSyntaxExpr, recS_bind_ty = tyVal
     , recS_later_rets = []
313 314 315 316
     , recS_rec_rets = [], recS_ret_ty = tyVal }

emptyRecStmt     = emptyRecStmt' placeHolderType
emptyRecStmtName = emptyRecStmt' placeHolderType
317
emptyRecStmtId   = emptyRecStmt' unitTy -- a panic might trigger during zonking
318
mkRecStmt stmts  = emptyRecStmt { recS_stmts = stmts }
319 320

-------------------------------
321 322
--- A useful function for building @OpApps@.  The operator is always a
-- variable, and we don't know the fixity yet.
323
mkHsOpApp :: LHsExpr id -> IdP id -> LHsExpr id -> HsExpr id
324 325
mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar (noLoc op)))
                           (error "mkOpApp:fixity") e2
326

327 328 329
unqualSplice :: RdrName
unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))

330
mkUntypedSplice :: SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs
Alan Zimmerman's avatar
Alan Zimmerman committed
331
mkUntypedSplice hasParen e = HsUntypedSplice hasParen unqualSplice e
332

333
mkHsSpliceE :: SpliceDecoration -> LHsExpr GhcPs -> HsExpr GhcPs
Alan Zimmerman's avatar
Alan Zimmerman committed
334
mkHsSpliceE hasParen e = HsSpliceE (mkUntypedSplice hasParen e)
335

336
mkHsSpliceTE :: SpliceDecoration -> LHsExpr GhcPs -> HsExpr GhcPs
Alan Zimmerman's avatar
Alan Zimmerman committed
337
mkHsSpliceTE hasParen e = HsSpliceE (HsTypedSplice hasParen unqualSplice e)
338

339
mkHsSpliceTy :: SpliceDecoration -> LHsExpr GhcPs -> HsType GhcPs
Alan Zimmerman's avatar
Alan Zimmerman committed
340 341
mkHsSpliceTy hasParen e
  = HsSpliceTy (HsUntypedSplice hasParen unqualSplice e) placeHolderKind
342

343
mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice GhcPs
344
mkHsQuasiQuote quoter span quote = HsQuasiQuote unqualSplice quoter span quote
345

twanvl's avatar
twanvl committed
346
unqualQuasiQuote :: RdrName
Ian Lynagh's avatar
Ian Lynagh committed
347
unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
348 349
                -- A name (uniquified later) to
                -- identify the quasi-quote
350

351 352
mkHsString :: SourceTextX p => String -> HsLit p
mkHsString s = HsString noSourceText (mkFastString s)
353

354
mkHsStringPrimLit :: SourceTextX p => FastString -> HsLit p
355
mkHsStringPrimLit fs
356
  = HsStringPrim noSourceText (fastStringToByteString fs)
357

358
-------------
359
userHsLTyVarBndrs :: SrcSpan -> [Located (IdP name)] -> [LHsTyVarBndr name]
360 361 362
-- Caller sets location
userHsLTyVarBndrs loc bndrs = [ L loc (UserTyVar v) | v <- bndrs ]

363
userHsTyVarBndrs :: SrcSpan -> [IdP name] -> [LHsTyVarBndr name]
364
-- Caller sets location
365
userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar (L loc v)) | v <- bndrs ]
366

367

Austin Seipp's avatar
Austin Seipp committed
368 369 370
{-
************************************************************************
*                                                                      *
371
        Constructing syntax with no location info
Austin Seipp's avatar
Austin Seipp committed
372 373 374
*                                                                      *
************************************************************************
-}
375

376
nlHsVar :: IdP id -> LHsExpr id
377
nlHsVar n = noLoc (HsVar (noLoc n))
378

Richard Eisenberg's avatar
Richard Eisenberg committed
379
-- NB: Only for LHsExpr **Id**
380
nlHsDataCon :: DataCon -> LHsExpr GhcTc
Richard Eisenberg's avatar
Richard Eisenberg committed
381 382
nlHsDataCon con = noLoc (HsConLikeOut (RealDataCon con))

383
nlHsLit :: HsLit p -> LHsExpr p
384 385
nlHsLit n = noLoc (HsLit n)

386 387
nlHsIntLit :: HasDefaultX p => Integer -> LHsExpr p
nlHsIntLit n = noLoc (HsLit (HsInt def (mkIntegralLit n)))
388

389
nlVarPat :: IdP id -> LPat id
390
nlVarPat n = noLoc (VarPat (noLoc n))
391

392
nlLitPat :: HsLit p -> LPat p
393 394 395
nlLitPat l = noLoc (LitPat l)

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

398 399 400 401 402 403 404 405 406 407 408 409
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))

410
nlHsApps :: IdP id -> [LHsExpr id] -> LHsExpr id
411
nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
412

413
nlHsVarApps :: IdP id -> [IdP id] -> LHsExpr id
414
nlHsVarApps f xs = noLoc (foldl mk (HsVar (noLoc f)) (map (HsVar . noLoc) xs))
415 416
                 where
                   mk f a = HsApp (noLoc f) (noLoc a)
417

418
nlConVarPat :: RdrName -> [RdrName] -> LPat GhcPs
419 420
nlConVarPat con vars = nlConPat con (map nlVarPat vars)

421
nlConVarPatName :: Name -> [Name] -> LPat GhcRn
Adam Gundry's avatar
Adam Gundry committed
422 423
nlConVarPatName con vars = nlConPatName con (map nlVarPat vars)

424
nlInfixConPat :: IdP id -> LPat id -> LPat id -> LPat id
425 426
nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))

427
nlConPat :: RdrName -> [LPat GhcPs] -> LPat GhcPs
428 429
nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))

430
nlConPatName :: Name -> [LPat GhcRn] -> LPat GhcRn
431 432
nlConPatName con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))

433
nlNullaryConPat :: IdP id -> LPat id
434 435
nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))

436
nlWildConPat :: DataCon -> LPat GhcPs
437
nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
438 439
                         (PrefixCon (nOfThem (dataConSourceArity con)
                                             nlWildPat)))
440

441
nlWildPat :: LPat GhcPs
442
nlWildPat  = noLoc (WildPat placeHolderType )  -- Pre-typechecking
443

444
nlWildPatName :: LPat GhcRn
445 446
nlWildPatName  = noLoc (WildPat placeHolderType )  -- Pre-typechecking

447
nlWildPatId :: LPat GhcTc
448 449
nlWildPatId  = noLoc (WildPat placeHolderTypeTc )  -- Post-typechecking

450 451
nlHsDo :: HsStmtContext Name -> [LStmt GhcPs (LHsExpr GhcPs)]
       -> LHsExpr GhcPs
452
nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)
453

454
nlHsOpApp :: LHsExpr id -> IdP id -> LHsExpr id -> LHsExpr id
455 456
nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)

457
nlHsLam  :: LMatch GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs
twanvl's avatar
twanvl committed
458 459
nlHsPar  :: LHsExpr id -> LHsExpr id
nlHsIf   :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id
460 461 462
nlHsCase :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)]
         -> LHsExpr GhcPs
nlList   :: [LHsExpr GhcPs] -> LHsExpr GhcPs
twanvl's avatar
twanvl committed
463

464
nlHsLam match          = noLoc (HsLam (mkMatchGroup Generated [match]))
465
nlHsPar e              = noLoc (HsPar e)
466 467 468 469 470 471

-- Note [Rebindable nlHsIf]
-- nlHsIf should generate if-expressions which are NOT subject to
-- RebindableSyntax, so the first field of HsIf is Nothing. (#12080)
nlHsIf cond true false = noLoc (HsIf Nothing cond true false)

472 473
nlHsCase expr matches  = noLoc (HsCase expr (mkMatchGroup Generated matches))
nlList exprs           = noLoc (ExplicitList placeHolderType Nothing exprs)
474

twanvl's avatar
twanvl committed
475
nlHsAppTy :: LHsType name -> LHsType name -> LHsType name
476
nlHsTyVar :: IdP name                     -> LHsType name
twanvl's avatar
twanvl committed
477
nlHsFunTy :: LHsType name -> LHsType name -> LHsType name
Alan Zimmerman's avatar
Alan Zimmerman committed
478
nlHsParTy :: LHsType name                 -> LHsType name
twanvl's avatar
twanvl committed
479

480
nlHsAppTy f t           = noLoc (HsAppTy f t)
Alan Zimmerman's avatar
Alan Zimmerman committed
481
nlHsTyVar x             = noLoc (HsTyVar NotPromoted (noLoc x))
482
nlHsFunTy a b           = noLoc (HsFunTy a b)
Alan Zimmerman's avatar
Alan Zimmerman committed
483
nlHsParTy t             = noLoc (HsParTy t)
484

485
nlHsTyConApp :: IdP name -> [LHsType name] -> LHsType name
486
nlHsTyConApp tycon tys  = foldl nlHsAppTy (nlHsTyVar tycon) tys
487

Austin Seipp's avatar
Austin Seipp committed
488
{-
489 490
Tuples.  All these functions are *pre-typechecker* because they lack
types on the tuple.
Austin Seipp's avatar
Austin Seipp committed
491
-}
492 493 494 495

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

498
mkLHsVarTuple :: [IdP a] -> LHsExpr a
499
mkLHsVarTuple ids  = mkLHsTupleExpr (map nlHsVar ids)
500

501
nlTuplePat :: [LPat id] -> Boxity -> LPat id
502
nlTuplePat pats box = noLoc (TuplePat pats box [])
503

504
missingTupArg :: HsTupArg GhcPs
505
missingTupArg = Missing placeHolderType
506

Simon Marlow's avatar
Simon Marlow committed
507 508 509 510 511 512
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
513
mkBigLHsVarTup :: [IdP id] -> LHsExpr id
Simon Marlow's avatar
Simon Marlow committed
514 515 516 517 518 519
mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids)

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

-- The Big equivalents for the source tuple patterns
520
mkBigLHsVarPatTup :: [IdP id] -> LPat id
Simon Marlow's avatar
Simon Marlow committed
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 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566
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
567 568 569
{-
************************************************************************
*                                                                      *
570
        LHsSigType and LHsSigWcType
Austin Seipp's avatar
Austin Seipp committed
571
*                                                                      *
572
********************************************************************* -}
573

574
mkLHsSigType :: LHsType GhcPs -> LHsSigType GhcPs
575
mkLHsSigType ty = mkHsImplicitBndrs ty
576

577
mkLHsSigWcType :: LHsType GhcPs -> LHsSigWcType GhcPs
578
mkLHsSigWcType ty = mkHsWildCardBndrs (mkHsImplicitBndrs ty)
579

580 581
mkHsSigEnv :: forall a. (LSig GhcRn -> Maybe ([Located Name], a))
                     -> [LSig GhcRn]
582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601
                     -> NameEnv a
mkHsSigEnv get_info sigs
  = mkNameEnv          (mk_pairs ordinary_sigs)
   `extendNameEnvList` (mk_pairs gen_dm_sigs)
   -- The subtlety is this: in a class decl with a
   -- default-method signature as well as a method signature
   -- we want the latter to win (Trac #12533)
   --    class C x where
   --       op :: forall a . x a -> x a
   --       default op :: forall b . x b -> x b
   --       op x = ...(e :: b -> b)...
   -- The scoped type variables of the 'default op', namely 'b',
   -- scope over the code for op.   The 'forall a' does not!
   -- This applies both in the renamer and typechecker, both
   -- of which use this function
  where
    (gen_dm_sigs, ordinary_sigs) = partition is_gen_dm_sig sigs
    is_gen_dm_sig (L _ (ClassOpSig True _ _)) = True
    is_gen_dm_sig _                           = False

602
    mk_pairs :: [LSig GhcRn] -> [(Name, a)]
603 604 605
    mk_pairs sigs = [ (n,a) | Just (ns,a) <- map get_info sigs
                            , L _ n <- ns ]

606
mkClassOpSigs :: [LSig GhcPs] -> [LSig GhcPs]
607 608 609 610 611
-- 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
612
  where
613 614
    fiddle (L loc (TypeSig nms ty)) = L loc (ClassOpSig False nms (dropWildCards ty))
    fiddle sig                      = sig
615

616
typeToLHsType :: Type -> LHsType GhcPs
617 618 619 620 621
-- ^ 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.
622 623
typeToLHsType ty
  = go ty
624
  where
625
    go :: Type -> LHsType GhcPs
Simon Peyton Jones's avatar
Simon Peyton Jones committed
626
    go ty@(FunTy arg _)
627 628 629 630
      | isPredTy arg
      , (theta, tau) <- tcSplitPhiTy ty
      = noLoc (HsQualTy { hst_ctxt = noLoc (map go theta)
                        , hst_body = go tau })
Simon Peyton Jones's avatar
Simon Peyton Jones committed
631
    go (FunTy arg res) = nlHsFunTy (go arg) (go res)
632 633 634 635
    go ty@(ForAllTy {})
      | (tvs, tau) <- tcSplitForAllTys ty
      = noLoc (HsForAllTy { hst_bndrs = map go_tv tvs
                          , hst_body = go tau })
636 637
    go (TyVarTy tv)         = nlHsTyVar (getRdrName tv)
    go (AppTy t1 t2)        = nlHsAppTy (go t1) (go t2)
638 639
    go (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy noSourceText n)
    go (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy noSourceText s)
640
    go (TyConApp tc args)   = nlHsTyConApp (getRdrName tc) (map go args')
641
       where
642 643 644 645 646
         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
647
         -- so we must remove them here (Trac #8563)
648

649
    go_tv :: TyVar -> LHsTyVarBndr GhcPs
650 651
    go_tv tv = noLoc $ KindedTyVar (noLoc (getRdrName tv))
                                   (go (tyVarKind tv))
652 653


654 655 656 657 658 659
{- *********************************************************************
*                                                                      *
    --------- HsWrappers: type args, dict args, casts ---------
*                                                                      *
********************************************************************* -}

660 661 662
mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id
mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)

663 664
-- Avoid (HsWrap co (HsWrap co' _)).
-- See Note [Detecting forced eta expansion] in DsExpr
665 666
mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id
mkHsWrap co_fn e | isIdHsWrapper co_fn = e
667 668
mkHsWrap co_fn (HsWrap co_fn' e)       = mkHsWrap (co_fn <.> co_fn') e
mkHsWrap co_fn e                       = HsWrap co_fn e
669

670
mkHsWrapCo :: TcCoercionN   -- A Nominal coercion  a ~N b
671
           -> HsExpr id -> HsExpr id
672
mkHsWrapCo co e = mkHsWrap (mkWpCastN co) e
673

674
mkHsWrapCoR :: TcCoercionR   -- A Representational coercion  a ~R b
675
            -> HsExpr id -> HsExpr id
676
mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e
677

678
mkLHsWrapCo :: TcCoercionN -> LHsExpr id -> LHsExpr id
Joachim Breitner's avatar
Joachim Breitner committed
679
mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e)
680

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
681 682 683 684 685 686
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)
687

688 689
mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id
mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
690
                       | otherwise           = CoPat co_fn p ty
691

692
mkHsWrapPatCo :: TcCoercionN -> Pat id -> Type -> Pat id
693
mkHsWrapPatCo co pat ty | isTcReflCo co = pat
694
                        | otherwise     = CoPat (mkWpCastN co) pat ty
695

696
mkHsDictLet :: TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc
697
mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr
Austin Seipp's avatar
Austin Seipp committed
698 699

{-
700
l
Austin Seipp's avatar
Austin Seipp committed
701 702
************************************************************************
*                                                                      *
703
                Bindings; with a location at the top
Austin Seipp's avatar
Austin Seipp committed
704 705 706
*                                                                      *
************************************************************************
-}
707

708 709
mkFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
          -> HsBind GhcPs
710
-- Not infix, with place holders for coercion and free vars
711
mkFunBind fn ms = FunBind { fun_id = fn
712 713
                          , fun_matches = mkMatchGroup Generated ms
                          , fun_co_fn = idHsWrapper
714
                          , bind_fvs = placeHolderNames
715
                          , fun_tick = [] }
716

717 718
mkTopFunBind :: Origin -> Located Name -> [LMatch GhcRn (LHsExpr GhcRn)]
             -> HsBind GhcRn
719
-- In Name-land, with empty bind_fvs
720
mkTopFunBind origin fn ms = FunBind { fun_id = fn
721
                                    , fun_matches = mkMatchGroup origin ms
722
                                    , fun_co_fn = idHsWrapper
723 724
                                    , bind_fvs = emptyNameSet -- NB: closed
                                                              --     binding
725
                                    , fun_tick = [] }
726

727
mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
728 729
mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs

730
mkVarBind :: IdP p -> LHsExpr p -> LHsBind p