Refactor treatment of wildcards
[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 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 checkValSigLhs,
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)
145 , tcdSigs = mkClassOpSigs sigs
146 , tcdMeths = binds
147 , tcdATs = ats, tcdATDefs = at_defs, tcdDocs = docs
148 , tcdFVs = placeHolderNames })) }
149
150 mkATDefault :: LTyFamInstDecl RdrName
151 -> Either (SrcSpan, SDoc) (LTyFamDefltEqn RdrName)
152 -- Take a type-family instance declaration and turn it into
153 -- a type-family default equation for a class declaration
154 -- We parse things as the former and use this function to convert to the latter
155 --
156 -- We use the Either monad because this also called
157 -- from Convert.hs
158 mkATDefault (L loc (TyFamInstDecl { tfid_eqn = L _ e }))
159 | TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_rhs = rhs } <- e
160 = do { tvs <- checkTyVars (ptext (sLit "default")) equalsDots tc (hsib_body pats)
161 ; return (L loc (TyFamEqn { tfe_tycon = tc
162 , tfe_pats = tvs
163 , tfe_rhs = rhs })) }
164
165 mkTyData :: SrcSpan
166 -> NewOrData
167 -> Maybe (Located CType)
168 -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
169 -> Maybe (LHsKind RdrName)
170 -> [LConDecl RdrName]
171 -> HsDeriving RdrName
172 -> P (LTyClDecl RdrName)
173 mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
174 = do { (tc, tparams,ann) <- checkTyClHdr False tycl_hdr
175 ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
176 ; tyvars <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams
177 ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
178 ; return (L loc (DataDecl { tcdLName = tc, tcdTyVars = tyvars,
179 tcdDataDefn = defn,
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 (ptext (sLit "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 -----------------------------------------------------------------------------
430 -- splitCon
431
432 -- When parsing data declarations, we sometimes inadvertently parse
433 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
434 -- This function splits up the type application, adds any pending
435 -- arguments, and converts the type constructor back into a data constructor.
436
437 splitCon :: LHsType RdrName
438 -> P (Located RdrName, HsConDeclDetails RdrName)
439 -- This gets given a "type" that should look like
440 -- C Int Bool
441 -- or C { x::Int, y::Bool }
442 -- and returns the pieces
443 splitCon ty
444 = split ty []
445 where
446 split (L _ (HsAppTy t u)) ts = split t (u : ts)
447 split (L l (HsTyVar (L _ tc))) ts = do data_con <- tyConToDataCon l tc
448 return (data_con, mk_rest ts)
449 split (L l (HsTupleTy HsBoxedOrConstraintTuple ts)) []
450 = return (L l (getRdrName (tupleDataCon Boxed (length ts))), PrefixCon ts)
451 split (L l _) _ = parseErrorSDoc l (text "Cannot parse data constructor in a data/newtype declaration:" <+> ppr ty)
452
453 mk_rest [L l (HsRecTy flds)] = RecCon (L l flds)
454 mk_rest ts = PrefixCon ts
455
456 recordPatSynErr :: SrcSpan -> LPat RdrName -> P a
457 recordPatSynErr loc pat =
458 parseErrorSDoc loc $
459 text "record syntax not supported for pattern synonym declarations:" $$
460 ppr pat
461
462 mkPatSynMatchGroup :: Located RdrName
463 -> Located (OrdList (LHsDecl RdrName))
464 -> P (MatchGroup RdrName (LHsExpr RdrName))
465 mkPatSynMatchGroup (L _ patsyn_name) (L _ decls) =
466 do { matches <- mapM fromDecl (fromOL decls)
467 ; return $ mkMatchGroup FromSource matches }
468 where
469 fromDecl (L loc decl@(ValD (PatBind pat@(L _ (ConPatIn (L _ name) details)) rhs _ _ _))) =
470 do { unless (name == patsyn_name) $
471 wrongNameBindingErr loc decl
472 ; match <- case details of
473 PrefixCon pats -> return $ Match NonFunBindMatch pats Nothing rhs
474 InfixCon pat1 pat2 ->
475 return $ Match NonFunBindMatch [pat1, pat2] Nothing rhs
476 RecCon{} -> recordPatSynErr loc pat
477 ; return $ L loc match }
478 fromDecl (L loc decl) = extraDeclErr loc decl
479
480 extraDeclErr loc decl =
481 parseErrorSDoc loc $
482 text "pattern synonym 'where' clause must contain a single binding:" $$
483 ppr decl
484
485 wrongNameBindingErr loc decl =
486 parseErrorSDoc loc $
487 text "pattern synonym 'where' clause must bind the pattern synonym's name" <+>
488 quotes (ppr patsyn_name) $$ ppr decl
489
490 mkSimpleConDecl :: Located RdrName -> Maybe [LHsTyVarBndr RdrName]
491 -> LHsContext RdrName -> HsConDeclDetails RdrName
492 -> ConDecl RdrName
493
494 mkSimpleConDecl name mb_forall cxt details
495 = ConDecl { con_names = [name]
496 , con_explicit = explicit
497 , con_qvars = qvars
498 , con_cxt = cxt
499 , con_details = details
500 , con_res = ResTyH98
501 , con_doc = Nothing }
502 where
503 (explicit, qvars) = case mb_forall of
504 Nothing -> (False, mkHsQTvs [])
505 Just tvs -> (True, mkHsQTvs tvs)
506
507 mkGadtDecl :: [Located RdrName]
508 -> LHsType RdrName -- Always a HsForAllTy
509 -> ([AddAnn], ConDecl RdrName)
510 mkGadtDecl names ty = ([], mkGadtDecl' names ty)
511
512 mkGadtDecl' :: [Located RdrName]
513 -> LHsType RdrName
514 -> ConDecl RdrName
515 -- We allow C,D :: ty
516 -- and expand it as if it had been
517 -- C :: ty; D :: ty
518 -- (Just like type signatures in general.)
519
520 mkGadtDecl' names lbody_ty@(L loc body_ty)
521 = mk_gadt_con names
522 where
523 (tvs, cxt, tau) = splitLHsSigmaTy lbody_ty
524 (details, res_ty) -- See Note [Sorting out the result type]
525 = case tau of
526 L _ (HsFunTy (L l (HsRecTy flds)) res_ty)
527 -> (RecCon (L l flds), res_ty)
528 _other -> (PrefixCon [], tau)
529
530 explicit = case body_ty of
531 HsForAllTy {} -> True
532 _ -> False
533
534 mk_gadt_con names
535 = ConDecl { con_names = names
536 , con_explicit = explicit
537 , con_qvars = mkHsQTvs tvs
538 , con_cxt = cxt
539 , con_details = details
540 , con_res = ResTyGADT loc res_ty
541 , con_doc = Nothing }
542
543 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
544 tyConToDataCon loc tc
545 | isTcOcc (rdrNameOcc tc)
546 = return (L loc (setRdrNameSpace tc srcDataName))
547 | otherwise
548 = parseErrorSDoc loc (msg $$ extra)
549 where
550 msg = text "Not a data constructor:" <+> quotes (ppr tc)
551 extra | tc == forall_tv_RDR
552 = text "Perhaps you intended to use ExistentialQuantification"
553 | otherwise = empty
554
555 setRdrNameSpace :: RdrName -> NameSpace -> RdrName
556 -- ^ This rather gruesome function is used mainly by the parser.
557 -- When parsing:
558 --
559 -- > data T a = T | T1 Int
560 --
561 -- we parse the data constructors as /types/ because of parser ambiguities,
562 -- so then we need to change the /type constr/ to a /data constr/
563 --
564 -- The exact-name case /can/ occur when parsing:
565 --
566 -- > data [] a = [] | a : [a]
567 --
568 -- For the exact-name case we return an original name.
569 setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ)
570 setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ)
571 setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ)
572 setRdrNameSpace (Exact n) ns
573 | Just thing <- wiredInNameTyThing_maybe n
574 = setWiredInNameSpace thing ns
575 -- Preserve Exact Names for wired-in things,
576 -- notably tuples and lists
577
578 | isExternalName n
579 = Orig (nameModule n) occ
580
581 | otherwise -- This can happen when quoting and then
582 -- splicing a fixity declaration for a type
583 = Exact (mkSystemNameAt (nameUnique n) occ (nameSrcSpan n))
584 where
585 occ = setOccNameSpace ns (nameOccName n)
586
587 setWiredInNameSpace :: TyThing -> NameSpace -> RdrName
588 setWiredInNameSpace (ATyCon tc) ns
589 | isDataConNameSpace ns
590 = ty_con_data_con tc
591 | isTcClsNameSpace ns
592 = Exact (getName tc) -- No-op
593
594 setWiredInNameSpace (AConLike (RealDataCon dc)) ns
595 | isTcClsNameSpace ns
596 = data_con_ty_con dc
597 | isDataConNameSpace ns
598 = Exact (getName dc) -- No-op
599
600 setWiredInNameSpace thing ns
601 = pprPanic "setWiredinNameSpace" (pprNameSpace ns <+> ppr thing)
602
603 ty_con_data_con :: TyCon -> RdrName
604 ty_con_data_con tc
605 | isTupleTyCon tc
606 , Just dc <- tyConSingleDataCon_maybe tc
607 = Exact (getName dc)
608
609 | tc `hasKey` listTyConKey
610 = Exact nilDataConName
611
612 | otherwise -- See Note [setRdrNameSpace for wired-in names]
613 = Unqual (setOccNameSpace srcDataName (getOccName tc))
614
615 data_con_ty_con :: DataCon -> RdrName
616 data_con_ty_con dc
617 | let tc = dataConTyCon dc
618 , isTupleTyCon tc
619 = Exact (getName tc)
620
621 | dc `hasKey` nilDataConKey
622 = Exact listTyConName
623
624 | otherwise -- See Note [setRdrNameSpace for wired-in names]
625 = Unqual (setOccNameSpace tcClsName (getOccName dc))
626
627
628 {- Note [setRdrNameSpace for wired-in names]
629 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
630 In GHC.Types, which declares (:), we have
631 infixr 5 :
632 The ambiguity about which ":" is meant is resolved by parsing it as a
633 data constructor, but then using dataTcOccs to try the type constructor too;
634 and that in turn calls setRdrNameSpace to change the name-space of ":" to
635 tcClsName. There isn't a corresponding ":" type constructor, but it's painful
636 to make setRdrNameSpace partial, so we just make an Unqual name instead. It
637 really doesn't matter!
638 -}
639
640 -- | Note [Sorting out the result type]
641 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
642 -- In a GADT declaration which is not a record, we put the whole constr
643 -- type into the ResTyGADT for now; the renamer will unravel it once it
644 -- has sorted out operator fixities. Consider for example
645 -- C :: a :*: b -> a :*: b -> a :+: b
646 -- Initially this type will parse as
647 -- a :*: (b -> (a :*: (b -> (a :+: b))))
648
649 -- so it's hard to split up the arguments until we've done the precedence
650 -- resolution (in the renamer) On the other hand, for a record
651 -- { x,y :: Int } -> a :*: b
652 -- there is no doubt. AND we need to sort records out so that
653 -- we can bring x,y into scope. So:
654 -- * For PrefixCon we keep all the args in the ResTyGADT
655 -- * For RecCon we do not
656
657 checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName] -> P (LHsQTyVars RdrName)
658 -- Same as checkTyVars, but in the P monad
659 checkTyVarsP pp_what equals_or_where tc tparms
660 = eitherToP $ checkTyVars pp_what equals_or_where tc tparms
661
662 eitherToP :: Either (SrcSpan, SDoc) a -> P a
663 -- Adapts the Either monad to the P monad
664 eitherToP (Left (loc, doc)) = parseErrorSDoc loc doc
665 eitherToP (Right thing) = return thing
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 -- Check that the name space is correct!
678 chk (L l (HsKindSig (L lv (HsTyVar (L _ tv))) k))
679 | isRdrTyVar tv = return (L l (KindedTyVar (L lv tv) k))
680 chk (L l (HsTyVar (L ltv tv)))
681 | isRdrTyVar tv = return (L l (UserTyVar (L ltv tv)))
682 chk t@(L loc _)
683 = Left (loc,
684 vcat [ ptext (sLit "Unexpected type") <+> quotes (ppr t)
685 , ptext (sLit "In the") <+> pp_what <+> ptext (sLit "declaration for") <+> quotes (ppr tc)
686 , vcat[ (ptext (sLit "A") <+> pp_what <+> ptext (sLit "declaration should have form"))
687 , nest 2 (pp_what <+> ppr tc
688 <+> hsep (map text (takeList tparms allNameStrings))
689 <+> equals_or_where) ] ])
690
691 whereDots, equalsDots :: SDoc
692 -- Second argument to checkTyVars
693 whereDots = ptext (sLit "where ...")
694 equalsDots = ptext (sLit "= ...")
695
696 checkDatatypeContext :: Maybe (LHsContext RdrName) -> P ()
697 checkDatatypeContext Nothing = return ()
698 checkDatatypeContext (Just (L loc c))
699 = do allowed <- extension datatypeContextsEnabled
700 unless allowed $
701 parseErrorSDoc loc
702 (text "Illegal datatype context (use DatatypeContexts):" <+>
703 pprHsContext c)
704
705 checkRecordSyntax :: Outputable a => Located a -> P (Located a)
706 checkRecordSyntax lr@(L loc r)
707 = do allowed <- extension traditionalRecordSyntaxEnabled
708 if allowed
709 then return lr
710 else parseErrorSDoc loc
711 (text "Illegal record syntax (use TraditionalRecordSyntax):" <+>
712 ppr r)
713
714 checkTyClHdr :: Bool -- True <=> class header
715 -- False <=> type header
716 -> LHsType RdrName
717 -> P (Located RdrName, -- the head symbol (type or class name)
718 [LHsType RdrName], -- parameters of head symbol
719 [AddAnn]) -- API Annotation for HsParTy when stripping parens
720 -- Well-formedness check and decomposition of type and class heads.
721 -- Decomposes T ty1 .. tyn into (T, [ty1, ..., tyn])
722 -- Int :*: Bool into (:*:, [Int, Bool])
723 -- returning the pieces
724 checkTyClHdr is_cls ty
725 = goL ty [] []
726 where
727 goL (L l ty) acc ann = go l ty acc ann
728
729 go l (HsTyVar (L _ tc)) acc ann
730 | isRdrTc tc = return (L l tc, acc, ann)
731 go _ (HsOpTy t1 (_, ltc@(L _ tc)) t2) acc ann
732 | isRdrTc tc = return (ltc, t1:t2:acc, ann)
733 go l (HsParTy ty) acc ann = goL ty acc (ann ++ mkParensApiAnn l)
734 go _ (HsAppTy t1 t2) acc ann = goL t1 (t2:acc) ann
735
736 go l (HsTupleTy HsBoxedOrConstraintTuple ts) [] ann
737 = return (L l (nameRdrName tup_name), ts, ann)
738 where
739 arity = length ts
740 tup_name | is_cls = cTupleTyConName arity
741 | otherwise = getName (tupleTyCon Boxed arity)
742 -- See Note [Unit tuples] in HsTypes (TODO: is this still relevant?)
743 go l _ _ _
744 = parseErrorSDoc l (text "Malformed head of type or class declaration:"
745 <+> ppr ty)
746
747 checkContext :: LHsType RdrName -> P ([AddAnn],LHsContext RdrName)
748 checkContext (L l orig_t)
749 = check [] (L l orig_t)
750 where
751 check anns (L lp (HsTupleTy _ ts)) -- (Eq a, Ord b) shows up as a tuple type
752 = return (anns ++ mkParensApiAnn lp,L l ts) -- Ditto ()
753
754 check anns (L lp1 (HsParTy ty))-- to be sure HsParTy doesn't get into the way
755 = check anns' ty
756 where anns' = if l == lp1 then anns
757 else (anns ++ mkParensApiAnn lp1)
758
759 check _anns _
760 = return ([],L l [L l orig_t]) -- no need for anns, returning original
761
762 -- -------------------------------------------------------------------------
763 -- Checking Patterns.
764
765 -- We parse patterns as expressions and check for valid patterns below,
766 -- converting the expression into a pattern at the same time.
767
768 checkPattern :: SDoc -> LHsExpr RdrName -> P (LPat RdrName)
769 checkPattern msg e = checkLPat msg e
770
771 checkPatterns :: SDoc -> [LHsExpr RdrName] -> P [LPat RdrName]
772 checkPatterns msg es = mapM (checkPattern msg) es
773
774 checkLPat :: SDoc -> LHsExpr RdrName -> P (LPat RdrName)
775 checkLPat msg e@(L l _) = checkPat msg l e []
776
777 checkPat :: SDoc -> SrcSpan -> LHsExpr RdrName -> [LPat RdrName]
778 -> P (LPat RdrName)
779 checkPat _ loc (L l (HsVar (L _ c))) args
780 | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
781 checkPat msg loc e args -- OK to let this happen even if bang-patterns
782 -- are not enabled, because there is no valid
783 -- non-bang-pattern parse of (C ! e)
784 | Just (e', args') <- splitBang e
785 = do { args'' <- checkPatterns msg args'
786 ; checkPat msg loc e' (args'' ++ args) }
787 checkPat msg loc (L _ (HsApp f e)) args
788 = do p <- checkLPat msg e
789 checkPat msg loc f (p : args)
790 checkPat msg loc (L _ e) []
791 = do p <- checkAPat msg loc e
792 return (L loc p)
793 checkPat msg loc e _
794 = patFail msg loc (unLoc e)
795
796 checkAPat :: SDoc -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
797 checkAPat msg loc e0 = do
798 pState <- getPState
799 let dynflags = dflags pState
800 case e0 of
801 EWildPat -> return (WildPat placeHolderType)
802 HsVar x -> return (VarPat x)
803 HsLit l -> return (LitPat l)
804
805 -- Overloaded numeric patterns (e.g. f 0 x = x)
806 -- Negation is recorded separately, so that the literal is zero or +ve
807 -- NB. Negative *primitive* literals are already handled by the lexer
808 HsOverLit pos_lit -> return (mkNPat (L loc pos_lit) Nothing)
809 NegApp (L l (HsOverLit pos_lit)) _
810 -> return (mkNPat (L l pos_lit) (Just noSyntaxExpr))
811
812 SectionR (L lb (HsVar (L _ bang))) e -- (! x)
813 | bang == bang_RDR
814 -> do { bang_on <- extension bangPatEnabled
815 ; if bang_on then do { e' <- checkLPat msg e
816 ; addAnnotation loc AnnBang lb
817 ; return (BangPat e') }
818 else parseErrorSDoc loc (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e0) }
819
820 ELazyPat e -> checkLPat msg e >>= (return . LazyPat)
821 EAsPat n e -> checkLPat msg e >>= (return . AsPat n)
822 -- view pattern is well-formed if the pattern is
823 EViewPat expr patE -> checkLPat msg patE >>=
824 (return . (\p -> ViewPat expr p placeHolderType))
825 ExprWithTySig e t -> do e <- checkLPat msg e
826 return (SigPatIn e 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 (mkLHsSigWcType sig))) 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 { m_fixity = FunBindMatch fun is_infix
919 , m_pats = ps
920 , m_type = opt_sig
921 , m_grhss = grhss })])
922 -- The span of the match covers the entire equation.
923 -- That isn't quite right, but it'll do for now.
924
925 makeFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)]
926 -> HsBind RdrName
927 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
928 makeFunBind fn ms
929 = FunBind { fun_id = fn,
930 fun_matches = mkMatchGroup FromSource ms,
931 fun_co_fn = idHsWrapper,
932 bind_fvs = placeHolderNames,
933 fun_tick = [] }
934
935 checkPatBind :: SDoc
936 -> LHsExpr RdrName
937 -> Located (a,GRHSs RdrName (LHsExpr RdrName))
938 -> P ([AddAnn],HsBind RdrName)
939 checkPatBind msg lhs (L _ (_,grhss))
940 = do { lhs <- checkPattern msg lhs
941 ; return ([],PatBind lhs grhss placeHolderType placeHolderNames
942 ([],[])) }
943
944 checkValSigLhs :: LHsExpr RdrName -> P (Located RdrName)
945 checkValSigLhs (L _ (HsVar lrdr@(L _ v)))
946 | isUnqual v
947 , not (isDataOcc (rdrNameOcc v))
948 = return lrdr
949
950 checkValSigLhs lhs@(L l _)
951 = parseErrorSDoc l ((text "Invalid type signature:" <+>
952 ppr lhs <+> text ":: ...")
953 $$ text hint)
954 where
955 hint | foreign_RDR `looks_like` lhs
956 = "Perhaps you meant to use ForeignFunctionInterface?"
957 | default_RDR `looks_like` lhs
958 = "Perhaps you meant to use DefaultSignatures?"
959 | pattern_RDR `looks_like` lhs
960 = "Perhaps you meant to use PatternSynonyms?"
961 | otherwise
962 = "Should be of form <variable> :: <type>"
963
964 -- A common error is to forget the ForeignFunctionInterface flag
965 -- so check for that, and suggest. cf Trac #3805
966 -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword
967 looks_like s (L _ (HsVar (L _ v))) = v == s
968 looks_like s (L _ (HsApp lhs _)) = looks_like s lhs
969 looks_like _ _ = False
970
971 foreign_RDR = mkUnqual varName (fsLit "foreign")
972 default_RDR = mkUnqual varName (fsLit "default")
973 pattern_RDR = mkUnqual varName (fsLit "pattern")
974
975
976 checkDoAndIfThenElse :: LHsExpr RdrName
977 -> Bool
978 -> LHsExpr RdrName
979 -> Bool
980 -> LHsExpr RdrName
981 -> P ()
982 checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
983 | semiThen || semiElse
984 = do pState <- getPState
985 unless (xopt Opt_DoAndIfThenElse (dflags pState)) $ do
986 parseErrorSDoc (combineLocs guardExpr elseExpr)
987 (text "Unexpected semi-colons in conditional:"
988 $$ nest 4 expr
989 $$ text "Perhaps you meant to use DoAndIfThenElse?")
990 | otherwise = return ()
991 where pprOptSemi True = semi
992 pprOptSemi False = empty
993 expr = text "if" <+> ppr guardExpr <> pprOptSemi semiThen <+>
994 text "then" <+> ppr thenExpr <> pprOptSemi semiElse <+>
995 text "else" <+> ppr elseExpr
996
997
998 -- The parser left-associates, so there should
999 -- not be any OpApps inside the e's
1000 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
1001 -- Splits (f ! g a b) into (f, [(! g), a, b])
1002 splitBang (L _ (OpApp l_arg bang@(L _ (HsVar (L _ op))) _ r_arg))
1003 | op == bang_RDR = Just (l_arg, L l' (SectionR bang arg1) : argns)
1004 where
1005 l' = combineLocs bang arg1
1006 (arg1,argns) = split_bang r_arg []
1007 split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
1008 split_bang e es = (e,es)
1009 splitBang _ = Nothing
1010
1011 isFunLhs :: LHsExpr RdrName
1012 -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName],[AddAnn]))
1013 -- A variable binding is parsed as a FunBind.
1014 -- Just (fun, is_infix, arg_pats) if e is a function LHS
1015 --
1016 -- The whole LHS is parsed as a single expression.
1017 -- Any infix operators on the LHS will parse left-associatively
1018 -- E.g. f !x y !z
1019 -- will parse (rather strangely) as
1020 -- (f ! x y) ! z
1021 -- It's up to isFunLhs to sort out the mess
1022 --
1023 -- a .!. !b
1024
1025 isFunLhs e = go e [] []
1026 where
1027 go (L loc (HsVar (L _ f))) es ann
1028 | not (isRdrDataCon f) = return (Just (L loc f, False, es, ann))
1029 go (L _ (HsApp f e)) es ann = go f (e:es) ann
1030 go (L l (HsPar e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l)
1031
1032 -- For infix function defns, there should be only one infix *function*
1033 -- (though there may be infix *datacons* involved too). So we don't
1034 -- need fixity info to figure out which function is being defined.
1035 -- a `K1` b `op` c `K2` d
1036 -- must parse as
1037 -- (a `K1` b) `op` (c `K2` d)
1038 -- The renamer checks later that the precedences would yield such a parse.
1039 --
1040 -- There is a complication to deal with bang patterns.
1041 --
1042 -- ToDo: what about this?
1043 -- x + 1 `op` y = ...
1044
1045 go e@(L loc (OpApp l (L loc' (HsVar (L _ op))) fix r)) es ann
1046 | Just (e',es') <- splitBang e
1047 = do { bang_on <- extension bangPatEnabled
1048 ; if bang_on then go e' (es' ++ es) ann
1049 else return (Just (L loc' op, True, (l:r:es), ann)) }
1050 -- No bangs; behave just like the next case
1051 | not (isRdrDataCon op) -- We have found the function!
1052 = return (Just (L loc' op, True, (l:r:es), ann))
1053 | otherwise -- Infix data con; keep going
1054 = do { mb_l <- go l es ann
1055 ; case mb_l of
1056 Just (op', True, j : k : es', ann')
1057 -> return (Just (op', True, j : op_app : es', ann'))
1058 where
1059 op_app = L loc (OpApp k (L loc' (HsVar (L loc' op))) fix r)
1060 _ -> return Nothing }
1061 go _ _ _ = return Nothing
1062
1063
1064 -- | Transform btype with strict_mark's into HsEqTy's
1065 -- (((~a) ~b) c) ~d ==> ((~a) ~ (b c)) ~ d
1066 splitTilde :: LHsType RdrName -> LHsType RdrName
1067 splitTilde t = go t
1068 where go (L loc (HsAppTy t1 t2))
1069 | L _ (HsBangTy (HsSrcBang Nothing NoSrcUnpack SrcLazy) t2') <- t2
1070 = L loc (HsEqTy (go t1) t2')
1071 | otherwise
1072 = case go t1 of
1073 (L _ (HsEqTy tl tr)) ->
1074 L loc (HsEqTy tl (L (combineLocs tr t2) (HsAppTy tr t2)))
1075 t -> L loc (HsAppTy t t2)
1076
1077 go t = t
1078
1079 ---------------------------------------------------------------------------
1080 -- Check for monad comprehensions
1081 --
1082 -- If the flag MonadComprehensions is set, return a `MonadComp' context,
1083 -- otherwise use the usual `ListComp' context
1084
1085 checkMonadComp :: P (HsStmtContext Name)
1086 checkMonadComp = do
1087 pState <- getPState
1088 return $ if xopt Opt_MonadComprehensions (dflags pState)
1089 then MonadComp
1090 else ListComp
1091
1092 -- -------------------------------------------------------------------------
1093 -- Checking arrow syntax.
1094
1095 -- We parse arrow syntax as expressions and check for valid syntax below,
1096 -- converting the expression into a pattern at the same time.
1097
1098 checkCommand :: LHsExpr RdrName -> P (LHsCmd RdrName)
1099 checkCommand lc = locMap checkCmd lc
1100
1101 locMap :: (SrcSpan -> a -> P b) -> Located a -> P (Located b)
1102 locMap f (L l a) = f l a >>= (\b -> return $ L l b)
1103
1104 checkCmd :: SrcSpan -> HsExpr RdrName -> P (HsCmd RdrName)
1105 checkCmd _ (HsArrApp e1 e2 ptt haat b) =
1106 return $ HsCmdArrApp e1 e2 ptt haat b
1107 checkCmd _ (HsArrForm e mf args) =
1108 return $ HsCmdArrForm e mf args
1109 checkCmd _ (HsApp e1 e2) =
1110 checkCommand e1 >>= (\c -> return $ HsCmdApp c e2)
1111 checkCmd _ (HsLam mg) =
1112 checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdLam mg')
1113 checkCmd _ (HsPar e) =
1114 checkCommand e >>= (\c -> return $ HsCmdPar c)
1115 checkCmd _ (HsCase e mg) =
1116 checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdCase e mg')
1117 checkCmd _ (HsIf cf ep et ee) = do
1118 pt <- checkCommand et
1119 pe <- checkCommand ee
1120 return $ HsCmdIf cf ep pt pe
1121 checkCmd _ (HsLet lb e) =
1122 checkCommand e >>= (\c -> return $ HsCmdLet lb c)
1123 checkCmd _ (HsDo DoExpr (L l stmts) ty) =
1124 mapM checkCmdLStmt stmts >>= (\ss -> return $ HsCmdDo (L l ss) ty)
1125
1126 checkCmd _ (OpApp eLeft op _fixity eRight) = do
1127 -- OpApp becomes a HsCmdArrForm with a (Just fixity) in it
1128 c1 <- checkCommand eLeft
1129 c2 <- checkCommand eRight
1130 let arg1 = L (getLoc c1) $ HsCmdTop c1 placeHolderType placeHolderType []
1131 arg2 = L (getLoc c2) $ HsCmdTop c2 placeHolderType placeHolderType []
1132 return $ HsCmdArrForm op Nothing [arg1, arg2]
1133
1134 checkCmd l e = cmdFail l e
1135
1136 checkCmdLStmt :: ExprLStmt RdrName -> P (CmdLStmt RdrName)
1137 checkCmdLStmt = locMap checkCmdStmt
1138
1139 checkCmdStmt :: SrcSpan -> ExprStmt RdrName -> P (CmdStmt RdrName)
1140 checkCmdStmt _ (LastStmt e s r) =
1141 checkCommand e >>= (\c -> return $ LastStmt c s r)
1142 checkCmdStmt _ (BindStmt pat e b f) =
1143 checkCommand e >>= (\c -> return $ BindStmt pat c b f)
1144 checkCmdStmt _ (BodyStmt e t g ty) =
1145 checkCommand e >>= (\c -> return $ BodyStmt c t g ty)
1146 checkCmdStmt _ (LetStmt bnds) = return $ LetStmt bnds
1147 checkCmdStmt _ stmt@(RecStmt { recS_stmts = stmts }) = do
1148 ss <- mapM checkCmdLStmt stmts
1149 return $ stmt { recS_stmts = ss }
1150 checkCmdStmt l stmt = cmdStmtFail l stmt
1151
1152 checkCmdMatchGroup :: MatchGroup RdrName (LHsExpr RdrName) -> P (MatchGroup RdrName (LHsCmd RdrName))
1153 checkCmdMatchGroup mg@(MG { mg_alts = L l ms }) = do
1154 ms' <- mapM (locMap $ const convert) ms
1155 return $ mg { mg_alts = L l ms' }
1156 where convert (Match mf pat mty grhss) = do
1157 grhss' <- checkCmdGRHSs grhss
1158 return $ Match mf pat mty grhss'
1159
1160 checkCmdGRHSs :: GRHSs RdrName (LHsExpr RdrName) -> P (GRHSs RdrName (LHsCmd RdrName))
1161 checkCmdGRHSs (GRHSs grhss binds) = do
1162 grhss' <- mapM checkCmdGRHS grhss
1163 return $ GRHSs grhss' binds
1164
1165 checkCmdGRHS :: LGRHS RdrName (LHsExpr RdrName) -> P (LGRHS RdrName (LHsCmd RdrName))
1166 checkCmdGRHS = locMap $ const convert
1167 where
1168 convert (GRHS stmts e) = do
1169 c <- checkCommand e
1170 -- cmdStmts <- mapM checkCmdLStmt stmts
1171 return $ GRHS {- cmdStmts -} stmts c
1172
1173
1174 cmdFail :: SrcSpan -> HsExpr RdrName -> P a
1175 cmdFail loc e = parseErrorSDoc loc (text "Parse error in command:" <+> ppr e)
1176 cmdStmtFail :: SrcSpan -> Stmt RdrName (LHsExpr RdrName) -> P a
1177 cmdStmtFail loc e = parseErrorSDoc loc
1178 (text "Parse error in command statement:" <+> ppr e)
1179
1180 ---------------------------------------------------------------------------
1181 -- Miscellaneous utilities
1182
1183 checkPrecP :: Located Int -> P (Located Int)
1184 checkPrecP (L l i)
1185 | 0 <= i && i <= maxPrecedence = return (L l i)
1186 | otherwise
1187 = parseErrorSDoc l (text ("Precedence out of range: " ++ show i))
1188
1189 mkRecConstrOrUpdate
1190 :: LHsExpr RdrName
1191 -> SrcSpan
1192 -> ([LHsRecField RdrName (LHsExpr RdrName)], Bool)
1193 -> P (HsExpr RdrName)
1194
1195 mkRecConstrOrUpdate (L l (HsVar (L _ c))) _ (fs,dd)
1196 | isRdrDataCon c
1197 = return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd))
1198 mkRecConstrOrUpdate exp@(L l _) _ (fs,dd)
1199 | dd = parseErrorSDoc l (text "You cannot use `..' in a record update")
1200 | otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs))
1201
1202 mkRdrRecordUpd :: LHsExpr RdrName -> [LHsRecUpdField RdrName] -> HsExpr RdrName
1203 mkRdrRecordUpd exp flds
1204 = RecordUpd { rupd_expr = exp
1205 , rupd_flds = flds
1206 , rupd_cons = PlaceHolder, rupd_in_tys = PlaceHolder
1207 , rupd_out_tys = PlaceHolder, rupd_wrap = PlaceHolder }
1208
1209 mkRdrRecordCon :: Located RdrName -> HsRecordBinds RdrName -> HsExpr RdrName
1210 mkRdrRecordCon con flds
1211 = RecordCon { rcon_con_name = con, rcon_flds = flds
1212 , rcon_con_expr = noPostTcExpr, rcon_con_like = PlaceHolder }
1213
1214 mk_rec_fields :: [LHsRecField id arg] -> Bool -> HsRecFields id arg
1215 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
1216 mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
1217
1218 mk_rec_upd_field :: HsRecField RdrName (LHsExpr RdrName) -> HsRecUpdField RdrName
1219 mk_rec_upd_field (HsRecField (L loc (FieldOcc rdr _)) arg pun)
1220 = HsRecField (L loc (Unambiguous rdr PlaceHolder)) arg pun
1221
1222 mkInlinePragma :: String -> (InlineSpec, RuleMatchInfo) -> Maybe Activation
1223 -> InlinePragma
1224 -- The (Maybe Activation) is because the user can omit
1225 -- the activation spec (and usually does)
1226 mkInlinePragma src (inl, match_info) mb_act
1227 = InlinePragma { inl_src = src -- Note [Pragma source text] in BasicTypes
1228 , inl_inline = inl
1229 , inl_sat = Nothing
1230 , inl_act = act
1231 , inl_rule = match_info }
1232 where
1233 act = case mb_act of
1234 Just act -> act
1235 Nothing -> -- No phase specified
1236 case inl of
1237 NoInline -> NeverActive
1238 _other -> AlwaysActive
1239
1240 -----------------------------------------------------------------------------
1241 -- utilities for foreign declarations
1242
1243 -- construct a foreign import declaration
1244 --
1245 mkImport :: Located CCallConv
1246 -> Located Safety
1247 -> (Located StringLiteral, Located RdrName, LHsSigType RdrName)
1248 -> P (HsDecl RdrName)
1249 mkImport (L lc cconv) (L ls safety) (L loc (StringLiteral esrc entity), v, ty)
1250 | cconv == PrimCallConv = do
1251 let funcTarget = CFunction (StaticTarget esrc entity Nothing True)
1252 importSpec = CImport (L lc PrimCallConv) (L ls safety) Nothing funcTarget
1253 (L loc (unpackFS entity))
1254 return (ForD (ForeignImport { fd_name = v, fd_sig_ty = ty
1255 , fd_co = noForeignImportCoercionYet
1256 , fd_fi = importSpec }))
1257 | cconv == JavaScriptCallConv = do
1258 let funcTarget = CFunction (StaticTarget esrc entity Nothing True)
1259 importSpec = CImport (L lc JavaScriptCallConv) (L ls safety) Nothing
1260 funcTarget (L loc (unpackFS entity))
1261 return (ForD (ForeignImport { fd_name = v, fd_sig_ty = ty
1262 , fd_co = noForeignImportCoercionYet
1263 , fd_fi = importSpec }))
1264 | otherwise = do
1265 case parseCImport (L lc cconv) (L ls safety) (mkExtName (unLoc v))
1266 (unpackFS entity) (L loc (unpackFS entity)) of
1267 Nothing -> parseErrorSDoc loc (text "Malformed entity string")
1268 Just importSpec -> return (ForD (ForeignImport { fd_name = v, fd_sig_ty = ty
1269 , fd_co = noForeignImportCoercionYet
1270 , fd_fi = importSpec }))
1271
1272 -- the string "foo" is ambigous: either a header or a C identifier. The
1273 -- C identifier case comes first in the alternatives below, so we pick
1274 -- that one.
1275 parseCImport :: Located CCallConv -> Located Safety -> FastString -> String
1276 -> Located SourceText
1277 -> Maybe ForeignImport
1278 parseCImport cconv safety nm str sourceText =
1279 listToMaybe $ map fst $ filter (null.snd) $
1280 readP_to_S parse str
1281 where
1282 parse = do
1283 skipSpaces
1284 r <- choice [
1285 string "dynamic" >> return (mk Nothing (CFunction DynamicTarget)),
1286 string "wrapper" >> return (mk Nothing CWrapper),
1287 do optional (token "static" >> skipSpaces)
1288 ((mk Nothing <$> cimp nm) +++
1289 (do h <- munch1 hdr_char
1290 skipSpaces
1291 mk (Just (Header h (mkFastString h))) <$> cimp nm))
1292 ]
1293 skipSpaces
1294 return r
1295
1296 token str = do _ <- string str
1297 toks <- look
1298 case toks of
1299 c : _
1300 | id_char c -> pfail
1301 _ -> return ()
1302
1303 mk h n = CImport cconv safety h n sourceText
1304
1305 hdr_char c = not (isSpace c) -- header files are filenames, which can contain
1306 -- pretty much any char (depending on the platform),
1307 -- so just accept any non-space character
1308 id_first_char c = isAlpha c || c == '_'
1309 id_char c = isAlphaNum c || c == '_'
1310
1311 cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)
1312 +++ (do isFun <- case cconv of
1313 L _ CApiConv ->
1314 option True
1315 (do token "value"
1316 skipSpaces
1317 return False)
1318 _ -> return True
1319 cid' <- cid
1320 return (CFunction (StaticTarget (unpackFS cid') cid'
1321 Nothing isFun)))
1322 where
1323 cid = return nm +++
1324 (do c <- satisfy id_first_char
1325 cs <- many (satisfy id_char)
1326 return (mkFastString (c:cs)))
1327
1328
1329 -- construct a foreign export declaration
1330 --
1331 mkExport :: Located CCallConv
1332 -> (Located StringLiteral, Located RdrName, LHsSigType RdrName)
1333 -> P (HsDecl RdrName)
1334 mkExport (L lc cconv) (L le (StringLiteral esrc entity), v, ty)
1335 = return $ ForD $
1336 ForeignExport { fd_name = v, fd_sig_ty = ty
1337 , fd_co = noForeignExportCoercionYet
1338 , fd_fe = CExport (L lc (CExportStatic esrc entity' cconv))
1339 (L le (unpackFS entity)) }
1340 where
1341 entity' | nullFS entity = mkExtName (unLoc v)
1342 | otherwise = entity
1343
1344 -- Supplying the ext_name in a foreign decl is optional; if it
1345 -- isn't there, the Haskell name is assumed. Note that no transformation
1346 -- of the Haskell name is then performed, so if you foreign export (++),
1347 -- it's external name will be "++". Too bad; it's important because we don't
1348 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
1349 --
1350 mkExtName :: RdrName -> CLabelString
1351 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
1352
1353 --------------------------------------------------------------------------------
1354 -- Help with module system imports/exports
1355
1356 data ImpExpSubSpec = ImpExpAbs
1357 | ImpExpAll
1358 | ImpExpList [Located RdrName]
1359 | ImpExpAllWith [Located (Maybe RdrName)]
1360
1361 mkModuleImpExp :: Located RdrName -> ImpExpSubSpec -> P (IE RdrName)
1362 mkModuleImpExp n@(L l name) subs =
1363 case subs of
1364 ImpExpAbs
1365 | isVarNameSpace (rdrNameSpace name) -> return $ IEVar n
1366 | otherwise -> return $ IEThingAbs (L l name)
1367 ImpExpAll -> return $ IEThingAll (L l name)
1368 ImpExpList xs ->
1369 return $ IEThingWith (L l name) NoIEWildcard xs []
1370 ImpExpAllWith xs ->
1371 do allowed <- extension patternSynonymsEnabled
1372 if allowed
1373 then
1374 let withs = map unLoc xs
1375 pos = maybe NoIEWildcard IEWildcard
1376 (findIndex isNothing withs)
1377 ies = [L l n | L l (Just n) <- xs]
1378 in return (IEThingWith (L l name) pos ies [])
1379 else parseErrorSDoc l
1380 (text "Illegal export form (use PatternSynonyms to enable)")
1381
1382 mkTypeImpExp :: Located RdrName -- TcCls or Var name space
1383 -> P (Located RdrName)
1384 mkTypeImpExp name =
1385 do allowed <- extension explicitNamespacesEnabled
1386 if allowed
1387 then return (fmap (`setRdrNameSpace` tcClsName) name)
1388 else parseErrorSDoc (getLoc name)
1389 (text "Illegal keyword 'type' (use ExplicitNamespaces to enable)")
1390
1391 checkImportSpec :: Located [LIE RdrName] -> P (Located [LIE RdrName])
1392 checkImportSpec ie@(L _ specs) =
1393 case [l | (L l (IEThingWith _ (IEWildcard _) _ _)) <- specs] of
1394 [] -> return ie
1395 (l:_) -> importSpecError l
1396 where
1397 importSpecError l =
1398 parseErrorSDoc l
1399 (text "Illegal import form, this syntax can only be used to bundle"
1400 $+$ text "pattern synonyms with types in module exports.")
1401
1402 -- In the correct order
1403 mkImpExpSubSpec :: [Located (Maybe RdrName)] -> P ([AddAnn], ImpExpSubSpec)
1404 mkImpExpSubSpec [] = return ([], ImpExpList [])
1405 mkImpExpSubSpec [L l Nothing] =
1406 return ([\s -> addAnnotation l AnnDotdot s], ImpExpAll)
1407 mkImpExpSubSpec xs =
1408 if (any (isNothing . unLoc) xs)
1409 then return $ ([], ImpExpAllWith xs)
1410 else return $ ([], ImpExpList ([L l x | L l (Just x) <- xs]))
1411
1412
1413 -----------------------------------------------------------------------------
1414 -- Misc utils
1415
1416 parseErrorSDoc :: SrcSpan -> SDoc -> P a
1417 parseErrorSDoc span s = failSpanMsgP span s