RdrHsSyn.hs 88.2 KB
Newer Older
rodlogic's avatar
rodlogic committed
1 2 3
--
--  (c) The University of Glasgow 2002-2006
--
4

rodlogic's avatar
rodlogic committed
5
-- Functions over HsSyn specialised to RdrName.
6

7
{-# LANGUAGE CPP #-}
8
{-# LANGUAGE FlexibleContexts #-}
9
{-# LANGUAGE TypeFamilies #-}
10
{-# LANGUAGE MagicHash #-}
11

12
module   RdrHsSyn (
13 14
        mkHsOpApp,
        mkHsIntegral, mkHsFractional, mkHsIsString,
15
        mkHsDo, mkSpliceDecl,
16
        mkRoleAnnotDecl,
rodlogic's avatar
rodlogic committed
17 18
        mkClassDecl,
        mkTyData, mkDataFamInst,
19
        mkTySynonym, mkTyFamInstEqn,
rodlogic's avatar
rodlogic committed
20
        mkTyFamInst,
21
        mkFamDecl, mkLHsSigType,
22
        mkInlinePragma,
23
        mkPatSynMatchGroup,
24
        mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
25
        mkTyClD, mkInstD,
26
        mkRdrRecordCon, mkRdrRecordUpd,
27
        setRdrNameSpace,
28
        filterCTuple,
29

30
        cvBindGroup,
31
        cvBindsAndSigs,
32
        cvTopDecls,
33
        placeHolderPunRhs,
34

35 36
        -- Stuff to do with Foreign declarations
        mkImport,
37
        parseCImport,
38 39 40
        mkExport,
        mkExtName,           -- RdrName -> CLabelString
        mkGadtDecl,          -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName
Alan Zimmerman's avatar
Alan Zimmerman committed
41
        mkConDeclH98,
42
        mkATDefault,
43 44 45

        -- Bunch of functions in the parser monad for
        -- checking and constructing values
46
        checkBlockArguments,
47 48 49
        checkPrecP,           -- Int -> P Int
        checkContext,         -- HsType -> P HsContext
        checkPattern,         -- HsExp -> P HsPat
batterseapower's avatar
batterseapower committed
50
        bang_RDR,
51 52
        checkPatterns,        -- SrcLoc -> [HsExp] -> P [HsPat]
        checkMonadComp,       -- P (HsStmtContext RdrName)
53
        checkCommand,         -- LHsExpr RdrName -> P (LHsCmd RdrName)
54
        checkValDef,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
55
        checkValSigLhs,
56
        checkDoAndIfThenElse,
57 58 59
        LRuleTyTmVar, RuleTyTmVar(..),
        mkRuleBndrs, mkRuleTyVarBndrs,
        checkRuleTyVarBndrNames,
60
        checkRecordSyntax,
61
        checkEmptyGADTs,
62
        parseErrorSDoc, hintBangPat,
63
        TyEl(..), mergeOps, mergeDataCon,
64 65 66

        -- Help with processing exports
        ImpExpSubSpec(..),
67
        ImpExpQcSpec(..),
68
        mkModuleImpExp,
69 70
        mkTypeImpExp,
        mkImpExpSubSpec,
71 72
        checkImportSpec,

73 74 75 76
        -- Warnings and errors
        warnStarIsType,
        failOpFewArgs,

77
        SumOrTuple (..), mkSumOrTuple
78

79 80
    ) where

81
import GhcPrelude
82
import HsSyn            -- Lots of it
83 84 85
import TyCon            ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe )
import DataCon          ( DataCon, dataConTyCon )
import ConLike          ( ConLike(..) )
86
import CoAxiom          ( Role, fsFromRole )
87 88 89
import RdrName
import Name
import BasicTypes
90
import TcEvidence       ( idHsWrapper )
91
import Lexer
Simon Peyton Jones's avatar
Simon Peyton Jones committed
92
import Lexeme           ( isLexCon )
Alec Theriault's avatar
Alec Theriault committed
93
import Type             ( TyThing(..), funTyCon )
94 95
import TysWiredIn       ( cTupleTyConName, tupleTyCon, tupleDataCon,
                          nilDataConName, nilDataConKey,
96 97
                          listTyConName, listTyConKey, eqTyCon_RDR,
                          tupleTyConName, cTupleTyConNameArity_maybe )
98
import ForeignCall
99
import PrelNames        ( forall_tv_RDR, allNameStrings )
100
import SrcLoc
101
import Unique           ( hasKey )
102
import OrdList          ( OrdList, fromOL )
cactus's avatar
cactus committed
103
import Bag              ( emptyBag, consBag )
104 105
import Outputable
import FastString
106
import Maybes
107
import Util
Alan Zimmerman's avatar
Alan Zimmerman committed
108
import ApiAnnotation
109
import Data.List
110
import DynFlags ( WarningFlag(..) )
111

112
import Control.Monad
113
import Text.ParserCombinators.ReadP as ReadP
Ian Lynagh's avatar
Ian Lynagh committed
114
import Data.Char
115

116 117
import Data.Data       ( dataTypeOf, fromConstr, dataTypeConstrs )

118
#include "HsVersions.h"
119

120

rodlogic's avatar
rodlogic committed
121 122 123
{- **********************************************************************

  Construction functions for Rdr stuff
124

rodlogic's avatar
rodlogic committed
125
  ********************************************************************* -}
126

rodlogic's avatar
rodlogic committed
127 128 129 130 131
-- | mkClassDecl builds a RdrClassDecl, filling in the names for tycon and
-- datacon by deriving them from the name of the class.  We fill in the names
-- for the tycon and datacon corresponding to the class, by deriving them
-- from the name of the class itself.  This saves recording the names in the
-- interface file (which would be equally good).
132

rodlogic's avatar
rodlogic committed
133 134
-- Similarly for mkConDecl, mkClassOpSig and default-method names.

135
--         *** See Note [The Naming story] in HsDecls ****
136

137 138
mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p)
mkTyClD (L loc d) = L loc (TyClD noExt d)
139

140 141
mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p)
mkInstD (L loc d) = L loc (InstD noExt d)
142

143
mkClassDecl :: SrcSpan
144
            -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
145
            -> Located (a,[LHsFunDep GhcPs])
146 147
            -> OrdList (LHsDecl GhcPs)
            -> P (LTyClDecl GhcPs)
148

149
mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
150 151
  = do { (binds, sigs, ats, at_insts, _, docs) <- cvBindsAndSigs where_cls
       ; let cxt = fromMaybe (noLoc []) mcxt
152
       ; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr
Alan Zimmerman's avatar
Alan Zimmerman committed
153
       ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
154
       ; tyvars <- checkTyVarsP (text "class") whereDots cls tparams
155 156
       ; (at_defs, anns) <- fmap unzip $ mapM (eitherToP . mkATDefault) at_insts
       ; sequence_ anns
157 158
       ; return (L loc (ClassDecl { tcdCExt = noExt, tcdCtxt = cxt
                                  , tcdLName = cls, tcdTyVars = tyvars
159
                                  , tcdFixity = fixity
160 161 162
                                  , tcdFDs = snd (unLoc fds)
                                  , tcdSigs = mkClassOpSigs sigs
                                  , tcdMeths = binds
163 164
                                  , tcdATs = ats, tcdATDefs = at_defs
                                  , tcdDocs  = docs })) }
165

166
mkATDefault :: LTyFamInstDecl GhcPs
167 168 169
            -> Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs, P ())
-- ^ Take a type-family instance declaration and turn it into
-- a type-family default equation for a class declaration.
170
-- We parse things as the former and use this function to convert to the latter
rodlogic's avatar
rodlogic committed
171
--
172 173 174 175 176
-- We use the Either monad because this also called from "Convert".
--
-- The @P ()@ we return corresponds represents an action which will add
-- some necessary paren annotations to the parsing context. Naturally, this
-- is not something that the "Convert" use cares about.
177
mkATDefault (L loc (TyFamInstDecl { tfid_eqn = HsIB { hsib_body = e }}))
178 179
      | FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs, feqn_pats = pats
               , feqn_fixity = fixity, feqn_rhs = rhs } <- e
180 181
      = do { (tvs, anns) <- checkTyVars (text "default") equalsDots tc pats
           ; let f = L loc (FamEqn { feqn_ext    = noExt
182
                                   , feqn_tycon  = tc
183 184
                                   , feqn_bndrs  = ASSERT( isNothing bndrs )
                                                   Nothing
185 186
                                   , feqn_pats   = tvs
                                   , feqn_fixity = fixity
187 188
                                   , feqn_rhs    = rhs })
           ; pure (f, anns) }
189 190
mkATDefault (L _ (TyFamInstDecl (HsIB _ (XFamEqn _)))) = panic "mkATDefault"
mkATDefault (L _ (TyFamInstDecl (XHsImplicitBndrs _))) = panic "mkATDefault"
191

192 193
mkTyData :: SrcSpan
         -> NewOrData
194
         -> Maybe (Located CType)
195 196 197 198 199
         -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
         -> Maybe (LHsKind GhcPs)
         -> [LConDecl GhcPs]
         -> HsDeriving GhcPs
         -> P (LTyClDecl GhcPs)
200
mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
201
  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
Alan Zimmerman's avatar
Alan Zimmerman committed
202
       ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
203
       ; tyvars <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams
204
       ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
205 206
       ; return (L loc (DataDecl { tcdDExt = noExt,
                                   tcdLName = tc, tcdTyVars = tyvars,
207
                                   tcdFixity = fixity,
208
                                   tcdDataDefn = defn })) }
209

210
mkDataDefn :: NewOrData
211
           -> Maybe (Located CType)
212 213 214 215 216
           -> Maybe (LHsContext GhcPs)
           -> Maybe (LHsKind GhcPs)
           -> [LConDecl GhcPs]
           -> HsDeriving GhcPs
           -> P (HsDataDefn GhcPs)
217 218
mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
  = do { checkDatatypeContext mcxt
219
       ; let cxt = fromMaybe (noLoc []) mcxt
220 221
       ; return (HsDataDefn { dd_ext = noExt
                            , dd_ND = new_or_data, dd_cType = cType
rodlogic's avatar
rodlogic committed
222
                            , dd_ctxt = cxt
223 224 225
                            , dd_cons = data_cons
                            , dd_kindSig = ksig
                            , dd_derivs = maybe_deriv }) }
thomasw's avatar
thomasw committed
226

227

228
mkTySynonym :: SrcSpan
229 230 231
            -> LHsType GhcPs  -- LHS
            -> LHsType GhcPs  -- RHS
            -> P (LTyClDecl GhcPs)
232
mkTySynonym loc lhs rhs
233
  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
Alan Zimmerman's avatar
Alan Zimmerman committed
234
       ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
235
       ; tyvars <- checkTyVarsP (text "type") equalsDots tc tparams
236 237
       ; return (L loc (SynDecl { tcdSExt = noExt
                                , tcdLName = tc, tcdTyVars = tyvars
238
                                , tcdFixity = fixity
239
                                , tcdRhs = rhs })) }
240

241 242
mkTyFamInstEqn :: Maybe [LHsTyVarBndr GhcPs]
               -> LHsType GhcPs
243 244
               -> LHsType GhcPs
               -> P (TyFamInstEqn GhcPs,[AddAnn])
245
mkTyFamInstEqn bndrs lhs rhs
246
  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
247
       ; return (mkHsImplicitBndrs
248 249
                  (FamEqn { feqn_ext    = noExt
                          , feqn_tycon  = tc
250
                          , feqn_bndrs  = bndrs
251 252 253
                          , feqn_pats   = tparams
                          , feqn_fixity = fixity
                          , feqn_rhs    = rhs }),
Alan Zimmerman's avatar
Alan Zimmerman committed
254
                 ann) }
255

256
mkDataFamInst :: SrcSpan
Jan Stolarek's avatar
Jan Stolarek committed
257 258
              -> NewOrData
              -> Maybe (Located CType)
259
              -> Located (Maybe (LHsContext GhcPs), Maybe [LHsTyVarBndr GhcPs], LHsType GhcPs)
260 261 262 263
              -> Maybe (LHsKind GhcPs)
              -> [LConDecl GhcPs]
              -> HsDeriving GhcPs
              -> P (LInstDecl GhcPs)
264
mkDataFamInst loc new_or_data cType (L _ (mcxt, bndrs, tycl_hdr)) ksig data_cons maybe_deriv
265
  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
Alan Zimmerman's avatar
Alan Zimmerman committed
266
       ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
267
       ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
268 269 270
       ; return (L loc (DataFamInstD noExt (DataFamInstDecl (mkHsImplicitBndrs
                  (FamEqn { feqn_ext    = noExt
                          , feqn_tycon  = tc
271
                          , feqn_bndrs  = bndrs
272
                          , feqn_pats   = tparams
273
                          , feqn_fixity = fixity
274
                          , feqn_rhs    = defn }))))) }
275

276
mkTyFamInst :: SrcSpan
277
            -> TyFamInstEqn GhcPs
278
            -> P (LInstDecl GhcPs)
279
mkTyFamInst loc eqn
280
  = return (L loc (TyFamInstD noExt (TyFamInstDecl eqn)))
281 282

mkFamDecl :: SrcSpan
283 284 285 286 287
          -> FamilyInfo GhcPs
          -> LHsType GhcPs                   -- LHS
          -> Located (FamilyResultSig GhcPs) -- Optional result signature
          -> Maybe (LInjectivityAnn GhcPs)   -- Injectivity annotation
          -> P (LTyClDecl GhcPs)
Jan Stolarek's avatar
Jan Stolarek committed
288
mkFamDecl loc info lhs ksig injAnn
289
  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
Alan Zimmerman's avatar
Alan Zimmerman committed
290
       ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
291
       ; tyvars <- checkTyVarsP (ppr info) equals_or_where tc tparams
292 293 294
       ; return (L loc (FamDecl noExt (FamilyDecl
                                           { fdExt       = noExt
                                           , fdInfo      = info, fdLName = tc
Jan Stolarek's avatar
Jan Stolarek committed
295
                                           , fdTyVars    = tyvars
296
                                           , fdFixity    = fixity
Jan Stolarek's avatar
Jan Stolarek committed
297 298
                                           , fdResultSig = ksig
                                           , fdInjectivityAnn = injAnn }))) }
299 300 301 302 303
  where
    equals_or_where = case info of
                        DataFamily          -> empty
                        OpenTypeFamily      -> empty
                        ClosedTypeFamily {} -> whereDots
304

305
mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs
306
-- If the user wrote
307
--      [pads| ... ]   then return a QuasiQuoteD
308
--      $(e)           then return a SpliceD
309 310
-- but if she wrote, say,
--      f x            then behave as if she'd written $(f x)
311
--                     ie a SpliceD
312 313 314
--
-- Typed splices are not allowed at the top level, thus we do not represent them
-- as spliced declaration.  See #10945
315
mkSpliceDecl lexpr@(L loc expr)
316
  | HsSpliceE _ splice@(HsUntypedSplice {}) <- expr
317
  = SpliceD noExt (SpliceDecl noExt (L loc splice) ExplicitSplice)
318

319
  | HsSpliceE _ splice@(HsQuasiQuote {}) <- expr
320
  = SpliceD noExt (SpliceDecl noExt (L loc splice) ExplicitSplice)
321 322

  | otherwise
323 324
  = SpliceD noExt (SpliceDecl noExt (L loc (mkUntypedSplice NoParens lexpr))
                              ImplicitSplice)
325

326
mkRoleAnnotDecl :: SrcSpan
327
                -> Located RdrName                -- type being annotated
328
                -> [Located (Maybe FastString)]      -- roles
329
                -> P (LRoleAnnotDecl GhcPs)
330 331
mkRoleAnnotDecl loc tycon roles
  = do { roles' <- mapM parse_role roles
332
       ; return $ L loc $ RoleAnnotDecl noExt tycon roles' }
333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352
  where
    role_data_type = dataTypeOf (undefined :: Role)
    all_roles = map fromConstr $ dataTypeConstrs role_data_type
    possible_roles = [(fsFromRole role, role) | role <- all_roles]

    parse_role (L loc_role Nothing) = return $ L loc_role Nothing
    parse_role (L loc_role (Just role))
      = case lookup role possible_roles of
          Just found_role -> return $ L loc_role $ Just found_role
          Nothing         ->
            let nearby = fuzzyLookup (unpackFS role) (mapFst unpackFS possible_roles) in
            parseErrorSDoc loc_role
              (text "Illegal role name" <+> quotes (ppr role) $$
               suggestions nearby)

    suggestions []   = empty
    suggestions [r]  = text "Perhaps you meant" <+> quotes (ppr r)
      -- will this last case ever happen??
    suggestions list = hang (text "Perhaps you meant one of these:")
                       2 (pprWithCommas (quotes . ppr) list)
353

rodlogic's avatar
rodlogic committed
354 355 356
{- **********************************************************************

  #cvBinds-etc# Converting to @HsBinds@, etc.
357

rodlogic's avatar
rodlogic committed
358 359 360 361 362
  ********************************************************************* -}

-- | Function definitions are restructured here. Each is assumed to be recursive
-- initially, and non recursive definitions are discovered by the dependency
-- analyser.
363 364


365
--  | Groups together bindings for a single function
366
cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]
367
cvTopDecls decls = go (fromOL decls)
368
  where
369
    go :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
370 371
    go []                     = []
    go (L l (ValD x b) : ds)  = L l' (ValD x b') : go ds'
372
                            where (L l' b', ds') = getMonoBind (L l b) ds
373
    go (d : ds)               = d : go ds
374

375
-- Declaration list may only contain value bindings and signatures.
376
cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs)
377
cvBindGroup binding
378 379
  = do { (mbs, sigs, fam_ds, tfam_insts, dfam_insts, _) <- cvBindsAndSigs binding
       ; ASSERT( null fam_ds && null tfam_insts && null dfam_insts)
380
         return $ ValBinds noExt mbs sigs }
381

382 383 384
cvBindsAndSigs :: OrdList (LHsDecl GhcPs)
  -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs]
          , [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])
385
-- Input decls contain just value bindings and signatures
386
-- and in case of class or instance declarations also
387
-- associated type declarations. They might also contain Haddock comments.
388
cvBindsAndSigs fb = go (fromOL fb)
389
  where
390
    go []              = return (emptyBag, [], [], [], [], [])
391
    go (L l (ValD _ b) : ds)
392 393 394 395 396 397 398
      = do { (bs, ss, ts, tfis, dfis, docs) <- go ds'
           ; return (b' `consBag` bs, ss, ts, tfis, dfis, docs) }
      where
        (b', ds') = getMonoBind (L l b) ds
    go (L l decl : ds)
      = do { (bs, ss, ts, tfis, dfis, docs) <- go ds
           ; case decl of
399
               SigD _ s
400
                 -> return (bs, L l s : ss, ts, tfis, dfis, docs)
401
               TyClD _ (FamDecl _ t)
402
                 -> return (bs, ss, L l t : ts, tfis, dfis, docs)
403
               InstD _ (TyFamInstD { tfid_inst = tfi })
404
                 -> return (bs, ss, ts, L l tfi : tfis, dfis, docs)
405
               InstD _ (DataFamInstD { dfid_inst = dfi })
406
                 -> return (bs, ss, ts, tfis, L l dfi : dfis, docs)
407
               DocD _ d
408
                 -> return (bs, ss, ts, tfis, dfis, L l d : docs)
409
               SpliceD _ d
410 411 412 413 414
                 -> parseErrorSDoc l $
                    hang (text "Declaration splices are allowed only" <+>
                          text "at the top level:")
                       2 (ppr d)
               _ -> pprPanic "cvBindsAndSigs" (ppr decl) }
415 416 417 418

-----------------------------------------------------------------------------
-- Group function bindings into equation groups

419 420
getMonoBind :: LHsBind GhcPs -> [LHsDecl GhcPs]
  -> (LHsBind GhcPs, [LHsDecl GhcPs])
421 422 423
-- Suppose      (b',ds') = getMonoBind b ds
--      ds is a list of parsed bindings
--      b is a MonoBinds that has just been read off the front
424 425 426 427 428

-- Then b' is the result of grouping more equations from ds that
-- belong with b into a single MonoBinds, and ds' is the depleted
-- list of parsed bindings.
--
429
-- All Haddock comments between equations inside the group are
430 431
-- discarded.
--
432 433
-- No AndMonoBinds or EmptyMonoBinds here; just single equations

434
getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1),
435 436
                               fun_matches
                                 = MG { mg_alts = L _ mtchs1 } })) binds
437
  | has_args mtchs1
438
  = go mtchs1 loc1 binds []
439
  where
440
    go mtchs loc
441 442 443
       (L loc2 (ValD _ (FunBind { fun_id = L _ f2,
                                  fun_matches
                                    = MG { mg_alts = L _ mtchs2 } })) : binds) _
444
        | f1 == f2 = go (mtchs2 ++ mtchs)
445
                        (combineSrcSpans loc loc2) binds []
446
    go mtchs loc (doc_decl@(L loc2 (DocD {})) : binds) doc_decls
447
        = let doc_decls' = doc_decl : doc_decls
448 449
          in go mtchs (combineSrcSpans loc loc2) binds doc_decls'
    go mtchs loc binds doc_decls
450
        = ( L loc (makeFunBind fun_id1 (reverse mtchs))
451
          , (reverse doc_decls) ++ binds)
452
        -- Reverse the final matches, to get it back in the right order
453
        -- Do the same thing with the trailing doc comments
454

455 456
getMonoBind bind binds = (bind, binds)

457
has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool
458 459
has_args []                                    = panic "RdrHsSyn:has_args"
has_args ((L _ (Match { m_pats = args })) : _) = not (null args)
460 461 462 463
        -- Don't group together FunBinds if they have
        -- no arguments.  This is necessary now that variable bindings
        -- with no arguments are now treated as FunBinds rather
        -- than pattern bindings (tests/rename/should_fail/rnfail002).
464
has_args ((L _ (XMatch _)) : _) = panic "has_args"
465

rodlogic's avatar
rodlogic committed
466 467 468
{- **********************************************************************

  #PrefixToHS-utils# Utilities for conversion
469

rodlogic's avatar
rodlogic committed
470
  ********************************************************************* -}
471

Simon Peyton Jones's avatar
Simon Peyton Jones committed
472 473
{- Note [Parsing data constructors is hard]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545

The problem with parsing data constructors is that they look a lot like types.
Compare:

  (s1)   data T = C t1 t2
  (s2)   type T = C t1 t2

Syntactically, there's little difference between these declarations, except in
(s1) 'C' is a data constructor, but in (s2) 'C' is a type constructor.

This similarity would pose no problem if we knew ahead of time if we are
parsing a type or a constructor declaration. Looking at (s1) and (s2), a simple
(but wrong!) rule comes to mind: in 'data' declarations assume we are parsing
data constructors, and in other contexts (e.g. 'type' declarations) assume we
are parsing type constructors.

This simple rule does not work because of two problematic cases:

  (p1)   data T = C t1 t2 :+ t3
  (p2)   data T = C t1 t2 => t3

In (p1) we encounter (:+) and it turns out we are parsing an infix data
declaration, so (C t1 t2) is a type and 'C' is a type constructor.
In (p2) we encounter (=>) and it turns out we are parsing an existential
context, so (C t1 t2) is a constraint and 'C' is a type constructor.

As the result, in order to determine whether (C t1 t2) declares a data
constructor, a type, or a context, we would need unlimited lookahead which
'happy' is not so happy with.

To further complicate matters, the interpretation of (!) and (~) is different
in constructors and types:

  (b1)   type T = C ! D
  (b2)   data T = C ! D
  (b3)   data T = C ! D => E

In (b1) and (b3), (!) is a type operator with two arguments: 'C' and 'D'. At
the same time, in (b2) it is a strictness annotation: 'C' is a data constructor
with a single strict argument 'D'. For the programmer, these cases are usually
easy to tell apart due to whitespace conventions:

  (b2)   data T = C !D         -- no space after the bang hints that
                               -- it is a strictness annotation

For the parser, on the other hand, this whitespace does not matter. We cannot
tell apart (b2) from (b3) until we encounter (=>), so it requires unlimited
lookahead.

The solution that accounts for all of these issues is to initially parse data
declarations and types as a reversed list of TyEl:

  data TyEl = TyElOpr RdrName
            | TyElOpd (HsType GhcPs)
            | TyElBang | TyElTilde
            | ...

For example, both occurences of (C ! D) in the following example are parsed
into equal lists of TyEl:

  data T = C ! D => C ! D   results in   [ TyElOpd (HsTyVar "D")
                                         , TyElBang
                                         , TyElOpd (HsTyVar "C") ]

Note that elements are in reverse order. Also, 'C' is parsed as a type
constructor (HsTyVar) even when it is a data constructor. We fix this in
`tyConToDataCon`.

By the time the list of TyEl is assembled, we have looked ahead enough to
decide whether to reduce using `mergeOps` (for types) or `mergeDataCon` (for
data constructors). These functions are where the actual job of parsing is
done.
546

Simon Peyton Jones's avatar
Simon Peyton Jones committed
547
-}
548

549 550
-- | Reinterpret a type constructor, including type operators, as a data
--   constructor.
Simon Peyton Jones's avatar
Simon Peyton Jones committed
551
-- See Note [Parsing data constructors is hard]
552
tyConToDataCon :: SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
553
tyConToDataCon loc tc
554
  | isTcOcc occ || isDataOcc occ
Simon Peyton Jones's avatar
Simon Peyton Jones committed
555 556 557 558
  , isLexCon (occNameFS occ)
  = return (L loc (setRdrNameSpace tc srcDataName))

  | otherwise
559
  = Left (loc, msg $$ extra)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
560 561 562 563 564 565 566
  where
    occ = rdrNameOcc tc

    msg = text "Not a data constructor:" <+> quotes (ppr tc)
    extra | tc == forall_tv_RDR
          = text "Perhaps you intended to use ExistentialQuantification"
          | otherwise = empty
567

568
mkPatSynMatchGroup :: Located RdrName
569 570
                   -> Located (OrdList (LHsDecl GhcPs))
                   -> P (MatchGroup GhcPs (LHsExpr GhcPs))
571
mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) =
572
    do { matches <- mapM fromDecl (fromOL decls)
573
       ; when (null matches) (wrongNumberErr loc)
574 575
       ; return $ mkMatchGroup FromSource matches }
  where
576
    fromDecl (L loc decl@(ValD _ (PatBind _
577 578
                                   pat@(L _ (ConPatIn ln@(L _ name) details))
                                   rhs _))) =
579 580 581
        do { unless (name == patsyn_name) $
               wrongNameBindingErr loc decl
           ; match <- case details of
582 583
               PrefixCon pats -> return $ Match { m_ext = noExt
                                                , m_ctxt = ctxt, m_pats = pats
584
                                                , m_grhss = rhs }
585 586 587
                   where
                     ctxt = FunRhs { mc_fun = ln, mc_fixity = Prefix, mc_strictness = NoSrcStrict }

588 589 590
               InfixCon p1 p2 -> return $ Match { m_ext = noExt
                                                , m_ctxt = ctxt
                                                , m_pats = [p1, p2]
591
                                                , m_grhss = rhs }
592 593 594
                   where
                     ctxt = FunRhs { mc_fun = ln, mc_fixity = Infix, mc_strictness = NoSrcStrict }

595 596 597 598 599 600 601 602 603 604 605 606 607 608
               RecCon{} -> recordPatSynErr loc pat
           ; return $ L loc match }
    fromDecl (L loc decl) = extraDeclErr loc decl

    extraDeclErr loc decl =
        parseErrorSDoc loc $
        text "pattern synonym 'where' clause must contain a single binding:" $$
        ppr decl

    wrongNameBindingErr loc decl =
        parseErrorSDoc loc $
        text "pattern synonym 'where' clause must bind the pattern synonym's name" <+>
        quotes (ppr patsyn_name) $$ ppr decl

609 610
    wrongNumberErr loc =
      parseErrorSDoc loc $
611
      text "pattern synonym 'where' clause cannot be empty" $$
612 613
      text "In the pattern synonym declaration for: " <+> ppr (patsyn_name)

614
recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a
Simon Peyton Jones's avatar
Simon Peyton Jones committed
615 616 617 618 619
recordPatSynErr loc pat =
    parseErrorSDoc loc $
    text "record syntax not supported for pattern synonym declarations:" $$
    ppr pat

620
mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr GhcPs]
621
                -> Maybe (LHsContext GhcPs) -> HsConDeclDetails GhcPs
622
                -> ConDecl GhcPs
623

624
mkConDeclH98 name mb_forall mb_cxt args
625 626
  = ConDeclH98 { con_ext    = noExt
               , con_name   = name
627
               , con_forall = noLoc $ isJust mb_forall
628 629
               , con_ex_tvs = mb_forall `orElse` []
               , con_mb_cxt = mb_cxt
630
               , con_args   = args'
631
               , con_doc    = Nothing }
632 633
  where
    args' = nudgeHsSrcBangs args
634

635
mkGadtDecl :: [Located RdrName]
636
           -> LHsType GhcPs     -- Always a HsForAllTy
637
           -> (ConDecl GhcPs, [AddAnn])
638
mkGadtDecl names ty
639 640
  = (ConDeclGADT { con_g_ext  = noExt
                 , con_names  = names
641
                 , con_forall = L l $ isLHsForAllTy ty'
642 643 644 645 646
                 , con_qvars  = mkHsQTvs tvs
                 , con_mb_cxt = mcxt
                 , con_args   = args'
                 , con_res_ty = res_ty
                 , con_doc    = Nothing }
647
    , anns1 ++ anns2)
648
  where
649 650 651
    (ty'@(L l _),anns1) = peel_parens ty []
    (tvs, rho) = splitLHsForAllTy ty'
    (mcxt, tau, anns2) = split_rho rho []
652

653 654 655 656
    split_rho (L _ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) ann
                                       = (Just cxt, tau, ann)
    split_rho (L l (HsParTy _ ty)) ann = split_rho ty (ann++mkParensApiAnn l)
    split_rho tau                  ann = (Nothing, tau, ann)
657

658
    (args, res_ty) = split_tau tau
659
    args' = nudgeHsSrcBangs args
660 661

    -- See Note [GADT abstract syntax] in HsDecls
662 663 664
    split_tau (L _ (HsFunTy _ (L loc (HsRecTy _ rf)) res_ty))
                                   = (RecCon (L loc rf), res_ty)
    split_tau tau                  = (PrefixCon [], tau)
665 666 667 668

    peel_parens (L l (HsParTy _ ty)) ann = peel_parens ty
                                                       (ann++mkParensApiAnn l)
    peel_parens ty                   ann = (ty, ann)
669

670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691
nudgeHsSrcBangs :: HsConDeclDetails GhcPs -> HsConDeclDetails GhcPs
-- ^ This function ensures that fields with strictness or packedness
-- annotations put these annotations on an outer 'HsBangTy'.
--
-- The problem is that in the parser, strictness and packedness annotations
-- bind more tightly that docstrings. However, the expectation downstream of
-- the parser (by functions such as 'getBangType' and 'getBangStrictness')
-- is that docstrings bind more tightly so that 'HsBangTy' may end up as the
-- top-level type.
--
-- See #15206
nudgeHsSrcBangs details
  = case details of
      PrefixCon as -> PrefixCon (map go as)
      RecCon r -> RecCon r
      InfixCon a1 a2 -> InfixCon (go a1) (go a2)
  where
    go (L l (HsDocTy _ (L _ (HsBangTy _ s lty)) lds)) =
      L l (HsBangTy noExt s (addCLoc lty lds (HsDocTy noExt lty lds)))
    go lty = lty


692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763
setRdrNameSpace :: RdrName -> NameSpace -> RdrName
-- ^ This rather gruesome function is used mainly by the parser.
-- When parsing:
--
-- > data T a = T | T1 Int
--
-- we parse the data constructors as /types/ because of parser ambiguities,
-- so then we need to change the /type constr/ to a /data constr/
--
-- The exact-name case /can/ occur when parsing:
--
-- > data [] a = [] | a : [a]
--
-- For the exact-name case we return an original name.
setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ)
setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ)
setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ)
setRdrNameSpace (Exact n)    ns
  | Just thing <- wiredInNameTyThing_maybe n
  = setWiredInNameSpace thing ns
    -- Preserve Exact Names for wired-in things,
    -- notably tuples and lists

  | isExternalName n
  = Orig (nameModule n) occ

  | otherwise   -- This can happen when quoting and then
                -- splicing a fixity declaration for a type
  = Exact (mkSystemNameAt (nameUnique n) occ (nameSrcSpan n))
  where
    occ = setOccNameSpace ns (nameOccName n)

setWiredInNameSpace :: TyThing -> NameSpace -> RdrName
setWiredInNameSpace (ATyCon tc) ns
  | isDataConNameSpace ns
  = ty_con_data_con tc
  | isTcClsNameSpace ns
  = Exact (getName tc)      -- No-op

setWiredInNameSpace (AConLike (RealDataCon dc)) ns
  | isTcClsNameSpace ns
  = data_con_ty_con dc
  | isDataConNameSpace ns
  = Exact (getName dc)      -- No-op

setWiredInNameSpace thing ns
  = pprPanic "setWiredinNameSpace" (pprNameSpace ns <+> ppr thing)

ty_con_data_con :: TyCon -> RdrName
ty_con_data_con tc
  | isTupleTyCon tc
  , Just dc <- tyConSingleDataCon_maybe tc
  = Exact (getName dc)

  | tc `hasKey` listTyConKey
  = Exact nilDataConName

  | otherwise  -- See Note [setRdrNameSpace for wired-in names]
  = Unqual (setOccNameSpace srcDataName (getOccName tc))

data_con_ty_con :: DataCon -> RdrName
data_con_ty_con dc
  | let tc = dataConTyCon dc
  , isTupleTyCon tc
  = Exact (getName tc)

  | dc `hasKey` nilDataConKey
  = Exact listTyConName

  | otherwise  -- See Note [setRdrNameSpace for wired-in names]
  = Unqual (setOccNameSpace tcClsName (getOccName dc))

764 765 766 767 768 769 770
-- | Replaces constraint tuple names with corresponding boxed ones.
filterCTuple :: RdrName -> RdrName
filterCTuple (Exact n)
  | Just arity <- cTupleTyConNameArity_maybe n
  = Exact $ tupleTyConName BoxedTuple arity
filterCTuple rdr = rdr

771 772 773 774 775 776 777 778 779 780 781 782 783

{- Note [setRdrNameSpace for wired-in names]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In GHC.Types, which declares (:), we have
  infixr 5 :
The ambiguity about which ":" is meant is resolved by parsing it as a
data constructor, but then using dataTcOccs to try the type constructor too;
and that in turn calls setRdrNameSpace to change the name-space of ":" to
tcClsName.  There isn't a corresponding ":" type constructor, but it's painful
to make setRdrNameSpace partial, so we just make an Unqual name instead. It
really doesn't matter!
-}

784 785
checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType GhcPs]
             -> P (LHsQTyVars GhcPs)
786
-- Same as checkTyVars, but in the P monad
rodlogic's avatar
rodlogic committed
787
checkTyVarsP pp_what equals_or_where tc tparms
788 789 790 791
  = do { let checkedTvs = checkTyVars pp_what equals_or_where tc tparms
       ; (tvs, anns) <- eitherToP checkedTvs
       ; anns
       ; pure tvs }
792 793 794 795 796

eitherToP :: Either (SrcSpan, SDoc) a -> P a
-- Adapts the Either monad to the P monad
eitherToP (Left (loc, doc)) = parseErrorSDoc loc doc
eitherToP (Right thing)     = return thing
797

798
checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsType GhcPs]
799 800 801 802 803 804 805
            -> Either (SrcSpan, SDoc)
                      ( LHsQTyVars GhcPs  -- the synthesized type variables
                      , P () )            -- action which adds annotations
-- ^ Check whether the given list of type parameters are all type variables
-- (possibly with a kind signature).
-- We use the Either monad because it's also called (via 'mkATDefault') from
-- "Convert".
rodlogic's avatar
rodlogic committed
806
checkTyVars pp_what equals_or_where tc tparms
807 808
  = do { (tvs, anns) <- fmap unzip $ mapM (chkParens []) tparms
       ; return (mkHsQTvs tvs, sequence_ anns) }
809
  where
810 811 812 813 814 815 816
        -- Keep around an action for adjusting the annotations of extra parens
    chkParens :: [AddAnn] -> LHsType GhcPs
              -> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, P ())
    chkParens acc (L l (HsParTy _ ty)) = chkParens (mkParensApiAnn l ++ acc) ty
    chkParens acc ty = case chk ty of
      Left err -> Left err
      Right tv@(L l _) -> Right (tv, addAnnsAt l (reverse acc))
817

818
        -- Check that the name space is correct!
819
    chk (L l (HsKindSig _ (L lv (HsTyVar _ _ (L _ tv))) k))
820
        | isRdrTyVar tv    = return (L l (KindedTyVar noExt (L lv tv) k))
821
    chk (L l (HsTyVar _ _ (L ltv tv)))
822
        | isRdrTyVar tv    = return (L l (UserTyVar noExt (L ltv tv)))
823
    chk t@(L loc _)
rodlogic's avatar
rodlogic committed
824
        = Left (loc,
825
                vcat [ text "Unexpected type" <+> quotes (ppr t)
826
                     , text "In the" <+> pp_what <+> ptext (sLit "declaration for") <+> quotes tc'
827
                     , vcat[ (text "A" <+> pp_what <+> ptext (sLit "declaration should have form"))
828
                     , nest 2 (pp_what <+> tc'
829 830
                                       <+> hsep (map text (takeList tparms allNameStrings))
                                       <+> equals_or_where) ] ])
831

832 833 834 835 836 837 838
    -- Avoid printing a constraint tuple in the error message. Print
    -- a plain old tuple instead (since that's what the user probably
    -- wrote). See #14907
    tc' = ppr $ fmap filterCTuple tc



839
whereDots, equalsDots :: SDoc
840
-- Second argument to checkTyVars
841 842
whereDots  = text "where ..."
equalsDots = text "= ..."
843

844
checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P ()
845
checkDatatypeContext Nothing = return ()
846
checkDatatypeContext (Just (L loc c))
847
    = do allowed <- getBit DatatypeContextsBit
848
         unless allowed $
849
             parseErrorSDoc loc
850
                 (text "Illegal datatype context (use DatatypeContexts):" <+>
851
                  pprHsContext c)
852

853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879
type LRuleTyTmVar = Located RuleTyTmVar
data RuleTyTmVar = RuleTyTmVar (Located RdrName) (Maybe (LHsType GhcPs))
-- ^ Essentially a wrapper for a @RuleBndr GhcPs@

-- turns RuleTyTmVars into RuleBnrs - this is straightforward
mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs]
mkRuleBndrs = fmap (fmap cvt_one)
  where cvt_one (RuleTyTmVar v Nothing)    = RuleBndr    noExt v
        cvt_one (RuleTyTmVar v (Just sig)) = RuleBndrSig noExt v (mkLHsSigWcType sig)

-- turns RuleTyTmVars into HsTyVarBndrs - this is more interesting
mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr GhcPs]
mkRuleTyVarBndrs = fmap (fmap cvt_one)
  where cvt_one (RuleTyTmVar v Nothing)    = UserTyVar   noExt (fmap tm_to_ty v)
        cvt_one (RuleTyTmVar v (Just sig)) = KindedTyVar noExt (fmap tm_to_ty v) sig
        -- takes something in namespace 'varName' to something in namespace 'tvName'
        tm_to_ty (Unqual occ) = Unqual (setOccNameSpace tvName occ)
        tm_to_ty _ = panic "mkRuleTyVarBndrs"

-- See note [Parsing explicit foralls in Rules] in Parser.y
checkRuleTyVarBndrNames :: [LHsTyVarBndr GhcPs] -> P ()
checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName)
  where check (L loc (Unqual occ)) = do
          when ((occNameString occ ==) `any` ["forall","family","role"])
               (parseErrorSDoc loc (text $ "parse error on input " ++ occNameString occ))
        check _ = panic "checkRuleTyVarBndrNames"

880 881
checkRecordSyntax :: Outputable a => Located a -> P (Located a)
checkRecordSyntax lr@(L loc r)
882
    = do allowed <- getBit TraditionalRecordSyntaxBit
883 884 885
         if allowed
             then return lr
             else parseErrorSDoc loc
886
                      (text "Illegal record syntax (use TraditionalRecordSyntax):" <+>
887 888
                       ppr r)

889 890 891 892 893
-- | Check if the gadt_constrlist is empty. Only raise parse error for
-- `data T where` to avoid affecting existing error message, see #8258.
checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs])
                -> P (Located ([AddAnn], [LConDecl GhcPs]))
checkEmptyGADTs gadts@(L span (_, []))               -- Empty GADT declaration.
894
    = do gadtSyntax <- getBit GadtSyntaxBit   -- GADTs implies GADTSyntax
895
         if gadtSyntax
896 897 898 899 900 901 902 903
            then return gadts
            else parseErrorSDoc span $ vcat
              [ text "Illegal keyword 'where' in data declaration"
              , text "Perhaps you intended to use GADTs or a similar language"
              , text "extension to enable syntax: data T where"
              ]
checkEmptyGADTs gadts = return gadts              -- Ordinary GADT declaration.

904 905
checkTyClHdr :: Bool               -- True  <=> class header
                                   -- False <=> type header
906 907 908 909
             -> LHsType GhcPs
             -> P (Located RdrName,      -- the head symbol (type or class name)
                   [LHsType GhcPs],      -- parameters of head symbol
                   LexicalFixity,        -- the declaration is in infix format
Alan Zimmerman's avatar
Alan Zimmerman committed
910
                   [AddAnn]) -- API Annotation for HsParTy when stripping parens
911
-- Well-formedness check and decomposition of type and class heads.
912
-- Decomposes   T ty1 .. tyn   into    (T, [ty1, ..., tyn])
913
--              Int :*: Bool   into    (:*:, [Int, Bool])
914
-- returning the pieces
915
checkTyClHdr is_cls ty
916
  = goL ty [] [] Prefix
917
  where
918 919
    goL (L l ty) acc ann fix = go l ty acc ann fix

920 921 922 923 924 925
    -- workaround to define '*' despite StarIsType
    go _ (HsParTy _ (L l (HsStarTy _ isUni))) acc ann fix
      = do { warnStarBndr l
           ; let name = mkOccName tcClsName (if isUni then "★" else "*")
           ; return (L l (Unqual name), acc, fix, ann) }

926
    go l (HsTyVar _ _ (L _ tc)) acc ann fix
927
      | isRdrTc tc               = return (L l tc, acc, fix, ann)
928
    go _ (HsOpTy _ t1 ltc@(L _ tc) t2) acc ann _fix
929
      | isRdrTc tc               = return (ltc, t1:t2:acc, Infix, ann)
930 931
    go l (HsParTy _ ty)    acc ann fix = goL ty acc (ann ++mkParensApiAnn l) fix
    go _ (HsAppTy _ t1 t2) acc ann fix = goL t1 (t2:acc) ann fix
932

933
    go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ann fix
934
      = return (L l (nameRdrName tup_name), ts, fix, ann)
935 936 937 938 939
      where
        arity = length ts
        tup_name | is_cls    = cTupleTyConName arity
                 | otherwise = getName (tupleTyCon Boxed arity)
                 -- See Note [Unit tuples] in HsTypes  (TODO: is this still relevant?)
940
    go l _ _ _ _
941 942
      = parseErrorSDoc l (text "Malformed head of type or class declaration:"
                          <+> ppr ty)
943

944 945 946 947
-- | Yield a parse error if we have a function applied directly to a do block
-- etc. and BlockArguments is not enabled.
checkBlockArguments :: LHsExpr GhcPs -> P ()
checkBlockArguments expr = case unLoc expr of
948 949
    HsDo _ DoExpr _ -> check "do block"
    HsDo _ MDoExpr _ -> check "mdo block"
950 951 952 953 954 955 956 957 958
    HsLam {} -> check "lambda expression"
    HsCase {} -> check "case expression"
    HsLamCase {} -> check "lambda-case expression"
    HsLet {} -> check "let expression"
    HsIf {} -> check "if expression"
    HsProc {} -> check "proc expression"
    _ -> return ()
  where
    check element = do
959
      blockArguments <- getBit BlockArgumentsBit
960
      unless blockArguments $
961 962 963 964 965 966
        parseErrorSDoc (getLoc expr) $
          text "Unexpected " <> text element <> text " in function application:"
           $$ nest 4 (ppr expr)
           $$ text "You could write it with parentheses"
           $$ text "Or perhaps you meant to enable BlockArguments?"

967 968 969 970 971 972 973 974 975
-- | Validate the context constraints and break up a context into a list
-- of predicates.
--
-- @
--     (Eq a, Ord b)        -->  [Eq a, Ord b]
--     Eq a                 -->  [Eq a]
--     (Eq a)               -->  [Eq a]
--     (((Eq a)))           -->  [Eq a]
-- @