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, mkHsIsString,
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, isRdrTc, 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 (HsEqualP ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
102 extract_pred (HsIParam n ty ) acc = extract_lty ty acc
104 extract_lty (L loc ty) acc
106 HsTyVar tv -> extract_tv loc tv acc
107 HsBangTy _ ty -> extract_lty ty acc
108 HsAppTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
109 HsListTy ty -> extract_lty ty acc
110 HsPArrTy ty -> extract_lty ty acc
111 HsTupleTy _ tys -> foldr extract_lty acc tys
112 HsFunTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
113 HsPredTy p -> extract_pred p acc
114 HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
115 HsParTy ty -> extract_lty ty acc
117 HsSpliceTy _ -> acc -- Type splices mention no type variables
118 HsKindSig ty k -> extract_lty ty acc
119 HsForAllTy exp [] cx ty -> extract_lctxt cx (extract_lty ty acc)
120 HsForAllTy exp tvs cx ty -> acc ++ (filter ((`notElem` locals) . unLoc) $
121 extract_lctxt cx (extract_lty ty []))
123 locals = hsLTyVarNames tvs
124 HsDocTy ty doc -> extract_lty ty acc
126 extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName]
127 extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc
130 extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName]
131 -- Get the type variables out of the type patterns in a bunch of
132 -- possibly-generic bindings in a class declaration
133 extractGenericPatTyVars binds
134 = nubBy eqLocated (foldrBag get [] binds)
136 get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms
139 get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
140 get_m other acc = acc
144 %************************************************************************
146 \subsection{Construction functions for Rdr stuff}
148 %************************************************************************
150 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
151 by deriving them from the name of the class. We fill in the names for the
152 tycon and datacon corresponding to the class, by deriving them from the
153 name of the class itself. This saves recording the names in the interface
154 file (which would be equally good).
156 Similarly for mkConDecl, mkClassOpSig and default-method names.
158 *** See "THE NAMING STORY" in HsDecls ****
161 mkClassDecl (cxt, cname, tyvars) fds sigs mbinds ats docs
162 = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
170 mkTyData new_or_data (context, tname, tyvars, typats) ksig data_cons maybe_deriv
171 = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
172 tcdTyVars = tyvars, tcdTyPats = typats, tcdCons = data_cons,
173 tcdKindSig = ksig, tcdDerivs = maybe_deriv }
177 mkHsNegApp :: LHsExpr RdrName -> HsExpr RdrName
178 -- RdrName If the type checker sees (negate 3#) it will barf, because negate
179 -- can't take an unboxed arg. But that is exactly what it will see when
180 -- we write "-3#". So we have to do the negation right now!
181 mkHsNegApp (L loc e) = f e
182 where f (HsLit (HsIntPrim i)) = HsLit (HsIntPrim (-i))
183 f (HsLit (HsFloatPrim i)) = HsLit (HsFloatPrim (-i))
184 f (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i))
185 f expr = NegApp (L loc e) noSyntaxExpr
188 %************************************************************************
190 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
192 %************************************************************************
194 Function definitions are restructured here. Each is assumed to be recursive
195 initially, and non recursive definitions are discovered by the dependency
200 -- | Groups together bindings for a single function
201 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
202 cvTopDecls decls = go (fromOL decls)
204 go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
206 go (L l (ValD b) : ds) = L l' (ValD b') : go ds'
207 where (L l' b', ds') = getMonoBind (L l b) ds
208 go (d : ds) = d : go ds
210 -- Declaration list may only contain value bindings and signatures.
211 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
213 = case cvBindsAndSigs binding of
214 (mbs, sigs, [], _) -> -- list of type decls *always* empty
217 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
218 -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl RdrName])
219 -- Input decls contain just value bindings and signatures
220 -- and in case of class or instance declarations also
221 -- associated type declarations. They might also contain Haddock comments.
222 cvBindsAndSigs fb = go (fromOL fb)
224 go [] = (emptyBag, [], [], [])
225 go (L l x@(SigD s) : ds) = (bs, L l s : ss, ts, docs)
226 where (bs, ss, ts, docs) = go ds
227 go (L l x@(ValD b) : ds) = (b' `consBag` bs, ss, ts, docs)
228 where (b', ds') = getMonoBind (L l b) ds
229 (bs, ss, ts, docs) = go ds'
230 go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs)
231 where (bs, ss, ts, docs) = go ds
232 go (L l (DocD d) : ds) = (bs, ss, ts, (L l d) : docs)
233 where (bs, ss, ts, docs) = go ds
235 -----------------------------------------------------------------------------
236 -- Group function bindings into equation groups
238 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
239 -> (LHsBind RdrName, [LHsDecl RdrName])
240 -- Suppose (b',ds') = getMonoBind b ds
241 -- ds is a list of parsed bindings
242 -- b is a MonoBinds that has just been read off the front
244 -- Then b' is the result of grouping more equations from ds that
245 -- belong with b into a single MonoBinds, and ds' is the depleted
246 -- list of parsed bindings.
248 -- All Haddock comments between equations inside the group are
251 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
253 getMonoBind (L loc1 bind@(FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1,
254 fun_matches = MatchGroup mtchs1 _ })) binds
256 = go is_infix1 mtchs1 loc1 binds []
258 go is_infix mtchs loc
259 (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
260 fun_matches = MatchGroup mtchs2 _ })) : binds) _
261 | f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs)
262 (combineSrcSpans loc loc2) binds []
263 go is_infix mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls
264 = let doc_decls' = doc_decl : doc_decls
265 in go is_infix mtchs (combineSrcSpans loc loc2) binds doc_decls'
266 go is_infix mtchs loc binds doc_decls
267 = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), (reverse doc_decls) ++ binds)
268 -- Reverse the final matches, to get it back in the right order
269 -- Do the same thing with the trailing doc comments
271 getMonoBind bind binds = (bind, binds)
273 has_args ((L _ (Match args _ _)) : _) = not (null args)
274 -- Don't group together FunBinds if they have
275 -- no arguments. This is necessary now that variable bindings
276 -- with no arguments are now treated as FunBinds rather
277 -- than pattern bindings (tests/rename/should_fail/rnfail002).
281 findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
282 findSplice ds = addl emptyRdrGroup ds
284 mkGroup :: [LHsDecl a] -> HsGroup a
285 mkGroup ds = addImpDecls emptyRdrGroup ds
287 addImpDecls :: HsGroup a -> [LHsDecl a] -> HsGroup a
288 -- The decls are imported, and should not have a splice
289 addImpDecls group decls = case addl group decls of
290 (group', Nothing) -> group'
291 other -> panic "addImpDecls"
293 addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
294 -- This stuff reverses the declarations (again) but it doesn't matter
297 addl gp [] = (gp, Nothing)
298 addl gp (L l d : ds) = add gp l d ds
301 add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a]
302 -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
304 add gp l (SpliceD e) ds = (gp, Just (e, ds))
306 -- Class declarations: pull out the fixity signatures to the top
307 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs})
310 let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
311 addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs}) ds
313 addl (gp { hs_tyclds = L l d : ts }) ds
315 addl (gp { hs_tyclds = L l d : ts }) ds
317 -- Signatures: fixity sigs go a different place than all others
318 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
319 = addl (gp {hs_fixds = L l f : ts}) ds
320 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
321 = addl (gp {hs_valds = add_sig (L l d) ts}) ds
323 -- Value declarations: use add_bind
324 add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds
325 = addl (gp { hs_valds = add_bind (L l d) ts }) ds
327 -- The rest are routine
328 add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds
329 = addl (gp { hs_instds = L l d : ts }) ds
330 add gp@(HsGroup {hs_derivds = ts}) l (DerivD d) ds
331 = addl (gp { hs_derivds = L l d : ts }) ds
332 add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
333 = addl (gp { hs_defds = L l d : ts }) ds
334 add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
335 = addl (gp { hs_fords = L l d : ts }) ds
336 add gp@(HsGroup {hs_depds = ts}) l (DeprecD d) ds
337 = addl (gp { hs_depds = L l d : ts }) ds
338 add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
339 = addl (gp { hs_ruleds = L l d : ts }) ds
342 = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds
344 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
345 add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
348 %************************************************************************
350 \subsection[PrefixToHS-utils]{Utilities for conversion}
352 %************************************************************************
356 -----------------------------------------------------------------------------
359 -- When parsing data declarations, we sometimes inadvertently parse
360 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
361 -- This function splits up the type application, adds any pending
362 -- arguments, and converts the type constructor back into a data constructor.
364 mkPrefixCon :: LHsType RdrName -> [LBangType RdrName]
365 -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
369 split (L _ (HsAppTy t u)) ts = split t (u : ts)
370 split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc
371 return (data_con, PrefixCon ts)
372 split (L l _) _ = parseError l "parse error in data/newtype declaration"
374 mkRecCon :: Located RdrName ->
375 [([Located RdrName], LBangType RdrName, Maybe (LHsDoc RdrName))] ->
376 P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
377 mkRecCon (L loc con) fields
378 = do data_con <- tyConToDataCon loc con
379 return (data_con, RecCon [ (HsRecField l t d) | (ls, t, d) <- fields, l <- ls ])
381 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
382 tyConToDataCon loc tc
383 | isTcOcc (rdrNameOcc tc)
384 = return (L loc (setRdrNameSpace tc srcDataName))
386 = parseError loc (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
388 ----------------------------------------------------------------------------
389 -- Various Syntactic Checks
391 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
392 checkInstType (L l t)
394 HsForAllTy exp tvs ctxt ty -> do
395 dict_ty <- checkDictTy ty
396 return (L l (HsForAllTy exp tvs ctxt dict_ty))
398 HsParTy ty -> checkInstType ty
400 ty -> do dict_ty <- checkDictTy (L l ty)
401 return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
403 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
404 checkDictTy (L spn ty) = check ty []
406 check (HsTyVar t) args | not (isRdrTyVar t)
407 = return (L spn (HsPredTy (HsClassP t args)))
408 check (HsAppTy l r) args = check (unLoc l) (r:args)
409 check (HsParTy t) args = check (unLoc t) args
410 check _ _ = parseError spn "Malformed instance header"
412 -- Check whether the given list of type parameters are all type variables
413 -- (possibly with a kind signature). If the second argument is `False',
414 -- only type variables are allowed and we raise an error on encountering a
415 -- non-variable; otherwise, we allow non-variable arguments and return the
416 -- entire list of parameters.
418 checkTyVars :: [LHsType RdrName] -> P ()
419 checkTyVars tparms = mapM_ chk tparms
421 -- Check that the name space is correct!
422 chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
423 | isRdrTyVar tv = return ()
424 chk (L l (HsTyVar tv))
425 | isRdrTyVar tv = return ()
427 parseError l "Type found where type variable expected"
429 -- Check whether the type arguments in a type synonym head are simply
430 -- variables. If not, we have a type equation of a type function and return
431 -- all patterns. If yes, we return 'Nothing' as the third component to
432 -- indicate a vanilla type synonym.
434 checkSynHdr :: LHsType RdrName
435 -> Bool -- is type instance?
436 -> P (Located RdrName, -- head symbol
437 [LHsTyVarBndr RdrName], -- parameters
438 [LHsType RdrName]) -- type patterns
439 checkSynHdr ty isTyInst =
440 do { (_, tc, tvs, tparms) <- checkTyClHdr (noLoc []) ty
441 ; unless isTyInst $ checkTyVars tparms
442 ; return (tc, tvs, tparms) }
445 -- Well-formedness check and decomposition of type and class heads.
447 checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
448 -> P (LHsContext RdrName, -- the type context
449 Located RdrName, -- the head symbol (type or class name)
450 [LHsTyVarBndr RdrName], -- free variables of the non-context part
451 [LHsType RdrName]) -- parameters of head symbol
452 -- The header of a type or class decl should look like
453 -- (C a, D b) => T a b
457 -- With associated types, we can also have non-variable parameters; ie,
459 -- The unaltered parameter list is returned in the fourth component of the
463 -- ('()', 'T', ['a'], ['Int', '[a]'])
464 checkTyClHdr (L l cxt) ty
465 = do (tc, tvs, parms) <- gol ty []
467 return (L l cxt, tc, tvs, parms)
469 gol (L l ty) acc = go l ty acc
471 go l (HsTyVar tc) acc
472 | isRdrTc tc = do tvs <- extractTyVars acc
473 return (L l tc, tvs, acc)
474 go l (HsOpTy t1 ltc@(L _ tc) t2) acc
475 | isRdrTc tc = do tvs <- extractTyVars (t1:t2:acc)
476 return (ltc, tvs, acc)
477 go l (HsParTy ty) acc = gol ty acc
478 go l (HsAppTy t1 t2) acc = gol t1 (t2:acc)
480 parseError l "Malformed head of type or class declaration"
482 -- The predicates in a type or class decl must be class predicates or
483 -- equational constraints. They need not all have variable-only
484 -- arguments, even in Haskell 98.
485 -- E.g. class (Monad m, Monad (t m)) => MonadT t m
486 chk_pred (L l (HsClassP _ _)) = return ()
487 chk_pred (L l (HsEqualP _ _)) = return ()
489 = parseError l "Malformed context in type or class declaration"
491 -- Extract the type variables of a list of type parameters.
493 -- * Type arguments can be complex type terms (needed for associated type
496 extractTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
497 extractTyVars tvs = collects [] tvs
499 -- Collect all variables (1st arg serves as an accumulator)
500 collect tvs (L l (HsForAllTy _ _ _ _)) =
501 parseError l "Forall type not allowed as type parameter"
502 collect tvs (L l (HsTyVar tv))
503 | isRdrTyVar tv = return $ L l (UserTyVar tv) : tvs
504 | otherwise = return tvs
505 collect tvs (L l (HsBangTy _ _ )) =
506 parseError l "Bang-style type annotations not allowed as type parameter"
507 collect tvs (L l (HsAppTy t1 t2 )) = do
508 tvs' <- collect tvs t2
510 collect tvs (L l (HsFunTy t1 t2 )) = do
511 tvs' <- collect tvs t2
513 collect tvs (L l (HsListTy t )) = collect tvs t
514 collect tvs (L l (HsPArrTy t )) = collect tvs t
515 collect tvs (L l (HsTupleTy _ ts )) = collects tvs ts
516 collect tvs (L l (HsOpTy t1 _ t2 )) = do
517 tvs' <- collect tvs t2
519 collect tvs (L l (HsParTy t )) = collect tvs t
520 collect tvs (L l (HsNumTy t )) = return tvs
521 collect tvs (L l (HsPredTy t )) =
522 parseError l "Predicate not allowed as type parameter"
523 collect tvs (L l (HsKindSig (L _ (HsTyVar tv)) k))
525 return $ L l (KindedTyVar tv k) : tvs
527 parseError l "Kind signature only allowed for type variables"
528 collect tvs (L l (HsSpliceTy t )) =
529 parseError l "Splice not allowed as type parameter"
531 -- Collect all variables of a list of types
532 collects tvs [] = return tvs
533 collects tvs (t:ts) = do
534 tvs' <- collects tvs ts
537 -- Check that associated type declarations of a class are all kind signatures.
539 checkKindSigs :: [LTyClDecl RdrName] -> P ()
540 checkKindSigs = mapM_ check
543 | isFamilyDecl tydecl
544 || isSynDecl tydecl = return ()
546 parseError l "Type declaration in a class must be a kind signature or synonym default"
548 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
552 check (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
553 = do ctx <- mapM checkPred ts
556 check (HsParTy ty) -- to be sure HsParTy doesn't get into the way
559 check (HsTyVar t) -- Empty context shows up as a unit type ()
560 | t == getRdrName unitTyCon = return (L l [])
563 = do p <- checkPred (L l t)
567 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
568 -- Watch out.. in ...deriving( Show )... we use checkPred on
569 -- the list of partially applied predicates in the deriving,
570 -- so there can be zero args.
571 checkPred (L spn (HsPredTy (HsIParam n ty)))
572 = return (L spn (HsIParam n ty))
576 checkl (L l ty) args = check l ty args
578 check _loc (HsPredTy pred@(HsEqualP _ _))
580 = return $ L spn pred
581 check _loc (HsTyVar t) args | not (isRdrTyVar t)
582 = return (L spn (HsClassP t args))
583 check _loc (HsAppTy l r) args = checkl l (r:args)
584 check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
585 check _loc (HsParTy t) args = checkl t args
586 check loc _ _ = parseError loc
587 "malformed class assertion"
589 ---------------------------------------------------------------------------
590 -- Checking stand-alone deriving declarations
592 checkDerivDecl :: LDerivDecl RdrName -> P (LDerivDecl RdrName)
593 checkDerivDecl d@(L loc _) =
594 do glaExtOn <- extension glaExtsEnabled
595 if glaExtOn then return d
596 else parseError loc "Illegal stand-alone deriving declaration (use -fglasgow-exts)"
598 ---------------------------------------------------------------------------
599 -- Checking statements in a do-expression
600 -- We parse do { e1 ; e2 ; }
601 -- as [ExprStmt e1, ExprStmt e2]
602 -- checkDo (a) checks that the last thing is an ExprStmt
603 -- (b) returns it separately
604 -- same comments apply for mdo as well
606 checkDo = checkDoMDo "a " "'do'"
607 checkMDo = checkDoMDo "an " "'mdo'"
609 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
610 checkDoMDo pre nm loc [] = parseError loc ("Empty " ++ nm ++ " construct")
611 checkDoMDo pre nm loc ss = do
614 check [L l (ExprStmt e _ _)] = return ([], e)
615 check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
616 " construct must be an expression")
621 -- -------------------------------------------------------------------------
622 -- Checking Patterns.
624 -- We parse patterns as expressions and check for valid patterns below,
625 -- converting the expression into a pattern at the same time.
627 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
628 checkPattern e = checkLPat e
630 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
631 checkPatterns es = mapM checkPattern es
633 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
634 checkLPat e@(L l _) = checkPat l e []
636 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
637 checkPat loc (L l (HsVar c)) args
638 | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
639 checkPat loc e args -- OK to let this happen even if bang-patterns
640 -- are not enabled, because there is no valid
641 -- non-bang-pattern parse of (C ! e)
642 | Just (e', args') <- splitBang e
643 = do { args'' <- checkPatterns args'
644 ; checkPat loc e' (args'' ++ args) }
645 checkPat loc (L _ (HsApp f x)) args
646 = do { x <- checkLPat x; checkPat loc f (x:args) }
647 checkPat loc (L _ e) []
648 = do { p <- checkAPat loc e; return (L loc p) }
649 checkPat loc pat _some_args
652 checkAPat loc e = case e of
653 EWildPat -> return (WildPat placeHolderType)
654 HsVar x | isQual x -> parseError loc ("Qualified variable in pattern: "
656 | otherwise -> return (VarPat x)
657 HsLit l -> return (LitPat l)
659 -- Overloaded numeric patterns (e.g. f 0 x = x)
660 -- Negation is recorded separately, so that the literal is zero or +ve
661 -- NB. Negative *primitive* literals are already handled by
662 -- RdrHsSyn.mkHsNegApp
663 HsOverLit pos_lit -> return (mkNPat pos_lit Nothing)
664 NegApp (L _ (HsOverLit pos_lit)) _
665 -> return (mkNPat pos_lit (Just noSyntaxExpr))
667 SectionR (L _ (HsVar bang)) e -- (! x)
669 -> do { bang_on <- extension bangPatEnabled
670 ; if bang_on then checkLPat e >>= (return . BangPat)
671 else parseError loc "Illegal bang-pattern (use -fbang-patterns)" }
673 ELazyPat e -> checkLPat e >>= (return . LazyPat)
674 EAsPat n e -> checkLPat e >>= (return . AsPat n)
675 ExprWithTySig e t -> checkLPat e >>= \e ->
676 -- Pattern signatures are parsed as sigtypes,
677 -- but they aren't explicit forall points. Hence
678 -- we have to remove the implicit forall here.
680 L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
683 return (SigPatIn e t')
686 OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
687 (L _ (HsOverLit lit@(HsIntegral _ _)))
689 -> return (mkNPlusKPat (L nloc n) lit)
691 OpApp l op fix r -> checkLPat l >>= \l ->
692 checkLPat r >>= \r ->
694 L cl (HsVar c) | isDataOcc (rdrNameOcc c)
695 -> return (ConPatIn (L cl c) (InfixCon l r))
698 HsPar e -> checkLPat e >>= (return . ParPat)
699 ExplicitList _ es -> mapM (\e -> checkLPat e) es >>= \ps ->
700 return (ListPat ps placeHolderType)
701 ExplicitPArr _ es -> mapM (\e -> checkLPat e) es >>= \ps ->
702 return (PArrPat ps placeHolderType)
704 ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
705 return (TuplePat ps b placeHolderType)
707 RecordCon c _ (HsRecordBinds fs) -> mapM checkPatField fs >>= \fs ->
708 return (ConPatIn c (RecCon (map (uncurry mkRecField) fs)))
710 HsType ty -> return (TypePat ty)
713 plus_RDR, bang_RDR :: RdrName
714 plus_RDR = mkUnqual varName FSLIT("+") -- Hack
715 bang_RDR = mkUnqual varName FSLIT("!") -- Hack
717 checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName)
718 checkPatField (n,e) = do
722 patFail loc = parseError loc "Parse error in pattern"
725 ---------------------------------------------------------------------------
726 -- Check Equation Syntax
728 checkValDef :: LHsExpr RdrName
729 -> Maybe (LHsType RdrName)
730 -> Located (GRHSs RdrName)
731 -> P (HsBind RdrName)
733 checkValDef lhs (Just sig) grhss
734 -- x :: ty = rhs parses as a *pattern* binding
735 = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
737 checkValDef lhs opt_sig grhss
738 = do { mb_fun <- isFunLhs lhs
740 Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
741 fun is_infix pats opt_sig grhss
742 Nothing -> checkPatBind lhs grhss }
744 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
746 = parseError (getLoc fun) ("Qualified name in function definition: " ++
747 showRdrName (unLoc fun))
749 = do ps <- checkPatterns pats
750 let match_span = combineSrcSpans lhs_loc rhs_span
751 return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
752 -- The span of the match covers the entire equation.
753 -- That isn't quite right, but it'll do for now.
755 makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
756 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
757 makeFunBind fn is_infix ms
758 = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
759 fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
761 checkPatBind lhs (L _ grhss)
762 = do { lhs <- checkPattern lhs
763 ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
769 checkValSig (L l (HsVar v)) ty
770 | isUnqual v && not (isDataOcc (rdrNameOcc v))
771 = return (TypeSig (L l v) ty)
772 checkValSig (L l other) ty
773 = parseError l "Invalid type signature"
775 mkGadtDecl :: Located RdrName
776 -> LHsType RdrName -- assuming HsType
778 mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = mk_gadt_con name qvars cxt ty
779 mkGadtDecl name ty = mk_gadt_con name [] (noLoc []) ty
781 mk_gadt_con name qvars cxt ty
782 = ConDecl { con_name = name
783 , con_explicit = Implicit
786 , con_details = PrefixCon []
787 , con_res = ResTyGADT ty
788 , con_doc = Nothing }
789 -- NB: we put the whole constr type into the ResTyGADT for now;
790 -- the renamer will unravel it once it has sorted out
793 -- A variable binding is parsed as a FunBind.
796 -- The parser left-associates, so there should
797 -- not be any OpApps inside the e's
798 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
799 -- Splits (f ! g a b) into (f, [(! g), a, b])
800 splitBang (L loc (OpApp l_arg bang@(L loc' (HsVar op)) _ r_arg))
801 | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
803 (arg1,argns) = split_bang r_arg []
804 split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
805 split_bang e es = (e,es)
806 splitBang other = Nothing
808 isFunLhs :: LHsExpr RdrName
809 -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
810 -- Just (fun, is_infix, arg_pats) if e is a function LHS
812 -- The whole LHS is parsed as a single expression.
813 -- Any infix operators on the LHS will parse left-associatively
815 -- will parse (rather strangely) as
817 -- It's up to isFunLhs to sort out the mess
823 go (L loc (HsVar f)) es
824 | not (isRdrDataCon f) = return (Just (L loc f, False, es))
825 go (L _ (HsApp f e)) es = go f (e:es)
826 go (L _ (HsPar e)) es@(_:_) = go e es
828 -- For infix function defns, there should be only one infix *function*
829 -- (though there may be infix *datacons* involved too). So we don't
830 -- need fixity info to figure out which function is being defined.
831 -- a `K1` b `op` c `K2` d
833 -- (a `K1` b) `op` (c `K2` d)
834 -- The renamer checks later that the precedences would yield such a parse.
836 -- There is a complication to deal with bang patterns.
838 -- ToDo: what about this?
839 -- x + 1 `op` y = ...
841 go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
842 | Just (e',es') <- splitBang e
843 = do { bang_on <- extension bangPatEnabled
844 ; if bang_on then go e' (es' ++ es)
845 else return (Just (L loc' op, True, (l:r:es))) }
846 -- No bangs; behave just like the next case
847 | not (isRdrDataCon op) -- We have found the function!
848 = return (Just (L loc' op, True, (l:r:es)))
849 | otherwise -- Infix data con; keep going
850 = do { mb_l <- go l es
852 Just (op', True, j : k : es')
853 -> return (Just (op', True, j : op_app : es'))
855 op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
856 _ -> return Nothing }
857 go _ _ = return Nothing
859 ---------------------------------------------------------------------------
860 -- Miscellaneous utilities
862 checkPrecP :: Located Int -> P Int
864 | 0 <= i && i <= maxPrecedence = return i
865 | otherwise = parseError l "Precedence out of range"
870 -> HsRecordBinds RdrName
871 -> P (HsExpr RdrName)
873 mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
874 = return (RecordCon (L l c) noPostTcExpr fs)
875 mkRecConstrOrUpdate exp loc fs@(HsRecordBinds (_:_))
876 = return (RecordUpd exp fs placeHolderType placeHolderType)
877 mkRecConstrOrUpdate _ loc (HsRecordBinds [])
878 = parseError loc "Empty record update"
880 mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec
881 -- The Maybe is becuase the user can omit the activation spec (and usually does)
882 mkInlineSpec Nothing True = alwaysInlineSpec -- INLINE
883 mkInlineSpec Nothing False = neverInlineSpec -- NOINLINE
884 mkInlineSpec (Just act) inl = Inline act inl
887 -----------------------------------------------------------------------------
888 -- utilities for foreign declarations
890 -- supported calling conventions
892 data CallConv = CCall CCallConv -- ccall or stdcall
895 -- construct a foreign import declaration
899 -> (Located FastString, Located RdrName, LHsType RdrName)
900 -> P (HsDecl RdrName)
901 mkImport (CCall cconv) safety (entity, v, ty) = do
902 importSpec <- parseCImport entity cconv safety v
903 return (ForD (ForeignImport v ty importSpec))
904 mkImport (DNCall ) _ (entity, v, ty) = do
905 spec <- parseDImport entity
906 return $ ForD (ForeignImport v ty (DNImport spec))
908 -- parse the entity string of a foreign import declaration for the `ccall' or
909 -- `stdcall' calling convention'
911 parseCImport :: Located FastString
916 parseCImport (L loc entity) cconv safety v
917 -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
918 | entity == FSLIT ("dynamic") =
919 return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
920 | entity == FSLIT ("wrapper") =
921 return $ CImport cconv safety nilFS nilFS CWrapper
922 | otherwise = parse0 (unpackFS entity)
924 -- using the static keyword?
925 parse0 (' ': rest) = parse0 rest
926 parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
927 parse0 rest = parse1 rest
928 -- check for header file name
929 parse1 "" = parse4 "" nilFS False nilFS
930 parse1 (' ':rest) = parse1 rest
931 parse1 str@('&':_ ) = parse2 str nilFS
932 parse1 str@('[':_ ) = parse3 str nilFS False
934 | ".h" `isSuffixOf` first = parse2 rest (mkFastString first)
935 | otherwise = parse4 str nilFS False nilFS
937 (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
938 -- check for address operator (indicating a label import)
939 parse2 "" header = parse4 "" header False nilFS
940 parse2 (' ':rest) header = parse2 rest header
941 parse2 ('&':rest) header = parse3 rest header True
942 parse2 str@('[':_ ) header = parse3 str header False
943 parse2 str header = parse4 str header False nilFS
944 -- check for library object name
945 parse3 (' ':rest) header isLbl = parse3 rest header isLbl
946 parse3 ('[':rest) header isLbl =
947 case break (== ']') rest of
948 (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib)
949 _ -> parseError loc "Missing ']' in entity"
950 parse3 str header isLbl = parse4 str header isLbl nilFS
951 -- check for name of C function
952 parse4 "" header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
953 parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib
954 parse4 str header isLbl lib
955 | all (== ' ') rest = build (mkFastString first) header isLbl lib
956 | otherwise = parseError loc "Malformed entity string"
958 (first, rest) = break (== ' ') str
960 build cid header False lib = return $
961 CImport cconv safety header lib (CFunction (StaticTarget cid))
962 build cid header True lib = return $
963 CImport cconv safety header lib (CLabel cid )
966 -- Unravel a dotnet spec string.
968 parseDImport :: Located FastString -> P DNCallSpec
969 parseDImport (L loc entity) = parse0 comps
971 comps = words (unpackFS entity)
975 | x == "static" = parse1 True xs
976 | otherwise = parse1 False (x:xs)
979 parse1 isStatic (x:xs)
980 | x == "method" = parse2 isStatic DNMethod xs
981 | x == "field" = parse2 isStatic DNField xs
982 | x == "ctor" = parse2 isStatic DNConstructor xs
983 parse1 isStatic xs = parse2 isStatic DNMethod xs
986 parse2 isStatic kind (('[':x):xs) =
989 vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
990 parse2 isStatic kind xs = parse3 isStatic kind "" xs
992 parse3 isStatic kind assem [x] =
993 return (DNCallSpec isStatic kind assem x
994 -- these will be filled in once known.
995 (error "FFI-dotnet-args")
996 (error "FFI-dotnet-result"))
997 parse3 _ _ _ _ = d'oh
999 d'oh = parseError loc "Malformed entity string"
1001 -- construct a foreign export declaration
1003 mkExport :: CallConv
1004 -> (Located FastString, Located RdrName, LHsType RdrName)
1005 -> P (HsDecl RdrName)
1006 mkExport (CCall cconv) (L loc entity, v, ty) = return $
1007 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
1009 entity' | nullFS entity = mkExtName (unLoc v)
1010 | otherwise = entity
1011 mkExport DNCall (L loc entity, v, ty) =
1012 parseError (getLoc v){-TODO: not quite right-}
1013 "Foreign export is not yet supported for .NET"
1015 -- Supplying the ext_name in a foreign decl is optional; if it
1016 -- isn't there, the Haskell name is assumed. Note that no transformation
1017 -- of the Haskell name is then performed, so if you foreign export (++),
1018 -- it's external name will be "++". Too bad; it's important because we don't
1019 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
1021 mkExtName :: RdrName -> CLabelString
1022 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
1026 -----------------------------------------------------------------------------
1030 showRdrName :: RdrName -> String
1031 showRdrName r = showSDoc (ppr r)
1033 parseError :: SrcSpan -> String -> P a
1034 parseError span s = failSpanMsgP span s