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 mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = mk_gadt_con name qvars cxt ty
820 mkGadtDecl name ty = mk_gadt_con name [] (noLoc []) ty
822 mk_gadt_con :: Located RdrName
823 -> [LHsTyVarBndr RdrName]
824 -> LHsContext RdrName
827 mk_gadt_con name qvars cxt ty
828 = ConDecl { con_name = name
829 , con_explicit = Implicit
832 , con_details = PrefixCon []
833 , con_res = ResTyGADT ty
834 , con_doc = Nothing }
835 -- NB: we put the whole constr type into the ResTyGADT for now;
836 -- the renamer will unravel it once it has sorted out
839 -- A variable binding is parsed as a FunBind.
842 -- The parser left-associates, so there should
843 -- not be any OpApps inside the e's
844 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
845 -- Splits (f ! g a b) into (f, [(! g), a, b])
846 splitBang (L loc (OpApp l_arg bang@(L _ (HsVar op)) _ r_arg))
847 | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
849 (arg1,argns) = split_bang r_arg []
850 split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
851 split_bang e es = (e,es)
852 splitBang _ = Nothing
854 isFunLhs :: LHsExpr RdrName
855 -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
856 -- Just (fun, is_infix, arg_pats) if e is a function LHS
858 -- The whole LHS is parsed as a single expression.
859 -- Any infix operators on the LHS will parse left-associatively
861 -- will parse (rather strangely) as
863 -- It's up to isFunLhs to sort out the mess
869 go (L loc (HsVar f)) es
870 | not (isRdrDataCon f) = return (Just (L loc f, False, es))
871 go (L _ (HsApp f e)) es = go f (e:es)
872 go (L _ (HsPar e)) es@(_:_) = go e es
874 -- For infix function defns, there should be only one infix *function*
875 -- (though there may be infix *datacons* involved too). So we don't
876 -- need fixity info to figure out which function is being defined.
877 -- a `K1` b `op` c `K2` d
879 -- (a `K1` b) `op` (c `K2` d)
880 -- The renamer checks later that the precedences would yield such a parse.
882 -- There is a complication to deal with bang patterns.
884 -- ToDo: what about this?
885 -- x + 1 `op` y = ...
887 go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
888 | Just (e',es') <- splitBang e
889 = do { bang_on <- extension bangPatEnabled
890 ; if bang_on then go e' (es' ++ es)
891 else return (Just (L loc' op, True, (l:r:es))) }
892 -- No bangs; behave just like the next case
893 | not (isRdrDataCon op) -- We have found the function!
894 = return (Just (L loc' op, True, (l:r:es)))
895 | otherwise -- Infix data con; keep going
896 = do { mb_l <- go l es
898 Just (op', True, j : k : es')
899 -> return (Just (op', True, j : op_app : es'))
901 op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
902 _ -> return Nothing }
903 go _ _ = return Nothing
905 ---------------------------------------------------------------------------
906 -- Miscellaneous utilities
908 checkPrecP :: Located Int -> P Int
910 | 0 <= i && i <= maxPrecedence = return i
911 | otherwise = parseError l "Precedence out of range"
916 -> ([HsRecField RdrName (LHsExpr RdrName)], Bool)
917 -> P (HsExpr RdrName)
919 mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) | isRdrDataCon c
920 = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd))
921 mkRecConstrOrUpdate exp loc (fs,dd)
922 | null fs = parseError loc "Empty record update"
923 | otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] [])
925 mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg
926 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
927 mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
929 mkInlineSpec :: Maybe Activation -> RuleMatchInfo -> Bool -> InlineSpec
930 -- The Maybe is becuase the user can omit the activation spec (and usually does)
931 mkInlineSpec Nothing match_info True = alwaysInlineSpec match_info
933 mkInlineSpec Nothing match_info False = neverInlineSpec match_info
935 mkInlineSpec (Just act) match_info inl = Inline (InlinePragma act match_info) inl
938 -----------------------------------------------------------------------------
939 -- utilities for foreign declarations
941 -- supported calling conventions
943 data CallConv = CCall CCallConv -- ccall or stdcall
946 -- construct a foreign import declaration
950 -> (Located FastString, Located RdrName, LHsType RdrName)
951 -> P (HsDecl RdrName)
952 mkImport (CCall cconv) safety (entity, v, ty) = do
953 importSpec <- parseCImport entity cconv safety v
954 return (ForD (ForeignImport v ty importSpec))
955 mkImport (DNCall ) _ (entity, v, ty) = do
956 spec <- parseDImport entity
957 return $ ForD (ForeignImport v ty (DNImport spec))
959 -- parse the entity string of a foreign import declaration for the `ccall' or
960 -- `stdcall' calling convention'
962 parseCImport :: Located FastString
967 parseCImport (L loc entity) cconv safety v
968 -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
969 | entity == fsLit "dynamic" =
970 return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
971 | entity == fsLit "wrapper" =
972 return $ CImport cconv safety nilFS nilFS CWrapper
973 | otherwise = parse0 (unpackFS entity)
975 -- using the static keyword?
976 parse0 (' ': rest) = parse0 rest
977 parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
978 parse0 rest = parse1 rest
979 -- check for header file name
980 parse1 "" = parse4 "" nilFS False nilFS
981 parse1 (' ':rest) = parse1 rest
982 parse1 str@('&':_ ) = parse2 str nilFS
983 parse1 str@('[':_ ) = parse3 str nilFS False
985 | ".h" `isSuffixOf` first = parse2 rest (mkFastString first)
986 | otherwise = parse4 str nilFS False nilFS
988 (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
989 -- check for address operator (indicating a label import)
990 parse2 "" header = parse4 "" header False nilFS
991 parse2 (' ':rest) header = parse2 rest header
992 parse2 ('&':rest) header = parse3 rest header True
993 parse2 str@('[':_ ) header = parse3 str header False
994 parse2 str header = parse4 str header False nilFS
995 -- check for library object name
996 parse3 (' ':rest) header isLbl = parse3 rest header isLbl
997 parse3 ('[':rest) header isLbl =
998 case break (== ']') rest of
999 (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib)
1000 _ -> parseError loc "Missing ']' in entity"
1001 parse3 str header isLbl = parse4 str header isLbl nilFS
1002 -- check for name of C function
1003 parse4 "" header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
1004 parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib
1005 parse4 str header isLbl lib
1006 | all (== ' ') rest = build (mkFastString first) header isLbl lib
1007 | otherwise = parseError loc "Malformed entity string"
1009 (first, rest) = break (== ' ') str
1011 build cid header False lib = return $
1012 CImport cconv safety header lib (CFunction (StaticTarget cid))
1013 build cid header True lib = return $
1014 CImport cconv safety header lib (CLabel cid )
1017 -- Unravel a dotnet spec string.
1019 parseDImport :: Located FastString -> P DNCallSpec
1020 parseDImport (L loc entity) = parse0 comps
1022 comps = words (unpackFS entity)
1026 | x == "static" = parse1 True xs
1027 | otherwise = parse1 False (x:xs)
1030 parse1 isStatic (x:xs)
1031 | x == "method" = parse2 isStatic DNMethod xs
1032 | x == "field" = parse2 isStatic DNField xs
1033 | x == "ctor" = parse2 isStatic DNConstructor xs
1034 parse1 isStatic xs = parse2 isStatic DNMethod xs
1036 parse2 _ _ [] = d'oh
1037 parse2 isStatic kind (('[':x):xs) =
1040 vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
1042 parse2 isStatic kind xs = parse3 isStatic kind "" xs
1044 parse3 isStatic kind assem [x] =
1045 return (DNCallSpec isStatic kind assem x
1046 -- these will be filled in once known.
1047 (error "FFI-dotnet-args")
1048 (error "FFI-dotnet-result"))
1049 parse3 _ _ _ _ = d'oh
1051 d'oh = parseError loc "Malformed entity string"
1053 -- construct a foreign export declaration
1055 mkExport :: CallConv
1056 -> (Located FastString, Located RdrName, LHsType RdrName)
1057 -> P (HsDecl RdrName)
1058 mkExport (CCall cconv) (L _ entity, v, ty) = return $
1059 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
1061 entity' | nullFS entity = mkExtName (unLoc v)
1062 | otherwise = entity
1063 mkExport DNCall (L _ _, v, _) =
1064 parseError (getLoc v){-TODO: not quite right-}
1065 "Foreign export is not yet supported for .NET"
1067 -- Supplying the ext_name in a foreign decl is optional; if it
1068 -- isn't there, the Haskell name is assumed. Note that no transformation
1069 -- of the Haskell name is then performed, so if you foreign export (++),
1070 -- it's external name will be "++". Too bad; it's important because we don't
1071 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
1073 mkExtName :: RdrName -> CLabelString
1074 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
1078 -----------------------------------------------------------------------------
1082 parseError :: SrcSpan -> String -> P a
1083 parseError span s = parseErrorSDoc span (text s)
1085 parseErrorSDoc :: SrcSpan -> SDoc -> P a
1086 parseErrorSDoc span s = failSpanMsgP span s