Utils.hs 57.4 KB
Newer Older
1 2 3 4
{-|
Module      : GHC.Hs.Utils
Description : Generic helpers for the HsSyn type.
Copyright   : (c) The University of Glasgow, 1992-2006
5

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

10 11 12 13 14
   Parameterised by          Module
   ----------------          -------------
   GhcPs/RdrName             parser/RdrHsSyn
   GhcRn/Name                rename/RnHsSyn
   GhcTc/Id                  typecheck/TcHsSyn
15 16 17 18 19

The @mk*@ functions attempt to construct a not-completely-useless SrcSpan
from their components, compared with the @nl*@ functions which
just attach noSrcSpan to everything.

Austin Seipp's avatar
Austin Seipp committed
20
-}
21

22
{-# LANGUAGE CPP #-}
23 24
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
25
{-# LANGUAGE TypeFamilies #-}
26
{-# LANGUAGE ViewPatterns #-}
Ian Lynagh's avatar
Ian Lynagh committed
27

Sylvain Henry's avatar
Sylvain Henry committed
28
module GHC.Hs.Utils(
29
  -- * Terms
Simon Peyton Jones's avatar
Simon Peyton Jones committed
30
  mkHsPar, mkHsApp, mkHsAppType, mkHsAppTypes, mkHsCaseAlt,
31
  mkSimpleMatch, unguardedGRHSs, unguardedRHS,
Ben Gamari's avatar
Ben Gamari committed
32
  mkMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf,
33
  mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,
34
  mkHsDictLet, mkHsLams,
35
  mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo,
36
  mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap,
37
  mkHsCmdIf,
38

Richard Eisenberg's avatar
Richard Eisenberg committed
39 40
  nlHsTyApp, nlHsTyApps, nlHsVar, nlHsDataCon,
  nlHsLit, nlHsApp, nlHsApps, nlHsSyntaxApps,
41
  nlHsIntLit, nlHsVarApps,
42
  nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
43
  mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
44
  typeToLHsType,
45

Simon Marlow's avatar
Simon Marlow committed
46 47 48 49
  -- * Constructing general big tuples
  -- $big_tuples
  mkChunkified, chunkify,

50
  -- * Bindings
51
  mkFunBind, mkVarBind, mkHsVarBind, mkSimpleGeneratedFunBind, mkTopFunBind,
Simon Marlow's avatar
Simon Marlow committed
52
  mkPatSynBind,
53
  isInfixFunBind,
54

55
  -- * Literals
56
  mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringPrimLit,
57

58
  -- * Patterns
Adam Gundry's avatar
Adam Gundry committed
59
  mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat,
60
  nlConPatName, nlInfixConPat, nlNullaryConPat, nlWildConPat, nlWildPat,
61
  nlWildPatName, nlTuplePat, mkParPat, nlParPat,
Simon Marlow's avatar
Simon Marlow committed
62
  mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup,
63

64
  -- * Types
65
  mkHsAppTy, mkHsAppKindTy,
66
  mkLHsSigType, mkLHsSigWcType, mkClassOpSigs, mkHsSigEnv,
67
  nlHsAppTy, nlHsAppKindTy, nlHsTyVar, nlHsFunTy, nlHsParTy, nlHsTyConApp,
68

69
  -- * Stmts
70 71
  mkTransformStmt, mkTransformByStmt, mkBodyStmt, mkBindStmt, mkTcBindStmt,
  mkLastStmt,
72 73
  emptyTransStmt, mkGroupUsingStmt, mkGroupByUsingStmt,
  emptyRecStmt, emptyRecStmtName, emptyRecStmtId, mkRecStmt,
74
  unitRecStmtTc,
75

76
  -- * Template Haskell
77
  mkUntypedSplice, mkTypedSplice,
78
  mkHsQuasiQuote, unqualQuasiQuote,
79

80
  -- * Collecting binders
81
  isUnliftedHsBind, isBangedHsBind,
Richard Eisenberg's avatar
Richard Eisenberg committed
82

83
  collectLocalBinders, collectHsValBinders, collectHsBindListBinders,
84
  collectHsIdBinders,
85 86 87 88
  collectHsBindsBinders, collectHsBindBinders, collectMethodBinders,
  collectPatBinders, collectPatsBinders,
  collectLStmtsBinders, collectStmtsBinders,
  collectLStmtBinders, collectStmtBinders,
89

90 91
  hsLTyClDeclBinders, hsTyClForeignBinders,
  hsPatSynSelectors, getPatSynBinds,
92
  hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,
93

94
  -- * Collecting implicit binders
95
  lStmtsImplicits, hsValBindsImplicits, lPatImplicits
96
  ) where
97

98 99
#include "HsVersions.h"

100 101
import GhcPrelude

Sylvain Henry's avatar
Sylvain Henry committed
102 103 104 105 106 107 108 109
import GHC.Hs.Decls
import GHC.Hs.Binds
import GHC.Hs.Expr
import GHC.Hs.Pat
import GHC.Hs.Types
import GHC.Hs.Lit
import GHC.Hs.PlaceHolder
import GHC.Hs.Extension
110

111
import TcEvidence
112 113
import RdrName
import Var
114
import TyCoRep
Ben Gamari's avatar
Ben Gamari committed
115
import Type   ( appTyArgFlags, splitAppTys, tyConArgFlags, tyConAppNeedsKindSig )
116
import TysWiredIn ( unitTy )
117
import TcType
118
import DataCon
Richard Eisenberg's avatar
Richard Eisenberg committed
119 120
import ConLike
import Id
121
import Name
122
import NameSet hiding ( unitFV )
123
import NameEnv
124
import BasicTypes
125
import SrcLoc
126 127
import FastString
import Util
128
import Bag
129
import Outputable
Simon Marlow's avatar
Simon Marlow committed
130
import Constants
131

132
import Data.Either
133 134
import Data.Function
import Data.List
135

Austin Seipp's avatar
Austin Seipp committed
136 137 138
{-
************************************************************************
*                                                                      *
139
        Some useful helpers for constructing syntax
Austin Seipp's avatar
Austin Seipp committed
140 141
*                                                                      *
************************************************************************
142

143 144 145
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
146
-}
147

148
-- | @e => (e)@
149
mkHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
150
mkHsPar e = L (getLoc e) (HsPar noExtField e)
151

152 153 154
mkSimpleMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p)))
              -> [LPat (GhcPass p)] -> Located (body (GhcPass p))
              -> LMatch (GhcPass p) (Located (body (GhcPass p)))
155
mkSimpleMatch ctxt pats rhs
156
  = L loc $
157
    Match { m_ext = noExtField, m_ctxt = ctxt, m_pats = pats
158
          , m_grhss = unguardedGRHSs rhs }
159 160
  where
    loc = case pats of
161 162
                []      -> getLoc rhs
                (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs)
163

164 165
unguardedGRHSs :: Located (body (GhcPass p))
               -> GRHSs (GhcPass p) (Located (body (GhcPass p)))
166
unguardedGRHSs rhs@(L loc _)
167
  = GRHSs noExtField (unguardedRHS loc rhs) (noLoc emptyLocalBinds)
168

169 170
unguardedRHS :: SrcSpan -> Located (body (GhcPass p))
             -> [LGRHS (GhcPass p) (Located (body (GhcPass p)))]
171
unguardedRHS loc rhs = [L loc (GRHS noExtField [] rhs)]
172

173
mkMatchGroup :: (XMG name (Located (body name)) ~ NoExtField)
174 175
             => Origin -> [LMatch name (Located (body name))]
             -> MatchGroup name (Located (body name))
176
mkMatchGroup origin matches = MG { mg_ext = noExtField
177
                                 , mg_alts = mkLocatedList matches
178 179
                                 , mg_origin = origin }

180 181
mkLocatedList ::  [Located a] -> Located [Located a]
mkLocatedList [] = noLoc []
182
mkLocatedList ms = L (combineLocs (head ms) (last ms)) ms
183

184
mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
185
mkHsApp e1 e2 = addCLoc e1 e2 (HsApp noExtField e1 e2)
186

187
mkHsAppType :: (NoGhcTc (GhcPass id) ~ GhcRn)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
188
            => LHsExpr (GhcPass id) -> LHsWcType GhcRn -> LHsExpr (GhcPass id)
189
mkHsAppType e t = addCLoc e t_body (HsAppType noExtField e paren_wct)
190 191 192
  where
    t_body    = hswc_body t
    paren_wct = t { hswc_body = parenthesizeHsType appPrec t_body }
193

194
mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn
195
mkHsAppTypes = foldl' mkHsAppType
196

197
mkHsLam :: (XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField) =>
198
  [LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
199
mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam noExtField matches))
200 201
  where
    matches = mkMatchGroup Generated
202
                           [mkSimpleMatch LambdaExpr pats' body]
203
    pats' = map (parenthesizePat appPrec) pats
204

205
mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc
206 207
mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars
                                       <.> mkWpLams dicts) expr
208

209 210
-- |A simple case alternative with a single pattern, no binds, no guards;
-- pre-typechecking
211 212
mkHsCaseAlt :: LPat (GhcPass p) -> (Located (body (GhcPass p)))
            -> LMatch (GhcPass p) (Located (body (GhcPass p)))
213 214
mkHsCaseAlt pat expr
  = mkSimpleMatch CaseAlt [pat] expr
215

216 217
nlHsTyApp :: IdP (GhcPass id) -> [Type] -> LHsExpr (GhcPass id)
nlHsTyApp fun_id tys
218
  = noLoc (mkHsWrap (mkWpTyApps tys) (HsVar noExtField (noLoc fun_id)))
219

220 221
nlHsTyApps :: IdP (GhcPass id) -> [Type] -> [LHsExpr (GhcPass id)]
           -> LHsExpr (GhcPass id)
222
nlHsTyApps fun_id tys xs = foldl' nlHsApp (nlHsTyApp fun_id tys) xs
223

224
--------- Adding parens ---------
225 226
-- | Wrap in parens if @'hsExprNeedsParens' appPrec@ says it needs them
-- So @f x@ becomes @(f x)@, but @3@ stays as @3@.
227
mkLHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
228 229
mkLHsPar le@(L loc e)
  | hsExprNeedsParens appPrec e = L loc (HsPar noExtField le)
230
  | otherwise                   = le
231

232
mkParPat :: LPat (GhcPass name) -> LPat (GhcPass name)
233 234
mkParPat lp@(L loc p)
  | patNeedsParens appPrec p = L loc (ParPat noExtField lp)
235
  | otherwise                = lp
236

237
nlParPat :: LPat (GhcPass name) -> LPat (GhcPass name)
238
nlParPat p = noLoc (ParPat noExtField p)
239

240
-------------------------------
241 242 243
-- These are the bits of syntax that contain rebindable names
-- See RnEnv.lookupSyntaxName

244 245 246
mkHsIntegral   :: IntegralLit -> HsOverLit GhcPs
mkHsFractional :: FractionalLit -> HsOverLit GhcPs
mkHsIsString   :: SourceText -> FastString -> HsOverLit GhcPs
247 248 249 250 251 252 253 254
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

255 256
mkLastStmt :: Located (bodyR (GhcPass idR))
           -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))
257
mkBodyStmt :: Located (bodyR GhcPs)
258 259
           -> StmtLR (GhcPass idL) GhcPs (Located (bodyR GhcPs))
mkBindStmt :: (XBindStmt (GhcPass idL) (GhcPass idR)
260
                         (Located (bodyR (GhcPass idR))) ~ NoExtField)
261 262
           => LPat (GhcPass idL) -> Located (bodyR (GhcPass idR))
           -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))
263 264
mkTcBindStmt :: LPat GhcTc -> Located (bodyR GhcTc)
             -> StmtLR GhcTc GhcTc (Located (bodyR GhcTc))
265

266
emptyRecStmt     :: StmtLR (GhcPass idL) GhcPs bodyR
267 268
emptyRecStmtName :: StmtLR GhcRn GhcRn bodyR
emptyRecStmtId   :: StmtLR GhcTc GhcTc bodyR
269 270
mkRecStmt        :: [LStmtLR (GhcPass idL) GhcPs bodyR]
                 -> StmtLR (GhcPass idL) GhcPs bodyR
twanvl's avatar
twanvl committed
271 272


273 274 275
mkHsIntegral     i  = OverLit noExtField (HsIntegral       i) noExpr
mkHsFractional   f  = OverLit noExtField (HsFractional     f) noExpr
mkHsIsString src s  = OverLit noExtField (HsIsString   src s) noExpr
276

277
mkHsDo ctxt stmts = HsDo noExtField ctxt (mkLocatedList stmts)
278 279
mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt])
  where
280
    last_stmt = L (getLoc expr) $ mkLastStmt expr
281

282 283
mkHsIf :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
       -> HsExpr (GhcPass p)
284
mkHsIf c a b = HsIf noExtField (Just noSyntaxExpr) c a b
Ben Gamari's avatar
Ben Gamari committed
285

286 287
mkHsCmdIf :: LHsExpr (GhcPass p) -> LHsCmd (GhcPass p) -> LHsCmd (GhcPass p)
       -> HsCmd (GhcPass p)
288
mkHsCmdIf c a b = HsCmdIf noExtField (Just noSyntaxExpr) c a b
289

290
mkNPat lit neg     = NPat noExtField lit neg noSyntaxExpr
291
mkNPlusKPat id lit
292
  = NPlusKPat noExtField id lit (unLoc lit) noSyntaxExpr noSyntaxExpr
Ben Gamari's avatar
Ben Gamari committed
293

294 295 296 297 298 299 300 301 302 303 304
mkTransformStmt    :: [ExprLStmt GhcPs] -> LHsExpr GhcPs
                   -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
mkTransformByStmt  :: [ExprLStmt GhcPs] -> LHsExpr GhcPs
                   -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
mkGroupUsingStmt   :: [ExprLStmt GhcPs] -> LHsExpr GhcPs
                   -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
mkGroupByUsingStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs
                   -> LHsExpr GhcPs
                   -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)

emptyTransStmt :: StmtLR GhcPs GhcPs (LHsExpr GhcPs)
305
emptyTransStmt = TransStmt { trS_ext = noExtField
306
                           , trS_form = panic "emptyTransStmt: form"
307
                           , trS_stmts = [], trS_bndrs = []
308
                           , trS_by = Nothing, trS_using = noLoc noExpr
309
                           , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr
310
                           , trS_fmap = noExpr }
311 312 313 314
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 }
315

316
mkLastStmt body = LastStmt noExtField body False noSyntaxExpr
317
mkBodyStmt body
318
  = BodyStmt noExtField body noSyntaxExpr noSyntaxExpr
319
mkBindStmt pat body
320
  = BindStmt noExtField pat body noSyntaxExpr noSyntaxExpr
321
mkTcBindStmt pat body = BindStmt unitTy pat body noSyntaxExpr noSyntaxExpr
322
  -- don't use placeHolderTypeTc above, because that panics during zonking
323

324
emptyRecStmt' :: forall idL idR body.
325 326
                 XRecStmt (GhcPass idL) (GhcPass idR) body
              -> StmtLR (GhcPass idL) (GhcPass idR) body
327 328 329 330 331 332
emptyRecStmt' tyVal =
   RecStmt
     { recS_stmts = [], recS_later_ids = []
     , recS_rec_ids = []
     , recS_ret_fn = noSyntaxExpr
     , recS_mfix_fn = noSyntaxExpr
333 334 335 336 337 338 339 340 341
     , recS_bind_fn = noSyntaxExpr
     , recS_ext = tyVal }

unitRecStmtTc :: RecStmtTc
unitRecStmtTc = RecStmtTc { recS_bind_ty = unitTy
                          , recS_later_rets = []
                          , recS_rec_rets = []
                          , recS_ret_ty = unitTy }

342 343
emptyRecStmt     = emptyRecStmt' noExtField
emptyRecStmtName = emptyRecStmt' noExtField
344 345
emptyRecStmtId   = emptyRecStmt' unitRecStmtTc
                                        -- a panic might trigger during zonking
346
mkRecStmt stmts  = emptyRecStmt { recS_stmts = stmts }
347 348

-------------------------------
349
-- | A useful function for building @OpApps@.  The operator is always a
350
-- variable, and we don't know the fixity yet.
351
mkHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
352
mkHsOpApp e1 op e2 = OpApp noExtField e1 (noLoc (HsVar noExtField (noLoc op))) e2
353

354 355 356
unqualSplice :: RdrName
unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))

357
mkUntypedSplice :: SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs
358
mkUntypedSplice hasParen e = HsUntypedSplice noExtField hasParen unqualSplice e
359

360
mkTypedSplice :: SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs
361
mkTypedSplice hasParen e = HsTypedSplice noExtField hasParen unqualSplice e
362

363
mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice GhcPs
364
mkHsQuasiQuote quoter span quote
365
  = HsQuasiQuote noExtField unqualSplice quoter span quote
366

twanvl's avatar
twanvl committed
367
unqualQuasiQuote :: RdrName
Ian Lynagh's avatar
Ian Lynagh committed
368
unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
369 370
                -- A name (uniquified later) to
                -- identify the quasi-quote
371

372 373
mkHsString :: String -> HsLit (GhcPass p)
mkHsString s = HsString NoSourceText (mkFastString s)
374

375
mkHsStringPrimLit :: FastString -> HsLit (GhcPass p)
376
mkHsStringPrimLit fs = HsStringPrim NoSourceText (bytesFS fs)
377

378

Austin Seipp's avatar
Austin Seipp committed
379 380 381
{-
************************************************************************
*                                                                      *
382
        Constructing syntax with no location info
Austin Seipp's avatar
Austin Seipp committed
383 384 385
*                                                                      *
************************************************************************
-}
386

387
nlHsVar :: IdP (GhcPass id) -> LHsExpr (GhcPass id)
388
nlHsVar n = noLoc (HsVar noExtField (noLoc n))
389

390
-- | NB: Only for 'LHsExpr' 'Id'.
391
nlHsDataCon :: DataCon -> LHsExpr GhcTc
392
nlHsDataCon con = noLoc (HsConLikeOut noExtField (RealDataCon con))
Richard Eisenberg's avatar
Richard Eisenberg committed
393

394
nlHsLit :: HsLit (GhcPass p) -> LHsExpr (GhcPass p)
395
nlHsLit n = noLoc (HsLit noExtField n)
396

397
nlHsIntLit :: Integer -> LHsExpr (GhcPass p)
398
nlHsIntLit n = noLoc (HsLit noExtField (HsInt noExtField (mkIntegralLit n)))
399

400
nlVarPat :: IdP (GhcPass id) -> LPat (GhcPass id)
401
nlVarPat n = noLoc (VarPat noExtField (noLoc n))
402

403
nlLitPat :: HsLit GhcPs -> LPat GhcPs
404
nlLitPat l = noLoc (LitPat noExtField l)
405

406
nlHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
407
nlHsApp f x = noLoc (HsApp noExtField f (mkLHsPar x))
408

409 410
nlHsSyntaxApps :: SyntaxExpr (GhcPass id) -> [LHsExpr (GhcPass id)]
               -> LHsExpr (GhcPass id)
411 412 413 414 415
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 )
416
    foldl' nlHsApp (noLoc fun) args
417 418

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

422
nlHsApps :: IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
423
nlHsApps f xs = foldl' nlHsApp (nlHsVar f) xs
424

425
nlHsVarApps :: IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
426 427
nlHsVarApps f xs = noLoc (foldl' mk (HsVar noExtField (noLoc f))
                                               (map ((HsVar noExtField) . noLoc) xs))
428
                 where
429
                   mk f a = HsApp noExtField (noLoc f) (noLoc a)
430

431
nlConVarPat :: RdrName -> [RdrName] -> LPat GhcPs
432 433
nlConVarPat con vars = nlConPat con (map nlVarPat vars)

434
nlConVarPatName :: Name -> [Name] -> LPat GhcRn
Adam Gundry's avatar
Adam Gundry committed
435 436
nlConVarPatName con vars = nlConPatName con (map nlVarPat vars)

437 438 439 440
nlInfixConPat :: RdrName -> LPat GhcPs -> LPat GhcPs -> LPat GhcPs
nlInfixConPat con l r = noLoc (ConPatIn (noLoc con)
                              (InfixCon (parenthesizePat opPrec l)
                                        (parenthesizePat opPrec r)))
441

442
nlConPat :: RdrName -> [LPat GhcPs] -> LPat GhcPs
443
nlConPat con pats =
444
  noLoc (ConPatIn (noLoc con) (PrefixCon (map (parenthesizePat appPrec) pats)))
445

446
nlConPatName :: Name -> [LPat GhcRn] -> LPat GhcRn
447
nlConPatName con pats =
448
  noLoc (ConPatIn (noLoc con) (PrefixCon (map (parenthesizePat appPrec) pats)))
449

450
nlNullaryConPat :: IdP (GhcPass p) -> LPat (GhcPass p)
451 452
nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))

453
nlWildConPat :: DataCon -> LPat GhcPs
454
nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
455
                         (PrefixCon (replicate (dataConSourceArity con)
456
                                             nlWildPat)))
457

458
-- | Wildcard pattern - after parsing
459
nlWildPat :: LPat GhcPs
460
nlWildPat  = noLoc (WildPat noExtField )
461

462
-- | Wildcard pattern - after renaming
463
nlWildPatName :: LPat GhcRn
464
nlWildPatName  = noLoc (WildPat noExtField )
465

466 467
nlHsDo :: HsStmtContext Name -> [LStmt GhcPs (LHsExpr GhcPs)]
       -> LHsExpr GhcPs
468
nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)
469

470
nlHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
471 472
nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)

473
nlHsLam  :: LMatch GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs
474 475 476
nlHsPar  :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsIf   :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
         -> LHsExpr (GhcPass id)
477 478 479
nlHsCase :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)]
         -> LHsExpr GhcPs
nlList   :: [LHsExpr GhcPs] -> LHsExpr GhcPs
twanvl's avatar
twanvl committed
480

481 482
nlHsLam match          = noLoc (HsLam noExtField (mkMatchGroup Generated [match]))
nlHsPar e              = noLoc (HsPar noExtField e)
483

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

489
nlHsCase expr matches
490 491
  = noLoc (HsCase noExtField expr (mkMatchGroup Generated matches))
nlList exprs          = noLoc (ExplicitList noExtField Nothing exprs)
492

493 494 495 496
nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
nlHsTyVar :: IdP (GhcPass p)                            -> LHsType (GhcPass p)
nlHsFunTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
nlHsParTy :: LHsType (GhcPass p)                        -> LHsType (GhcPass p)
twanvl's avatar
twanvl committed
497

498 499 500 501
nlHsAppTy f t = noLoc (HsAppTy noExtField f (parenthesizeHsType appPrec t))
nlHsTyVar x   = noLoc (HsTyVar noExtField NotPromoted (noLoc x))
nlHsFunTy a b = noLoc (HsFunTy noExtField (parenthesizeHsType funPrec a) b)
nlHsParTy t   = noLoc (HsParTy noExtField t)
502

503
nlHsTyConApp :: IdP (GhcPass p) -> [LHsType (GhcPass p)] -> LHsType (GhcPass p)
504
nlHsTyConApp tycon tys  = foldl' nlHsAppTy (nlHsTyVar tycon) tys
505

506 507
nlHsAppKindTy ::
  LHsType (GhcPass p) -> LHsKind (GhcPass p) -> LHsType (GhcPass p)
508 509
nlHsAppKindTy f k
  = noLoc (HsAppKindTy noSrcSpan f (parenthesizeHsType appPrec k))
510

Austin Seipp's avatar
Austin Seipp committed
511
{-
512 513
Tuples.  All these functions are *pre-typechecker* because they lack
types on the tuple.
Austin Seipp's avatar
Austin Seipp committed
514
-}
515

516
mkLHsTupleExpr :: [LHsExpr (GhcPass a)] -> LHsExpr (GhcPass a)
517 518
-- Makes a pre-typechecker boxed tuple, deals with 1 case
mkLHsTupleExpr [e] = e
519
mkLHsTupleExpr es
520
  = noLoc $ ExplicitTuple noExtField (map (noLoc . (Present noExtField)) es) Boxed
521

522
mkLHsVarTuple :: [IdP (GhcPass a)] -> LHsExpr (GhcPass a)
523
mkLHsVarTuple ids  = mkLHsTupleExpr (map nlHsVar ids)
524

525
nlTuplePat :: [LPat GhcPs] -> Boxity -> LPat GhcPs
526
nlTuplePat pats box = noLoc (TuplePat noExtField pats box)
527

528
missingTupArg :: HsTupArg GhcPs
529
missingTupArg = Missing noExtField
530

531
mkLHsPatTup :: [LPat GhcRn] -> LPat GhcRn
532
mkLHsPatTup []     = noLoc $ TuplePat noExtField [] Boxed
Simon Marlow's avatar
Simon Marlow committed
533
mkLHsPatTup [lpat] = lpat
534
mkLHsPatTup lpats  = L (getLoc (head lpats)) $ TuplePat noExtField lpats Boxed
Simon Marlow's avatar
Simon Marlow committed
535

536
-- | The Big equivalents for the source tuple expressions
537
mkBigLHsVarTup :: [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
Simon Marlow's avatar
Simon Marlow committed
538 539
mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids)

540
mkBigLHsTup :: [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
Simon Marlow's avatar
Simon Marlow committed
541 542
mkBigLHsTup = mkChunkified mkLHsTupleExpr

543
-- | The Big equivalents for the source tuple patterns
544
mkBigLHsVarPatTup :: [IdP GhcRn] -> LPat GhcRn
Simon Marlow's avatar
Simon Marlow committed
545 546
mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs)

547
mkBigLHsPatTup :: [LPat GhcRn] -> LPat GhcRn
Simon Marlow's avatar
Simon Marlow committed
548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590
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
591 592 593
{-
************************************************************************
*                                                                      *
594
        LHsSigType and LHsSigWcType
Austin Seipp's avatar
Austin Seipp committed
595
*                                                                      *
596
********************************************************************* -}
597

598
mkLHsSigType :: LHsType GhcPs -> LHsSigType GhcPs
599
mkLHsSigType ty = mkHsImplicitBndrs ty
600

601
mkLHsSigWcType :: LHsType GhcPs -> LHsSigWcType GhcPs
602
mkLHsSigWcType ty = mkHsWildCardBndrs (mkHsImplicitBndrs ty)
603

604 605
mkHsSigEnv :: forall a. (LSig GhcRn -> Maybe ([Located Name], a))
                     -> [LSig GhcRn]
606 607 608 609 610 611
                     -> 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
612
   -- we want the latter to win (#12533)
613 614 615 616 617 618 619 620 621 622
   --    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
623 624
    is_gen_dm_sig (L _ (ClassOpSig _ True _ _)) = True
    is_gen_dm_sig _                             = False
625

626
    mk_pairs :: [LSig GhcRn] -> [(Name, a)]
627
    mk_pairs sigs = [ (n,a) | Just (ns,a) <- map get_info sigs
628
                            , L _ n <- ns ]
629

630
mkClassOpSigs :: [LSig GhcPs] -> [LSig GhcPs]
631
-- ^ Convert 'TypeSig' to 'ClassOpSig'.
632 633 634 635
-- The former is what is parsed, but the latter is
-- what we need in class/instance declarations
mkClassOpSigs sigs
  = map fiddle sigs
636
  where
637 638
    fiddle (L loc (TypeSig _ nms ty))
      = L loc (ClassOpSig noExtField False nms (dropWildCards ty))
639
    fiddle sig = sig
640

641
typeToLHsType :: Type -> LHsType GhcPs
642 643 644 645 646
-- ^ 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.
647 648
typeToLHsType ty
  = go ty
649
  where
650
    go :: Type -> LHsType GhcPs
Simon Peyton Jones's avatar
Simon Peyton Jones committed
651 652 653 654 655
    go ty@(FunTy { ft_af = af, ft_arg = arg, ft_res = res })
      = case af of
          VisArg   -> nlHsFunTy (go arg) (go res)
          InvisArg | (theta, tau) <- tcSplitPhiTy ty
                   -> noLoc (HsQualTy { hst_ctxt = noLoc (map go theta)
656
                                      , hst_xqual = noExtField
Simon Peyton Jones's avatar
Simon Peyton Jones committed
657 658
                                      , hst_body = go tau })

Ryan Scott's avatar
Ryan Scott committed
659 660 661 662
    go ty@(ForAllTy (Bndr _ argf) _)
      | (tvs, tau) <- tcSplitForAllTysSameVis argf ty
      = noLoc (HsForAllTy { hst_fvf = argToForallVisFlag argf
                          , hst_bndrs = map go_tv tvs
663
                          , hst_xforall = noExtField
664
                          , hst_body = go tau })
665
    go (TyVarTy tv)         = nlHsTyVar (getRdrName tv)
666
    go (LitTy (NumTyLit n))
667
      = noLoc $ HsTyLit noExtField (HsNumTy NoSourceText n)
668
    go (LitTy (StrTyLit s))
669
      = noLoc $ HsTyLit noExtField (HsStrTy NoSourceText s)
670
    go ty@(TyConApp tc args)
671
      | tyConAppNeedsKindSig True tc (length args)
672 673
        -- We must produce an explicit kind signature here to make certain
        -- programs kind-check. See Note [Kind signatures in typeToLHsType].
674
      = nlHsParTy $ noLoc $ HsKindSig noExtField ty' (go (tcTypeKind ty))
675
      | otherwise = ty'
676
       where
677 678 679 680 681 682 683
        ty' :: LHsType GhcPs
        ty' = go_app (nlHsTyVar (getRdrName tc)) args (tyConArgFlags tc args)
    go ty@(AppTy {})        = go_app (go head) args (appTyArgFlags head args)
      where
        head :: Type
        args :: [Type]
        (head, args) = splitAppTys ty
684 685 686 687
    go (CastTy ty _)        = go ty
    go (CoercionTy co)      = pprPanic "toLHsSigWcType" (ppr co)

         -- Source-language types have _invisible_ kind arguments,
688
         -- so we must remove them here (#8563)
689

690 691 692 693 694 695 696 697 698 699 700 701 702
    go_app :: LHsType GhcPs -- The type being applied
           -> [Type]        -- The argument types
           -> [ArgFlag]     -- The argument types' visibilities
           -> LHsType GhcPs
    go_app head args arg_flags =
      foldl' (\f (arg, flag) ->
               let arg' = go arg in
               case flag of
                 Inferred  -> f
                 Specified -> f `nlHsAppKindTy` arg'
                 Required  -> f `nlHsAppTy`     arg')
             head (zip args arg_flags)

703
    go_tv :: TyVar -> LHsTyVarBndr GhcPs
704
    go_tv tv = noLoc $ KindedTyVar noExtField (noLoc (getRdrName tv))
705
                                   (go (tyVarKind tv))
706

707 708 709 710
{-
Note [Kind signatures in typeToLHsType]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
There are types that typeToLHsType can produce which require explicit kind
711
signatures in order to kind-check. Here is an example from #14579:
712

713 714 715 716 717 718 719 720 721 722 723 724 725
  -- type P :: forall {k} {t :: k}. Proxy t
  type P = 'Proxy

  -- type Wat :: forall a. Proxy a -> *
  newtype Wat (x :: Proxy (a :: Type)) = MkWat (Maybe a)
    deriving Eq

  -- type Wat2 :: forall {a}. Proxy a -> *
  type Wat2 = Wat

  -- type Glurp :: * -> *
  newtype Glurp a = MkGlurp (Wat2 (P :: Proxy a))
    deriving Eq
726 727 728 729

The derived Eq instance for Glurp (without any kind signatures) would be:

  instance Eq a => Eq (Glurp a) where
730 731
    (==) = coerce @(Wat2 P  -> Wat2 P  -> Bool)
                  @(Glurp a -> Glurp a -> Bool)
732
                  (==) :: Glurp a -> Glurp a -> Bool
733 734 735

(Where the visible type applications use types produced by typeToLHsType.)

736 737 738 739 740 741 742