2 % (c) The University of Glasgow, 1996-2003
4 Functions over HsSyn specialised to RdrName.
9 extractHsRhoRdrTyVars, extractGenericPatTyVars,
11 mkHsOpApp, mkClassDecl,
12 mkHsIntegral, mkHsFractional, mkHsIsString,
14 mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec,
15 mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
20 findSplice, checkDecBrGroup,
22 -- Stuff to do with Foreign declarations
24 mkImport, -- CallConv -> Safety
25 -- -> (FastString, RdrName, RdrNameHsType)
28 -- -> (FastString, RdrName, RdrNameHsType)
30 mkExtName, -- RdrName -> CLabelString
31 mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName
33 -- Bunch of functions in the parser monad for
34 -- checking and constructing values
35 checkPrecP, -- Int -> P Int
36 checkContext, -- HsType -> P HsContext
37 checkPred, -- HsType -> P HsPred
38 checkTyClHdr, -- LHsContext RdrName -> LHsType RdrName
39 -- -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName])
40 checkTyVars, -- [LHsType RdrName] -> P ()
41 checkSynHdr, -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName])
42 checkKindSigs, -- [LTyClDecl RdrName] -> P ()
43 checkInstType, -- HsType -> P HsType
44 checkDerivDecl, -- LDerivDecl RdrName -> P (LDerivDecl RdrName)
45 checkPattern, -- HsExp -> P HsPat
47 checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat]
48 checkDo, -- [Stmt] -> P [Stmt]
49 checkMDo, -- [Stmt] -> P [Stmt]
50 checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
51 checkValSig, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
56 import HsSyn -- Lots of it
57 import Class ( FunDep )
58 import TypeRep ( Kind )
59 import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc,
60 isRdrDataCon, isUnqual, getRdrName, isQual,
61 setRdrNameSpace, showRdrName )
62 import BasicTypes ( maxPrecedence, Activation, RuleMatchInfo,
63 InlinePragma(..), InlineSpec(..),
64 alwaysInlineSpec, neverInlineSpec )
65 import Lexer ( P, failSpanMsgP, extension, standaloneDerivingEnabled, bangPatEnabled )
66 import TysWiredIn ( unitTyCon )
67 import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
68 DNCallSpec(..), DNKind(..), CLabelString )
69 import OccName ( srcDataName, varName, isDataOcc, isTcOcc,
71 import PrelNames ( forall_tv_RDR )
73 import OrdList ( OrdList, fromOL )
74 import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag )
78 import List ( isSuffixOf, nubBy )
79 import Monad ( unless )
81 #include "HsVersions.h"
85 %************************************************************************
87 \subsection{A few functions over HsSyn at RdrName}
89 %************************************************************************
91 extractHsTyRdrNames finds the free variables of a HsType
92 It's used when making the for-alls explicit.
95 extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName]
96 extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty [])
98 extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName]
99 -- This one takes the context and tau-part of a
100 -- sigma type and returns their free type variables
101 extractHsRhoRdrTyVars ctxt ty
102 = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty [])
104 extract_lctxt :: Located [LHsPred RdrName] -> [Located RdrName] -> [Located RdrName]
105 extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt)
107 extract_pred :: HsPred RdrName -> [Located RdrName] -> [Located RdrName]
108 extract_pred (HsClassP _ tys) acc = foldr extract_lty acc tys
109 extract_pred (HsEqualP ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
110 extract_pred (HsIParam _ ty ) acc = extract_lty ty acc
112 extract_lty :: LHsType RdrName -> [Located RdrName] -> [Located RdrName]
113 extract_lty (L loc ty) acc
115 HsTyVar tv -> extract_tv loc tv acc
116 HsBangTy _ ty -> extract_lty ty acc
117 HsAppTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
118 HsListTy ty -> extract_lty ty acc
119 HsPArrTy ty -> extract_lty ty acc
120 HsTupleTy _ tys -> foldr extract_lty acc tys
121 HsFunTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
122 HsPredTy p -> extract_pred p acc
123 HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
124 HsParTy ty -> extract_lty ty acc
126 HsSpliceTy _ -> acc -- Type splices mention no type variables
127 HsKindSig ty _ -> extract_lty ty acc
128 HsForAllTy _ [] cx ty -> extract_lctxt cx (extract_lty ty acc)
129 HsForAllTy _ tvs cx ty -> acc ++ (filter ((`notElem` locals) . unLoc) $
130 extract_lctxt cx (extract_lty ty []))
132 locals = hsLTyVarNames tvs
133 HsDocTy ty _ -> extract_lty ty acc
135 extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName]
136 extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc
139 extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName]
140 -- Get the type variables out of the type patterns in a bunch of
141 -- possibly-generic bindings in a class declaration
142 extractGenericPatTyVars binds
143 = nubBy eqLocated (foldrBag get [] binds)
145 get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms
148 get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
153 %************************************************************************
155 \subsection{Construction functions for Rdr stuff}
157 %************************************************************************
159 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
160 by deriving them from the name of the class. We fill in the names for the
161 tycon and datacon corresponding to the class, by deriving them from the
162 name of the class itself. This saves recording the names in the interface
163 file (which would be equally good).
165 Similarly for mkConDecl, mkClassOpSig and default-method names.
167 *** See "THE NAMING STORY" in HsDecls ****
170 mkClassDecl :: (LHsContext name, Located name, [LHsTyVarBndr name])
171 -> [Located (FunDep name)]
177 mkClassDecl (cxt, cname, tyvars) fds sigs mbinds ats docs
178 = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
186 mkTyData :: NewOrData
190 Maybe [LHsType name])
193 -> Maybe [LHsType name]
195 mkTyData new_or_data (context, tname, tyvars, typats) ksig data_cons maybe_deriv
196 = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
197 tcdTyVars = tyvars, tcdTyPats = typats, tcdCons = data_cons,
198 tcdKindSig = ksig, tcdDerivs = maybe_deriv }
201 %************************************************************************
203 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
205 %************************************************************************
207 Function definitions are restructured here. Each is assumed to be recursive
208 initially, and non recursive definitions are discovered by the dependency
213 -- | Groups together bindings for a single function
214 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
215 cvTopDecls decls = go (fromOL decls)
217 go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
219 go (L l (ValD b) : ds) = L l' (ValD b') : go ds'
220 where (L l' b', ds') = getMonoBind (L l b) ds
221 go (d : ds) = d : go ds
223 -- Declaration list may only contain value bindings and signatures.
224 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
226 = case cvBindsAndSigs binding of
227 (mbs, sigs, tydecls, _) -> ASSERT( null tydecls )
230 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
231 -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl RdrName])
232 -- Input decls contain just value bindings and signatures
233 -- and in case of class or instance declarations also
234 -- associated type declarations. They might also contain Haddock comments.
235 cvBindsAndSigs fb = go (fromOL fb)
237 go [] = (emptyBag, [], [], [])
238 go (L l (SigD s) : ds) = (bs, L l s : ss, ts, docs)
239 where (bs, ss, ts, docs) = go ds
240 go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, docs)
241 where (b', ds') = getMonoBind (L l b) ds
242 (bs, ss, ts, docs) = go ds'
243 go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs)
244 where (bs, ss, ts, docs) = go ds
245 go (L l (DocD d) : ds) = (bs, ss, ts, (L l d) : docs)
246 where (bs, ss, ts, docs) = go ds
247 go (L _ d : _) = pprPanic "cvBindsAndSigs" (ppr d)
249 -----------------------------------------------------------------------------
250 -- Group function bindings into equation groups
252 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
253 -> (LHsBind RdrName, [LHsDecl RdrName])
254 -- Suppose (b',ds') = getMonoBind b ds
255 -- ds is a list of parsed bindings
256 -- b is a MonoBinds that has just been read off the front
258 -- Then b' is the result of grouping more equations from ds that
259 -- belong with b into a single MonoBinds, and ds' is the depleted
260 -- list of parsed bindings.
262 -- All Haddock comments between equations inside the group are
265 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
267 getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1,
268 fun_matches = MatchGroup mtchs1 _ })) binds
270 = go is_infix1 mtchs1 loc1 binds []
272 go is_infix mtchs loc
273 (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
274 fun_matches = MatchGroup mtchs2 _ })) : binds) _
275 | f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs)
276 (combineSrcSpans loc loc2) binds []
277 go is_infix mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls
278 = let doc_decls' = doc_decl : doc_decls
279 in go is_infix mtchs (combineSrcSpans loc loc2) binds doc_decls'
280 go is_infix mtchs loc binds doc_decls
281 = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), (reverse doc_decls) ++ binds)
282 -- Reverse the final matches, to get it back in the right order
283 -- Do the same thing with the trailing doc comments
285 getMonoBind bind binds = (bind, binds)
287 has_args :: [LMatch RdrName] -> Bool
288 has_args [] = panic "RdrHsSyn:has_args"
289 has_args ((L _ (Match args _ _)) : _) = not (null args)
290 -- Don't group together FunBinds if they have
291 -- no arguments. This is necessary now that variable bindings
292 -- with no arguments are now treated as FunBinds rather
293 -- than pattern bindings (tests/rename/should_fail/rnfail002).
297 findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
298 findSplice ds = addl emptyRdrGroup ds
300 checkDecBrGroup :: [LHsDecl a] -> P (HsGroup a)
301 -- Turn the body of a [d| ... |] into a HsGroup
302 -- There should be no splices in the "..."
303 checkDecBrGroup decls
304 = case addl emptyRdrGroup decls of
305 (group, Nothing) -> return group
306 (_, Just (SpliceDecl (L loc _), _)) ->
307 parseError loc "Declaration splices are not permitted inside declaration brackets"
308 -- Why not? See Section 7.3 of the TH paper.
310 addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
311 -- This stuff reverses the declarations (again) but it doesn't matter
314 addl gp [] = (gp, Nothing)
315 addl gp (L l d : ds) = add gp l d ds
318 add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a]
319 -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
321 add gp _ (SpliceD e) ds = (gp, Just (e, ds))
323 -- Class declarations: pull out the fixity signatures to the top
324 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs})
327 let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
328 addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs}) ds
330 addl (gp { hs_tyclds = L l d : ts }) ds
332 -- Signatures: fixity sigs go a different place than all others
333 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
334 = addl (gp {hs_fixds = L l f : ts}) ds
335 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
336 = addl (gp {hs_valds = add_sig (L l d) ts}) ds
338 -- Value declarations: use add_bind
339 add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds
340 = addl (gp { hs_valds = add_bind (L l d) ts }) ds
342 -- The rest are routine
343 add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds
344 = addl (gp { hs_instds = L l d : ts }) ds
345 add gp@(HsGroup {hs_derivds = ts}) l (DerivD d) ds
346 = addl (gp { hs_derivds = L l d : ts }) ds
347 add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
348 = addl (gp { hs_defds = L l d : ts }) ds
349 add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
350 = addl (gp { hs_fords = L l d : ts }) ds
351 add gp@(HsGroup {hs_warnds = ts}) l (WarningD d) ds
352 = addl (gp { hs_warnds = L l d : ts }) ds
353 add gp@(HsGroup {hs_annds = ts}) l (AnnD d) ds
354 = addl (gp { hs_annds = L l d : ts }) ds
355 add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
356 = addl (gp { hs_ruleds = L l d : ts }) ds
359 = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds
361 add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
362 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
363 add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind"
365 add_sig :: LSig a -> HsValBinds a -> HsValBinds a
366 add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
367 add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig"
370 %************************************************************************
372 \subsection[PrefixToHS-utils]{Utilities for conversion}
374 %************************************************************************
378 -----------------------------------------------------------------------------
381 -- When parsing data declarations, we sometimes inadvertently parse
382 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
383 -- This function splits up the type application, adds any pending
384 -- arguments, and converts the type constructor back into a data constructor.
386 mkPrefixCon :: LHsType RdrName -> [LBangType RdrName]
387 -> P (Located RdrName, HsConDeclDetails RdrName)
391 split (L _ (HsAppTy t u)) ts = split t (u : ts)
392 split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc
393 return (data_con, PrefixCon ts)
394 split (L l _) _ = parseError l "parse error in data/newtype declaration"
396 mkRecCon :: Located RdrName ->
397 [([Located RdrName], LBangType RdrName, Maybe (LHsDoc RdrName))] ->
398 P (Located RdrName, HsConDeclDetails RdrName)
399 mkRecCon (L loc con) fields
400 = do data_con <- tyConToDataCon loc con
401 return (data_con, RecCon [ ConDeclField l t d | (ls, t, d) <- fields, l <- ls ])
403 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
404 tyConToDataCon loc tc
405 | isTcOcc (rdrNameOcc tc)
406 = return (L loc (setRdrNameSpace tc srcDataName))
408 = parseErrorSDoc loc (msg $$ extra)
410 msg = text "Not a data constructor:" <+> quotes (ppr tc)
411 extra | tc == forall_tv_RDR
412 = text "Perhaps you intended to use -XExistentialQuantification"
415 ----------------------------------------------------------------------------
416 -- Various Syntactic Checks
418 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
419 checkInstType (L l t)
421 HsForAllTy exp tvs ctxt ty -> do
422 dict_ty <- checkDictTy ty
423 return (L l (HsForAllTy exp tvs ctxt dict_ty))
425 HsParTy ty -> checkInstType ty
427 ty -> do dict_ty <- checkDictTy (L l ty)
428 return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
430 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
431 checkDictTy (L spn ty) = check ty []
433 check (HsTyVar t) args | not (isRdrTyVar t)
434 = return (L spn (HsPredTy (HsClassP t args)))
435 check (HsAppTy l r) args = check (unLoc l) (r:args)
436 check (HsParTy t) args = check (unLoc t) args
437 check _ _ = parseError spn "Malformed instance header"
439 -- Check whether the given list of type parameters are all type variables
440 -- (possibly with a kind signature). If the second argument is `False',
441 -- only type variables are allowed and we raise an error on encountering a
442 -- non-variable; otherwise, we allow non-variable arguments and return the
443 -- entire list of parameters.
445 checkTyVars :: [LHsType RdrName] -> P ()
446 checkTyVars tparms = mapM_ chk tparms
448 -- Check that the name space is correct!
449 chk (L _ (HsKindSig (L _ (HsTyVar tv)) _))
450 | isRdrTyVar tv = return ()
451 chk (L _ (HsTyVar tv))
452 | isRdrTyVar tv = return ()
454 parseError l "Type found where type variable expected"
456 -- Check whether the type arguments in a type synonym head are simply
457 -- variables. If not, we have a type family instance and return all patterns.
458 -- If yes, we return 'Nothing' as the third component to indicate a vanilla
461 checkSynHdr :: LHsType RdrName
462 -> Bool -- is type instance?
463 -> P (Located RdrName, -- head symbol
464 [LHsTyVarBndr RdrName], -- parameters
465 [LHsType RdrName]) -- type patterns
466 checkSynHdr ty isTyInst =
467 do { (_, tc, tvs, tparms) <- checkTyClHdr (noLoc []) ty
468 ; unless isTyInst $ checkTyVars tparms
469 ; return (tc, tvs, tparms) }
472 -- Well-formedness check and decomposition of type and class heads.
474 checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
475 -> P (LHsContext RdrName, -- the type context
476 Located RdrName, -- the head symbol (type or class name)
477 [LHsTyVarBndr RdrName], -- free variables of the non-context part
478 [LHsType RdrName]) -- parameters of head symbol
479 -- The header of a type or class decl should look like
480 -- (C a, D b) => T a b
484 -- With associated types, we can also have non-variable parameters; ie,
487 -- The unaltered parameter list is returned in the fourth component of the
491 -- ('()', 'T', ['a'], ['Int', '[a]'])
492 checkTyClHdr (L l cxt) ty
493 = do (tc, tvs, parms) <- gol ty []
495 return (L l cxt, tc, tvs, parms)
497 gol (L l ty) acc = go l ty acc
499 go l (HsTyVar tc) acc
500 | isRdrTc tc = do tvs <- extractTyVars acc
501 return (L l tc, tvs, acc)
502 go _ (HsOpTy t1 ltc@(L _ tc) t2) acc
503 | isRdrTc tc = do tvs <- extractTyVars (t1:t2:acc)
504 return (ltc, tvs, t1:t2:acc)
505 go _ (HsParTy ty) acc = gol ty acc
506 go _ (HsAppTy t1 t2) acc = gol t1 (t2:acc)
508 parseError l "Malformed head of type or class declaration"
510 -- The predicates in a type or class decl must be class predicates or
511 -- equational constraints. They need not all have variable-only
512 -- arguments, even in Haskell 98.
513 -- E.g. class (Monad m, Monad (t m)) => MonadT t m
514 chk_pred (L _ (HsClassP _ _)) = return ()
515 chk_pred (L _ (HsEqualP _ _)) = return ()
517 = parseError l "Malformed context in type or class declaration"
519 -- Extract the type variables of a list of type parameters.
521 -- * Type arguments can be complex type terms (needed for associated type
524 extractTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
525 extractTyVars tvs = collects tvs []
527 -- Collect all variables (2nd arg serves as an accumulator)
528 collect :: LHsType RdrName -> [LHsTyVarBndr RdrName]
529 -> P [LHsTyVarBndr RdrName]
530 collect (L l (HsForAllTy _ _ _ _)) =
531 const $ parseError l "Forall type not allowed as type parameter"
532 collect (L l (HsTyVar tv))
533 | isRdrTyVar tv = return . (L l (UserTyVar tv) :)
535 collect (L l (HsBangTy _ _ )) =
536 const $ parseError l "Bang-style type annotations not allowed as type parameter"
537 collect (L _ (HsAppTy t1 t2 )) = collect t2 >=> collect t1
538 collect (L _ (HsFunTy t1 t2 )) = collect t2 >=> collect t1
539 collect (L _ (HsListTy t )) = collect t
540 collect (L _ (HsPArrTy t )) = collect t
541 collect (L _ (HsTupleTy _ ts )) = collects ts
542 collect (L _ (HsOpTy t1 _ t2 )) = collect t2 >=> collect t1
543 collect (L _ (HsParTy t )) = collect t
544 collect (L _ (HsNumTy _ )) = return
545 collect (L l (HsPredTy _ )) =
546 const $ parseError l "Predicate not allowed as type parameter"
547 collect (L l (HsKindSig (L _ ty) k))
548 | HsTyVar tv <- ty, isRdrTyVar tv
549 = return . (L l (KindedTyVar tv k) :)
551 = const $ parseError l "Kind signature only allowed for type variables"
552 collect (L l (HsSpliceTy _ )) =
553 const $ parseError l "Splice not allowed as type parameter"
554 collect (L _ (HsDocTy t _ )) = collect t
556 -- Collect all variables of a list of types
558 collects (t:ts) = collects ts >=> collect t
560 (f >=> g) x = f x >>= g
562 -- Check that associated type declarations of a class are all kind signatures.
564 checkKindSigs :: [LTyClDecl RdrName] -> P ()
565 checkKindSigs = mapM_ check
568 | isFamilyDecl tydecl
569 || isSynDecl tydecl = return ()
571 parseError l "Type declaration in a class must be a kind signature or synonym default"
573 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
577 check (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
578 = do ctx <- mapM checkPred ts
581 check (HsParTy ty) -- to be sure HsParTy doesn't get into the way
584 check (HsTyVar t) -- Empty context shows up as a unit type ()
585 | t == getRdrName unitTyCon = return (L l [])
588 = do p <- checkPred (L l t)
592 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
593 -- Watch out.. in ...deriving( Show )... we use checkPred on
594 -- the list of partially applied predicates in the deriving,
595 -- so there can be zero args.
596 checkPred (L spn (HsPredTy (HsIParam n ty)))
597 = return (L spn (HsIParam n ty))
601 checkl (L l ty) args = check l ty args
603 check _loc (HsPredTy pred@(HsEqualP _ _))
605 = return $ L spn pred
606 check _loc (HsTyVar t) args | not (isRdrTyVar t)
607 = return (L spn (HsClassP t args))
608 check _loc (HsAppTy l r) args = checkl l (r:args)
609 check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
610 check _loc (HsParTy t) args = checkl t args
611 check loc _ _ = parseError loc
612 "malformed class assertion"
614 ---------------------------------------------------------------------------
615 -- Checking stand-alone deriving declarations
617 checkDerivDecl :: LDerivDecl RdrName -> P (LDerivDecl RdrName)
618 checkDerivDecl d@(L loc _) =
619 do stDerivOn <- extension standaloneDerivingEnabled
620 if stDerivOn then return d
621 else parseError loc "Illegal stand-alone deriving declaration (use -XStandaloneDeriving)"
623 ---------------------------------------------------------------------------
624 -- Checking statements in a do-expression
625 -- We parse do { e1 ; e2 ; }
626 -- as [ExprStmt e1, ExprStmt e2]
627 -- checkDo (a) checks that the last thing is an ExprStmt
628 -- (b) returns it separately
629 -- same comments apply for mdo as well
631 checkDo, checkMDo :: SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
633 checkDo = checkDoMDo "a " "'do'"
634 checkMDo = checkDoMDo "an " "'mdo'"
636 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
637 checkDoMDo _ nm loc [] = parseError loc ("Empty " ++ nm ++ " construct")
638 checkDoMDo pre nm _ ss = do
641 check [] = panic "RdrHsSyn:checkDoMDo"
642 check [L _ (ExprStmt e _ _)] = return ([], e)
643 check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
644 " construct must be an expression")
649 -- -------------------------------------------------------------------------
650 -- Checking Patterns.
652 -- We parse patterns as expressions and check for valid patterns below,
653 -- converting the expression into a pattern at the same time.
655 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
656 checkPattern e = checkLPat e
658 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
659 checkPatterns es = mapM checkPattern es
661 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
662 checkLPat e@(L l _) = checkPat l e []
664 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
665 checkPat loc (L l (HsVar c)) args
666 | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
667 checkPat loc e args -- OK to let this happen even if bang-patterns
668 -- are not enabled, because there is no valid
669 -- non-bang-pattern parse of (C ! e)
670 | Just (e', args') <- splitBang e
671 = do { args'' <- checkPatterns args'
672 ; checkPat loc e' (args'' ++ args) }
673 checkPat loc (L _ (HsApp f x)) args
674 = do { x <- checkLPat x; checkPat loc f (x:args) }
675 checkPat loc (L _ e) []
676 = do { p <- checkAPat loc e; return (L loc p) }
680 checkAPat :: SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
681 checkAPat loc e = case e of
682 EWildPat -> return (WildPat placeHolderType)
683 HsVar x | isQual x -> parseError loc ("Qualified variable in pattern: "
685 | otherwise -> return (VarPat x)
686 HsLit l -> return (LitPat l)
688 -- Overloaded numeric patterns (e.g. f 0 x = x)
689 -- Negation is recorded separately, so that the literal is zero or +ve
690 -- NB. Negative *primitive* literals are already handled by the lexer
691 HsOverLit pos_lit -> return (mkNPat pos_lit Nothing)
692 NegApp (L _ (HsOverLit pos_lit)) _
693 -> return (mkNPat pos_lit (Just noSyntaxExpr))
695 SectionR (L _ (HsVar bang)) e -- (! x)
697 -> do { bang_on <- extension bangPatEnabled
698 ; if bang_on then checkLPat e >>= (return . BangPat)
699 else parseError loc "Illegal bang-pattern (use -XBangPatterns)" }
701 ELazyPat e -> checkLPat e >>= (return . LazyPat)
702 EAsPat n e -> checkLPat e >>= (return . AsPat n)
703 -- view pattern is well-formed if the pattern is
704 EViewPat expr patE -> checkLPat patE >>= (return . (\p -> ViewPat expr p placeHolderType))
705 ExprWithTySig e t -> do e <- checkLPat e
706 -- Pattern signatures are parsed as sigtypes,
707 -- but they aren't explicit forall points. Hence
708 -- we have to remove the implicit forall here.
710 L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
712 return (SigPatIn e t')
715 OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
716 (L _ (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
718 -> return (mkNPlusKPat (L nloc n) lit)
720 OpApp l op _fix r -> do l <- checkLPat l
723 L cl (HsVar c) | isDataOcc (rdrNameOcc c)
724 -> return (ConPatIn (L cl c) (InfixCon l r))
727 HsPar e -> checkLPat e >>= (return . ParPat)
728 ExplicitList _ es -> do ps <- mapM checkLPat es
729 return (ListPat ps placeHolderType)
730 ExplicitPArr _ es -> do ps <- mapM checkLPat es
731 return (PArrPat ps placeHolderType)
733 ExplicitTuple es b -> do ps <- mapM checkLPat es
734 return (TuplePat ps b placeHolderType)
736 RecordCon c _ (HsRecFields fs dd)
737 -> do fs <- mapM checkPatField fs
738 return (ConPatIn c (RecCon (HsRecFields fs dd)))
739 HsQuasiQuoteE q -> return (QuasiQuotePat q)
741 HsType ty -> return (TypePat ty)
744 plus_RDR, bang_RDR :: RdrName
745 plus_RDR = mkUnqual varName (fsLit "+") -- Hack
746 bang_RDR = mkUnqual varName (fsLit "!") -- Hack
748 checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
749 checkPatField fld = do { p <- checkLPat (hsRecFieldArg fld)
750 ; return (fld { hsRecFieldArg = p }) }
752 patFail :: SrcSpan -> P a
753 patFail loc = parseError loc "Parse error in pattern"
756 ---------------------------------------------------------------------------
757 -- Check Equation Syntax
759 checkValDef :: LHsExpr RdrName
760 -> Maybe (LHsType RdrName)
761 -> Located (GRHSs RdrName)
762 -> P (HsBind RdrName)
764 checkValDef lhs (Just sig) grhss
765 -- x :: ty = rhs parses as a *pattern* binding
766 = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
768 checkValDef lhs opt_sig grhss
769 = do { mb_fun <- isFunLhs lhs
771 Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
772 fun is_infix pats opt_sig grhss
773 Nothing -> checkPatBind lhs grhss }
775 checkFunBind :: SrcSpan
779 -> Maybe (LHsType RdrName)
780 -> Located (GRHSs RdrName)
781 -> P (HsBind RdrName)
782 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
784 = parseErrorSDoc (getLoc fun)
785 (ptext (sLit "Qualified name in function definition:") <+> ppr (unLoc fun))
787 = do ps <- checkPatterns pats
788 let match_span = combineSrcSpans lhs_loc rhs_span
789 return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
790 -- The span of the match covers the entire equation.
791 -- That isn't quite right, but it'll do for now.
793 makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
794 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
795 makeFunBind fn is_infix ms
796 = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
797 fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
799 checkPatBind :: LHsExpr RdrName
800 -> Located (GRHSs RdrName)
801 -> P (HsBind RdrName)
802 checkPatBind lhs (L _ grhss)
803 = do { lhs <- checkPattern lhs
804 ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
810 checkValSig (L l (HsVar v)) ty
811 | isUnqual v && not (isDataOcc (rdrNameOcc v))
812 = return (TypeSig (L l v) ty)
813 checkValSig (L l _) _
814 = parseError l "Invalid type signature"
816 mkGadtDecl :: [Located RdrName]
817 -> LHsType RdrName -- assuming HsType
819 -- We allow C,D :: ty
820 -- and expand it as if it had been
822 -- (Just like type signatures in general.)
824 = [mk_gadt_con name qvars cxt tau | name <- names]
826 (qvars,cxt,tau) = case ty of
827 L _ (HsForAllTy _ qvars cxt tau) -> (qvars, cxt, tau)
828 _ -> ([], noLoc [], ty)
830 mk_gadt_con :: Located RdrName
831 -> [LHsTyVarBndr RdrName]
832 -> LHsContext RdrName
835 mk_gadt_con name qvars cxt ty
836 = ConDecl { con_name = name
837 , con_explicit = Implicit
840 , con_details = PrefixCon []
841 , con_res = ResTyGADT ty
842 , con_doc = Nothing }
843 -- NB: we put the whole constr type into the ResTyGADT for now;
844 -- the renamer will unravel it once it has sorted out
847 -- A variable binding is parsed as a FunBind.
850 -- The parser left-associates, so there should
851 -- not be any OpApps inside the e's
852 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
853 -- Splits (f ! g a b) into (f, [(! g), a, b])
854 splitBang (L loc (OpApp l_arg bang@(L _ (HsVar op)) _ r_arg))
855 | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
857 (arg1,argns) = split_bang r_arg []
858 split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
859 split_bang e es = (e,es)
860 splitBang _ = Nothing
862 isFunLhs :: LHsExpr RdrName
863 -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
864 -- Just (fun, is_infix, arg_pats) if e is a function LHS
866 -- The whole LHS is parsed as a single expression.
867 -- Any infix operators on the LHS will parse left-associatively
869 -- will parse (rather strangely) as
871 -- It's up to isFunLhs to sort out the mess
877 go (L loc (HsVar f)) es
878 | not (isRdrDataCon f) = return (Just (L loc f, False, es))
879 go (L _ (HsApp f e)) es = go f (e:es)
880 go (L _ (HsPar e)) es@(_:_) = go e es
882 -- For infix function defns, there should be only one infix *function*
883 -- (though there may be infix *datacons* involved too). So we don't
884 -- need fixity info to figure out which function is being defined.
885 -- a `K1` b `op` c `K2` d
887 -- (a `K1` b) `op` (c `K2` d)
888 -- The renamer checks later that the precedences would yield such a parse.
890 -- There is a complication to deal with bang patterns.
892 -- ToDo: what about this?
893 -- x + 1 `op` y = ...
895 go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
896 | Just (e',es') <- splitBang e
897 = do { bang_on <- extension bangPatEnabled
898 ; if bang_on then go e' (es' ++ es)
899 else return (Just (L loc' op, True, (l:r:es))) }
900 -- No bangs; behave just like the next case
901 | not (isRdrDataCon op) -- We have found the function!
902 = return (Just (L loc' op, True, (l:r:es)))
903 | otherwise -- Infix data con; keep going
904 = do { mb_l <- go l es
906 Just (op', True, j : k : es')
907 -> return (Just (op', True, j : op_app : es'))
909 op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
910 _ -> return Nothing }
911 go _ _ = return Nothing
913 ---------------------------------------------------------------------------
914 -- Miscellaneous utilities
916 checkPrecP :: Located Int -> P Int
918 | 0 <= i && i <= maxPrecedence = return i
919 | otherwise = parseError l "Precedence out of range"
924 -> ([HsRecField RdrName (LHsExpr RdrName)], Bool)
925 -> P (HsExpr RdrName)
927 mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) | isRdrDataCon c
928 = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd))
929 mkRecConstrOrUpdate exp loc (fs,dd)
930 | null fs = parseError loc "Empty record update"
931 | otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] [])
933 mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg
934 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
935 mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
937 mkInlineSpec :: Maybe Activation -> RuleMatchInfo -> Bool -> InlineSpec
938 -- The Maybe is becuase the user can omit the activation spec (and usually does)
939 mkInlineSpec Nothing match_info True = alwaysInlineSpec match_info
941 mkInlineSpec Nothing match_info False = neverInlineSpec match_info
943 mkInlineSpec (Just act) match_info inl = Inline (InlinePragma act match_info) inl
946 -----------------------------------------------------------------------------
947 -- utilities for foreign declarations
949 -- supported calling conventions
951 data CallConv = CCall CCallConv -- ccall or stdcall
954 -- construct a foreign import declaration
958 -> (Located FastString, Located RdrName, LHsType RdrName)
959 -> P (HsDecl RdrName)
960 mkImport (CCall cconv) safety (entity, v, ty) = do
961 importSpec <- parseCImport entity cconv safety v
962 return (ForD (ForeignImport v ty importSpec))
963 mkImport (DNCall ) _ (entity, v, ty) = do
964 spec <- parseDImport entity
965 return $ ForD (ForeignImport v ty (DNImport spec))
967 -- parse the entity string of a foreign import declaration for the `ccall' or
968 -- `stdcall' calling convention'
970 parseCImport :: Located FastString
975 parseCImport (L loc entity) cconv safety v
976 -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
977 | entity == fsLit "dynamic" =
978 return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
979 | entity == fsLit "wrapper" =
980 return $ CImport cconv safety nilFS nilFS CWrapper
981 | otherwise = parse0 (unpackFS entity)
983 -- using the static keyword?
984 parse0 (' ': rest) = parse0 rest
985 parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
986 parse0 rest = parse1 rest
987 -- check for header file name
988 parse1 "" = parse4 "" nilFS False nilFS
989 parse1 (' ':rest) = parse1 rest
990 parse1 str@('&':_ ) = parse2 str nilFS
991 parse1 str@('[':_ ) = parse3 str nilFS False
993 | ".h" `isSuffixOf` first = parse2 rest (mkFastString first)
994 | otherwise = parse4 str nilFS False nilFS
996 (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
997 -- check for address operator (indicating a label import)
998 parse2 "" header = parse4 "" header False nilFS
999 parse2 (' ':rest) header = parse2 rest header
1000 parse2 ('&':rest) header = parse3 rest header True
1001 parse2 str@('[':_ ) header = parse3 str header False
1002 parse2 str header = parse4 str header False nilFS
1003 -- check for library object name
1004 parse3 (' ':rest) header isLbl = parse3 rest header isLbl
1005 parse3 ('[':rest) header isLbl =
1006 case break (== ']') rest of
1007 (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib)
1008 _ -> parseError loc "Missing ']' in entity"
1009 parse3 str header isLbl = parse4 str header isLbl nilFS
1010 -- check for name of C function
1011 parse4 "" header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
1012 parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib
1013 parse4 str header isLbl lib
1014 | all (== ' ') rest = build (mkFastString first) header isLbl lib
1015 | otherwise = parseError loc "Malformed entity string"
1017 (first, rest) = break (== ' ') str
1019 build cid header False lib = return $
1020 CImport cconv safety header lib (CFunction (StaticTarget cid))
1021 build cid header True lib = return $
1022 CImport cconv safety header lib (CLabel cid )
1025 -- Unravel a dotnet spec string.
1027 parseDImport :: Located FastString -> P DNCallSpec
1028 parseDImport (L loc entity) = parse0 comps
1030 comps = words (unpackFS entity)
1034 | x == "static" = parse1 True xs
1035 | otherwise = parse1 False (x:xs)
1038 parse1 isStatic (x:xs)
1039 | x == "method" = parse2 isStatic DNMethod xs
1040 | x == "field" = parse2 isStatic DNField xs
1041 | x == "ctor" = parse2 isStatic DNConstructor xs
1042 parse1 isStatic xs = parse2 isStatic DNMethod xs
1044 parse2 _ _ [] = d'oh
1045 parse2 isStatic kind (('[':x):xs) =
1048 vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
1050 parse2 isStatic kind xs = parse3 isStatic kind "" xs
1052 parse3 isStatic kind assem [x] =
1053 return (DNCallSpec isStatic kind assem x
1054 -- these will be filled in once known.
1055 (error "FFI-dotnet-args")
1056 (error "FFI-dotnet-result"))
1057 parse3 _ _ _ _ = d'oh
1059 d'oh = parseError loc "Malformed entity string"
1061 -- construct a foreign export declaration
1063 mkExport :: CallConv
1064 -> (Located FastString, Located RdrName, LHsType RdrName)
1065 -> P (HsDecl RdrName)
1066 mkExport (CCall cconv) (L _ entity, v, ty) = return $
1067 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
1069 entity' | nullFS entity = mkExtName (unLoc v)
1070 | otherwise = entity
1071 mkExport DNCall (L _ _, v, _) =
1072 parseError (getLoc v){-TODO: not quite right-}
1073 "Foreign export is not yet supported for .NET"
1075 -- Supplying the ext_name in a foreign decl is optional; if it
1076 -- isn't there, the Haskell name is assumed. Note that no transformation
1077 -- of the Haskell name is then performed, so if you foreign export (++),
1078 -- it's external name will be "++". Too bad; it's important because we don't
1079 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
1081 mkExtName :: RdrName -> CLabelString
1082 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
1086 -----------------------------------------------------------------------------
1090 parseError :: SrcSpan -> String -> P a
1091 parseError span s = parseErrorSDoc span (text s)
1093 parseErrorSDoc :: SrcSpan -> SDoc -> P a
1094 parseErrorSDoc span s = failSpanMsgP span s