RdrHsSyn.hs 55.8 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

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

26
        cvBindGroup,
27
        cvBindsAndSigs,
28
        cvTopDecls,
29
        placeHolderPunRhs,
30

31
32
        -- Stuff to do with Foreign declarations
        mkImport,
33
        parseCImport,
34
35
36
37
        mkExport,
        mkExtName,           -- RdrName -> CLabelString
        mkGadtDecl,          -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName
        mkSimpleConDecl,
38
        mkATDefault,
39
40
41
42
43
44

        -- Bunch of functions in the parser monad for
        -- checking and constructing values
        checkPrecP,           -- Int -> P Int
        checkContext,         -- HsType -> P HsContext
        checkPattern,         -- HsExp -> P HsPat
batterseapower's avatar
batterseapower committed
45
        bang_RDR,
46
47
        checkPatterns,        -- SrcLoc -> [HsExp] -> P [HsPat]
        checkMonadComp,       -- P (HsStmtContext RdrName)
48
        checkCommand,         -- LHsExpr RdrName -> P (LHsCmd RdrName)
49
50
51
        checkValDef,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
        checkValSig,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
        checkDoAndIfThenElse,
52
        checkRecordSyntax,
53
        parseErrorSDoc,
54
        splitTilde,
55
56
57

        -- Help with processing exports
        ImpExpSubSpec(..),
58
        mkModuleImpExp,
59
60
61
        mkTypeImpExp,
        mkImpExpSubSpec,
        checkImportSpec
62

63
64
    ) where

65
import HsSyn            -- Lots of it
66
import Class            ( FunDep )
67
68
69
import TyCon            ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe )
import DataCon          ( DataCon, dataConTyCon )
import ConLike          ( ConLike(..) )
70
import CoAxiom          ( Role, fsFromRole )
71
72
73
import RdrName
import Name
import BasicTypes
74
import TcEvidence       ( idHsWrapper )
75
import Lexer
76
77
78
79
import Type             ( TyThing(..) )
import TysWiredIn       ( cTupleTyConName, tupleTyCon, tupleDataCon,
                          nilDataConName, nilDataConKey,
                          listTyConName, listTyConKey )
80
import ForeignCall
81
import PrelNames        ( forall_tv_RDR, allNameStrings )
82
import DynFlags
83
import SrcLoc
84
import Unique           ( hasKey )
85
import OrdList          ( OrdList, fromOL )
Gergő Érdi's avatar
Gergő Érdi committed
86
import Bag              ( emptyBag, consBag )
87
88
import Outputable
import FastString
89
import Maybes
90
import Util
Alan Zimmerman's avatar
Alan Zimmerman committed
91
import ApiAnnotation
92
import Data.List
93

94
#if __GLASGOW_HASKELL__ < 709
95
import Control.Applicative ((<$>))
96
#endif
97
import Control.Monad
98

99
import Text.ParserCombinators.ReadP as ReadP
Ian Lynagh's avatar
Ian Lynagh committed
100
import Data.Char
101

102
103
import Data.Data       ( dataTypeOf, fromConstr, dataTypeConstrs )

104
#include "HsVersions.h"
105

106

rodlogic's avatar
rodlogic committed
107
108
109
{- **********************************************************************

  Construction functions for Rdr stuff
110

rodlogic's avatar
rodlogic committed
111
  ********************************************************************* -}
112

rodlogic's avatar
rodlogic committed
113
114
115
116
117
-- | 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).
118

rodlogic's avatar
rodlogic committed
119
120
121
-- Similarly for mkConDecl, mkClassOpSig and default-method names.

--         *** See "THE NAMING STORY" in HsDecls ****
122

123
124
125
126
127
128
mkTyClD :: LTyClDecl n -> LHsDecl n
mkTyClD (L loc d) = L loc (TyClD d)

mkInstD :: LInstDecl n -> LHsDecl n
mkInstD (L loc d) = L loc (InstD d)

129
mkClassDecl :: SrcSpan
130
            -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
Alan Zimmerman's avatar
Alan Zimmerman committed
131
            -> Located (a,[Located (FunDep (Located RdrName))])
132
            -> OrdList (LHsDecl RdrName)
133
            -> P (LTyClDecl RdrName)
134

135
mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
136
137
  = do { (binds, sigs, ats, at_insts, _, docs) <- cvBindsAndSigs where_cls
       ; let cxt = fromMaybe (noLoc []) mcxt
138
       ; (cls, tparams,ann) <- checkTyClHdr True tycl_hdr
Alan Zimmerman's avatar
Alan Zimmerman committed
139
       ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
140
141
       ; tyvars <- checkTyVarsP (ptext (sLit "class")) whereDots cls tparams
       ; at_defs <- mapM (eitherToP . mkATDefault) at_insts
142
       ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars,
Alan Zimmerman's avatar
Alan Zimmerman committed
143
144
                                    tcdFDs = snd (unLoc fds), tcdSigs = sigs,
                                    tcdMeths = binds,
145
146
                                    tcdATs = ats, tcdATDefs = at_defs, tcdDocs  = docs,
                                    tcdFVs = placeHolderNames })) }
147

148
149
150
151
152
mkATDefault :: LTyFamInstDecl RdrName
            -> Either (SrcSpan, SDoc) (LTyFamDefltEqn RdrName)
-- 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
153
154
--
-- We use the Either monad because this also called
155
156
157
158
159
160
161
162
-- from Convert.hs
mkATDefault (L loc (TyFamInstDecl { tfid_eqn = L _ e }))
      | TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_rhs = rhs } <- e
      = do { tvs <- checkTyVars (ptext (sLit "default")) equalsDots tc (hswb_cts pats)
           ; return (L loc (TyFamEqn { tfe_tycon = tc
                                     , tfe_pats = tvs
                                     , tfe_rhs = rhs })) }

163
164
mkTyData :: SrcSpan
         -> NewOrData
165
         -> Maybe (Located CType)
166
         -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
167
         -> Maybe (LHsKind RdrName)
168
         -> [LConDecl RdrName]
169
         -> Maybe (Located [LHsType RdrName])
170
         -> P (LTyClDecl RdrName)
171
mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
172
  = do { (tc, tparams,ann) <- checkTyClHdr False tycl_hdr
Alan Zimmerman's avatar
Alan Zimmerman committed
173
       ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
174
       ; tyvars <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams
175
       ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
176
       ; return (L loc (DataDecl { tcdLName = tc, tcdTyVars = tyvars,
177
178
                                   tcdDataDefn = defn,
                                   tcdFVs = placeHolderNames })) }
179

180
mkDataDefn :: NewOrData
181
           -> Maybe (Located CType)
182
           -> Maybe (LHsContext RdrName)
183
           -> Maybe (LHsKind RdrName)
184
           -> [LConDecl RdrName]
185
           -> Maybe (Located [LHsType RdrName])
186
           -> P (HsDataDefn RdrName)
187
188
mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
  = do { checkDatatypeContext mcxt
189
       ; let cxt = fromMaybe (noLoc []) mcxt
190
       ; return (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
rodlogic's avatar
rodlogic committed
191
                            , dd_ctxt = cxt
192
193
194
                            , dd_cons = data_cons
                            , dd_kindSig = ksig
                            , dd_derivs = maybe_deriv }) }
thomasw's avatar
thomasw committed
195

196

197
mkTySynonym :: SrcSpan
198
            -> LHsType RdrName  -- LHS
199
            -> LHsType RdrName  -- RHS
200
            -> P (LTyClDecl RdrName)
201
mkTySynonym loc lhs rhs
202
  = do { (tc, tparams,ann) <- checkTyClHdr False lhs
Alan Zimmerman's avatar
Alan Zimmerman committed
203
       ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
204
       ; tyvars <- checkTyVarsP (ptext (sLit "type")) equalsDots tc tparams
205
       ; return (L loc (SynDecl { tcdLName = tc, tcdTyVars = tyvars
206
                                , tcdRhs = rhs, tcdFVs = placeHolderNames })) }
207

208
mkTyFamInstEqn :: LHsType RdrName
209
               -> LHsType RdrName
Alan Zimmerman's avatar
Alan Zimmerman committed
210
               -> P (TyFamInstEqn RdrName,[AddAnn])
211
mkTyFamInstEqn lhs rhs
thomasw's avatar
thomasw committed
212
  = do { (tc, tparams, ann) <- checkTyClHdr False lhs
213
214
       ; return (TyFamEqn { tfe_tycon = tc
                          , tfe_pats  = mkHsWithBndrs tparams
Alan Zimmerman's avatar
Alan Zimmerman committed
215
216
                          , tfe_rhs   = rhs },
                 ann) }
217

218
mkDataFamInst :: SrcSpan
Jan Stolarek's avatar
Jan Stolarek committed
219
220
221
222
223
224
225
              -> NewOrData
              -> Maybe (Located CType)
              -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
              -> Maybe (LHsKind RdrName)
              -> [LConDecl RdrName]
              -> Maybe (Located [LHsType RdrName])
              -> P (LInstDecl RdrName)
226
mkDataFamInst loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
227
  = do { (tc, tparams,ann) <- checkTyClHdr False tycl_hdr
Alan Zimmerman's avatar
Alan Zimmerman committed
228
       ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
229
230
       ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
       ; return (L loc (DataFamInstD (
Adam Gundry's avatar
Adam Gundry committed
231
232
                  DataFamInstDecl { dfid_tycon = tc
                                  , dfid_pats = mkHsWithBndrs tparams
233
234
                                  , dfid_defn = defn, dfid_fvs = placeHolderNames }))) }

235
236
mkTyFamInst :: SrcSpan
            -> LTyFamInstEqn RdrName
237
            -> P (LInstDecl RdrName)
238
mkTyFamInst loc eqn
239
240
  = return (L loc (TyFamInstD (TyFamInstDecl { tfid_eqn  = eqn
                                             , tfid_fvs  = placeHolderNames })))
241
242

mkFamDecl :: SrcSpan
243
          -> FamilyInfo RdrName
Jan Stolarek's avatar
Jan Stolarek committed
244
245
246
          -> LHsType RdrName                   -- LHS
          -> Located (FamilyResultSig RdrName) -- Optional result signature
          -> Maybe (LInjectivityAnn RdrName)   -- Injectivity annotation
247
          -> P (LTyClDecl RdrName)
Jan Stolarek's avatar
Jan Stolarek committed
248
249
mkFamDecl loc info lhs ksig injAnn
  = do { (tc, tparams, ann) <- checkTyClHdr False lhs
Alan Zimmerman's avatar
Alan Zimmerman committed
250
       ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
251
       ; tyvars <- checkTyVarsP (ppr info) equals_or_where tc tparams
Jan Stolarek's avatar
Jan Stolarek committed
252
253
254
255
       ; return (L loc (FamDecl (FamilyDecl{ fdInfo      = info, fdLName = tc
                                           , fdTyVars    = tyvars
                                           , fdResultSig = ksig
                                           , fdInjectivityAnn = injAnn }))) }
256
257
258
259
260
  where
    equals_or_where = case info of
                        DataFamily          -> empty
                        OpenTypeFamily      -> empty
                        ClosedTypeFamily {} -> whereDots
261

262
mkSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName
263
-- If the user wrote
264
--      [pads| ... ]   then return a QuasiQuoteD
265
--      $(e)           then return a SpliceD
266
267
-- but if she wrote, say,
--      f x            then behave as if she'd written $(f x)
268
--                     ie a SpliceD
269
270
271
--
-- Typed splices are not allowed at the top level, thus we do not represent them
-- as spliced declaration.  See #10945
272
mkSpliceDecl lexpr@(L loc expr)
273
274
275
276
277
278
279
280
  | HsSpliceE splice@(HsUntypedSplice {}) <- expr
  = SpliceD (SpliceDecl (L loc splice) ExplicitSplice)

  | HsSpliceE splice@(HsQuasiQuote {}) <- expr
  = SpliceD (SpliceDecl (L loc splice) ExplicitSplice)

  | otherwise
  = SpliceD (SpliceDecl (L loc (mkUntypedSplice lexpr)) ImplicitSplice)
281

282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
mkRoleAnnotDecl :: SrcSpan
                -> Located RdrName                   -- type being annotated
                -> [Located (Maybe FastString)]      -- roles
                -> P (LRoleAnnotDecl RdrName)
mkRoleAnnotDecl loc tycon roles
  = do { roles' <- mapM parse_role roles
       ; return $ L loc $ RoleAnnotDecl tycon roles' }
  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)
309

rodlogic's avatar
rodlogic committed
310
311
312
{- **********************************************************************

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

rodlogic's avatar
rodlogic committed
314
315
316
317
318
  ********************************************************************* -}

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


321
--  | Groups together bindings for a single function
322
323
cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
cvTopDecls decls = go (fromOL decls)
324
  where
325
    go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
326
    go []                   = []
327
    go (L l (ValD b) : ds)  = L l' (ValD b') : go ds'
328
329
                            where (L l' b', ds') = getMonoBind (L l b) ds
    go (d : ds)             = d : go ds
330

331
-- Declaration list may only contain value bindings and signatures.
332
cvBindGroup :: OrdList (LHsDecl RdrName) -> P (HsValBinds RdrName)
333
cvBindGroup binding
334
335
336
  = do { (mbs, sigs, fam_ds, tfam_insts, dfam_insts, _) <- cvBindsAndSigs binding
       ; ASSERT( null fam_ds && null tfam_insts && null dfam_insts)
         return $ ValBindsIn mbs sigs }
337

338
cvBindsAndSigs :: OrdList (LHsDecl RdrName)
339
  -> P (LHsBinds RdrName, [LSig RdrName], [LFamilyDecl RdrName]
340
          , [LTyFamInstDecl RdrName], [LDataFamInstDecl RdrName], [LDocDecl])
341
-- Input decls contain just value bindings and signatures
342
-- and in case of class or instance declarations also
343
-- associated type declarations. They might also contain Haddock comments.
344
cvBindsAndSigs fb = go (fromOL fb)
345
  where
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
    go []              = return (emptyBag, [], [], [], [], [])
    go (L l (ValD b) : ds)
      = 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
               SigD s
                 -> return (bs, L l s : ss, ts, tfis, dfis, docs)
               TyClD (FamDecl t)
                 -> return (bs, ss, L l t : ts, tfis, dfis, docs)
               InstD (TyFamInstD { tfid_inst = tfi })
                 -> return (bs, ss, ts, L l tfi : tfis, dfis, docs)
               InstD (DataFamInstD { dfid_inst = dfi })
                 -> return (bs, ss, ts, tfis, L l dfi : dfis, docs)
               DocD d
                 -> return (bs, ss, ts, tfis, dfis, L l d : docs)
               SpliceD d
                 -> parseErrorSDoc l $
                    hang (text "Declaration splices are allowed only" <+>
                          text "at the top level:")
                       2 (ppr d)
               _ -> pprPanic "cvBindsAndSigs" (ppr decl) }
371
372
373
374

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

375
376
getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
  -> (LHsBind RdrName, [LHsDecl RdrName])
377
378
379
-- 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
380
381
382
383
384

-- 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.
--
385
-- All Haddock comments between equations inside the group are
386
387
-- discarded.
--
388
389
-- No AndMonoBinds or EmptyMonoBinds here; just single equations

390
getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1),
391
                               fun_matches = MG { mg_alts = mtchs1 } })) binds
392
  | has_args mtchs1
393
  = go mtchs1 loc1 binds []
394
  where
395
396
    go mtchs loc
       (L loc2 (ValD (FunBind { fun_id = L _ f2,
397
                                fun_matches = MG { mg_alts = mtchs2 } })) : binds) _
398
        | f1 == f2 = go (mtchs2 ++ mtchs)
399
                        (combineSrcSpans loc loc2) binds []
400
    go mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls
401
        = let doc_decls' = doc_decl : doc_decls
402
403
404
405
          in go mtchs (combineSrcSpans loc loc2) binds doc_decls'
    go mtchs loc binds doc_decls
        = ( L loc (makeFunBind fun_id1 (reverse mtchs))
          , (reverse doc_decls) ++ binds)
406
        -- Reverse the final matches, to get it back in the right order
407
        -- Do the same thing with the trailing doc comments
408

409
410
getMonoBind bind binds = (bind, binds)

411
has_args :: [LMatch RdrName (LHsExpr RdrName)] -> Bool
412
has_args []                           = panic "RdrHsSyn:has_args"
Alan Zimmerman's avatar
Alan Zimmerman committed
413
has_args ((L _ (Match _ args _ _)) : _) = not (null args)
414
415
416
417
        -- 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).
418

rodlogic's avatar
rodlogic committed
419
420
421
{- **********************************************************************

  #PrefixToHS-utils# Utilities for conversion
422

rodlogic's avatar
rodlogic committed
423
  ********************************************************************* -}
424

425
-----------------------------------------------------------------------------
426
-- splitCon
427
428
429
430
431
432

-- When parsing data declarations, we sometimes inadvertently parse
-- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
-- This function splits up the type application, adds any pending
-- arguments, and converts the type constructor back into a data constructor.

433
434
435
436
437
438
439
440
splitCon :: LHsType RdrName
      -> P (Located RdrName, HsConDeclDetails RdrName)
-- This gets given a "type" that should look like
--      C Int Bool
-- or   C { x::Int, y::Bool }
-- and returns the pieces
splitCon ty
 = split ty []
441
 where
442
443
444
   split (L _ (HsAppTy t u)) ts    = split t (u : ts)
   split (L l (HsTyVar tc))  ts    = do data_con <- tyConToDataCon l tc
                                        return (data_con, mk_rest ts)
445
446
447
   split (L l (HsTupleTy HsBoxedOrConstraintTuple ts)) []
      = return (L l (getRdrName (tupleDataCon Boxed (length ts))), PrefixCon ts)
   split (L l _) _ = parseErrorSDoc l (text "Cannot parse data constructor in a data/newtype declaration:" <+> ppr ty)
448

Alan Zimmerman's avatar
Alan Zimmerman committed
449
   mk_rest [L l (HsRecTy flds)] = RecCon (L l flds)
450
451
   mk_rest ts                   = PrefixCon ts

452
453
454
455
456
457
recordPatSynErr :: SrcSpan -> LPat RdrName -> P a
recordPatSynErr loc pat =
    parseErrorSDoc loc $
    text "record syntax not supported for pattern synonym declarations:" $$
    ppr pat

458
459
460
461
mkPatSynMatchGroup :: Located RdrName
                   -> Located (OrdList (LHsDecl RdrName))
                   -> P (MatchGroup RdrName (LHsExpr RdrName))
mkPatSynMatchGroup (L _ patsyn_name) (L _ decls) =
462
463
464
465
466
467
468
    do { matches <- mapM fromDecl (fromOL decls)
       ; return $ mkMatchGroup FromSource matches }
  where
    fromDecl (L loc decl@(ValD (PatBind pat@(L _ (ConPatIn (L _ name) details)) rhs _ _ _))) =
        do { unless (name == patsyn_name) $
               wrongNameBindingErr loc decl
           ; match <- case details of
469
               PrefixCon pats -> return $ Match NonFunBindMatch pats Nothing rhs
Alan Zimmerman's avatar
Alan Zimmerman committed
470
               InfixCon pat1 pat2 ->
471
                         return $ Match NonFunBindMatch [pat1, pat2] Nothing rhs
472
473
474
475
476
477
478
479
480
481
482
483
484
485
               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

486
mkSimpleConDecl :: Located RdrName -> [LHsTyVarBndr RdrName]
487
488
                -> LHsContext RdrName -> HsConDeclDetails RdrName
                -> ConDecl RdrName
489
490

mkSimpleConDecl name qvars cxt details
Jan Stolarek's avatar
Jan Stolarek committed
491
  = ConDecl { con_names    = [name]
492
            , con_explicit = Explicit
493
            , con_qvars    = mkHsQTvs qvars
494
495
496
            , con_cxt      = cxt
            , con_details  = details
            , con_res      = ResTyH98
497
            , con_doc      = Nothing }
498

499
500
mkGadtDecl :: [Located RdrName]
           -> LHsType RdrName     -- Always a HsForAllTy
Jan Stolarek's avatar
Jan Stolarek committed
501
502
503
504
505
           -> ([AddAnn], ConDecl RdrName)
mkGadtDecl names (L l ty) =
  let (anns, ty') = flattenHsForAllTyKeepAnns ty
      gadt        = mkGadtDecl' names (L l ty')
  in (anns, gadt)
506
507

mkGadtDecl' :: [Located RdrName]
Jan Stolarek's avatar
Jan Stolarek committed
508
509
            ->  LHsType RdrName     -- Always a HsForAllTy
            -> (ConDecl RdrName)
510
-- We allow C,D :: ty
511
-- and expand it as if it had been
512
513
--    C :: ty; D :: ty
-- (Just like type signatures in general.)
thomasw's avatar
thomasw committed
514
mkGadtDecl' names (L ls (HsForAllTy imp _ qvars cxt tau))
Jan Stolarek's avatar
Jan Stolarek committed
515
  = mk_gadt_con names
516
  where
517
    (details, res_ty)           -- See Note [Sorting out the result type]
518
      = case tau of
Alan Zimmerman's avatar
Alan Zimmerman committed
519
520
          L _ (HsFunTy (L l (HsRecTy flds)) res_ty)
                                            -> (RecCon (L l flds), res_ty)
Jan Stolarek's avatar
Jan Stolarek committed
521
          _other                            -> (PrefixCon [], tau)
522

523
    mk_gadt_con names
Jan Stolarek's avatar
Jan Stolarek committed
524
       = ConDecl { con_names    = names
525
526
527
528
                 , con_explicit = imp
                 , con_qvars    = qvars
                 , con_cxt      = cxt
                 , con_details  = details
Alan Zimmerman's avatar
Alan Zimmerman committed
529
                 , con_res      = ResTyGADT ls res_ty
530
                 , con_doc      = Nothing }
531
mkGadtDecl' _ other_ty = pprPanic "mkGadtDecl" (ppr other_ty)
532
533
534

tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
tyConToDataCon loc tc
535
  | isTcOcc (rdrNameOcc tc)
536
  = return (L loc (setRdrNameSpace tc srcDataName))
537
  | otherwise
538
539
540
541
  = parseErrorSDoc loc (msg $$ extra)
  where
    msg = text "Not a data constructor:" <+> quotes (ppr tc)
    extra | tc == forall_tv_RDR
542
          = text "Perhaps you intended to use ExistentialQuantification"
543
          | otherwise = empty
rodlogic's avatar
rodlogic committed
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
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
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!
-}

rodlogic's avatar
rodlogic committed
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
-- | Note [Sorting out the result type]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- In a GADT declaration which is not a record, we put the whole constr
-- type into the ResTyGADT for now; the renamer will unravel it once it
-- has sorted out operator fixities. Consider for example
--      C :: a :*: b -> a :*: b -> a :+: b
-- Initially this type will parse as
--       a :*: (b -> (a :*: (b -> (a :+: b))))

-- so it's hard to split up the arguments until we've done the precedence
-- resolution (in the renamer) On the other hand, for a record
--         { x,y :: Int } -> a :*: b
-- there is no doubt.  AND we need to sort records out so that
-- we can bring x,y into scope.  So:
--    * For PrefixCon we keep all the args in the ResTyGADT
--    * For RecCon we do not

647
648
checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName] -> P (LHsTyVarBndrs RdrName)
-- Same as checkTyVars, but in the P monad
rodlogic's avatar
rodlogic committed
649
650
checkTyVarsP pp_what equals_or_where tc tparms
  = eitherToP $ checkTyVars pp_what equals_or_where tc tparms
651
652
653
654
655

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
rodlogic's avatar
rodlogic committed
656
checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName]
657
            -> Either (SrcSpan, SDoc) (LHsTyVarBndrs RdrName)
658
-- Check whether the given list of type parameters are all type variables
659
660
661
-- (possibly with a kind signature)
-- We use the Either monad because it's also called (via mkATDefault) from
-- Convert.hs
rodlogic's avatar
rodlogic committed
662
checkTyVars pp_what equals_or_where tc tparms
663
664
  = do { tvs <- mapM chk tparms
       ; return (mkHsQTvs tvs) }
665
  where
rodlogic's avatar
rodlogic committed
666

667
        -- Check that the name space is correct!
Alan Zimmerman's avatar
Alan Zimmerman committed
668
669
    chk (L l (HsKindSig (L lv (HsTyVar tv)) k))
        | isRdrTyVar tv    = return (L l (KindedTyVar (L lv tv) k))
670
    chk (L l (HsTyVar tv))
671
        | isRdrTyVar tv    = return (L l (UserTyVar tv))
672
    chk t@(L loc _)
rodlogic's avatar
rodlogic committed
673
        = Left (loc,
674
675
676
                vcat [ ptext (sLit "Unexpected type") <+> quotes (ppr t)
                     , ptext (sLit "In the") <+> pp_what <+> ptext (sLit "declaration for") <+> quotes (ppr tc)
                     , vcat[ (ptext (sLit "A") <+> pp_what <+> ptext (sLit "declaration should have form"))
rodlogic's avatar
rodlogic committed
677
                     , nest 2 (pp_what <+> ppr tc
678
679
                                       <+> hsep (map text (takeList tparms allNameStrings))
                                       <+> equals_or_where) ] ])
680

681
whereDots, equalsDots :: SDoc
682
-- Second argument to checkTyVars
683
684
whereDots  = ptext (sLit "where ...")
equalsDots = ptext (sLit "= ...")
685

686
687
checkDatatypeContext :: Maybe (LHsContext RdrName) -> P ()
checkDatatypeContext Nothing = return ()
688
checkDatatypeContext (Just (L loc c))
689
690
    = do allowed <- extension datatypeContextsEnabled
         unless allowed $
691
             parseErrorSDoc loc
692
                 (text "Illegal datatype context (use DatatypeContexts):" <+>
693
                  pprHsContext c)
694

695
696
697
698
699
700
checkRecordSyntax :: Outputable a => Located a -> P (Located a)
checkRecordSyntax lr@(L loc r)
    = do allowed <- extension traditionalRecordSyntaxEnabled
         if allowed
             then return lr
             else parseErrorSDoc loc
701
                      (text "Illegal record syntax (use TraditionalRecordSyntax):" <+>
702
703
                       ppr r)

704
705
706
checkTyClHdr :: Bool               -- True  <=> class header
                                   -- False <=> type header
             -> LHsType RdrName
707
             -> P (Located RdrName,          -- the head symbol (type or class name)
Alan Zimmerman's avatar
Alan Zimmerman committed
708
709
                   [LHsType RdrName],        -- parameters of head symbol
                   [AddAnn]) -- API Annotation for HsParTy when stripping parens
710
-- Well-formedness check and decomposition of type and class heads.
711
-- Decomposes   T ty1 .. tyn   into    (T, [ty1, ..., tyn])
712
--              Int :*: Bool   into    (:*:, [Int, Bool])
713
-- returning the pieces
714
checkTyClHdr is_cls ty
Alan Zimmerman's avatar
Alan Zimmerman committed
715
  = goL ty [] []
716
  where
Alan Zimmerman's avatar
Alan Zimmerman committed
717
718
719
    goL (L l ty) acc ann = go l ty acc ann

    go l (HsTyVar tc) acc ann
720
      | isRdrTc tc               = return (L l tc, acc, ann)
Alan Zimmerman's avatar
Alan Zimmerman committed
721
    go _ (HsOpTy t1 (_, ltc@(L _ tc)) t2) acc ann
722
      | isRdrTc tc               = return (ltc, t1:t2:acc, ann)
Alan Zimmerman's avatar
Alan Zimmerman committed
723
724
    go l (HsParTy ty)    acc ann = goL ty acc (ann ++ mkParensApiAnn l)
    go _ (HsAppTy t1 t2) acc ann = goL t1 (t2:acc) ann
725
726
727
728
729
730
731
732
733
734
735

    go l (HsTupleTy HsBoxedOrConstraintTuple ts) [] ann
      = return (L l (nameRdrName tup_name), ts, ann)
      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?)
    go l _  _  _
      = parseErrorSDoc l (text "Malformed head of type or class declaration:"
                          <+> ppr ty)
736

737
checkContext :: LHsType RdrName -> P ([AddAnn],LHsContext RdrName)
batterseapower's avatar
batterseapower committed
738
checkContext (L l orig_t)
739
  = check [] (L l orig_t)
740
 where
741
742
  check anns (L lp (HsTupleTy _ ts))   -- (Eq a, Ord b) shows up as a tuple type
    = return (anns ++ mkParensApiAnn lp,L l ts)                -- Ditto ()
743

744
745
746
747
  check anns (L lp1 (HsParTy ty))-- to be sure HsParTy doesn't get into the way
       = check anns' ty
         where anns' = if l == lp1 then anns
                                   else (anns ++ mkParensApiAnn lp1)
748

749
750
  check _anns _
    = return ([],L l [L l orig_t]) -- no need for anns, returning original
751

752
-- -------------------------------------------------------------------------
753
754
755
756
757
-- Checking Patterns.

-- We parse patterns as expressions and check for valid patterns below,
-- converting the expression into a pattern at the same time.

758
759
checkPattern :: SDoc -> LHsExpr RdrName -> P (LPat RdrName)
checkPattern msg e = checkLPat msg e
760

761
762
checkPatterns :: SDoc -> [LHsExpr RdrName] -> P [LPat RdrName]
checkPatterns msg es = mapM (checkPattern msg) es
763

764
765
checkLPat :: SDoc -> LHsExpr RdrName -> P (LPat RdrName)
checkLPat msg e@(L l _) = checkPat msg l e []
766

767
768
769
checkPat :: SDoc -> SrcSpan -> LHsExpr RdrName -> [LPat RdrName]
         -> P (LPat RdrName)
checkPat _ loc (L l (HsVar c)) args
770
  | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
771
checkPat msg loc e args     -- OK to let this happen even if bang-patterns
772
773
                        -- are not enabled, because there is no valid
                        -- non-bang-pattern parse of (C ! e)
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
774
  | Just (e', args') <- splitBang e
775
776
777
778
779
780
781
  = do  { args'' <- checkPatterns msg args'
        ; checkPat msg loc e' (args'' ++ args) }
checkPat msg loc (L _ (HsApp f e)) args
  = do p <- checkLPat msg e
       checkPat msg loc f (p : args)
checkPat msg loc (L _ e) []
  = do p <- checkAPat msg loc e
782
       return (L loc p)
783
784
checkPat msg loc e _
  = patFail msg loc (unLoc e)
785

786
787
checkAPat :: SDoc -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
checkAPat msg loc e0 = do
788
789
790
 pState <- getPState
 let dynflags = dflags pState
 case e0 of
791
792
793
   EWildPat -> return (WildPat placeHolderType)
   HsVar x  -> return (VarPat x)
   HsLit l  -> return (LitPat l)
794
795
796

   -- Overloaded numeric patterns (e.g. f 0 x = x)
   -- Negation is recorded separately, so that the literal is zero or +ve
797
   -- NB. Negative *primitive* literals are already handled by the lexer
Alan Zimmerman's avatar
Alan Zimmerman committed
798
799
800
   HsOverLit pos_lit          -> return (mkNPat (L loc pos_lit) Nothing)
   NegApp (L l (HsOverLit pos_lit)) _
                        -> return (mkNPat (L l pos_lit) (Just noSyntaxExpr))
801

Alan Zimmerman's avatar
Alan Zimmerman committed
802
   SectionR (L lb (HsVar bang)) e        -- (! x)
803
804
        | bang == bang_RDR
        -> do { bang_on <- extension bangPatEnabled
Alan Zimmerman's avatar
Alan Zimmerman committed
805
806
807
              ; if bang_on then do { e' <- checkLPat msg e
                                   ; addAnnotation loc AnnBang lb
                                   ; return  (BangPat e') }
808
                else parseErrorSDoc loc (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e0) }
809

810
811
   ELazyPat e         -> checkLPat msg e >>= (return . LazyPat)
   EAsPat n e         -> checkLPat msg e >>= (return . AsPat n)
812
   -- view pattern is well-formed if the pattern is
thomasw's avatar
thomasw committed
813
   EViewPat expr patE  -> checkLPat msg patE >>=
814
                            (return . (\p -> ViewPat expr p placeHolderType))
thomasw's avatar
thomasw committed
815
816
817
818
819
820
821
822
   ExprWithTySig e t _ -> do e <- checkLPat msg e
                             -- Pattern signatures are parsed as sigtypes,
                             -- but they aren't explicit forall points.  Hence
                             -- we have to remove the implicit forall here.
                             let t' = case t of
                                        L _ (HsForAllTy Implicit _ _
                                             (L _ []) ty) -> ty
                                        other -> other
Alan Zimmerman's avatar
Alan Zimmerman committed
823
                             return (SigPatIn e (mkHsWithBndrs t'))
824

825
   -- n+k patterns
826
   OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
Alan Zimmerman's avatar
Alan Zimmerman committed
827
         (L lloc (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
828
                      | xopt Opt_NPlusKPatterns dynflags && (plus == plus_RDR)
Alan Zimmerman's avatar
Alan Zimmerman committed
829
                      -> return (mkNPlusKPat (L nloc n) (L lloc lit))
830

831
832
   OpApp l op _fix r  -> do l <- checkLPat msg l
                            r <- checkLPat msg r
833
834
835
                            case op of
                               L cl (HsVar c) | isDataOcc (rdrNameOcc c)
                                      -> return (ConPatIn (L cl c) (InfixCon l r))
836
                               _ -> patFail msg loc e0
837

838
   HsPar e            -> checkLPat msg e >>= (return . ParPat)
839
840
   ExplicitList _ _ es  -> do ps <- mapM (checkLPat msg) es
                              return (ListPat ps placeHolderType Nothing)
841
   ExplicitPArr _ es  -> do ps <- mapM (checkLPat msg) es
842
                            return (PArrPat ps placeHolderType)
843
844

   ExplicitTuple es b
845
846
     | all tupArgPresent es  -> do ps <- mapM (checkLPat msg)
                                              [e | L _ (Present e) <- es]
847
                                   return (TuplePat ps b [])
848
     | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0)
849

Matthew Pickering's avatar
Matthew Pickering committed
850
   RecordCon c _ (HsRecFields fs dd) _
851
852
                        -> do fs <- mapM (checkPatField msg) fs
                              return (ConPatIn c (RecCon (HsRecFields fs dd)))
853
854
855
   HsSpliceE s | not (isTypedSplice s)
               -> return (SplicePat s)
   _           -> patFail msg loc e0
856

857
placeHolderPunRhs :: LHsExpr RdrName
858
859
-- The RHS of a punned record field will be filled in by the renamer
-- It's better not to make it an error, in case we want to print it when debugging
860
placeHolderPunRhs = noLoc (HsVar pun_RDR)
861
862

plus_RDR, bang_RDR, pun_RDR :: RdrName
863
864
plus_RDR = mkUnqual varName (fsLit "+") -- Hack
bang_RDR = mkUnqual varName (fsLit "!") -- Hack
865
pun_RDR  = mkUnqual varName (fsLit "pun-right-hand-side")
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
866

867
868
869
870
checkPatField :: SDoc -> LHsRecField RdrName (LHsExpr RdrName)
              -> P (LHsRecField RdrName (LPat RdrName))
checkPatField msg (L l fld) = do p <- checkLPat msg (hsRecFieldArg fld)
                                 return (L l (fld { hsRecFieldArg = p }))
871

872
873
874
875
patFail :: SDoc -> SrcSpan -> HsExpr RdrName -> P a
patFail msg loc e = parseErrorSDoc loc err
    where err = text "Parse error in pattern:" <+> ppr e
             $$ msg
876
877
878
879
880


---------------------------------------------------------------------------
-- Check Equation Syntax

881
882
checkValDef :: SDoc
            -> LHsExpr RdrName
883
            -> Maybe (LHsType RdrName)
Alan Zimmerman's avatar
Alan Zimmerman committed
884
            -> Located (a,GRHSs RdrName (LHsExpr RdrName))
885
            -> P ([AddAnn],HsBind RdrName)
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
886

887
checkValDef msg lhs (Just sig) grhss
888
        -- x :: ty = rhs  parses as a *pattern* binding
thomasw's avatar
thomasw committed
889
890
  = checkPatBind msg (L (combineLocs lhs sig)
                        (ExprWithTySig lhs sig PlaceHolder)) grhss
891

Alan Zimmerman's avatar
Alan Zimmerman committed
892
checkValDef msg lhs opt_sig g@(L l (_,grhss))
893
894
  = do  { mb_fun <- isFunLhs lhs
        ; case mb_fun of
895
896
            Just (fun, is_infix, pats, ann) ->
              checkFunBind msg ann (getLoc lhs)
897
898
                                           fun is_infix pats opt_sig (L l grhss)
            Nothing -> checkPatBind msg lhs g }
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
899

900
checkFunBind :: SDoc
901
             -> [AddAnn]
902
             -> SrcSpan