HsUtils.hs 49.3 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, mkHsCaseAlt,
24
  mkSimpleMatch, unguardedGRHSs, unguardedRHS,
25
  mkMatchGroup, mkMatch, 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
Richard Eisenberg's avatar
Richard Eisenberg committed
75 76
  isUnliftedHsBind,

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

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

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

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

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

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

143 144 145 146
mkSimpleMatch :: HsMatchContext (NameOrRdrName id)
              -> [LPat id] -> Located (body id)
              -> LMatch id (Located (body id))
mkSimpleMatch ctxt pats rhs
147
  = L loc $
148
    Match ctxt pats Nothing (unguardedGRHSs rhs)
149 150
  where
    loc = case pats of
151 152
                []      -> getLoc rhs
                (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs)
153

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

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

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

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

173 174 175
mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)

176 177 178 179 180 181
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)

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

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

192 193 194 195 196
-- |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
197

198
nlHsTyApp :: name -> [Type] -> LHsExpr name
199
nlHsTyApp fun_id tys = noLoc (mkHsWrap (mkWpTyApps tys) (HsVar (noLoc fun_id)))
200

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

204 205 206 207 208 209 210 211 212 213 214
--------- 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
215 216
nlParPat :: LPat name -> LPat name
nlParPat p = noLoc (ParPat p)
217

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

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

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

234
mkLastStmt :: Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR))
235 236
mkBodyStmt :: Located (bodyR RdrName)
           -> StmtLR idL RdrName (Located (bodyR RdrName))
237 238 239 240
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))
241

242 243 244 245
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
246 247


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

252 253
noRebindableInfo :: PlaceHolder
noRebindableInfo = PlaceHolder -- Just another placeholder;
254

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

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

263 264
mkNPat lit neg     = NPat lit neg noSyntaxExpr placeHolderType
mkNPlusKPat id lit = NPlusKPat id lit (unLoc lit) noSyntaxExpr noSyntaxExpr placeHolderType
265

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

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

Simon Marlow's avatar
Simon Marlow committed
291
mkLastStmt body     = LastStmt body False noSyntaxExpr
292
mkBodyStmt body     = BodyStmt body noSyntaxExpr noSyntaxExpr placeHolderType
293 294 295
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
296

297 298 299 300 301 302 303 304
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
305 306
     , recS_bind_fn = noSyntaxExpr, recS_bind_ty = tyVal
     , recS_later_rets = []
307 308 309 310
     , recS_rec_rets = [], recS_ret_ty = tyVal }

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

-------------------------------
315 316
--- 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
317
mkHsOpApp :: LHsExpr id -> id -> LHsExpr id -> HsExpr id
318 319
mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar (noLoc op)))
                           (error "mkOpApp:fixity") e2
320

321 322 323
unqualSplice :: RdrName
unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))

324
mkUntypedSplice :: SpliceDecoration -> LHsExpr RdrName -> HsSplice RdrName
Alan Zimmerman's avatar
Alan Zimmerman committed
325
mkUntypedSplice hasParen e = HsUntypedSplice hasParen unqualSplice e
326

327
mkHsSpliceE :: SpliceDecoration -> LHsExpr RdrName -> HsExpr RdrName
Alan Zimmerman's avatar
Alan Zimmerman committed
328
mkHsSpliceE hasParen e = HsSpliceE (mkUntypedSplice hasParen e)
329

330
mkHsSpliceTE :: SpliceDecoration -> LHsExpr RdrName -> HsExpr RdrName
Alan Zimmerman's avatar
Alan Zimmerman committed
331
mkHsSpliceTE hasParen e = HsSpliceE (HsTypedSplice hasParen unqualSplice e)
332

333
mkHsSpliceTy :: SpliceDecoration -> LHsExpr RdrName -> HsType RdrName
Alan Zimmerman's avatar
Alan Zimmerman committed
334 335
mkHsSpliceTy hasParen e
  = HsSpliceTy (HsUntypedSplice hasParen unqualSplice e) placeHolderKind
336

337 338
mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice RdrName
mkHsQuasiQuote quoter span quote = HsQuasiQuote unqualSplice quoter span quote
339

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

twanvl's avatar
twanvl committed
345
mkHsString :: String -> HsLit
Alan Zimmerman's avatar
Alan Zimmerman committed
346
mkHsString s = HsString NoSourceText (mkFastString s)
347

348 349
mkHsStringPrimLit :: FastString -> HsLit
mkHsStringPrimLit fs
Alan Zimmerman's avatar
Alan Zimmerman committed
350
  = HsStringPrim NoSourceText (fastStringToByteString fs)
351

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

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

361

Austin Seipp's avatar
Austin Seipp committed
362 363 364
{-
************************************************************************
*                                                                      *
365
        Constructing syntax with no location info
Austin Seipp's avatar
Austin Seipp committed
366 367 368
*                                                                      *
************************************************************************
-}
369 370

nlHsVar :: id -> LHsExpr id
371
nlHsVar n = noLoc (HsVar (noLoc n))
372

Richard Eisenberg's avatar
Richard Eisenberg committed
373 374 375 376
-- NB: Only for LHsExpr **Id**
nlHsDataCon :: DataCon -> LHsExpr Id
nlHsDataCon con = noLoc (HsConLikeOut (RealDataCon con))

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

380 381 382
nlHsIntLit :: Integer -> LHsExpr id
nlHsIntLit n = noLoc (HsLit (HsInt (mkIntegralLit n)))

383
nlVarPat :: id -> LPat id
384
nlVarPat n = noLoc (VarPat (noLoc n))
385 386 387 388 389

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

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

392 393 394 395 396 397 398 399 400 401 402 403
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))

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

407
nlHsVarApps :: id -> [id] -> LHsExpr id
408
nlHsVarApps f xs = noLoc (foldl mk (HsVar (noLoc f)) (map (HsVar . noLoc) xs))
409 410
                 where
                   mk f a = HsApp (noLoc f) (noLoc a)
411

412
nlConVarPat :: RdrName -> [RdrName] -> LPat RdrName
413 414
nlConVarPat con vars = nlConPat con (map nlVarPat vars)

Adam Gundry's avatar
Adam Gundry committed
415 416 417
nlConVarPatName :: Name -> [Name] -> LPat Name
nlConVarPatName con vars = nlConPatName con (map nlVarPat vars)

418 419 420
nlInfixConPat :: id -> LPat id -> LPat id -> LPat id
nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))

421
nlConPat :: RdrName -> [LPat RdrName] -> LPat RdrName
422 423
nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))

424 425 426
nlConPatName :: Name -> [LPat Name] -> LPat Name
nlConPatName con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))

427 428 429 430 431
nlNullaryConPat :: id -> LPat id
nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))

nlWildConPat :: DataCon -> LPat RdrName
nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
432 433
                         (PrefixCon (nOfThem (dataConSourceArity con)
                                             nlWildPat)))
434

435 436
nlWildPat :: LPat RdrName
nlWildPat  = noLoc (WildPat placeHolderType )  -- Pre-typechecking
437

438 439 440 441 442 443 444 445
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
446
nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)
447

twanvl's avatar
twanvl committed
448
nlHsOpApp :: LHsExpr id -> id -> LHsExpr id -> LHsExpr id
449 450
nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)

451
nlHsLam  :: LMatch RdrName (LHsExpr RdrName) -> LHsExpr RdrName
twanvl's avatar
twanvl committed
452 453
nlHsPar  :: LHsExpr id -> LHsExpr id
nlHsIf   :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id
454 455 456
nlHsCase :: LHsExpr RdrName -> [LMatch RdrName (LHsExpr RdrName)]
         -> LHsExpr RdrName
nlList   :: [LHsExpr RdrName] -> LHsExpr RdrName
twanvl's avatar
twanvl committed
457

458
nlHsLam match          = noLoc (HsLam (mkMatchGroup Generated [match]))
459
nlHsPar e              = noLoc (HsPar e)
460 461 462 463 464 465

-- 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)

466 467
nlHsCase expr matches  = noLoc (HsCase expr (mkMatchGroup Generated matches))
nlList exprs           = noLoc (ExplicitList placeHolderType Nothing exprs)
468

twanvl's avatar
twanvl committed
469 470 471
nlHsAppTy :: LHsType name -> LHsType name -> LHsType name
nlHsTyVar :: name                         -> LHsType name
nlHsFunTy :: LHsType name -> LHsType name -> LHsType name
Alan Zimmerman's avatar
Alan Zimmerman committed
472
nlHsParTy :: LHsType name                 -> LHsType name
twanvl's avatar
twanvl committed
473

474
nlHsAppTy f t           = noLoc (HsAppTy f t)
Alan Zimmerman's avatar
Alan Zimmerman committed
475
nlHsTyVar x             = noLoc (HsTyVar NotPromoted (noLoc x))
476
nlHsFunTy a b           = noLoc (HsFunTy a b)
Alan Zimmerman's avatar
Alan Zimmerman committed
477
nlHsParTy t             = noLoc (HsParTy t)
478

twanvl's avatar
twanvl committed
479
nlHsTyConApp :: name -> [LHsType name] -> LHsType name
480
nlHsTyConApp tycon tys  = foldl nlHsAppTy (nlHsTyVar tycon) tys
481

Austin Seipp's avatar
Austin Seipp committed
482
{-
483 484
Tuples.  All these functions are *pre-typechecker* because they lack
types on the tuple.
Austin Seipp's avatar
Austin Seipp committed
485
-}
486 487 488 489

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

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

495
nlTuplePat :: [LPat id] -> Boxity -> LPat id
496
nlTuplePat pats box = noLoc (TuplePat pats box [])
497

498
missingTupArg :: HsTupArg RdrName
499
missingTupArg = Missing placeHolderType
500

Simon Marlow's avatar
Simon Marlow committed
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 547 548 549 550 551 552 553 554 555 556 557 558 559 560
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
561 562 563
{-
************************************************************************
*                                                                      *
564
        LHsSigType and LHsSigWcType
Austin Seipp's avatar
Austin Seipp committed
565
*                                                                      *
566
********************************************************************* -}
567

568 569
mkLHsSigType :: LHsType RdrName -> LHsSigType RdrName
mkLHsSigType ty = mkHsImplicitBndrs ty
570

571
mkLHsSigWcType :: LHsType RdrName -> LHsSigWcType RdrName
572
mkLHsSigWcType ty = mkHsWildCardBndrs (mkHsImplicitBndrs ty)
573

574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599
mkHsSigEnv :: forall a. (LSig Name -> Maybe ([Located Name], a))
                     -> [LSig Name]
                     -> 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

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

600 601 602 603 604 605
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
606
  where
607 608
    fiddle (L loc (TypeSig nms ty)) = L loc (ClassOpSig False nms (dropWildCards ty))
    fiddle sig                      = sig
609

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

643 644 645
    go_tv :: TyVar -> LHsTyVarBndr RdrName
    go_tv tv = noLoc $ KindedTyVar (noLoc (getRdrName tv))
                                   (go (tyVarKind tv))
646 647


648 649 650 651 652 653
{- *********************************************************************
*                                                                      *
    --------- HsWrappers: type args, dict args, casts ---------
*                                                                      *
********************************************************************* -}

654 655 656
mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id
mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)

657 658
-- Avoid (HsWrap co (HsWrap co' _)).
-- See Note [Detecting forced eta expansion] in DsExpr
659 660
mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id
mkHsWrap co_fn e | isIdHsWrapper co_fn = e
661 662
mkHsWrap co_fn (HsWrap co_fn' e)       = mkHsWrap (co_fn <.> co_fn') e
mkHsWrap co_fn e                       = HsWrap co_fn e
663

664
mkHsWrapCo :: TcCoercionN   -- A Nominal coercion  a ~N b
665
           -> HsExpr id -> HsExpr id
666
mkHsWrapCo co e = mkHsWrap (mkWpCastN co) e
667

668
mkHsWrapCoR :: TcCoercionR   -- A Representational coercion  a ~R b
669
            -> HsExpr id -> HsExpr id
670
mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e
671

672
mkLHsWrapCo :: TcCoercionN -> LHsExpr id -> LHsExpr id
Joachim Breitner's avatar
Joachim Breitner committed
673
mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e)
674

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
675 676 677 678 679 680
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)
681

682 683
mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id
mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
684
                       | otherwise           = CoPat co_fn p ty
685

686
mkHsWrapPatCo :: TcCoercionN -> Pat id -> Type -> Pat id
687
mkHsWrapPatCo co pat ty | isTcReflCo co = pat
688
                        | otherwise     = CoPat (mkWpCastN co) pat ty
689 690 691

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

{-
694
l
Austin Seipp's avatar
Austin Seipp committed
695 696
************************************************************************
*                                                                      *
697
                Bindings; with a location at the top
Austin Seipp's avatar
Austin Seipp committed
698 699 700
*                                                                      *
************************************************************************
-}
701

702 703
mkFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)]
          -> HsBind RdrName
704
-- Not infix, with place holders for coercion and free vars
705
mkFunBind fn ms = FunBind { fun_id = fn
706 707
                          , fun_matches = mkMatchGroup Generated ms
                          , fun_co_fn = idHsWrapper
708
                          , bind_fvs = placeHolderNames
709
                          , fun_tick = [] }
710

711 712
mkTopFunBind :: Origin -> Located Name -> [LMatch Name (LHsExpr Name)]
             -> HsBind Name
713
-- In Name-land, with empty bind_fvs
714
mkTopFunBind origin fn ms = FunBind { fun_id = fn
715
                                    , fun_matches = mkMatchGroup origin ms
716
                                    , fun_co_fn = idHsWrapper
717 718
                                    , bind_fvs = emptyNameSet -- NB: closed
                                                              --     binding
719
                                    , fun_tick = [] }
720

721
mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
722 723 724 725
mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs

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

728 729
mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName)
             -> LPat RdrName -> HsPatSynDir RdrName -> HsBind RdrName
730 731 732 733 734 735 736
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
737

738 739 740 741
-- |If any of the matches in the 'FunBind' are infix, the 'FunBind' is
-- considered infix.
isInfixFunBind :: HsBindLR id1 id2 -> Bool
isInfixFunBind (FunBind _ (MG matches _ _ _) _ _ _)
742
  = any (isInfixMatch . unLoc) (unLoc matches)
743 744 745
isInfixFunBind _ = False


746
------------
747
mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
748
                -> LHsExpr RdrName -> LHsBind RdrName
749
mk_easy_FunBind loc fun pats expr
750 751 752
  = L loc $ mkFunBind (L loc fun)
              [mkMatch (FunRhs (L loc fun) Prefix) pats expr
                       (noLoc emptyLocalBinds)]
753

754
------------
755 756 757 758
mkMatch :: HsMatchContext (NameOrRdrName id) -> [LPat id] -> LHsExpr id
        -> Located (HsLocalBinds id) -> LMatch id (LHsExpr id)
mkMatch ctxt pats expr lbinds
  = noLoc (Match ctxt (map paren pats) Nothing
759
                 (GRHSs (unguardedRHS noSrcSpan expr) lbinds))
760
  where
761 762
    paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp)
                     | otherwise          = lp
763

Austin Seipp's avatar
Austin Seipp committed
764 765 766
{-
************************************************************************
*                                                                      *
767
        Collecting binders
Austin Seipp's avatar
Austin Seipp committed
768 769
*                                                                      *
************************************************************************
770 771 772 773 774 775 776 777 778 779 780

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).

781 782 783
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
784
to return a [Name] or [Id].  Before renaming the record punning
785 786
and wild-card mechanism makes it hard to know what is bound.
So these functions should not be applied to (HsSyn RdrName)
Richard Eisenberg's avatar
Richard Eisenberg committed
787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830

Note [Unlifted id check in isHsUnliftedBind]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose there is a binding with the type (Num a => (# a, a #)). Is this a
strict binding that should be disallowed at the top level? At first glance,
no, because it's a function. But consider how this is desugared via
AbsBinds:

  -- x :: Num a => (# a, a #)
  x = (# 3, 4 #)

becomes

  x = \ $dictNum ->
      let x_mono = (# fromInteger $dictNum 3, fromInteger $dictNum 4 #) in
      x_mono

Note that the inner let is strict. And thus if we have a bunch of mutually
recursive bindings of this form, we could end up in trouble. This was shown
up in #9140.

But if there is a type signature on x, everything changes because of the
desugaring used by AbsBindsSig:

  x :: Num a => (# a, a #)
  x = (# 3, 4 #)

becomes

  x = \ $dictNum -> (# fromInteger $dictNum 3, fromInteger $dictNum 4 #)

No strictness anymore! The bottom line here is that, for inferred types, we
care about the strictness of the type after the =>. For checked types
(AbsBindsSig), we care about the overall strictness.

This matters. If we don't separate out the AbsBindsSig case, then GHC runs into
a problem when compiling

  undefined :: forall (r :: RuntimeRep) (a :: TYPE r). HasCallStack => a

Looking only after the =>, we cannot tell if this is strict or not. (GHC panics
if you try.) Looking at the whole type, on the other hand, tells you that this
is a lifted function type, with no trouble at all.

Austin Seipp's avatar
Austin Seipp committed
831
-}
832 833

----------------- Bindings --------------------------
Richard Eisenberg's avatar
Richard Eisenberg committed
834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852

-- | Should we treat this as an unlifted bind? This will be true for any
-- bind that binds an unlifted variable, but we must be careful around
-- AbsBinds. See Note [Unlifted id check in isUnliftedHsBind]. For usage
-- information, see Note [Strict binds check] is DsBinds.
isUnliftedHsBind :: HsBind Id -> Bool  -- works only over typechecked binds
isUnliftedHsBind (AbsBindsSig { abs_sig_export = id })
  = isUnliftedType (idType id)
isUnliftedHsBind bind
  = any is_unlifted_id (collectHsBindBinders bind)
  where
    is_unlifted_id id
      = case tcSplitSigmaTy (idType id) of
          (_, _, tau) -> isUnliftedType tau
          -- For the is_unlifted che