RdrHsSyn.hs 107 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
{-# LANGUAGE ViewPatterns #-}
12 13 14 15 16 17
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
18

19
module   RdrHsSyn (
20 21
        mkHsOpApp,
        mkHsIntegral, mkHsFractional, mkHsIsString,
22
        mkHsDo, mkSpliceDecl,
23
        mkRoleAnnotDecl,
rodlogic's avatar
rodlogic committed
24 25
        mkClassDecl,
        mkTyData, mkDataFamInst,
26
        mkTySynonym, mkTyFamInstEqn,
rodlogic's avatar
rodlogic committed
27
        mkTyFamInst,
28
        mkFamDecl, mkLHsSigType,
29
        mkInlinePragma,
30
        mkPatSynMatchGroup,
31
        mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
32
        mkTyClD, mkInstD,
33
        mkRdrRecordCon, mkRdrRecordUpd,
34
        setRdrNameSpace,
35
        filterCTuple,
36

37
        cvBindGroup,
38
        cvBindsAndSigs,
39
        cvTopDecls,
40
        placeHolderPunRhs,
41

42 43
        -- Stuff to do with Foreign declarations
        mkImport,
44
        parseCImport,
45
        mkExport,
46 47
        mkExtName,    -- RdrName -> CLabelString
        mkGadtDecl,   -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName
Alan Zimmerman's avatar
Alan Zimmerman committed
48
        mkConDeclH98,
49
        mkATDefault,
50 51 52

        -- Bunch of functions in the parser monad for
        -- checking and constructing values
53
        checkBlockArguments,
54 55 56
        checkPrecP,           -- Int -> P Int
        checkContext,         -- HsType -> P HsContext
        checkPattern,         -- HsExp -> P HsPat
batterseapower's avatar
batterseapower committed
57
        bang_RDR,
58
        isBangRdr,
59
        isTildeRdr,
60 61 62
        checkPatterns,        -- SrcLoc -> [HsExp] -> P [HsPat]
        checkMonadComp,       -- P (HsStmtContext RdrName)
        checkValDef,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
63
        checkValSigLhs,
64
        checkDoAndIfThenElse,
65 66 67
        LRuleTyTmVar, RuleTyTmVar(..),
        mkRuleBndrs, mkRuleTyVarBndrs,
        checkRuleTyVarBndrNames,
68
        checkRecordSyntax,
Tao He's avatar
Tao He committed
69
        checkEmptyGADTs,
70
        addFatalError, hintBangPat,
71
        TyEl(..), mergeOps, mergeDataCon,
72 73 74

        -- Help with processing exports
        ImpExpSubSpec(..),
75
        ImpExpQcSpec(..),
76
        mkModuleImpExp,
77 78
        mkTypeImpExp,
        mkImpExpSubSpec,
79 80
        checkImportSpec,

81 82 83 84
        -- Token symbols
        forallSym,
        starSym,

85 86 87 88
        -- Warnings and errors
        warnStarIsType,
        failOpFewArgs,

89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104
        SumOrTuple (..), mkSumOrTuple,

        -- Expression/command ambiguity resolution
        PV,
        ExpCmdP(ExpCmdP, runExpCmdP),
        ExpCmdI(..),
        ecFromExp,
        ecFromCmd,
        ecHsLam,
        ecHsLet,
        ecOpApp,
        ecHsCase,
        ecHsApp,
        ecHsIf,
        ecHsDo,
        ecHsPar,
105

106 107
    ) where

108
import GhcPrelude
109
import HsSyn            -- Lots of it
110 111 112
import TyCon            ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe )
import DataCon          ( DataCon, dataConTyCon )
import ConLike          ( ConLike(..) )
113
import CoAxiom          ( Role, fsFromRole )
114 115 116
import RdrName
import Name
import BasicTypes
117
import TcEvidence       ( idHsWrapper )
118
import Lexer
Simon Peyton Jones's avatar
Simon Peyton Jones committed
119
import Lexeme           ( isLexCon )
Alec Theriault's avatar
Alec Theriault committed
120
import Type             ( TyThing(..), funTyCon )
121 122
import TysWiredIn       ( cTupleTyConName, tupleTyCon, tupleDataCon,
                          nilDataConName, nilDataConKey,
123 124
                          listTyConName, listTyConKey, eqTyCon_RDR,
                          tupleTyConName, cTupleTyConNameArity_maybe )
125
import ForeignCall
126
import PrelNames        ( allNameStrings )
127
import SrcLoc
128
import Unique           ( hasKey )
129
import OrdList          ( OrdList, fromOL )
Gergő Érdi's avatar
Gergő Érdi committed
130
import Bag              ( emptyBag, consBag )
131 132
import Outputable
import FastString
133
import Maybes
134
import Util
Alan Zimmerman's avatar
Alan Zimmerman committed
135
import ApiAnnotation
136
import Data.List
137
import DynFlags ( WarningFlag(..) )
138

139
import Control.Monad
140
import Text.ParserCombinators.ReadP as ReadP
Ian Lynagh's avatar
Ian Lynagh committed
141
import Data.Char
My Nguyen's avatar
My Nguyen committed
142
import qualified Data.Monoid as Monoid
143 144
import Data.Data       ( dataTypeOf, fromConstr, dataTypeConstrs )

145
#include "HsVersions.h"
146

147

rodlogic's avatar
rodlogic committed
148 149 150
{- **********************************************************************

  Construction functions for Rdr stuff
151

rodlogic's avatar
rodlogic committed
152
  ********************************************************************* -}
153

rodlogic's avatar
rodlogic committed
154 155 156 157 158
-- | 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).
159

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

162
--         *** See Note [The Naming story] in HsDecls ****
163

164
mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p)
165
mkTyClD (dL->L loc d) = cL loc (TyClD noExt d)
166

167
mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p)
168
mkInstD (dL->L loc d) = cL loc (InstD noExt d)
169

170
mkClassDecl :: SrcSpan
171
            -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
172
            -> Located (a,[LHsFunDep GhcPs])
173 174
            -> OrdList (LHsDecl GhcPs)
            -> P (LTyClDecl GhcPs)
175

176
mkClassDecl loc (dL->L _ (mcxt, tycl_hdr)) fds where_cls
177 178
  = do { (binds, sigs, ats, at_insts, _, docs) <- cvBindsAndSigs where_cls
       ; let cxt = fromMaybe (noLoc []) mcxt
179
       ; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr
180 181 182 183 184
       ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan
       ; (tyvars,annst) <- checkTyVarsP (text "class") whereDots cls tparams
       ; addAnnsAt loc annst -- Add any API Annotations to the top SrcSpan
       ; (at_defs, annsi) <- mapAndUnzipM (eitherToP . mkATDefault) at_insts
       ; sequence_ annsi
185 186 187 188 189 190 191 192
       ; return (cL loc (ClassDecl { tcdCExt = noExt, tcdCtxt = cxt
                                   , tcdLName = cls, tcdTyVars = tyvars
                                   , tcdFixity = fixity
                                   , tcdFDs = snd (unLoc fds)
                                   , tcdSigs = mkClassOpSigs sigs
                                   , tcdMeths = binds
                                   , tcdATs = ats, tcdATDefs = at_defs
                                   , tcdDocs  = docs })) }
193

194
mkATDefault :: LTyFamInstDecl GhcPs
195 196 197
            -> 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.
198
-- We parse things as the former and use this function to convert to the latter
rodlogic's avatar
rodlogic committed
199
--
200 201 202 203 204
-- 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.
205
mkATDefault (dL->L loc (TyFamInstDecl { tfid_eqn = HsIB { hsib_body = e }}))
206 207
      | FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs, feqn_pats = pats
               , feqn_fixity = fixity, feqn_rhs = rhs } <- e
208
      = do { (tvs, anns) <- checkTyVars (text "default") equalsDots tc pats
209 210 211 212 213 214 215
           ; let f = cL loc (FamEqn { feqn_ext    = noExt
                                    , feqn_tycon  = tc
                                    , feqn_bndrs  = ASSERT( isNothing bndrs )
                                                    Nothing
                                    , feqn_pats   = tvs
                                    , feqn_fixity = fixity
                                    , feqn_rhs    = rhs })
216
           ; pure (f, addAnnsAt loc anns) }
217 218 219 220
mkATDefault (dL->L _ (TyFamInstDecl (HsIB _ (XFamEqn _)))) = panic "mkATDefault"
mkATDefault (dL->L _ (TyFamInstDecl (XHsImplicitBndrs _))) = panic "mkATDefault"
mkATDefault _ = panic "mkATDefault: Impossible Match"
                                -- due to #15884
221

222 223
mkTyData :: SrcSpan
         -> NewOrData
224
         -> Maybe (Located CType)
225 226 227 228 229
         -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
         -> Maybe (LHsKind GhcPs)
         -> [LConDecl GhcPs]
         -> HsDeriving GhcPs
         -> P (LTyClDecl GhcPs)
230 231
mkTyData loc new_or_data cType (dL->L _ (mcxt, tycl_hdr))
         ksig data_cons maybe_deriv
232
  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
233 234 235
       ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan
       ; (tyvars, anns) <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams
       ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan
236
       ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
237 238 239 240
       ; return (cL loc (DataDecl { tcdDExt = noExt,
                                    tcdLName = tc, tcdTyVars = tyvars,
                                    tcdFixity = fixity,
                                    tcdDataDefn = defn })) }
241

242
mkDataDefn :: NewOrData
243
           -> Maybe (Located CType)
244 245 246 247 248
           -> Maybe (LHsContext GhcPs)
           -> Maybe (LHsKind GhcPs)
           -> [LConDecl GhcPs]
           -> HsDeriving GhcPs
           -> P (HsDataDefn GhcPs)
249 250
mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
  = do { checkDatatypeContext mcxt
251
       ; let cxt = fromMaybe (noLoc []) mcxt
252 253
       ; return (HsDataDefn { dd_ext = noExt
                            , dd_ND = new_or_data, dd_cType = cType
rodlogic's avatar
rodlogic committed
254
                            , dd_ctxt = cxt
255 256 257
                            , dd_cons = data_cons
                            , dd_kindSig = ksig
                            , dd_derivs = maybe_deriv }) }
thomasw's avatar
thomasw committed
258

259

260
mkTySynonym :: SrcSpan
261 262 263
            -> LHsType GhcPs  -- LHS
            -> LHsType GhcPs  -- RHS
            -> P (LTyClDecl GhcPs)
264
mkTySynonym loc lhs rhs
265
  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
266 267 268
       ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan
       ; (tyvars, anns) <- checkTyVarsP (text "type") equalsDots tc tparams
       ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan
269 270 271 272
       ; return (cL loc (SynDecl { tcdSExt = noExt
                                 , tcdLName = tc, tcdTyVars = tyvars
                                 , tcdFixity = fixity
                                 , tcdRhs = rhs })) }
273

274 275
mkTyFamInstEqn :: Maybe [LHsTyVarBndr GhcPs]
               -> LHsType GhcPs
276 277
               -> LHsType GhcPs
               -> P (TyFamInstEqn GhcPs,[AddAnn])
278
mkTyFamInstEqn bndrs lhs rhs
279
  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
280
       ; return (mkHsImplicitBndrs
281 282
                  (FamEqn { feqn_ext    = noExt
                          , feqn_tycon  = tc
283
                          , feqn_bndrs  = bndrs
284 285 286
                          , feqn_pats   = tparams
                          , feqn_fixity = fixity
                          , feqn_rhs    = rhs }),
Alan Zimmerman's avatar
Alan Zimmerman committed
287
                 ann) }
288

289
mkDataFamInst :: SrcSpan
Jan Stolarek's avatar
Jan Stolarek committed
290 291
              -> NewOrData
              -> Maybe (Located CType)
292 293
              -> (Maybe ( LHsContext GhcPs), Maybe [LHsTyVarBndr GhcPs]
                        , LHsType GhcPs)
294 295 296 297
              -> Maybe (LHsKind GhcPs)
              -> [LConDecl GhcPs]
              -> HsDeriving GhcPs
              -> P (LInstDecl GhcPs)
298
mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr)
299
              ksig data_cons maybe_deriv
300
  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
Alan Zimmerman's avatar
Alan Zimmerman committed
301
       ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
302
       ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
303
       ; return (cL loc (DataFamInstD noExt (DataFamInstDecl (mkHsImplicitBndrs
304 305
                  (FamEqn { feqn_ext    = noExt
                          , feqn_tycon  = tc
306
                          , feqn_bndrs  = bndrs
307
                          , feqn_pats   = tparams
308
                          , feqn_fixity = fixity
309
                          , feqn_rhs    = defn }))))) }
310

311
mkTyFamInst :: SrcSpan
312
            -> TyFamInstEqn GhcPs
313
            -> P (LInstDecl GhcPs)
314
mkTyFamInst loc eqn
315
  = return (cL loc (TyFamInstD noExt (TyFamInstDecl eqn)))
316 317

mkFamDecl :: SrcSpan
318 319 320 321 322
          -> 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
323
mkFamDecl loc info lhs ksig injAnn
324
  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
325 326 327
       ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan
       ; (tyvars, anns) <- checkTyVarsP (ppr info) equals_or_where tc tparams
       ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan
328
       ; return (cL loc (FamDecl noExt (FamilyDecl
329 330
                                           { fdExt       = noExt
                                           , fdInfo      = info, fdLName = tc
Jan Stolarek's avatar
Jan Stolarek committed
331
                                           , fdTyVars    = tyvars
332
                                           , fdFixity    = fixity
Jan Stolarek's avatar
Jan Stolarek committed
333 334
                                           , fdResultSig = ksig
                                           , fdInjectivityAnn = injAnn }))) }
335 336 337 338 339
  where
    equals_or_where = case info of
                        DataFamily          -> empty
                        OpenTypeFamily      -> empty
                        ClosedTypeFamily {} -> whereDots
340

341
mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs
342
-- If the user wrote
343
--      [pads| ... ]   then return a QuasiQuoteD
344
--      $(e)           then return a SpliceD
345 346
-- but if she wrote, say,
--      f x            then behave as if she'd written $(f x)
347
--                     ie a SpliceD
348 349 350
--
-- Typed splices are not allowed at the top level, thus we do not represent them
-- as spliced declaration.  See #10945
351
mkSpliceDecl lexpr@(dL->L loc expr)
352
  | HsSpliceE _ splice@(HsUntypedSplice {}) <- expr
353
  = SpliceD noExt (SpliceDecl noExt (cL loc splice) ExplicitSplice)
354

355
  | HsSpliceE _ splice@(HsQuasiQuote {}) <- expr
356
  = SpliceD noExt (SpliceDecl noExt (cL loc splice) ExplicitSplice)
357 358

  | otherwise
359
  = SpliceD noExt (SpliceDecl noExt (cL loc (mkUntypedSplice NoParens lexpr))
360
                              ImplicitSplice)
361

362
mkRoleAnnotDecl :: SrcSpan
363
                -> Located RdrName                -- type being annotated
364
                -> [Located (Maybe FastString)]      -- roles
365
                -> P (LRoleAnnotDecl GhcPs)
366 367
mkRoleAnnotDecl loc tycon roles
  = do { roles' <- mapM parse_role roles
368
       ; return $ cL loc $ RoleAnnotDecl noExt tycon roles' }
369 370 371 372 373
  where
    role_data_type = dataTypeOf (undefined :: Role)
    all_roles = map fromConstr $ dataTypeConstrs role_data_type
    possible_roles = [(fsFromRole role, role) | role <- all_roles]

374 375
    parse_role (dL->L loc_role Nothing) = return $ cL loc_role Nothing
    parse_role (dL->L loc_role (Just role))
376
      = case lookup role possible_roles of
377
          Just found_role -> return $ cL loc_role $ Just found_role
378
          Nothing         ->
379 380 381
            let nearby = fuzzyLookup (unpackFS role)
                  (mapFst unpackFS possible_roles)
            in
382
            addFatalError loc_role
383 384
              (text "Illegal role name" <+> quotes (ppr role) $$
               suggestions nearby)
385 386
    parse_role _ = panic "parse_role: Impossible Match"
                                -- due to #15884
387 388 389 390 391 392

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

rodlogic's avatar
rodlogic committed
394 395 396
{- **********************************************************************

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

rodlogic's avatar
rodlogic committed
398 399 400 401 402
  ********************************************************************* -}

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


405
--  | Groups together bindings for a single function
406
cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]
407
cvTopDecls decls = go (fromOL decls)
408
  where
409
    go :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
410
    go []                     = []
411 412 413 414
    go ((dL->L l (ValD x b)) : ds)
      = cL l' (ValD x b') : go ds'
        where (dL->L l' b', ds') = getMonoBind (cL l b) ds
    go (d : ds)                    = d : go ds
415

416
-- Declaration list may only contain value bindings and signatures.
417
cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs)
418
cvBindGroup binding
419 420
  = do { (mbs, sigs, fam_ds, tfam_insts
         , dfam_insts, _) <- cvBindsAndSigs binding
421
       ; ASSERT( null fam_ds && null tfam_insts && null dfam_insts)
422
         return $ ValBinds noExt mbs sigs }
423

424 425 426
cvBindsAndSigs :: OrdList (LHsDecl GhcPs)
  -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs]
          , [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])
427
-- Input decls contain just value bindings and signatures
428
-- and in case of class or instance declarations also
429
-- associated type declarations. They might also contain Haddock comments.
430
cvBindsAndSigs fb = go (fromOL fb)
431
  where
432
    go []              = return (emptyBag, [], [], [], [], [])
433
    go ((dL->L l (ValD _ b)) : ds)
434 435 436
      = do { (bs, ss, ts, tfis, dfis, docs) <- go ds'
           ; return (b' `consBag` bs, ss, ts, tfis, dfis, docs) }
      where
437 438
        (b', ds') = getMonoBind (cL l b) ds
    go ((dL->L l decl) : ds)
439 440
      = do { (bs, ss, ts, tfis, dfis, docs) <- go ds
           ; case decl of
441
               SigD _ s
442
                 -> return (bs, cL l s : ss, ts, tfis, dfis, docs)
443
               TyClD _ (FamDecl _ t)
444
                 -> return (bs, ss, cL l t : ts, tfis, dfis, docs)
445
               InstD _ (TyFamInstD { tfid_inst = tfi })
446
                 -> return (bs, ss, ts, cL l tfi : tfis, dfis, docs)
447
               InstD _ (DataFamInstD { dfid_inst = dfi })
448
                 -> return (bs, ss, ts, tfis, cL l dfi : dfis, docs)
449
               DocD _ d
450
                 -> return (bs, ss, ts, tfis, dfis, cL l d : docs)
451
               SpliceD _ d
452
                 -> addFatalError l $
453 454 455 456
                    hang (text "Declaration splices are allowed only" <+>
                          text "at the top level:")
                       2 (ppr d)
               _ -> pprPanic "cvBindsAndSigs" (ppr decl) }
457 458 459 460

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

461 462
getMonoBind :: LHsBind GhcPs -> [LHsDecl GhcPs]
  -> (LHsBind GhcPs, [LHsDecl GhcPs])
463 464 465
-- 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
466 467 468 469 470

-- 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.
--
471
-- All Haddock comments between equations inside the group are
472 473
-- discarded.
--
474 475
-- No AndMonoBinds or EmptyMonoBinds here; just single equations

476 477 478 479
getMonoBind (dL->L loc1 (FunBind { fun_id = fun_id1@(dL->L _ f1)
                                 , fun_matches =
                                   MG { mg_alts = (dL->L _ mtchs1) } }))
            binds
480
  | has_args mtchs1
481
  = go mtchs1 loc1 binds []
482
  where
483
    go mtchs loc
484 485 486 487
       ((dL->L loc2 (ValD _ (FunBind { fun_id = (dL->L _ f2)
                                    , fun_matches =
                                        MG { mg_alts = (dL->L _ mtchs2) } })))
         : binds) _
488
        | f1 == f2 = go (mtchs2 ++ mtchs)
489
                        (combineSrcSpans loc loc2) binds []
490
    go mtchs loc (doc_decl@(dL->L loc2 (DocD {})) : binds) doc_decls
491
        = let doc_decls' = doc_decl : doc_decls
492 493
          in go mtchs (combineSrcSpans loc loc2) binds doc_decls'
    go mtchs loc binds doc_decls
494
        = ( cL loc (makeFunBind fun_id1 (reverse mtchs))
495
          , (reverse doc_decls) ++ binds)
496
        -- Reverse the final matches, to get it back in the right order
497
        -- Do the same thing with the trailing doc comments
498

499 500
getMonoBind bind binds = (bind, binds)

501
has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool
502
has_args []                                    = panic "RdrHsSyn:has_args"
503
has_args ((dL->L _ (Match { m_pats = args })) : _) = not (null args)
504 505 506 507
        -- 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).
508 509
has_args ((dL->L _ (XMatch _)) : _) = panic "has_args"
has_args (_ : _) = panic "has_args:Impossible Match" -- due to #15884
510

rodlogic's avatar
rodlogic committed
511 512 513
{- **********************************************************************

  #PrefixToHS-utils# Utilities for conversion
514

rodlogic's avatar
rodlogic committed
515
  ********************************************************************* -}
516

Simon Peyton Jones's avatar
Simon Peyton Jones committed
517 518
{- Note [Parsing data constructors is hard]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590

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

Simon Peyton Jones's avatar
Simon Peyton Jones committed
592
-}
593

594 595
-- | Reinterpret a type constructor, including type operators, as a data
--   constructor.
Simon Peyton Jones's avatar
Simon Peyton Jones committed
596
-- See Note [Parsing data constructors is hard]
597
tyConToDataCon :: SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
598
tyConToDataCon loc tc
599
  | isTcOcc occ || isDataOcc occ
Simon Peyton Jones's avatar
Simon Peyton Jones committed
600
  , isLexCon (occNameFS occ)
601
  = return (cL loc (setRdrNameSpace tc srcDataName))
Simon Peyton Jones's avatar
Simon Peyton Jones committed
602 603

  | otherwise
604
  = Left (loc, msg)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
605 606 607
  where
    occ = rdrNameOcc tc
    msg = text "Not a data constructor:" <+> quotes (ppr tc)
608

609
mkPatSynMatchGroup :: Located RdrName
610 611
                   -> Located (OrdList (LHsDecl GhcPs))
                   -> P (MatchGroup GhcPs (LHsExpr GhcPs))
612
mkPatSynMatchGroup (dL->L loc patsyn_name) (dL->L _ decls) =
613
    do { matches <- mapM fromDecl (fromOL decls)
614
       ; when (null matches) (wrongNumberErr loc)
615 616
       ; return $ mkMatchGroup FromSource matches }
  where
617 618
    fromDecl (dL->L loc decl@(ValD _ (PatBind _
                             pat@(dL->L _ (ConPatIn ln@(dL->L _ name) details))
619
                                   rhs _))) =
620 621 622
        do { unless (name == patsyn_name) $
               wrongNameBindingErr loc decl
           ; match <- case details of
623 624
               PrefixCon pats -> return $ Match { m_ext = noExt
                                                , m_ctxt = ctxt, m_pats = pats
625
                                                , m_grhss = rhs }
Simon Peyton Jones's avatar
Simon Peyton Jones committed
626
                   where
627 628 629
                     ctxt = FunRhs { mc_fun = ln
                                   , mc_fixity = Prefix
                                   , mc_strictness = NoSrcStrict }
Simon Peyton Jones's avatar
Simon Peyton Jones committed
630

631 632 633
               InfixCon p1 p2 -> return $ Match { m_ext = noExt
                                                , m_ctxt = ctxt
                                                , m_pats = [p1, p2]
634
                                                , m_grhss = rhs }
Simon Peyton Jones's avatar
Simon Peyton Jones committed
635
                   where
636 637 638
                     ctxt = FunRhs { mc_fun = ln
                                   , mc_fixity = Infix
                                   , mc_strictness = NoSrcStrict }
Simon Peyton Jones's avatar
Simon Peyton Jones committed
639

640
               RecCon{} -> recordPatSynErr loc pat
641 642
           ; return $ cL loc match }
    fromDecl (dL->L loc decl) = extraDeclErr loc decl
643 644

    extraDeclErr loc decl =
645
        addFatalError loc $
646 647 648 649
        text "pattern synonym 'where' clause must contain a single binding:" $$
        ppr decl

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

654
    wrongNumberErr loc =
655
      addFatalError loc $
656
      text "pattern synonym 'where' clause cannot be empty" $$
657 658
      text "In the pattern synonym declaration for: " <+> ppr (patsyn_name)

659
recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a
Simon Peyton Jones's avatar
Simon Peyton Jones committed
660
recordPatSynErr loc pat =
661
    addFatalError loc $
Simon Peyton Jones's avatar
Simon Peyton Jones committed
662 663 664
    text "record syntax not supported for pattern synonym declarations:" $$
    ppr pat

665
mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr GhcPs]
666
                -> Maybe (LHsContext GhcPs) -> HsConDeclDetails GhcPs
667
                -> ConDecl GhcPs
668

669
mkConDeclH98 name mb_forall mb_cxt args
670 671
  = ConDeclH98 { con_ext    = noExt
               , con_name   = name
672
               , con_forall = noLoc $ isJust mb_forall
673 674
               , con_ex_tvs = mb_forall `orElse` []
               , con_mb_cxt = mb_cxt
675
               , con_args   = args'
676
               , con_doc    = Nothing }
677 678
  where
    args' = nudgeHsSrcBangs args
679

680
mkGadtDecl :: [Located RdrName]
681
           -> LHsType GhcPs     -- Always a HsForAllTy
682
           -> (ConDecl GhcPs, [AddAnn])
683
mkGadtDecl names ty
684 685
  = (ConDeclGADT { con_g_ext  = noExt
                 , con_names  = names
686
                 , con_forall = cL l $ isLHsForAllTy ty'
687 688 689 690 691
                 , con_qvars  = mkHsQTvs tvs
                 , con_mb_cxt = mcxt
                 , con_args   = args'
                 , con_res_ty = res_ty
                 , con_doc    = Nothing }
692
    , anns1 ++ anns2)
693
  where
694
    (ty'@(dL->L l _),anns1) = peel_parens ty []
Ryan Scott's avatar
Ryan Scott committed
695
    (tvs, rho) = splitLHsForAllTyInvis ty'
696
    (mcxt, tau, anns2) = split_rho rho []
697

698 699 700 701 702 703
    split_rho (dL->L _ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) ann
      = (Just cxt, tau, ann)
    split_rho (dL->L l (HsParTy _ ty)) ann
      = split_rho ty (ann++mkParensApiAnn l)
    split_rho tau                  ann
      = (Nothing, tau, ann)
704

705
    (args, res_ty) = split_tau tau
706
    args' = nudgeHsSrcBangs args
707 708

    -- See Note [GADT abstract syntax] in HsDecls
709 710 711 712
    split_tau (dL->L _ (HsFunTy _ (dL->L loc (HsRecTy _ rf)) res_ty))
      = (RecCon (cL loc rf), res_ty)
    split_tau tau
      = (PrefixCon [], tau)
713

714
    peel_parens (dL->L l (HsParTy _ ty)) ann = peel_parens ty
715 716
                                                       (ann++mkParensApiAnn l)
    peel_parens ty                   ann = (ty, ann)
717

718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734
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
735 736
    go (dL->L l (HsDocTy _ (dL->L _ (HsBangTy _ s lty)) lds)) =
      cL l (HsBangTy noExt s (addCLoc lty lds (HsDocTy noExt lty lds)))
737 738 739
    go lty = lty


740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806