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] -> Bool -> P ()
40 checkSynHdr, -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName], Maybe [LHsType 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 whether the given list of type parameters are all type variables
381 -- (possibly with a kind signature). If the second argument is `False', we
382 -- only type variables are allowed and we raise an error on encountering a
383 -- non-variable; otherwise, we return the entire list parameters iff at least
384 -- one is not a variable.
386 checkTyVars :: [LHsType RdrName] -> Bool -> P (Maybe [LHsType RdrName])
387 checkTyVars tparms nonVarsOk =
389 areVars <- mapM chk tparms
390 return $ if and areVars then Nothing else Just tparms
392 -- Check that the name space is correct!
393 chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
394 | isRdrTyVar tv = return True
395 chk (L l (HsTyVar tv))
396 | isRdrTyVar tv = return True
398 | nonVarsOk = return False
400 parseError l "Type found where type variable expected"
402 -- Check whether the type arguments in a type synonym head are simply
403 -- variables. If not, we have a type equation of a type function and return
406 checkSynHdr :: LHsType RdrName
407 -> Bool -- non-variables admitted?
408 -> P (Located RdrName, -- head symbol
409 [LHsTyVarBndr RdrName], -- parameters
410 Maybe [LHsType RdrName]) -- type patterns
411 checkSynHdr ty nonVarsOk =
412 do { (_, tc, tvs, Just tparms) <- checkTyClHdr (noLoc []) ty
413 ; typats <- checkTyVars tparms nonVarsOk
414 ; return (tc, tvs, typats) }
417 -- Well-formedness check and decomposition of type and class heads.
419 checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
420 -> P (LHsContext RdrName, -- the type context
421 Located RdrName, -- the head symbol (type or class name)
422 [LHsTyVarBndr RdrName], -- free variables of the non-context part
423 Maybe [LHsType RdrName]) -- parameters of head symbol; wrapped into
424 -- 'Maybe' for 'mkTyData'
425 -- The header of a type or class decl should look like
426 -- (C a, D b) => T a b
430 -- With associated types, we can also have non-variable parameters; ie,
432 -- The unaltered parameter list is returned in the fourth component of the
436 -- ('()', 'T', ['a'], Just ['Int', '[a]'])
437 checkTyClHdr (L l cxt) ty
438 = do (tc, tvs, parms) <- gol ty []
440 return (L l cxt, tc, tvs, Just parms)
442 gol (L l ty) acc = go l ty acc
444 go l (HsTyVar tc) acc
445 | not (isRdrTyVar tc) = do
446 tvs <- extractTyVars acc
447 return (L l tc, tvs, acc)
448 go l (HsOpTy t1 tc t2) acc = do
449 tvs <- extractTyVars (t1:t2:acc)
450 return (tc, tvs, acc)
451 go l (HsParTy ty) acc = gol ty acc
452 go l (HsAppTy t1 t2) acc = gol t1 (t2:acc)
454 parseError l "Malformed head of type or class declaration"
456 -- The predicates in a type or class decl must all
457 -- be HsClassPs. They need not all be type variables,
458 -- even in Haskell 98. E.g. class (Monad m, Monad (t m)) => MonadT t m
459 chk_pred (L l (HsClassP _ args)) = return ()
461 = parseError l "Malformed context in type or class declaration"
463 -- Extract the type variables of a list of type parameters.
465 -- * Type arguments can be complex type terms (needed for associated type
468 extractTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
469 extractTyVars tvs = collects [] tvs
471 -- Collect all variables (1st arg serves as an accumulator)
472 collect tvs (L l (HsForAllTy _ _ _ _)) =
473 parseError l "Forall type not allowed as type parameter"
474 collect tvs (L l (HsTyVar tv))
475 | isRdrTyVar tv = return $ L l (UserTyVar tv) : tvs
476 | otherwise = return tvs
477 collect tvs (L l (HsBangTy _ _ )) =
478 parseError l "Bang-style type annotations not allowed as type parameter"
479 collect tvs (L l (HsAppTy t1 t2 )) = do
480 tvs' <- collect tvs t2
482 collect tvs (L l (HsFunTy t1 t2 )) = do
483 tvs' <- collect tvs t2
485 collect tvs (L l (HsListTy t )) = collect tvs t
486 collect tvs (L l (HsPArrTy t )) = collect tvs t
487 collect tvs (L l (HsTupleTy _ ts )) = collects tvs ts
488 collect tvs (L l (HsOpTy t1 _ t2 )) = do
489 tvs' <- collect tvs t2
491 collect tvs (L l (HsParTy t )) = collect tvs t
492 collect tvs (L l (HsNumTy t )) = return tvs
493 collect tvs (L l (HsPredTy t )) =
494 parseError l "Predicate not allowed as type parameter"
495 collect tvs (L l (HsKindSig (L _ (HsTyVar tv)) k))
497 return $ L l (KindedTyVar tv k) : tvs
499 parseError l "Kind signature only allowed for type variables"
500 collect tvs (L l (HsSpliceTy t )) =
501 parseError l "Splice not allowed as type parameter"
503 -- Collect all variables of a list of types
504 collects tvs [] = return tvs
505 collects tvs (t:ts) = do
506 tvs' <- collects tvs ts
509 -- Wrap a toplevel type or class declaration into 'TyClDecl' after ensuring
510 -- that all type parameters are variables only (which is in contrast to
511 -- associated type declarations).
513 checkTopTyClD :: LTyClDecl RdrName -> P (HsDecl RdrName)
514 checkTopTyClD (L _ d@TyData {tcdTyPats = Just typats}) =
516 checkTyVars typats False
517 return $ TyClD d {tcdTyPats = Nothing}
518 checkTopTyClD (L _ d) = return $ TyClD d
520 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
524 check (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
525 = do ctx <- mapM checkPred ts
528 check (HsParTy ty) -- to be sure HsParTy doesn't get into the way
531 check (HsTyVar t) -- Empty context shows up as a unit type ()
532 | t == getRdrName unitTyCon = return (L l [])
535 = do p <- checkPred (L l t)
539 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
540 -- Watch out.. in ...deriving( Show )... we use checkPred on
541 -- the list of partially applied predicates in the deriving,
542 -- so there can be zero args.
543 checkPred (L spn (HsPredTy (HsIParam n ty)))
544 = return (L spn (HsIParam n ty))
548 checkl (L l ty) args = check l ty args
550 check _loc (HsTyVar t) args | not (isRdrTyVar t)
551 = return (L spn (HsClassP t args))
552 check _loc (HsAppTy l r) args = checkl l (r:args)
553 check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
554 check _loc (HsParTy t) args = checkl t args
555 check loc _ _ = parseError loc "malformed class assertion"
557 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
558 checkDictTy (L spn ty) = check ty []
560 check (HsTyVar t) args | not (isRdrTyVar t)
561 = return (L spn (HsPredTy (HsClassP t args)))
562 check (HsAppTy l r) args = check (unLoc l) (r:args)
563 check (HsParTy t) args = check (unLoc t) args
564 check _ _ = parseError spn "Malformed context in instance header"
566 ---------------------------------------------------------------------------
567 -- Checking statements in a do-expression
568 -- We parse do { e1 ; e2 ; }
569 -- as [ExprStmt e1, ExprStmt e2]
570 -- checkDo (a) checks that the last thing is an ExprStmt
571 -- (b) returns it separately
572 -- same comments apply for mdo as well
574 checkDo = checkDoMDo "a " "'do'"
575 checkMDo = checkDoMDo "an " "'mdo'"
577 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
578 checkDoMDo pre nm loc [] = parseError loc ("Empty " ++ nm ++ " construct")
579 checkDoMDo pre nm loc ss = do
582 check [L l (ExprStmt e _ _)] = return ([], e)
583 check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
584 " construct must be an expression")
589 -- -------------------------------------------------------------------------
590 -- Checking Patterns.
592 -- We parse patterns as expressions and check for valid patterns below,
593 -- converting the expression into a pattern at the same time.
595 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
596 checkPattern e = checkLPat e
598 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
599 checkPatterns es = mapM checkPattern es
601 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
602 checkLPat e@(L l _) = checkPat l e []
604 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
605 checkPat loc (L l (HsVar c)) args
606 | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
607 checkPat loc e args -- OK to let this happen even if bang-patterns
608 -- are not enabled, because there is no valid
609 -- non-bang-pattern parse of (C ! e)
610 | Just (e', args') <- splitBang e
611 = do { args'' <- checkPatterns args'
612 ; checkPat loc e' (args'' ++ args) }
613 checkPat loc (L _ (HsApp f x)) args
614 = do { x <- checkLPat x; checkPat loc f (x:args) }
615 checkPat loc (L _ e) []
616 = do { p <- checkAPat loc e; return (L loc p) }
617 checkPat loc pat _some_args
620 checkAPat loc e = case e of
621 EWildPat -> return (WildPat placeHolderType)
622 HsVar x | isQual x -> parseError loc ("Qualified variable in pattern: "
624 | otherwise -> return (VarPat x)
625 HsLit l -> return (LitPat l)
627 -- Overloaded numeric patterns (e.g. f 0 x = x)
628 -- Negation is recorded separately, so that the literal is zero or +ve
629 -- NB. Negative *primitive* literals are already handled by
630 -- RdrHsSyn.mkHsNegApp
631 HsOverLit pos_lit -> return (mkNPat pos_lit Nothing)
632 NegApp (L _ (HsOverLit pos_lit)) _
633 -> return (mkNPat pos_lit (Just noSyntaxExpr))
635 SectionR (L _ (HsVar bang)) e -- (! x)
637 -> do { bang_on <- extension bangPatEnabled
638 ; if bang_on then checkLPat e >>= (return . BangPat)
639 else parseError loc "Illegal bang-pattern (use -fbang-patterns)" }
641 ELazyPat e -> checkLPat e >>= (return . LazyPat)
642 EAsPat n e -> checkLPat e >>= (return . AsPat n)
643 ExprWithTySig e t -> checkLPat e >>= \e ->
644 -- Pattern signatures are parsed as sigtypes,
645 -- but they aren't explicit forall points. Hence
646 -- we have to remove the implicit forall here.
648 L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
651 return (SigPatIn e t')
654 OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
655 (L _ (HsOverLit lit@(HsIntegral _ _)))
657 -> return (mkNPlusKPat (L nloc n) lit)
659 OpApp l op fix r -> checkLPat l >>= \l ->
660 checkLPat r >>= \r ->
662 L cl (HsVar c) | isDataOcc (rdrNameOcc c)
663 -> return (ConPatIn (L cl c) (InfixCon l r))
666 HsPar e -> checkLPat e >>= (return . ParPat)
667 ExplicitList _ es -> mapM (\e -> checkLPat e) es >>= \ps ->
668 return (ListPat ps placeHolderType)
669 ExplicitPArr _ es -> mapM (\e -> checkLPat e) es >>= \ps ->
670 return (PArrPat ps placeHolderType)
672 ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
673 return (TuplePat ps b placeHolderType)
675 RecordCon c _ fs -> mapM checkPatField fs >>= \fs ->
676 return (ConPatIn c (RecCon fs))
678 HsType ty -> return (TypePat ty)
681 plus_RDR, bang_RDR :: RdrName
682 plus_RDR = mkUnqual varName FSLIT("+") -- Hack
683 bang_RDR = mkUnqual varName FSLIT("!") -- Hack
685 checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName)
686 checkPatField (n,e) = do
690 patFail loc = parseError loc "Parse error in pattern"
693 ---------------------------------------------------------------------------
694 -- Check Equation Syntax
696 checkValDef :: LHsExpr RdrName
697 -> Maybe (LHsType RdrName)
698 -> Located (GRHSs RdrName)
699 -> P (HsBind RdrName)
701 checkValDef lhs (Just sig) grhss
702 -- x :: ty = rhs parses as a *pattern* binding
703 = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
705 checkValDef lhs opt_sig grhss
706 = do { mb_fun <- isFunLhs lhs
708 Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
709 fun is_infix pats opt_sig grhss
710 Nothing -> checkPatBind lhs grhss }
712 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
714 = parseError (getLoc fun) ("Qualified name in function definition: " ++
715 showRdrName (unLoc fun))
717 = do ps <- checkPatterns pats
718 let match_span = combineSrcSpans lhs_loc rhs_span
719 return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
720 -- The span of the match covers the entire equation.
721 -- That isn't quite right, but it'll do for now.
723 makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
724 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
725 makeFunBind fn is_infix ms
726 = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
727 fun_co_fn = idCoercion, bind_fvs = placeHolderNames }
729 checkPatBind lhs (L _ grhss)
730 = do { lhs <- checkPattern lhs
731 ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
737 checkValSig (L l (HsVar v)) ty
738 | isUnqual v && not (isDataOcc (rdrNameOcc v))
739 = return (TypeSig (L l v) ty)
740 checkValSig (L l other) ty
741 = parseError l "Invalid type signature"
743 mkGadtDecl :: Located RdrName
744 -> LHsType RdrName -- assuming HsType
746 mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = mk_gadt_con name qvars cxt ty
747 mkGadtDecl name ty = mk_gadt_con name [] (noLoc []) ty
749 mk_gadt_con name qvars cxt ty
750 = ConDecl { con_name = name
751 , con_explicit = Implicit
754 , con_details = PrefixCon []
755 , con_res = ResTyGADT ty }
756 -- NB: we put the whole constr type into the ResTyGADT for now;
757 -- the renamer will unravel it once it has sorted out
760 -- A variable binding is parsed as a FunBind.
763 -- The parser left-associates, so there should
764 -- not be any OpApps inside the e's
765 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
766 -- Splits (f ! g a b) into (f, [(! g), a, g])
767 splitBang (L loc (OpApp l_arg bang@(L loc' (HsVar op)) _ r_arg))
768 | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
770 (arg1,argns) = split_bang r_arg []
771 split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
772 split_bang e es = (e,es)
773 splitBang other = Nothing
775 isFunLhs :: LHsExpr RdrName
776 -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
777 -- Just (fun, is_infix, arg_pats) if e is a function LHS
780 go (L loc (HsVar f)) es
781 | not (isRdrDataCon f) = return (Just (L loc f, False, es))
782 go (L _ (HsApp f e)) es = go f (e:es)
783 go (L _ (HsPar e)) es@(_:_) = go e es
785 -- For infix function defns, there should be only one infix *function*
786 -- (though there may be infix *datacons* involved too). So we don't
787 -- need fixity info to figure out which function is being defined.
788 -- a `K1` b `op` c `K2` d
790 -- (a `K1` b) `op` (c `K2` d)
791 -- The renamer checks later that the precedences would yield such a parse.
793 -- There is a complication to deal with bang patterns.
795 -- ToDo: what about this?
796 -- x + 1 `op` y = ...
798 go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
799 | Just (e',es') <- splitBang e
800 = do { bang_on <- extension bangPatEnabled
801 ; if bang_on then go e' (es' ++ es)
802 else return (Just (L loc' op, True, (l:r:es))) }
803 -- No bangs; behave just like the next case
804 | not (isRdrDataCon op) -- We have found the function!
805 = return (Just (L loc' op, True, (l:r:es)))
806 | otherwise -- Infix data con; keep going
807 = do { mb_l <- go l es
809 Just (op', True, j : k : es')
810 -> return (Just (op', True, j : op_app : es'))
812 op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
813 _ -> return Nothing }
814 go _ _ = return Nothing
816 ---------------------------------------------------------------------------
817 -- Miscellaneous utilities
819 checkPrecP :: Located Int -> P Int
821 | 0 <= i && i <= maxPrecedence = return i
822 | otherwise = parseError l "Precedence out of range"
827 -> HsRecordBinds RdrName
828 -> P (HsExpr RdrName)
830 mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
831 = return (RecordCon (L l c) noPostTcExpr fs)
832 mkRecConstrOrUpdate exp loc fs@(_:_)
833 = return (RecordUpd exp fs placeHolderType placeHolderType)
834 mkRecConstrOrUpdate _ loc []
835 = parseError loc "Empty record update"
837 mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec
838 -- The Maybe is becuase the user can omit the activation spec (and usually does)
839 mkInlineSpec Nothing True = alwaysInlineSpec -- INLINE
840 mkInlineSpec Nothing False = neverInlineSpec -- NOINLINE
841 mkInlineSpec (Just act) inl = Inline act inl
844 -----------------------------------------------------------------------------
845 -- utilities for foreign declarations
847 -- supported calling conventions
849 data CallConv = CCall CCallConv -- ccall or stdcall
852 -- construct a foreign import declaration
856 -> (Located FastString, Located RdrName, LHsType RdrName)
857 -> P (HsDecl RdrName)
858 mkImport (CCall cconv) safety (entity, v, ty) = do
859 importSpec <- parseCImport entity cconv safety v
860 return (ForD (ForeignImport v ty importSpec))
861 mkImport (DNCall ) _ (entity, v, ty) = do
862 spec <- parseDImport entity
863 return $ ForD (ForeignImport v ty (DNImport spec))
865 -- parse the entity string of a foreign import declaration for the `ccall' or
866 -- `stdcall' calling convention'
868 parseCImport :: Located FastString
873 parseCImport (L loc entity) cconv safety v
874 -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
875 | entity == FSLIT ("dynamic") =
876 return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
877 | entity == FSLIT ("wrapper") =
878 return $ CImport cconv safety nilFS nilFS CWrapper
879 | otherwise = parse0 (unpackFS entity)
881 -- using the static keyword?
882 parse0 (' ': rest) = parse0 rest
883 parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
884 parse0 rest = parse1 rest
885 -- check for header file name
886 parse1 "" = parse4 "" nilFS False nilFS
887 parse1 (' ':rest) = parse1 rest
888 parse1 str@('&':_ ) = parse2 str nilFS
889 parse1 str@('[':_ ) = parse3 str nilFS False
891 | ".h" `isSuffixOf` first = parse2 rest (mkFastString first)
892 | otherwise = parse4 str nilFS False nilFS
894 (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
895 -- check for address operator (indicating a label import)
896 parse2 "" header = parse4 "" header False nilFS
897 parse2 (' ':rest) header = parse2 rest header
898 parse2 ('&':rest) header = parse3 rest header True
899 parse2 str@('[':_ ) header = parse3 str header False
900 parse2 str header = parse4 str header False nilFS
901 -- check for library object name
902 parse3 (' ':rest) header isLbl = parse3 rest header isLbl
903 parse3 ('[':rest) header isLbl =
904 case break (== ']') rest of
905 (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib)
906 _ -> parseError loc "Missing ']' in entity"
907 parse3 str header isLbl = parse4 str header isLbl nilFS
908 -- check for name of C function
909 parse4 "" header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
910 parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib
911 parse4 str header isLbl lib
912 | all (== ' ') rest = build (mkFastString first) header isLbl lib
913 | otherwise = parseError loc "Malformed entity string"
915 (first, rest) = break (== ' ') str
917 build cid header False lib = return $
918 CImport cconv safety header lib (CFunction (StaticTarget cid))
919 build cid header True lib = return $
920 CImport cconv safety header lib (CLabel cid )
923 -- Unravel a dotnet spec string.
925 parseDImport :: Located FastString -> P DNCallSpec
926 parseDImport (L loc entity) = parse0 comps
928 comps = words (unpackFS entity)
932 | x == "static" = parse1 True xs
933 | otherwise = parse1 False (x:xs)
936 parse1 isStatic (x:xs)
937 | x == "method" = parse2 isStatic DNMethod xs
938 | x == "field" = parse2 isStatic DNField xs
939 | x == "ctor" = parse2 isStatic DNConstructor xs
940 parse1 isStatic xs = parse2 isStatic DNMethod xs
943 parse2 isStatic kind (('[':x):xs) =
946 vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
947 parse2 isStatic kind xs = parse3 isStatic kind "" xs
949 parse3 isStatic kind assem [x] =
950 return (DNCallSpec isStatic kind assem x
951 -- these will be filled in once known.
952 (error "FFI-dotnet-args")
953 (error "FFI-dotnet-result"))
954 parse3 _ _ _ _ = d'oh
956 d'oh = parseError loc "Malformed entity string"
958 -- construct a foreign export declaration
961 -> (Located FastString, Located RdrName, LHsType RdrName)
962 -> P (HsDecl RdrName)
963 mkExport (CCall cconv) (L loc entity, v, ty) = return $
964 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
966 entity' | nullFS entity = mkExtName (unLoc v)
968 mkExport DNCall (L loc entity, v, ty) =
969 parseError (getLoc v){-TODO: not quite right-}
970 "Foreign export is not yet supported for .NET"
972 -- Supplying the ext_name in a foreign decl is optional; if it
973 -- isn't there, the Haskell name is assumed. Note that no transformation
974 -- of the Haskell name is then performed, so if you foreign export (++),
975 -- it's external name will be "++". Too bad; it's important because we don't
976 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
978 mkExtName :: RdrName -> CLabelString
979 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
983 -----------------------------------------------------------------------------
987 showRdrName :: RdrName -> String
988 showRdrName r = showSDoc (ppr r)
990 parseError :: SrcSpan -> String -> P a
991 parseError span s = failSpanMsgP span s