RdrHsSyn.hs 71.1 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
        splitCon, mkInlinePragma,
23
        mkPatSynMatchGroup,
24
        mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
25
        mkTyClD, mkInstD,
26
        mkRdrRecordCon, mkRdrRecordUpd,
27
        setRdrNameSpace,
28

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

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

        -- Bunch of functions in the parser monad for
        -- checking and constructing values
45
        checkBlockArguments,
46 47
        checkPrecP,           -- Int -> P Int
        checkContext,         -- HsType -> P HsContext
48
        checkInfixConstr,
49
        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
        checkRecordSyntax,
Tao He's avatar
Tao He committed
58
        checkEmptyGADTs,
59
        parseErrorSDoc, hintBangPat,
60 61
        splitTilde,
        TyEl(..), mergeOps,
62 63 64

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

71 72 73 74
        -- Warnings and errors
        warnStarIsType,
        failOpFewArgs,

75
        SumOrTuple (..), mkSumOrTuple
76

77 78
    ) where

79
import GhcPrelude
80
import HsSyn            -- Lots of it
81
import Class            ( FunDep )
82 83 84
import TyCon            ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe )
import DataCon          ( DataCon, dataConTyCon )
import ConLike          ( ConLike(..) )
85
import CoAxiom          ( Role, fsFromRole )
86 87 88
import RdrName
import Name
import BasicTypes
89
import TcEvidence       ( idHsWrapper )
90
import Lexer
Simon Peyton Jones's avatar
Simon Peyton Jones committed
91
import Lexeme           ( isLexCon )
92 93 94
import Type             ( TyThing(..) )
import TysWiredIn       ( cTupleTyConName, tupleTyCon, tupleDataCon,
                          nilDataConName, nilDataConKey,
95
                          listTyConName, listTyConKey )
96
import ForeignCall
97
import PrelNames        ( forall_tv_RDR, eqTyCon_RDR, allNameStrings )
98
import SrcLoc
99
import Unique           ( hasKey )
100
import OrdList          ( OrdList, fromOL )
Gergő Érdi's avatar
Gergő Érdi committed
101
import Bag              ( emptyBag, consBag )
102 103
import Outputable
import FastString
104
import Maybes
105
import Util
Alan Zimmerman's avatar
Alan Zimmerman committed
106
import ApiAnnotation
107
import HsExtension      ( noExt )
108
import Data.List
109
import qualified GHC.LanguageExtensions as LangExt
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)
Alan Zimmerman's avatar
Alan Zimmerman committed
145
            -> Located (a,[Located (FunDep (Located RdrName))])
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
       ; at_defs <- mapM (eitherToP . mkATDefault) at_insts
156 157
       ; return (L loc (ClassDecl { tcdCExt = noExt, tcdCtxt = cxt
                                  , tcdLName = cls, tcdTyVars = tyvars
158
                                  , tcdFixity = fixity
159 160 161
                                  , tcdFDs = snd (unLoc fds)
                                  , tcdSigs = mkClassOpSigs sigs
                                  , tcdMeths = binds
162 163
                                  , tcdATs = ats, tcdATDefs = at_defs
                                  , tcdDocs  = docs })) }
164

165 166
mkATDefault :: LTyFamInstDecl GhcPs
            -> Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs)
167 168 169
-- Take a type-family instance declaration and turn it into
-- a type-family default equation for a class declaration
-- We parse things as the former and use this function to convert to the latter
rodlogic's avatar
rodlogic committed
170 171
--
-- We use the Either monad because this also called
172
-- from Convert.hs
173 174 175 176
mkATDefault (L loc (TyFamInstDecl { tfid_eqn = HsIB { hsib_body = e }}))
      | FamEqn { feqn_tycon = tc, feqn_pats = pats, feqn_fixity = fixity
               , feqn_rhs = rhs } <- e
      = do { tvs <- checkTyVars (text "default") equalsDots tc pats
177 178
           ; return (L loc (FamEqn { feqn_ext    = noExt
                                   , feqn_tycon  = tc
179 180 181
                                   , feqn_pats   = tvs
                                   , feqn_fixity = fixity
                                   , feqn_rhs    = rhs })) }
182 183
mkATDefault (L _ (TyFamInstDecl (HsIB _ (XFamEqn _)))) = panic "mkATDefault"
mkATDefault (L _ (TyFamInstDecl (XHsImplicitBndrs _))) = panic "mkATDefault"
184

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

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

220

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

234 235 236
mkTyFamInstEqn :: LHsType GhcPs
               -> LHsType GhcPs
               -> P (TyFamInstEqn GhcPs,[AddAnn])
237
mkTyFamInstEqn lhs rhs
238
  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
239
       ; return (mkHsImplicitBndrs
240 241
                  (FamEqn { feqn_ext    = noExt
                          , feqn_tycon  = tc
242 243 244
                          , feqn_pats   = tparams
                          , feqn_fixity = fixity
                          , feqn_rhs    = rhs }),
Alan Zimmerman's avatar
Alan Zimmerman committed
245
                 ann) }
246

247
mkDataFamInst :: SrcSpan
Jan Stolarek's avatar
Jan Stolarek committed
248 249
              -> NewOrData
              -> Maybe (Located CType)
250 251 252 253 254
              -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
              -> Maybe (LHsKind GhcPs)
              -> [LConDecl GhcPs]
              -> HsDeriving GhcPs
              -> P (LInstDecl GhcPs)
255
mkDataFamInst loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
256
  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
Alan Zimmerman's avatar
Alan Zimmerman committed
257
       ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
258
       ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
259 260 261 262
       ; return (L loc (DataFamInstD noExt (DataFamInstDecl (mkHsImplicitBndrs
                  (FamEqn { feqn_ext    = noExt
                          , feqn_tycon  = tc
                          , feqn_pats   = tparams
263
                          , feqn_fixity = fixity
264
                          , feqn_rhs    = defn }))))) }
265

266
mkTyFamInst :: SrcSpan
267
            -> TyFamInstEqn GhcPs
268
            -> P (LInstDecl GhcPs)
269
mkTyFamInst loc eqn
270
  = return (L loc (TyFamInstD noExt (TyFamInstDecl eqn)))
271 272

mkFamDecl :: SrcSpan
273 274 275 276 277
          -> 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
278
mkFamDecl loc info lhs ksig injAnn
279
  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
Alan Zimmerman's avatar
Alan Zimmerman committed
280
       ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
281
       ; tyvars <- checkTyVarsP (ppr info) equals_or_where tc tparams
282 283 284
       ; return (L loc (FamDecl noExt (FamilyDecl
                                           { fdExt       = noExt
                                           , fdInfo      = info, fdLName = tc
Jan Stolarek's avatar
Jan Stolarek committed
285
                                           , fdTyVars    = tyvars
286
                                           , fdFixity    = fixity
Jan Stolarek's avatar
Jan Stolarek committed
287 288
                                           , fdResultSig = ksig
                                           , fdInjectivityAnn = injAnn }))) }
289 290 291 292 293
  where
    equals_or_where = case info of
                        DataFamily          -> empty
                        OpenTypeFamily      -> empty
                        ClosedTypeFamily {} -> whereDots
294

295
mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs
296
-- If the user wrote
297
--      [pads| ... ]   then return a QuasiQuoteD
298
--      $(e)           then return a SpliceD
299 300
-- but if she wrote, say,
--      f x            then behave as if she'd written $(f x)
301
--                     ie a SpliceD
302 303 304
--
-- Typed splices are not allowed at the top level, thus we do not represent them
-- as spliced declaration.  See #10945
305
mkSpliceDecl lexpr@(L loc expr)
306
  | HsSpliceE _ splice@(HsUntypedSplice {}) <- expr
307
  = SpliceD noExt (SpliceDecl noExt (L loc splice) ExplicitSplice)
308

309
  | HsSpliceE _ splice@(HsQuasiQuote {}) <- expr
310
  = SpliceD noExt (SpliceDecl noExt (L loc splice) ExplicitSplice)
311 312

  | otherwise
313 314
  = SpliceD noExt (SpliceDecl noExt (L loc (mkUntypedSplice NoParens lexpr))
                              ImplicitSplice)
315

316
mkRoleAnnotDecl :: SrcSpan
317
                -> Located RdrName                -- type being annotated
318
                -> [Located (Maybe FastString)]      -- roles
319
                -> P (LRoleAnnotDecl GhcPs)
320 321
mkRoleAnnotDecl loc tycon roles
  = do { roles' <- mapM parse_role roles
322
       ; return $ L loc $ RoleAnnotDecl noExt tycon roles' }
323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342
  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)
343

rodlogic's avatar
rodlogic committed
344 345 346
{- **********************************************************************

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

rodlogic's avatar
rodlogic committed
348 349 350 351 352
  ********************************************************************* -}

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


355
--  | Groups together bindings for a single function
356
cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]
357
cvTopDecls decls = go (fromOL decls)
358
  where
359
    go :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
360 361
    go []                     = []
    go (L l (ValD x b) : ds)  = L l' (ValD x b') : go ds'
362
                            where (L l' b', ds') = getMonoBind (L l b) ds
363
    go (d : ds)               = d : go ds
364

365
-- Declaration list may only contain value bindings and signatures.
366
cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs)
367
cvBindGroup binding
368 369
  = do { (mbs, sigs, fam_ds, tfam_insts, dfam_insts, _) <- cvBindsAndSigs binding
       ; ASSERT( null fam_ds && null tfam_insts && null dfam_insts)
370
         return $ ValBinds noExt mbs sigs }
371

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

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

409 410
getMonoBind :: LHsBind GhcPs -> [LHsDecl GhcPs]
  -> (LHsBind GhcPs, [LHsDecl GhcPs])
411 412 413
-- 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
414 415 416 417 418

-- 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.
--
419
-- All Haddock comments between equations inside the group are
420 421
-- discarded.
--
422 423
-- No AndMonoBinds or EmptyMonoBinds here; just single equations

424
getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1),
425 426
                               fun_matches
                                 = MG { mg_alts = L _ mtchs1 } })) binds
427
  | has_args mtchs1
428
  = go mtchs1 loc1 binds []
429
  where
430
    go mtchs loc
431 432 433
       (L loc2 (ValD _ (FunBind { fun_id = L _ f2,
                                  fun_matches
                                    = MG { mg_alts = L _ mtchs2 } })) : binds) _
434
        | f1 == f2 = go (mtchs2 ++ mtchs)
435
                        (combineSrcSpans loc loc2) binds []
436
    go mtchs loc (doc_decl@(L loc2 (DocD {})) : binds) doc_decls
437
        = let doc_decls' = doc_decl : doc_decls
438 439
          in go mtchs (combineSrcSpans loc loc2) binds doc_decls'
    go mtchs loc binds doc_decls
440
        = ( L loc (makeFunBind fun_id1 (reverse mtchs))
441
          , (reverse doc_decls) ++ binds)
442
        -- Reverse the final matches, to get it back in the right order
443
        -- Do the same thing with the trailing doc comments
444

445 446
getMonoBind bind binds = (bind, binds)

447
has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool
448 449
has_args []                                    = panic "RdrHsSyn:has_args"
has_args ((L _ (Match { m_pats = args })) : _) = not (null args)
450 451 452 453
        -- 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).
454
has_args ((L _ (XMatch _)) : _) = panic "has_args"
455

rodlogic's avatar
rodlogic committed
456 457 458
{- **********************************************************************

  #PrefixToHS-utils# Utilities for conversion
459

rodlogic's avatar
rodlogic committed
460
  ********************************************************************* -}
461

Simon Peyton Jones's avatar
Simon Peyton Jones committed
462 463 464 465 466 467 468 469 470 471 472 473 474
{- Note [Parsing data constructors is hard]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We parse the RHS of the constructor declaration
     data T = C t1 t2
as a btype_no_ops (treating C as a type constructor) and then convert C to be
a data constructor.  Reason: it might continue like this:
     data T = C t1 t2 :% D Int
in which case C really /would/ be a type constructor.  We can't resolve this
ambiguity till we come across the constructor oprerator :% (or not, more usually)

So the plan is:

* Parse the data constructor declration as a type (actually btype_no_ops)
475

476 477
* Use 'splitCon' to rejig it into the data constructor, the args, and possibly
  extract a docstring for the constructor
Simon Peyton Jones's avatar
Simon Peyton Jones committed
478 479 480 481 482 483 484 485

* In doing so, we use 'tyConToDataCon' to convert the RdrName for
  the data con, which has been parsed as a tycon, back to a datacon.
  This is more than just adjusting the name space; for operators we
  need to check that it begins with a colon.  E.g.
     data T = (+++)
  will parse ok (since tycons can be operators), but we should reject
  it (Trac #12051).
486 487 488 489 490 491

'splitCon' takes a reversed list @apps@ of types as input, such that
@foldl1 mkHsAppTy (reverse apps)@ yields the original type. This is because
this is easy for the parser to produce and we avoid the overhead of unrolling
'HsAppTy'.

Simon Peyton Jones's avatar
Simon Peyton Jones committed
492
-}
493

494
splitCon :: [LHsType GhcPs]
495 496 497 498
      -> P ( Located RdrName         -- constructor name
           , HsConDeclDetails GhcPs  -- constructor field information
           , Maybe LHsDocString      -- docstring to go on the constructor
           )
Simon Peyton Jones's avatar
Simon Peyton Jones committed
499
-- See Note [Parsing data constructors is hard]
500 501 502 503
-- This gets given a "type" that should look like
--      C Int Bool
-- or   C { x::Int, y::Bool }
-- and returns the pieces
504
splitCon apps
505
 = split apps' []
506
 where
507
   oneDoc = [ () | L _ (HsDocTy{}) <- apps ] `lengthIs` 1
508
   ty = foldl1 mkHsAppTy (reverse apps)
509 510 511 512

   -- the trailing doc, if any, can be extracted first
   (apps', trailing_doc)
     = case apps of
513
         L _ (HsDocTy _ t ds) : ts | oneDoc -> (t : ts, Just ds)
514 515 516 517 518
         ts -> (ts, Nothing)

   -- A comment on the constructor is handled a bit differently - it doesn't
   -- remain an 'HsDocTy', but gets lifted out and returned as the third
   -- element of the tuple.
519
   split [ L _ (HsDocTy _ con con_doc) ] ts = do
520 521
     (data_con, con_details, con_doc') <- split [con] ts
     return (data_con, con_details, con_doc' `mplus` Just con_doc)
522
   split [ L l (HsTyVar _ _ (L _ tc)) ] ts = do
523 524
     data_con <- tyConToDataCon l tc
     return (data_con, mk_rest ts, trailing_doc)
525
   split [ L l (HsTupleTy _ HsBoxedOrConstraintTuple ts) ] []
526 527 528 529 530 531 532 533 534
     = return ( L l (getRdrName (tupleDataCon Boxed (length ts)))
              , PrefixCon ts
              , trailing_doc
              )
   split [ L l _ ] _ = parseErrorSDoc l (text msg <+> ppr ty)
     where msg = "Cannot parse data constructor in a data/newtype declaration:"
   split (u : us) ts = split us (u : ts)
   split _ _ = panic "RdrHsSyn:splitCon"

535 536 537
   mk_rest [L _ (HsDocTy _ t@(L _ HsRecTy{}) _)] = mk_rest [t]
   mk_rest [L l (HsRecTy _ flds)] = RecCon (L l flds)
   mk_rest ts                     = PrefixCon ts
538

Simon Peyton Jones's avatar
Simon Peyton Jones committed
539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555
tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
-- See Note [Parsing data constructors is hard]
-- Data constructor RHSs are parsed as types
tyConToDataCon loc tc
  | isTcOcc occ
  , isLexCon (occNameFS occ)
  = return (L loc (setRdrNameSpace tc srcDataName))

  | otherwise
  = parseErrorSDoc loc (msg $$ extra)
  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
556

557 558 559
-- | Split a type to extract the trailing doc string (if there is one) from a
-- type produced by the 'btype_no_ops' production.
splitDocTy :: LHsType GhcPs -> (LHsType GhcPs, Maybe LHsDocString)
560
splitDocTy (L l (HsAppTy x t1 t2)) = (L l (HsAppTy x t1 t2'), ds)
561
  where ~(t2', ds) = splitDocTy t2
562
splitDocTy (L _ (HsDocTy _ ty ds)) = (ty, Just ds)
563 564 565 566 567 568 569 570 571 572
splitDocTy ty = (ty, Nothing)

-- | Given a type that is a field to an infix data constructor, try to split
-- off a trailing docstring on the type, and check that there are no other
-- docstrings.
checkInfixConstr :: LHsType GhcPs -> P (LHsType GhcPs, Maybe LHsDocString)
checkInfixConstr ty = checkNoDocs msg ty' *> pure (ty', doc_string)
  where (ty', doc_string) = splitDocTy ty
        msg = text "infix constructor field"

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

593 594 595
               InfixCon p1 p2 -> return $ Match { m_ext = noExt
                                                , m_ctxt = ctxt
                                                , m_pats = [p1, p2]
596
                                                , m_grhss = rhs }
Simon Peyton Jones's avatar
Simon Peyton Jones committed
597 598 599
                   where
                     ctxt = FunRhs { mc_fun = ln, mc_fixity = Infix, mc_strictness = NoSrcStrict }

600 601 602 603 604 605 606 607 608 609 610 611 612 613
               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

614 615
    wrongNumberErr loc =
      parseErrorSDoc loc $
616
      text "pattern synonym 'where' clause cannot be empty" $$
617 618
      text "In the pattern synonym declaration for: " <+> ppr (patsyn_name)

619
recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a
Simon Peyton Jones's avatar
Simon Peyton Jones committed
620 621 622 623 624
recordPatSynErr loc pat =
    parseErrorSDoc loc $
    text "record syntax not supported for pattern synonym declarations:" $$
    ppr pat

625
mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr GhcPs]
626
                -> Maybe (LHsContext GhcPs) -> HsConDeclDetails GhcPs
627
                -> ConDecl GhcPs
628

629
mkConDeclH98 name mb_forall mb_cxt args
630 631
  = ConDeclH98 { con_ext    = noExt
               , con_name   = name
632
               , con_forall = noLoc $ isJust mb_forall
633 634
               , con_ex_tvs = mb_forall `orElse` []
               , con_mb_cxt = mb_cxt
635
               , con_args   = args'
636
               , con_doc    = Nothing }
637 638
  where
    args' = nudgeHsSrcBangs args
639

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

658 659 660 661
    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)
662

663
    (args, res_ty) = split_tau tau
664
    args' = nudgeHsSrcBangs args
665 666

    -- See Note [GADT abstract syntax] in HsDecls
667 668 669
    split_tau (L _ (HsFunTy _ (L loc (HsRecTy _ rf)) res_ty))
                                   = (RecCon (L loc rf), res_ty)
    split_tau tau                  = (PrefixCon [], tau)
670 671 672 673

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

675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696
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


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 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781
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))


{- 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!
-}

782 783
checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType GhcPs]
             -> P (LHsQTyVars GhcPs)
784
-- Same as checkTyVars, but in the P monad
rodlogic's avatar
rodlogic committed
785 786
checkTyVarsP pp_what equals_or_where tc tparms
  = eitherToP $ checkTyVars pp_what equals_or_where tc tparms
787 788 789 790 791

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
792

793 794
checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsType GhcPs]
            -> Either (SrcSpan, SDoc) (LHsQTyVars GhcPs)
795
-- Check whether the given list of type parameters are all type variables
796 797 798
-- (possibly with a kind signature)
-- We use the Either monad because it's also called (via mkATDefault) from
-- Convert.hs