2 % (c) The University of Glasgow, 1996-2003
4 Functions over HsSyn specialised to RdrName.
9 extractHsRhoRdrTyVars, extractGenericPatTyVars,
11 mkHsOpApp, mkClassDecl,
12 mkHsIntegral, mkHsFractional, mkHsIsString,
14 mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec,
15 mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
20 findSplice, checkDecBrGroup,
22 -- Stuff to do with Foreign declarations
24 mkImport, -- CallConv -> Safety
25 -- -> (FastString, RdrName, RdrNameHsType)
28 -- -> (FastString, RdrName, RdrNameHsType)
30 mkExtName, -- RdrName -> CLabelString
31 mkGadtDecl, -- Located RdrName -> LHsType RdrName -> ConDecl RdrName
33 -- Bunch of functions in the parser monad for
34 -- checking and constructing values
35 checkPrecP, -- Int -> P Int
36 checkContext, -- HsType -> P HsContext
37 checkPred, -- HsType -> P HsPred
38 checkTyClHdr, -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName])
39 checkTyVars, -- [LHsType RdrName] -> P ()
40 checkSynHdr, -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName])
41 checkKindSigs, -- [LTyClDecl RdrName] -> P ()
42 checkInstType, -- HsType -> P HsType
43 checkDerivDecl, -- LDerivDecl RdrName -> P (LDerivDecl RdrName)
44 checkPattern, -- HsExp -> P HsPat
46 checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat]
47 checkDo, -- [Stmt] -> P [Stmt]
48 checkMDo, -- [Stmt] -> P [Stmt]
49 checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
50 checkValSig, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
51 parseError, -- String -> Pa
54 #include "HsVersions.h"
56 import HsSyn -- Lots of it
57 import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc,
58 isRdrDataCon, isUnqual, getRdrName, isQual,
60 import BasicTypes ( maxPrecedence, Activation, InlineSpec(..), alwaysInlineSpec, neverInlineSpec )
61 import Lexer ( P, failSpanMsgP, extension, standaloneDerivingEnabled, bangPatEnabled )
62 import TysWiredIn ( unitTyCon )
63 import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
64 DNCallSpec(..), DNKind(..), CLabelString )
65 import OccName ( srcDataName, varName, isDataOcc, isTcOcc,
68 import OrdList ( OrdList, fromOL )
69 import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag )
73 import List ( isSuffixOf, nubBy )
74 import Monad ( unless )
78 %************************************************************************
80 \subsection{A few functions over HsSyn at RdrName}
82 %************************************************************************
84 extractHsTyRdrNames finds the free variables of a HsType
85 It's used when making the for-alls explicit.
88 extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName]
89 extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty [])
91 extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName]
92 -- This one takes the context and tau-part of a
93 -- sigma type and returns their free type variables
94 extractHsRhoRdrTyVars ctxt ty
95 = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty [])
97 extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt)
99 extract_pred (HsClassP cls tys) acc = foldr extract_lty acc tys
100 extract_pred (HsEqualP ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
101 extract_pred (HsIParam n ty ) acc = extract_lty ty acc
103 extract_lty (L loc ty) acc
105 HsTyVar tv -> extract_tv loc tv acc
106 HsBangTy _ ty -> extract_lty ty acc
107 HsAppTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
108 HsListTy ty -> extract_lty ty acc
109 HsPArrTy ty -> extract_lty ty acc
110 HsTupleTy _ tys -> foldr extract_lty acc tys
111 HsFunTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
112 HsPredTy p -> extract_pred p acc
113 HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
114 HsParTy ty -> extract_lty ty acc
116 HsSpliceTy _ -> acc -- Type splices mention no type variables
117 HsKindSig ty k -> extract_lty ty acc
118 HsForAllTy exp [] cx ty -> extract_lctxt cx (extract_lty ty acc)
119 HsForAllTy exp tvs cx ty -> acc ++ (filter ((`notElem` locals) . unLoc) $
120 extract_lctxt cx (extract_lty ty []))
122 locals = hsLTyVarNames tvs
123 HsDocTy ty doc -> extract_lty ty acc
125 extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName]
126 extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc
129 extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName]
130 -- Get the type variables out of the type patterns in a bunch of
131 -- possibly-generic bindings in a class declaration
132 extractGenericPatTyVars binds
133 = nubBy eqLocated (foldrBag get [] binds)
135 get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms
138 get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
139 get_m other acc = acc
143 %************************************************************************
145 \subsection{Construction functions for Rdr stuff}
147 %************************************************************************
149 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
150 by deriving them from the name of the class. We fill in the names for the
151 tycon and datacon corresponding to the class, by deriving them from the
152 name of the class itself. This saves recording the names in the interface
153 file (which would be equally good).
155 Similarly for mkConDecl, mkClassOpSig and default-method names.
157 *** See "THE NAMING STORY" in HsDecls ****
160 mkClassDecl (cxt, cname, tyvars) fds sigs mbinds ats docs
161 = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
169 mkTyData new_or_data (context, tname, tyvars, typats) ksig data_cons maybe_deriv
170 = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
171 tcdTyVars = tyvars, tcdTyPats = typats, tcdCons = data_cons,
172 tcdKindSig = ksig, tcdDerivs = maybe_deriv }
175 %************************************************************************
177 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
179 %************************************************************************
181 Function definitions are restructured here. Each is assumed to be recursive
182 initially, and non recursive definitions are discovered by the dependency
187 -- | Groups together bindings for a single function
188 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
189 cvTopDecls decls = go (fromOL decls)
191 go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
193 go (L l (ValD b) : ds) = L l' (ValD b') : go ds'
194 where (L l' b', ds') = getMonoBind (L l b) ds
195 go (d : ds) = d : go ds
197 -- Declaration list may only contain value bindings and signatures.
198 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
200 = case cvBindsAndSigs binding of
201 (mbs, sigs, [], _) -> -- list of type decls *always* empty
204 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
205 -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl RdrName])
206 -- Input decls contain just value bindings and signatures
207 -- and in case of class or instance declarations also
208 -- associated type declarations. They might also contain Haddock comments.
209 cvBindsAndSigs fb = go (fromOL fb)
211 go [] = (emptyBag, [], [], [])
212 go (L l x@(SigD s) : ds) = (bs, L l s : ss, ts, docs)
213 where (bs, ss, ts, docs) = go ds
214 go (L l x@(ValD b) : ds) = (b' `consBag` bs, ss, ts, docs)
215 where (b', ds') = getMonoBind (L l b) ds
216 (bs, ss, ts, docs) = go ds'
217 go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs)
218 where (bs, ss, ts, docs) = go ds
219 go (L l (DocD d) : ds) = (bs, ss, ts, (L l d) : docs)
220 where (bs, ss, ts, docs) = go ds
222 -----------------------------------------------------------------------------
223 -- Group function bindings into equation groups
225 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
226 -> (LHsBind RdrName, [LHsDecl RdrName])
227 -- Suppose (b',ds') = getMonoBind b ds
228 -- ds is a list of parsed bindings
229 -- b is a MonoBinds that has just been read off the front
231 -- Then b' is the result of grouping more equations from ds that
232 -- belong with b into a single MonoBinds, and ds' is the depleted
233 -- list of parsed bindings.
235 -- All Haddock comments between equations inside the group are
238 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
240 getMonoBind (L loc1 bind@(FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1,
241 fun_matches = MatchGroup mtchs1 _ })) binds
243 = go is_infix1 mtchs1 loc1 binds []
245 go is_infix mtchs loc
246 (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
247 fun_matches = MatchGroup mtchs2 _ })) : binds) _
248 | f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs)
249 (combineSrcSpans loc loc2) binds []
250 go is_infix mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls
251 = let doc_decls' = doc_decl : doc_decls
252 in go is_infix mtchs (combineSrcSpans loc loc2) binds doc_decls'
253 go is_infix mtchs loc binds doc_decls
254 = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), (reverse doc_decls) ++ binds)
255 -- Reverse the final matches, to get it back in the right order
256 -- Do the same thing with the trailing doc comments
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 checkDecBrGroup :: [LHsDecl a] -> P (HsGroup a)
272 -- Turn the body of a [d| ... |] into a HsGroup
273 -- There should be no splices in the "..."
274 checkDecBrGroup decls
275 = case addl emptyRdrGroup decls of
276 (group, Nothing) -> return group
277 (_, Just (SpliceDecl (L loc _), _)) ->
278 parseError loc "Declaration splices are not permitted inside declaration brackets"
279 -- Why not? See Section 7.3 of the TH paper.
281 addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
282 -- This stuff reverses the declarations (again) but it doesn't matter
285 addl gp [] = (gp, Nothing)
286 addl gp (L l d : ds) = add gp l d ds
289 add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a]
290 -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
292 add gp l (SpliceD e) ds = (gp, Just (e, ds))
294 -- Class declarations: pull out the fixity signatures to the top
295 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs})
298 let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
299 addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs}) ds
301 addl (gp { hs_tyclds = L l d : ts }) ds
303 -- Signatures: fixity sigs go a different place than all others
304 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
305 = addl (gp {hs_fixds = L l f : ts}) ds
306 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
307 = addl (gp {hs_valds = add_sig (L l d) ts}) ds
309 -- Value declarations: use add_bind
310 add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds
311 = addl (gp { hs_valds = add_bind (L l d) ts }) ds
313 -- The rest are routine
314 add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds
315 = addl (gp { hs_instds = L l d : ts }) ds
316 add gp@(HsGroup {hs_derivds = ts}) l (DerivD d) ds
317 = addl (gp { hs_derivds = L l d : ts }) ds
318 add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
319 = addl (gp { hs_defds = L l d : ts }) ds
320 add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
321 = addl (gp { hs_fords = L l d : ts }) ds
322 add gp@(HsGroup {hs_depds = ts}) l (DeprecD d) ds
323 = addl (gp { hs_depds = L l d : ts }) ds
324 add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
325 = addl (gp { hs_ruleds = L l d : ts }) ds
328 = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds
330 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
331 add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
334 %************************************************************************
336 \subsection[PrefixToHS-utils]{Utilities for conversion}
338 %************************************************************************
342 -----------------------------------------------------------------------------
345 -- When parsing data declarations, we sometimes inadvertently parse
346 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
347 -- This function splits up the type application, adds any pending
348 -- arguments, and converts the type constructor back into a data constructor.
350 mkPrefixCon :: LHsType RdrName -> [LBangType RdrName]
351 -> P (Located RdrName, HsConDeclDetails RdrName)
355 split (L _ (HsAppTy t u)) ts = split t (u : ts)
356 split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc
357 return (data_con, PrefixCon ts)
358 split (L l _) _ = parseError l "parse error in data/newtype declaration"
360 mkRecCon :: Located RdrName ->
361 [([Located RdrName], LBangType RdrName, Maybe (LHsDoc RdrName))] ->
362 P (Located RdrName, HsConDeclDetails RdrName)
363 mkRecCon (L loc con) fields
364 = do data_con <- tyConToDataCon loc con
365 return (data_con, RecCon [ ConDeclField l t d | (ls, t, d) <- fields, l <- ls ])
367 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
368 tyConToDataCon loc tc
369 | isTcOcc (rdrNameOcc tc)
370 = return (L loc (setRdrNameSpace tc srcDataName))
372 = parseError loc (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
374 ----------------------------------------------------------------------------
375 -- Various Syntactic Checks
377 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
378 checkInstType (L l t)
380 HsForAllTy exp tvs ctxt ty -> do
381 dict_ty <- checkDictTy ty
382 return (L l (HsForAllTy exp tvs ctxt dict_ty))
384 HsParTy ty -> checkInstType ty
386 ty -> do dict_ty <- checkDictTy (L l ty)
387 return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
389 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
390 checkDictTy (L spn ty) = check ty []
392 check (HsTyVar t) args | not (isRdrTyVar t)
393 = return (L spn (HsPredTy (HsClassP t args)))
394 check (HsAppTy l r) args = check (unLoc l) (r:args)
395 check (HsParTy t) args = check (unLoc t) args
396 check _ _ = parseError spn "Malformed instance header"
398 -- Check whether the given list of type parameters are all type variables
399 -- (possibly with a kind signature). If the second argument is `False',
400 -- only type variables are allowed and we raise an error on encountering a
401 -- non-variable; otherwise, we allow non-variable arguments and return the
402 -- entire list of parameters.
404 checkTyVars :: [LHsType RdrName] -> P ()
405 checkTyVars tparms = mapM_ chk tparms
407 -- Check that the name space is correct!
408 chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
409 | isRdrTyVar tv = return ()
410 chk (L l (HsTyVar tv))
411 | isRdrTyVar tv = return ()
413 parseError l "Type found where type variable expected"
415 -- Check whether the type arguments in a type synonym head are simply
416 -- variables. If not, we have a type family instance and return all patterns.
417 -- If yes, we return 'Nothing' as the third component to indicate a vanilla
420 checkSynHdr :: LHsType RdrName
421 -> Bool -- is type instance?
422 -> P (Located RdrName, -- head symbol
423 [LHsTyVarBndr RdrName], -- parameters
424 [LHsType RdrName]) -- type patterns
425 checkSynHdr ty isTyInst =
426 do { (_, tc, tvs, tparms) <- checkTyClHdr (noLoc []) ty
427 ; unless isTyInst $ checkTyVars tparms
428 ; return (tc, tvs, tparms) }
431 -- Well-formedness check and decomposition of type and class heads.
433 checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
434 -> P (LHsContext RdrName, -- the type context
435 Located RdrName, -- the head symbol (type or class name)
436 [LHsTyVarBndr RdrName], -- free variables of the non-context part
437 [LHsType RdrName]) -- parameters of head symbol
438 -- The header of a type or class decl should look like
439 -- (C a, D b) => T a b
443 -- With associated types, we can also have non-variable parameters; ie,
446 -- The unaltered parameter list is returned in the fourth component of the
450 -- ('()', 'T', ['a'], ['Int', '[a]'])
451 checkTyClHdr (L l cxt) ty
452 = do (tc, tvs, parms) <- gol ty []
454 return (L l cxt, tc, tvs, parms)
456 gol (L l ty) acc = go l ty acc
458 go l (HsTyVar tc) acc
459 | isRdrTc tc = do tvs <- extractTyVars acc
460 return (L l tc, tvs, acc)
461 go l (HsOpTy t1 ltc@(L _ tc) t2) acc
462 | isRdrTc tc = do tvs <- extractTyVars (t1:t2:acc)
463 return (ltc, tvs, t1:t2:acc)
464 go l (HsParTy ty) acc = gol ty acc
465 go l (HsAppTy t1 t2) acc = gol t1 (t2:acc)
467 parseError l "Malformed head of type or class declaration"
469 -- The predicates in a type or class decl must be class predicates or
470 -- equational constraints. They need not all have variable-only
471 -- arguments, even in Haskell 98.
472 -- E.g. class (Monad m, Monad (t m)) => MonadT t m
473 chk_pred (L l (HsClassP _ _)) = return ()
474 chk_pred (L l (HsEqualP _ _)) = return ()
476 = parseError l "Malformed context in type or class declaration"
478 -- Extract the type variables of a list of type parameters.
480 -- * Type arguments can be complex type terms (needed for associated type
483 extractTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
484 extractTyVars tvs = collects [] tvs
486 -- Collect all variables (1st arg serves as an accumulator)
487 collect tvs (L l (HsForAllTy _ _ _ _)) =
488 parseError l "Forall type not allowed as type parameter"
489 collect tvs (L l (HsTyVar tv))
490 | isRdrTyVar tv = return $ L l (UserTyVar tv) : tvs
491 | otherwise = return tvs
492 collect tvs (L l (HsBangTy _ _ )) =
493 parseError l "Bang-style type annotations not allowed as type parameter"
494 collect tvs (L l (HsAppTy t1 t2 )) = do
495 tvs' <- collect tvs t2
497 collect tvs (L l (HsFunTy t1 t2 )) = do
498 tvs' <- collect tvs t2
500 collect tvs (L l (HsListTy t )) = collect tvs t
501 collect tvs (L l (HsPArrTy t )) = collect tvs t
502 collect tvs (L l (HsTupleTy _ ts )) = collects tvs ts
503 collect tvs (L l (HsOpTy t1 _ t2 )) = do
504 tvs' <- collect tvs t2
506 collect tvs (L l (HsParTy t )) = collect tvs t
507 collect tvs (L l (HsNumTy t )) = return tvs
508 collect tvs (L l (HsPredTy t )) =
509 parseError l "Predicate not allowed as type parameter"
510 collect tvs (L l (HsKindSig (L _ (HsTyVar tv)) k))
512 return $ L l (KindedTyVar tv k) : tvs
514 parseError l "Kind signature only allowed for type variables"
515 collect tvs (L l (HsSpliceTy t )) =
516 parseError l "Splice not allowed as type parameter"
518 -- Collect all variables of a list of types
519 collects tvs [] = return tvs
520 collects tvs (t:ts) = do
521 tvs' <- collects tvs ts
524 -- Check that associated type declarations of a class are all kind signatures.
526 checkKindSigs :: [LTyClDecl RdrName] -> P ()
527 checkKindSigs = mapM_ check
530 | isFamilyDecl tydecl
531 || isSynDecl tydecl = return ()
533 parseError l "Type declaration in a class must be a kind signature or synonym default"
535 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
539 check (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
540 = do ctx <- mapM checkPred ts
543 check (HsParTy ty) -- to be sure HsParTy doesn't get into the way
546 check (HsTyVar t) -- Empty context shows up as a unit type ()
547 | t == getRdrName unitTyCon = return (L l [])
550 = do p <- checkPred (L l t)
554 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
555 -- Watch out.. in ...deriving( Show )... we use checkPred on
556 -- the list of partially applied predicates in the deriving,
557 -- so there can be zero args.
558 checkPred (L spn (HsPredTy (HsIParam n ty)))
559 = return (L spn (HsIParam n ty))
563 checkl (L l ty) args = check l ty args
565 check _loc (HsPredTy pred@(HsEqualP _ _))
567 = return $ L spn pred
568 check _loc (HsTyVar t) args | not (isRdrTyVar t)
569 = return (L spn (HsClassP t args))
570 check _loc (HsAppTy l r) args = checkl l (r:args)
571 check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
572 check _loc (HsParTy t) args = checkl t args
573 check loc _ _ = parseError loc
574 "malformed class assertion"
576 ---------------------------------------------------------------------------
577 -- Checking stand-alone deriving declarations
579 checkDerivDecl :: LDerivDecl RdrName -> P (LDerivDecl RdrName)
580 checkDerivDecl d@(L loc _) =
581 do stDerivOn <- extension standaloneDerivingEnabled
582 if stDerivOn then return d
583 else parseError loc "Illegal stand-alone deriving declaration (use -XStandaloneDeriving)"
585 ---------------------------------------------------------------------------
586 -- Checking statements in a do-expression
587 -- We parse do { e1 ; e2 ; }
588 -- as [ExprStmt e1, ExprStmt e2]
589 -- checkDo (a) checks that the last thing is an ExprStmt
590 -- (b) returns it separately
591 -- same comments apply for mdo as well
593 checkDo = checkDoMDo "a " "'do'"
594 checkMDo = checkDoMDo "an " "'mdo'"
596 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
597 checkDoMDo pre nm loc [] = parseError loc ("Empty " ++ nm ++ " construct")
598 checkDoMDo pre nm loc ss = do
601 check [L l (ExprStmt e _ _)] = return ([], e)
602 check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
603 " construct must be an expression")
608 -- -------------------------------------------------------------------------
609 -- Checking Patterns.
611 -- We parse patterns as expressions and check for valid patterns below,
612 -- converting the expression into a pattern at the same time.
614 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
615 checkPattern e = checkLPat e
617 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
618 checkPatterns es = mapM checkPattern es
620 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
621 checkLPat e@(L l _) = checkPat l e []
623 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
624 checkPat loc (L l (HsVar c)) args
625 | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
626 checkPat loc e args -- OK to let this happen even if bang-patterns
627 -- are not enabled, because there is no valid
628 -- non-bang-pattern parse of (C ! e)
629 | Just (e', args') <- splitBang e
630 = do { args'' <- checkPatterns args'
631 ; checkPat loc e' (args'' ++ args) }
632 checkPat loc (L _ (HsApp f x)) args
633 = do { x <- checkLPat x; checkPat loc f (x:args) }
634 checkPat loc (L _ e) []
635 = do { p <- checkAPat loc e; return (L loc p) }
636 checkPat loc pat _some_args
639 checkAPat loc e = case e of
640 EWildPat -> return (WildPat placeHolderType)
641 HsVar x | isQual x -> parseError loc ("Qualified variable in pattern: "
643 | otherwise -> return (VarPat x)
644 HsLit l -> return (LitPat l)
646 -- Overloaded numeric patterns (e.g. f 0 x = x)
647 -- Negation is recorded separately, so that the literal is zero or +ve
648 -- NB. Negative *primitive* literals are already handled by the lexer
649 HsOverLit pos_lit -> return (mkNPat pos_lit Nothing)
650 NegApp (L _ (HsOverLit pos_lit)) _
651 -> return (mkNPat pos_lit (Just noSyntaxExpr))
653 SectionR (L _ (HsVar bang)) e -- (! x)
655 -> do { bang_on <- extension bangPatEnabled
656 ; if bang_on then checkLPat e >>= (return . BangPat)
657 else parseError loc "Illegal bang-pattern (use -fbang-patterns)" }
659 ELazyPat e -> checkLPat e >>= (return . LazyPat)
660 EAsPat n e -> checkLPat e >>= (return . AsPat n)
661 ExprWithTySig e t -> checkLPat e >>= \e ->
662 -- Pattern signatures are parsed as sigtypes,
663 -- but they aren't explicit forall points. Hence
664 -- we have to remove the implicit forall here.
666 L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
669 return (SigPatIn e t')
672 OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
673 (L _ (HsOverLit lit@(HsIntegral _ _)))
675 -> return (mkNPlusKPat (L nloc n) lit)
677 OpApp l op fix r -> checkLPat l >>= \l ->
678 checkLPat r >>= \r ->
680 L cl (HsVar c) | isDataOcc (rdrNameOcc c)
681 -> return (ConPatIn (L cl c) (InfixCon l r))
684 HsPar e -> checkLPat e >>= (return . ParPat)
685 ExplicitList _ es -> mapM (\e -> checkLPat e) es >>= \ps ->
686 return (ListPat ps placeHolderType)
687 ExplicitPArr _ es -> mapM (\e -> checkLPat e) es >>= \ps ->
688 return (PArrPat ps placeHolderType)
690 ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
691 return (TuplePat ps b placeHolderType)
693 RecordCon c _ (HsRecFields fs dd)
694 -> mapM checkPatField fs >>= \fs ->
695 return (ConPatIn c (RecCon (HsRecFields fs dd)))
697 HsType ty -> return (TypePat ty)
700 plus_RDR, bang_RDR :: RdrName
701 plus_RDR = mkUnqual varName FSLIT("+") -- Hack
702 bang_RDR = mkUnqual varName FSLIT("!") -- Hack
704 checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
705 checkPatField fld = do { p <- checkLPat (hsRecFieldArg fld)
706 ; return (fld { hsRecFieldArg = p }) }
708 patFail loc = parseError loc "Parse error in pattern"
711 ---------------------------------------------------------------------------
712 -- Check Equation Syntax
714 checkValDef :: LHsExpr RdrName
715 -> Maybe (LHsType RdrName)
716 -> Located (GRHSs RdrName)
717 -> P (HsBind RdrName)
719 checkValDef lhs (Just sig) grhss
720 -- x :: ty = rhs parses as a *pattern* binding
721 = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
723 checkValDef lhs opt_sig grhss
724 = do { mb_fun <- isFunLhs lhs
726 Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
727 fun is_infix pats opt_sig grhss
728 Nothing -> checkPatBind lhs grhss }
730 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
732 = parseError (getLoc fun) ("Qualified name in function definition: " ++
733 showRdrName (unLoc fun))
735 = do ps <- checkPatterns pats
736 let match_span = combineSrcSpans lhs_loc rhs_span
737 return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
738 -- The span of the match covers the entire equation.
739 -- That isn't quite right, but it'll do for now.
741 makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
742 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
743 makeFunBind fn is_infix ms
744 = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
745 fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
747 checkPatBind lhs (L _ grhss)
748 = do { lhs <- checkPattern lhs
749 ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
755 checkValSig (L l (HsVar v)) ty
756 | isUnqual v && not (isDataOcc (rdrNameOcc v))
757 = return (TypeSig (L l v) ty)
758 checkValSig (L l other) ty
759 = parseError l "Invalid type signature"
761 mkGadtDecl :: Located RdrName
762 -> LHsType RdrName -- assuming HsType
764 mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = mk_gadt_con name qvars cxt ty
765 mkGadtDecl name ty = mk_gadt_con name [] (noLoc []) ty
767 mk_gadt_con name qvars cxt ty
768 = ConDecl { con_name = name
769 , con_explicit = Implicit
772 , con_details = PrefixCon []
773 , con_res = ResTyGADT ty
774 , con_doc = Nothing }
775 -- NB: we put the whole constr type into the ResTyGADT for now;
776 -- the renamer will unravel it once it has sorted out
779 -- A variable binding is parsed as a FunBind.
782 -- The parser left-associates, so there should
783 -- not be any OpApps inside the e's
784 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
785 -- Splits (f ! g a b) into (f, [(! g), a, b])
786 splitBang (L loc (OpApp l_arg bang@(L loc' (HsVar op)) _ r_arg))
787 | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
789 (arg1,argns) = split_bang r_arg []
790 split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
791 split_bang e es = (e,es)
792 splitBang other = Nothing
794 isFunLhs :: LHsExpr RdrName
795 -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
796 -- Just (fun, is_infix, arg_pats) if e is a function LHS
798 -- The whole LHS is parsed as a single expression.
799 -- Any infix operators on the LHS will parse left-associatively
801 -- will parse (rather strangely) as
803 -- It's up to isFunLhs to sort out the mess
809 go (L loc (HsVar f)) es
810 | not (isRdrDataCon f) = return (Just (L loc f, False, es))
811 go (L _ (HsApp f e)) es = go f (e:es)
812 go (L _ (HsPar e)) es@(_:_) = go e es
814 -- For infix function defns, there should be only one infix *function*
815 -- (though there may be infix *datacons* involved too). So we don't
816 -- need fixity info to figure out which function is being defined.
817 -- a `K1` b `op` c `K2` d
819 -- (a `K1` b) `op` (c `K2` d)
820 -- The renamer checks later that the precedences would yield such a parse.
822 -- There is a complication to deal with bang patterns.
824 -- ToDo: what about this?
825 -- x + 1 `op` y = ...
827 go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
828 | Just (e',es') <- splitBang e
829 = do { bang_on <- extension bangPatEnabled
830 ; if bang_on then go e' (es' ++ es)
831 else return (Just (L loc' op, True, (l:r:es))) }
832 -- No bangs; behave just like the next case
833 | not (isRdrDataCon op) -- We have found the function!
834 = return (Just (L loc' op, True, (l:r:es)))
835 | otherwise -- Infix data con; keep going
836 = do { mb_l <- go l es
838 Just (op', True, j : k : es')
839 -> return (Just (op', True, j : op_app : es'))
841 op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
842 _ -> return Nothing }
843 go _ _ = return Nothing
845 ---------------------------------------------------------------------------
846 -- Miscellaneous utilities
848 checkPrecP :: Located Int -> P Int
850 | 0 <= i && i <= maxPrecedence = return i
851 | otherwise = parseError l "Precedence out of range"
856 -> ([HsRecField RdrName (LHsExpr RdrName)], Bool)
857 -> P (HsExpr RdrName)
859 mkRecConstrOrUpdate (L l (HsVar c)) loc (fs,dd) | isRdrDataCon c
860 = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd))
861 mkRecConstrOrUpdate exp loc (fs,dd)
862 | null fs = parseError loc "Empty record update"
863 | otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] [])
865 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
866 mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
868 mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec
869 -- The Maybe is becuase the user can omit the activation spec (and usually does)
870 mkInlineSpec Nothing True = alwaysInlineSpec -- INLINE
871 mkInlineSpec Nothing False = neverInlineSpec -- NOINLINE
872 mkInlineSpec (Just act) inl = Inline act inl
875 -----------------------------------------------------------------------------
876 -- utilities for foreign declarations
878 -- supported calling conventions
880 data CallConv = CCall CCallConv -- ccall or stdcall
883 -- construct a foreign import declaration
887 -> (Located FastString, Located RdrName, LHsType RdrName)
888 -> P (HsDecl RdrName)
889 mkImport (CCall cconv) safety (entity, v, ty) = do
890 importSpec <- parseCImport entity cconv safety v
891 return (ForD (ForeignImport v ty importSpec))
892 mkImport (DNCall ) _ (entity, v, ty) = do
893 spec <- parseDImport entity
894 return $ ForD (ForeignImport v ty (DNImport spec))
896 -- parse the entity string of a foreign import declaration for the `ccall' or
897 -- `stdcall' calling convention'
899 parseCImport :: Located FastString
904 parseCImport (L loc entity) cconv safety v
905 -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
906 | entity == FSLIT ("dynamic") =
907 return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
908 | entity == FSLIT ("wrapper") =
909 return $ CImport cconv safety nilFS nilFS CWrapper
910 | otherwise = parse0 (unpackFS entity)
912 -- using the static keyword?
913 parse0 (' ': rest) = parse0 rest
914 parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
915 parse0 rest = parse1 rest
916 -- check for header file name
917 parse1 "" = parse4 "" nilFS False nilFS
918 parse1 (' ':rest) = parse1 rest
919 parse1 str@('&':_ ) = parse2 str nilFS
920 parse1 str@('[':_ ) = parse3 str nilFS False
922 | ".h" `isSuffixOf` first = parse2 rest (mkFastString first)
923 | otherwise = parse4 str nilFS False nilFS
925 (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
926 -- check for address operator (indicating a label import)
927 parse2 "" header = parse4 "" header False nilFS
928 parse2 (' ':rest) header = parse2 rest header
929 parse2 ('&':rest) header = parse3 rest header True
930 parse2 str@('[':_ ) header = parse3 str header False
931 parse2 str header = parse4 str header False nilFS
932 -- check for library object name
933 parse3 (' ':rest) header isLbl = parse3 rest header isLbl
934 parse3 ('[':rest) header isLbl =
935 case break (== ']') rest of
936 (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib)
937 _ -> parseError loc "Missing ']' in entity"
938 parse3 str header isLbl = parse4 str header isLbl nilFS
939 -- check for name of C function
940 parse4 "" header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
941 parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib
942 parse4 str header isLbl lib
943 | all (== ' ') rest = build (mkFastString first) header isLbl lib
944 | otherwise = parseError loc "Malformed entity string"
946 (first, rest) = break (== ' ') str
948 build cid header False lib = return $
949 CImport cconv safety header lib (CFunction (StaticTarget cid))
950 build cid header True lib = return $
951 CImport cconv safety header lib (CLabel cid )
954 -- Unravel a dotnet spec string.
956 parseDImport :: Located FastString -> P DNCallSpec
957 parseDImport (L loc entity) = parse0 comps
959 comps = words (unpackFS entity)
963 | x == "static" = parse1 True xs
964 | otherwise = parse1 False (x:xs)
967 parse1 isStatic (x:xs)
968 | x == "method" = parse2 isStatic DNMethod xs
969 | x == "field" = parse2 isStatic DNField xs
970 | x == "ctor" = parse2 isStatic DNConstructor xs
971 parse1 isStatic xs = parse2 isStatic DNMethod xs
974 parse2 isStatic kind (('[':x):xs) =
977 vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
978 parse2 isStatic kind xs = parse3 isStatic kind "" xs
980 parse3 isStatic kind assem [x] =
981 return (DNCallSpec isStatic kind assem x
982 -- these will be filled in once known.
983 (error "FFI-dotnet-args")
984 (error "FFI-dotnet-result"))
985 parse3 _ _ _ _ = d'oh
987 d'oh = parseError loc "Malformed entity string"
989 -- construct a foreign export declaration
992 -> (Located FastString, Located RdrName, LHsType RdrName)
993 -> P (HsDecl RdrName)
994 mkExport (CCall cconv) (L loc entity, v, ty) = return $
995 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
997 entity' | nullFS entity = mkExtName (unLoc v)
999 mkExport DNCall (L loc entity, v, ty) =
1000 parseError (getLoc v){-TODO: not quite right-}
1001 "Foreign export is not yet supported for .NET"
1003 -- Supplying the ext_name in a foreign decl is optional; if it
1004 -- isn't there, the Haskell name is assumed. Note that no transformation
1005 -- of the Haskell name is then performed, so if you foreign export (++),
1006 -- it's external name will be "++". Too bad; it's important because we don't
1007 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
1009 mkExtName :: RdrName -> CLabelString
1010 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
1014 -----------------------------------------------------------------------------
1018 showRdrName :: RdrName -> String
1019 showRdrName r = showSDoc (ppr r)
1021 parseError :: SrcSpan -> String -> P a
1022 parseError span s = failSpanMsgP span s