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])
39 checkTyVars, -- [LHsType RdrName] -> P ()
40 checkSynHdr, -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName])
41 checkTopTyClD, -- LTyClDecl RdrName -> P (HsDecl RdrName)
42 checkInstType, -- HsType -> P HsType
43 checkPattern, -- HsExp -> P HsPat
44 checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat]
45 checkDo, -- [Stmt] -> P [Stmt]
46 checkMDo, -- [Stmt] -> P [Stmt]
47 checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
48 checkValSig, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
49 parseError, -- String -> Pa
52 #include "HsVersions.h"
54 import HsSyn -- Lots of it
55 import RdrName ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc,
56 isRdrDataCon, isUnqual, getRdrName, isQual,
58 import BasicTypes ( maxPrecedence, Activation, InlineSpec(..), alwaysInlineSpec, neverInlineSpec )
59 import Lexer ( P, failSpanMsgP, extension, bangPatEnabled )
60 import TysWiredIn ( unitTyCon )
61 import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
62 DNCallSpec(..), DNKind(..), CLabelString )
63 import OccName ( srcDataName, varName, isDataOcc, isTcOcc,
66 import OrdList ( OrdList, fromOL )
67 import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag )
72 import List ( isSuffixOf, nubBy )
76 %************************************************************************
78 \subsection{A few functions over HsSyn at RdrName}
80 %************************************************************************
82 extractHsTyRdrNames finds the free variables of a HsType
83 It's used when making the for-alls explicit.
86 extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName]
87 extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty [])
89 extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName]
90 -- This one takes the context and tau-part of a
91 -- sigma type and returns their free type variables
92 extractHsRhoRdrTyVars ctxt ty
93 = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty [])
95 extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt)
97 extract_pred (HsClassP cls tys) acc = foldr extract_lty acc tys
98 extract_pred (HsIParam n ty) acc = extract_lty ty acc
100 extract_lty (L loc ty) acc
102 HsTyVar tv -> extract_tv loc tv acc
103 HsBangTy _ ty -> extract_lty ty acc
104 HsAppTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
105 HsListTy ty -> extract_lty ty acc
106 HsPArrTy ty -> extract_lty ty acc
107 HsTupleTy _ tys -> foldr extract_lty acc tys
108 HsFunTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
109 HsPredTy p -> extract_pred p acc
110 HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
111 HsParTy ty -> extract_lty ty acc
113 HsSpliceTy _ -> acc -- Type splices mention no type variables
114 HsKindSig ty k -> extract_lty ty acc
115 HsForAllTy exp [] cx ty -> extract_lctxt cx (extract_lty ty acc)
116 HsForAllTy exp tvs cx ty -> acc ++ (filter ((`notElem` locals) . unLoc) $
117 extract_lctxt cx (extract_lty ty []))
119 locals = hsLTyVarNames tvs
121 extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName]
122 extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc
125 extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName]
126 -- Get the type variables out of the type patterns in a bunch of
127 -- possibly-generic bindings in a class declaration
128 extractGenericPatTyVars binds
129 = nubBy eqLocated (foldrBag get [] binds)
131 get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms
134 get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
135 get_m other acc = acc
139 %************************************************************************
141 \subsection{Construction functions for Rdr stuff}
143 %************************************************************************
145 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
146 by deriving them from the name of the class. We fill in the names for the
147 tycon and datacon corresponding to the class, by deriving them from the
148 name of the class itself. This saves recording the names in the interface
149 file (which would be equally good).
151 Similarly for mkConDecl, mkClassOpSig and default-method names.
153 *** See "THE NAMING STORY" in HsDecls ****
156 mkClassDecl (cxt, cname, tyvars) fds sigs mbinds ats
157 = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
164 mkTyData new_or_data (context, tname, tyvars, typats) ksig data_cons maybe_deriv
165 = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
166 tcdTyVars = tyvars, tcdTyPats = typats, tcdCons = data_cons,
167 tcdKindSig = ksig, tcdDerivs = maybe_deriv }
171 mkHsNegApp :: LHsExpr RdrName -> HsExpr RdrName
172 -- RdrName If the type checker sees (negate 3#) it will barf, because negate
173 -- can't take an unboxed arg. But that is exactly what it will see when
174 -- we write "-3#". So we have to do the negation right now!
175 mkHsNegApp (L loc e) = f e
176 where f (HsLit (HsIntPrim i)) = HsLit (HsIntPrim (-i))
177 f (HsLit (HsFloatPrim i)) = HsLit (HsFloatPrim (-i))
178 f (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i))
179 f expr = NegApp (L loc e) noSyntaxExpr
182 %************************************************************************
184 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
186 %************************************************************************
188 Function definitions are restructured here. Each is assumed to be recursive
189 initially, and non recursive definitions are discovered by the dependency
194 -- | Groups together bindings for a single function
195 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
196 cvTopDecls decls = go (fromOL decls)
198 go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
200 go (L l (ValD b) : ds) = L l' (ValD b') : go ds'
201 where (L l' b', ds') = getMonoBind (L l b) ds
202 go (d : ds) = d : go ds
204 -- Declaration list may only contain value bindings and signatures
206 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
208 = case cvBindsAndSigs binding of
209 (mbs, sigs, []) -> -- list of type decls *always* empty
212 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
213 -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName])
214 -- Input decls contain just value bindings and signatures
215 -- and in case of class or instance declarations also
216 -- associated data or synonym definitions
217 cvBindsAndSigs fb = go (fromOL fb)
219 go [] = (emptyBag, [], [])
220 go (L l (SigD s) : ds) = (bs, L l s : ss, ts)
221 where (bs, ss, ts) = go ds
222 go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts)
223 where (b', ds') = getMonoBind (L l b) ds
224 (bs, ss, ts) = go ds'
225 go (L l (TyClD t): ds) = (bs, ss, L l t : ts)
226 where (bs, ss, ts) = go ds
228 -----------------------------------------------------------------------------
229 -- Group function bindings into equation groups
231 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
232 -> (LHsBind RdrName, [LHsDecl RdrName])
233 -- Suppose (b',ds') = getMonoBind b ds
234 -- ds is a list of parsed bindings
235 -- b is a MonoBinds that has just been read off the front
237 -- Then b' is the result of grouping more equations from ds that
238 -- belong with b into a single MonoBinds, and ds' is the depleted
239 -- list of parsed bindings.
241 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
243 getMonoBind (L loc1 bind@(FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1,
244 fun_matches = MatchGroup mtchs1 _ })) binds
246 = go is_infix1 mtchs1 loc1 binds
248 go is_infix mtchs loc
249 (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
250 fun_matches = MatchGroup mtchs2 _ })) : binds)
251 | f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs)
252 (combineSrcSpans loc loc2) binds
253 go is_infix mtchs loc binds
254 = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), binds)
255 -- Reverse the final matches, to get it back in the right order
257 getMonoBind bind binds = (bind, binds)
259 has_args ((L _ (Match args _ _)) : _) = not (null args)
260 -- Don't group together FunBinds if they have
261 -- no arguments. This is necessary now that variable bindings
262 -- with no arguments are now treated as FunBinds rather
263 -- than pattern bindings (tests/rename/should_fail/rnfail002).
267 findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
268 findSplice ds = addl emptyRdrGroup ds
270 mkGroup :: [LHsDecl a] -> HsGroup a
271 mkGroup ds = addImpDecls emptyRdrGroup ds
273 addImpDecls :: HsGroup a -> [LHsDecl a] -> HsGroup a
274 -- The decls are imported, and should not have a splice
275 addImpDecls group decls = case addl group decls of
276 (group', Nothing) -> group'
277 other -> panic "addImpDecls"
279 addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
280 -- This stuff reverses the declarations (again) but it doesn't matter
283 addl gp [] = (gp, Nothing)
284 addl gp (L l d : ds) = add gp l d ds
287 add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a]
288 -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
290 add gp l (SpliceD e) ds = (gp, Just (e, ds))
292 -- Class declarations: pull out the fixity signatures to the top
293 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
295 let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
296 addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs }) ds
298 addl (gp { hs_tyclds = L l d : ts }) ds
300 -- Signatures: fixity sigs go a different place than all others
301 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
302 = addl (gp {hs_fixds = L l f : ts}) ds
303 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
304 = addl (gp {hs_valds = add_sig (L l d) ts}) ds
306 -- Value declarations: use add_bind
307 add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds
308 = addl (gp { hs_valds = add_bind (L l d) ts }) ds
310 -- The rest are routine
311 add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds
312 = addl (gp { hs_instds = L l d : ts }) ds
313 add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
314 = addl (gp { hs_defds = L l d : ts }) ds
315 add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
316 = addl (gp { hs_fords = L l d : ts }) ds
317 add gp@(HsGroup {hs_depds = ts}) l (DeprecD d) ds
318 = addl (gp { hs_depds = L l d : ts }) ds
319 add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
320 = addl (gp { hs_ruleds = L l d : ts }) ds
322 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
323 add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
326 %************************************************************************
328 \subsection[PrefixToHS-utils]{Utilities for conversion}
330 %************************************************************************
334 -----------------------------------------------------------------------------
337 -- When parsing data declarations, we sometimes inadvertently parse
338 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
339 -- This function splits up the type application, adds any pending
340 -- arguments, and converts the type constructor back into a data constructor.
342 mkPrefixCon :: LHsType RdrName -> [LBangType RdrName]
343 -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
347 split (L _ (HsAppTy t u)) ts = split t (u : ts)
348 split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc
349 return (data_con, PrefixCon ts)
350 split (L l _) _ = parseError l "parse error in data/newtype declaration"
352 mkRecCon :: Located RdrName -> [([Located RdrName], LBangType RdrName)]
353 -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
354 mkRecCon (L loc con) fields
355 = do data_con <- tyConToDataCon loc con
356 return (data_con, RecCon [ (l,t) | (ls,t) <- fields, l <- ls ])
358 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
359 tyConToDataCon loc tc
360 | isTcOcc (rdrNameOcc tc)
361 = return (L loc (setRdrNameSpace tc srcDataName))
363 = parseError loc (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
365 ----------------------------------------------------------------------------
366 -- Various Syntactic Checks
368 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
369 checkInstType (L l t)
371 HsForAllTy exp tvs ctxt ty -> do
372 dict_ty <- checkDictTy ty
373 return (L l (HsForAllTy exp tvs ctxt dict_ty))
375 HsParTy ty -> checkInstType ty
377 ty -> do dict_ty <- checkDictTy (L l ty)
378 return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
380 -- Check that the given list of type parameters are all type variables
381 -- (possibly with a kind signature).
383 checkTyVars :: [LHsType RdrName] -> P ()
384 checkTyVars tvs = mapM_ chk tvs
386 -- Check that the name space is correct!
387 chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
388 | isRdrTyVar tv = return ()
389 chk (L l (HsTyVar tv))
390 | isRdrTyVar tv = return ()
392 = parseError l "Type found where type variable expected"
394 checkSynHdr :: LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName])
395 checkSynHdr ty = do { (_, tc, tvs, Just tparms) <- checkTyClHdr (noLoc []) ty
399 checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
400 -> P (LHsContext RdrName, -- the type context
401 Located RdrName, -- the head symbol (type or class name)
402 [LHsTyVarBndr RdrName], -- free variables of the non-context part
403 Maybe [LHsType RdrName]) -- parameters of head symbol; wrapped into
404 -- 'Maybe' for 'mkTyData'
405 -- The header of a type or class decl should look like
406 -- (C a, D b) => T a b
410 -- With associated types, we can also have non-variable parameters; ie,
412 -- The unaltered parameter list is returned in the fourth component of the
416 -- ('()', 'T', ['a'], Just ['Int', '[a]'])
417 checkTyClHdr (L l cxt) ty
418 = do (tc, tvs, parms) <- gol ty []
420 return (L l cxt, tc, tvs, Just parms)
422 gol (L l ty) acc = go l ty acc
424 go l (HsTyVar tc) acc
425 | not (isRdrTyVar tc) = do
426 tvs <- extractTyVars acc
427 return (L l tc, tvs, acc)
428 go l (HsOpTy t1 tc t2) acc = do
429 tvs <- extractTyVars (t1:t2:acc)
430 return (tc, tvs, acc)
431 go l (HsParTy ty) acc = gol ty acc
432 go l (HsAppTy t1 t2) acc = gol t1 (t2:acc)
434 parseError l "Malformed head of type or class declaration"
436 -- The predicates in a type or class decl must all
437 -- be HsClassPs. They need not all be type variables,
438 -- even in Haskell 98. E.g. class (Monad m, Monad (t m)) => MonadT t m
439 chk_pred (L l (HsClassP _ args)) = return ()
441 = parseError l "Malformed context in type or class declaration"
443 -- Extract the type variables of a list of type parameters.
445 -- * Type arguments can be complex type terms (needed for associated type
448 extractTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
449 extractTyVars tvs = collects [] tvs
451 -- Collect all variables (1st arg serves as an accumulator)
452 collect tvs (L l (HsForAllTy _ _ _ _)) =
453 parseError l "Forall type not allowed as type parameter"
454 collect tvs (L l (HsTyVar tv))
455 | isRdrTyVar tv = return $ L l (UserTyVar tv) : tvs
456 | otherwise = return tvs
457 collect tvs (L l (HsBangTy _ _ )) =
458 parseError l "Bang-style type annotations not allowed as type parameter"
459 collect tvs (L l (HsAppTy t1 t2 )) = do
460 tvs' <- collect tvs t2
462 collect tvs (L l (HsFunTy t1 t2 )) = do
463 tvs' <- collect tvs t2
465 collect tvs (L l (HsListTy t )) = collect tvs t
466 collect tvs (L l (HsPArrTy t )) = collect tvs t
467 collect tvs (L l (HsTupleTy _ ts )) = collects tvs ts
468 collect tvs (L l (HsOpTy t1 _ t2 )) = do
469 tvs' <- collect tvs t2
471 collect tvs (L l (HsParTy t )) = collect tvs t
472 collect tvs (L l (HsNumTy t )) = return tvs
473 collect tvs (L l (HsPredTy t )) =
474 parseError l "Predicate not allowed as type parameter"
475 collect tvs (L l (HsKindSig (L _ (HsTyVar tv)) k))
477 return $ L l (KindedTyVar tv k) : tvs
479 parseError l "Kind signature only allowed for type variables"
480 collect tvs (L l (HsSpliceTy t )) =
481 parseError l "Splice not allowed as type parameter"
483 -- Collect all variables of a list of types
484 collects tvs [] = return tvs
485 collects tvs (t:ts) = do
486 tvs' <- collects tvs ts
489 -- Wrap a toplevel type or class declaration into 'TyClDecl' after ensuring
490 -- that all type parameters are variables only (which is in contrast to
491 -- associated type declarations).
493 checkTopTyClD :: LTyClDecl RdrName -> P (HsDecl RdrName)
494 checkTopTyClD (L _ d@TyData {tcdTyPats = Just typats}) =
497 return $ TyClD d {tcdTyPats = Nothing}
498 checkTopTyClD (L _ d) = return $ TyClD d
500 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
504 check (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
505 = do ctx <- mapM checkPred ts
508 check (HsParTy ty) -- to be sure HsParTy doesn't get into the way
511 check (HsTyVar t) -- Empty context shows up as a unit type ()
512 | t == getRdrName unitTyCon = return (L l [])
515 = do p <- checkPred (L l t)
519 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
520 -- Watch out.. in ...deriving( Show )... we use checkPred on
521 -- the list of partially applied predicates in the deriving,
522 -- so there can be zero args.
523 checkPred (L spn (HsPredTy (HsIParam n ty)))
524 = return (L spn (HsIParam n ty))
528 checkl (L l ty) args = check l ty args
530 check _loc (HsTyVar t) args | not (isRdrTyVar t)
531 = return (L spn (HsClassP t args))
532 check _loc (HsAppTy l r) args = checkl l (r:args)
533 check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
534 check _loc (HsParTy t) args = checkl t args
535 check loc _ _ = parseError loc "malformed class assertion"
537 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
538 checkDictTy (L spn ty) = check ty []
540 check (HsTyVar t) args | not (isRdrTyVar t)
541 = return (L spn (HsPredTy (HsClassP t args)))
542 check (HsAppTy l r) args = check (unLoc l) (r:args)
543 check (HsParTy t) args = check (unLoc t) args
544 check _ _ = parseError spn "Malformed context in instance header"
546 ---------------------------------------------------------------------------
547 -- Checking statements in a do-expression
548 -- We parse do { e1 ; e2 ; }
549 -- as [ExprStmt e1, ExprStmt e2]
550 -- checkDo (a) checks that the last thing is an ExprStmt
551 -- (b) returns it separately
552 -- same comments apply for mdo as well
554 checkDo = checkDoMDo "a " "'do'"
555 checkMDo = checkDoMDo "an " "'mdo'"
557 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
558 checkDoMDo pre nm loc [] = parseError loc ("Empty " ++ nm ++ " construct")
559 checkDoMDo pre nm loc ss = do
562 check [L l (ExprStmt e _ _)] = return ([], e)
563 check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
564 " construct must be an expression")
569 -- -------------------------------------------------------------------------
570 -- Checking Patterns.
572 -- We parse patterns as expressions and check for valid patterns below,
573 -- converting the expression into a pattern at the same time.
575 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
576 checkPattern e = checkLPat e
578 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
579 checkPatterns es = mapM checkPattern es
581 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
582 checkLPat e@(L l _) = checkPat l e []
584 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
585 checkPat loc (L l (HsVar c)) args
586 | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
587 checkPat loc e args -- OK to let this happen even if bang-patterns
588 -- are not enabled, because there is no valid
589 -- non-bang-pattern parse of (C ! e)
590 | Just (e', args') <- splitBang e
591 = do { args'' <- checkPatterns args'
592 ; checkPat loc e' (args'' ++ args) }
593 checkPat loc (L _ (HsApp f x)) args
594 = do { x <- checkLPat x; checkPat loc f (x:args) }
595 checkPat loc (L _ e) []
596 = do { p <- checkAPat loc e; return (L loc p) }
597 checkPat loc pat _some_args
600 checkAPat loc e = case e of
601 EWildPat -> return (WildPat placeHolderType)
602 HsVar x | isQual x -> parseError loc ("Qualified variable in pattern: "
604 | otherwise -> return (VarPat x)
605 HsLit l -> return (LitPat l)
607 -- Overloaded numeric patterns (e.g. f 0 x = x)
608 -- Negation is recorded separately, so that the literal is zero or +ve
609 -- NB. Negative *primitive* literals are already handled by
610 -- RdrHsSyn.mkHsNegApp
611 HsOverLit pos_lit -> return (mkNPat pos_lit Nothing)
612 NegApp (L _ (HsOverLit pos_lit)) _
613 -> return (mkNPat pos_lit (Just noSyntaxExpr))
615 SectionR (L _ (HsVar bang)) e -- (! x)
617 -> do { bang_on <- extension bangPatEnabled
618 ; if bang_on then checkLPat e >>= (return . BangPat)
619 else parseError loc "Illegal bang-pattern (use -fbang-patterns)" }
621 ELazyPat e -> checkLPat e >>= (return . LazyPat)
622 EAsPat n e -> checkLPat e >>= (return . AsPat n)
623 ExprWithTySig e t -> checkLPat e >>= \e ->
624 -- Pattern signatures are parsed as sigtypes,
625 -- but they aren't explicit forall points. Hence
626 -- we have to remove the implicit forall here.
628 L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
631 return (SigPatIn e t')
634 OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
635 (L _ (HsOverLit lit@(HsIntegral _ _)))
637 -> return (mkNPlusKPat (L nloc n) lit)
639 OpApp l op fix r -> checkLPat l >>= \l ->
640 checkLPat r >>= \r ->
642 L cl (HsVar c) | isDataOcc (rdrNameOcc c)
643 -> return (ConPatIn (L cl c) (InfixCon l r))
646 HsPar e -> checkLPat e >>= (return . ParPat)
647 ExplicitList _ es -> mapM (\e -> checkLPat e) es >>= \ps ->
648 return (ListPat ps placeHolderType)
649 ExplicitPArr _ es -> mapM (\e -> checkLPat e) es >>= \ps ->
650 return (PArrPat ps placeHolderType)
652 ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
653 return (TuplePat ps b placeHolderType)
655 RecordCon c _ fs -> mapM checkPatField fs >>= \fs ->
656 return (ConPatIn c (RecCon fs))
658 HsType ty -> return (TypePat ty)
661 plus_RDR, bang_RDR :: RdrName
662 plus_RDR = mkUnqual varName FSLIT("+") -- Hack
663 bang_RDR = mkUnqual varName FSLIT("!") -- Hack
665 checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName)
666 checkPatField (n,e) = do
670 patFail loc = parseError loc "Parse error in pattern"
673 ---------------------------------------------------------------------------
674 -- Check Equation Syntax
676 checkValDef :: LHsExpr RdrName
677 -> Maybe (LHsType RdrName)
678 -> Located (GRHSs RdrName)
679 -> P (HsBind RdrName)
681 checkValDef lhs (Just sig) grhss
682 -- x :: ty = rhs parses as a *pattern* binding
683 = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
685 checkValDef lhs opt_sig grhss
686 = do { mb_fun <- isFunLhs lhs
688 Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
689 fun is_infix pats opt_sig grhss
690 Nothing -> checkPatBind lhs grhss }
692 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
694 = parseError (getLoc fun) ("Qualified name in function definition: " ++
695 showRdrName (unLoc fun))
697 = do ps <- checkPatterns pats
698 let match_span = combineSrcSpans lhs_loc rhs_span
699 return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
700 -- The span of the match covers the entire equation.
701 -- That isn't quite right, but it'll do for now.
703 makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
704 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
705 makeFunBind fn is_infix ms
706 = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
707 fun_co_fn = idCoercion, bind_fvs = placeHolderNames }
709 checkPatBind lhs (L _ grhss)
710 = do { lhs <- checkPattern lhs
711 ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
717 checkValSig (L l (HsVar v)) ty
718 | isUnqual v && not (isDataOcc (rdrNameOcc v))
719 = return (TypeSig (L l v) ty)
720 checkValSig (L l other) ty
721 = parseError l "Invalid type signature"
723 mkGadtDecl :: Located RdrName
724 -> LHsType RdrName -- assuming HsType
726 mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = mk_gadt_con name qvars cxt ty
727 mkGadtDecl name ty = mk_gadt_con name [] (noLoc []) ty
729 mk_gadt_con name qvars cxt ty
730 = ConDecl { con_name = name
731 , con_explicit = Implicit
734 , con_details = PrefixCon []
735 , con_res = ResTyGADT ty }
736 -- NB: we put the whole constr type into the ResTyGADT for now;
737 -- the renamer will unravel it once it has sorted out
740 -- A variable binding is parsed as a FunBind.
743 -- The parser left-associates, so there should
744 -- not be any OpApps inside the e's
745 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
746 -- Splits (f ! g a b) into (f, [(! g), a, g])
747 splitBang (L loc (OpApp l_arg bang@(L loc' (HsVar op)) _ r_arg))
748 | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
750 (arg1,argns) = split_bang r_arg []
751 split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
752 split_bang e es = (e,es)
753 splitBang other = Nothing
755 isFunLhs :: LHsExpr RdrName
756 -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
757 -- Just (fun, is_infix, arg_pats) if e is a function LHS
760 go (L loc (HsVar f)) es
761 | not (isRdrDataCon f) = return (Just (L loc f, False, es))
762 go (L _ (HsApp f e)) es = go f (e:es)
763 go (L _ (HsPar e)) es@(_:_) = go e es
765 -- For infix function defns, there should be only one infix *function*
766 -- (though there may be infix *datacons* involved too). So we don't
767 -- need fixity info to figure out which function is being defined.
768 -- a `K1` b `op` c `K2` d
770 -- (a `K1` b) `op` (c `K2` d)
771 -- The renamer checks later that the precedences would yield such a parse.
773 -- There is a complication to deal with bang patterns.
775 -- ToDo: what about this?
776 -- x + 1 `op` y = ...
778 go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
779 | Just (e',es') <- splitBang e
780 = do { bang_on <- extension bangPatEnabled
781 ; if bang_on then go e' (es' ++ es)
782 else return (Just (L loc' op, True, (l:r:es))) }
783 -- No bangs; behave just like the next case
784 | not (isRdrDataCon op) -- We have found the function!
785 = return (Just (L loc' op, True, (l:r:es)))
786 | otherwise -- Infix data con; keep going
787 = do { mb_l <- go l es
789 Just (op', True, j : k : es')
790 -> return (Just (op', True, j : op_app : es'))
792 op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
793 _ -> return Nothing }
794 go _ _ = return Nothing
796 ---------------------------------------------------------------------------
797 -- Miscellaneous utilities
799 checkPrecP :: Located Int -> P Int
801 | 0 <= i && i <= maxPrecedence = return i
802 | otherwise = parseError l "Precedence out of range"
807 -> HsRecordBinds RdrName
808 -> P (HsExpr RdrName)
810 mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
811 = return (RecordCon (L l c) noPostTcExpr fs)
812 mkRecConstrOrUpdate exp loc fs@(_:_)
813 = return (RecordUpd exp fs placeHolderType placeHolderType)
814 mkRecConstrOrUpdate _ loc []
815 = parseError loc "Empty record update"
817 mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec
818 -- The Maybe is becuase the user can omit the activation spec (and usually does)
819 mkInlineSpec Nothing True = alwaysInlineSpec -- INLINE
820 mkInlineSpec Nothing False = neverInlineSpec -- NOINLINE
821 mkInlineSpec (Just act) inl = Inline act inl
824 -----------------------------------------------------------------------------
825 -- utilities for foreign declarations
827 -- supported calling conventions
829 data CallConv = CCall CCallConv -- ccall or stdcall
832 -- construct a foreign import declaration
836 -> (Located FastString, Located RdrName, LHsType RdrName)
837 -> P (HsDecl RdrName)
838 mkImport (CCall cconv) safety (entity, v, ty) = do
839 importSpec <- parseCImport entity cconv safety v
840 return (ForD (ForeignImport v ty importSpec))
841 mkImport (DNCall ) _ (entity, v, ty) = do
842 spec <- parseDImport entity
843 return $ ForD (ForeignImport v ty (DNImport spec))
845 -- parse the entity string of a foreign import declaration for the `ccall' or
846 -- `stdcall' calling convention'
848 parseCImport :: Located FastString
853 parseCImport (L loc entity) cconv safety v
854 -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
855 | entity == FSLIT ("dynamic") =
856 return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
857 | entity == FSLIT ("wrapper") =
858 return $ CImport cconv safety nilFS nilFS CWrapper
859 | otherwise = parse0 (unpackFS entity)
861 -- using the static keyword?
862 parse0 (' ': rest) = parse0 rest
863 parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
864 parse0 rest = parse1 rest
865 -- check for header file name
866 parse1 "" = parse4 "" nilFS False nilFS
867 parse1 (' ':rest) = parse1 rest
868 parse1 str@('&':_ ) = parse2 str nilFS
869 parse1 str@('[':_ ) = parse3 str nilFS False
871 | ".h" `isSuffixOf` first = parse2 rest (mkFastString first)
872 | otherwise = parse4 str nilFS False nilFS
874 (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
875 -- check for address operator (indicating a label import)
876 parse2 "" header = parse4 "" header False nilFS
877 parse2 (' ':rest) header = parse2 rest header
878 parse2 ('&':rest) header = parse3 rest header True
879 parse2 str@('[':_ ) header = parse3 str header False
880 parse2 str header = parse4 str header False nilFS
881 -- check for library object name
882 parse3 (' ':rest) header isLbl = parse3 rest header isLbl
883 parse3 ('[':rest) header isLbl =
884 case break (== ']') rest of
885 (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib)
886 _ -> parseError loc "Missing ']' in entity"
887 parse3 str header isLbl = parse4 str header isLbl nilFS
888 -- check for name of C function
889 parse4 "" header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
890 parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib
891 parse4 str header isLbl lib
892 | all (== ' ') rest = build (mkFastString first) header isLbl lib
893 | otherwise = parseError loc "Malformed entity string"
895 (first, rest) = break (== ' ') str
897 build cid header False lib = return $
898 CImport cconv safety header lib (CFunction (StaticTarget cid))
899 build cid header True lib = return $
900 CImport cconv safety header lib (CLabel cid )
903 -- Unravel a dotnet spec string.
905 parseDImport :: Located FastString -> P DNCallSpec
906 parseDImport (L loc entity) = parse0 comps
908 comps = words (unpackFS entity)
912 | x == "static" = parse1 True xs
913 | otherwise = parse1 False (x:xs)
916 parse1 isStatic (x:xs)
917 | x == "method" = parse2 isStatic DNMethod xs
918 | x == "field" = parse2 isStatic DNField xs
919 | x == "ctor" = parse2 isStatic DNConstructor xs
920 parse1 isStatic xs = parse2 isStatic DNMethod xs
923 parse2 isStatic kind (('[':x):xs) =
926 vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
927 parse2 isStatic kind xs = parse3 isStatic kind "" xs
929 parse3 isStatic kind assem [x] =
930 return (DNCallSpec isStatic kind assem x
931 -- these will be filled in once known.
932 (error "FFI-dotnet-args")
933 (error "FFI-dotnet-result"))
934 parse3 _ _ _ _ = d'oh
936 d'oh = parseError loc "Malformed entity string"
938 -- construct a foreign export declaration
941 -> (Located FastString, Located RdrName, LHsType RdrName)
942 -> P (HsDecl RdrName)
943 mkExport (CCall cconv) (L loc entity, v, ty) = return $
944 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
946 entity' | nullFS entity = mkExtName (unLoc v)
948 mkExport DNCall (L loc entity, v, ty) =
949 parseError (getLoc v){-TODO: not quite right-}
950 "Foreign export is not yet supported for .NET"
952 -- Supplying the ext_name in a foreign decl is optional; if it
953 -- isn't there, the Haskell name is assumed. Note that no transformation
954 -- of the Haskell name is then performed, so if you foreign export (++),
955 -- it's external name will be "++". Too bad; it's important because we don't
956 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
958 mkExtName :: RdrName -> CLabelString
959 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
963 -----------------------------------------------------------------------------
967 showRdrName :: RdrName -> String
968 showRdrName r = showSDoc (ppr r)
970 parseError :: SrcSpan -> String -> P a
971 parseError span s = failSpanMsgP span s