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