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