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