2 % (c) The University of Glasgow, 1996-2003
4 Functions over HsSyn specialised to RdrName.
9 extractHsRhoRdrTyVars, extractGenericPatTyVars,
11 mkHsOpApp, mkClassDecl,
12 mkHsIntegral, mkHsFractional, mkHsIsString,
14 mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec,
15 mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
20 findSplice, checkDecBrGroup,
22 -- Stuff to do with Foreign declarations
24 mkImport, -- CallConv -> Safety
25 -- -> (FastString, RdrName, RdrNameHsType)
28 -- -> (FastString, RdrName, RdrNameHsType)
30 mkExtName, -- RdrName -> CLabelString
31 mkGadtDecl, -- Located RdrName -> LHsType RdrName -> ConDecl RdrName
33 -- Bunch of functions in the parser monad for
34 -- checking and constructing values
35 checkPrecP, -- Int -> P Int
36 checkContext, -- HsType -> P HsContext
37 checkPred, -- HsType -> P HsPred
38 checkTyClHdr, -- LHsContext RdrName -> LHsType RdrName
39 -- -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName])
40 checkTyVars, -- [LHsType RdrName] -> P ()
41 checkSynHdr, -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName])
42 checkKindSigs, -- [LTyClDecl RdrName] -> P ()
43 checkInstType, -- HsType -> P HsType
44 checkDerivDecl, -- LDerivDecl RdrName -> P (LDerivDecl RdrName)
45 checkPattern, -- HsExp -> P HsPat
47 checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat]
48 checkDo, -- [Stmt] -> P [Stmt]
49 checkMDo, -- [Stmt] -> P [Stmt]
50 checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
51 checkValSig, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
52 parseError, -- String -> Pa
55 import HsSyn -- Lots of it
56 import Class ( FunDep )
57 import TypeRep ( Kind )
58 import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc,
59 isRdrDataCon, isUnqual, getRdrName, isQual,
60 setRdrNameSpace, showRdrName )
61 import BasicTypes ( maxPrecedence, Activation, RuleMatchInfo,
62 InlinePragma(..), InlineSpec(..),
63 alwaysInlineSpec, neverInlineSpec )
64 import Lexer ( P, failSpanMsgP, extension, standaloneDerivingEnabled, bangPatEnabled )
65 import TysWiredIn ( unitTyCon )
66 import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
67 DNCallSpec(..), DNKind(..), CLabelString )
68 import OccName ( srcDataName, varName, isDataOcc, isTcOcc,
70 import PrelNames ( forall_tv_RDR )
72 import OrdList ( OrdList, fromOL )
73 import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag )
77 import List ( isSuffixOf, nubBy )
78 import Monad ( unless )
80 #include "HsVersions.h"
84 %************************************************************************
86 \subsection{A few functions over HsSyn at RdrName}
88 %************************************************************************
90 extractHsTyRdrNames finds the free variables of a HsType
91 It's used when making the for-alls explicit.
94 extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName]
95 extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty [])
97 extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName]
98 -- This one takes the context and tau-part of a
99 -- sigma type and returns their free type variables
100 extractHsRhoRdrTyVars ctxt ty
101 = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty [])
103 extract_lctxt :: Located [LHsPred RdrName] -> [Located RdrName] -> [Located RdrName]
104 extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt)
106 extract_pred :: HsPred RdrName -> [Located RdrName] -> [Located RdrName]
107 extract_pred (HsClassP _ tys) acc = foldr extract_lty acc tys
108 extract_pred (HsEqualP ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
109 extract_pred (HsIParam _ ty ) acc = extract_lty ty acc
111 extract_lty :: LHsType RdrName -> [Located RdrName] -> [Located RdrName]
112 extract_lty (L loc ty) acc
114 HsTyVar tv -> extract_tv loc tv acc
115 HsBangTy _ ty -> extract_lty ty acc
116 HsAppTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
117 HsListTy ty -> extract_lty ty acc
118 HsPArrTy ty -> extract_lty ty acc
119 HsTupleTy _ tys -> foldr extract_lty acc tys
120 HsFunTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
121 HsPredTy p -> extract_pred p acc
122 HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
123 HsParTy ty -> extract_lty ty acc
125 HsSpliceTy _ -> acc -- Type splices mention no type variables
126 HsKindSig ty _ -> extract_lty ty acc
127 HsForAllTy _ [] cx ty -> extract_lctxt cx (extract_lty ty acc)
128 HsForAllTy _ tvs cx ty -> acc ++ (filter ((`notElem` locals) . unLoc) $
129 extract_lctxt cx (extract_lty ty []))
131 locals = hsLTyVarNames tvs
132 HsDocTy ty _ -> extract_lty ty acc
134 extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName]
135 extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc
138 extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName]
139 -- Get the type variables out of the type patterns in a bunch of
140 -- possibly-generic bindings in a class declaration
141 extractGenericPatTyVars binds
142 = nubBy eqLocated (foldrBag get [] binds)
144 get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms
147 get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
152 %************************************************************************
154 \subsection{Construction functions for Rdr stuff}
156 %************************************************************************
158 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
159 by deriving them from the name of the class. We fill in the names for the
160 tycon and datacon corresponding to the class, by deriving them from the
161 name of the class itself. This saves recording the names in the interface
162 file (which would be equally good).
164 Similarly for mkConDecl, mkClassOpSig and default-method names.
166 *** See "THE NAMING STORY" in HsDecls ****
169 mkClassDecl :: (LHsContext name, Located name, [LHsTyVarBndr name])
170 -> [Located (FunDep name)]
176 mkClassDecl (cxt, cname, tyvars) fds sigs mbinds ats docs
177 = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
185 mkTyData :: NewOrData
189 Maybe [LHsType name])
192 -> Maybe [LHsType name]
194 mkTyData new_or_data (context, tname, tyvars, typats) ksig data_cons maybe_deriv
195 = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
196 tcdTyVars = tyvars, tcdTyPats = typats, tcdCons = data_cons,
197 tcdKindSig = ksig, tcdDerivs = maybe_deriv }
200 %************************************************************************
202 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
204 %************************************************************************
206 Function definitions are restructured here. Each is assumed to be recursive
207 initially, and non recursive definitions are discovered by the dependency
212 -- | Groups together bindings for a single function
213 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
214 cvTopDecls decls = go (fromOL decls)
216 go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
218 go (L l (ValD b) : ds) = L l' (ValD b') : go ds'
219 where (L l' b', ds') = getMonoBind (L l b) ds
220 go (d : ds) = d : go ds
222 -- Declaration list may only contain value bindings and signatures.
223 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
225 = case cvBindsAndSigs binding of
226 (mbs, sigs, tydecls, _) -> ASSERT( null tydecls )
229 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
230 -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl RdrName])
231 -- Input decls contain just value bindings and signatures
232 -- and in case of class or instance declarations also
233 -- associated type declarations. They might also contain Haddock comments.
234 cvBindsAndSigs fb = go (fromOL fb)
236 go [] = (emptyBag, [], [], [])
237 go (L l (SigD s) : ds) = (bs, L l s : ss, ts, docs)
238 where (bs, ss, ts, docs) = go ds
239 go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, docs)
240 where (b', ds') = getMonoBind (L l b) ds
241 (bs, ss, ts, docs) = go ds'
242 go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs)
243 where (bs, ss, ts, docs) = go ds
244 go (L l (DocD d) : ds) = (bs, ss, ts, (L l d) : docs)
245 where (bs, ss, ts, docs) = go ds
246 go (L _ d : _) = pprPanic "cvBindsAndSigs" (ppr d)
248 -----------------------------------------------------------------------------
249 -- Group function bindings into equation groups
251 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
252 -> (LHsBind RdrName, [LHsDecl RdrName])
253 -- Suppose (b',ds') = getMonoBind b ds
254 -- ds is a list of parsed bindings
255 -- b is a MonoBinds that has just been read off the front
257 -- Then b' is the result of grouping more equations from ds that
258 -- belong with b into a single MonoBinds, and ds' is the depleted
259 -- list of parsed bindings.
261 -- All Haddock comments between equations inside the group are
264 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
266 getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1,
267 fun_matches = MatchGroup mtchs1 _ })) binds
269 = go is_infix1 mtchs1 loc1 binds []
271 go is_infix mtchs loc
272 (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
273 fun_matches = MatchGroup mtchs2 _ })) : binds) _
274 | f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs)
275 (combineSrcSpans loc loc2) binds []
276 go is_infix mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls
277 = let doc_decls' = doc_decl : doc_decls
278 in go is_infix mtchs (combineSrcSpans loc loc2) binds doc_decls'
279 go is_infix mtchs loc binds doc_decls
280 = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), (reverse doc_decls) ++ binds)
281 -- Reverse the final matches, to get it back in the right order
282 -- Do the same thing with the trailing doc comments
284 getMonoBind bind binds = (bind, binds)
286 has_args :: [LMatch RdrName] -> Bool
287 has_args [] = panic "RdrHsSyn:has_args"
288 has_args ((L _ (Match args _ _)) : _) = not (null args)
289 -- Don't group together FunBinds if they have
290 -- no arguments. This is necessary now that variable bindings
291 -- with no arguments are now treated as FunBinds rather
292 -- than pattern bindings (tests/rename/should_fail/rnfail002).
296 findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
297 findSplice ds = addl emptyRdrGroup ds
299 checkDecBrGroup :: [LHsDecl a] -> P (HsGroup a)
300 -- Turn the body of a [d| ... |] into a HsGroup
301 -- There should be no splices in the "..."
302 checkDecBrGroup decls
303 = case addl emptyRdrGroup decls of
304 (group, Nothing) -> return group
305 (_, Just (SpliceDecl (L loc _), _)) ->
306 parseError loc "Declaration splices are not permitted inside declaration brackets"
307 -- Why not? See Section 7.3 of the TH paper.
309 addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
310 -- This stuff reverses the declarations (again) but it doesn't matter
313 addl gp [] = (gp, Nothing)
314 addl gp (L l d : ds) = add gp l d ds
317 add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a]
318 -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
320 add gp _ (SpliceD e) ds = (gp, Just (e, ds))
322 -- Class declarations: pull out the fixity signatures to the top
323 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs})
326 let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
327 addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs}) ds
329 addl (gp { hs_tyclds = L l d : ts }) ds
331 -- Signatures: fixity sigs go a different place than all others
332 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
333 = addl (gp {hs_fixds = L l f : ts}) ds
334 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
335 = addl (gp {hs_valds = add_sig (L l d) ts}) ds
337 -- Value declarations: use add_bind
338 add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds
339 = addl (gp { hs_valds = add_bind (L l d) ts }) ds
341 -- The rest are routine
342 add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds
343 = addl (gp { hs_instds = L l d : ts }) ds
344 add gp@(HsGroup {hs_derivds = ts}) l (DerivD d) ds
345 = addl (gp { hs_derivds = L l d : ts }) ds
346 add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
347 = addl (gp { hs_defds = L l d : ts }) ds
348 add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
349 = addl (gp { hs_fords = L l d : ts }) ds
350 add gp@(HsGroup {hs_warnds = ts}) l (WarningD d) ds
351 = addl (gp { hs_warnds = L l d : ts }) ds
352 add gp@(HsGroup {hs_annds = ts}) l (AnnD d) ds
353 = addl (gp { hs_annds = L l d : ts }) ds
354 add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
355 = addl (gp { hs_ruleds = L l d : ts }) ds
358 = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds
360 add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
361 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
362 add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind"
364 add_sig :: LSig a -> HsValBinds a -> HsValBinds a
365 add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
366 add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig"
369 %************************************************************************
371 \subsection[PrefixToHS-utils]{Utilities for conversion}
373 %************************************************************************
377 -----------------------------------------------------------------------------
380 -- When parsing data declarations, we sometimes inadvertently parse
381 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
382 -- This function splits up the type application, adds any pending
383 -- arguments, and converts the type constructor back into a data constructor.
385 mkPrefixCon :: LHsType RdrName -> [LBangType RdrName]
386 -> P (Located RdrName, HsConDeclDetails RdrName)
390 split (L _ (HsAppTy t u)) ts = split t (u : ts)
391 split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc
392 return (data_con, PrefixCon ts)
393 split (L l _) _ = parseError l "parse error in data/newtype declaration"
395 mkRecCon :: Located RdrName ->
396 [([Located RdrName], LBangType RdrName, Maybe (LHsDoc RdrName))] ->
397 P (Located RdrName, HsConDeclDetails RdrName)
398 mkRecCon (L loc con) fields
399 = do data_con <- tyConToDataCon loc con
400 return (data_con, RecCon [ ConDeclField l t d | (ls, t, d) <- fields, l <- ls ])
402 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
403 tyConToDataCon loc tc
404 | isTcOcc (rdrNameOcc tc)
405 = return (L loc (setRdrNameSpace tc srcDataName))
407 = parseErrorSDoc loc (msg $$ extra)
409 msg = text "Not a data constructor:" <+> quotes (ppr tc)
410 extra | tc == forall_tv_RDR
411 = text "Perhaps you intended to use -XExistentialQuantification"
414 ----------------------------------------------------------------------------
415 -- Various Syntactic Checks
417 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
418 checkInstType (L l t)
420 HsForAllTy exp tvs ctxt ty -> do
421 dict_ty <- checkDictTy ty
422 return (L l (HsForAllTy exp tvs ctxt dict_ty))
424 HsParTy ty -> checkInstType ty
426 ty -> do dict_ty <- checkDictTy (L l ty)
427 return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
429 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
430 checkDictTy (L spn ty) = check ty []
432 check (HsTyVar t) args | not (isRdrTyVar t)
433 = return (L spn (HsPredTy (HsClassP t args)))
434 check (HsAppTy l r) args = check (unLoc l) (r:args)
435 check (HsParTy t) args = check (unLoc t) args
436 check _ _ = parseError spn "Malformed instance header"
438 -- Check whether the given list of type parameters are all type variables
439 -- (possibly with a kind signature). If the second argument is `False',
440 -- only type variables are allowed and we raise an error on encountering a
441 -- non-variable; otherwise, we allow non-variable arguments and return the
442 -- entire list of parameters.
444 checkTyVars :: [LHsType RdrName] -> P ()
445 checkTyVars tparms = mapM_ chk tparms
447 -- Check that the name space is correct!
448 chk (L _ (HsKindSig (L _ (HsTyVar tv)) _))
449 | isRdrTyVar tv = return ()
450 chk (L _ (HsTyVar tv))
451 | isRdrTyVar tv = return ()
453 parseError l "Type found where type variable expected"
455 -- Check whether the type arguments in a type synonym head are simply
456 -- variables. If not, we have a type family instance and return all patterns.
457 -- If yes, we return 'Nothing' as the third component to indicate a vanilla
460 checkSynHdr :: LHsType RdrName
461 -> Bool -- is type instance?
462 -> P (Located RdrName, -- head symbol
463 [LHsTyVarBndr RdrName], -- parameters
464 [LHsType RdrName]) -- type patterns
465 checkSynHdr ty isTyInst =
466 do { (_, tc, tvs, tparms) <- checkTyClHdr (noLoc []) ty
467 ; unless isTyInst $ checkTyVars tparms
468 ; return (tc, tvs, tparms) }
471 -- Well-formedness check and decomposition of type and class heads.
473 checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
474 -> P (LHsContext RdrName, -- the type context
475 Located RdrName, -- the head symbol (type or class name)
476 [LHsTyVarBndr RdrName], -- free variables of the non-context part
477 [LHsType RdrName]) -- parameters of head symbol
478 -- The header of a type or class decl should look like
479 -- (C a, D b) => T a b
483 -- With associated types, we can also have non-variable parameters; ie,
486 -- The unaltered parameter list is returned in the fourth component of the
490 -- ('()', 'T', ['a'], ['Int', '[a]'])
491 checkTyClHdr (L l cxt) ty
492 = do (tc, tvs, parms) <- gol ty []
494 return (L l cxt, tc, tvs, parms)
496 gol (L l ty) acc = go l ty acc
498 go l (HsTyVar tc) acc
499 | isRdrTc tc = do tvs <- extractTyVars acc
500 return (L l tc, tvs, acc)
501 go _ (HsOpTy t1 ltc@(L _ tc) t2) acc
502 | isRdrTc tc = do tvs <- extractTyVars (t1:t2:acc)
503 return (ltc, tvs, t1:t2:acc)
504 go _ (HsParTy ty) acc = gol ty acc
505 go _ (HsAppTy t1 t2) acc = gol t1 (t2:acc)
507 parseError l "Malformed head of type or class declaration"
509 -- The predicates in a type or class decl must be class predicates or
510 -- equational constraints. They need not all have variable-only
511 -- arguments, even in Haskell 98.
512 -- E.g. class (Monad m, Monad (t m)) => MonadT t m
513 chk_pred (L _ (HsClassP _ _)) = return ()
514 chk_pred (L _ (HsEqualP _ _)) = return ()
516 = parseError l "Malformed context in type or class declaration"
518 -- Extract the type variables of a list of type parameters.
520 -- * Type arguments can be complex type terms (needed for associated type
523 extractTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
524 extractTyVars tvs = collects tvs []
526 -- Collect all variables (2nd arg serves as an accumulator)
527 collect :: LHsType RdrName -> [LHsTyVarBndr RdrName]
528 -> P [LHsTyVarBndr RdrName]
529 collect (L l (HsForAllTy _ _ _ _)) =
530 const $ parseError l "Forall type not allowed as type parameter"
531 collect (L l (HsTyVar tv))
532 | isRdrTyVar tv = return . (L l (UserTyVar tv) :)
534 collect (L l (HsBangTy _ _ )) =
535 const $ parseError l "Bang-style type annotations not allowed as type parameter"
536 collect (L _ (HsAppTy t1 t2 )) = collect t2 >=> collect t1
537 collect (L _ (HsFunTy t1 t2 )) = collect t2 >=> collect t1
538 collect (L _ (HsListTy t )) = collect t
539 collect (L _ (HsPArrTy t )) = collect t
540 collect (L _ (HsTupleTy _ ts )) = collects ts
541 collect (L _ (HsOpTy t1 _ t2 )) = collect t2 >=> collect t1
542 collect (L _ (HsParTy t )) = collect t
543 collect (L _ (HsNumTy _ )) = return
544 collect (L l (HsPredTy _ )) =
545 const $ parseError l "Predicate not allowed as type parameter"
546 collect (L l (HsKindSig (L _ ty) k))
547 | HsTyVar tv <- ty, isRdrTyVar tv
548 = return . (L l (KindedTyVar tv k) :)
550 = const $ parseError l "Kind signature only allowed for type variables"
551 collect (L l (HsSpliceTy _ )) =
552 const $ parseError l "Splice not allowed as type parameter"
553 collect (L _ (HsDocTy t _ )) = collect t
555 -- Collect all variables of a list of types
557 collects (t:ts) = collects ts >=> collect t
559 (f >=> g) x = f x >>= g
561 -- Check that associated type declarations of a class are all kind signatures.
563 checkKindSigs :: [LTyClDecl RdrName] -> P ()
564 checkKindSigs = mapM_ check
567 | isFamilyDecl tydecl
568 || isSynDecl tydecl = return ()
570 parseError l "Type declaration in a class must be a kind signature or synonym default"
572 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
576 check (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
577 = do ctx <- mapM checkPred ts
580 check (HsParTy ty) -- to be sure HsParTy doesn't get into the way
583 check (HsTyVar t) -- Empty context shows up as a unit type ()
584 | t == getRdrName unitTyCon = return (L l [])
587 = do p <- checkPred (L l t)
591 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
592 -- Watch out.. in ...deriving( Show )... we use checkPred on
593 -- the list of partially applied predicates in the deriving,
594 -- so there can be zero args.
595 checkPred (L spn (HsPredTy (HsIParam n ty)))
596 = return (L spn (HsIParam n ty))
600 checkl (L l ty) args = check l ty args
602 check _loc (HsPredTy pred@(HsEqualP _ _))
604 = return $ L spn pred
605 check _loc (HsTyVar t) args | not (isRdrTyVar t)
606 = return (L spn (HsClassP t args))
607 check _loc (HsAppTy l r) args = checkl l (r:args)
608 check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
609 check _loc (HsParTy t) args = checkl t args
610 check loc _ _ = parseError loc
611 "malformed class assertion"
613 ---------------------------------------------------------------------------
614 -- Checking stand-alone deriving declarations
616 checkDerivDecl :: LDerivDecl RdrName -> P (LDerivDecl RdrName)
617 checkDerivDecl d@(L loc _) =
618 do stDerivOn <- extension standaloneDerivingEnabled
619 if stDerivOn then return d
620 else parseError loc "Illegal stand-alone deriving declaration (use -XStandaloneDeriving)"
622 ---------------------------------------------------------------------------
623 -- Checking statements in a do-expression
624 -- We parse do { e1 ; e2 ; }
625 -- as [ExprStmt e1, ExprStmt e2]
626 -- checkDo (a) checks that the last thing is an ExprStmt
627 -- (b) returns it separately
628 -- same comments apply for mdo as well
630 checkDo, checkMDo :: SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
632 checkDo = checkDoMDo "a " "'do'"
633 checkMDo = checkDoMDo "an " "'mdo'"
635 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
636 checkDoMDo _ nm loc [] = parseError loc ("Empty " ++ nm ++ " construct")
637 checkDoMDo pre nm _ ss = do
640 check [] = panic "RdrHsSyn:checkDoMDo"
641 check [L _ (ExprStmt e _ _)] = return ([], e)
642 check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
643 " construct must be an expression")
648 -- -------------------------------------------------------------------------
649 -- Checking Patterns.
651 -- We parse patterns as expressions and check for valid patterns below,
652 -- converting the expression into a pattern at the same time.
654 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
655 checkPattern e = checkLPat e
657 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
658 checkPatterns es = mapM checkPattern es
660 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
661 checkLPat e@(L l _) = checkPat l e []
663 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
664 checkPat loc (L l (HsVar c)) args
665 | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
666 checkPat loc e args -- OK to let this happen even if bang-patterns
667 -- are not enabled, because there is no valid
668 -- non-bang-pattern parse of (C ! e)
669 | Just (e', args') <- splitBang e
670 = do { args'' <- checkPatterns args'
671 ; checkPat loc e' (args'' ++ args) }
672 checkPat loc (L _ (HsApp f x)) args
673 = do { x <- checkLPat x; checkPat loc f (x:args) }
674 checkPat loc (L _ e) []
675 = do { p <- checkAPat loc e; return (L loc p) }
679 checkAPat :: SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
680 checkAPat loc e = case e of
681 EWildPat -> return (WildPat placeHolderType)
682 HsVar x | isQual x -> parseError loc ("Qualified variable in pattern: "
684 | otherwise -> return (VarPat x)
685 HsLit l -> return (LitPat l)
687 -- Overloaded numeric patterns (e.g. f 0 x = x)
688 -- Negation is recorded separately, so that the literal is zero or +ve
689 -- NB. Negative *primitive* literals are already handled by the lexer
690 HsOverLit pos_lit -> return (mkNPat pos_lit Nothing)
691 NegApp (L _ (HsOverLit pos_lit)) _
692 -> return (mkNPat pos_lit (Just noSyntaxExpr))
694 SectionR (L _ (HsVar bang)) e -- (! x)
696 -> do { bang_on <- extension bangPatEnabled
697 ; if bang_on then checkLPat e >>= (return . BangPat)
698 else parseError loc "Illegal bang-pattern (use -XBangPatterns)" }
700 ELazyPat e -> checkLPat e >>= (return . LazyPat)
701 EAsPat n e -> checkLPat e >>= (return . AsPat n)
702 -- view pattern is well-formed if the pattern is
703 EViewPat expr patE -> checkLPat patE >>= (return . (\p -> ViewPat expr p placeHolderType))
704 ExprWithTySig e t -> do e <- checkLPat e
705 -- Pattern signatures are parsed as sigtypes,
706 -- but they aren't explicit forall points. Hence
707 -- we have to remove the implicit forall here.
709 L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
711 return (SigPatIn e t')
714 OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
715 (L _ (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
717 -> return (mkNPlusKPat (L nloc n) lit)
719 OpApp l op _fix r -> do l <- checkLPat l
722 L cl (HsVar c) | isDataOcc (rdrNameOcc c)
723 -> return (ConPatIn (L cl c) (InfixCon l r))
726 HsPar e -> checkLPat e >>= (return . ParPat)
727 ExplicitList _ es -> do ps <- mapM checkLPat es
728 return (ListPat ps placeHolderType)
729 ExplicitPArr _ es -> do ps <- mapM checkLPat es
730 return (PArrPat ps placeHolderType)
732 ExplicitTuple es b -> do ps <- mapM checkLPat es
733 return (TuplePat ps b placeHolderType)
735 RecordCon c _ (HsRecFields fs dd)
736 -> do fs <- mapM checkPatField fs
737 return (ConPatIn c (RecCon (HsRecFields fs dd)))
738 HsQuasiQuoteE q -> return (QuasiQuotePat q)
740 HsType ty -> return (TypePat ty)
743 plus_RDR, bang_RDR :: RdrName
744 plus_RDR = mkUnqual varName (fsLit "+") -- Hack
745 bang_RDR = mkUnqual varName (fsLit "!") -- Hack
747 checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
748 checkPatField fld = do { p <- checkLPat (hsRecFieldArg fld)
749 ; return (fld { hsRecFieldArg = p }) }
751 patFail :: SrcSpan -> P a
752 patFail loc = parseError loc "Parse error in pattern"
755 ---------------------------------------------------------------------------
756 -- Check Equation Syntax
758 checkValDef :: LHsExpr RdrName
759 -> Maybe (LHsType RdrName)
760 -> Located (GRHSs RdrName)
761 -> P (HsBind RdrName)
763 checkValDef lhs (Just sig) grhss
764 -- x :: ty = rhs parses as a *pattern* binding
765 = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
767 checkValDef lhs opt_sig grhss
768 = do { mb_fun <- isFunLhs lhs
770 Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
771 fun is_infix pats opt_sig grhss
772 Nothing -> checkPatBind lhs grhss }
774 checkFunBind :: SrcSpan
778 -> Maybe (LHsType RdrName)
779 -> Located (GRHSs RdrName)
780 -> P (HsBind RdrName)
781 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
783 = parseErrorSDoc (getLoc fun)
784 (ptext (sLit "Qualified name in function definition:") <+> ppr (unLoc fun))
786 = do ps <- checkPatterns pats
787 let match_span = combineSrcSpans lhs_loc rhs_span
788 return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
789 -- The span of the match covers the entire equation.
790 -- That isn't quite right, but it'll do for now.
792 makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
793 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
794 makeFunBind fn is_infix ms
795 = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
796 fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
798 checkPatBind :: LHsExpr RdrName
799 -> Located (GRHSs RdrName)
800 -> P (HsBind RdrName)
801 checkPatBind lhs (L _ grhss)
802 = do { lhs <- checkPattern lhs
803 ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
809 checkValSig (L l (HsVar v)) ty
810 | isUnqual v && not (isDataOcc (rdrNameOcc v))
811 = return (TypeSig (L l v) ty)
812 checkValSig (L l _) _
813 = parseError l "Invalid type signature"
815 mkGadtDecl :: Located RdrName
816 -> LHsType RdrName -- assuming HsType
818 mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = mk_gadt_con name qvars cxt ty
819 mkGadtDecl name ty = mk_gadt_con name [] (noLoc []) ty
821 mk_gadt_con :: Located RdrName
822 -> [LHsTyVarBndr RdrName]
823 -> LHsContext RdrName
826 mk_gadt_con name qvars cxt ty
827 = ConDecl { con_name = name
828 , con_explicit = Implicit
831 , con_details = PrefixCon []
832 , con_res = ResTyGADT ty
833 , con_doc = Nothing }
834 -- NB: we put the whole constr type into the ResTyGADT for now;
835 -- the renamer will unravel it once it has sorted out
838 -- A variable binding is parsed as a FunBind.
841 -- The parser left-associates, so there should
842 -- not be any OpApps inside the e's
843 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
844 -- Splits (f ! g a b) into (f, [(! g), a, b])
845 splitBang (L loc (OpApp l_arg bang@(L _ (HsVar op)) _ r_arg))
846 | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
848 (arg1,argns) = split_bang r_arg []
849 split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
850 split_bang e es = (e,es)
851 splitBang _ = Nothing
853 isFunLhs :: LHsExpr RdrName
854 -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
855 -- Just (fun, is_infix, arg_pats) if e is a function LHS
857 -- The whole LHS is parsed as a single expression.
858 -- Any infix operators on the LHS will parse left-associatively
860 -- will parse (rather strangely) as
862 -- It's up to isFunLhs to sort out the mess
868 go (L loc (HsVar f)) es
869 | not (isRdrDataCon f) = return (Just (L loc f, False, es))
870 go (L _ (HsApp f e)) es = go f (e:es)
871 go (L _ (HsPar e)) es@(_:_) = go e es
873 -- For infix function defns, there should be only one infix *function*
874 -- (though there may be infix *datacons* involved too). So we don't
875 -- need fixity info to figure out which function is being defined.
876 -- a `K1` b `op` c `K2` d
878 -- (a `K1` b) `op` (c `K2` d)
879 -- The renamer checks later that the precedences would yield such a parse.
881 -- There is a complication to deal with bang patterns.
883 -- ToDo: what about this?
884 -- x + 1 `op` y = ...
886 go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
887 | Just (e',es') <- splitBang e
888 = do { bang_on <- extension bangPatEnabled
889 ; if bang_on then go e' (es' ++ es)
890 else return (Just (L loc' op, True, (l:r:es))) }
891 -- No bangs; behave just like the next case
892 | not (isRdrDataCon op) -- We have found the function!
893 = return (Just (L loc' op, True, (l:r:es)))
894 | otherwise -- Infix data con; keep going
895 = do { mb_l <- go l es
897 Just (op', True, j : k : es')
898 -> return (Just (op', True, j : op_app : es'))
900 op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
901 _ -> return Nothing }
902 go _ _ = return Nothing
904 ---------------------------------------------------------------------------
905 -- Miscellaneous utilities
907 checkPrecP :: Located Int -> P Int
909 | 0 <= i && i <= maxPrecedence = return i
910 | otherwise = parseError l "Precedence out of range"
915 -> ([HsRecField RdrName (LHsExpr RdrName)], Bool)
916 -> P (HsExpr RdrName)
918 mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) | isRdrDataCon c
919 = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd))
920 mkRecConstrOrUpdate exp loc (fs,dd)
921 | null fs = parseError loc "Empty record update"
922 | otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] [])
924 mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg
925 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
926 mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
928 mkInlineSpec :: Maybe Activation -> RuleMatchInfo -> Bool -> InlineSpec
929 -- The Maybe is becuase the user can omit the activation spec (and usually does)
930 mkInlineSpec Nothing match_info True = alwaysInlineSpec match_info
932 mkInlineSpec Nothing match_info False = neverInlineSpec match_info
934 mkInlineSpec (Just act) match_info inl = Inline (InlinePragma act match_info) inl
937 -----------------------------------------------------------------------------
938 -- utilities for foreign declarations
940 -- supported calling conventions
942 data CallConv = CCall CCallConv -- ccall or stdcall
945 -- construct a foreign import declaration
949 -> (Located FastString, Located RdrName, LHsType RdrName)
950 -> P (HsDecl RdrName)
951 mkImport (CCall cconv) safety (entity, v, ty) = do
952 importSpec <- parseCImport entity cconv safety v
953 return (ForD (ForeignImport v ty importSpec))
954 mkImport (DNCall ) _ (entity, v, ty) = do
955 spec <- parseDImport entity
956 return $ ForD (ForeignImport v ty (DNImport spec))
958 -- parse the entity string of a foreign import declaration for the `ccall' or
959 -- `stdcall' calling convention'
961 parseCImport :: Located FastString
966 parseCImport (L loc entity) cconv safety v
967 -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
968 | entity == fsLit "dynamic" =
969 return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
970 | entity == fsLit "wrapper" =
971 return $ CImport cconv safety nilFS nilFS CWrapper
972 | otherwise = parse0 (unpackFS entity)
974 -- using the static keyword?
975 parse0 (' ': rest) = parse0 rest
976 parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
977 parse0 rest = parse1 rest
978 -- check for header file name
979 parse1 "" = parse4 "" nilFS False nilFS
980 parse1 (' ':rest) = parse1 rest
981 parse1 str@('&':_ ) = parse2 str nilFS
982 parse1 str@('[':_ ) = parse3 str nilFS False
984 | ".h" `isSuffixOf` first = parse2 rest (mkFastString first)
985 | otherwise = parse4 str nilFS False nilFS
987 (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
988 -- check for address operator (indicating a label import)
989 parse2 "" header = parse4 "" header False nilFS
990 parse2 (' ':rest) header = parse2 rest header
991 parse2 ('&':rest) header = parse3 rest header True
992 parse2 str@('[':_ ) header = parse3 str header False
993 parse2 str header = parse4 str header False nilFS
994 -- check for library object name
995 parse3 (' ':rest) header isLbl = parse3 rest header isLbl
996 parse3 ('[':rest) header isLbl =
997 case break (== ']') rest of
998 (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib)
999 _ -> parseError loc "Missing ']' in entity"
1000 parse3 str header isLbl = parse4 str header isLbl nilFS
1001 -- check for name of C function
1002 parse4 "" header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
1003 parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib
1004 parse4 str header isLbl lib
1005 | all (== ' ') rest = build (mkFastString first) header isLbl lib
1006 | otherwise = parseError loc "Malformed entity string"
1008 (first, rest) = break (== ' ') str
1010 build cid header False lib = return $
1011 CImport cconv safety header lib (CFunction (StaticTarget cid))
1012 build cid header True lib = return $
1013 CImport cconv safety header lib (CLabel cid )
1016 -- Unravel a dotnet spec string.
1018 parseDImport :: Located FastString -> P DNCallSpec
1019 parseDImport (L loc entity) = parse0 comps
1021 comps = words (unpackFS entity)
1025 | x == "static" = parse1 True xs
1026 | otherwise = parse1 False (x:xs)
1029 parse1 isStatic (x:xs)
1030 | x == "method" = parse2 isStatic DNMethod xs
1031 | x == "field" = parse2 isStatic DNField xs
1032 | x == "ctor" = parse2 isStatic DNConstructor xs
1033 parse1 isStatic xs = parse2 isStatic DNMethod xs
1035 parse2 _ _ [] = d'oh
1036 parse2 isStatic kind (('[':x):xs) =
1039 vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
1041 parse2 isStatic kind xs = parse3 isStatic kind "" xs
1043 parse3 isStatic kind assem [x] =
1044 return (DNCallSpec isStatic kind assem x
1045 -- these will be filled in once known.
1046 (error "FFI-dotnet-args")
1047 (error "FFI-dotnet-result"))
1048 parse3 _ _ _ _ = d'oh
1050 d'oh = parseError loc "Malformed entity string"
1052 -- construct a foreign export declaration
1054 mkExport :: CallConv
1055 -> (Located FastString, Located RdrName, LHsType RdrName)
1056 -> P (HsDecl RdrName)
1057 mkExport (CCall cconv) (L _ entity, v, ty) = return $
1058 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
1060 entity' | nullFS entity = mkExtName (unLoc v)
1061 | otherwise = entity
1062 mkExport DNCall (L _ _, v, _) =
1063 parseError (getLoc v){-TODO: not quite right-}
1064 "Foreign export is not yet supported for .NET"
1066 -- Supplying the ext_name in a foreign decl is optional; if it
1067 -- isn't there, the Haskell name is assumed. Note that no transformation
1068 -- of the Haskell name is then performed, so if you foreign export (++),
1069 -- it's external name will be "++". Too bad; it's important because we don't
1070 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
1072 mkExtName :: RdrName -> CLabelString
1073 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
1077 -----------------------------------------------------------------------------
1081 parseError :: SrcSpan -> String -> P a
1082 parseError span s = parseErrorSDoc span (text s)
1084 parseErrorSDoc :: SrcSpan -> SDoc -> P a
1085 parseErrorSDoc span s = failSpanMsgP span s