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