HsUtils.hs 49.4 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, mkHsAppTypes, 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,
Ben Gamari's avatar
Ben Gamari 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

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

92 93
#include "HsVersions.h"

94 95
import GhcPrelude

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

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

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

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

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

Ben Gamari's avatar
Ben Gamari committed
142 143
mkHsPar :: LHsExpr id -> LHsExpr id
mkHsPar e = L (getLoc e) (HsPar e)
144

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

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

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

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

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

Ben Gamari's avatar
Ben Gamari committed
176 177
mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)
178

Ben Gamari's avatar
Ben Gamari committed
179 180
mkHsAppType :: LHsExpr name -> LHsWcType name -> LHsExpr name
mkHsAppType e t = addCLoc e (hswc_body t) (HsAppType e t)
181

Ben Gamari's avatar
Ben Gamari committed
182
mkHsAppTypes :: LHsExpr name -> [LHsWcType name] -> LHsExpr name
183 184
mkHsAppTypes = foldl mkHsAppType

185
mkHsAppTypeOut :: LHsExpr GhcTc -> LHsWcType GhcRn -> LHsExpr GhcTc
Ben Gamari's avatar
Ben Gamari committed
186
mkHsAppTypeOut e t = addCLoc e (hswc_body t) (HsAppTypeOut e t)
187

188
mkHsLam :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
Ben Gamari's avatar
Ben Gamari committed
189
mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
190 191 192
  where
    matches = mkMatchGroup Generated
                           [mkSimpleMatch LambdaExpr pats body]
193

194
mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc
195 196
mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars
                                       <.> mkWpLams dicts) expr
197

198 199 200 201 202
-- |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
203

Ben Gamari's avatar
Ben Gamari committed
204 205
nlHsTyApp :: IdP name -> [Type] -> LHsExpr name
nlHsTyApp fun_id tys = noLoc (mkHsWrap (mkWpTyApps tys) (HsVar (noLoc fun_id)))
206

Ben Gamari's avatar
Ben Gamari committed
207
nlHsTyApps :: IdP name -> [Type] -> [LHsExpr name] -> LHsExpr name
208 209
nlHsTyApps fun_id tys xs = foldl nlHsApp (nlHsTyApp fun_id tys) xs

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

Ben Gamari's avatar
Ben Gamari committed
217 218
mkParPat :: LPat name -> LPat name
mkParPat lp@(L loc p) | hsPatNeedsParens p = L loc (ParPat lp)
219 220
                      | otherwise          = lp

Ben Gamari's avatar
Ben Gamari committed
221 222
nlParPat :: LPat name -> LPat name
nlParPat p = noLoc (ParPat p)
223

224
-------------------------------
225 226 227
-- These are the bits of syntax that contain rebindable names
-- See RnEnv.lookupSyntaxName

Ben Gamari's avatar
Ben Gamari committed
228 229 230 231 232
mkHsIntegral   :: IntegralLit -> PostTc GhcPs Type
               -> HsOverLit GhcPs
mkHsFractional :: FractionalLit -> PostTc GhcPs Type -> HsOverLit GhcPs
mkHsIsString :: SourceText -> FastString -> PostTc GhcPs Type
             -> HsOverLit GhcPs
233 234 235 236 237 238 239 240
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

Ben Gamari's avatar
Ben Gamari committed
241 242
mkLastStmt :: SourceTextX idR
           => Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR))
243 244
mkBodyStmt :: Located (bodyR GhcPs)
           -> StmtLR idL GhcPs (Located (bodyR GhcPs))
Ben Gamari's avatar
Ben Gamari committed
245 246 247
mkBindStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
           => LPat idL -> Located (bodyR idR)
           -> StmtLR idL idR (Located (bodyR idR))
248 249
mkTcBindStmt :: LPat GhcTc -> Located (bodyR GhcTc)
             -> StmtLR GhcTc GhcTc (Located (bodyR GhcTc))
250

Ben Gamari's avatar
Ben Gamari committed
251
emptyRecStmt     :: StmtLR idL  GhcPs bodyR
252 253 254
emptyRecStmtName :: StmtLR GhcRn GhcRn bodyR
emptyRecStmtId   :: StmtLR GhcTc GhcTc bodyR
mkRecStmt    :: [LStmtLR idL GhcPs bodyR] -> StmtLR idL GhcPs bodyR
twanvl's avatar
twanvl committed
255 256


Ben Gamari's avatar
Ben Gamari committed
257 258 259
mkHsIntegral     i  = OverLit (HsIntegral       i) noRebindableInfo noExpr
mkHsFractional   f  = OverLit (HsFractional     f) noRebindableInfo noExpr
mkHsIsString src s  = OverLit (HsIsString   src s) noRebindableInfo noExpr
260

261
noRebindableInfo :: PlaceHolder
Ben Gamari's avatar
Ben Gamari committed
262
noRebindableInfo = PlaceHolder -- Just another placeholder;
263

Ben Gamari's avatar
Ben Gamari committed
264
mkHsDo ctxt stmts = HsDo ctxt (mkLocatedList stmts) placeHolderType
265 266 267
mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt])
  where
    last_stmt = L (getLoc expr) $ mkLastStmt expr
268

Ben Gamari's avatar
Ben Gamari committed
269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289
mkHsIf :: SourceTextX p => LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b

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

mkTransformStmt    :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
                   => [ExprLStmt idL] -> LHsExpr idR
                   -> StmtLR idL idR (LHsExpr idL)
mkTransformByStmt  :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
                   => [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR
                   -> StmtLR idL idR (LHsExpr idL)
mkGroupUsingStmt   :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
                   => [ExprLStmt idL]                -> LHsExpr idR
                   -> StmtLR idL idR (LHsExpr idL)
mkGroupByUsingStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
                   => [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR
                   -> StmtLR idL idR (LHsExpr idL)

emptyTransStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
               => StmtLR idL idR (LHsExpr idR)
290
emptyTransStmt = TransStmt { trS_form = panic "emptyTransStmt: form"
291
                           , trS_stmts = [], trS_bndrs = []
292
                           , trS_by = Nothing, trS_using = noLoc noExpr
293
                           , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr
Ben Gamari's avatar
Ben Gamari committed
294
                           , trS_bind_arg_ty = PlaceHolder
295
                           , trS_fmap = noExpr }
296 297 298 299
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 }
300

Simon Marlow's avatar
Simon Marlow committed
301
mkLastStmt body     = LastStmt body False noSyntaxExpr
302
mkBodyStmt body     = BodyStmt body noSyntaxExpr noSyntaxExpr placeHolderType
Ben Gamari's avatar
Ben Gamari committed
303
mkBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr PlaceHolder
304 305
mkTcBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr unitTy
  -- don't use placeHolderTypeTc above, because that panics during zonking
306

Ben Gamari's avatar
Ben Gamari committed
307 308
emptyRecStmt' :: forall idL idR body. SourceTextX idR =>
                       PostTc idR Type -> StmtLR idL idR body
309 310 311 312 313 314
emptyRecStmt' tyVal =
   RecStmt
     { recS_stmts = [], recS_later_ids = []
     , recS_rec_ids = []
     , recS_ret_fn = noSyntaxExpr
     , recS_mfix_fn = noSyntaxExpr
315 316
     , recS_bind_fn = noSyntaxExpr, recS_bind_ty = tyVal
     , recS_later_rets = []
317 318 319 320
     , recS_rec_rets = [], recS_ret_ty = tyVal }

emptyRecStmt     = emptyRecStmt' placeHolderType
emptyRecStmtName = emptyRecStmt' placeHolderType
321
emptyRecStmtId   = emptyRecStmt' unitTy -- a panic might trigger during zonking
322
mkRecStmt stmts  = emptyRecStmt { recS_stmts = stmts }
323 324

-------------------------------
325 326
--- A useful function for building @OpApps@.  The operator is always a
-- variable, and we don't know the fixity yet.
Ben Gamari's avatar
Ben Gamari committed
327 328 329
mkHsOpApp :: LHsExpr id -> IdP id -> LHsExpr id -> HsExpr id
mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar (noLoc op)))
                           (error "mkOpApp:fixity") e2
330

331 332 333
unqualSplice :: RdrName
unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))

334
mkUntypedSplice :: SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs
Ben Gamari's avatar
Ben Gamari committed
335
mkUntypedSplice hasParen e = HsUntypedSplice hasParen unqualSplice e
336

337
mkHsSpliceE :: SpliceDecoration -> LHsExpr GhcPs -> HsExpr GhcPs
Ben Gamari's avatar
Ben Gamari committed
338
mkHsSpliceE hasParen e = HsSpliceE (mkUntypedSplice hasParen e)
339

340
mkHsSpliceTE :: SpliceDecoration -> LHsExpr GhcPs -> HsExpr GhcPs
Ben Gamari's avatar
Ben Gamari committed
341
mkHsSpliceTE hasParen e = HsSpliceE (HsTypedSplice hasParen unqualSplice e)
342

343
mkHsSpliceTy :: SpliceDecoration -> LHsExpr GhcPs -> HsType GhcPs
Ben Gamari's avatar
Ben Gamari committed
344 345
mkHsSpliceTy hasParen e
  = HsSpliceTy (HsUntypedSplice hasParen unqualSplice e) placeHolderKind
346

347
mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice GhcPs
Ben Gamari's avatar
Ben Gamari committed
348
mkHsQuasiQuote quoter span quote = HsQuasiQuote unqualSplice quoter span quote
349

twanvl's avatar
twanvl committed
350
unqualQuasiQuote :: RdrName
Ian Lynagh's avatar
Ian Lynagh committed
351
unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
352 353
                -- A name (uniquified later) to
                -- identify the quasi-quote
354

355 356
mkHsString :: SourceTextX p => String -> HsLit p
mkHsString s = HsString noSourceText (mkFastString s)
357

358
mkHsStringPrimLit :: SourceTextX p => FastString -> HsLit p
359
mkHsStringPrimLit fs
360
  = HsStringPrim noSourceText (fastStringToByteString fs)
361

362
-------------
Ben Gamari's avatar
Ben Gamari committed
363
userHsLTyVarBndrs :: SrcSpan -> [Located (IdP name)] -> [LHsTyVarBndr name]
364
-- Caller sets location
Ben Gamari's avatar
Ben Gamari committed
365
userHsLTyVarBndrs loc bndrs = [ L loc (UserTyVar v) | v <- bndrs ]
366

Ben Gamari's avatar
Ben Gamari committed
367
userHsTyVarBndrs :: SrcSpan -> [IdP name] -> [LHsTyVarBndr name]
368
-- Caller sets location
Ben Gamari's avatar
Ben Gamari committed
369
userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar (L loc v)) | v <- bndrs ]
370

371

Austin Seipp's avatar
Austin Seipp committed
372 373 374
{-
************************************************************************
*                                                                      *
375
        Constructing syntax with no location info
Austin Seipp's avatar
Austin Seipp committed
376 377 378
*                                                                      *
************************************************************************
-}
379

Ben Gamari's avatar
Ben Gamari committed
380 381
nlHsVar :: IdP id -> LHsExpr id
nlHsVar n = noLoc (HsVar (noLoc n))
382

Richard Eisenberg's avatar
Richard Eisenberg committed
383
-- NB: Only for LHsExpr **Id**
384
nlHsDataCon :: DataCon -> LHsExpr GhcTc
Ben Gamari's avatar
Ben Gamari committed
385
nlHsDataCon con = noLoc (HsConLikeOut (RealDataCon con))
Richard Eisenberg's avatar
Richard Eisenberg committed
386

Ben Gamari's avatar
Ben Gamari committed
387 388
nlHsLit :: HsLit p -> LHsExpr p
nlHsLit n = noLoc (HsLit n)
389

Ben Gamari's avatar
Ben Gamari committed
390 391
nlHsIntLit :: HasDefaultX p => Integer -> LHsExpr p
nlHsIntLit n = noLoc (HsLit (HsInt def (mkIntegralLit n)))
392

Ben Gamari's avatar
Ben Gamari committed
393 394
nlVarPat :: IdP id -> LPat id
nlVarPat n = noLoc (VarPat (noLoc n))
395

Ben Gamari's avatar
Ben Gamari committed
396 397
nlLitPat :: HsLit p -> LPat p
nlLitPat l = noLoc (LitPat l)
398

Ben Gamari's avatar
Ben Gamari committed
399 400
nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
nlHsApp f x = noLoc (HsApp f (mkLHsPar x))
401

Ben Gamari's avatar
Ben Gamari committed
402
nlHsSyntaxApps :: SyntaxExpr id -> [LHsExpr id] -> LHsExpr id
403 404 405 406 407 408 409 410 411 412 413
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))

Ben Gamari's avatar
Ben Gamari committed
414
nlHsApps :: IdP id -> [LHsExpr id] -> LHsExpr id
415
nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
416

Ben Gamari's avatar
Ben Gamari committed
417 418
nlHsVarApps :: IdP id -> [IdP id] -> LHsExpr id
nlHsVarApps f xs = noLoc (foldl mk (HsVar (noLoc f)) (map (HsVar . noLoc) xs))
419
                 where
Ben Gamari's avatar
Ben Gamari committed
420
                   mk f a = HsApp (noLoc f) (noLoc a)
421

422
nlConVarPat :: RdrName -> [RdrName] -> LPat GhcPs
423 424
nlConVarPat con vars = nlConPat con (map nlVarPat vars)

425
nlConVarPatName :: Name -> [Name] -> LPat GhcRn
Adam Gundry's avatar
Adam Gundry committed
426 427
nlConVarPatName con vars = nlConPatName con (map nlVarPat vars)

428
nlInfixConPat :: IdP id -> LPat id -> LPat id -> LPat id
429 430
nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))

431
nlConPat :: RdrName -> [LPat GhcPs] -> LPat GhcPs
432 433
nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))

434
nlConPatName :: Name -> [LPat GhcRn] -> LPat GhcRn
435 436
nlConPatName con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))

437
nlNullaryConPat :: IdP id -> LPat id
438 439
nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))

440
nlWildConPat :: DataCon -> LPat GhcPs
441
nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
442 443
                         (PrefixCon (nOfThem (dataConSourceArity con)
                                             nlWildPat)))
444

445
nlWildPat :: LPat GhcPs
Ben Gamari's avatar
Ben Gamari committed
446
nlWildPat  = noLoc (WildPat placeHolderType )  -- Pre-typechecking
447

448
nlWildPatName :: LPat GhcRn
Ben Gamari's avatar
Ben Gamari committed
449 450 451 452
nlWildPatName  = noLoc (WildPat placeHolderType )  -- Pre-typechecking

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

454 455
nlHsDo :: HsStmtContext Name -> [LStmt GhcPs (LHsExpr GhcPs)]
       -> LHsExpr GhcPs
456
nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)
457

Ben Gamari's avatar
Ben Gamari committed
458
nlHsOpApp :: LHsExpr id -> IdP id -> LHsExpr id -> LHsExpr id
459 460
nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)

461
nlHsLam  :: LMatch GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs
Ben Gamari's avatar
Ben Gamari committed
462 463
nlHsPar  :: LHsExpr id -> LHsExpr id
nlHsIf   :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id
464 465 466
nlHsCase :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)]
         -> LHsExpr GhcPs
nlList   :: [LHsExpr GhcPs] -> LHsExpr GhcPs
twanvl's avatar
twanvl committed
467

Ben Gamari's avatar
Ben Gamari committed
468 469
nlHsLam match          = noLoc (HsLam (mkMatchGroup Generated [match]))
nlHsPar e              = noLoc (HsPar e)
470 471 472 473

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

Ben Gamari's avatar
Ben Gamari committed
476 477
nlHsCase expr matches  = noLoc (HsCase expr (mkMatchGroup Generated matches))
nlList exprs           = noLoc (ExplicitList placeHolderType Nothing exprs)
478

Ben Gamari's avatar
Ben Gamari committed
479 480 481 482
nlHsAppTy :: LHsType name -> LHsType name -> LHsType name
nlHsTyVar :: IdP name                     -> LHsType name
nlHsFunTy :: LHsType name -> LHsType name -> LHsType name
nlHsParTy :: LHsType name                 -> LHsType name
twanvl's avatar
twanvl committed
483

Ben Gamari's avatar
Ben Gamari committed
484 485 486 487
nlHsAppTy f t           = noLoc (HsAppTy f t)
nlHsTyVar x             = noLoc (HsTyVar NotPromoted (noLoc x))
nlHsFunTy a b           = noLoc (HsFunTy a b)
nlHsParTy t             = noLoc (HsParTy t)
488

Ben Gamari's avatar
Ben Gamari committed
489
nlHsTyConApp :: IdP name -> [LHsType name] -> LHsType name
490
nlHsTyConApp tycon tys  = foldl nlHsAppTy (nlHsTyVar tycon) tys
491

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

Ben Gamari's avatar
Ben Gamari committed
497
mkLHsTupleExpr :: [LHsExpr a] -> LHsExpr a
498 499
-- Makes a pre-typechecker boxed tuple, deals with 1 case
mkLHsTupleExpr [e] = e
Ben Gamari's avatar
Ben Gamari committed
500
mkLHsTupleExpr es  = noLoc $ ExplicitTuple (map (noLoc . Present) es) Boxed
501

Ben Gamari's avatar
Ben Gamari committed
502
mkLHsVarTuple :: [IdP a] -> LHsExpr a
503
mkLHsVarTuple ids  = mkLHsTupleExpr (map nlHsVar ids)
504

Ben Gamari's avatar
Ben Gamari committed
505 506
nlTuplePat :: [LPat id] -> Boxity -> LPat id
nlTuplePat pats box = noLoc (TuplePat pats box [])
507

508
missingTupArg :: HsTupArg GhcPs
Ben Gamari's avatar
Ben Gamari committed
509
missingTupArg = Missing placeHolderType
510

Ben Gamari's avatar
Ben Gamari committed
511 512
mkLHsPatTup :: [LPat id] -> LPat id
mkLHsPatTup []     = noLoc $ TuplePat [] Boxed []
Simon Marlow's avatar
Simon Marlow committed
513
mkLHsPatTup [lpat] = lpat
Ben Gamari's avatar
Ben Gamari committed
514
mkLHsPatTup lpats  = L (getLoc (head lpats)) $ TuplePat lpats Boxed []
Simon Marlow's avatar
Simon Marlow committed
515 516

-- The Big equivalents for the source tuple expressions
Ben Gamari's avatar
Ben Gamari committed
517
mkBigLHsVarTup :: [IdP id] -> LHsExpr id
Simon Marlow's avatar
Simon Marlow committed
518 519
mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids)

Ben Gamari's avatar
Ben Gamari committed
520
mkBigLHsTup :: [LHsExpr id] -> LHsExpr id
Simon Marlow's avatar
Simon Marlow committed
521 522 523
mkBigLHsTup = mkChunkified mkLHsTupleExpr

-- The Big equivalents for the source tuple patterns
Ben Gamari's avatar
Ben Gamari committed
524
mkBigLHsVarPatTup :: [IdP id] -> LPat id
Simon Marlow's avatar
Simon Marlow committed
525 526
mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs)

Ben Gamari's avatar
Ben Gamari committed
527
mkBigLHsPatTup :: [LPat id] -> LPat id
Simon Marlow's avatar
Simon Marlow committed
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 567 568 569 570
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
571 572 573
{-
************************************************************************
*                                                                      *
574
        LHsSigType and LHsSigWcType
Austin Seipp's avatar
Austin Seipp committed
575
*                                                                      *
576
********************************************************************* -}
577

578
mkLHsSigType :: LHsType GhcPs -> LHsSigType GhcPs
579
mkLHsSigType ty = mkHsImplicitBndrs ty
580

581
mkLHsSigWcType :: LHsType GhcPs -> LHsSigWcType GhcPs
582
mkLHsSigWcType ty = mkHsWildCardBndrs (mkHsImplicitBndrs ty)
583

584 585
mkHsSigEnv :: forall a. (LSig GhcRn -> Maybe ([Located Name], a))
                     -> [LSig GhcRn]
586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605
                     -> 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

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

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

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

653
    go_tv :: TyVar -> LHsTyVarBndr GhcPs
Ben Gamari's avatar
Ben Gamari committed
654
    go_tv tv = noLoc $ KindedTyVar (noLoc (getRdrName tv))
655
                                   (go (tyVarKind tv))
656 657


658 659 660 661 662 663
{- *********************************************************************
*                                                                      *
    --------- HsWrappers: type args, dict args, casts ---------
*                                                                      *
********************************************************************* -}

Ben Gamari's avatar
Ben Gamari committed
664
mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id
665 666
mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)

667 668
-- Avoid (HsWrap co (HsWrap co' _)).
-- See Note [Detecting forced eta expansion] in DsExpr
Ben Gamari's avatar
Ben Gamari committed
669
mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id
670
mkHsWrap co_fn e | isIdHsWrapper co_fn = e
Ben Gamari's avatar
Ben Gamari committed
671 672
mkHsWrap co_fn (HsWrap co_fn' e)       = mkHsWrap (co_fn <.> co_fn') e
mkHsWrap co_fn e                       = HsWrap co_fn e
673

674
mkHsWrapCo :: TcCoercionN   -- A Nominal coercion  a ~N b
Ben Gamari's avatar
Ben Gamari committed
675
           -> HsExpr id -> HsExpr id
676
mkHsWrapCo co e = mkHsWrap (mkWpCastN co) e
677

678
mkHsWrapCoR :: TcCoercionR   -- A Representational coercion  a ~R b
Ben Gamari's avatar
Ben Gamari committed
679
            -> HsExpr id -> HsExpr id
680
mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e
681

Ben Gamari's avatar
Ben Gamari committed
682
mkLHsWrapCo :: TcCoercionN -> LHsExpr id -> LHsExpr id
Joachim Breitner's avatar
Joachim Breitner committed
683
mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e)
684

Ben Gamari's avatar
Ben Gamari committed
685
mkHsCmdWrap :: HsWrapper -> HsCmd id -> HsCmd id
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
686
mkHsCmdWrap w cmd | isIdHsWrapper w = cmd
Ben Gamari's avatar
Ben Gamari committed
687
                  | otherwise       = HsCmdWrap w cmd
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
688

Ben Gamari's avatar
Ben Gamari committed
689
mkLHsCmdWrap :: HsWrapper -> LHsCmd id -> LHsCmd id
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
690
mkLHsCmdWrap w (L loc c) = L loc (mkHsCmdWrap w c)
691

Ben Gamari's avatar
Ben Gamari committed
692
mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id
693
mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
Ben Gamari's avatar
Ben Gamari committed
694
                       | otherwise           = CoPat co_fn p ty
695

Ben Gamari's avatar
Ben Gamari committed
696
mkHsWrapPatCo :: TcCoercionN -> Pat id -> Type -> Pat id
697
mkHsWrapPatCo co pat ty | isTcReflCo co = pat
Ben Gamari's avatar
Ben Gamari committed
698
                        | otherwise     = CoPat (mkWpCastN co) pat ty
699

700
mkHsDictLet :: TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc
701
mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr
Austin Seipp's avatar
Austin Seipp committed
702 703

{-
704
l
Austin Seipp's avatar
Austin Seipp committed
705 706
************************************************************************
*                                                                      *
707
                Bindings; with a location at the top
Austin Seipp's avatar
Austin Seipp committed
708 709 710
*                                                                      *
************************************************************************
-}
711

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

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

731
mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
732 733
mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs

734
mkVarBind :: IdP p -> LHsExpr p -> LHsBind p
735
mkVarBind var rhs = L (getLoc rhs) $
736
                    VarBind { var_id = var, var_rhs = rhs, var_inline = False }
737

738
mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName)
739
             -> LPat GhcPs -> HsPatSynDir GhcPs -> HsBind GhcPs
740 741 742 743 744 745 746
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
747

748 749 750 751
-- |If any of the matches in the 'FunBind' are infix, the 'FunBind' is
-- considered infix.
isInfixFunBind :: HsBindLR id1 id2 -> Bool
isInfixFunBind (FunBind _ (MG matches _ _ _) _ _ _)
752
  = any (isInfixMatch . unLoc) (unLoc matches)
753 754 755
isInfixFunBind _ = False


756
------------
757 758
mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat GhcPs]
                -> LHsExpr GhcPs -> LHsBind GhcPs
759
mk_easy_FunBind loc fun pats expr
760
  = L loc $ mkFunBind (L loc fun)
Ben Gamari's avatar
Ben Gamari committed
761
              [mkMatch (mkPrefixFunRhs (L loc fun)) pats expr
762
                       (noLoc emptyLocalBinds)]
763

Ben Gamari's avatar
Ben Gamari committed
764
-- | Make a prefix, non-strict function 'HsMatchContext'
Ben Gamari's avatar
Ben Gamari committed
765
mkPrefixFunRhs :: Located id -> HsMatchContext id
Simon Peyton Jones's avatar
Simon Peyton Jones committed
766 767 768
mkPrefixFunRhs n = FunRhs { mc_fun = n
                          , mc_fixity = Prefix
                          , mc_strictness = NoSrcStrict }
Ben Gamari's avatar
Ben Gamari committed
769

770
------------