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