2 % (c) The University of Glasgow, 1996-2003
4 Functions over HsSyn specialised to RdrName.
9 extractHsRhoRdrTyVars, extractGenericPatTyVars,
11 mkHsOpApp, mkClassDecl,
12 mkHsNegApp, mkHsIntegral, mkHsFractional,
14 mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec,
15 mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
22 -- Stuff to do with Foreign declarations
24 mkImport, -- CallConv -> Safety
25 -- -> (FastString, RdrName, RdrNameHsType)
28 -- -> (FastString, RdrName, RdrNameHsType)
30 mkExtName, -- RdrName -> CLabelString
31 mkGadtDecl, -- Located RdrName -> LHsType RdrName -> ConDecl RdrName
33 -- Bunch of functions in the parser monad for
34 -- checking and constructing values
35 checkPrecP, -- Int -> P Int
36 checkContext, -- HsType -> P HsContext
37 checkPred, -- HsType -> P HsPred
38 checkTyClHdr, -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName])
39 checkTyVars, -- [LHsType RdrName] -> Bool -> P ()
40 checkSynHdr, -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName], Maybe [LHsType RdrName])
41 checkKindSigs, -- [LTyClDecl RdrName] -> P ()
42 checkTopTypeD, -- LTyClDecl RdrName -> P (HsDecl RdrName)
43 checkInstType, -- HsType -> P HsType
44 checkPattern, -- HsExp -> P HsPat
45 checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat]
46 checkDo, -- [Stmt] -> P [Stmt]
47 checkMDo, -- [Stmt] -> P [Stmt]
48 checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
49 checkValSig, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
50 parseError, -- String -> Pa
53 #include "HsVersions.h"
55 import HsSyn -- Lots of it
56 import RdrName ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc,
57 isRdrDataCon, isUnqual, getRdrName, isQual,
59 import BasicTypes ( maxPrecedence, Activation, InlineSpec(..), alwaysInlineSpec, neverInlineSpec )
60 import Lexer ( P, failSpanMsgP, extension, bangPatEnabled )
61 import TysWiredIn ( unitTyCon )
62 import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
63 DNCallSpec(..), DNKind(..), CLabelString )
64 import OccName ( srcDataName, varName, isDataOcc, isTcOcc,
67 import OrdList ( OrdList, fromOL )
68 import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag )
73 import List ( isSuffixOf, nubBy )
77 %************************************************************************
79 \subsection{A few functions over HsSyn at RdrName}
81 %************************************************************************
83 extractHsTyRdrNames finds the free variables of a HsType
84 It's used when making the for-alls explicit.
87 extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName]
88 extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty [])
90 extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName]
91 -- This one takes the context and tau-part of a
92 -- sigma type and returns their free type variables
93 extractHsRhoRdrTyVars ctxt ty
94 = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty [])
96 extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt)
98 extract_pred (HsClassP cls tys) acc = foldr extract_lty acc tys
99 extract_pred (HsIParam n ty) acc = extract_lty ty acc
101 extract_lty (L loc ty) acc
103 HsTyVar tv -> extract_tv loc tv acc
104 HsBangTy _ ty -> extract_lty ty acc
105 HsAppTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
106 HsListTy ty -> extract_lty ty acc
107 HsPArrTy ty -> extract_lty ty acc
108 HsTupleTy _ tys -> foldr extract_lty acc tys
109 HsFunTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
110 HsPredTy p -> extract_pred p acc
111 HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
112 HsParTy ty -> extract_lty ty acc
114 HsSpliceTy _ -> acc -- Type splices mention no type variables
115 HsKindSig ty k -> extract_lty ty acc
116 HsForAllTy exp [] cx ty -> extract_lctxt cx (extract_lty ty acc)
117 HsForAllTy exp tvs cx ty -> acc ++ (filter ((`notElem` locals) . unLoc) $
118 extract_lctxt cx (extract_lty ty []))
120 locals = hsLTyVarNames tvs
122 extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName]
123 extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc
126 extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName]
127 -- Get the type variables out of the type patterns in a bunch of
128 -- possibly-generic bindings in a class declaration
129 extractGenericPatTyVars binds
130 = nubBy eqLocated (foldrBag get [] binds)
132 get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms
135 get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
136 get_m other acc = acc
140 %************************************************************************
142 \subsection{Construction functions for Rdr stuff}
144 %************************************************************************
146 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
147 by deriving them from the name of the class. We fill in the names for the
148 tycon and datacon corresponding to the class, by deriving them from the
149 name of the class itself. This saves recording the names in the interface
150 file (which would be equally good).
152 Similarly for mkConDecl, mkClassOpSig and default-method names.
154 *** See "THE NAMING STORY" in HsDecls ****
157 mkClassDecl (cxt, cname, tyvars) fds sigs mbinds ats
158 = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
165 mkTyData new_or_data (context, tname, tyvars, typats) ksig data_cons maybe_deriv
166 = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
167 tcdTyVars = tyvars, tcdTyPats = typats, tcdCons = data_cons,
168 tcdKindSig = ksig, tcdDerivs = maybe_deriv }
172 mkHsNegApp :: LHsExpr RdrName -> HsExpr RdrName
173 -- RdrName If the type checker sees (negate 3#) it will barf, because negate
174 -- can't take an unboxed arg. But that is exactly what it will see when
175 -- we write "-3#". So we have to do the negation right now!
176 mkHsNegApp (L loc e) = f e
177 where f (HsLit (HsIntPrim i)) = HsLit (HsIntPrim (-i))
178 f (HsLit (HsFloatPrim i)) = HsLit (HsFloatPrim (-i))
179 f (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i))
180 f expr = NegApp (L loc e) noSyntaxExpr
183 %************************************************************************
185 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
187 %************************************************************************
189 Function definitions are restructured here. Each is assumed to be recursive
190 initially, and non recursive definitions are discovered by the dependency
195 -- | Groups together bindings for a single function
196 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
197 cvTopDecls decls = go (fromOL decls)
199 go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
201 go (L l (ValD b) : ds) = L l' (ValD b') : go ds'
202 where (L l' b', ds') = getMonoBind (L l b) ds
203 go (d : ds) = d : go ds
205 -- Declaration list may only contain value bindings and signatures
207 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
209 = case cvBindsAndSigs binding of
210 (mbs, sigs, []) -> -- list of type decls *always* empty
213 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
214 -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName])
215 -- Input decls contain just value bindings and signatures
216 -- and in case of class or instance declarations also
217 -- associated type declarations
218 cvBindsAndSigs fb = go (fromOL fb)
220 go [] = (emptyBag, [], [])
221 go (L l (SigD s) : ds) = (bs, L l s : ss, ts)
222 where (bs, ss, ts) = go ds
223 go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts)
224 where (b', ds') = getMonoBind (L l b) ds
225 (bs, ss, ts) = go ds'
226 go (L l (TyClD t): ds) = (bs, ss, L l t : ts)
227 where (bs, ss, ts) = go ds
229 -----------------------------------------------------------------------------
230 -- Group function bindings into equation groups
232 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
233 -> (LHsBind RdrName, [LHsDecl RdrName])
234 -- Suppose (b',ds') = getMonoBind b ds
235 -- ds is a list of parsed bindings
236 -- b is a MonoBinds that has just been read off the front
238 -- Then b' is the result of grouping more equations from ds that
239 -- belong with b into a single MonoBinds, and ds' is the depleted
240 -- list of parsed bindings.
242 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
244 getMonoBind (L loc1 bind@(FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1,
245 fun_matches = MatchGroup mtchs1 _ })) binds
247 = go is_infix1 mtchs1 loc1 binds
249 go is_infix mtchs loc
250 (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
251 fun_matches = MatchGroup mtchs2 _ })) : binds)
252 | f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs)
253 (combineSrcSpans loc loc2) binds
254 go is_infix mtchs loc binds
255 = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), binds)
256 -- Reverse the final matches, to get it back in the right order
258 getMonoBind bind binds = (bind, binds)
260 has_args ((L _ (Match args _ _)) : _) = not (null args)
261 -- Don't group together FunBinds if they have
262 -- no arguments. This is necessary now that variable bindings
263 -- with no arguments are now treated as FunBinds rather
264 -- than pattern bindings (tests/rename/should_fail/rnfail002).
268 findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
269 findSplice ds = addl emptyRdrGroup ds
271 mkGroup :: [LHsDecl a] -> HsGroup a
272 mkGroup ds = addImpDecls emptyRdrGroup ds
274 addImpDecls :: HsGroup a -> [LHsDecl a] -> HsGroup a
275 -- The decls are imported, and should not have a splice
276 addImpDecls group decls = case addl group decls of
277 (group', Nothing) -> group'
278 other -> panic "addImpDecls"
280 addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
281 -- This stuff reverses the declarations (again) but it doesn't matter
284 addl gp [] = (gp, Nothing)
285 addl gp (L l d : ds) = add gp l d ds
288 add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a]
289 -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
291 add gp l (SpliceD e) ds = (gp, Just (e, ds))
293 -- Class declarations: pull out the fixity signatures to the top
294 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
296 let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
297 addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs }) ds
299 addl (gp { hs_tyclds = L l d : ts }) ds
301 -- Signatures: fixity sigs go a different place than all others
302 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
303 = addl (gp {hs_fixds = L l f : ts}) ds
304 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
305 = addl (gp {hs_valds = add_sig (L l d) ts}) ds
307 -- Value declarations: use add_bind
308 add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds
309 = addl (gp { hs_valds = add_bind (L l d) ts }) ds
311 -- The rest are routine
312 add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds
313 = addl (gp { hs_instds = L l d : ts }) ds
314 add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
315 = addl (gp { hs_defds = L l d : ts }) ds
316 add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
317 = addl (gp { hs_fords = L l d : ts }) ds
318 add gp@(HsGroup {hs_depds = ts}) l (DeprecD d) ds
319 = addl (gp { hs_depds = L l d : ts }) ds
320 add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
321 = addl (gp { hs_ruleds = L l d : ts }) ds
323 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
324 add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
327 %************************************************************************
329 \subsection[PrefixToHS-utils]{Utilities for conversion}
331 %************************************************************************
335 -----------------------------------------------------------------------------
338 -- When parsing data declarations, we sometimes inadvertently parse
339 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
340 -- This function splits up the type application, adds any pending
341 -- arguments, and converts the type constructor back into a data constructor.
343 mkPrefixCon :: LHsType RdrName -> [LBangType RdrName]
344 -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
348 split (L _ (HsAppTy t u)) ts = split t (u : ts)
349 split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc
350 return (data_con, PrefixCon ts)
351 split (L l _) _ = parseError l "parse error in data/newtype declaration"
353 mkRecCon :: Located RdrName -> [([Located RdrName], LBangType RdrName)]
354 -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
355 mkRecCon (L loc con) fields
356 = do data_con <- tyConToDataCon loc con
357 return (data_con, RecCon [ (l,t) | (ls,t) <- fields, l <- ls ])
359 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
360 tyConToDataCon loc tc
361 | isTcOcc (rdrNameOcc tc)
362 = return (L loc (setRdrNameSpace tc srcDataName))
364 = parseError loc (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
366 ----------------------------------------------------------------------------
367 -- Various Syntactic Checks
369 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
370 checkInstType (L l t)
372 HsForAllTy exp tvs ctxt ty -> do
373 dict_ty <- checkDictTy ty
374 return (L l (HsForAllTy exp tvs ctxt dict_ty))
376 HsParTy ty -> checkInstType ty
378 ty -> do dict_ty <- checkDictTy (L l ty)
379 return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
381 -- Check whether the given list of type parameters are all type variables
382 -- (possibly with a kind signature). If the second argument is `False', we
383 -- only type variables are allowed and we raise an error on encountering a
384 -- non-variable; otherwise, we return the entire list parameters iff at least
385 -- one is not a variable.
387 checkTyVars :: [LHsType RdrName] -> Bool -> P (Maybe [LHsType RdrName])
388 checkTyVars tparms nonVarsOk =
390 areVars <- mapM chk tparms
391 return $ if and areVars then Nothing else Just tparms
393 -- Check that the name space is correct!
394 chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
395 | isRdrTyVar tv = return True
396 chk (L l (HsTyVar tv))
397 | isRdrTyVar tv = return True
399 | nonVarsOk = return False
401 parseError l "Type found where type variable expected"
403 -- Check whether the type arguments in a type synonym head are simply
404 -- variables. If not, we have a type equation of a type function and return
405 -- all patterns. If yes, we return 'Nothing' as the third component to
406 -- indicate a vanilla type synonym.
408 checkSynHdr :: LHsType RdrName
409 -> Bool -- non-variables admitted?
410 -> P (Located RdrName, -- head symbol
411 [LHsTyVarBndr RdrName], -- parameters
412 Maybe [LHsType RdrName]) -- type patterns
413 checkSynHdr ty nonVarsOk =
414 do { (_, tc, tvs, tparms) <- checkTyClHdr (noLoc []) ty
415 ; typats <- checkTyVars tparms nonVarsOk
416 ; return (tc, tvs, typats) }
419 -- Well-formedness check and decomposition of type and class heads.
421 checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
422 -> P (LHsContext RdrName, -- the type context
423 Located RdrName, -- the head symbol (type or class name)
424 [LHsTyVarBndr RdrName], -- free variables of the non-context part
425 [LHsType RdrName]) -- parameters of head symbol
426 -- The header of a type or class decl should look like
427 -- (C a, D b) => T a b
431 -- With associated types, we can also have non-variable parameters; ie,
433 -- The unaltered parameter list is returned in the fourth component of the
437 -- ('()', 'T', ['a'], ['Int', '[a]'])
438 checkTyClHdr (L l cxt) ty
439 = do (tc, tvs, parms) <- gol ty []
441 return (L l cxt, tc, tvs, parms)
443 gol (L l ty) acc = go l ty acc
445 go l (HsTyVar tc) acc
446 | not (isRdrTyVar tc) = do
447 tvs <- extractTyVars acc
448 return (L l tc, tvs, acc)
449 go l (HsOpTy t1 tc t2) acc = do
450 tvs <- extractTyVars (t1:t2:acc)
451 return (tc, tvs, acc)
452 go l (HsParTy ty) acc = gol ty acc
453 go l (HsAppTy t1 t2) acc = gol t1 (t2:acc)
455 parseError l "Malformed head of type or class declaration"
457 -- The predicates in a type or class decl must all
458 -- be HsClassPs. They need not all be type variables,
459 -- even in Haskell 98. E.g. class (Monad m, Monad (t m)) => MonadT t m
460 chk_pred (L l (HsClassP _ args)) = return ()
462 = parseError l "Malformed context in type or class declaration"
464 -- Extract the type variables of a list of type parameters.
466 -- * Type arguments can be complex type terms (needed for associated type
469 extractTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
470 extractTyVars tvs = collects [] tvs
472 -- Collect all variables (1st arg serves as an accumulator)
473 collect tvs (L l (HsForAllTy _ _ _ _)) =
474 parseError l "Forall type not allowed as type parameter"
475 collect tvs (L l (HsTyVar tv))
476 | isRdrTyVar tv = return $ L l (UserTyVar tv) : tvs
477 | otherwise = return tvs
478 collect tvs (L l (HsBangTy _ _ )) =
479 parseError l "Bang-style type annotations not allowed as type parameter"
480 collect tvs (L l (HsAppTy t1 t2 )) = do
481 tvs' <- collect tvs t2
483 collect tvs (L l (HsFunTy t1 t2 )) = do
484 tvs' <- collect tvs t2
486 collect tvs (L l (HsListTy t )) = collect tvs t
487 collect tvs (L l (HsPArrTy t )) = collect tvs t
488 collect tvs (L l (HsTupleTy _ ts )) = collects tvs ts
489 collect tvs (L l (HsOpTy t1 _ t2 )) = do
490 tvs' <- collect tvs t2
492 collect tvs (L l (HsParTy t )) = collect tvs t
493 collect tvs (L l (HsNumTy t )) = return tvs
494 collect tvs (L l (HsPredTy t )) =
495 parseError l "Predicate not allowed as type parameter"
496 collect tvs (L l (HsKindSig (L _ (HsTyVar tv)) k))
498 return $ L l (KindedTyVar tv k) : tvs
500 parseError l "Kind signature only allowed for type variables"
501 collect tvs (L l (HsSpliceTy t )) =
502 parseError l "Splice not allowed as type parameter"
504 -- Collect all variables of a list of types
505 collects tvs [] = return tvs
506 collects tvs (t:ts) = do
507 tvs' <- collects tvs ts
510 -- Check that associated type declarations of a class are all kind signatures.
512 checkKindSigs :: [LTyClDecl RdrName] -> P ()
513 checkKindSigs = mapM_ check
516 | isKindSigDecl tydecl
517 || isSynDecl tydecl = return ()
519 parseError l "Type declaration in a class must be a kind signature or synonym default"
521 -- Wrap a toplevel type or data declaration into 'TyClD' and ensure for
522 -- data declarations that all type parameters are variables only (which is in
523 -- contrast to type functions and associated type declarations).
525 checkTopTypeD :: LTyClDecl RdrName -> P (HsDecl RdrName)
526 checkTopTypeD (L _ d@TyData {tcdTyPats = Just typats}) =
528 -- `tcdTyPats' will only be of the form `Just typats' if `typats' contains
529 -- a non-variable pattern. We call `checkTyPats' instead of raising an
530 -- error straight away, as `checkTyPats' raises the error at the location
531 -- of that non-variable pattern.
533 checkTyVars typats False
534 panic "checkTopTypeD: check on previous line should fail w/ a parse error"
535 checkTopTypeD (L _ d) = return $ TyClD d
537 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
541 check (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
542 = do ctx <- mapM checkPred ts
545 check (HsParTy ty) -- to be sure HsParTy doesn't get into the way
548 check (HsTyVar t) -- Empty context shows up as a unit type ()
549 | t == getRdrName unitTyCon = return (L l [])
552 = do p <- checkPred (L l t)
556 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
557 -- Watch out.. in ...deriving( Show )... we use checkPred on
558 -- the list of partially applied predicates in the deriving,
559 -- so there can be zero args.
560 checkPred (L spn (HsPredTy (HsIParam n ty)))
561 = return (L spn (HsIParam n ty))
565 checkl (L l ty) args = check l ty args
567 check _loc (HsTyVar t) args | not (isRdrTyVar t)
568 = return (L spn (HsClassP t args))
569 check _loc (HsAppTy l r) args = checkl l (r:args)
570 check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
571 check _loc (HsParTy t) args = checkl t args
572 check loc _ _ = parseError loc "malformed class assertion"
574 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
575 checkDictTy (L spn ty) = check ty []
577 check (HsTyVar t) args | not (isRdrTyVar t)
578 = return (L spn (HsPredTy (HsClassP t args)))
579 check (HsAppTy l r) args = check (unLoc l) (r:args)
580 check (HsParTy t) args = check (unLoc t) args
581 check _ _ = parseError spn "Malformed context in instance header"
583 ---------------------------------------------------------------------------
584 -- Checking statements in a do-expression
585 -- We parse do { e1 ; e2 ; }
586 -- as [ExprStmt e1, ExprStmt e2]
587 -- checkDo (a) checks that the last thing is an ExprStmt
588 -- (b) returns it separately
589 -- same comments apply for mdo as well
591 checkDo = checkDoMDo "a " "'do'"
592 checkMDo = checkDoMDo "an " "'mdo'"
594 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
595 checkDoMDo pre nm loc [] = parseError loc ("Empty " ++ nm ++ " construct")
596 checkDoMDo pre nm loc ss = do
599 check [L l (ExprStmt e _ _)] = return ([], e)
600 check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
601 " construct must be an expression")
606 -- -------------------------------------------------------------------------
607 -- Checking Patterns.
609 -- We parse patterns as expressions and check for valid patterns below,
610 -- converting the expression into a pattern at the same time.
612 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
613 checkPattern e = checkLPat e
615 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
616 checkPatterns es = mapM checkPattern es
618 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
619 checkLPat e@(L l _) = checkPat l e []
621 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
622 checkPat loc (L l (HsVar c)) args
623 | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
624 checkPat loc e args -- OK to let this happen even if bang-patterns
625 -- are not enabled, because there is no valid
626 -- non-bang-pattern parse of (C ! e)
627 | Just (e', args') <- splitBang e
628 = do { args'' <- checkPatterns args'
629 ; checkPat loc e' (args'' ++ args) }
630 checkPat loc (L _ (HsApp f x)) args
631 = do { x <- checkLPat x; checkPat loc f (x:args) }
632 checkPat loc (L _ e) []
633 = do { p <- checkAPat loc e; return (L loc p) }
634 checkPat loc pat _some_args
637 checkAPat loc e = case e of
638 EWildPat -> return (WildPat placeHolderType)
639 HsVar x | isQual x -> parseError loc ("Qualified variable in pattern: "
641 | otherwise -> return (VarPat x)
642 HsLit l -> return (LitPat l)
644 -- Overloaded numeric patterns (e.g. f 0 x = x)
645 -- Negation is recorded separately, so that the literal is zero or +ve
646 -- NB. Negative *primitive* literals are already handled by
647 -- RdrHsSyn.mkHsNegApp
648 HsOverLit pos_lit -> return (mkNPat pos_lit Nothing)
649 NegApp (L _ (HsOverLit pos_lit)) _
650 -> return (mkNPat pos_lit (Just noSyntaxExpr))
652 SectionR (L _ (HsVar bang)) e -- (! x)
654 -> do { bang_on <- extension bangPatEnabled
655 ; if bang_on then checkLPat e >>= (return . BangPat)
656 else parseError loc "Illegal bang-pattern (use -fbang-patterns)" }
658 ELazyPat e -> checkLPat e >>= (return . LazyPat)
659 EAsPat n e -> checkLPat e >>= (return . AsPat n)
660 ExprWithTySig e t -> checkLPat e >>= \e ->
661 -- Pattern signatures are parsed as sigtypes,
662 -- but they aren't explicit forall points. Hence
663 -- we have to remove the implicit forall here.
665 L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
668 return (SigPatIn e t')
671 OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
672 (L _ (HsOverLit lit@(HsIntegral _ _)))
674 -> return (mkNPlusKPat (L nloc n) lit)
676 OpApp l op fix r -> checkLPat l >>= \l ->
677 checkLPat r >>= \r ->
679 L cl (HsVar c) | isDataOcc (rdrNameOcc c)
680 -> return (ConPatIn (L cl c) (InfixCon l r))
683 HsPar e -> checkLPat e >>= (return . ParPat)
684 ExplicitList _ es -> mapM (\e -> checkLPat e) es >>= \ps ->
685 return (ListPat ps placeHolderType)
686 ExplicitPArr _ es -> mapM (\e -> checkLPat e) es >>= \ps ->
687 return (PArrPat ps placeHolderType)
689 ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
690 return (TuplePat ps b placeHolderType)
692 RecordCon c _ fs -> mapM checkPatField fs >>= \fs ->
693 return (ConPatIn c (RecCon fs))
695 HsType ty -> return (TypePat ty)
698 plus_RDR, bang_RDR :: RdrName
699 plus_RDR = mkUnqual varName FSLIT("+") -- Hack
700 bang_RDR = mkUnqual varName FSLIT("!") -- Hack
702 checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName)
703 checkPatField (n,e) = do
707 patFail loc = parseError loc "Parse error in pattern"
710 ---------------------------------------------------------------------------
711 -- Check Equation Syntax
713 checkValDef :: LHsExpr RdrName
714 -> Maybe (LHsType RdrName)
715 -> Located (GRHSs RdrName)
716 -> P (HsBind RdrName)
718 checkValDef lhs (Just sig) grhss
719 -- x :: ty = rhs parses as a *pattern* binding
720 = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
722 checkValDef lhs opt_sig grhss
723 = do { mb_fun <- isFunLhs lhs
725 Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
726 fun is_infix pats opt_sig grhss
727 Nothing -> checkPatBind lhs grhss }
729 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
731 = parseError (getLoc fun) ("Qualified name in function definition: " ++
732 showRdrName (unLoc fun))
734 = do ps <- checkPatterns pats
735 let match_span = combineSrcSpans lhs_loc rhs_span
736 return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
737 -- The span of the match covers the entire equation.
738 -- That isn't quite right, but it'll do for now.
740 makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
741 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
742 makeFunBind fn is_infix ms
743 = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
744 fun_co_fn = idCoercion, bind_fvs = placeHolderNames }
746 checkPatBind lhs (L _ grhss)
747 = do { lhs <- checkPattern lhs
748 ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
754 checkValSig (L l (HsVar v)) ty
755 | isUnqual v && not (isDataOcc (rdrNameOcc v))
756 = return (TypeSig (L l v) ty)
757 checkValSig (L l other) ty
758 = parseError l "Invalid type signature"
760 mkGadtDecl :: Located RdrName
761 -> LHsType RdrName -- assuming HsType
763 mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = mk_gadt_con name qvars cxt ty
764 mkGadtDecl name ty = mk_gadt_con name [] (noLoc []) ty
766 mk_gadt_con name qvars cxt ty
767 = ConDecl { con_name = name
768 , con_explicit = Implicit
771 , con_details = PrefixCon []
772 , con_res = ResTyGADT ty }
773 -- NB: we put the whole constr type into the ResTyGADT for now;
774 -- the renamer will unravel it once it has sorted out
777 -- A variable binding is parsed as a FunBind.
780 -- The parser left-associates, so there should
781 -- not be any OpApps inside the e's
782 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
783 -- Splits (f ! g a b) into (f, [(! g), a, g])
784 splitBang (L loc (OpApp l_arg bang@(L loc' (HsVar op)) _ r_arg))
785 | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
787 (arg1,argns) = split_bang r_arg []
788 split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
789 split_bang e es = (e,es)
790 splitBang other = Nothing
792 isFunLhs :: LHsExpr RdrName
793 -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
794 -- Just (fun, is_infix, arg_pats) if e is a function LHS
797 go (L loc (HsVar f)) es
798 | not (isRdrDataCon f) = return (Just (L loc f, False, es))
799 go (L _ (HsApp f e)) es = go f (e:es)
800 go (L _ (HsPar e)) es@(_:_) = go e es
802 -- For infix function defns, there should be only one infix *function*
803 -- (though there may be infix *datacons* involved too). So we don't
804 -- need fixity info to figure out which function is being defined.
805 -- a `K1` b `op` c `K2` d
807 -- (a `K1` b) `op` (c `K2` d)
808 -- The renamer checks later that the precedences would yield such a parse.
810 -- There is a complication to deal with bang patterns.
812 -- ToDo: what about this?
813 -- x + 1 `op` y = ...
815 go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
816 | Just (e',es') <- splitBang e
817 = do { bang_on <- extension bangPatEnabled
818 ; if bang_on then go e' (es' ++ es)
819 else return (Just (L loc' op, True, (l:r:es))) }
820 -- No bangs; behave just like the next case
821 | not (isRdrDataCon op) -- We have found the function!
822 = return (Just (L loc' op, True, (l:r:es)))
823 | otherwise -- Infix data con; keep going
824 = do { mb_l <- go l es
826 Just (op', True, j : k : es')
827 -> return (Just (op', True, j : op_app : es'))
829 op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
830 _ -> return Nothing }
831 go _ _ = return Nothing
833 ---------------------------------------------------------------------------
834 -- Miscellaneous utilities
836 checkPrecP :: Located Int -> P Int
838 | 0 <= i && i <= maxPrecedence = return i
839 | otherwise = parseError l "Precedence out of range"
844 -> HsRecordBinds RdrName
845 -> P (HsExpr RdrName)
847 mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
848 = return (RecordCon (L l c) noPostTcExpr fs)
849 mkRecConstrOrUpdate exp loc fs@(_:_)
850 = return (RecordUpd exp fs placeHolderType placeHolderType)
851 mkRecConstrOrUpdate _ loc []
852 = parseError loc "Empty record update"
854 mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec
855 -- The Maybe is becuase the user can omit the activation spec (and usually does)
856 mkInlineSpec Nothing True = alwaysInlineSpec -- INLINE
857 mkInlineSpec Nothing False = neverInlineSpec -- NOINLINE
858 mkInlineSpec (Just act) inl = Inline act inl
861 -----------------------------------------------------------------------------
862 -- utilities for foreign declarations
864 -- supported calling conventions
866 data CallConv = CCall CCallConv -- ccall or stdcall
869 -- construct a foreign import declaration
873 -> (Located FastString, Located RdrName, LHsType RdrName)
874 -> P (HsDecl RdrName)
875 mkImport (CCall cconv) safety (entity, v, ty) = do
876 importSpec <- parseCImport entity cconv safety v
877 return (ForD (ForeignImport v ty importSpec))
878 mkImport (DNCall ) _ (entity, v, ty) = do
879 spec <- parseDImport entity
880 return $ ForD (ForeignImport v ty (DNImport spec))
882 -- parse the entity string of a foreign import declaration for the `ccall' or
883 -- `stdcall' calling convention'
885 parseCImport :: Located FastString
890 parseCImport (L loc entity) cconv safety v
891 -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
892 | entity == FSLIT ("dynamic") =
893 return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
894 | entity == FSLIT ("wrapper") =
895 return $ CImport cconv safety nilFS nilFS CWrapper
896 | otherwise = parse0 (unpackFS entity)
898 -- using the static keyword?
899 parse0 (' ': rest) = parse0 rest
900 parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
901 parse0 rest = parse1 rest
902 -- check for header file name
903 parse1 "" = parse4 "" nilFS False nilFS
904 parse1 (' ':rest) = parse1 rest
905 parse1 str@('&':_ ) = parse2 str nilFS
906 parse1 str@('[':_ ) = parse3 str nilFS False
908 | ".h" `isSuffixOf` first = parse2 rest (mkFastString first)
909 | otherwise = parse4 str nilFS False nilFS
911 (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
912 -- check for address operator (indicating a label import)
913 parse2 "" header = parse4 "" header False nilFS
914 parse2 (' ':rest) header = parse2 rest header
915 parse2 ('&':rest) header = parse3 rest header True
916 parse2 str@('[':_ ) header = parse3 str header False
917 parse2 str header = parse4 str header False nilFS
918 -- check for library object name
919 parse3 (' ':rest) header isLbl = parse3 rest header isLbl
920 parse3 ('[':rest) header isLbl =
921 case break (== ']') rest of
922 (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib)
923 _ -> parseError loc "Missing ']' in entity"
924 parse3 str header isLbl = parse4 str header isLbl nilFS
925 -- check for name of C function
926 parse4 "" header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
927 parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib
928 parse4 str header isLbl lib
929 | all (== ' ') rest = build (mkFastString first) header isLbl lib
930 | otherwise = parseError loc "Malformed entity string"
932 (first, rest) = break (== ' ') str
934 build cid header False lib = return $
935 CImport cconv safety header lib (CFunction (StaticTarget cid))
936 build cid header True lib = return $
937 CImport cconv safety header lib (CLabel cid )
940 -- Unravel a dotnet spec string.
942 parseDImport :: Located FastString -> P DNCallSpec
943 parseDImport (L loc entity) = parse0 comps
945 comps = words (unpackFS entity)
949 | x == "static" = parse1 True xs
950 | otherwise = parse1 False (x:xs)
953 parse1 isStatic (x:xs)
954 | x == "method" = parse2 isStatic DNMethod xs
955 | x == "field" = parse2 isStatic DNField xs
956 | x == "ctor" = parse2 isStatic DNConstructor xs
957 parse1 isStatic xs = parse2 isStatic DNMethod xs
960 parse2 isStatic kind (('[':x):xs) =
963 vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
964 parse2 isStatic kind xs = parse3 isStatic kind "" xs
966 parse3 isStatic kind assem [x] =
967 return (DNCallSpec isStatic kind assem x
968 -- these will be filled in once known.
969 (error "FFI-dotnet-args")
970 (error "FFI-dotnet-result"))
971 parse3 _ _ _ _ = d'oh
973 d'oh = parseError loc "Malformed entity string"
975 -- construct a foreign export declaration
978 -> (Located FastString, Located RdrName, LHsType RdrName)
979 -> P (HsDecl RdrName)
980 mkExport (CCall cconv) (L loc entity, v, ty) = return $
981 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
983 entity' | nullFS entity = mkExtName (unLoc v)
985 mkExport DNCall (L loc entity, v, ty) =
986 parseError (getLoc v){-TODO: not quite right-}
987 "Foreign export is not yet supported for .NET"
989 -- Supplying the ext_name in a foreign decl is optional; if it
990 -- isn't there, the Haskell name is assumed. Note that no transformation
991 -- of the Haskell name is then performed, so if you foreign export (++),
992 -- it's external name will be "++". Too bad; it's important because we don't
993 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
995 mkExtName :: RdrName -> CLabelString
996 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
1000 -----------------------------------------------------------------------------
1004 showRdrName :: RdrName -> String
1005 showRdrName r = showSDoc (ppr r)
1007 parseError :: SrcSpan -> String -> P a
1008 parseError span s = failSpanMsgP span s