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