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, glaExtsEnabled, 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 equation of a type function and return
417 -- all patterns. If yes, we return 'Nothing' as the third component to
418 -- indicate a vanilla type synonym.
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,
445 -- The unaltered parameter list is returned in the fourth component of the
449 -- ('()', 'T', ['a'], ['Int', '[a]'])
450 checkTyClHdr (L l cxt) ty
451 = do (tc, tvs, parms) <- gol ty []
453 return (L l cxt, tc, tvs, parms)
455 gol (L l ty) acc = go l ty acc
457 go l (HsTyVar tc) acc
458 | isRdrTc tc = do tvs <- extractTyVars acc
459 return (L l tc, tvs, acc)
460 go l (HsOpTy t1 ltc@(L _ tc) t2) acc
461 | isRdrTc tc = do tvs <- extractTyVars (t1:t2:acc)
462 return (ltc, tvs, acc)
463 go l (HsParTy ty) acc = gol ty acc
464 go l (HsAppTy t1 t2) acc = gol t1 (t2:acc)
466 parseError l "Malformed head of type or class declaration"
468 -- The predicates in a type or class decl must be class predicates or
469 -- equational constraints. They need not all have variable-only
470 -- arguments, even in Haskell 98.
471 -- E.g. class (Monad m, Monad (t m)) => MonadT t m
472 chk_pred (L l (HsClassP _ _)) = return ()
473 chk_pred (L l (HsEqualP _ _)) = return ()
475 = parseError l "Malformed context in type or class declaration"
477 -- Extract the type variables of a list of type parameters.
479 -- * Type arguments can be complex type terms (needed for associated type
482 extractTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
483 extractTyVars tvs = collects [] tvs
485 -- Collect all variables (1st arg serves as an accumulator)
486 collect tvs (L l (HsForAllTy _ _ _ _)) =
487 parseError l "Forall type not allowed as type parameter"
488 collect tvs (L l (HsTyVar tv))
489 | isRdrTyVar tv = return $ L l (UserTyVar tv) : tvs
490 | otherwise = return tvs
491 collect tvs (L l (HsBangTy _ _ )) =
492 parseError l "Bang-style type annotations not allowed as type parameter"
493 collect tvs (L l (HsAppTy t1 t2 )) = do
494 tvs' <- collect tvs t2
496 collect tvs (L l (HsFunTy t1 t2 )) = do
497 tvs' <- collect tvs t2
499 collect tvs (L l (HsListTy t )) = collect tvs t
500 collect tvs (L l (HsPArrTy t )) = collect tvs t
501 collect tvs (L l (HsTupleTy _ ts )) = collects tvs ts
502 collect tvs (L l (HsOpTy t1 _ t2 )) = do
503 tvs' <- collect tvs t2
505 collect tvs (L l (HsParTy t )) = collect tvs t
506 collect tvs (L l (HsNumTy t )) = return tvs
507 collect tvs (L l (HsPredTy t )) =
508 parseError l "Predicate not allowed as type parameter"
509 collect tvs (L l (HsKindSig (L _ (HsTyVar tv)) k))
511 return $ L l (KindedTyVar tv k) : tvs
513 parseError l "Kind signature only allowed for type variables"
514 collect tvs (L l (HsSpliceTy t )) =
515 parseError l "Splice not allowed as type parameter"
517 -- Collect all variables of a list of types
518 collects tvs [] = return tvs
519 collects tvs (t:ts) = do
520 tvs' <- collects tvs ts
523 -- Check that associated type declarations of a class are all kind signatures.
525 checkKindSigs :: [LTyClDecl RdrName] -> P ()
526 checkKindSigs = mapM_ check
529 | isFamilyDecl tydecl
530 || isSynDecl tydecl = return ()
532 parseError l "Type declaration in a class must be a kind signature or synonym default"
534 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
538 check (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
539 = do ctx <- mapM checkPred ts
542 check (HsParTy ty) -- to be sure HsParTy doesn't get into the way
545 check (HsTyVar t) -- Empty context shows up as a unit type ()
546 | t == getRdrName unitTyCon = return (L l [])
549 = do p <- checkPred (L l t)
553 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
554 -- Watch out.. in ...deriving( Show )... we use checkPred on
555 -- the list of partially applied predicates in the deriving,
556 -- so there can be zero args.
557 checkPred (L spn (HsPredTy (HsIParam n ty)))
558 = return (L spn (HsIParam n ty))
562 checkl (L l ty) args = check l ty args
564 check _loc (HsPredTy pred@(HsEqualP _ _))
566 = return $ L spn pred
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
573 "malformed class assertion"
575 ---------------------------------------------------------------------------
576 -- Checking stand-alone deriving declarations
578 checkDerivDecl :: LDerivDecl RdrName -> P (LDerivDecl RdrName)
579 checkDerivDecl d@(L loc _) =
580 do glaExtOn <- extension glaExtsEnabled
581 if glaExtOn then return d
582 else parseError loc "Illegal stand-alone deriving declaration (use -fglasgow-exts)"
584 ---------------------------------------------------------------------------
585 -- Checking statements in a do-expression
586 -- We parse do { e1 ; e2 ; }
587 -- as [ExprStmt e1, ExprStmt e2]
588 -- checkDo (a) checks that the last thing is an ExprStmt
589 -- (b) returns it separately
590 -- same comments apply for mdo as well
592 checkDo = checkDoMDo "a " "'do'"
593 checkMDo = checkDoMDo "an " "'mdo'"
595 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
596 checkDoMDo pre nm loc [] = parseError loc ("Empty " ++ nm ++ " construct")
597 checkDoMDo pre nm loc ss = do
600 check [L l (ExprStmt e _ _)] = return ([], e)
601 check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
602 " construct must be an expression")
607 -- -------------------------------------------------------------------------
608 -- Checking Patterns.
610 -- We parse patterns as expressions and check for valid patterns below,
611 -- converting the expression into a pattern at the same time.
613 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
614 checkPattern e = checkLPat e
616 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
617 checkPatterns es = mapM checkPattern es
619 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
620 checkLPat e@(L l _) = checkPat l e []
622 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
623 checkPat loc (L l (HsVar c)) args
624 | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
625 checkPat loc e args -- OK to let this happen even if bang-patterns
626 -- are not enabled, because there is no valid
627 -- non-bang-pattern parse of (C ! e)
628 | Just (e', args') <- splitBang e
629 = do { args'' <- checkPatterns args'
630 ; checkPat loc e' (args'' ++ args) }
631 checkPat loc (L _ (HsApp f x)) args
632 = do { x <- checkLPat x; checkPat loc f (x:args) }
633 checkPat loc (L _ e) []
634 = do { p <- checkAPat loc e; return (L loc p) }
635 checkPat loc pat _some_args
638 checkAPat loc e = case e of
639 EWildPat -> return (WildPat placeHolderType)
640 HsVar x | isQual x -> parseError loc ("Qualified variable in pattern: "
642 | otherwise -> return (VarPat x)
643 HsLit l -> return (LitPat l)
645 -- Overloaded numeric patterns (e.g. f 0 x = x)
646 -- Negation is recorded separately, so that the literal is zero or +ve
647 -- NB. Negative *primitive* literals are already handled by the lexer
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 _ (HsRecFields fs dd)
693 -> mapM checkPatField fs >>= \fs ->
694 return (ConPatIn c (RecCon (HsRecFields fs dd)))
696 HsType ty -> return (TypePat ty)
699 plus_RDR, bang_RDR :: RdrName
700 plus_RDR = mkUnqual varName FSLIT("+") -- Hack
701 bang_RDR = mkUnqual varName FSLIT("!") -- Hack
703 checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
704 checkPatField fld = do { p <- checkLPat (hsRecFieldArg fld)
705 ; return (fld { hsRecFieldArg = p }) }
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 = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
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 , con_doc = Nothing }
774 -- NB: we put the whole constr type into the ResTyGADT for now;
775 -- the renamer will unravel it once it has sorted out
778 -- A variable binding is parsed as a FunBind.
781 -- The parser left-associates, so there should
782 -- not be any OpApps inside the e's
783 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
784 -- Splits (f ! g a b) into (f, [(! g), a, b])
785 splitBang (L loc (OpApp l_arg bang@(L loc' (HsVar op)) _ r_arg))
786 | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
788 (arg1,argns) = split_bang r_arg []
789 split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
790 split_bang e es = (e,es)
791 splitBang other = Nothing
793 isFunLhs :: LHsExpr RdrName
794 -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
795 -- Just (fun, is_infix, arg_pats) if e is a function LHS
797 -- The whole LHS is parsed as a single expression.
798 -- Any infix operators on the LHS will parse left-associatively
800 -- will parse (rather strangely) as
802 -- It's up to isFunLhs to sort out the mess
808 go (L loc (HsVar f)) es
809 | not (isRdrDataCon f) = return (Just (L loc f, False, es))
810 go (L _ (HsApp f e)) es = go f (e:es)
811 go (L _ (HsPar e)) es@(_:_) = go e es
813 -- For infix function defns, there should be only one infix *function*
814 -- (though there may be infix *datacons* involved too). So we don't
815 -- need fixity info to figure out which function is being defined.
816 -- a `K1` b `op` c `K2` d
818 -- (a `K1` b) `op` (c `K2` d)
819 -- The renamer checks later that the precedences would yield such a parse.
821 -- There is a complication to deal with bang patterns.
823 -- ToDo: what about this?
824 -- x + 1 `op` y = ...
826 go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
827 | Just (e',es') <- splitBang e
828 = do { bang_on <- extension bangPatEnabled
829 ; if bang_on then go e' (es' ++ es)
830 else return (Just (L loc' op, True, (l:r:es))) }
831 -- No bangs; behave just like the next case
832 | not (isRdrDataCon op) -- We have found the function!
833 = return (Just (L loc' op, True, (l:r:es)))
834 | otherwise -- Infix data con; keep going
835 = do { mb_l <- go l es
837 Just (op', True, j : k : es')
838 -> return (Just (op', True, j : op_app : es'))
840 op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
841 _ -> return Nothing }
842 go _ _ = return Nothing
844 ---------------------------------------------------------------------------
845 -- Miscellaneous utilities
847 checkPrecP :: Located Int -> P Int
849 | 0 <= i && i <= maxPrecedence = return i
850 | otherwise = parseError l "Precedence out of range"
855 -> ([HsRecField RdrName (LHsExpr RdrName)], Bool)
856 -> P (HsExpr RdrName)
858 mkRecConstrOrUpdate (L l (HsVar c)) loc (fs,dd) | isRdrDataCon c
859 = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd))
860 mkRecConstrOrUpdate exp loc (fs,dd)
861 | null fs = parseError loc "Empty record update"
862 | otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] [])
864 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
865 mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
867 mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec
868 -- The Maybe is becuase the user can omit the activation spec (and usually does)
869 mkInlineSpec Nothing True = alwaysInlineSpec -- INLINE
870 mkInlineSpec Nothing False = neverInlineSpec -- NOINLINE
871 mkInlineSpec (Just act) inl = Inline act inl
874 -----------------------------------------------------------------------------
875 -- utilities for foreign declarations
877 -- supported calling conventions
879 data CallConv = CCall CCallConv -- ccall or stdcall
882 -- construct a foreign import declaration
886 -> (Located FastString, Located RdrName, LHsType RdrName)
887 -> P (HsDecl RdrName)
888 mkImport (CCall cconv) safety (entity, v, ty) = do
889 importSpec <- parseCImport entity cconv safety v
890 return (ForD (ForeignImport v ty importSpec))
891 mkImport (DNCall ) _ (entity, v, ty) = do
892 spec <- parseDImport entity
893 return $ ForD (ForeignImport v ty (DNImport spec))
895 -- parse the entity string of a foreign import declaration for the `ccall' or
896 -- `stdcall' calling convention'
898 parseCImport :: Located FastString
903 parseCImport (L loc entity) cconv safety v
904 -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
905 | entity == FSLIT ("dynamic") =
906 return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
907 | entity == FSLIT ("wrapper") =
908 return $ CImport cconv safety nilFS nilFS CWrapper
909 | otherwise = parse0 (unpackFS entity)
911 -- using the static keyword?
912 parse0 (' ': rest) = parse0 rest
913 parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
914 parse0 rest = parse1 rest
915 -- check for header file name
916 parse1 "" = parse4 "" nilFS False nilFS
917 parse1 (' ':rest) = parse1 rest
918 parse1 str@('&':_ ) = parse2 str nilFS
919 parse1 str@('[':_ ) = parse3 str nilFS False
921 | ".h" `isSuffixOf` first = parse2 rest (mkFastString first)
922 | otherwise = parse4 str nilFS False nilFS
924 (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
925 -- check for address operator (indicating a label import)
926 parse2 "" header = parse4 "" header False nilFS
927 parse2 (' ':rest) header = parse2 rest header
928 parse2 ('&':rest) header = parse3 rest header True
929 parse2 str@('[':_ ) header = parse3 str header False
930 parse2 str header = parse4 str header False nilFS
931 -- check for library object name
932 parse3 (' ':rest) header isLbl = parse3 rest header isLbl
933 parse3 ('[':rest) header isLbl =
934 case break (== ']') rest of
935 (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib)
936 _ -> parseError loc "Missing ']' in entity"
937 parse3 str header isLbl = parse4 str header isLbl nilFS
938 -- check for name of C function
939 parse4 "" header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
940 parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib
941 parse4 str header isLbl lib
942 | all (== ' ') rest = build (mkFastString first) header isLbl lib
943 | otherwise = parseError loc "Malformed entity string"
945 (first, rest) = break (== ' ') str
947 build cid header False lib = return $
948 CImport cconv safety header lib (CFunction (StaticTarget cid))
949 build cid header True lib = return $
950 CImport cconv safety header lib (CLabel cid )
953 -- Unravel a dotnet spec string.
955 parseDImport :: Located FastString -> P DNCallSpec
956 parseDImport (L loc entity) = parse0 comps
958 comps = words (unpackFS entity)
962 | x == "static" = parse1 True xs
963 | otherwise = parse1 False (x:xs)
966 parse1 isStatic (x:xs)
967 | x == "method" = parse2 isStatic DNMethod xs
968 | x == "field" = parse2 isStatic DNField xs
969 | x == "ctor" = parse2 isStatic DNConstructor xs
970 parse1 isStatic xs = parse2 isStatic DNMethod xs
973 parse2 isStatic kind (('[':x):xs) =
976 vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
977 parse2 isStatic kind xs = parse3 isStatic kind "" xs
979 parse3 isStatic kind assem [x] =
980 return (DNCallSpec isStatic kind assem x
981 -- these will be filled in once known.
982 (error "FFI-dotnet-args")
983 (error "FFI-dotnet-result"))
984 parse3 _ _ _ _ = d'oh
986 d'oh = parseError loc "Malformed entity string"
988 -- construct a foreign export declaration
991 -> (Located FastString, Located RdrName, LHsType RdrName)
992 -> P (HsDecl RdrName)
993 mkExport (CCall cconv) (L loc entity, v, ty) = return $
994 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
996 entity' | nullFS entity = mkExtName (unLoc v)
998 mkExport DNCall (L loc entity, v, ty) =
999 parseError (getLoc v){-TODO: not quite right-}
1000 "Foreign export is not yet supported for .NET"
1002 -- Supplying the ext_name in a foreign decl is optional; if it
1003 -- isn't there, the Haskell name is assumed. Note that no transformation
1004 -- of the Haskell name is then performed, so if you foreign export (++),
1005 -- it's external name will be "++". Too bad; it's important because we don't
1006 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
1008 mkExtName :: RdrName -> CLabelString
1009 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
1013 -----------------------------------------------------------------------------
1017 showRdrName :: RdrName -> String
1018 showRdrName r = showSDoc (ppr r)
1020 parseError :: SrcSpan -> String -> P a
1021 parseError span s = failSpanMsgP span s