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,
314 hs_docs = add_doc decl docs }) ds
316 -- Signatures: fixity sigs go a different place than all others
317 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
318 = addl (gp {hs_fixds = L l f : ts}) ds
319 add gp@(HsGroup {hs_valds = ts, hs_docs = docs}) l x@(SigD d) ds
320 = addl (gp {hs_valds = add_sig (L l d) ts, hs_docs = add_doc x docs}) ds
322 -- Value declarations: use add_bind
323 add gp@(HsGroup {hs_valds = ts, hs_docs = docs}) l x@(ValD d) ds
324 = addl (gp { hs_valds = add_bind (L l d) ts, hs_docs = add_doc x docs }) ds
326 -- The rest are routine
327 add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds
328 = addl (gp { hs_instds = L l d : ts }) ds
329 add gp@(HsGroup {hs_derivds = ts}) l (DerivD d) ds
330 = addl (gp { hs_derivds = L l d : ts }) ds
331 add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
332 = addl (gp { hs_defds = L l d : ts }) ds
333 add gp@(HsGroup {hs_fords = ts, hs_docs = docs}) l x@(ForD d) ds
334 = addl (gp { hs_fords = L l d : ts, hs_docs = add_doc x docs }) ds
335 add gp@(HsGroup {hs_depds = ts}) l (DeprecD d) ds
336 = addl (gp { hs_depds = L l d : ts }) ds
337 add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
338 = addl (gp { hs_ruleds = L l d : ts }) ds
341 = addl (gp { hs_docs = DocEntity d : (hs_docs gp) }) ds
343 add_doc decl docs = case getMainDeclBinder decl of
344 Just name -> DeclEntity name : docs
347 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
348 add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
351 %************************************************************************
353 \subsection[PrefixToHS-utils]{Utilities for conversion}
355 %************************************************************************
359 -----------------------------------------------------------------------------
362 -- When parsing data declarations, we sometimes inadvertently parse
363 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
364 -- This function splits up the type application, adds any pending
365 -- arguments, and converts the type constructor back into a data constructor.
367 mkPrefixCon :: LHsType RdrName -> [LBangType RdrName]
368 -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
372 split (L _ (HsAppTy t u)) ts = split t (u : ts)
373 split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc
374 return (data_con, PrefixCon ts)
375 split (L l _) _ = parseError l "parse error in data/newtype declaration"
377 mkRecCon :: Located RdrName ->
378 [([Located RdrName], LBangType RdrName, Maybe (LHsDoc RdrName))] ->
379 P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
380 mkRecCon (L loc con) fields
381 = do data_con <- tyConToDataCon loc con
382 return (data_con, RecCon [ (HsRecField l t d) | (ls, t, d) <- fields, l <- ls ])
384 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
385 tyConToDataCon loc tc
386 | isTcOcc (rdrNameOcc tc)
387 = return (L loc (setRdrNameSpace tc srcDataName))
389 = parseError loc (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
391 ----------------------------------------------------------------------------
392 -- Various Syntactic Checks
394 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
395 checkInstType (L l t)
397 HsForAllTy exp tvs ctxt ty -> do
398 dict_ty <- checkDictTy ty
399 return (L l (HsForAllTy exp tvs ctxt dict_ty))
401 HsParTy ty -> checkInstType ty
403 ty -> do dict_ty <- checkDictTy (L l ty)
404 return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
406 -- Check whether the given list of type parameters are all type variables
407 -- (possibly with a kind signature). If the second argument is `False',
408 -- only type variables are allowed and we raise an error on encountering a
409 -- non-variable; otherwise, we allow non-variable arguments and return the
410 -- entire list of parameters.
412 checkTyVars :: [LHsType RdrName] -> P ()
413 checkTyVars tparms = mapM_ chk tparms
415 -- Check that the name space is correct!
416 chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
417 | isRdrTyVar tv = return ()
418 chk (L l (HsTyVar tv))
419 | isRdrTyVar tv = return ()
421 parseError l "Type found where type variable expected"
423 -- Check whether the type arguments in a type synonym head are simply
424 -- variables. If not, we have a type equation of a type function and return
425 -- all patterns. If yes, we return 'Nothing' as the third component to
426 -- indicate a vanilla type synonym.
428 checkSynHdr :: LHsType RdrName
429 -> Bool -- is type instance?
430 -> P (Located RdrName, -- head symbol
431 [LHsTyVarBndr RdrName], -- parameters
432 [LHsType RdrName]) -- type patterns
433 checkSynHdr ty isTyInst =
434 do { (_, tc, tvs, tparms) <- checkTyClHdr (noLoc []) ty
435 ; unless isTyInst $ checkTyVars tparms
436 ; return (tc, tvs, tparms) }
439 -- Well-formedness check and decomposition of type and class heads.
441 checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
442 -> P (LHsContext RdrName, -- the type context
443 Located RdrName, -- the head symbol (type or class name)
444 [LHsTyVarBndr RdrName], -- free variables of the non-context part
445 [LHsType RdrName]) -- parameters of head symbol
446 -- The header of a type or class decl should look like
447 -- (C a, D b) => T a b
451 -- With associated types, we can also have non-variable parameters; ie,
453 -- The unaltered parameter list is returned in the fourth component of the
457 -- ('()', 'T', ['a'], ['Int', '[a]'])
458 checkTyClHdr (L l cxt) ty
459 = do (tc, tvs, parms) <- gol ty []
461 return (L l cxt, tc, tvs, parms)
463 gol (L l ty) acc = go l ty acc
465 go l (HsTyVar tc) acc
466 | not (isRdrTyVar tc) = do
467 tvs <- extractTyVars acc
468 return (L l tc, tvs, acc)
469 go l (HsOpTy t1 tc t2) acc = do
470 tvs <- extractTyVars (t1:t2:acc)
471 return (tc, tvs, acc)
472 go l (HsParTy ty) acc = gol ty acc
473 go l (HsAppTy t1 t2) acc = gol t1 (t2:acc)
475 parseError l "Malformed head of type or class declaration"
477 -- The predicates in a type or class decl must all
478 -- be HsClassPs. They need not all be type variables,
479 -- even in Haskell 98. E.g. class (Monad m, Monad (t m)) => MonadT t m
480 chk_pred (L l (HsClassP _ args)) = return ()
482 = parseError l "Malformed context in type or class declaration"
484 -- Extract the type variables of a list of type parameters.
486 -- * Type arguments can be complex type terms (needed for associated type
489 extractTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
490 extractTyVars tvs = collects [] tvs
492 -- Collect all variables (1st arg serves as an accumulator)
493 collect tvs (L l (HsForAllTy _ _ _ _)) =
494 parseError l "Forall type not allowed as type parameter"
495 collect tvs (L l (HsTyVar tv))
496 | isRdrTyVar tv = return $ L l (UserTyVar tv) : tvs
497 | otherwise = return tvs
498 collect tvs (L l (HsBangTy _ _ )) =
499 parseError l "Bang-style type annotations not allowed as type parameter"
500 collect tvs (L l (HsAppTy t1 t2 )) = do
501 tvs' <- collect tvs t2
503 collect tvs (L l (HsFunTy t1 t2 )) = do
504 tvs' <- collect tvs t2
506 collect tvs (L l (HsListTy t )) = collect tvs t
507 collect tvs (L l (HsPArrTy t )) = collect tvs t
508 collect tvs (L l (HsTupleTy _ ts )) = collects tvs ts
509 collect tvs (L l (HsOpTy t1 _ t2 )) = do
510 tvs' <- collect tvs t2
512 collect tvs (L l (HsParTy t )) = collect tvs t
513 collect tvs (L l (HsNumTy t )) = return tvs
514 collect tvs (L l (HsPredTy t )) =
515 parseError l "Predicate not allowed as type parameter"
516 collect tvs (L l (HsKindSig (L _ (HsTyVar tv)) k))
518 return $ L l (KindedTyVar tv k) : tvs
520 parseError l "Kind signature only allowed for type variables"
521 collect tvs (L l (HsSpliceTy t )) =
522 parseError l "Splice not allowed as type parameter"
524 -- Collect all variables of a list of types
525 collects tvs [] = return tvs
526 collects tvs (t:ts) = do
527 tvs' <- collects tvs ts
530 -- Check that associated type declarations of a class are all kind signatures.
532 checkKindSigs :: [LTyClDecl RdrName] -> P ()
533 checkKindSigs = mapM_ check
536 | isKindSigDecl tydecl
537 || isSynDecl tydecl = return ()
539 parseError l "Type declaration in a class must be a kind signature or synonym default"
541 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
545 check (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
546 = do ctx <- mapM checkPred ts
549 check (HsParTy ty) -- to be sure HsParTy doesn't get into the way
552 check (HsTyVar t) -- Empty context shows up as a unit type ()
553 | t == getRdrName unitTyCon = return (L l [])
556 = do p <- checkPred (L l t)
560 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
561 -- Watch out.. in ...deriving( Show )... we use checkPred on
562 -- the list of partially applied predicates in the deriving,
563 -- so there can be zero args.
564 checkPred (L spn (HsPredTy (HsIParam n ty)))
565 = return (L spn (HsIParam n ty))
569 checkl (L l ty) args = check l ty args
571 check _loc (HsTyVar t) args | not (isRdrTyVar t)
572 = return (L spn (HsClassP t args))
573 check _loc (HsAppTy l r) args = checkl l (r:args)
574 check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
575 check _loc (HsParTy t) args = checkl t args
576 check loc _ _ = parseError loc "malformed class assertion"
578 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
579 checkDictTy (L spn ty) = check ty []
581 check (HsTyVar t) args | not (isRdrTyVar t)
582 = return (L spn (HsPredTy (HsClassP t args)))
583 check (HsAppTy l r) args = check (unLoc l) (r:args)
584 check (HsParTy t) args = check (unLoc t) args
585 check _ _ = parseError spn "Malformed context in instance header"
588 ---------------------------------------------------------------------------
589 -- Checking stand-alone deriving declarations
591 checkDerivDecl :: LDerivDecl RdrName -> P (LDerivDecl RdrName)
592 checkDerivDecl d@(L loc _) =
593 do glaExtOn <- extension glaExtsEnabled
594 if glaExtOn then return d
595 else parseError loc "Illegal stand-alone deriving declaration (use -fglasgow-exts)"
597 ---------------------------------------------------------------------------
598 -- Checking statements in a do-expression
599 -- We parse do { e1 ; e2 ; }
600 -- as [ExprStmt e1, ExprStmt e2]
601 -- checkDo (a) checks that the last thing is an ExprStmt
602 -- (b) returns it separately
603 -- same comments apply for mdo as well
605 checkDo = checkDoMDo "a " "'do'"
606 checkMDo = checkDoMDo "an " "'mdo'"
608 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
609 checkDoMDo pre nm loc [] = parseError loc ("Empty " ++ nm ++ " construct")
610 checkDoMDo pre nm loc ss = do
613 check [L l (ExprStmt e _ _)] = return ([], e)
614 check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
615 " construct must be an expression")
620 -- -------------------------------------------------------------------------
621 -- Checking Patterns.
623 -- We parse patterns as expressions and check for valid patterns below,
624 -- converting the expression into a pattern at the same time.
626 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
627 checkPattern e = checkLPat e
629 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
630 checkPatterns es = mapM checkPattern es
632 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
633 checkLPat e@(L l _) = checkPat l e []
635 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
636 checkPat loc (L l (HsVar c)) args
637 | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
638 checkPat loc e args -- OK to let this happen even if bang-patterns
639 -- are not enabled, because there is no valid
640 -- non-bang-pattern parse of (C ! e)
641 | Just (e', args') <- splitBang e
642 = do { args'' <- checkPatterns args'
643 ; checkPat loc e' (args'' ++ args) }
644 checkPat loc (L _ (HsApp f x)) args
645 = do { x <- checkLPat x; checkPat loc f (x:args) }
646 checkPat loc (L _ e) []
647 = do { p <- checkAPat loc e; return (L loc p) }
648 checkPat loc pat _some_args
651 checkAPat loc e = case e of
652 EWildPat -> return (WildPat placeHolderType)
653 HsVar x | isQual x -> parseError loc ("Qualified variable in pattern: "
655 | otherwise -> return (VarPat x)
656 HsLit l -> return (LitPat l)
658 -- Overloaded numeric patterns (e.g. f 0 x = x)
659 -- Negation is recorded separately, so that the literal is zero or +ve
660 -- NB. Negative *primitive* literals are already handled by
661 -- RdrHsSyn.mkHsNegApp
662 HsOverLit pos_lit -> return (mkNPat pos_lit Nothing)
663 NegApp (L _ (HsOverLit pos_lit)) _
664 -> return (mkNPat pos_lit (Just noSyntaxExpr))
666 SectionR (L _ (HsVar bang)) e -- (! x)
668 -> do { bang_on <- extension bangPatEnabled
669 ; if bang_on then checkLPat e >>= (return . BangPat)
670 else parseError loc "Illegal bang-pattern (use -fbang-patterns)" }
672 ELazyPat e -> checkLPat e >>= (return . LazyPat)
673 EAsPat n e -> checkLPat e >>= (return . AsPat n)
674 ExprWithTySig e t -> checkLPat e >>= \e ->
675 -- Pattern signatures are parsed as sigtypes,
676 -- but they aren't explicit forall points. Hence
677 -- we have to remove the implicit forall here.
679 L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
682 return (SigPatIn e t')
685 OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
686 (L _ (HsOverLit lit@(HsIntegral _ _)))
688 -> return (mkNPlusKPat (L nloc n) lit)
690 OpApp l op fix r -> checkLPat l >>= \l ->
691 checkLPat r >>= \r ->
693 L cl (HsVar c) | isDataOcc (rdrNameOcc c)
694 -> return (ConPatIn (L cl c) (InfixCon l r))
697 HsPar e -> checkLPat e >>= (return . ParPat)
698 ExplicitList _ es -> mapM (\e -> checkLPat e) es >>= \ps ->
699 return (ListPat ps placeHolderType)
700 ExplicitPArr _ es -> mapM (\e -> checkLPat e) es >>= \ps ->
701 return (PArrPat ps placeHolderType)
703 ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
704 return (TuplePat ps b placeHolderType)
706 RecordCon c _ fs -> mapM checkPatField fs >>= \fs ->
707 return (ConPatIn c (RecCon (map (uncurry mkRecField) fs)))
709 HsType ty -> return (TypePat ty)
712 plus_RDR, bang_RDR :: RdrName
713 plus_RDR = mkUnqual varName FSLIT("+") -- Hack
714 bang_RDR = mkUnqual varName FSLIT("!") -- Hack
716 checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName)
717 checkPatField (n,e) = do
721 patFail loc = parseError loc "Parse error in pattern"
724 ---------------------------------------------------------------------------
725 -- Check Equation Syntax
727 checkValDef :: LHsExpr RdrName
728 -> Maybe (LHsType RdrName)
729 -> Located (GRHSs RdrName)
730 -> P (HsBind RdrName)
732 checkValDef lhs (Just sig) grhss
733 -- x :: ty = rhs parses as a *pattern* binding
734 = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
736 checkValDef lhs opt_sig grhss
737 = do { mb_fun <- isFunLhs lhs
739 Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
740 fun is_infix pats opt_sig grhss
741 Nothing -> checkPatBind lhs grhss }
743 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
745 = parseError (getLoc fun) ("Qualified name in function definition: " ++
746 showRdrName (unLoc fun))
748 = do ps <- checkPatterns pats
749 let match_span = combineSrcSpans lhs_loc rhs_span
750 return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
751 -- The span of the match covers the entire equation.
752 -- That isn't quite right, but it'll do for now.
754 makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
755 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
756 makeFunBind fn is_infix ms
757 = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
758 fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames }
760 checkPatBind lhs (L _ grhss)
761 = do { lhs <- checkPattern lhs
762 ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
768 checkValSig (L l (HsVar v)) ty
769 | isUnqual v && not (isDataOcc (rdrNameOcc v))
770 = return (TypeSig (L l v) ty)
771 checkValSig (L l other) ty
772 = parseError l "Invalid type signature"
774 mkGadtDecl :: Located RdrName
775 -> LHsType RdrName -- assuming HsType
777 mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = mk_gadt_con name qvars cxt ty
778 mkGadtDecl name ty = mk_gadt_con name [] (noLoc []) ty
780 mk_gadt_con name qvars cxt ty
781 = ConDecl { con_name = name
782 , con_explicit = Implicit
785 , con_details = PrefixCon []
786 , con_res = ResTyGADT ty
787 , con_doc = Nothing }
788 -- NB: we put the whole constr type into the ResTyGADT for now;
789 -- the renamer will unravel it once it has sorted out
792 -- A variable binding is parsed as a FunBind.
795 -- The parser left-associates, so there should
796 -- not be any OpApps inside the e's
797 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
798 -- Splits (f ! g a b) into (f, [(! g), a, g])
799 splitBang (L loc (OpApp l_arg bang@(L loc' (HsVar op)) _ r_arg))
800 | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
802 (arg1,argns) = split_bang r_arg []
803 split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
804 split_bang e es = (e,es)
805 splitBang other = Nothing
807 isFunLhs :: LHsExpr RdrName
808 -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
809 -- Just (fun, is_infix, arg_pats) if e is a function LHS
812 go (L loc (HsVar f)) es
813 | not (isRdrDataCon f) = return (Just (L loc f, False, es))
814 go (L _ (HsApp f e)) es = go f (e:es)
815 go (L _ (HsPar e)) es@(_:_) = go e es
817 -- For infix function defns, there should be only one infix *function*
818 -- (though there may be infix *datacons* involved too). So we don't
819 -- need fixity info to figure out which function is being defined.
820 -- a `K1` b `op` c `K2` d
822 -- (a `K1` b) `op` (c `K2` d)
823 -- The renamer checks later that the precedences would yield such a parse.
825 -- There is a complication to deal with bang patterns.
827 -- ToDo: what about this?
828 -- x + 1 `op` y = ...
830 go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
831 | Just (e',es') <- splitBang e
832 = do { bang_on <- extension bangPatEnabled
833 ; if bang_on then go e' (es' ++ es)
834 else return (Just (L loc' op, True, (l:r:es))) }
835 -- No bangs; behave just like the next case
836 | not (isRdrDataCon op) -- We have found the function!
837 = return (Just (L loc' op, True, (l:r:es)))
838 | otherwise -- Infix data con; keep going
839 = do { mb_l <- go l es
841 Just (op', True, j : k : es')
842 -> return (Just (op', True, j : op_app : es'))
844 op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
845 _ -> return Nothing }
846 go _ _ = return Nothing
848 ---------------------------------------------------------------------------
849 -- Miscellaneous utilities
851 checkPrecP :: Located Int -> P Int
853 | 0 <= i && i <= maxPrecedence = return i
854 | otherwise = parseError l "Precedence out of range"
859 -> HsRecordBinds RdrName
860 -> P (HsExpr RdrName)
862 mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
863 = return (RecordCon (L l c) noPostTcExpr fs)
864 mkRecConstrOrUpdate exp loc fs@(_:_)
865 = return (RecordUpd exp fs placeHolderType placeHolderType)
866 mkRecConstrOrUpdate _ loc []
867 = parseError loc "Empty record update"
869 mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec
870 -- The Maybe is becuase the user can omit the activation spec (and usually does)
871 mkInlineSpec Nothing True = alwaysInlineSpec -- INLINE
872 mkInlineSpec Nothing False = neverInlineSpec -- NOINLINE
873 mkInlineSpec (Just act) inl = Inline act inl
876 -----------------------------------------------------------------------------
877 -- utilities for foreign declarations
879 -- supported calling conventions
881 data CallConv = CCall CCallConv -- ccall or stdcall
884 -- construct a foreign import declaration
888 -> (Located FastString, Located RdrName, LHsType RdrName)
889 -> P (HsDecl RdrName)
890 mkImport (CCall cconv) safety (entity, v, ty) = do
891 importSpec <- parseCImport entity cconv safety v
892 return (ForD (ForeignImport v ty importSpec))
893 mkImport (DNCall ) _ (entity, v, ty) = do
894 spec <- parseDImport entity
895 return $ ForD (ForeignImport v ty (DNImport spec))
897 -- parse the entity string of a foreign import declaration for the `ccall' or
898 -- `stdcall' calling convention'
900 parseCImport :: Located FastString
905 parseCImport (L loc entity) cconv safety v
906 -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
907 | entity == FSLIT ("dynamic") =
908 return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
909 | entity == FSLIT ("wrapper") =
910 return $ CImport cconv safety nilFS nilFS CWrapper
911 | otherwise = parse0 (unpackFS entity)
913 -- using the static keyword?
914 parse0 (' ': rest) = parse0 rest
915 parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
916 parse0 rest = parse1 rest
917 -- check for header file name
918 parse1 "" = parse4 "" nilFS False nilFS
919 parse1 (' ':rest) = parse1 rest
920 parse1 str@('&':_ ) = parse2 str nilFS
921 parse1 str@('[':_ ) = parse3 str nilFS False
923 | ".h" `isSuffixOf` first = parse2 rest (mkFastString first)
924 | otherwise = parse4 str nilFS False nilFS
926 (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
927 -- check for address operator (indicating a label import)
928 parse2 "" header = parse4 "" header False nilFS
929 parse2 (' ':rest) header = parse2 rest header
930 parse2 ('&':rest) header = parse3 rest header True
931 parse2 str@('[':_ ) header = parse3 str header False
932 parse2 str header = parse4 str header False nilFS
933 -- check for library object name
934 parse3 (' ':rest) header isLbl = parse3 rest header isLbl
935 parse3 ('[':rest) header isLbl =
936 case break (== ']') rest of
937 (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib)
938 _ -> parseError loc "Missing ']' in entity"
939 parse3 str header isLbl = parse4 str header isLbl nilFS
940 -- check for name of C function
941 parse4 "" header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
942 parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib
943 parse4 str header isLbl lib
944 | all (== ' ') rest = build (mkFastString first) header isLbl lib
945 | otherwise = parseError loc "Malformed entity string"
947 (first, rest) = break (== ' ') str
949 build cid header False lib = return $
950 CImport cconv safety header lib (CFunction (StaticTarget cid))
951 build cid header True lib = return $
952 CImport cconv safety header lib (CLabel cid )
955 -- Unravel a dotnet spec string.
957 parseDImport :: Located FastString -> P DNCallSpec
958 parseDImport (L loc entity) = parse0 comps
960 comps = words (unpackFS entity)
964 | x == "static" = parse1 True xs
965 | otherwise = parse1 False (x:xs)
968 parse1 isStatic (x:xs)
969 | x == "method" = parse2 isStatic DNMethod xs
970 | x == "field" = parse2 isStatic DNField xs
971 | x == "ctor" = parse2 isStatic DNConstructor xs
972 parse1 isStatic xs = parse2 isStatic DNMethod xs
975 parse2 isStatic kind (('[':x):xs) =
978 vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
979 parse2 isStatic kind xs = parse3 isStatic kind "" xs
981 parse3 isStatic kind assem [x] =
982 return (DNCallSpec isStatic kind assem x
983 -- these will be filled in once known.
984 (error "FFI-dotnet-args")
985 (error "FFI-dotnet-result"))
986 parse3 _ _ _ _ = d'oh
988 d'oh = parseError loc "Malformed entity string"
990 -- construct a foreign export declaration
993 -> (Located FastString, Located RdrName, LHsType RdrName)
994 -> P (HsDecl RdrName)
995 mkExport (CCall cconv) (L loc entity, v, ty) = return $
996 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
998 entity' | nullFS entity = mkExtName (unLoc v)
1000 mkExport DNCall (L loc entity, v, ty) =
1001 parseError (getLoc v){-TODO: not quite right-}
1002 "Foreign export is not yet supported for .NET"
1004 -- Supplying the ext_name in a foreign decl is optional; if it
1005 -- isn't there, the Haskell name is assumed. Note that no transformation
1006 -- of the Haskell name is then performed, so if you foreign export (++),
1007 -- it's external name will be "++". Too bad; it's important because we don't
1008 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
1010 mkExtName :: RdrName -> CLabelString
1011 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
1015 -----------------------------------------------------------------------------
1019 showRdrName :: RdrName -> String
1020 showRdrName r = showSDoc (ppr r)
1022 parseError :: SrcSpan -> String -> P a
1023 parseError span s = failSpanMsgP span s