2 % (c) The University of Glasgow, 1996-2003
4 Functions over HsSyn specialised to RdrName.
9 extractHsRhoRdrTyVars, extractGenericPatTyVars,
11 mkHsOpApp, mkClassDecl,
12 mkHsNegApp, mkHsIntegral, mkHsFractional,
14 mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec,
15 mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
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 -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName])
39 checkTyVars, -- [LHsType RdrName] -> P ()
40 checkSynHdr, -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName])
41 checkKindSigs, -- [LTyClDecl RdrName] -> P ()
42 checkInstType, -- HsType -> P HsType
43 checkDerivDecl, -- LDerivDecl RdrName -> P (LDerivDecl RdrName)
44 checkPattern, -- HsExp -> P HsPat
46 checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat]
47 checkDo, -- [Stmt] -> P [Stmt]
48 checkMDo, -- [Stmt] -> P [Stmt]
49 checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
50 checkValSig, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
51 parseError, -- String -> Pa
54 #include "HsVersions.h"
56 import HsSyn -- Lots of it
57 import RdrName ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc,
58 isRdrDataCon, isUnqual, getRdrName, isQual,
60 import BasicTypes ( maxPrecedence, Activation, InlineSpec(..), alwaysInlineSpec, neverInlineSpec )
61 import Lexer ( P, failSpanMsgP, extension, glaExtsEnabled, bangPatEnabled )
62 import TysWiredIn ( unitTyCon )
63 import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
64 DNCallSpec(..), DNKind(..), CLabelString )
65 import OccName ( srcDataName, varName, isDataOcc, isTcOcc,
68 import OrdList ( OrdList, fromOL )
69 import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag )
74 import List ( isSuffixOf, nubBy )
75 import Monad ( unless )
79 %************************************************************************
81 \subsection{A few functions over HsSyn at RdrName}
83 %************************************************************************
85 extractHsTyRdrNames finds the free variables of a HsType
86 It's used when making the for-alls explicit.
89 extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName]
90 extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty [])
92 extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName]
93 -- This one takes the context and tau-part of a
94 -- sigma type and returns their free type variables
95 extractHsRhoRdrTyVars ctxt ty
96 = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty [])
98 extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt)
100 extract_pred (HsClassP cls tys) acc = foldr extract_lty acc tys
101 extract_pred (HsIParam n ty) acc = extract_lty ty acc
103 extract_lty (L loc ty) acc
105 HsTyVar tv -> extract_tv loc tv acc
106 HsBangTy _ ty -> extract_lty ty acc
107 HsAppTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
108 HsListTy ty -> extract_lty ty acc
109 HsPArrTy ty -> extract_lty ty acc
110 HsTupleTy _ tys -> foldr extract_lty acc tys
111 HsFunTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
112 HsPredTy p -> extract_pred p acc
113 HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
114 HsParTy ty -> extract_lty ty acc
116 HsSpliceTy _ -> acc -- Type splices mention no type variables
117 HsKindSig ty k -> extract_lty ty acc
118 HsForAllTy exp [] cx ty -> extract_lctxt cx (extract_lty ty acc)
119 HsForAllTy exp tvs cx ty -> acc ++ (filter ((`notElem` locals) . unLoc) $
120 extract_lctxt cx (extract_lty ty []))
122 locals = hsLTyVarNames tvs
123 HsDocTy ty doc -> extract_lty ty acc
125 extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName]
126 extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc
129 extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName]
130 -- Get the type variables out of the type patterns in a bunch of
131 -- possibly-generic bindings in a class declaration
132 extractGenericPatTyVars binds
133 = nubBy eqLocated (foldrBag get [] binds)
135 get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms
138 get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
139 get_m other acc = acc
143 %************************************************************************
145 \subsection{Construction functions for Rdr stuff}
147 %************************************************************************
149 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
150 by deriving them from the name of the class. We fill in the names for the
151 tycon and datacon corresponding to the class, by deriving them from the
152 name of the class itself. This saves recording the names in the interface
153 file (which would be equally good).
155 Similarly for mkConDecl, mkClassOpSig and default-method names.
157 *** See "THE NAMING STORY" in HsDecls ****
160 mkClassDecl (cxt, cname, tyvars) fds sigs mbinds ats docs
161 = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
169 mkTyData new_or_data (context, tname, tyvars, typats) ksig data_cons maybe_deriv
170 = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
171 tcdTyVars = tyvars, tcdTyPats = typats, tcdCons = data_cons,
172 tcdKindSig = ksig, tcdDerivs = maybe_deriv }
176 mkHsNegApp :: LHsExpr RdrName -> HsExpr RdrName
177 -- RdrName If the type checker sees (negate 3#) it will barf, because negate
178 -- can't take an unboxed arg. But that is exactly what it will see when
179 -- we write "-3#". So we have to do the negation right now!
180 mkHsNegApp (L loc e) = f e
181 where f (HsLit (HsIntPrim i)) = HsLit (HsIntPrim (-i))
182 f (HsLit (HsFloatPrim i)) = HsLit (HsFloatPrim (-i))
183 f (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i))
184 f expr = NegApp (L loc e) noSyntaxExpr
187 %************************************************************************
189 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
191 %************************************************************************
193 Function definitions are restructured here. Each is assumed to be recursive
194 initially, and non recursive definitions are discovered by the dependency
199 -- | Groups together bindings for a single function
200 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
201 cvTopDecls decls = go (fromOL decls)
203 go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
205 go (L l (ValD b) : ds) = L l' (ValD b') : go ds'
206 where (L l' b', ds') = getMonoBind (L l b) ds
207 go (d : ds) = d : go ds
209 -- Declaration list may only contain value bindings and signatures.
210 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
212 = case cvBindsAndSigs binding of
213 (mbs, sigs, [], _) -> -- list of type decls *always* empty
216 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
217 -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [DocEntity RdrName])
218 -- Input decls contain just value bindings and signatures
219 -- and in case of class or instance declarations also
220 -- associated type declarations. They might also contain Haddock comments.
221 cvBindsAndSigs fb = go (fromOL fb)
223 go [] = (emptyBag, [], [], [])
224 go (L l x@(SigD s) : ds) = (bs, L l s : ss, ts, add_doc x docs)
225 where (bs, ss, ts, docs) = go ds
226 go (L l x@(ValD b) : ds) = (b' `consBag` bs, ss, ts, add_doc x docs)
227 where (b', ds') = getMonoBind (L l b) ds
228 (bs, ss, ts, docs) = go ds'
229 go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs)
230 where (bs, ss, ts, docs) = go ds
231 go (L _ (DocD d) : ds) = (bs, ss, ts, DocEntity d : docs)
232 where (bs, ss, ts, docs) = go ds
234 -----------------------------------------------------------------------------
235 -- Group function bindings into equation groups
237 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
238 -> (LHsBind RdrName, [LHsDecl RdrName])
239 -- Suppose (b',ds') = getMonoBind b ds
240 -- ds is a list of parsed bindings
241 -- b is a MonoBinds that has just been read off the front
243 -- Then b' is the result of grouping more equations from ds that
244 -- belong with b into a single MonoBinds, and ds' is the depleted
245 -- list of parsed bindings.
247 -- All Haddock comments between equations inside the group are
250 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
252 getMonoBind (L loc1 bind@(FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1,
253 fun_matches = MatchGroup mtchs1 _ })) binds
255 = go is_infix1 mtchs1 loc1 binds []
257 go is_infix mtchs loc
258 (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
259 fun_matches = MatchGroup mtchs2 _ })) : binds) _
260 | f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs)
261 (combineSrcSpans loc loc2) binds []
262 go is_infix mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls
263 = let doc_decls' = doc_decl : doc_decls
264 in go is_infix mtchs (combineSrcSpans loc loc2) binds doc_decls'
265 go is_infix mtchs loc binds doc_decls
266 = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), (reverse doc_decls) ++ binds)
267 -- Reverse the final matches, to get it back in the right order
268 -- Do the same thing with the trailing doc comments
270 getMonoBind bind binds = (bind, binds)
272 has_args ((L _ (Match args _ _)) : _) = not (null args)
273 -- Don't group together FunBinds if they have
274 -- no arguments. This is necessary now that variable bindings
275 -- with no arguments are now treated as FunBinds rather
276 -- than pattern bindings (tests/rename/should_fail/rnfail002).
280 findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
281 findSplice ds = addl emptyRdrGroup ds
283 mkGroup :: [LHsDecl a] -> HsGroup a
284 mkGroup ds = addImpDecls emptyRdrGroup ds
286 addImpDecls :: HsGroup a -> [LHsDecl a] -> HsGroup a
287 -- The decls are imported, and should not have a splice
288 addImpDecls group decls = case addl group decls of
289 (group', Nothing) -> group'
290 other -> panic "addImpDecls"
292 addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
293 -- This stuff reverses the declarations (again) but it doesn't matter
296 addl gp [] = (gp, Nothing)
297 addl gp (L l d : ds) = add gp l d ds
300 add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a]
301 -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
303 add gp l (SpliceD e) ds = (gp, Just (e, ds))
305 -- Class declarations: pull out the fixity signatures to the top
306 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs, hs_docs = docs})
309 let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
310 addl (gp { hs_tyclds = L l d : ts,
311 hs_fixds = fsigs ++ fs,
312 hs_docs = add_doc decl docs}) ds
314 addl (gp { hs_tyclds = L l d : ts }) ds
316 addl (gp { hs_tyclds = L l d : ts,
317 hs_docs = add_doc decl docs }) ds
319 -- Signatures: fixity sigs go a different place than all others
320 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
321 = addl (gp {hs_fixds = L l f : ts}) ds
322 add gp@(HsGroup {hs_valds = ts, hs_docs = docs}) l x@(SigD d) ds
323 = addl (gp {hs_valds = add_sig (L l d) ts, hs_docs = add_doc x docs}) ds
325 -- Value declarations: use add_bind
326 add gp@(HsGroup {hs_valds = ts, hs_docs = docs}) l x@(ValD d) ds
327 = addl (gp { hs_valds = add_bind (L l d) ts, hs_docs = add_doc x docs }) ds
329 -- The rest are routine
330 add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds
331 = addl (gp { hs_instds = L l d : ts }) ds
332 add gp@(HsGroup {hs_derivds = ts}) l (DerivD d) ds
333 = addl (gp { hs_derivds = L l d : ts }) ds
334 add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
335 = addl (gp { hs_defds = L l d : ts }) ds
336 add gp@(HsGroup {hs_fords = ts, hs_docs = docs}) l x@(ForD d) ds
337 = addl (gp { hs_fords = L l d : ts, hs_docs = add_doc x docs }) ds
338 add gp@(HsGroup {hs_depds = ts}) l (DeprecD d) ds
339 = addl (gp { hs_depds = L l d : ts }) ds
340 add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
341 = addl (gp { hs_ruleds = L l d : ts }) ds
344 = addl (gp { hs_docs = DocEntity d : (hs_docs gp) }) ds
346 add_doc decl docs = case getMainDeclBinder decl of
347 Just name -> DeclEntity name : docs
350 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
351 add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
354 %************************************************************************
356 \subsection[PrefixToHS-utils]{Utilities for conversion}
358 %************************************************************************
362 -----------------------------------------------------------------------------
365 -- When parsing data declarations, we sometimes inadvertently parse
366 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
367 -- This function splits up the type application, adds any pending
368 -- arguments, and converts the type constructor back into a data constructor.
370 mkPrefixCon :: LHsType RdrName -> [LBangType RdrName]
371 -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
375 split (L _ (HsAppTy t u)) ts = split t (u : ts)
376 split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc
377 return (data_con, PrefixCon ts)
378 split (L l _) _ = parseError l "parse error in data/newtype declaration"
380 mkRecCon :: Located RdrName ->
381 [([Located RdrName], LBangType RdrName, Maybe (LHsDoc RdrName))] ->
382 P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
383 mkRecCon (L loc con) fields
384 = do data_con <- tyConToDataCon loc con
385 return (data_con, RecCon [ (HsRecField l t d) | (ls, t, d) <- fields, l <- ls ])
387 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
388 tyConToDataCon loc tc
389 | isTcOcc (rdrNameOcc tc)
390 = return (L loc (setRdrNameSpace tc srcDataName))
392 = parseError loc (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
394 ----------------------------------------------------------------------------
395 -- Various Syntactic Checks
397 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
398 checkInstType (L l t)
400 HsForAllTy exp tvs ctxt ty -> do
401 dict_ty <- checkDictTy ty
402 return (L l (HsForAllTy exp tvs ctxt dict_ty))
404 HsParTy ty -> checkInstType ty
406 ty -> do dict_ty <- checkDictTy (L l ty)
407 return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
409 -- Check whether the given list of type parameters are all type variables
410 -- (possibly with a kind signature). If the second argument is `False',
411 -- only type variables are allowed and we raise an error on encountering a
412 -- non-variable; otherwise, we allow non-variable arguments and return the
413 -- entire list of parameters.
415 checkTyVars :: [LHsType RdrName] -> P ()
416 checkTyVars tparms = mapM_ chk tparms
418 -- Check that the name space is correct!
419 chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
420 | isRdrTyVar tv = return ()
421 chk (L l (HsTyVar tv))
422 | isRdrTyVar tv = return ()
424 parseError l "Type found where type variable expected"
426 -- Check whether the type arguments in a type synonym head are simply
427 -- variables. If not, we have a type equation of a type function and return
428 -- all patterns. If yes, we return 'Nothing' as the third component to
429 -- indicate a vanilla type synonym.
431 checkSynHdr :: LHsType RdrName
432 -> Bool -- is type instance?
433 -> P (Located RdrName, -- head symbol
434 [LHsTyVarBndr RdrName], -- parameters
435 [LHsType RdrName]) -- type patterns
436 checkSynHdr ty isTyInst =
437 do { (_, tc, tvs, tparms) <- checkTyClHdr (noLoc []) ty
438 ; unless isTyInst $ checkTyVars tparms
439 ; return (tc, tvs, tparms) }
442 -- Well-formedness check and decomposition of type and class heads.
444 checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
445 -> P (LHsContext RdrName, -- the type context
446 Located RdrName, -- the head symbol (type or class name)
447 [LHsTyVarBndr RdrName], -- free variables of the non-context part
448 [LHsType RdrName]) -- parameters of head symbol
449 -- The header of a type or class decl should look like
450 -- (C a, D b) => T a b
454 -- With associated types, we can also have non-variable parameters; ie,
456 -- The unaltered parameter list is returned in the fourth component of the
460 -- ('()', 'T', ['a'], ['Int', '[a]'])
461 checkTyClHdr (L l cxt) ty
462 = do (tc, tvs, parms) <- gol ty []
464 return (L l cxt, tc, tvs, parms)
466 gol (L l ty) acc = go l ty acc
468 go l (HsTyVar tc) acc
469 | not (isRdrTyVar tc) = do
470 tvs <- extractTyVars acc
471 return (L l tc, tvs, acc)
472 go l (HsOpTy t1 tc t2) acc = do
473 tvs <- extractTyVars (t1:t2:acc)
474 return (tc, tvs, acc)
475 go l (HsParTy ty) acc = gol ty acc
476 go l (HsAppTy t1 t2) acc = gol t1 (t2:acc)
478 parseError l "Malformed head of type or class declaration"
480 -- The predicates in a type or class decl must all
481 -- be HsClassPs. They need not all be type variables,
482 -- even in Haskell 98. E.g. class (Monad m, Monad (t m)) => MonadT t m
483 chk_pred (L l (HsClassP _ args)) = return ()
485 = parseError l "Malformed context in type or class declaration"
487 -- Extract the type variables of a list of type parameters.
489 -- * Type arguments can be complex type terms (needed for associated type
492 extractTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
493 extractTyVars tvs = collects [] tvs
495 -- Collect all variables (1st arg serves as an accumulator)
496 collect tvs (L l (HsForAllTy _ _ _ _)) =
497 parseError l "Forall type not allowed as type parameter"
498 collect tvs (L l (HsTyVar tv))
499 | isRdrTyVar tv = return $ L l (UserTyVar tv) : tvs
500 | otherwise = return tvs
501 collect tvs (L l (HsBangTy _ _ )) =
502 parseError l "Bang-style type annotations not allowed as type parameter"
503 collect tvs (L l (HsAppTy t1 t2 )) = do
504 tvs' <- collect tvs t2
506 collect tvs (L l (HsFunTy t1 t2 )) = do
507 tvs' <- collect tvs t2
509 collect tvs (L l (HsListTy t )) = collect tvs t
510 collect tvs (L l (HsPArrTy t )) = collect tvs t
511 collect tvs (L l (HsTupleTy _ ts )) = collects tvs ts
512 collect tvs (L l (HsOpTy t1 _ t2 )) = do
513 tvs' <- collect tvs t2
515 collect tvs (L l (HsParTy t )) = collect tvs t
516 collect tvs (L l (HsNumTy t )) = return tvs
517 collect tvs (L l (HsPredTy t )) =
518 parseError l "Predicate not allowed as type parameter"
519 collect tvs (L l (HsKindSig (L _ (HsTyVar tv)) k))
521 return $ L l (KindedTyVar tv k) : tvs
523 parseError l "Kind signature only allowed for type variables"
524 collect tvs (L l (HsSpliceTy t )) =
525 parseError l "Splice not allowed as type parameter"
527 -- Collect all variables of a list of types
528 collects tvs [] = return tvs
529 collects tvs (t:ts) = do
530 tvs' <- collects tvs ts
533 -- Check that associated type declarations of a class are all kind signatures.
535 checkKindSigs :: [LTyClDecl RdrName] -> P ()
536 checkKindSigs = mapM_ check
539 | isKindSigDecl tydecl
540 || isSynDecl tydecl = return ()
542 parseError l "Type declaration in a class must be a kind signature or synonym default"
544 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
548 check (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
549 = do ctx <- mapM checkPred ts
552 check (HsParTy ty) -- to be sure HsParTy doesn't get into the way
555 check (HsTyVar t) -- Empty context shows up as a unit type ()
556 | t == getRdrName unitTyCon = return (L l [])
559 = do p <- checkPred (L l t)
563 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
564 -- Watch out.. in ...deriving( Show )... we use checkPred on
565 -- the list of partially applied predicates in the deriving,
566 -- so there can be zero args.
567 checkPred (L spn (HsPredTy (HsIParam n ty)))
568 = return (L spn (HsIParam n ty))
572 checkl (L l ty) args = check l ty args
574 check _loc (HsTyVar t) args | not (isRdrTyVar t)
575 = return (L spn (HsClassP t args))
576 check _loc (HsAppTy l r) args = checkl l (r:args)
577 check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
578 check _loc (HsParTy t) args = checkl t args
579 check loc _ _ = parseError loc "malformed class assertion"
581 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
582 checkDictTy (L spn ty) = check ty []
584 check (HsTyVar t) args | not (isRdrTyVar t)
585 = return (L spn (HsPredTy (HsClassP t args)))
586 check (HsAppTy l r) args = check (unLoc l) (r:args)
587 check (HsParTy t) args = check (unLoc t) args
588 check _ _ = parseError spn "Malformed context in instance header"
591 ---------------------------------------------------------------------------
592 -- Checking stand-alone deriving declarations
594 checkDerivDecl :: LDerivDecl RdrName -> P (LDerivDecl RdrName)
595 checkDerivDecl d@(L loc _) =
596 do glaExtOn <- extension glaExtsEnabled
597 if glaExtOn then return d
598 else parseError loc "Illegal stand-alone deriving declaration (use -fglasgow-exts)"
600 ---------------------------------------------------------------------------
601 -- Checking statements in a do-expression
602 -- We parse do { e1 ; e2 ; }
603 -- as [ExprStmt e1, ExprStmt e2]
604 -- checkDo (a) checks that the last thing is an ExprStmt
605 -- (b) returns it separately
606 -- same comments apply for mdo as well
608 checkDo = checkDoMDo "a " "'do'"
609 checkMDo = checkDoMDo "an " "'mdo'"
611 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
612 checkDoMDo pre nm loc [] = parseError loc ("Empty " ++ nm ++ " construct")
613 checkDoMDo pre nm loc ss = do
616 check [L l (ExprStmt e _ _)] = return ([], e)
617 check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
618 " construct must be an expression")
623 -- -------------------------------------------------------------------------
624 -- Checking Patterns.
626 -- We parse patterns as expressions and check for valid patterns below,
627 -- converting the expression into a pattern at the same time.
629 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
630 checkPattern e = checkLPat e
632 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
633 checkPatterns es = mapM checkPattern es
635 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
636 checkLPat e@(L l _) = checkPat l e []
638 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
639 checkPat loc (L l (HsVar c)) args
640 | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
641 checkPat loc e args -- OK to let this happen even if bang-patterns
642 -- are not enabled, because there is no valid
643 -- non-bang-pattern parse of (C ! e)
644 | Just (e', args') <- splitBang e
645 = do { args'' <- checkPatterns args'
646 ; checkPat loc e' (args'' ++ args) }
647 checkPat loc (L _ (HsApp f x)) args
648 = do { x <- checkLPat x; checkPat loc f (x:args) }
649 checkPat loc (L _ e) []
650 = do { p <- checkAPat loc e; return (L loc p) }
651 checkPat loc pat _some_args
654 checkAPat loc e = case e of
655 EWildPat -> return (WildPat placeHolderType)
656 HsVar x | isQual x -> parseError loc ("Qualified variable in pattern: "
658 | otherwise -> return (VarPat x)
659 HsLit l -> return (LitPat l)
661 -- Overloaded numeric patterns (e.g. f 0 x = x)
662 -- Negation is recorded separately, so that the literal is zero or +ve
663 -- NB. Negative *primitive* literals are already handled by
664 -- RdrHsSyn.mkHsNegApp
665 HsOverLit pos_lit -> return (mkNPat pos_lit Nothing)
666 NegApp (L _ (HsOverLit pos_lit)) _
667 -> return (mkNPat pos_lit (Just noSyntaxExpr))
669 SectionR (L _ (HsVar bang)) e -- (! x)
671 -> do { bang_on <- extension bangPatEnabled
672 ; if bang_on then checkLPat e >>= (return . BangPat)
673 else parseError loc "Illegal bang-pattern (use -fbang-patterns)" }
675 ELazyPat e -> checkLPat e >>= (return . LazyPat)
676 EAsPat n e -> checkLPat e >>= (return . AsPat n)
677 ExprWithTySig e t -> checkLPat e >>= \e ->
678 -- Pattern signatures are parsed as sigtypes,
679 -- but they aren't explicit forall points. Hence
680 -- we have to remove the implicit forall here.
682 L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
685 return (SigPatIn e t')
688 OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
689 (L _ (HsOverLit lit@(HsIntegral _ _)))
691 -> return (mkNPlusKPat (L nloc n) lit)
693 OpApp l op fix r -> checkLPat l >>= \l ->
694 checkLPat r >>= \r ->
696 L cl (HsVar c) | isDataOcc (rdrNameOcc c)
697 -> return (ConPatIn (L cl c) (InfixCon l r))
700 HsPar e -> checkLPat e >>= (return . ParPat)
701 ExplicitList _ es -> mapM (\e -> checkLPat e) es >>= \ps ->
702 return (ListPat ps placeHolderType)
703 ExplicitPArr _ es -> mapM (\e -> checkLPat e) es >>= \ps ->
704 return (PArrPat ps placeHolderType)
706 ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
707 return (TuplePat ps b placeHolderType)
709 RecordCon c _ fs -> mapM checkPatField fs >>= \fs ->
710 return (ConPatIn c (RecCon (map (uncurry mkRecField) fs)))
712 HsType ty -> return (TypePat ty)
715 plus_RDR, bang_RDR :: RdrName
716 plus_RDR = mkUnqual varName FSLIT("+") -- Hack
717 bang_RDR = mkUnqual varName FSLIT("!") -- Hack
719 checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName)
720 checkPatField (n,e) = do
724 patFail loc = parseError loc "Parse error in pattern"
727 ---------------------------------------------------------------------------
728 -- Check Equation Syntax
730 checkValDef :: LHsExpr RdrName
731 -> Maybe (LHsType RdrName)
732 -> Located (GRHSs RdrName)
733 -> P (HsBind RdrName)
735 checkValDef lhs (Just sig) grhss
736 -- x :: ty = rhs parses as a *pattern* binding
737 = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
739 checkValDef lhs opt_sig grhss
740 = do { mb_fun <- isFunLhs lhs
742 Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
743 fun is_infix pats opt_sig grhss
744 Nothing -> checkPatBind lhs grhss }
746 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
748 = parseError (getLoc fun) ("Qualified name in function definition: " ++
749 showRdrName (unLoc fun))
751 = do ps <- checkPatterns pats
752 let match_span = combineSrcSpans lhs_loc rhs_span
753 return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
754 -- The span of the match covers the entire equation.
755 -- That isn't quite right, but it'll do for now.
757 makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
758 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
759 makeFunBind fn is_infix ms
760 = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
761 fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
763 checkPatBind lhs (L _ grhss)
764 = do { lhs <- checkPattern lhs
765 ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
771 checkValSig (L l (HsVar v)) ty
772 | isUnqual v && not (isDataOcc (rdrNameOcc v))
773 = return (TypeSig (L l v) ty)
774 checkValSig (L l other) ty
775 = parseError l "Invalid type signature"
777 mkGadtDecl :: Located RdrName
778 -> LHsType RdrName -- assuming HsType
780 mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = mk_gadt_con name qvars cxt ty
781 mkGadtDecl name ty = mk_gadt_con name [] (noLoc []) ty
783 mk_gadt_con name qvars cxt ty
784 = ConDecl { con_name = name
785 , con_explicit = Implicit
788 , con_details = PrefixCon []
789 , con_res = ResTyGADT ty
790 , con_doc = Nothing }
791 -- NB: we put the whole constr type into the ResTyGADT for now;
792 -- the renamer will unravel it once it has sorted out
795 -- A variable binding is parsed as a FunBind.
798 -- The parser left-associates, so there should
799 -- not be any OpApps inside the e's
800 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
801 -- Splits (f ! g a b) into (f, [(! g), a, g])
802 splitBang (L loc (OpApp l_arg bang@(L loc' (HsVar op)) _ r_arg))
803 | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
805 (arg1,argns) = split_bang r_arg []
806 split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
807 split_bang e es = (e,es)
808 splitBang other = Nothing
810 isFunLhs :: LHsExpr RdrName
811 -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
812 -- Just (fun, is_infix, arg_pats) if e is a function LHS
815 go (L loc (HsVar f)) es
816 | not (isRdrDataCon f) = return (Just (L loc f, False, es))
817 go (L _ (HsApp f e)) es = go f (e:es)
818 go (L _ (HsPar e)) es@(_:_) = go e es
820 -- For infix function defns, there should be only one infix *function*
821 -- (though there may be infix *datacons* involved too). So we don't
822 -- need fixity info to figure out which function is being defined.
823 -- a `K1` b `op` c `K2` d
825 -- (a `K1` b) `op` (c `K2` d)
826 -- The renamer checks later that the precedences would yield such a parse.
828 -- There is a complication to deal with bang patterns.
830 -- ToDo: what about this?
831 -- x + 1 `op` y = ...
833 go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
834 | Just (e',es') <- splitBang e
835 = do { bang_on <- extension bangPatEnabled
836 ; if bang_on then go e' (es' ++ es)
837 else return (Just (L loc' op, True, (l:r:es))) }
838 -- No bangs; behave just like the next case
839 | not (isRdrDataCon op) -- We have found the function!
840 = return (Just (L loc' op, True, (l:r:es)))
841 | otherwise -- Infix data con; keep going
842 = do { mb_l <- go l es
844 Just (op', True, j : k : es')
845 -> return (Just (op', True, j : op_app : es'))
847 op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
848 _ -> return Nothing }
849 go _ _ = return Nothing
851 ---------------------------------------------------------------------------
852 -- Miscellaneous utilities
854 checkPrecP :: Located Int -> P Int
856 | 0 <= i && i <= maxPrecedence = return i
857 | otherwise = parseError l "Precedence out of range"
862 -> HsRecordBinds RdrName
863 -> P (HsExpr RdrName)
865 mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
866 = return (RecordCon (L l c) noPostTcExpr fs)
867 mkRecConstrOrUpdate exp loc fs@(_:_)
868 = return (RecordUpd exp fs placeHolderType placeHolderType)
869 mkRecConstrOrUpdate _ loc []
870 = parseError loc "Empty record update"
872 mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec
873 -- The Maybe is becuase the user can omit the activation spec (and usually does)
874 mkInlineSpec Nothing True = alwaysInlineSpec -- INLINE
875 mkInlineSpec Nothing False = neverInlineSpec -- NOINLINE
876 mkInlineSpec (Just act) inl = Inline act inl
879 -----------------------------------------------------------------------------
880 -- utilities for foreign declarations
882 -- supported calling conventions
884 data CallConv = CCall CCallConv -- ccall or stdcall
887 -- construct a foreign import declaration
891 -> (Located FastString, Located RdrName, LHsType RdrName)
892 -> P (HsDecl RdrName)
893 mkImport (CCall cconv) safety (entity, v, ty) = do
894 importSpec <- parseCImport entity cconv safety v
895 return (ForD (ForeignImport v ty importSpec))
896 mkImport (DNCall ) _ (entity, v, ty) = do
897 spec <- parseDImport entity
898 return $ ForD (ForeignImport v ty (DNImport spec))
900 -- parse the entity string of a foreign import declaration for the `ccall' or
901 -- `stdcall' calling convention'
903 parseCImport :: Located FastString
908 parseCImport (L loc entity) cconv safety v
909 -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
910 | entity == FSLIT ("dynamic") =
911 return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
912 | entity == FSLIT ("wrapper") =
913 return $ CImport cconv safety nilFS nilFS CWrapper
914 | otherwise = parse0 (unpackFS entity)
916 -- using the static keyword?
917 parse0 (' ': rest) = parse0 rest
918 parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
919 parse0 rest = parse1 rest
920 -- check for header file name
921 parse1 "" = parse4 "" nilFS False nilFS
922 parse1 (' ':rest) = parse1 rest
923 parse1 str@('&':_ ) = parse2 str nilFS
924 parse1 str@('[':_ ) = parse3 str nilFS False
926 | ".h" `isSuffixOf` first = parse2 rest (mkFastString first)
927 | otherwise = parse4 str nilFS False nilFS
929 (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
930 -- check for address operator (indicating a label import)
931 parse2 "" header = parse4 "" header False nilFS
932 parse2 (' ':rest) header = parse2 rest header
933 parse2 ('&':rest) header = parse3 rest header True
934 parse2 str@('[':_ ) header = parse3 str header False
935 parse2 str header = parse4 str header False nilFS
936 -- check for library object name
937 parse3 (' ':rest) header isLbl = parse3 rest header isLbl
938 parse3 ('[':rest) header isLbl =
939 case break (== ']') rest of
940 (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib)
941 _ -> parseError loc "Missing ']' in entity"
942 parse3 str header isLbl = parse4 str header isLbl nilFS
943 -- check for name of C function
944 parse4 "" header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
945 parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib
946 parse4 str header isLbl lib
947 | all (== ' ') rest = build (mkFastString first) header isLbl lib
948 | otherwise = parseError loc "Malformed entity string"
950 (first, rest) = break (== ' ') str
952 build cid header False lib = return $
953 CImport cconv safety header lib (CFunction (StaticTarget cid))
954 build cid header True lib = return $
955 CImport cconv safety header lib (CLabel cid )
958 -- Unravel a dotnet spec string.
960 parseDImport :: Located FastString -> P DNCallSpec
961 parseDImport (L loc entity) = parse0 comps
963 comps = words (unpackFS entity)
967 | x == "static" = parse1 True xs
968 | otherwise = parse1 False (x:xs)
971 parse1 isStatic (x:xs)
972 | x == "method" = parse2 isStatic DNMethod xs
973 | x == "field" = parse2 isStatic DNField xs
974 | x == "ctor" = parse2 isStatic DNConstructor xs
975 parse1 isStatic xs = parse2 isStatic DNMethod xs
978 parse2 isStatic kind (('[':x):xs) =
981 vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
982 parse2 isStatic kind xs = parse3 isStatic kind "" xs
984 parse3 isStatic kind assem [x] =
985 return (DNCallSpec isStatic kind assem x
986 -- these will be filled in once known.
987 (error "FFI-dotnet-args")
988 (error "FFI-dotnet-result"))
989 parse3 _ _ _ _ = d'oh
991 d'oh = parseError loc "Malformed entity string"
993 -- construct a foreign export declaration
996 -> (Located FastString, Located RdrName, LHsType RdrName)
997 -> P (HsDecl RdrName)
998 mkExport (CCall cconv) (L loc entity, v, ty) = return $
999 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
1001 entity' | nullFS entity = mkExtName (unLoc v)
1002 | otherwise = entity
1003 mkExport DNCall (L loc entity, v, ty) =
1004 parseError (getLoc v){-TODO: not quite right-}
1005 "Foreign export is not yet supported for .NET"
1007 -- Supplying the ext_name in a foreign decl is optional; if it
1008 -- isn't there, the Haskell name is assumed. Note that no transformation
1009 -- of the Haskell name is then performed, so if you foreign export (++),
1010 -- it's external name will be "++". Too bad; it's important because we don't
1011 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
1013 mkExtName :: RdrName -> CLabelString
1014 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
1018 -----------------------------------------------------------------------------
1022 showRdrName :: RdrName -> String
1023 showRdrName r = showSDoc (ppr r)
1025 parseError :: SrcSpan -> String -> P a
1026 parseError span s = failSpanMsgP span s