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, InlineSpec(..), alwaysInlineSpec, neverInlineSpec )
62 import Lexer ( P, failSpanMsgP, extension, standaloneDerivingEnabled, bangPatEnabled )
63 import TysWiredIn ( unitTyCon )
64 import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
65 DNCallSpec(..), DNKind(..), CLabelString )
66 import OccName ( srcDataName, varName, isDataOcc, isTcOcc,
68 import PrelNames ( forall_tv_RDR )
70 import OrdList ( OrdList, fromOL )
71 import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag )
75 import List ( isSuffixOf, nubBy )
76 import Monad ( unless )
78 #include "HsVersions.h"
82 %************************************************************************
84 \subsection{A few functions over HsSyn at RdrName}
86 %************************************************************************
88 extractHsTyRdrNames finds the free variables of a HsType
89 It's used when making the for-alls explicit.
92 extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName]
93 extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty [])
95 extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName]
96 -- This one takes the context and tau-part of a
97 -- sigma type and returns their free type variables
98 extractHsRhoRdrTyVars ctxt ty
99 = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty [])
101 extract_lctxt :: Located [LHsPred RdrName] -> [Located RdrName] -> [Located RdrName]
102 extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt)
104 extract_pred :: HsPred RdrName -> [Located RdrName] -> [Located RdrName]
105 extract_pred (HsClassP _ tys) acc = foldr extract_lty acc tys
106 extract_pred (HsEqualP ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
107 extract_pred (HsIParam _ ty ) acc = extract_lty ty acc
109 extract_lty :: LHsType RdrName -> [Located RdrName] -> [Located RdrName]
110 extract_lty (L loc ty) acc
112 HsTyVar tv -> extract_tv loc tv acc
113 HsBangTy _ ty -> extract_lty ty acc
114 HsAppTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
115 HsListTy ty -> extract_lty ty acc
116 HsPArrTy ty -> extract_lty ty acc
117 HsTupleTy _ tys -> foldr extract_lty acc tys
118 HsFunTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
119 HsPredTy p -> extract_pred p acc
120 HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
121 HsParTy ty -> extract_lty ty acc
123 HsSpliceTy _ -> acc -- Type splices mention no type variables
124 HsKindSig ty _ -> extract_lty ty acc
125 HsForAllTy _ [] cx ty -> extract_lctxt cx (extract_lty ty acc)
126 HsForAllTy _ tvs cx ty -> acc ++ (filter ((`notElem` locals) . unLoc) $
127 extract_lctxt cx (extract_lty ty []))
129 locals = hsLTyVarNames tvs
130 HsDocTy ty _ -> extract_lty ty acc
132 extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName]
133 extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc
136 extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName]
137 -- Get the type variables out of the type patterns in a bunch of
138 -- possibly-generic bindings in a class declaration
139 extractGenericPatTyVars binds
140 = nubBy eqLocated (foldrBag get [] binds)
142 get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms
145 get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
150 %************************************************************************
152 \subsection{Construction functions for Rdr stuff}
154 %************************************************************************
156 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
157 by deriving them from the name of the class. We fill in the names for the
158 tycon and datacon corresponding to the class, by deriving them from the
159 name of the class itself. This saves recording the names in the interface
160 file (which would be equally good).
162 Similarly for mkConDecl, mkClassOpSig and default-method names.
164 *** See "THE NAMING STORY" in HsDecls ****
167 mkClassDecl :: (LHsContext name, Located name, [LHsTyVarBndr name])
168 -> [Located (FunDep name)]
174 mkClassDecl (cxt, cname, tyvars) fds sigs mbinds ats docs
175 = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
183 mkTyData :: NewOrData
187 Maybe [LHsType name])
190 -> Maybe [LHsType name]
192 mkTyData new_or_data (context, tname, tyvars, typats) ksig data_cons maybe_deriv
193 = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
194 tcdTyVars = tyvars, tcdTyPats = typats, tcdCons = data_cons,
195 tcdKindSig = ksig, tcdDerivs = maybe_deriv }
198 %************************************************************************
200 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
202 %************************************************************************
204 Function definitions are restructured here. Each is assumed to be recursive
205 initially, and non recursive definitions are discovered by the dependency
210 -- | Groups together bindings for a single function
211 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
212 cvTopDecls decls = go (fromOL decls)
214 go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
216 go (L l (ValD b) : ds) = L l' (ValD b') : go ds'
217 where (L l' b', ds') = getMonoBind (L l b) ds
218 go (d : ds) = d : go ds
220 -- Declaration list may only contain value bindings and signatures.
221 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
223 = case cvBindsAndSigs binding of
224 (mbs, sigs, tydecls, _) -> ASSERT( null tydecls )
227 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
228 -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl RdrName])
229 -- Input decls contain just value bindings and signatures
230 -- and in case of class or instance declarations also
231 -- associated type declarations. They might also contain Haddock comments.
232 cvBindsAndSigs fb = go (fromOL fb)
234 go [] = (emptyBag, [], [], [])
235 go (L l (SigD s) : ds) = (bs, L l s : ss, ts, docs)
236 where (bs, ss, ts, docs) = go ds
237 go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, docs)
238 where (b', ds') = getMonoBind (L l b) ds
239 (bs, ss, ts, docs) = go ds'
240 go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs)
241 where (bs, ss, ts, docs) = go ds
242 go (L l (DocD d) : ds) = (bs, ss, ts, (L l d) : docs)
243 where (bs, ss, ts, docs) = go ds
244 go (L _ d : _) = pprPanic "cvBindsAndSigs" (ppr d)
246 -----------------------------------------------------------------------------
247 -- Group function bindings into equation groups
249 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
250 -> (LHsBind RdrName, [LHsDecl RdrName])
251 -- Suppose (b',ds') = getMonoBind b ds
252 -- ds is a list of parsed bindings
253 -- b is a MonoBinds that has just been read off the front
255 -- Then b' is the result of grouping more equations from ds that
256 -- belong with b into a single MonoBinds, and ds' is the depleted
257 -- list of parsed bindings.
259 -- All Haddock comments between equations inside the group are
262 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
264 getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1,
265 fun_matches = MatchGroup mtchs1 _ })) binds
267 = go is_infix1 mtchs1 loc1 binds []
269 go is_infix mtchs loc
270 (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
271 fun_matches = MatchGroup mtchs2 _ })) : binds) _
272 | f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs)
273 (combineSrcSpans loc loc2) binds []
274 go is_infix mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls
275 = let doc_decls' = doc_decl : doc_decls
276 in go is_infix mtchs (combineSrcSpans loc loc2) binds doc_decls'
277 go is_infix mtchs loc binds doc_decls
278 = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), (reverse doc_decls) ++ binds)
279 -- Reverse the final matches, to get it back in the right order
280 -- Do the same thing with the trailing doc comments
282 getMonoBind bind binds = (bind, binds)
284 has_args :: [LMatch RdrName] -> Bool
285 has_args [] = panic "RdrHsSyn:has_args"
286 has_args ((L _ (Match args _ _)) : _) = not (null args)
287 -- Don't group together FunBinds if they have
288 -- no arguments. This is necessary now that variable bindings
289 -- with no arguments are now treated as FunBinds rather
290 -- than pattern bindings (tests/rename/should_fail/rnfail002).
294 findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
295 findSplice ds = addl emptyRdrGroup ds
297 checkDecBrGroup :: [LHsDecl a] -> P (HsGroup a)
298 -- Turn the body of a [d| ... |] into a HsGroup
299 -- There should be no splices in the "..."
300 checkDecBrGroup decls
301 = case addl emptyRdrGroup decls of
302 (group, Nothing) -> return group
303 (_, Just (SpliceDecl (L loc _), _)) ->
304 parseError loc "Declaration splices are not permitted inside declaration brackets"
305 -- Why not? See Section 7.3 of the TH paper.
307 addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
308 -- This stuff reverses the declarations (again) but it doesn't matter
311 addl gp [] = (gp, Nothing)
312 addl gp (L l d : ds) = add gp l d ds
315 add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a]
316 -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
318 add gp _ (SpliceD e) ds = (gp, Just (e, ds))
320 -- Class declarations: pull out the fixity signatures to the top
321 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs})
324 let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
325 addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs}) ds
327 addl (gp { hs_tyclds = L l d : ts }) ds
329 -- Signatures: fixity sigs go a different place than all others
330 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
331 = addl (gp {hs_fixds = L l f : ts}) ds
332 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
333 = addl (gp {hs_valds = add_sig (L l d) ts}) ds
335 -- Value declarations: use add_bind
336 add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds
337 = addl (gp { hs_valds = add_bind (L l d) ts }) ds
339 -- The rest are routine
340 add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds
341 = addl (gp { hs_instds = L l d : ts }) ds
342 add gp@(HsGroup {hs_derivds = ts}) l (DerivD d) ds
343 = addl (gp { hs_derivds = L l d : ts }) ds
344 add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
345 = addl (gp { hs_defds = L l d : ts }) ds
346 add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
347 = addl (gp { hs_fords = L l d : ts }) ds
348 add gp@(HsGroup {hs_warnds = ts}) l (WarningD d) ds
349 = addl (gp { hs_warnds = L l d : ts }) ds
350 add gp@(HsGroup {hs_annds = ts}) l (AnnD d) ds
351 = addl (gp { hs_annds = L l d : ts }) ds
352 add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
353 = addl (gp { hs_ruleds = L l d : ts }) ds
356 = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds
358 add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
359 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
360 add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind"
362 add_sig :: LSig a -> HsValBinds a -> HsValBinds a
363 add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
364 add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig"
367 %************************************************************************
369 \subsection[PrefixToHS-utils]{Utilities for conversion}
371 %************************************************************************
375 -----------------------------------------------------------------------------
378 -- When parsing data declarations, we sometimes inadvertently parse
379 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
380 -- This function splits up the type application, adds any pending
381 -- arguments, and converts the type constructor back into a data constructor.
383 mkPrefixCon :: LHsType RdrName -> [LBangType RdrName]
384 -> P (Located RdrName, HsConDeclDetails RdrName)
388 split (L _ (HsAppTy t u)) ts = split t (u : ts)
389 split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc
390 return (data_con, PrefixCon ts)
391 split (L l _) _ = parseError l "parse error in data/newtype declaration"
393 mkRecCon :: Located RdrName ->
394 [([Located RdrName], LBangType RdrName, Maybe (LHsDoc RdrName))] ->
395 P (Located RdrName, HsConDeclDetails RdrName)
396 mkRecCon (L loc con) fields
397 = do data_con <- tyConToDataCon loc con
398 return (data_con, RecCon [ ConDeclField l t d | (ls, t, d) <- fields, l <- ls ])
400 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
401 tyConToDataCon loc tc
402 | isTcOcc (rdrNameOcc tc)
403 = return (L loc (setRdrNameSpace tc srcDataName))
405 = parseErrorSDoc loc (msg $$ extra)
407 msg = text "Not a data constructor:" <+> quotes (ppr tc)
408 extra | tc == forall_tv_RDR
409 = text "Perhaps you intended to use -XExistentialQuantification"
412 ----------------------------------------------------------------------------
413 -- Various Syntactic Checks
415 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
416 checkInstType (L l t)
418 HsForAllTy exp tvs ctxt ty -> do
419 dict_ty <- checkDictTy ty
420 return (L l (HsForAllTy exp tvs ctxt dict_ty))
422 HsParTy ty -> checkInstType ty
424 ty -> do dict_ty <- checkDictTy (L l ty)
425 return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
427 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
428 checkDictTy (L spn ty) = check ty []
430 check (HsTyVar t) args | not (isRdrTyVar t)
431 = return (L spn (HsPredTy (HsClassP t args)))
432 check (HsAppTy l r) args = check (unLoc l) (r:args)
433 check (HsParTy t) args = check (unLoc t) args
434 check _ _ = parseError spn "Malformed instance header"
436 -- Check whether the given list of type parameters are all type variables
437 -- (possibly with a kind signature). If the second argument is `False',
438 -- only type variables are allowed and we raise an error on encountering a
439 -- non-variable; otherwise, we allow non-variable arguments and return the
440 -- entire list of parameters.
442 checkTyVars :: [LHsType RdrName] -> P ()
443 checkTyVars tparms = mapM_ chk tparms
445 -- Check that the name space is correct!
446 chk (L _ (HsKindSig (L _ (HsTyVar tv)) _))
447 | isRdrTyVar tv = return ()
448 chk (L _ (HsTyVar tv))
449 | isRdrTyVar tv = return ()
451 parseError l "Type found where type variable expected"
453 -- Check whether the type arguments in a type synonym head are simply
454 -- variables. If not, we have a type family instance and return all patterns.
455 -- If yes, we return 'Nothing' as the third component to indicate a vanilla
458 checkSynHdr :: LHsType RdrName
459 -> Bool -- is type instance?
460 -> P (Located RdrName, -- head symbol
461 [LHsTyVarBndr RdrName], -- parameters
462 [LHsType RdrName]) -- type patterns
463 checkSynHdr ty isTyInst =
464 do { (_, tc, tvs, tparms) <- checkTyClHdr (noLoc []) ty
465 ; unless isTyInst $ checkTyVars tparms
466 ; return (tc, tvs, tparms) }
469 -- Well-formedness check and decomposition of type and class heads.
471 checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
472 -> P (LHsContext RdrName, -- the type context
473 Located RdrName, -- the head symbol (type or class name)
474 [LHsTyVarBndr RdrName], -- free variables of the non-context part
475 [LHsType RdrName]) -- parameters of head symbol
476 -- The header of a type or class decl should look like
477 -- (C a, D b) => T a b
481 -- With associated types, we can also have non-variable parameters; ie,
484 -- The unaltered parameter list is returned in the fourth component of the
488 -- ('()', 'T', ['a'], ['Int', '[a]'])
489 checkTyClHdr (L l cxt) ty
490 = do (tc, tvs, parms) <- gol ty []
492 return (L l cxt, tc, tvs, parms)
494 gol (L l ty) acc = go l ty acc
496 go l (HsTyVar tc) acc
497 | isRdrTc tc = do tvs <- extractTyVars acc
498 return (L l tc, tvs, acc)
499 go _ (HsOpTy t1 ltc@(L _ tc) t2) acc
500 | isRdrTc tc = do tvs <- extractTyVars (t1:t2:acc)
501 return (ltc, tvs, t1:t2:acc)
502 go _ (HsParTy ty) acc = gol ty acc
503 go _ (HsAppTy t1 t2) acc = gol t1 (t2:acc)
505 parseError l "Malformed head of type or class declaration"
507 -- The predicates in a type or class decl must be class predicates or
508 -- equational constraints. They need not all have variable-only
509 -- arguments, even in Haskell 98.
510 -- E.g. class (Monad m, Monad (t m)) => MonadT t m
511 chk_pred (L _ (HsClassP _ _)) = return ()
512 chk_pred (L _ (HsEqualP _ _)) = return ()
514 = parseError l "Malformed context in type or class declaration"
516 -- Extract the type variables of a list of type parameters.
518 -- * Type arguments can be complex type terms (needed for associated type
521 extractTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
522 extractTyVars tvs = collects tvs []
524 -- Collect all variables (2nd arg serves as an accumulator)
525 collect :: LHsType RdrName -> [LHsTyVarBndr RdrName]
526 -> P [LHsTyVarBndr RdrName]
527 collect (L l (HsForAllTy _ _ _ _)) =
528 const $ parseError l "Forall type not allowed as type parameter"
529 collect (L l (HsTyVar tv))
530 | isRdrTyVar tv = return . (L l (UserTyVar tv) :)
532 collect (L l (HsBangTy _ _ )) =
533 const $ parseError l "Bang-style type annotations not allowed as type parameter"
534 collect (L _ (HsAppTy t1 t2 )) = collect t2 >=> collect t1
535 collect (L _ (HsFunTy t1 t2 )) = collect t2 >=> collect t1
536 collect (L _ (HsListTy t )) = collect t
537 collect (L _ (HsPArrTy t )) = collect t
538 collect (L _ (HsTupleTy _ ts )) = collects ts
539 collect (L _ (HsOpTy t1 _ t2 )) = collect t2 >=> collect t1
540 collect (L _ (HsParTy t )) = collect t
541 collect (L _ (HsNumTy _ )) = return
542 collect (L l (HsPredTy _ )) =
543 const $ parseError l "Predicate not allowed as type parameter"
544 collect (L l (HsKindSig (L _ ty) k))
545 | HsTyVar tv <- ty, isRdrTyVar tv
546 = return . (L l (KindedTyVar tv k) :)
548 = const $ parseError l "Kind signature only allowed for type variables"
549 collect (L l (HsSpliceTy _ )) =
550 const $ parseError l "Splice not allowed as type parameter"
551 collect (L _ (HsDocTy t _ )) = collect t
553 -- Collect all variables of a list of types
555 collects (t:ts) = collects ts >=> collect t
557 (f >=> g) x = f x >>= g
559 -- Check that associated type declarations of a class are all kind signatures.
561 checkKindSigs :: [LTyClDecl RdrName] -> P ()
562 checkKindSigs = mapM_ check
565 | isFamilyDecl tydecl
566 || isSynDecl tydecl = return ()
568 parseError l "Type declaration in a class must be a kind signature or synonym default"
570 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
574 check (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
575 = do ctx <- mapM checkPred ts
578 check (HsParTy ty) -- to be sure HsParTy doesn't get into the way
581 check (HsTyVar t) -- Empty context shows up as a unit type ()
582 | t == getRdrName unitTyCon = return (L l [])
585 = do p <- checkPred (L l t)
589 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
590 -- Watch out.. in ...deriving( Show )... we use checkPred on
591 -- the list of partially applied predicates in the deriving,
592 -- so there can be zero args.
593 checkPred (L spn (HsPredTy (HsIParam n ty)))
594 = return (L spn (HsIParam n ty))
598 checkl (L l ty) args = check l ty args
600 check _loc (HsPredTy pred@(HsEqualP _ _))
602 = return $ L spn pred
603 check _loc (HsTyVar t) args | not (isRdrTyVar t)
604 = return (L spn (HsClassP t args))
605 check _loc (HsAppTy l r) args = checkl l (r:args)
606 check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
607 check _loc (HsParTy t) args = checkl t args
608 check loc _ _ = parseError loc
609 "malformed class assertion"
611 ---------------------------------------------------------------------------
612 -- Checking stand-alone deriving declarations
614 checkDerivDecl :: LDerivDecl RdrName -> P (LDerivDecl RdrName)
615 checkDerivDecl d@(L loc _) =
616 do stDerivOn <- extension standaloneDerivingEnabled
617 if stDerivOn then return d
618 else parseError loc "Illegal stand-alone deriving declaration (use -XStandaloneDeriving)"
620 ---------------------------------------------------------------------------
621 -- Checking statements in a do-expression
622 -- We parse do { e1 ; e2 ; }
623 -- as [ExprStmt e1, ExprStmt e2]
624 -- checkDo (a) checks that the last thing is an ExprStmt
625 -- (b) returns it separately
626 -- same comments apply for mdo as well
628 checkDo, checkMDo :: SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
630 checkDo = checkDoMDo "a " "'do'"
631 checkMDo = checkDoMDo "an " "'mdo'"
633 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
634 checkDoMDo _ nm loc [] = parseError loc ("Empty " ++ nm ++ " construct")
635 checkDoMDo pre nm _ ss = do
638 check [] = panic "RdrHsSyn:checkDoMDo"
639 check [L _ (ExprStmt e _ _)] = return ([], e)
640 check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
641 " construct must be an expression")
646 -- -------------------------------------------------------------------------
647 -- Checking Patterns.
649 -- We parse patterns as expressions and check for valid patterns below,
650 -- converting the expression into a pattern at the same time.
652 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
653 checkPattern e = checkLPat e
655 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
656 checkPatterns es = mapM checkPattern es
658 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
659 checkLPat e@(L l _) = checkPat l e []
661 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
662 checkPat loc (L l (HsVar c)) args
663 | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
664 checkPat loc e args -- OK to let this happen even if bang-patterns
665 -- are not enabled, because there is no valid
666 -- non-bang-pattern parse of (C ! e)
667 | Just (e', args') <- splitBang e
668 = do { args'' <- checkPatterns args'
669 ; checkPat loc e' (args'' ++ args) }
670 checkPat loc (L _ (HsApp f x)) args
671 = do { x <- checkLPat x; checkPat loc f (x:args) }
672 checkPat loc (L _ e) []
673 = do { p <- checkAPat loc e; return (L loc p) }
677 checkAPat :: SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
678 checkAPat loc e = case e of
679 EWildPat -> return (WildPat placeHolderType)
680 HsVar x | isQual x -> parseError loc ("Qualified variable in pattern: "
682 | otherwise -> return (VarPat x)
683 HsLit l -> return (LitPat l)
685 -- Overloaded numeric patterns (e.g. f 0 x = x)
686 -- Negation is recorded separately, so that the literal is zero or +ve
687 -- NB. Negative *primitive* literals are already handled by the lexer
688 HsOverLit pos_lit -> return (mkNPat pos_lit Nothing)
689 NegApp (L _ (HsOverLit pos_lit)) _
690 -> return (mkNPat pos_lit (Just noSyntaxExpr))
692 SectionR (L _ (HsVar bang)) e -- (! x)
694 -> do { bang_on <- extension bangPatEnabled
695 ; if bang_on then checkLPat e >>= (return . BangPat)
696 else parseError loc "Illegal bang-pattern (use -XBangPatterns)" }
698 ELazyPat e -> checkLPat e >>= (return . LazyPat)
699 EAsPat n e -> checkLPat e >>= (return . AsPat n)
700 -- view pattern is well-formed if the pattern is
701 EViewPat expr patE -> checkLPat patE >>= (return . (\p -> ViewPat expr p placeHolderType))
702 ExprWithTySig e t -> do e <- checkLPat e
703 -- Pattern signatures are parsed as sigtypes,
704 -- but they aren't explicit forall points. Hence
705 -- we have to remove the implicit forall here.
707 L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
709 return (SigPatIn e t')
712 OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
713 (L _ (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
715 -> return (mkNPlusKPat (L nloc n) lit)
717 OpApp l op _fix r -> do l <- checkLPat l
720 L cl (HsVar c) | isDataOcc (rdrNameOcc c)
721 -> return (ConPatIn (L cl c) (InfixCon l r))
724 HsPar e -> checkLPat e >>= (return . ParPat)
725 ExplicitList _ es -> do ps <- mapM checkLPat es
726 return (ListPat ps placeHolderType)
727 ExplicitPArr _ es -> do ps <- mapM checkLPat es
728 return (PArrPat ps placeHolderType)
730 ExplicitTuple es b -> do ps <- mapM checkLPat es
731 return (TuplePat ps b placeHolderType)
733 RecordCon c _ (HsRecFields fs dd)
734 -> do fs <- mapM checkPatField fs
735 return (ConPatIn c (RecCon (HsRecFields fs dd)))
736 HsQuasiQuoteE q -> return (QuasiQuotePat q)
738 HsType ty -> return (TypePat ty)
741 plus_RDR, bang_RDR :: RdrName
742 plus_RDR = mkUnqual varName (fsLit "+") -- Hack
743 bang_RDR = mkUnqual varName (fsLit "!") -- Hack
745 checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
746 checkPatField fld = do { p <- checkLPat (hsRecFieldArg fld)
747 ; return (fld { hsRecFieldArg = p }) }
749 patFail :: SrcSpan -> P a
750 patFail loc = parseError loc "Parse error in pattern"
753 ---------------------------------------------------------------------------
754 -- Check Equation Syntax
756 checkValDef :: LHsExpr RdrName
757 -> Maybe (LHsType RdrName)
758 -> Located (GRHSs RdrName)
759 -> P (HsBind RdrName)
761 checkValDef lhs (Just sig) grhss
762 -- x :: ty = rhs parses as a *pattern* binding
763 = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
765 checkValDef lhs opt_sig grhss
766 = do { mb_fun <- isFunLhs lhs
768 Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
769 fun is_infix pats opt_sig grhss
770 Nothing -> checkPatBind lhs grhss }
772 checkFunBind :: SrcSpan
776 -> Maybe (LHsType RdrName)
777 -> Located (GRHSs RdrName)
778 -> P (HsBind RdrName)
779 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
781 = parseErrorSDoc (getLoc fun)
782 (ptext (sLit "Qualified name in function definition:") <+> ppr (unLoc fun))
784 = do ps <- checkPatterns pats
785 let match_span = combineSrcSpans lhs_loc rhs_span
786 return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
787 -- The span of the match covers the entire equation.
788 -- That isn't quite right, but it'll do for now.
790 makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
791 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
792 makeFunBind fn is_infix ms
793 = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
794 fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
796 checkPatBind :: LHsExpr RdrName
797 -> Located (GRHSs RdrName)
798 -> P (HsBind RdrName)
799 checkPatBind lhs (L _ grhss)
800 = do { lhs <- checkPattern lhs
801 ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
807 checkValSig (L l (HsVar v)) ty
808 | isUnqual v && not (isDataOcc (rdrNameOcc v))
809 = return (TypeSig (L l v) ty)
810 checkValSig (L l _) _
811 = parseError l "Invalid type signature"
813 mkGadtDecl :: Located RdrName
814 -> LHsType RdrName -- assuming HsType
816 mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = mk_gadt_con name qvars cxt ty
817 mkGadtDecl name ty = mk_gadt_con name [] (noLoc []) ty
819 mk_gadt_con :: Located RdrName
820 -> [LHsTyVarBndr RdrName]
821 -> LHsContext RdrName
824 mk_gadt_con name qvars cxt ty
825 = ConDecl { con_name = name
826 , con_explicit = Implicit
829 , con_details = PrefixCon []
830 , con_res = ResTyGADT ty
831 , con_doc = Nothing }
832 -- NB: we put the whole constr type into the ResTyGADT for now;
833 -- the renamer will unravel it once it has sorted out
836 -- A variable binding is parsed as a FunBind.
839 -- The parser left-associates, so there should
840 -- not be any OpApps inside the e's
841 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
842 -- Splits (f ! g a b) into (f, [(! g), a, b])
843 splitBang (L loc (OpApp l_arg bang@(L _ (HsVar op)) _ r_arg))
844 | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
846 (arg1,argns) = split_bang r_arg []
847 split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
848 split_bang e es = (e,es)
849 splitBang _ = Nothing
851 isFunLhs :: LHsExpr RdrName
852 -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
853 -- Just (fun, is_infix, arg_pats) if e is a function LHS
855 -- The whole LHS is parsed as a single expression.
856 -- Any infix operators on the LHS will parse left-associatively
858 -- will parse (rather strangely) as
860 -- It's up to isFunLhs to sort out the mess
866 go (L loc (HsVar f)) es
867 | not (isRdrDataCon f) = return (Just (L loc f, False, es))
868 go (L _ (HsApp f e)) es = go f (e:es)
869 go (L _ (HsPar e)) es@(_:_) = go e es
871 -- For infix function defns, there should be only one infix *function*
872 -- (though there may be infix *datacons* involved too). So we don't
873 -- need fixity info to figure out which function is being defined.
874 -- a `K1` b `op` c `K2` d
876 -- (a `K1` b) `op` (c `K2` d)
877 -- The renamer checks later that the precedences would yield such a parse.
879 -- There is a complication to deal with bang patterns.
881 -- ToDo: what about this?
882 -- x + 1 `op` y = ...
884 go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
885 | Just (e',es') <- splitBang e
886 = do { bang_on <- extension bangPatEnabled
887 ; if bang_on then go e' (es' ++ es)
888 else return (Just (L loc' op, True, (l:r:es))) }
889 -- No bangs; behave just like the next case
890 | not (isRdrDataCon op) -- We have found the function!
891 = return (Just (L loc' op, True, (l:r:es)))
892 | otherwise -- Infix data con; keep going
893 = do { mb_l <- go l es
895 Just (op', True, j : k : es')
896 -> return (Just (op', True, j : op_app : es'))
898 op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
899 _ -> return Nothing }
900 go _ _ = return Nothing
902 ---------------------------------------------------------------------------
903 -- Miscellaneous utilities
905 checkPrecP :: Located Int -> P Int
907 | 0 <= i && i <= maxPrecedence = return i
908 | otherwise = parseError l "Precedence out of range"
913 -> ([HsRecField RdrName (LHsExpr RdrName)], Bool)
914 -> P (HsExpr RdrName)
916 mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) | isRdrDataCon c
917 = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd))
918 mkRecConstrOrUpdate exp loc (fs,dd)
919 | null fs = parseError loc "Empty record update"
920 | otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] [])
922 mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg
923 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
924 mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
926 mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec
927 -- The Maybe is becuase the user can omit the activation spec (and usually does)
928 mkInlineSpec Nothing True = alwaysInlineSpec -- INLINE
929 mkInlineSpec Nothing False = neverInlineSpec -- NOINLINE
930 mkInlineSpec (Just act) inl = Inline act inl
933 -----------------------------------------------------------------------------
934 -- utilities for foreign declarations
936 -- supported calling conventions
938 data CallConv = CCall CCallConv -- ccall or stdcall
941 -- construct a foreign import declaration
945 -> (Located FastString, Located RdrName, LHsType RdrName)
946 -> P (HsDecl RdrName)
947 mkImport (CCall cconv) safety (entity, v, ty) = do
948 importSpec <- parseCImport entity cconv safety v
949 return (ForD (ForeignImport v ty importSpec))
950 mkImport (DNCall ) _ (entity, v, ty) = do
951 spec <- parseDImport entity
952 return $ ForD (ForeignImport v ty (DNImport spec))
954 -- parse the entity string of a foreign import declaration for the `ccall' or
955 -- `stdcall' calling convention'
957 parseCImport :: Located FastString
962 parseCImport (L loc entity) cconv safety v
963 -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
964 | entity == fsLit "dynamic" =
965 return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
966 | entity == fsLit "wrapper" =
967 return $ CImport cconv safety nilFS nilFS CWrapper
968 | otherwise = parse0 (unpackFS entity)
970 -- using the static keyword?
971 parse0 (' ': rest) = parse0 rest
972 parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
973 parse0 rest = parse1 rest
974 -- check for header file name
975 parse1 "" = parse4 "" nilFS False nilFS
976 parse1 (' ':rest) = parse1 rest
977 parse1 str@('&':_ ) = parse2 str nilFS
978 parse1 str@('[':_ ) = parse3 str nilFS False
980 | ".h" `isSuffixOf` first = parse2 rest (mkFastString first)
981 | otherwise = parse4 str nilFS False nilFS
983 (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
984 -- check for address operator (indicating a label import)
985 parse2 "" header = parse4 "" header False nilFS
986 parse2 (' ':rest) header = parse2 rest header
987 parse2 ('&':rest) header = parse3 rest header True
988 parse2 str@('[':_ ) header = parse3 str header False
989 parse2 str header = parse4 str header False nilFS
990 -- check for library object name
991 parse3 (' ':rest) header isLbl = parse3 rest header isLbl
992 parse3 ('[':rest) header isLbl =
993 case break (== ']') rest of
994 (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib)
995 _ -> parseError loc "Missing ']' in entity"
996 parse3 str header isLbl = parse4 str header isLbl nilFS
997 -- check for name of C function
998 parse4 "" header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
999 parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib
1000 parse4 str header isLbl lib
1001 | all (== ' ') rest = build (mkFastString first) header isLbl lib
1002 | otherwise = parseError loc "Malformed entity string"
1004 (first, rest) = break (== ' ') str
1006 build cid header False lib = return $
1007 CImport cconv safety header lib (CFunction (StaticTarget cid))
1008 build cid header True lib = return $
1009 CImport cconv safety header lib (CLabel cid )
1012 -- Unravel a dotnet spec string.
1014 parseDImport :: Located FastString -> P DNCallSpec
1015 parseDImport (L loc entity) = parse0 comps
1017 comps = words (unpackFS entity)
1021 | x == "static" = parse1 True xs
1022 | otherwise = parse1 False (x:xs)
1025 parse1 isStatic (x:xs)
1026 | x == "method" = parse2 isStatic DNMethod xs
1027 | x == "field" = parse2 isStatic DNField xs
1028 | x == "ctor" = parse2 isStatic DNConstructor xs
1029 parse1 isStatic xs = parse2 isStatic DNMethod xs
1031 parse2 _ _ [] = d'oh
1032 parse2 isStatic kind (('[':x):xs) =
1035 vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
1037 parse2 isStatic kind xs = parse3 isStatic kind "" xs
1039 parse3 isStatic kind assem [x] =
1040 return (DNCallSpec isStatic kind assem x
1041 -- these will be filled in once known.
1042 (error "FFI-dotnet-args")
1043 (error "FFI-dotnet-result"))
1044 parse3 _ _ _ _ = d'oh
1046 d'oh = parseError loc "Malformed entity string"
1048 -- construct a foreign export declaration
1050 mkExport :: CallConv
1051 -> (Located FastString, Located RdrName, LHsType RdrName)
1052 -> P (HsDecl RdrName)
1053 mkExport (CCall cconv) (L _ entity, v, ty) = return $
1054 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
1056 entity' | nullFS entity = mkExtName (unLoc v)
1057 | otherwise = entity
1058 mkExport DNCall (L _ _, v, _) =
1059 parseError (getLoc v){-TODO: not quite right-}
1060 "Foreign export is not yet supported for .NET"
1062 -- Supplying the ext_name in a foreign decl is optional; if it
1063 -- isn't there, the Haskell name is assumed. Note that no transformation
1064 -- of the Haskell name is then performed, so if you foreign export (++),
1065 -- it's external name will be "++". Too bad; it's important because we don't
1066 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
1068 mkExtName :: RdrName -> CLabelString
1069 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
1073 -----------------------------------------------------------------------------
1077 parseError :: SrcSpan -> String -> P a
1078 parseError span s = parseErrorSDoc span (text s)
1080 parseErrorSDoc :: SrcSpan -> SDoc -> P a
1081 parseErrorSDoc span s = failSpanMsgP span s