Implement unboxed sum primitive type
[ghc.git] / compiler / parser / RdrHsSyn.hs
1 --
2 -- (c) The University of Glasgow 2002-2006
3 --
4
5 -- Functions over HsSyn specialised to RdrName.
6
7 {-# LANGUAGE CPP #-}
8 {-# LANGUAGE FlexibleContexts #-}
9
10 module RdrHsSyn (
11 mkHsOpApp,
12 mkHsIntegral, mkHsFractional, mkHsIsString,
13 mkHsDo, mkSpliceDecl,
14 mkRoleAnnotDecl,
15 mkClassDecl,
16 mkTyData, mkDataFamInst,
17 mkTySynonym, mkTyFamInstEqn,
18 mkTyFamInst,
19 mkFamDecl, mkLHsSigType,
20 splitCon, mkInlinePragma,
21 mkPatSynMatchGroup,
22 mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
23 mkTyClD, mkInstD,
24 mkRdrRecordCon, mkRdrRecordUpd,
25 setRdrNameSpace,
26
27 cvBindGroup,
28 cvBindsAndSigs,
29 cvTopDecls,
30 placeHolderPunRhs,
31
32 -- Stuff to do with Foreign declarations
33 mkImport,
34 parseCImport,
35 mkExport,
36 mkExtName, -- RdrName -> CLabelString
37 mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName
38 mkConDeclH98,
39 mkATDefault,
40
41 -- Bunch of functions in the parser monad for
42 -- checking and constructing values
43 checkPrecP, -- Int -> P Int
44 checkContext, -- HsType -> P HsContext
45 checkPattern, -- HsExp -> P HsPat
46 bang_RDR,
47 checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat]
48 checkMonadComp, -- P (HsStmtContext RdrName)
49 checkCommand, -- LHsExpr RdrName -> P (LHsCmd RdrName)
50 checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
51 checkValSigLhs,
52 checkDoAndIfThenElse,
53 checkRecordSyntax,
54 parseErrorSDoc,
55 splitTilde, splitTildeApps,
56
57 -- Help with processing exports
58 ImpExpSubSpec(..),
59 mkModuleImpExp,
60 mkTypeImpExp,
61 mkImpExpSubSpec,
62 checkImportSpec,
63
64 SumOrTuple (..), mkSumOrTuple
65
66 ) where
67
68 import HsSyn -- Lots of it
69 import Class ( FunDep )
70 import TyCon ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe )
71 import DataCon ( DataCon, dataConTyCon )
72 import ConLike ( ConLike(..) )
73 import CoAxiom ( Role, fsFromRole )
74 import RdrName
75 import Name
76 import BasicTypes
77 import TcEvidence ( idHsWrapper )
78 import Lexer
79 import Lexeme ( isLexCon )
80 import Type ( TyThing(..) )
81 import TysWiredIn ( cTupleTyConName, tupleTyCon, tupleDataCon,
82 nilDataConName, nilDataConKey,
83 listTyConName, listTyConKey,
84 starKindTyConName, unicodeStarKindTyConName )
85 import ForeignCall
86 import PrelNames ( forall_tv_RDR, eqTyCon_RDR, allNameStrings )
87 import SrcLoc
88 import Unique ( hasKey )
89 import OrdList ( OrdList, fromOL )
90 import Bag ( emptyBag, consBag )
91 import Outputable
92 import FastString
93 import Maybes
94 import Util
95 import ApiAnnotation
96 import Data.List
97 import qualified GHC.LanguageExtensions as LangExt
98 import MonadUtils
99
100 import Control.Monad
101 import Text.ParserCombinators.ReadP as ReadP
102 import Data.Char
103
104 import Data.Data ( dataTypeOf, fromConstr, dataTypeConstrs )
105
106 #include "HsVersions.h"
107
108
109 {- **********************************************************************
110
111 Construction functions for Rdr stuff
112
113 ********************************************************************* -}
114
115 -- | mkClassDecl builds a RdrClassDecl, filling in the names for tycon and
116 -- datacon by deriving them from the name of the class. We fill in the names
117 -- for the tycon and datacon corresponding to the class, by deriving them
118 -- from the name of the class itself. This saves recording the names in the
119 -- interface file (which would be equally good).
120
121 -- Similarly for mkConDecl, mkClassOpSig and default-method names.
122
123 -- *** See Note [The Naming story] in HsDecls ****
124
125 mkTyClD :: LTyClDecl n -> LHsDecl n
126 mkTyClD (L loc d) = L loc (TyClD d)
127
128 mkInstD :: LInstDecl n -> LHsDecl n
129 mkInstD (L loc d) = L loc (InstD d)
130
131 mkClassDecl :: SrcSpan
132 -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
133 -> Located (a,[Located (FunDep (Located RdrName))])
134 -> OrdList (LHsDecl RdrName)
135 -> P (LTyClDecl RdrName)
136
137 mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
138 = do { (binds, sigs, ats, at_insts, _, docs) <- cvBindsAndSigs where_cls
139 ; let cxt = fromMaybe (noLoc []) mcxt
140 ; (cls, tparams,ann) <- checkTyClHdr True tycl_hdr
141 ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
142 ; tyvars <- checkTyVarsP (text "class") whereDots cls tparams
143 ; at_defs <- mapM (eitherToP . mkATDefault) at_insts
144 ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars
145 , tcdFDs = snd (unLoc fds)
146 , tcdSigs = mkClassOpSigs sigs
147 , tcdMeths = binds
148 , tcdATs = ats, tcdATDefs = at_defs, tcdDocs = docs
149 , tcdFVs = placeHolderNames })) }
150
151 mkATDefault :: LTyFamInstDecl RdrName
152 -> Either (SrcSpan, SDoc) (LTyFamDefltEqn RdrName)
153 -- Take a type-family instance declaration and turn it into
154 -- a type-family default equation for a class declaration
155 -- We parse things as the former and use this function to convert to the latter
156 --
157 -- We use the Either monad because this also called
158 -- from Convert.hs
159 mkATDefault (L loc (TyFamInstDecl { tfid_eqn = L _ e }))
160 | TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_rhs = rhs } <- e
161 = do { tvs <- checkTyVars (text "default") equalsDots tc (hsib_body pats)
162 ; return (L loc (TyFamEqn { tfe_tycon = tc
163 , tfe_pats = tvs
164 , tfe_rhs = rhs })) }
165
166 mkTyData :: SrcSpan
167 -> NewOrData
168 -> Maybe (Located CType)
169 -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
170 -> Maybe (LHsKind RdrName)
171 -> [LConDecl RdrName]
172 -> HsDeriving RdrName
173 -> P (LTyClDecl RdrName)
174 mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
175 = do { (tc, tparams,ann) <- checkTyClHdr False tycl_hdr
176 ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
177 ; tyvars <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams
178 ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
179 ; return (L loc (DataDecl { tcdLName = tc, tcdTyVars = tyvars,
180 tcdDataDefn = defn,
181 tcdDataCusk = PlaceHolder,
182 tcdFVs = placeHolderNames })) }
183
184 mkDataDefn :: NewOrData
185 -> Maybe (Located CType)
186 -> Maybe (LHsContext RdrName)
187 -> Maybe (LHsKind RdrName)
188 -> [LConDecl RdrName]
189 -> HsDeriving RdrName
190 -> P (HsDataDefn RdrName)
191 mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
192 = do { checkDatatypeContext mcxt
193 ; let cxt = fromMaybe (noLoc []) mcxt
194 ; return (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
195 , dd_ctxt = cxt
196 , dd_cons = data_cons
197 , dd_kindSig = ksig
198 , dd_derivs = maybe_deriv }) }
199
200
201 mkTySynonym :: SrcSpan
202 -> LHsType RdrName -- LHS
203 -> LHsType RdrName -- RHS
204 -> P (LTyClDecl RdrName)
205 mkTySynonym loc lhs rhs
206 = do { (tc, tparams,ann) <- checkTyClHdr False lhs
207 ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
208 ; tyvars <- checkTyVarsP (text "type") equalsDots tc tparams
209 ; return (L loc (SynDecl { tcdLName = tc, tcdTyVars = tyvars
210 , tcdRhs = rhs, tcdFVs = placeHolderNames })) }
211
212 mkTyFamInstEqn :: LHsType RdrName
213 -> LHsType RdrName
214 -> P (TyFamInstEqn RdrName,[AddAnn])
215 mkTyFamInstEqn lhs rhs
216 = do { (tc, tparams, ann) <- checkTyClHdr False lhs
217 ; return (TyFamEqn { tfe_tycon = tc
218 , tfe_pats = mkHsImplicitBndrs tparams
219 , tfe_rhs = rhs },
220 ann) }
221
222 mkDataFamInst :: SrcSpan
223 -> NewOrData
224 -> Maybe (Located CType)
225 -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
226 -> Maybe (LHsKind RdrName)
227 -> [LConDecl RdrName]
228 -> HsDeriving RdrName
229 -> P (LInstDecl RdrName)
230 mkDataFamInst loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
231 = do { (tc, tparams,ann) <- checkTyClHdr False tycl_hdr
232 ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
233 ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
234 ; return (L loc (DataFamInstD (
235 DataFamInstDecl { dfid_tycon = tc
236 , dfid_pats = mkHsImplicitBndrs tparams
237 , dfid_defn = defn, dfid_fvs = placeHolderNames }))) }
238
239 mkTyFamInst :: SrcSpan
240 -> LTyFamInstEqn RdrName
241 -> P (LInstDecl RdrName)
242 mkTyFamInst loc eqn
243 = return (L loc (TyFamInstD (TyFamInstDecl { tfid_eqn = eqn
244 , tfid_fvs = placeHolderNames })))
245
246 mkFamDecl :: SrcSpan
247 -> FamilyInfo RdrName
248 -> LHsType RdrName -- LHS
249 -> Located (FamilyResultSig RdrName) -- Optional result signature
250 -> Maybe (LInjectivityAnn RdrName) -- Injectivity annotation
251 -> P (LTyClDecl RdrName)
252 mkFamDecl loc info lhs ksig injAnn
253 = do { (tc, tparams, ann) <- checkTyClHdr False lhs
254 ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
255 ; tyvars <- checkTyVarsP (ppr info) equals_or_where tc tparams
256 ; return (L loc (FamDecl (FamilyDecl{ fdInfo = info, fdLName = tc
257 , fdTyVars = tyvars
258 , fdResultSig = ksig
259 , fdInjectivityAnn = injAnn }))) }
260 where
261 equals_or_where = case info of
262 DataFamily -> empty
263 OpenTypeFamily -> empty
264 ClosedTypeFamily {} -> whereDots
265
266 mkSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName
267 -- If the user wrote
268 -- [pads| ... ] then return a QuasiQuoteD
269 -- $(e) then return a SpliceD
270 -- but if she wrote, say,
271 -- f x then behave as if she'd written $(f x)
272 -- ie a SpliceD
273 --
274 -- Typed splices are not allowed at the top level, thus we do not represent them
275 -- as spliced declaration. See #10945
276 mkSpliceDecl lexpr@(L loc expr)
277 | HsSpliceE splice@(HsUntypedSplice {}) <- expr
278 = SpliceD (SpliceDecl (L loc splice) ExplicitSplice)
279
280 | HsSpliceE splice@(HsQuasiQuote {}) <- expr
281 = SpliceD (SpliceDecl (L loc splice) ExplicitSplice)
282
283 | otherwise
284 = SpliceD (SpliceDecl (L loc (mkUntypedSplice lexpr)) ImplicitSplice)
285
286 mkRoleAnnotDecl :: SrcSpan
287 -> Located RdrName -- type being annotated
288 -> [Located (Maybe FastString)] -- roles
289 -> P (LRoleAnnotDecl RdrName)
290 mkRoleAnnotDecl loc tycon roles
291 = do { roles' <- mapM parse_role roles
292 ; return $ L loc $ RoleAnnotDecl tycon roles' }
293 where
294 role_data_type = dataTypeOf (undefined :: Role)
295 all_roles = map fromConstr $ dataTypeConstrs role_data_type
296 possible_roles = [(fsFromRole role, role) | role <- all_roles]
297
298 parse_role (L loc_role Nothing) = return $ L loc_role Nothing
299 parse_role (L loc_role (Just role))
300 = case lookup role possible_roles of
301 Just found_role -> return $ L loc_role $ Just found_role
302 Nothing ->
303 let nearby = fuzzyLookup (unpackFS role) (mapFst unpackFS possible_roles) in
304 parseErrorSDoc loc_role
305 (text "Illegal role name" <+> quotes (ppr role) $$
306 suggestions nearby)
307
308 suggestions [] = empty
309 suggestions [r] = text "Perhaps you meant" <+> quotes (ppr r)
310 -- will this last case ever happen??
311 suggestions list = hang (text "Perhaps you meant one of these:")
312 2 (pprWithCommas (quotes . ppr) list)
313
314 {- **********************************************************************
315
316 #cvBinds-etc# Converting to @HsBinds@, etc.
317
318 ********************************************************************* -}
319
320 -- | Function definitions are restructured here. Each is assumed to be recursive
321 -- initially, and non recursive definitions are discovered by the dependency
322 -- analyser.
323
324
325 -- | Groups together bindings for a single function
326 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
327 cvTopDecls decls = go (fromOL decls)
328 where
329 go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
330 go [] = []
331 go (L l (ValD b) : ds) = L l' (ValD b') : go ds'
332 where (L l' b', ds') = getMonoBind (L l b) ds
333 go (d : ds) = d : go ds
334
335 -- Declaration list may only contain value bindings and signatures.
336 cvBindGroup :: OrdList (LHsDecl RdrName) -> P (HsValBinds RdrName)
337 cvBindGroup binding
338 = do { (mbs, sigs, fam_ds, tfam_insts, dfam_insts, _) <- cvBindsAndSigs binding
339 ; ASSERT( null fam_ds && null tfam_insts && null dfam_insts)
340 return $ ValBindsIn mbs sigs }
341
342 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
343 -> P (LHsBinds RdrName, [LSig RdrName], [LFamilyDecl RdrName]
344 , [LTyFamInstDecl RdrName], [LDataFamInstDecl RdrName], [LDocDecl])
345 -- Input decls contain just value bindings and signatures
346 -- and in case of class or instance declarations also
347 -- associated type declarations. They might also contain Haddock comments.
348 cvBindsAndSigs fb = go (fromOL fb)
349 where
350 go [] = return (emptyBag, [], [], [], [], [])
351 go (L l (ValD b) : ds)
352 = do { (bs, ss, ts, tfis, dfis, docs) <- go ds'
353 ; return (b' `consBag` bs, ss, ts, tfis, dfis, docs) }
354 where
355 (b', ds') = getMonoBind (L l b) ds
356 go (L l decl : ds)
357 = do { (bs, ss, ts, tfis, dfis, docs) <- go ds
358 ; case decl of
359 SigD s
360 -> return (bs, L l s : ss, ts, tfis, dfis, docs)
361 TyClD (FamDecl t)
362 -> return (bs, ss, L l t : ts, tfis, dfis, docs)
363 InstD (TyFamInstD { tfid_inst = tfi })
364 -> return (bs, ss, ts, L l tfi : tfis, dfis, docs)
365 InstD (DataFamInstD { dfid_inst = dfi })
366 -> return (bs, ss, ts, tfis, L l dfi : dfis, docs)
367 DocD d
368 -> return (bs, ss, ts, tfis, dfis, L l d : docs)
369 SpliceD d
370 -> parseErrorSDoc l $
371 hang (text "Declaration splices are allowed only" <+>
372 text "at the top level:")
373 2 (ppr d)
374 _ -> pprPanic "cvBindsAndSigs" (ppr decl) }
375
376 -----------------------------------------------------------------------------
377 -- Group function bindings into equation groups
378
379 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
380 -> (LHsBind RdrName, [LHsDecl RdrName])
381 -- Suppose (b',ds') = getMonoBind b ds
382 -- ds is a list of parsed bindings
383 -- b is a MonoBinds that has just been read off the front
384
385 -- Then b' is the result of grouping more equations from ds that
386 -- belong with b into a single MonoBinds, and ds' is the depleted
387 -- list of parsed bindings.
388 --
389 -- All Haddock comments between equations inside the group are
390 -- discarded.
391 --
392 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
393
394 getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1),
395 fun_matches
396 = MG { mg_alts = L _ mtchs1 } })) binds
397 | has_args mtchs1
398 = go mtchs1 loc1 binds []
399 where
400 go mtchs loc
401 (L loc2 (ValD (FunBind { fun_id = L _ f2,
402 fun_matches
403 = MG { mg_alts = L _ mtchs2 } })) : binds) _
404 | f1 == f2 = go (mtchs2 ++ mtchs)
405 (combineSrcSpans loc loc2) binds []
406 go mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls
407 = let doc_decls' = doc_decl : doc_decls
408 in go mtchs (combineSrcSpans loc loc2) binds doc_decls'
409 go mtchs loc binds doc_decls
410 = ( L loc (makeFunBind fun_id1 (reverse mtchs))
411 , (reverse doc_decls) ++ binds)
412 -- Reverse the final matches, to get it back in the right order
413 -- Do the same thing with the trailing doc comments
414
415 getMonoBind bind binds = (bind, binds)
416
417 has_args :: [LMatch RdrName (LHsExpr RdrName)] -> Bool
418 has_args [] = panic "RdrHsSyn:has_args"
419 has_args ((L _ (Match _ args _ _)) : _) = not (null args)
420 -- Don't group together FunBinds if they have
421 -- no arguments. This is necessary now that variable bindings
422 -- with no arguments are now treated as FunBinds rather
423 -- than pattern bindings (tests/rename/should_fail/rnfail002).
424
425 {- **********************************************************************
426
427 #PrefixToHS-utils# Utilities for conversion
428
429 ********************************************************************* -}
430
431 {- Note [Parsing data constructors is hard]
432 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
433 We parse the RHS of the constructor declaration
434 data T = C t1 t2
435 as a btype_no_ops (treating C as a type constructor) and then convert C to be
436 a data constructor. Reason: it might continue like this:
437 data T = C t1 t2 :% D Int
438 in which case C really /would/ be a type constructor. We can't resolve this
439 ambiguity till we come across the constructor oprerator :% (or not, more usually)
440
441 So the plan is:
442
443 * Parse the data constructor declration as a type (actually btype_no_ops)
444
445 * Use 'splitCon' to rejig it into the data constructor and the args
446
447 * In doing so, we use 'tyConToDataCon' to convert the RdrName for
448 the data con, which has been parsed as a tycon, back to a datacon.
449 This is more than just adjusting the name space; for operators we
450 need to check that it begins with a colon. E.g.
451 data T = (+++)
452 will parse ok (since tycons can be operators), but we should reject
453 it (Trac #12051).
454 -}
455
456 splitCon :: LHsType RdrName
457 -> P (Located RdrName, HsConDeclDetails RdrName)
458 -- See Note [Parsing data constructors is hard]
459 -- This gets given a "type" that should look like
460 -- C Int Bool
461 -- or C { x::Int, y::Bool }
462 -- and returns the pieces
463 splitCon ty
464 = split ty []
465 where
466 -- This is used somewhere where HsAppsTy is not used
467 split (L _ (HsAppTy t u)) ts = split t (u : ts)
468 split (L l (HsTyVar (L _ tc))) ts = do data_con <- tyConToDataCon l tc
469 return (data_con, mk_rest ts)
470 split (L l (HsTupleTy HsBoxedOrConstraintTuple ts)) []
471 = return (L l (getRdrName (tupleDataCon Boxed (length ts))), PrefixCon ts)
472 split (L l _) _ = parseErrorSDoc l (text "Cannot parse data constructor in a data/newtype declaration:" <+> ppr ty)
473
474 mk_rest [L l (HsRecTy flds)] = RecCon (L l flds)
475 mk_rest ts = PrefixCon ts
476
477 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
478 -- See Note [Parsing data constructors is hard]
479 -- Data constructor RHSs are parsed as types
480 tyConToDataCon loc tc
481 | isTcOcc occ
482 , isLexCon (occNameFS occ)
483 = return (L loc (setRdrNameSpace tc srcDataName))
484
485 | otherwise
486 = parseErrorSDoc loc (msg $$ extra)
487 where
488 occ = rdrNameOcc tc
489
490 msg = text "Not a data constructor:" <+> quotes (ppr tc)
491 extra | tc == forall_tv_RDR
492 = text "Perhaps you intended to use ExistentialQuantification"
493 | otherwise = empty
494
495 mkPatSynMatchGroup :: Located RdrName
496 -> Located (OrdList (LHsDecl RdrName))
497 -> P (MatchGroup RdrName (LHsExpr RdrName))
498 mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) =
499 do { matches <- mapM fromDecl (fromOL decls)
500 ; when (null matches) (wrongNumberErr loc)
501 ; return $ mkMatchGroup FromSource matches }
502 where
503 fromDecl (L loc decl@(ValD (PatBind pat@(L _ (ConPatIn ln@(L _ name) details)) rhs _ _ _))) =
504 do { unless (name == patsyn_name) $
505 wrongNameBindingErr loc decl
506 ; match <- case details of
507 PrefixCon pats ->
508 return $ Match (FunRhs ln Prefix) pats Nothing rhs
509 InfixCon pat1 pat2 ->
510 return $ Match (FunRhs ln Infix) [pat1, pat2] Nothing rhs
511 RecCon{} -> recordPatSynErr loc pat
512 ; return $ L loc match }
513 fromDecl (L loc decl) = extraDeclErr loc decl
514
515 extraDeclErr loc decl =
516 parseErrorSDoc loc $
517 text "pattern synonym 'where' clause must contain a single binding:" $$
518 ppr decl
519
520 wrongNameBindingErr loc decl =
521 parseErrorSDoc loc $
522 text "pattern synonym 'where' clause must bind the pattern synonym's name" <+>
523 quotes (ppr patsyn_name) $$ ppr decl
524
525 wrongNumberErr loc =
526 parseErrorSDoc loc $
527 text "pattern synonym 'where' clause cannot be empty" $$
528 text "In the pattern synonym declaration for: " <+> ppr (patsyn_name)
529
530 recordPatSynErr :: SrcSpan -> LPat RdrName -> P a
531 recordPatSynErr loc pat =
532 parseErrorSDoc loc $
533 text "record syntax not supported for pattern synonym declarations:" $$
534 ppr pat
535
536 mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr RdrName]
537 -> LHsContext RdrName -> HsConDeclDetails RdrName
538 -> ConDecl RdrName
539
540 mkConDeclH98 name mb_forall cxt details
541 = ConDeclH98 { con_name = name
542 , con_qvars = fmap mkHsQTvs mb_forall
543 , con_cxt = Just cxt
544 -- AZ:TODO: when can cxt be Nothing?
545 -- remembering that () is a valid context.
546 , con_details = details
547 , con_doc = Nothing }
548
549 mkGadtDecl :: [Located RdrName]
550 -> LHsSigType RdrName -- Always a HsForAllTy
551 -> ConDecl RdrName
552 mkGadtDecl names ty = ConDeclGADT { con_names = names
553 , con_type = ty
554 , con_doc = Nothing }
555
556 setRdrNameSpace :: RdrName -> NameSpace -> RdrName
557 -- ^ This rather gruesome function is used mainly by the parser.
558 -- When parsing:
559 --
560 -- > data T a = T | T1 Int
561 --
562 -- we parse the data constructors as /types/ because of parser ambiguities,
563 -- so then we need to change the /type constr/ to a /data constr/
564 --
565 -- The exact-name case /can/ occur when parsing:
566 --
567 -- > data [] a = [] | a : [a]
568 --
569 -- For the exact-name case we return an original name.
570 setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ)
571 setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ)
572 setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ)
573 setRdrNameSpace (Exact n) ns
574 | Just thing <- wiredInNameTyThing_maybe n
575 = setWiredInNameSpace thing ns
576 -- Preserve Exact Names for wired-in things,
577 -- notably tuples and lists
578
579 | isExternalName n
580 = Orig (nameModule n) occ
581
582 | otherwise -- This can happen when quoting and then
583 -- splicing a fixity declaration for a type
584 = Exact (mkSystemNameAt (nameUnique n) occ (nameSrcSpan n))
585 where
586 occ = setOccNameSpace ns (nameOccName n)
587
588 setWiredInNameSpace :: TyThing -> NameSpace -> RdrName
589 setWiredInNameSpace (ATyCon tc) ns
590 | isDataConNameSpace ns
591 = ty_con_data_con tc
592 | isTcClsNameSpace ns
593 = Exact (getName tc) -- No-op
594
595 setWiredInNameSpace (AConLike (RealDataCon dc)) ns
596 | isTcClsNameSpace ns
597 = data_con_ty_con dc
598 | isDataConNameSpace ns
599 = Exact (getName dc) -- No-op
600
601 setWiredInNameSpace thing ns
602 = pprPanic "setWiredinNameSpace" (pprNameSpace ns <+> ppr thing)
603
604 ty_con_data_con :: TyCon -> RdrName
605 ty_con_data_con tc
606 | isTupleTyCon tc
607 , Just dc <- tyConSingleDataCon_maybe tc
608 = Exact (getName dc)
609
610 | tc `hasKey` listTyConKey
611 = Exact nilDataConName
612
613 | otherwise -- See Note [setRdrNameSpace for wired-in names]
614 = Unqual (setOccNameSpace srcDataName (getOccName tc))
615
616 data_con_ty_con :: DataCon -> RdrName
617 data_con_ty_con dc
618 | let tc = dataConTyCon dc
619 , isTupleTyCon tc
620 = Exact (getName tc)
621
622 | dc `hasKey` nilDataConKey
623 = Exact listTyConName
624
625 | otherwise -- See Note [setRdrNameSpace for wired-in names]
626 = Unqual (setOccNameSpace tcClsName (getOccName dc))
627
628
629 {- Note [setRdrNameSpace for wired-in names]
630 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
631 In GHC.Types, which declares (:), we have
632 infixr 5 :
633 The ambiguity about which ":" is meant is resolved by parsing it as a
634 data constructor, but then using dataTcOccs to try the type constructor too;
635 and that in turn calls setRdrNameSpace to change the name-space of ":" to
636 tcClsName. There isn't a corresponding ":" type constructor, but it's painful
637 to make setRdrNameSpace partial, so we just make an Unqual name instead. It
638 really doesn't matter!
639 -}
640
641 -- | Note [Sorting out the result type]
642 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
643 -- In a GADT declaration which is not a record, we put the whole constr type
644 -- into the res_ty for a ConDeclGADT for now; the renamer will unravel it once
645 -- it has sorted out operator fixities. Consider for example
646 -- C :: a :*: b -> a :*: b -> a :+: b
647 -- Initially this type will parse as
648 -- a :*: (b -> (a :*: (b -> (a :+: b))))
649 --
650 -- so it's hard to split up the arguments until we've done the precedence
651 -- resolution (in the renamer). On the other hand, for a record
652 -- { x,y :: Int } -> a :*: b
653 -- there is no doubt. AND we need to sort records out so that
654 -- we can bring x,y into scope. So:
655 -- * For PrefixCon we keep all the args in the res_ty
656 -- * For RecCon we do not
657
658 checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName] -> P (LHsQTyVars RdrName)
659 -- Same as checkTyVars, but in the P monad
660 checkTyVarsP pp_what equals_or_where tc tparms
661 = eitherToP $ checkTyVars pp_what equals_or_where tc tparms
662
663 eitherToP :: Either (SrcSpan, SDoc) a -> P a
664 -- Adapts the Either monad to the P monad
665 eitherToP (Left (loc, doc)) = parseErrorSDoc loc doc
666 eitherToP (Right thing) = return thing
667
668 checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName]
669 -> Either (SrcSpan, SDoc) (LHsQTyVars RdrName)
670 -- Check whether the given list of type parameters are all type variables
671 -- (possibly with a kind signature)
672 -- We use the Either monad because it's also called (via mkATDefault) from
673 -- Convert.hs
674 checkTyVars pp_what equals_or_where tc tparms
675 = do { tvs <- mapM chk tparms
676 ; return (mkHsQTvs tvs) }
677 where
678
679 chk (L _ (HsParTy ty)) = chk ty
680 chk (L _ (HsAppsTy [L _ (HsAppPrefix ty)])) = chk ty
681
682 -- Check that the name space is correct!
683 chk (L l (HsKindSig
684 (L _ (HsAppsTy [L _ (HsAppPrefix (L lv (HsTyVar (L _ tv))))])) k))
685 | isRdrTyVar tv = return (L l (KindedTyVar (L lv tv) k))
686 chk (L l (HsTyVar (L ltv tv)))
687 | isRdrTyVar tv = return (L l (UserTyVar (L ltv tv)))
688 chk t@(L loc _)
689 = Left (loc,
690 vcat [ text "Unexpected type" <+> quotes (ppr t)
691 , text "In the" <+> pp_what <+> ptext (sLit "declaration for") <+> quotes (ppr tc)
692 , vcat[ (text "A" <+> pp_what <+> ptext (sLit "declaration should have form"))
693 , nest 2 (pp_what <+> ppr tc
694 <+> hsep (map text (takeList tparms allNameStrings))
695 <+> equals_or_where) ] ])
696
697 whereDots, equalsDots :: SDoc
698 -- Second argument to checkTyVars
699 whereDots = text "where ..."
700 equalsDots = text "= ..."
701
702 checkDatatypeContext :: Maybe (LHsContext RdrName) -> P ()
703 checkDatatypeContext Nothing = return ()
704 checkDatatypeContext (Just (L loc c))
705 = do allowed <- extension datatypeContextsEnabled
706 unless allowed $
707 parseErrorSDoc loc
708 (text "Illegal datatype context (use DatatypeContexts):" <+>
709 pprHsContext c)
710
711 checkRecordSyntax :: Outputable a => Located a -> P (Located a)
712 checkRecordSyntax lr@(L loc r)
713 = do allowed <- extension traditionalRecordSyntaxEnabled
714 if allowed
715 then return lr
716 else parseErrorSDoc loc
717 (text "Illegal record syntax (use TraditionalRecordSyntax):" <+>
718 ppr r)
719
720 checkTyClHdr :: Bool -- True <=> class header
721 -- False <=> type header
722 -> LHsType RdrName
723 -> P (Located RdrName, -- the head symbol (type or class name)
724 [LHsType RdrName], -- parameters of head symbol
725 [AddAnn]) -- API Annotation for HsParTy when stripping parens
726 -- Well-formedness check and decomposition of type and class heads.
727 -- Decomposes T ty1 .. tyn into (T, [ty1, ..., tyn])
728 -- Int :*: Bool into (:*:, [Int, Bool])
729 -- returning the pieces
730 checkTyClHdr is_cls ty
731 = goL ty [] []
732 where
733 goL (L l ty) acc ann = go l ty acc ann
734
735 go l (HsTyVar (L _ tc)) acc ann
736 | isRdrTc tc = return (L l tc, acc, ann)
737 go _ (HsOpTy t1 ltc@(L _ tc) t2) acc ann
738 | isRdrTc tc = return (ltc, t1:t2:acc, ann)
739 go l (HsParTy ty) acc ann = goL ty acc (ann ++ mkParensApiAnn l)
740 go _ (HsAppTy t1 t2) acc ann = goL t1 (t2:acc) ann
741 go _ (HsAppsTy ts) acc ann
742 | Just (head, args) <- getAppsTyHead_maybe ts = goL head (args ++ acc) ann
743
744 go _ (HsAppsTy [L _ (HsAppInfix (L loc star))]) [] ann
745 | occNameFS (rdrNameOcc star) == fsLit "*"
746 = return (L loc (nameRdrName starKindTyConName), [], ann)
747 | occNameFS (rdrNameOcc star) == fsLit "★"
748 = return (L loc (nameRdrName unicodeStarKindTyConName), [], ann)
749
750 go l (HsTupleTy HsBoxedOrConstraintTuple ts) [] ann
751 = return (L l (nameRdrName tup_name), ts, ann)
752 where
753 arity = length ts
754 tup_name | is_cls = cTupleTyConName arity
755 | otherwise = getName (tupleTyCon Boxed arity)
756 -- See Note [Unit tuples] in HsTypes (TODO: is this still relevant?)
757 go l _ _ _
758 = parseErrorSDoc l (text "Malformed head of type or class declaration:"
759 <+> ppr ty)
760
761 checkContext :: LHsType RdrName -> P ([AddAnn],LHsContext RdrName)
762 checkContext (L l orig_t)
763 = check [] (L l orig_t)
764 where
765 check anns (L lp (HsTupleTy _ ts)) -- (Eq a, Ord b) shows up as a tuple type
766 = return (anns ++ mkParensApiAnn lp,L l ts) -- Ditto ()
767
768 -- don't let HsAppsTy get in the way
769 check anns (L _ (HsAppsTy [L _ (HsAppPrefix ty)]))
770 = check anns ty
771
772 check anns (L lp1 (HsParTy ty))-- to be sure HsParTy doesn't get into the way
773 = check anns' ty
774 where anns' = if l == lp1 then anns
775 else (anns ++ mkParensApiAnn lp1)
776
777 check _anns _
778 = return ([],L l [L l orig_t]) -- no need for anns, returning original
779
780 -- -------------------------------------------------------------------------
781 -- Checking Patterns.
782
783 -- We parse patterns as expressions and check for valid patterns below,
784 -- converting the expression into a pattern at the same time.
785
786 checkPattern :: SDoc -> LHsExpr RdrName -> P (LPat RdrName)
787 checkPattern msg e = checkLPat msg e
788
789 checkPatterns :: SDoc -> [LHsExpr RdrName] -> P [LPat RdrName]
790 checkPatterns msg es = mapM (checkPattern msg) es
791
792 checkLPat :: SDoc -> LHsExpr RdrName -> P (LPat RdrName)
793 checkLPat msg e@(L l _) = checkPat msg l e []
794
795 checkPat :: SDoc -> SrcSpan -> LHsExpr RdrName -> [LPat RdrName]
796 -> P (LPat RdrName)
797 checkPat _ loc (L l (HsVar (L _ c))) args
798 | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
799 checkPat msg loc e args -- OK to let this happen even if bang-patterns
800 -- are not enabled, because there is no valid
801 -- non-bang-pattern parse of (C ! e)
802 | Just (e', args') <- splitBang e
803 = do { args'' <- checkPatterns msg args'
804 ; checkPat msg loc e' (args'' ++ args) }
805 checkPat msg loc (L _ (HsApp f e)) args
806 = do p <- checkLPat msg e
807 checkPat msg loc f (p : args)
808 checkPat msg loc (L _ e) []
809 = do p <- checkAPat msg loc e
810 return (L loc p)
811 checkPat msg loc e _
812 = patFail msg loc (unLoc e)
813
814 checkAPat :: SDoc -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
815 checkAPat msg loc e0 = do
816 pState <- getPState
817 let opts = options pState
818 case e0 of
819 EWildPat -> return (WildPat placeHolderType)
820 HsVar x -> return (VarPat x)
821 HsLit l -> return (LitPat l)
822
823 -- Overloaded numeric patterns (e.g. f 0 x = x)
824 -- Negation is recorded separately, so that the literal is zero or +ve
825 -- NB. Negative *primitive* literals are already handled by the lexer
826 HsOverLit pos_lit -> return (mkNPat (L loc pos_lit) Nothing)
827 NegApp (L l (HsOverLit pos_lit)) _
828 -> return (mkNPat (L l pos_lit) (Just noSyntaxExpr))
829
830 SectionR (L lb (HsVar (L _ bang))) e -- (! x)
831 | bang == bang_RDR
832 -> do { bang_on <- extension bangPatEnabled
833 ; if bang_on then do { e' <- checkLPat msg e
834 ; addAnnotation loc AnnBang lb
835 ; return (BangPat e') }
836 else parseErrorSDoc loc (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e0) }
837
838 ELazyPat e -> checkLPat msg e >>= (return . LazyPat)
839 EAsPat n e -> checkLPat msg e >>= (return . AsPat n)
840 -- view pattern is well-formed if the pattern is
841 EViewPat expr patE -> checkLPat msg patE >>=
842 (return . (\p -> ViewPat expr p placeHolderType))
843 ExprWithTySig e t -> do e <- checkLPat msg e
844 return (SigPatIn e t)
845
846 -- n+k patterns
847 OpApp (L nloc (HsVar (L _ n))) (L _ (HsVar (L _ plus))) _
848 (L lloc (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
849 | extopt LangExt.NPlusKPatterns opts && (plus == plus_RDR)
850 -> return (mkNPlusKPat (L nloc n) (L lloc lit))
851
852 OpApp l op _fix r -> do l <- checkLPat msg l
853 r <- checkLPat msg r
854 case op of
855 L cl (HsVar (L _ c)) | isDataOcc (rdrNameOcc c)
856 -> return (ConPatIn (L cl c) (InfixCon l r))
857 _ -> patFail msg loc e0
858
859 HsPar e -> checkLPat msg e >>= (return . ParPat)
860 ExplicitList _ _ es -> do ps <- mapM (checkLPat msg) es
861 return (ListPat ps placeHolderType Nothing)
862 ExplicitPArr _ es -> do ps <- mapM (checkLPat msg) es
863 return (PArrPat ps placeHolderType)
864
865 ExplicitTuple es b
866 | all tupArgPresent es -> do ps <- mapM (checkLPat msg)
867 [e | L _ (Present e) <- es]
868 return (TuplePat ps b [])
869 | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0)
870
871 ExplicitSum alt arity expr _ -> do
872 p <- checkLPat msg expr
873 return (SumPat p alt arity placeHolderType)
874
875 RecordCon { rcon_con_name = c, rcon_flds = HsRecFields fs dd }
876 -> do fs <- mapM (checkPatField msg) fs
877 return (ConPatIn c (RecCon (HsRecFields fs dd)))
878 HsSpliceE s | not (isTypedSplice s)
879 -> return (SplicePat s)
880 _ -> patFail msg loc e0
881
882 placeHolderPunRhs :: LHsExpr RdrName
883 -- The RHS of a punned record field will be filled in by the renamer
884 -- It's better not to make it an error, in case we want to print it when debugging
885 placeHolderPunRhs = noLoc (HsVar (noLoc pun_RDR))
886
887 plus_RDR, bang_RDR, pun_RDR :: RdrName
888 plus_RDR = mkUnqual varName (fsLit "+") -- Hack
889 bang_RDR = mkUnqual varName (fsLit "!") -- Hack
890 pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side")
891
892 checkPatField :: SDoc -> LHsRecField RdrName (LHsExpr RdrName)
893 -> P (LHsRecField RdrName (LPat RdrName))
894 checkPatField msg (L l fld) = do p <- checkLPat msg (hsRecFieldArg fld)
895 return (L l (fld { hsRecFieldArg = p }))
896
897 patFail :: SDoc -> SrcSpan -> HsExpr RdrName -> P a
898 patFail msg loc e = parseErrorSDoc loc err
899 where err = text "Parse error in pattern:" <+> ppr e
900 $$ msg
901
902
903 ---------------------------------------------------------------------------
904 -- Check Equation Syntax
905
906 checkValDef :: SDoc
907 -> LHsExpr RdrName
908 -> Maybe (LHsType RdrName)
909 -> Located (a,GRHSs RdrName (LHsExpr RdrName))
910 -> P ([AddAnn],HsBind RdrName)
911
912 checkValDef msg lhs (Just sig) grhss
913 -- x :: ty = rhs parses as a *pattern* binding
914 = checkPatBind msg (L (combineLocs lhs sig)
915 (ExprWithTySig lhs (mkLHsSigWcType sig))) grhss
916
917 checkValDef msg lhs opt_sig g@(L l (_,grhss))
918 = do { mb_fun <- isFunLhs lhs
919 ; case mb_fun of
920 Just (fun, is_infix, pats, ann) ->
921 checkFunBind msg ann (getLoc lhs)
922 fun is_infix pats opt_sig (L l grhss)
923 Nothing -> checkPatBind msg lhs g }
924
925 checkFunBind :: SDoc
926 -> [AddAnn]
927 -> SrcSpan
928 -> Located RdrName
929 -> FunctionFixity
930 -> [LHsExpr RdrName]
931 -> Maybe (LHsType RdrName)
932 -> Located (GRHSs RdrName (LHsExpr RdrName))
933 -> P ([AddAnn],HsBind RdrName)
934 checkFunBind msg ann lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
935 = do ps <- checkPatterns msg pats
936 let match_span = combineSrcSpans lhs_loc rhs_span
937 -- Add back the annotations stripped from any HsPar values in the lhs
938 -- mapM_ (\a -> a match_span) ann
939 return (ann, makeFunBind fun
940 [L match_span (Match { m_ctxt = FunRhs fun is_infix
941 , m_pats = ps
942 , m_type = opt_sig
943 , m_grhss = grhss })])
944 -- The span of the match covers the entire equation.
945 -- That isn't quite right, but it'll do for now.
946
947 makeFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)]
948 -> HsBind RdrName
949 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
950 makeFunBind fn ms
951 = FunBind { fun_id = fn,
952 fun_matches = mkMatchGroup FromSource ms,
953 fun_co_fn = idHsWrapper,
954 bind_fvs = placeHolderNames,
955 fun_tick = [] }
956
957 checkPatBind :: SDoc
958 -> LHsExpr RdrName
959 -> Located (a,GRHSs RdrName (LHsExpr RdrName))
960 -> P ([AddAnn],HsBind RdrName)
961 checkPatBind msg lhs (L _ (_,grhss))
962 = do { lhs <- checkPattern msg lhs
963 ; return ([],PatBind lhs grhss placeHolderType placeHolderNames
964 ([],[])) }
965
966 checkValSigLhs :: LHsExpr RdrName -> P (Located RdrName)
967 checkValSigLhs (L _ (HsVar lrdr@(L _ v)))
968 | isUnqual v
969 , not (isDataOcc (rdrNameOcc v))
970 = return lrdr
971
972 checkValSigLhs lhs@(L l _)
973 = parseErrorSDoc l ((text "Invalid type signature:" <+>
974 ppr lhs <+> text ":: ...")
975 $$ text hint)
976 where
977 hint | foreign_RDR `looks_like` lhs
978 = "Perhaps you meant to use ForeignFunctionInterface?"
979 | default_RDR `looks_like` lhs
980 = "Perhaps you meant to use DefaultSignatures?"
981 | pattern_RDR `looks_like` lhs
982 = "Perhaps you meant to use PatternSynonyms?"
983 | otherwise
984 = "Should be of form <variable> :: <type>"
985
986 -- A common error is to forget the ForeignFunctionInterface flag
987 -- so check for that, and suggest. cf Trac #3805
988 -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword
989 looks_like s (L _ (HsVar (L _ v))) = v == s
990 looks_like s (L _ (HsApp lhs _)) = looks_like s lhs
991 looks_like _ _ = False
992
993 foreign_RDR = mkUnqual varName (fsLit "foreign")
994 default_RDR = mkUnqual varName (fsLit "default")
995 pattern_RDR = mkUnqual varName (fsLit "pattern")
996
997
998 checkDoAndIfThenElse :: LHsExpr RdrName
999 -> Bool
1000 -> LHsExpr RdrName
1001 -> Bool
1002 -> LHsExpr RdrName
1003 -> P ()
1004 checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
1005 | semiThen || semiElse
1006 = do pState <- getPState
1007 unless (extopt LangExt.DoAndIfThenElse (options pState)) $ do
1008 parseErrorSDoc (combineLocs guardExpr elseExpr)
1009 (text "Unexpected semi-colons in conditional:"
1010 $$ nest 4 expr
1011 $$ text "Perhaps you meant to use DoAndIfThenElse?")
1012 | otherwise = return ()
1013 where pprOptSemi True = semi
1014 pprOptSemi False = empty
1015 expr = text "if" <+> ppr guardExpr <> pprOptSemi semiThen <+>
1016 text "then" <+> ppr thenExpr <> pprOptSemi semiElse <+>
1017 text "else" <+> ppr elseExpr
1018
1019
1020 -- The parser left-associates, so there should
1021 -- not be any OpApps inside the e's
1022 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
1023 -- Splits (f ! g a b) into (f, [(! g), a, b])
1024 splitBang (L _ (OpApp l_arg bang@(L _ (HsVar (L _ op))) _ r_arg))
1025 | op == bang_RDR = Just (l_arg, L l' (SectionR bang arg1) : argns)
1026 where
1027 l' = combineLocs bang arg1
1028 (arg1,argns) = split_bang r_arg []
1029 split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
1030 split_bang e es = (e,es)
1031 splitBang _ = Nothing
1032
1033 isFunLhs :: LHsExpr RdrName
1034 -> P (Maybe (Located RdrName, FunctionFixity, [LHsExpr RdrName],[AddAnn]))
1035 -- A variable binding is parsed as a FunBind.
1036 -- Just (fun, is_infix, arg_pats) if e is a function LHS
1037 --
1038 -- The whole LHS is parsed as a single expression.
1039 -- Any infix operators on the LHS will parse left-associatively
1040 -- E.g. f !x y !z
1041 -- will parse (rather strangely) as
1042 -- (f ! x y) ! z
1043 -- It's up to isFunLhs to sort out the mess
1044 --
1045 -- a .!. !b
1046
1047 isFunLhs e = go e [] []
1048 where
1049 go (L loc (HsVar (L _ f))) es ann
1050 | not (isRdrDataCon f) = return (Just (L loc f, Prefix, es, ann))
1051 go (L _ (HsApp f e)) es ann = go f (e:es) ann
1052 go (L l (HsPar e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l)
1053
1054 -- For infix function defns, there should be only one infix *function*
1055 -- (though there may be infix *datacons* involved too). So we don't
1056 -- need fixity info to figure out which function is being defined.
1057 -- a `K1` b `op` c `K2` d
1058 -- must parse as
1059 -- (a `K1` b) `op` (c `K2` d)
1060 -- The renamer checks later that the precedences would yield such a parse.
1061 --
1062 -- There is a complication to deal with bang patterns.
1063 --
1064 -- ToDo: what about this?
1065 -- x + 1 `op` y = ...
1066
1067 go e@(L loc (OpApp l (L loc' (HsVar (L _ op))) fix r)) es ann
1068 | Just (e',es') <- splitBang e
1069 = do { bang_on <- extension bangPatEnabled
1070 ; if bang_on then go e' (es' ++ es) ann
1071 else return (Just (L loc' op, Infix, (l:r:es), ann)) }
1072 -- No bangs; behave just like the next case
1073 | not (isRdrDataCon op) -- We have found the function!
1074 = return (Just (L loc' op, Infix, (l:r:es), ann))
1075 | otherwise -- Infix data con; keep going
1076 = do { mb_l <- go l es ann
1077 ; case mb_l of
1078 Just (op', Infix, j : k : es', ann')
1079 -> return (Just (op', Infix, j : op_app : es', ann'))
1080 where
1081 op_app = L loc (OpApp k (L loc' (HsVar (L loc' op))) fix r)
1082 _ -> return Nothing }
1083 go _ _ _ = return Nothing
1084
1085
1086 -- | Transform btype_no_ops with strict_mark's into HsEqTy's
1087 -- (((~a) ~b) c) ~d ==> ((~a) ~ (b c)) ~ d
1088 splitTilde :: LHsType RdrName -> P (LHsType RdrName)
1089 splitTilde t = go t
1090 where go (L loc (HsAppTy t1 t2))
1091 | L lo (HsBangTy (HsSrcBang Nothing NoSrcUnpack SrcLazy) t2') <- t2
1092 = do
1093 moveAnnotations lo loc
1094 t1' <- go t1
1095 return (L loc (HsEqTy t1' t2'))
1096 | otherwise
1097 = do
1098 t1' <- go t1
1099 case t1' of
1100 (L lo (HsEqTy tl tr)) -> do
1101 let lr = combineLocs tr t2
1102 moveAnnotations lo loc
1103 return (L loc (HsEqTy tl (L lr (HsAppTy tr t2))))
1104 t -> do
1105 return (L loc (HsAppTy t t2))
1106
1107 go t = return t
1108
1109
1110 -- | Transform tyapps with strict_marks into uses of twiddle
1111 -- [~a, ~b, c, ~d] ==> (~a) ~ b c ~ d
1112 splitTildeApps :: [LHsAppType RdrName] -> P [LHsAppType RdrName]
1113 splitTildeApps [] = return []
1114 splitTildeApps (t : rest) = do
1115 rest' <- concatMapM go rest
1116 return (t : rest')
1117 where go (L l (HsAppPrefix
1118 (L loc (HsBangTy
1119 (HsSrcBang Nothing NoSrcUnpack SrcLazy)
1120 ty))))
1121 = addAnnotation l AnnTilde tilde_loc >>
1122 return
1123 [L tilde_loc (HsAppInfix (L tilde_loc eqTyCon_RDR)),
1124 L l (HsAppPrefix ty)]
1125 -- NOTE: no annotation is attached to an HsAppPrefix, so the
1126 -- surrounding SrcSpan is not critical
1127 where
1128 tilde_loc = srcSpanFirstCharacter loc
1129
1130 go t = return [t]
1131
1132
1133
1134 ---------------------------------------------------------------------------
1135 -- Check for monad comprehensions
1136 --
1137 -- If the flag MonadComprehensions is set, return a `MonadComp' context,
1138 -- otherwise use the usual `ListComp' context
1139
1140 checkMonadComp :: P (HsStmtContext Name)
1141 checkMonadComp = do
1142 pState <- getPState
1143 return $ if extopt LangExt.MonadComprehensions (options pState)
1144 then MonadComp
1145 else ListComp
1146
1147 -- -------------------------------------------------------------------------
1148 -- Checking arrow syntax.
1149
1150 -- We parse arrow syntax as expressions and check for valid syntax below,
1151 -- converting the expression into a pattern at the same time.
1152
1153 checkCommand :: LHsExpr RdrName -> P (LHsCmd RdrName)
1154 checkCommand lc = locMap checkCmd lc
1155
1156 locMap :: (SrcSpan -> a -> P b) -> Located a -> P (Located b)
1157 locMap f (L l a) = f l a >>= (\b -> return $ L l b)
1158
1159 checkCmd :: SrcSpan -> HsExpr RdrName -> P (HsCmd RdrName)
1160 checkCmd _ (HsArrApp e1 e2 ptt haat b) =
1161 return $ HsCmdArrApp e1 e2 ptt haat b
1162 checkCmd _ (HsArrForm e mf args) =
1163 return $ HsCmdArrForm e mf args
1164 checkCmd _ (HsApp e1 e2) =
1165 checkCommand e1 >>= (\c -> return $ HsCmdApp c e2)
1166 checkCmd _ (HsLam mg) =
1167 checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdLam mg')
1168 checkCmd _ (HsPar e) =
1169 checkCommand e >>= (\c -> return $ HsCmdPar c)
1170 checkCmd _ (HsCase e mg) =
1171 checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdCase e mg')
1172 checkCmd _ (HsIf cf ep et ee) = do
1173 pt <- checkCommand et
1174 pe <- checkCommand ee
1175 return $ HsCmdIf cf ep pt pe
1176 checkCmd _ (HsLet lb e) =
1177 checkCommand e >>= (\c -> return $ HsCmdLet lb c)
1178 checkCmd _ (HsDo DoExpr (L l stmts) ty) =
1179 mapM checkCmdLStmt stmts >>= (\ss -> return $ HsCmdDo (L l ss) ty)
1180
1181 checkCmd _ (OpApp eLeft op _fixity eRight) = do
1182 -- OpApp becomes a HsCmdArrForm with a (Just fixity) in it
1183 c1 <- checkCommand eLeft
1184 c2 <- checkCommand eRight
1185 let arg1 = L (getLoc c1) $ HsCmdTop c1 placeHolderType placeHolderType []
1186 arg2 = L (getLoc c2) $ HsCmdTop c2 placeHolderType placeHolderType []
1187 return $ HsCmdArrForm op Nothing [arg1, arg2]
1188
1189 checkCmd l e = cmdFail l e
1190
1191 checkCmdLStmt :: ExprLStmt RdrName -> P (CmdLStmt RdrName)
1192 checkCmdLStmt = locMap checkCmdStmt
1193
1194 checkCmdStmt :: SrcSpan -> ExprStmt RdrName -> P (CmdStmt RdrName)
1195 checkCmdStmt _ (LastStmt e s r) =
1196 checkCommand e >>= (\c -> return $ LastStmt c s r)
1197 checkCmdStmt _ (BindStmt pat e b f t) =
1198 checkCommand e >>= (\c -> return $ BindStmt pat c b f t)
1199 checkCmdStmt _ (BodyStmt e t g ty) =
1200 checkCommand e >>= (\c -> return $ BodyStmt c t g ty)
1201 checkCmdStmt _ (LetStmt bnds) = return $ LetStmt bnds
1202 checkCmdStmt _ stmt@(RecStmt { recS_stmts = stmts }) = do
1203 ss <- mapM checkCmdLStmt stmts
1204 return $ stmt { recS_stmts = ss }
1205 checkCmdStmt l stmt = cmdStmtFail l stmt
1206
1207 checkCmdMatchGroup :: MatchGroup RdrName (LHsExpr RdrName) -> P (MatchGroup RdrName (LHsCmd RdrName))
1208 checkCmdMatchGroup mg@(MG { mg_alts = L l ms }) = do
1209 ms' <- mapM (locMap $ const convert) ms
1210 return $ mg { mg_alts = L l ms' }
1211 where convert (Match mf pat mty grhss) = do
1212 grhss' <- checkCmdGRHSs grhss
1213 return $ Match mf pat mty grhss'
1214
1215 checkCmdGRHSs :: GRHSs RdrName (LHsExpr RdrName) -> P (GRHSs RdrName (LHsCmd RdrName))
1216 checkCmdGRHSs (GRHSs grhss binds) = do
1217 grhss' <- mapM checkCmdGRHS grhss
1218 return $ GRHSs grhss' binds
1219
1220 checkCmdGRHS :: LGRHS RdrName (LHsExpr RdrName) -> P (LGRHS RdrName (LHsCmd RdrName))
1221 checkCmdGRHS = locMap $ const convert
1222 where
1223 convert (GRHS stmts e) = do
1224 c <- checkCommand e
1225 -- cmdStmts <- mapM checkCmdLStmt stmts
1226 return $ GRHS {- cmdStmts -} stmts c
1227
1228
1229 cmdFail :: SrcSpan -> HsExpr RdrName -> P a
1230 cmdFail loc e = parseErrorSDoc loc (text "Parse error in command:" <+> ppr e)
1231 cmdStmtFail :: SrcSpan -> Stmt RdrName (LHsExpr RdrName) -> P a
1232 cmdStmtFail loc e = parseErrorSDoc loc
1233 (text "Parse error in command statement:" <+> ppr e)
1234
1235 ---------------------------------------------------------------------------
1236 -- Miscellaneous utilities
1237
1238 checkPrecP :: Located (SourceText,Int) -> P (Located (SourceText,Int))
1239 checkPrecP (L l (src,i))
1240 | 0 <= i && i <= maxPrecedence = return (L l (src,i))
1241 | otherwise
1242 = parseErrorSDoc l (text ("Precedence out of range: " ++ show i))
1243
1244 mkRecConstrOrUpdate
1245 :: LHsExpr RdrName
1246 -> SrcSpan
1247 -> ([LHsRecField RdrName (LHsExpr RdrName)], Bool)
1248 -> P (HsExpr RdrName)
1249
1250 mkRecConstrOrUpdate (L l (HsVar (L _ c))) _ (fs,dd)
1251 | isRdrDataCon c
1252 = return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd))
1253 mkRecConstrOrUpdate exp@(L l _) _ (fs,dd)
1254 | dd = parseErrorSDoc l (text "You cannot use `..' in a record update")
1255 | otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs))
1256
1257 mkRdrRecordUpd :: LHsExpr RdrName -> [LHsRecUpdField RdrName] -> HsExpr RdrName
1258 mkRdrRecordUpd exp flds
1259 = RecordUpd { rupd_expr = exp
1260 , rupd_flds = flds
1261 , rupd_cons = PlaceHolder, rupd_in_tys = PlaceHolder
1262 , rupd_out_tys = PlaceHolder, rupd_wrap = PlaceHolder }
1263
1264 mkRdrRecordCon :: Located RdrName -> HsRecordBinds RdrName -> HsExpr RdrName
1265 mkRdrRecordCon con flds
1266 = RecordCon { rcon_con_name = con, rcon_flds = flds
1267 , rcon_con_expr = noPostTcExpr, rcon_con_like = PlaceHolder }
1268
1269 mk_rec_fields :: [LHsRecField id arg] -> Bool -> HsRecFields id arg
1270 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
1271 mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
1272
1273 mk_rec_upd_field :: HsRecField RdrName (LHsExpr RdrName) -> HsRecUpdField RdrName
1274 mk_rec_upd_field (HsRecField (L loc (FieldOcc rdr _)) arg pun)
1275 = HsRecField (L loc (Unambiguous rdr PlaceHolder)) arg pun
1276
1277 mkInlinePragma :: String -> (InlineSpec, RuleMatchInfo) -> Maybe Activation
1278 -> InlinePragma
1279 -- The (Maybe Activation) is because the user can omit
1280 -- the activation spec (and usually does)
1281 mkInlinePragma src (inl, match_info) mb_act
1282 = InlinePragma { inl_src = src -- Note [Pragma source text] in BasicTypes
1283 , inl_inline = inl
1284 , inl_sat = Nothing
1285 , inl_act = act
1286 , inl_rule = match_info }
1287 where
1288 act = case mb_act of
1289 Just act -> act
1290 Nothing -> -- No phase specified
1291 case inl of
1292 NoInline -> NeverActive
1293 _other -> AlwaysActive
1294
1295 -----------------------------------------------------------------------------
1296 -- utilities for foreign declarations
1297
1298 -- construct a foreign import declaration
1299 --
1300 mkImport :: Located CCallConv
1301 -> Located Safety
1302 -> (Located StringLiteral, Located RdrName, LHsSigType RdrName)
1303 -> P (HsDecl RdrName)
1304 mkImport (L lc cconv) (L ls safety) (L loc (StringLiteral esrc entity), v, ty)
1305 | cconv == PrimCallConv = do
1306 let funcTarget = CFunction (StaticTarget esrc entity Nothing True)
1307 importSpec = CImport (L lc PrimCallConv) (L ls safety) Nothing funcTarget
1308 (L loc esrc)
1309 return (ForD (ForeignImport { fd_name = v, fd_sig_ty = ty
1310 , fd_co = noForeignImportCoercionYet
1311 , fd_fi = importSpec }))
1312 | cconv == JavaScriptCallConv = do
1313 let funcTarget = CFunction (StaticTarget esrc entity Nothing True)
1314 importSpec = CImport (L lc JavaScriptCallConv) (L ls safety) Nothing
1315 funcTarget (L loc (unpackFS entity))
1316 return (ForD (ForeignImport { fd_name = v, fd_sig_ty = ty
1317 , fd_co = noForeignImportCoercionYet
1318 , fd_fi = importSpec }))
1319 | otherwise = do
1320 case parseCImport (L lc cconv) (L ls safety) (mkExtName (unLoc v))
1321 (unpackFS entity) (L loc (unpackFS entity)) of
1322 Nothing -> parseErrorSDoc loc (text "Malformed entity string")
1323 Just importSpec -> return (ForD (ForeignImport { fd_name = v, fd_sig_ty = ty
1324 , fd_co = noForeignImportCoercionYet
1325 , fd_fi = importSpec }))
1326
1327 -- the string "foo" is ambiguous: either a header or a C identifier. The
1328 -- C identifier case comes first in the alternatives below, so we pick
1329 -- that one.
1330 parseCImport :: Located CCallConv -> Located Safety -> FastString -> String
1331 -> Located SourceText
1332 -> Maybe ForeignImport
1333 parseCImport cconv safety nm str sourceText =
1334 listToMaybe $ map fst $ filter (null.snd) $
1335 readP_to_S parse str
1336 where
1337 parse = do
1338 skipSpaces
1339 r <- choice [
1340 string "dynamic" >> return (mk Nothing (CFunction DynamicTarget)),
1341 string "wrapper" >> return (mk Nothing CWrapper),
1342 do optional (token "static" >> skipSpaces)
1343 ((mk Nothing <$> cimp nm) +++
1344 (do h <- munch1 hdr_char
1345 skipSpaces
1346 mk (Just (Header h (mkFastString h))) <$> cimp nm))
1347 ]
1348 skipSpaces
1349 return r
1350
1351 token str = do _ <- string str
1352 toks <- look
1353 case toks of
1354 c : _
1355 | id_char c -> pfail
1356 _ -> return ()
1357
1358 mk h n = CImport cconv safety h n sourceText
1359
1360 hdr_char c = not (isSpace c) -- header files are filenames, which can contain
1361 -- pretty much any char (depending on the platform),
1362 -- so just accept any non-space character
1363 id_first_char c = isAlpha c || c == '_'
1364 id_char c = isAlphaNum c || c == '_'
1365
1366 cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)
1367 +++ (do isFun <- case cconv of
1368 L _ CApiConv ->
1369 option True
1370 (do token "value"
1371 skipSpaces
1372 return False)
1373 _ -> return True
1374 cid' <- cid
1375 return (CFunction (StaticTarget (unpackFS cid') cid'
1376 Nothing isFun)))
1377 where
1378 cid = return nm +++
1379 (do c <- satisfy id_first_char
1380 cs <- many (satisfy id_char)
1381 return (mkFastString (c:cs)))
1382
1383
1384 -- construct a foreign export declaration
1385 --
1386 mkExport :: Located CCallConv
1387 -> (Located StringLiteral, Located RdrName, LHsSigType RdrName)
1388 -> P (HsDecl RdrName)
1389 mkExport (L lc cconv) (L le (StringLiteral esrc entity), v, ty)
1390 = return $ ForD $
1391 ForeignExport { fd_name = v, fd_sig_ty = ty
1392 , fd_co = noForeignExportCoercionYet
1393 , fd_fe = CExport (L lc (CExportStatic esrc entity' cconv))
1394 (L le (unpackFS entity)) }
1395 where
1396 entity' | nullFS entity = mkExtName (unLoc v)
1397 | otherwise = entity
1398
1399 -- Supplying the ext_name in a foreign decl is optional; if it
1400 -- isn't there, the Haskell name is assumed. Note that no transformation
1401 -- of the Haskell name is then performed, so if you foreign export (++),
1402 -- it's external name will be "++". Too bad; it's important because we don't
1403 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
1404 --
1405 mkExtName :: RdrName -> CLabelString
1406 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
1407
1408 --------------------------------------------------------------------------------
1409 -- Help with module system imports/exports
1410
1411 data ImpExpSubSpec = ImpExpAbs
1412 | ImpExpAll
1413 | ImpExpList [Located RdrName]
1414 | ImpExpAllWith [Located (Maybe RdrName)]
1415
1416 mkModuleImpExp :: Located RdrName -> ImpExpSubSpec -> P (IE RdrName)
1417 mkModuleImpExp n@(L l name) subs =
1418 case subs of
1419 ImpExpAbs
1420 | isVarNameSpace (rdrNameSpace name) -> return $ IEVar n
1421 | otherwise -> IEThingAbs . L l <$> nameT
1422 ImpExpAll -> IEThingAll . L l <$> nameT
1423 ImpExpList xs ->
1424 (\newName -> IEThingWith (L l newName) NoIEWildcard xs []) <$> nameT
1425 ImpExpAllWith xs ->
1426 do allowed <- extension patternSynonymsEnabled
1427 if allowed
1428 then
1429 let withs = map unLoc xs
1430 pos = maybe NoIEWildcard IEWildcard
1431 (findIndex isNothing withs)
1432 ies = [L l n | L l (Just n) <- xs]
1433 in (\newName -> IEThingWith (L l newName) pos ies []) <$> nameT
1434 else parseErrorSDoc l
1435 (text "Illegal export form (use PatternSynonyms to enable)")
1436 where
1437 nameT =
1438 if isVarNameSpace (rdrNameSpace name)
1439 then parseErrorSDoc l
1440 (text "Expecting a type constructor but found a variable,"
1441 <+> quotes (ppr name) <> text "."
1442 $$ if isSymOcc $ rdrNameOcc name
1443 then text "If" <+> quotes (ppr name) <+> text "is a type constructor"
1444 <+> text "then enable ExplicitNamespaces and use the 'type' keyword."
1445 else empty)
1446 else return $ name
1447
1448 mkTypeImpExp :: Located RdrName -- TcCls or Var name space
1449 -> P (Located RdrName)
1450 mkTypeImpExp name =
1451 do allowed <- extension explicitNamespacesEnabled
1452 if allowed
1453 then return (fmap (`setRdrNameSpace` tcClsName) name)
1454 else parseErrorSDoc (getLoc name)
1455 (text "Illegal keyword 'type' (use ExplicitNamespaces to enable)")
1456
1457 checkImportSpec :: Located [LIE RdrName] -> P (Located [LIE RdrName])
1458 checkImportSpec ie@(L _ specs) =
1459 case [l | (L l (IEThingWith _ (IEWildcard _) _ _)) <- specs] of
1460 [] -> return ie
1461 (l:_) -> importSpecError l
1462 where
1463 importSpecError l =
1464 parseErrorSDoc l
1465 (text "Illegal import form, this syntax can only be used to bundle"
1466 $+$ text "pattern synonyms with types in module exports.")
1467
1468 -- In the correct order
1469 mkImpExpSubSpec :: [Located (Maybe RdrName)] -> P ([AddAnn], ImpExpSubSpec)
1470 mkImpExpSubSpec [] = return ([], ImpExpList [])
1471 mkImpExpSubSpec [L l Nothing] =
1472 return ([\s -> addAnnotation s AnnDotdot l], ImpExpAll)
1473 mkImpExpSubSpec xs =
1474 if (any (isNothing . unLoc) xs)
1475 then return $ ([], ImpExpAllWith xs)
1476 else return $ ([], ImpExpList ([L l x | L l (Just x) <- xs]))
1477
1478
1479 -----------------------------------------------------------------------------
1480 -- Misc utils
1481
1482 parseErrorSDoc :: SrcSpan -> SDoc -> P a
1483 parseErrorSDoc span s = failSpanMsgP span s
1484
1485 data SumOrTuple
1486 = Sum ConTag Arity (LHsExpr RdrName)
1487 | Tuple [LHsTupArg RdrName]
1488
1489 mkSumOrTuple :: Boxity -> SrcSpan -> SumOrTuple -> P (HsExpr RdrName)
1490
1491 -- Tuple
1492 mkSumOrTuple boxity _ (Tuple es) = return (ExplicitTuple es boxity)
1493
1494 -- Sum
1495 mkSumOrTuple Unboxed _ (Sum alt arity e) =
1496 return (ExplicitSum alt arity e PlaceHolder)
1497 mkSumOrTuple Boxed l (Sum alt arity (L _ e)) =
1498 parseErrorSDoc l (hang (text "Boxed sums not supported:") 2 (ppr_boxed_sum alt arity e))
1499 where
1500 ppr_boxed_sum :: ConTag -> Arity -> HsExpr RdrName -> SDoc
1501 ppr_boxed_sum alt arity e =
1502 text "(" <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt) <+> text ")"
1503
1504 ppr_bars n = hsep (replicate n (Outputable.char '|'))