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
45 checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat]
46 checkDo, -- [Stmt] -> P [Stmt]
47 checkMDo, -- [Stmt] -> P [Stmt]
48 checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
49 checkValSig, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
50 parseError, -- String -> Pa
53 #include "HsVersions.h"
55 import HsSyn -- Lots of it
56 import RdrName ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc,
57 isRdrDataCon, isUnqual, getRdrName, isQual,
59 import BasicTypes ( maxPrecedence, Activation, InlineSpec(..), alwaysInlineSpec, neverInlineSpec )
60 import Lexer ( P, failSpanMsgP, extension, glaExtsEnabled, bangPatEnabled )
61 import TysWiredIn ( unitTyCon )
62 import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
63 DNCallSpec(..), DNKind(..), CLabelString )
64 import OccName ( srcDataName, varName, isDataOcc, isTcOcc,
67 import OrdList ( OrdList, fromOL )
68 import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag )
73 import List ( isSuffixOf, nubBy )
74 import Monad ( unless )
78 %************************************************************************
80 \subsection{A few functions over HsSyn at RdrName}
82 %************************************************************************
84 extractHsTyRdrNames finds the free variables of a HsType
85 It's used when making the for-alls explicit.
88 extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName]
89 extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty [])
91 extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName]
92 -- This one takes the context and tau-part of a
93 -- sigma type and returns their free type variables
94 extractHsRhoRdrTyVars ctxt ty
95 = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty [])
97 extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt)
99 extract_pred (HsClassP cls tys) acc = foldr extract_lty acc tys
100 extract_pred (HsIParam n ty) acc = extract_lty ty acc
102 extract_lty (L loc ty) acc
104 HsTyVar tv -> extract_tv loc tv acc
105 HsBangTy _ ty -> extract_lty ty acc
106 HsAppTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
107 HsListTy ty -> extract_lty ty acc
108 HsPArrTy ty -> extract_lty ty acc
109 HsTupleTy _ tys -> foldr extract_lty acc tys
110 HsFunTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
111 HsPredTy p -> extract_pred p acc
112 HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
113 HsParTy ty -> extract_lty ty acc
115 HsSpliceTy _ -> acc -- Type splices mention no type variables
116 HsKindSig ty k -> extract_lty ty acc
117 HsForAllTy exp [] cx ty -> extract_lctxt cx (extract_lty ty acc)
118 HsForAllTy exp tvs cx ty -> acc ++ (filter ((`notElem` locals) . unLoc) $
119 extract_lctxt cx (extract_lty ty []))
121 locals = hsLTyVarNames tvs
122 HsDocTy ty doc -> extract_lty ty acc
124 extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName]
125 extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc
128 extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName]
129 -- Get the type variables out of the type patterns in a bunch of
130 -- possibly-generic bindings in a class declaration
131 extractGenericPatTyVars binds
132 = nubBy eqLocated (foldrBag get [] binds)
134 get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms
137 get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
138 get_m other acc = acc
142 %************************************************************************
144 \subsection{Construction functions for Rdr stuff}
146 %************************************************************************
148 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
149 by deriving them from the name of the class. We fill in the names for the
150 tycon and datacon corresponding to the class, by deriving them from the
151 name of the class itself. This saves recording the names in the interface
152 file (which would be equally good).
154 Similarly for mkConDecl, mkClassOpSig and default-method names.
156 *** See "THE NAMING STORY" in HsDecls ****
159 mkClassDecl (cxt, cname, tyvars) fds sigs mbinds ats docs
160 = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
168 mkTyData new_or_data (context, tname, tyvars, typats) ksig data_cons maybe_deriv
169 = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
170 tcdTyVars = tyvars, tcdTyPats = typats, tcdCons = data_cons,
171 tcdKindSig = ksig, tcdDerivs = maybe_deriv }
175 mkHsNegApp :: LHsExpr RdrName -> HsExpr RdrName
176 -- RdrName If the type checker sees (negate 3#) it will barf, because negate
177 -- can't take an unboxed arg. But that is exactly what it will see when
178 -- we write "-3#". So we have to do the negation right now!
179 mkHsNegApp (L loc e) = f e
180 where f (HsLit (HsIntPrim i)) = HsLit (HsIntPrim (-i))
181 f (HsLit (HsFloatPrim i)) = HsLit (HsFloatPrim (-i))
182 f (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i))
183 f expr = NegApp (L loc e) noSyntaxExpr
186 %************************************************************************
188 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
190 %************************************************************************
192 Function definitions are restructured here. Each is assumed to be recursive
193 initially, and non recursive definitions are discovered by the dependency
198 -- | Groups together bindings for a single function
199 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
200 cvTopDecls decls = go (fromOL decls)
202 go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
204 go (L l (ValD b) : ds) = L l' (ValD b') : go ds'
205 where (L l' b', ds') = getMonoBind (L l b) ds
206 go (d : ds) = d : go ds
208 -- Declaration list may only contain value bindings and signatures.
209 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
211 = case cvBindsAndSigs binding of
212 (mbs, sigs, [], _) -> -- list of type decls *always* empty
215 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
216 -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [DocEntity RdrName])
217 -- Input decls contain just value bindings and signatures
218 -- and in case of class or instance declarations also
219 -- associated type declarations. They might also contain Haddock comments.
220 cvBindsAndSigs fb = go (fromOL fb)
222 go [] = (emptyBag, [], [], [])
223 go (L l x@(SigD s) : ds) = (bs, L l s : ss, ts, add_doc x docs)
224 where (bs, ss, ts, docs) = go ds
225 go (L l x@(ValD b) : ds) = (b' `consBag` bs, ss, ts, add_doc x docs)
226 where (b', ds') = getMonoBind (L l b) ds
227 (bs, ss, ts, docs) = go ds'
228 go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs)
229 where (bs, ss, ts, docs) = go ds
230 go (L _ (DocD d) : ds) = (bs, ss, ts, DocEntity d : docs)
231 where (bs, ss, ts, docs) = go ds
233 -----------------------------------------------------------------------------
234 -- Group function bindings into equation groups
236 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
237 -> (LHsBind RdrName, [LHsDecl RdrName])
238 -- Suppose (b',ds') = getMonoBind b ds
239 -- ds is a list of parsed bindings
240 -- b is a MonoBinds that has just been read off the front
242 -- Then b' is the result of grouping more equations from ds that
243 -- belong with b into a single MonoBinds, and ds' is the depleted
244 -- list of parsed bindings.
246 -- All Haddock comments between equations inside the group are
249 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
251 getMonoBind (L loc1 bind@(FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1,
252 fun_matches = MatchGroup mtchs1 _ })) binds
254 = go is_infix1 mtchs1 loc1 binds []
256 go is_infix mtchs loc
257 (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
258 fun_matches = MatchGroup mtchs2 _ })) : binds) _
259 | f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs)
260 (combineSrcSpans loc loc2) binds []
261 go is_infix mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls
262 = let doc_decls' = doc_decl : doc_decls
263 in go is_infix mtchs (combineSrcSpans loc loc2) binds doc_decls'
264 go is_infix mtchs loc binds doc_decls
265 = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), (reverse doc_decls) ++ binds)
266 -- Reverse the final matches, to get it back in the right order
267 -- Do the same thing with the trailing doc comments
269 getMonoBind bind binds = (bind, binds)
271 has_args ((L _ (Match args _ _)) : _) = not (null args)
272 -- Don't group together FunBinds if they have
273 -- no arguments. This is necessary now that variable bindings
274 -- with no arguments are now treated as FunBinds rather
275 -- than pattern bindings (tests/rename/should_fail/rnfail002).
279 findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
280 findSplice ds = addl emptyRdrGroup ds
282 mkGroup :: [LHsDecl a] -> HsGroup a
283 mkGroup ds = addImpDecls emptyRdrGroup ds
285 addImpDecls :: HsGroup a -> [LHsDecl a] -> HsGroup a
286 -- The decls are imported, and should not have a splice
287 addImpDecls group decls = case addl group decls of
288 (group', Nothing) -> group'
289 other -> panic "addImpDecls"
291 addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
292 -- This stuff reverses the declarations (again) but it doesn't matter
295 addl gp [] = (gp, Nothing)
296 addl gp (L l d : ds) = add gp l d ds
299 add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a]
300 -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
302 add gp l (SpliceD e) ds = (gp, Just (e, ds))
304 -- Class declarations: pull out the fixity signatures to the top
305 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs, hs_docs = docs})
308 let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
309 addl (gp { hs_tyclds = L l d : ts,
310 hs_fixds = fsigs ++ fs,
311 hs_docs = add_doc decl docs}) ds
313 addl (gp { hs_tyclds = L l d : ts }) ds
315 addl (gp { hs_tyclds = L l d : ts,
316 hs_docs = add_doc decl docs }) ds
318 -- Signatures: fixity sigs go a different place than all others
319 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
320 = addl (gp {hs_fixds = L l f : ts}) ds
321 add gp@(HsGroup {hs_valds = ts, hs_docs = docs}) l x@(SigD d) ds
322 = addl (gp {hs_valds = add_sig (L l d) ts, hs_docs = add_doc x docs}) ds
324 -- Value declarations: use add_bind
325 add gp@(HsGroup {hs_valds = ts, hs_docs = docs}) l x@(ValD d) ds
326 = addl (gp { hs_valds = add_bind (L l d) ts, hs_docs = add_doc x docs }) ds
328 -- The rest are routine
329 add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds
330 = addl (gp { hs_instds = L l d : ts }) ds
331 add gp@(HsGroup {hs_derivds = ts}) l (DerivD d) ds
332 = addl (gp { hs_derivds = L l d : ts }) ds
333 add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
334 = addl (gp { hs_defds = L l d : ts }) ds
335 add gp@(HsGroup {hs_fords = ts, hs_docs = docs}) l x@(ForD d) ds
336 = addl (gp { hs_fords = L l d : ts, hs_docs = add_doc x docs }) ds
337 add gp@(HsGroup {hs_depds = ts}) l (DeprecD d) ds
338 = addl (gp { hs_depds = L l d : ts }) ds
339 add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
340 = addl (gp { hs_ruleds = L l d : ts }) ds
343 = addl (gp { hs_docs = DocEntity d : (hs_docs gp) }) ds
345 add_doc decl docs = case getMainDeclBinder decl of
346 Just name -> DeclEntity name : docs
349 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
350 add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
353 %************************************************************************
355 \subsection[PrefixToHS-utils]{Utilities for conversion}
357 %************************************************************************
361 -----------------------------------------------------------------------------
364 -- When parsing data declarations, we sometimes inadvertently parse
365 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
366 -- This function splits up the type application, adds any pending
367 -- arguments, and converts the type constructor back into a data constructor.
369 mkPrefixCon :: LHsType RdrName -> [LBangType RdrName]
370 -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
374 split (L _ (HsAppTy t u)) ts = split t (u : ts)
375 split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc
376 return (data_con, PrefixCon ts)
377 split (L l _) _ = parseError l "parse error in data/newtype declaration"
379 mkRecCon :: Located RdrName ->
380 [([Located RdrName], LBangType RdrName, Maybe (LHsDoc RdrName))] ->
381 P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
382 mkRecCon (L loc con) fields
383 = do data_con <- tyConToDataCon loc con
384 return (data_con, RecCon [ (HsRecField l t d) | (ls, t, d) <- fields, l <- ls ])
386 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
387 tyConToDataCon loc tc
388 | isTcOcc (rdrNameOcc tc)
389 = return (L loc (setRdrNameSpace tc srcDataName))
391 = parseError loc (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
393 ----------------------------------------------------------------------------
394 -- Various Syntactic Checks
396 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
397 checkInstType (L l t)
399 HsForAllTy exp tvs ctxt ty -> do
400 dict_ty <- checkDictTy ty
401 return (L l (HsForAllTy exp tvs ctxt dict_ty))
403 HsParTy ty -> checkInstType ty
405 ty -> do dict_ty <- checkDictTy (L l ty)
406 return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
408 -- Check whether the given list of type parameters are all type variables
409 -- (possibly with a kind signature). If the second argument is `False',
410 -- only type variables are allowed and we raise an error on encountering a
411 -- non-variable; otherwise, we allow non-variable arguments and return the
412 -- entire list of parameters.
414 checkTyVars :: [LHsType RdrName] -> P ()
415 checkTyVars tparms = mapM_ chk tparms
417 -- Check that the name space is correct!
418 chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
419 | isRdrTyVar tv = return ()
420 chk (L l (HsTyVar tv))
421 | isRdrTyVar tv = return ()
423 parseError l "Type found where type variable expected"
425 -- Check whether the type arguments in a type synonym head are simply
426 -- variables. If not, we have a type equation of a type function and return
427 -- all patterns. If yes, we return 'Nothing' as the third component to
428 -- indicate a vanilla type synonym.
430 checkSynHdr :: LHsType RdrName
431 -> Bool -- is type instance?
432 -> P (Located RdrName, -- head symbol
433 [LHsTyVarBndr RdrName], -- parameters
434 [LHsType RdrName]) -- type patterns
435 checkSynHdr ty isTyInst =
436 do { (_, tc, tvs, tparms) <- checkTyClHdr (noLoc []) ty
437 ; unless isTyInst $ checkTyVars tparms
438 ; return (tc, tvs, tparms) }
441 -- Well-formedness check and decomposition of type and class heads.
443 checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
444 -> P (LHsContext RdrName, -- the type context
445 Located RdrName, -- the head symbol (type or class name)
446 [LHsTyVarBndr RdrName], -- free variables of the non-context part
447 [LHsType RdrName]) -- parameters of head symbol
448 -- The header of a type or class decl should look like
449 -- (C a, D b) => T a b
453 -- With associated types, we can also have non-variable parameters; ie,
455 -- The unaltered parameter list is returned in the fourth component of the
459 -- ('()', 'T', ['a'], ['Int', '[a]'])
460 checkTyClHdr (L l cxt) ty
461 = do (tc, tvs, parms) <- gol ty []
463 return (L l cxt, tc, tvs, parms)
465 gol (L l ty) acc = go l ty acc
467 go l (HsTyVar tc) acc
468 | not (isRdrTyVar tc) = do
469 tvs <- extractTyVars acc
470 return (L l tc, tvs, acc)
471 go l (HsOpTy t1 tc t2) acc = do
472 tvs <- extractTyVars (t1:t2:acc)
473 return (tc, tvs, acc)
474 go l (HsParTy ty) acc = gol ty acc
475 go l (HsAppTy t1 t2) acc = gol t1 (t2:acc)
477 parseError l "Malformed head of type or class declaration"
479 -- The predicates in a type or class decl must all
480 -- be HsClassPs. They need not all be type variables,
481 -- even in Haskell 98. E.g. class (Monad m, Monad (t m)) => MonadT t m
482 chk_pred (L l (HsClassP _ args)) = return ()
484 = parseError l "Malformed context in type or class declaration"
486 -- Extract the type variables of a list of type parameters.
488 -- * Type arguments can be complex type terms (needed for associated type
491 extractTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
492 extractTyVars tvs = collects [] tvs
494 -- Collect all variables (1st arg serves as an accumulator)
495 collect tvs (L l (HsForAllTy _ _ _ _)) =
496 parseError l "Forall type not allowed as type parameter"
497 collect tvs (L l (HsTyVar tv))
498 | isRdrTyVar tv = return $ L l (UserTyVar tv) : tvs
499 | otherwise = return tvs
500 collect tvs (L l (HsBangTy _ _ )) =
501 parseError l "Bang-style type annotations not allowed as type parameter"
502 collect tvs (L l (HsAppTy t1 t2 )) = do
503 tvs' <- collect tvs t2
505 collect tvs (L l (HsFunTy t1 t2 )) = do
506 tvs' <- collect tvs t2
508 collect tvs (L l (HsListTy t )) = collect tvs t
509 collect tvs (L l (HsPArrTy t )) = collect tvs t
510 collect tvs (L l (HsTupleTy _ ts )) = collects tvs ts
511 collect tvs (L l (HsOpTy t1 _ t2 )) = do
512 tvs' <- collect tvs t2
514 collect tvs (L l (HsParTy t )) = collect tvs t
515 collect tvs (L l (HsNumTy t )) = return tvs
516 collect tvs (L l (HsPredTy t )) =
517 parseError l "Predicate not allowed as type parameter"
518 collect tvs (L l (HsKindSig (L _ (HsTyVar tv)) k))
520 return $ L l (KindedTyVar tv k) : tvs
522 parseError l "Kind signature only allowed for type variables"
523 collect tvs (L l (HsSpliceTy t )) =
524 parseError l "Splice not allowed as type parameter"
526 -- Collect all variables of a list of types
527 collects tvs [] = return tvs
528 collects tvs (t:ts) = do
529 tvs' <- collects tvs ts
532 -- Check that associated type declarations of a class are all kind signatures.
534 checkKindSigs :: [LTyClDecl RdrName] -> P ()
535 checkKindSigs = mapM_ check
538 | isKindSigDecl tydecl
539 || isSynDecl tydecl = return ()
541 parseError l "Type declaration in a class must be a kind signature or synonym default"
543 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
547 check (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
548 = do ctx <- mapM checkPred ts
551 check (HsParTy ty) -- to be sure HsParTy doesn't get into the way
554 check (HsTyVar t) -- Empty context shows up as a unit type ()
555 | t == getRdrName unitTyCon = return (L l [])
558 = do p <- checkPred (L l t)
562 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
563 -- Watch out.. in ...deriving( Show )... we use checkPred on
564 -- the list of partially applied predicates in the deriving,
565 -- so there can be zero args.
566 checkPred (L spn (HsPredTy (HsIParam n ty)))
567 = return (L spn (HsIParam n ty))
571 checkl (L l ty) args = check l ty args
573 check _loc (HsTyVar t) args | not (isRdrTyVar t)
574 = return (L spn (HsClassP t args))
575 check _loc (HsAppTy l r) args = checkl l (r:args)
576 check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
577 check _loc (HsParTy t) args = checkl t args
578 check loc _ _ = parseError loc "malformed class assertion"
580 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
581 checkDictTy (L spn ty) = check ty []
583 check (HsTyVar t) args | not (isRdrTyVar t)
584 = return (L spn (HsPredTy (HsClassP t args)))
585 check (HsAppTy l r) args = check (unLoc l) (r:args)
586 check (HsParTy t) args = check (unLoc t) args
587 check _ _ = parseError spn "Malformed context in instance header"
590 ---------------------------------------------------------------------------
591 -- Checking stand-alone deriving declarations
593 checkDerivDecl :: LDerivDecl RdrName -> P (LDerivDecl RdrName)
594 checkDerivDecl d@(L loc _) =
595 do glaExtOn <- extension glaExtsEnabled
596 if glaExtOn then return d
597 else parseError loc "Illegal stand-alone deriving declaration (use -fglasgow-exts)"
599 ---------------------------------------------------------------------------
600 -- Checking statements in a do-expression
601 -- We parse do { e1 ; e2 ; }
602 -- as [ExprStmt e1, ExprStmt e2]
603 -- checkDo (a) checks that the last thing is an ExprStmt
604 -- (b) returns it separately
605 -- same comments apply for mdo as well
607 checkDo = checkDoMDo "a " "'do'"
608 checkMDo = checkDoMDo "an " "'mdo'"
610 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
611 checkDoMDo pre nm loc [] = parseError loc ("Empty " ++ nm ++ " construct")
612 checkDoMDo pre nm loc ss = do
615 check [L l (ExprStmt e _ _)] = return ([], e)
616 check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
617 " construct must be an expression")
622 -- -------------------------------------------------------------------------
623 -- Checking Patterns.
625 -- We parse patterns as expressions and check for valid patterns below,
626 -- converting the expression into a pattern at the same time.
628 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
629 checkPattern e = checkLPat e
631 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
632 checkPatterns es = mapM checkPattern es
634 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
635 checkLPat e@(L l _) = checkPat l e []
637 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
638 checkPat loc (L l (HsVar c)) args
639 | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
640 checkPat loc e args -- OK to let this happen even if bang-patterns
641 -- are not enabled, because there is no valid
642 -- non-bang-pattern parse of (C ! e)
643 | Just (e', args') <- splitBang e
644 = do { args'' <- checkPatterns args'
645 ; checkPat loc e' (args'' ++ args) }
646 checkPat loc (L _ (HsApp f x)) args
647 = do { x <- checkLPat x; checkPat loc f (x:args) }
648 checkPat loc (L _ e) []
649 = do { p <- checkAPat loc e; return (L loc p) }
650 checkPat loc pat _some_args
653 checkAPat loc e = case e of
654 EWildPat -> return (WildPat placeHolderType)
655 HsVar x | isQual x -> parseError loc ("Qualified variable in pattern: "
657 | otherwise -> return (VarPat x)
658 HsLit l -> return (LitPat l)
660 -- Overloaded numeric patterns (e.g. f 0 x = x)
661 -- Negation is recorded separately, so that the literal is zero or +ve
662 -- NB. Negative *primitive* literals are already handled by
663 -- RdrHsSyn.mkHsNegApp
664 HsOverLit pos_lit -> return (mkNPat pos_lit Nothing)
665 NegApp (L _ (HsOverLit pos_lit)) _
666 -> return (mkNPat pos_lit (Just noSyntaxExpr))
668 SectionR (L _ (HsVar bang)) e -- (! x)
670 -> do { bang_on <- extension bangPatEnabled
671 ; if bang_on then checkLPat e >>= (return . BangPat)
672 else parseError loc "Illegal bang-pattern (use -fbang-patterns)" }
674 ELazyPat e -> checkLPat e >>= (return . LazyPat)
675 EAsPat n e -> checkLPat e >>= (return . AsPat n)
676 ExprWithTySig e t -> checkLPat e >>= \e ->
677 -- Pattern signatures are parsed as sigtypes,
678 -- but they aren't explicit forall points. Hence
679 -- we have to remove the implicit forall here.
681 L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
684 return (SigPatIn e t')
687 OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
688 (L _ (HsOverLit lit@(HsIntegral _ _)))
690 -> return (mkNPlusKPat (L nloc n) lit)
692 OpApp l op fix r -> checkLPat l >>= \l ->
693 checkLPat r >>= \r ->
695 L cl (HsVar c) | isDataOcc (rdrNameOcc c)
696 -> return (ConPatIn (L cl c) (InfixCon l r))
699 HsPar e -> checkLPat e >>= (return . ParPat)
700 ExplicitList _ es -> mapM (\e -> checkLPat e) es >>= \ps ->
701 return (ListPat ps placeHolderType)
702 ExplicitPArr _ es -> mapM (\e -> checkLPat e) es >>= \ps ->
703 return (PArrPat ps placeHolderType)
705 ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
706 return (TuplePat ps b placeHolderType)
708 RecordCon c _ fs -> mapM checkPatField fs >>= \fs ->
709 return (ConPatIn c (RecCon (map (uncurry mkRecField) fs)))
711 HsType ty -> return (TypePat ty)
714 plus_RDR, bang_RDR :: RdrName
715 plus_RDR = mkUnqual varName FSLIT("+") -- Hack
716 bang_RDR = mkUnqual varName FSLIT("!") -- Hack
718 checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName)
719 checkPatField (n,e) = do
723 patFail loc = parseError loc "Parse error in pattern"
726 ---------------------------------------------------------------------------
727 -- Check Equation Syntax
729 checkValDef :: LHsExpr RdrName
730 -> Maybe (LHsType RdrName)
731 -> Located (GRHSs RdrName)
732 -> P (HsBind RdrName)
734 checkValDef lhs (Just sig) grhss
735 -- x :: ty = rhs parses as a *pattern* binding
736 = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
738 checkValDef lhs opt_sig grhss
739 = do { mb_fun <- isFunLhs lhs
741 Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
742 fun is_infix pats opt_sig grhss
743 Nothing -> checkPatBind lhs grhss }
745 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
747 = parseError (getLoc fun) ("Qualified name in function definition: " ++
748 showRdrName (unLoc fun))
750 = do ps <- checkPatterns pats
751 let match_span = combineSrcSpans lhs_loc rhs_span
752 return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
753 -- The span of the match covers the entire equation.
754 -- That isn't quite right, but it'll do for now.
756 makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
757 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
758 makeFunBind fn is_infix ms
759 = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
760 fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames }
762 checkPatBind lhs (L _ grhss)
763 = do { lhs <- checkPattern lhs
764 ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
770 checkValSig (L l (HsVar v)) ty
771 | isUnqual v && not (isDataOcc (rdrNameOcc v))
772 = return (TypeSig (L l v) ty)
773 checkValSig (L l other) ty
774 = parseError l "Invalid type signature"
776 mkGadtDecl :: Located RdrName
777 -> LHsType RdrName -- assuming HsType
779 mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = mk_gadt_con name qvars cxt ty
780 mkGadtDecl name ty = mk_gadt_con name [] (noLoc []) ty
782 mk_gadt_con name qvars cxt ty
783 = ConDecl { con_name = name
784 , con_explicit = Implicit
787 , con_details = PrefixCon []
788 , con_res = ResTyGADT ty
789 , con_doc = Nothing }
790 -- NB: we put the whole constr type into the ResTyGADT for now;
791 -- the renamer will unravel it once it has sorted out
794 -- A variable binding is parsed as a FunBind.
797 -- The parser left-associates, so there should
798 -- not be any OpApps inside the e's
799 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
800 -- Splits (f ! g a b) into (f, [(! g), a, g])
801 splitBang (L loc (OpApp l_arg bang@(L loc' (HsVar op)) _ r_arg))
802 | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
804 (arg1,argns) = split_bang r_arg []
805 split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
806 split_bang e es = (e,es)
807 splitBang other = Nothing
809 isFunLhs :: LHsExpr RdrName
810 -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
811 -- Just (fun, is_infix, arg_pats) if e is a function LHS
814 go (L loc (HsVar f)) es
815 | not (isRdrDataCon f) = return (Just (L loc f, False, es))
816 go (L _ (HsApp f e)) es = go f (e:es)
817 go (L _ (HsPar e)) es@(_:_) = go e es
819 -- For infix function defns, there should be only one infix *function*
820 -- (though there may be infix *datacons* involved too). So we don't
821 -- need fixity info to figure out which function is being defined.
822 -- a `K1` b `op` c `K2` d
824 -- (a `K1` b) `op` (c `K2` d)
825 -- The renamer checks later that the precedences would yield such a parse.
827 -- There is a complication to deal with bang patterns.
829 -- ToDo: what about this?
830 -- x + 1 `op` y = ...
832 go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
833 | Just (e',es') <- splitBang e
834 = do { bang_on <- extension bangPatEnabled
835 ; if bang_on then go e' (es' ++ es)
836 else return (Just (L loc' op, True, (l:r:es))) }
837 -- No bangs; behave just like the next case
838 | not (isRdrDataCon op) -- We have found the function!
839 = return (Just (L loc' op, True, (l:r:es)))
840 | otherwise -- Infix data con; keep going
841 = do { mb_l <- go l es
843 Just (op', True, j : k : es')
844 -> return (Just (op', True, j : op_app : es'))
846 op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
847 _ -> return Nothing }
848 go _ _ = return Nothing
850 ---------------------------------------------------------------------------
851 -- Miscellaneous utilities
853 checkPrecP :: Located Int -> P Int
855 | 0 <= i && i <= maxPrecedence = return i
856 | otherwise = parseError l "Precedence out of range"
861 -> HsRecordBinds RdrName
862 -> P (HsExpr RdrName)
864 mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
865 = return (RecordCon (L l c) noPostTcExpr fs)
866 mkRecConstrOrUpdate exp loc fs@(_:_)
867 = return (RecordUpd exp fs placeHolderType placeHolderType)
868 mkRecConstrOrUpdate _ loc []
869 = parseError loc "Empty record update"
871 mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec
872 -- The Maybe is becuase the user can omit the activation spec (and usually does)
873 mkInlineSpec Nothing True = alwaysInlineSpec -- INLINE
874 mkInlineSpec Nothing False = neverInlineSpec -- NOINLINE
875 mkInlineSpec (Just act) inl = Inline act inl
878 -----------------------------------------------------------------------------
879 -- utilities for foreign declarations
881 -- supported calling conventions
883 data CallConv = CCall CCallConv -- ccall or stdcall
886 -- construct a foreign import declaration
890 -> (Located FastString, Located RdrName, LHsType RdrName)
891 -> P (HsDecl RdrName)
892 mkImport (CCall cconv) safety (entity, v, ty) = do
893 importSpec <- parseCImport entity cconv safety v
894 return (ForD (ForeignImport v ty importSpec))
895 mkImport (DNCall ) _ (entity, v, ty) = do
896 spec <- parseDImport entity
897 return $ ForD (ForeignImport v ty (DNImport spec))
899 -- parse the entity string of a foreign import declaration for the `ccall' or
900 -- `stdcall' calling convention'
902 parseCImport :: Located FastString
907 parseCImport (L loc entity) cconv safety v
908 -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
909 | entity == FSLIT ("dynamic") =
910 return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
911 | entity == FSLIT ("wrapper") =
912 return $ CImport cconv safety nilFS nilFS CWrapper
913 | otherwise = parse0 (unpackFS entity)
915 -- using the static keyword?
916 parse0 (' ': rest) = parse0 rest
917 parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
918 parse0 rest = parse1 rest
919 -- check for header file name
920 parse1 "" = parse4 "" nilFS False nilFS
921 parse1 (' ':rest) = parse1 rest
922 parse1 str@('&':_ ) = parse2 str nilFS
923 parse1 str@('[':_ ) = parse3 str nilFS False
925 | ".h" `isSuffixOf` first = parse2 rest (mkFastString first)
926 | otherwise = parse4 str nilFS False nilFS
928 (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
929 -- check for address operator (indicating a label import)
930 parse2 "" header = parse4 "" header False nilFS
931 parse2 (' ':rest) header = parse2 rest header
932 parse2 ('&':rest) header = parse3 rest header True
933 parse2 str@('[':_ ) header = parse3 str header False
934 parse2 str header = parse4 str header False nilFS
935 -- check for library object name
936 parse3 (' ':rest) header isLbl = parse3 rest header isLbl
937 parse3 ('[':rest) header isLbl =
938 case break (== ']') rest of
939 (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib)
940 _ -> parseError loc "Missing ']' in entity"
941 parse3 str header isLbl = parse4 str header isLbl nilFS
942 -- check for name of C function
943 parse4 "" header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
944 parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib
945 parse4 str header isLbl lib
946 | all (== ' ') rest = build (mkFastString first) header isLbl lib
947 | otherwise = parseError loc "Malformed entity string"
949 (first, rest) = break (== ' ') str
951 build cid header False lib = return $
952 CImport cconv safety header lib (CFunction (StaticTarget cid))
953 build cid header True lib = return $
954 CImport cconv safety header lib (CLabel cid )
957 -- Unravel a dotnet spec string.
959 parseDImport :: Located FastString -> P DNCallSpec
960 parseDImport (L loc entity) = parse0 comps
962 comps = words (unpackFS entity)
966 | x == "static" = parse1 True xs
967 | otherwise = parse1 False (x:xs)
970 parse1 isStatic (x:xs)
971 | x == "method" = parse2 isStatic DNMethod xs
972 | x == "field" = parse2 isStatic DNField xs
973 | x == "ctor" = parse2 isStatic DNConstructor xs
974 parse1 isStatic xs = parse2 isStatic DNMethod xs
977 parse2 isStatic kind (('[':x):xs) =
980 vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
981 parse2 isStatic kind xs = parse3 isStatic kind "" xs
983 parse3 isStatic kind assem [x] =
984 return (DNCallSpec isStatic kind assem x
985 -- these will be filled in once known.
986 (error "FFI-dotnet-args")
987 (error "FFI-dotnet-result"))
988 parse3 _ _ _ _ = d'oh
990 d'oh = parseError loc "Malformed entity string"
992 -- construct a foreign export declaration
995 -> (Located FastString, Located RdrName, LHsType RdrName)
996 -> P (HsDecl RdrName)
997 mkExport (CCall cconv) (L loc entity, v, ty) = return $
998 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
1000 entity' | nullFS entity = mkExtName (unLoc v)
1001 | otherwise = entity
1002 mkExport DNCall (L loc entity, v, ty) =
1003 parseError (getLoc v){-TODO: not quite right-}
1004 "Foreign export is not yet supported for .NET"
1006 -- Supplying the ext_name in a foreign decl is optional; if it
1007 -- isn't there, the Haskell name is assumed. Note that no transformation
1008 -- of the Haskell name is then performed, so if you foreign export (++),
1009 -- it's external name will be "++". Too bad; it's important because we don't
1010 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
1012 mkExtName :: RdrName -> CLabelString
1013 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
1017 -----------------------------------------------------------------------------
1021 showRdrName :: RdrName -> String
1022 showRdrName r = showSDoc (ppr r)
1024 parseError :: SrcSpan -> String -> P a
1025 parseError span s = failSpanMsgP span s