2 % (c) The University of Glasgow, 1996-2003
4 Functions over HsSyn specialised to RdrName.
7 {-# OPTIONS -fno-warn-incomplete-patterns #-}
8 -- The above warning supression flag is a temporary kludge.
9 -- While working on this module you are encouraged to remove it and fix
10 -- any warnings in the module. See
11 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
16 extractHsRhoRdrTyVars, extractGenericPatTyVars,
18 mkHsOpApp, mkClassDecl,
19 mkHsIntegral, mkHsFractional, mkHsIsString,
21 mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec,
22 mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
27 findSplice, checkDecBrGroup,
29 -- Stuff to do with Foreign declarations
31 mkImport, -- CallConv -> Safety
32 -- -> (FastString, RdrName, RdrNameHsType)
35 -- -> (FastString, RdrName, RdrNameHsType)
37 mkExtName, -- RdrName -> CLabelString
38 mkGadtDecl, -- Located RdrName -> LHsType RdrName -> ConDecl RdrName
40 -- Bunch of functions in the parser monad for
41 -- checking and constructing values
42 checkPrecP, -- Int -> P Int
43 checkContext, -- HsType -> P HsContext
44 checkPred, -- HsType -> P HsPred
45 checkTyClHdr, -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName])
46 checkTyVars, -- [LHsType RdrName] -> P ()
47 checkSynHdr, -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName])
48 checkKindSigs, -- [LTyClDecl RdrName] -> P ()
49 checkInstType, -- HsType -> P HsType
50 checkDerivDecl, -- LDerivDecl RdrName -> P (LDerivDecl RdrName)
51 checkPattern, -- HsExp -> P HsPat
53 checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat]
54 checkDo, -- [Stmt] -> P [Stmt]
55 checkMDo, -- [Stmt] -> P [Stmt]
56 checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
57 checkValSig, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
58 parseError, -- String -> Pa
61 #include "HsVersions.h"
63 import HsSyn -- Lots of it
64 import Class ( FunDep )
65 import TypeRep ( Kind )
66 import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc,
67 isRdrDataCon, isUnqual, getRdrName, isQual,
69 import BasicTypes ( maxPrecedence, Activation, InlineSpec(..), alwaysInlineSpec, neverInlineSpec )
70 import Lexer ( P, failSpanMsgP, extension, standaloneDerivingEnabled, bangPatEnabled )
71 import TysWiredIn ( unitTyCon )
72 import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
73 DNCallSpec(..), DNKind(..), CLabelString )
74 import OccName ( srcDataName, varName, isDataOcc, isTcOcc,
77 import OrdList ( OrdList, fromOL )
78 import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag )
82 import List ( isSuffixOf, nubBy )
83 import Monad ( unless )
87 %************************************************************************
89 \subsection{A few functions over HsSyn at RdrName}
91 %************************************************************************
93 extractHsTyRdrNames finds the free variables of a HsType
94 It's used when making the for-alls explicit.
97 extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName]
98 extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty [])
100 extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName]
101 -- This one takes the context and tau-part of a
102 -- sigma type and returns their free type variables
103 extractHsRhoRdrTyVars ctxt ty
104 = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty [])
106 extract_lctxt :: Located [LHsPred RdrName] -> [Located RdrName] -> [Located RdrName]
107 extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt)
109 extract_pred :: HsPred RdrName -> [Located RdrName] -> [Located RdrName]
110 extract_pred (HsClassP _ tys) acc = foldr extract_lty acc tys
111 extract_pred (HsEqualP ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
112 extract_pred (HsIParam _ ty ) acc = extract_lty ty acc
114 extract_lty :: LHsType RdrName -> [Located RdrName] -> [Located RdrName]
115 extract_lty (L loc ty) acc
117 HsTyVar tv -> extract_tv loc tv acc
118 HsBangTy _ ty -> extract_lty ty acc
119 HsAppTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
120 HsListTy ty -> extract_lty ty acc
121 HsPArrTy ty -> extract_lty ty acc
122 HsTupleTy _ tys -> foldr extract_lty acc tys
123 HsFunTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
124 HsPredTy p -> extract_pred p acc
125 HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
126 HsParTy ty -> extract_lty ty acc
128 HsSpliceTy _ -> acc -- Type splices mention no type variables
129 HsKindSig ty _ -> extract_lty ty acc
130 HsForAllTy _ [] cx ty -> extract_lctxt cx (extract_lty ty acc)
131 HsForAllTy _ tvs cx ty -> acc ++ (filter ((`notElem` locals) . unLoc) $
132 extract_lctxt cx (extract_lty ty []))
134 locals = hsLTyVarNames tvs
135 HsDocTy ty _ -> extract_lty ty acc
137 extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName]
138 extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc
141 extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName]
142 -- Get the type variables out of the type patterns in a bunch of
143 -- possibly-generic bindings in a class declaration
144 extractGenericPatTyVars binds
145 = nubBy eqLocated (foldrBag get [] binds)
147 get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms
150 get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
155 %************************************************************************
157 \subsection{Construction functions for Rdr stuff}
159 %************************************************************************
161 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
162 by deriving them from the name of the class. We fill in the names for the
163 tycon and datacon corresponding to the class, by deriving them from the
164 name of the class itself. This saves recording the names in the interface
165 file (which would be equally good).
167 Similarly for mkConDecl, mkClassOpSig and default-method names.
169 *** See "THE NAMING STORY" in HsDecls ****
172 mkClassDecl :: (LHsContext name, Located name, [LHsTyVarBndr name])
173 -> [Located (FunDep name)]
179 mkClassDecl (cxt, cname, tyvars) fds sigs mbinds ats docs
180 = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
188 mkTyData :: NewOrData
192 Maybe [LHsType name])
195 -> Maybe [LHsType name]
197 mkTyData new_or_data (context, tname, tyvars, typats) ksig data_cons maybe_deriv
198 = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
199 tcdTyVars = tyvars, tcdTyPats = typats, tcdCons = data_cons,
200 tcdKindSig = ksig, tcdDerivs = maybe_deriv }
203 %************************************************************************
205 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
207 %************************************************************************
209 Function definitions are restructured here. Each is assumed to be recursive
210 initially, and non recursive definitions are discovered by the dependency
215 -- | Groups together bindings for a single function
216 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
217 cvTopDecls decls = go (fromOL decls)
219 go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
221 go (L l (ValD b) : ds) = L l' (ValD b') : go ds'
222 where (L l' b', ds') = getMonoBind (L l b) ds
223 go (d : ds) = d : go ds
225 -- Declaration list may only contain value bindings and signatures.
226 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
228 = case cvBindsAndSigs binding of
229 (mbs, sigs, [], _) -> -- list of type decls *always* empty
232 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
233 -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl RdrName])
234 -- Input decls contain just value bindings and signatures
235 -- and in case of class or instance declarations also
236 -- associated type declarations. They might also contain Haddock comments.
237 cvBindsAndSigs fb = go (fromOL fb)
239 go [] = (emptyBag, [], [], [])
240 go (L l (SigD s) : ds) = (bs, L l s : ss, ts, docs)
241 where (bs, ss, ts, docs) = go ds
242 go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, docs)
243 where (b', ds') = getMonoBind (L l b) ds
244 (bs, ss, ts, docs) = go ds'
245 go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs)
246 where (bs, ss, ts, docs) = go ds
247 go (L l (DocD d) : ds) = (bs, ss, ts, (L l d) : docs)
248 where (bs, ss, ts, docs) = go ds
250 -----------------------------------------------------------------------------
251 -- Group function bindings into equation groups
253 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
254 -> (LHsBind RdrName, [LHsDecl RdrName])
255 -- Suppose (b',ds') = getMonoBind b ds
256 -- ds is a list of parsed bindings
257 -- b is a MonoBinds that has just been read off the front
259 -- Then b' is the result of grouping more equations from ds that
260 -- belong with b into a single MonoBinds, and ds' is the depleted
261 -- list of parsed bindings.
263 -- All Haddock comments between equations inside the group are
266 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
268 getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1,
269 fun_matches = MatchGroup mtchs1 _ })) binds
271 = go is_infix1 mtchs1 loc1 binds []
273 go is_infix mtchs loc
274 (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
275 fun_matches = MatchGroup mtchs2 _ })) : binds) _
276 | f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs)
277 (combineSrcSpans loc loc2) binds []
278 go is_infix mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls
279 = let doc_decls' = doc_decl : doc_decls
280 in go is_infix mtchs (combineSrcSpans loc loc2) binds doc_decls'
281 go is_infix mtchs loc binds doc_decls
282 = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), (reverse doc_decls) ++ binds)
283 -- Reverse the final matches, to get it back in the right order
284 -- Do the same thing with the trailing doc comments
286 getMonoBind bind binds = (bind, binds)
288 has_args :: [LMatch RdrName] -> Bool
289 has_args ((L _ (Match args _ _)) : _) = not (null args)
290 -- Don't group together FunBinds if they have
291 -- no arguments. This is necessary now that variable bindings
292 -- with no arguments are now treated as FunBinds rather
293 -- than pattern bindings (tests/rename/should_fail/rnfail002).
297 findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
298 findSplice ds = addl emptyRdrGroup ds
300 checkDecBrGroup :: [LHsDecl a] -> P (HsGroup a)
301 -- Turn the body of a [d| ... |] into a HsGroup
302 -- There should be no splices in the "..."
303 checkDecBrGroup decls
304 = case addl emptyRdrGroup decls of
305 (group, Nothing) -> return group
306 (_, Just (SpliceDecl (L loc _), _)) ->
307 parseError loc "Declaration splices are not permitted inside declaration brackets"
308 -- Why not? See Section 7.3 of the TH paper.
310 addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
311 -- This stuff reverses the declarations (again) but it doesn't matter
314 addl gp [] = (gp, Nothing)
315 addl gp (L l d : ds) = add gp l d ds
318 add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a]
319 -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
321 add gp _ (SpliceD e) ds = (gp, Just (e, ds))
323 -- Class declarations: pull out the fixity signatures to the top
324 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs})
327 let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
328 addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs}) ds
330 addl (gp { hs_tyclds = L l d : ts }) ds
332 -- Signatures: fixity sigs go a different place than all others
333 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
334 = addl (gp {hs_fixds = L l f : ts}) ds
335 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
336 = addl (gp {hs_valds = add_sig (L l d) ts}) ds
338 -- Value declarations: use add_bind
339 add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds
340 = addl (gp { hs_valds = add_bind (L l d) ts }) ds
342 -- The rest are routine
343 add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds
344 = addl (gp { hs_instds = L l d : ts }) ds
345 add gp@(HsGroup {hs_derivds = ts}) l (DerivD d) ds
346 = addl (gp { hs_derivds = L l d : ts }) ds
347 add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
348 = addl (gp { hs_defds = L l d : ts }) ds
349 add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
350 = addl (gp { hs_fords = L l d : ts }) ds
351 add gp@(HsGroup {hs_depds = ts}) l (DeprecD d) ds
352 = addl (gp { hs_depds = L l d : ts }) ds
353 add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
354 = addl (gp { hs_ruleds = L l d : ts }) ds
357 = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds
359 add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
360 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
362 add_sig :: LSig a -> HsValBinds a -> HsValBinds a
363 add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
366 %************************************************************************
368 \subsection[PrefixToHS-utils]{Utilities for conversion}
370 %************************************************************************
374 -----------------------------------------------------------------------------
377 -- When parsing data declarations, we sometimes inadvertently parse
378 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
379 -- This function splits up the type application, adds any pending
380 -- arguments, and converts the type constructor back into a data constructor.
382 mkPrefixCon :: LHsType RdrName -> [LBangType RdrName]
383 -> P (Located RdrName, HsConDeclDetails RdrName)
387 split (L _ (HsAppTy t u)) ts = split t (u : ts)
388 split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc
389 return (data_con, PrefixCon ts)
390 split (L l _) _ = parseError l "parse error in data/newtype declaration"
392 mkRecCon :: Located RdrName ->
393 [([Located RdrName], LBangType RdrName, Maybe (LHsDoc RdrName))] ->
394 P (Located RdrName, HsConDeclDetails RdrName)
395 mkRecCon (L loc con) fields
396 = do data_con <- tyConToDataCon loc con
397 return (data_con, RecCon [ ConDeclField l t d | (ls, t, d) <- fields, l <- ls ])
399 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
400 tyConToDataCon loc tc
401 | isTcOcc (rdrNameOcc tc)
402 = return (L loc (setRdrNameSpace tc srcDataName))
404 = parseError loc (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
406 ----------------------------------------------------------------------------
407 -- Various Syntactic Checks
409 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
410 checkInstType (L l t)
412 HsForAllTy exp tvs ctxt ty -> do
413 dict_ty <- checkDictTy ty
414 return (L l (HsForAllTy exp tvs ctxt dict_ty))
416 HsParTy ty -> checkInstType ty
418 ty -> do dict_ty <- checkDictTy (L l ty)
419 return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
421 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
422 checkDictTy (L spn ty) = check ty []
424 check (HsTyVar t) args | not (isRdrTyVar t)
425 = return (L spn (HsPredTy (HsClassP t args)))
426 check (HsAppTy l r) args = check (unLoc l) (r:args)
427 check (HsParTy t) args = check (unLoc t) args
428 check _ _ = parseError spn "Malformed instance header"
430 -- Check whether the given list of type parameters are all type variables
431 -- (possibly with a kind signature). If the second argument is `False',
432 -- only type variables are allowed and we raise an error on encountering a
433 -- non-variable; otherwise, we allow non-variable arguments and return the
434 -- entire list of parameters.
436 checkTyVars :: [LHsType RdrName] -> P ()
437 checkTyVars tparms = mapM_ chk tparms
439 -- Check that the name space is correct!
440 chk (L _ (HsKindSig (L _ (HsTyVar tv)) _))
441 | isRdrTyVar tv = return ()
442 chk (L _ (HsTyVar tv))
443 | isRdrTyVar tv = return ()
445 parseError l "Type found where type variable expected"
447 -- Check whether the type arguments in a type synonym head are simply
448 -- variables. If not, we have a type family instance and return all patterns.
449 -- If yes, we return 'Nothing' as the third component to indicate a vanilla
452 checkSynHdr :: LHsType RdrName
453 -> Bool -- is type instance?
454 -> P (Located RdrName, -- head symbol
455 [LHsTyVarBndr RdrName], -- parameters
456 [LHsType RdrName]) -- type patterns
457 checkSynHdr ty isTyInst =
458 do { (_, tc, tvs, tparms) <- checkTyClHdr (noLoc []) ty
459 ; unless isTyInst $ checkTyVars tparms
460 ; return (tc, tvs, tparms) }
463 -- Well-formedness check and decomposition of type and class heads.
465 checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
466 -> P (LHsContext RdrName, -- the type context
467 Located RdrName, -- the head symbol (type or class name)
468 [LHsTyVarBndr RdrName], -- free variables of the non-context part
469 [LHsType RdrName]) -- parameters of head symbol
470 -- The header of a type or class decl should look like
471 -- (C a, D b) => T a b
475 -- With associated types, we can also have non-variable parameters; ie,
478 -- The unaltered parameter list is returned in the fourth component of the
482 -- ('()', 'T', ['a'], ['Int', '[a]'])
483 checkTyClHdr (L l cxt) ty
484 = do (tc, tvs, parms) <- gol ty []
486 return (L l cxt, tc, tvs, parms)
488 gol (L l ty) acc = go l ty acc
490 go l (HsTyVar tc) acc
491 | isRdrTc tc = do tvs <- extractTyVars acc
492 return (L l tc, tvs, acc)
493 go _ (HsOpTy t1 ltc@(L _ tc) t2) acc
494 | isRdrTc tc = do tvs <- extractTyVars (t1:t2:acc)
495 return (ltc, tvs, t1:t2:acc)
496 go _ (HsParTy ty) acc = gol ty acc
497 go _ (HsAppTy t1 t2) acc = gol t1 (t2:acc)
499 parseError l "Malformed head of type or class declaration"
501 -- The predicates in a type or class decl must be class predicates or
502 -- equational constraints. They need not all have variable-only
503 -- arguments, even in Haskell 98.
504 -- E.g. class (Monad m, Monad (t m)) => MonadT t m
505 chk_pred (L _ (HsClassP _ _)) = return ()
506 chk_pred (L _ (HsEqualP _ _)) = return ()
508 = parseError l "Malformed context in type or class declaration"
510 -- Extract the type variables of a list of type parameters.
512 -- * Type arguments can be complex type terms (needed for associated type
515 extractTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
516 extractTyVars tvs = collects tvs []
518 -- Collect all variables (2nd arg serves as an accumulator)
519 collect :: LHsType RdrName -> [LHsTyVarBndr RdrName]
520 -> P [LHsTyVarBndr RdrName]
521 collect (L l (HsForAllTy _ _ _ _)) =
522 const $ parseError l "Forall type not allowed as type parameter"
523 collect (L l (HsTyVar tv))
524 | isRdrTyVar tv = return . (L l (UserTyVar tv) :)
526 collect (L l (HsBangTy _ _ )) =
527 const $ parseError l "Bang-style type annotations not allowed as type parameter"
528 collect (L _ (HsAppTy t1 t2 )) = collect t2 >=> collect t1
529 collect (L _ (HsFunTy t1 t2 )) = collect t2 >=> collect t1
530 collect (L _ (HsListTy t )) = collect t
531 collect (L _ (HsPArrTy t )) = collect t
532 collect (L _ (HsTupleTy _ ts )) = collects ts
533 collect (L _ (HsOpTy t1 _ t2 )) = collect t2 >=> collect t1
534 collect (L _ (HsParTy t )) = collect t
535 collect (L _ (HsNumTy _ )) = return
536 collect (L l (HsPredTy _ )) =
537 const $ parseError l "Predicate not allowed as type parameter"
538 collect (L l (HsKindSig (L _ (HsTyVar tv)) k))
540 return . (L l (KindedTyVar tv k) :)
542 const $ parseError l "Kind signature only allowed for type variables"
543 collect (L l (HsSpliceTy _ )) =
544 const $ parseError l "Splice not allowed as type parameter"
546 -- Collect all variables of a list of types
548 collects (t:ts) = collects ts >=> collect t
550 (f >=> g) x = f x >>= g
552 -- Check that associated type declarations of a class are all kind signatures.
554 checkKindSigs :: [LTyClDecl RdrName] -> P ()
555 checkKindSigs = mapM_ check
558 | isFamilyDecl tydecl
559 || isSynDecl tydecl = return ()
561 parseError l "Type declaration in a class must be a kind signature or synonym default"
563 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
567 check (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
568 = do ctx <- mapM checkPred ts
571 check (HsParTy ty) -- to be sure HsParTy doesn't get into the way
574 check (HsTyVar t) -- Empty context shows up as a unit type ()
575 | t == getRdrName unitTyCon = return (L l [])
578 = do p <- checkPred (L l t)
582 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
583 -- Watch out.. in ...deriving( Show )... we use checkPred on
584 -- the list of partially applied predicates in the deriving,
585 -- so there can be zero args.
586 checkPred (L spn (HsPredTy (HsIParam n ty)))
587 = return (L spn (HsIParam n ty))
591 checkl (L l ty) args = check l ty args
593 check _loc (HsPredTy pred@(HsEqualP _ _))
595 = return $ L spn pred
596 check _loc (HsTyVar t) args | not (isRdrTyVar t)
597 = return (L spn (HsClassP t args))
598 check _loc (HsAppTy l r) args = checkl l (r:args)
599 check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
600 check _loc (HsParTy t) args = checkl t args
601 check loc _ _ = parseError loc
602 "malformed class assertion"
604 ---------------------------------------------------------------------------
605 -- Checking stand-alone deriving declarations
607 checkDerivDecl :: LDerivDecl RdrName -> P (LDerivDecl RdrName)
608 checkDerivDecl d@(L loc _) =
609 do stDerivOn <- extension standaloneDerivingEnabled
610 if stDerivOn then return d
611 else parseError loc "Illegal stand-alone deriving declaration (use -XStandaloneDeriving)"
613 ---------------------------------------------------------------------------
614 -- Checking statements in a do-expression
615 -- We parse do { e1 ; e2 ; }
616 -- as [ExprStmt e1, ExprStmt e2]
617 -- checkDo (a) checks that the last thing is an ExprStmt
618 -- (b) returns it separately
619 -- same comments apply for mdo as well
621 checkDo, checkMDo :: SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
623 checkDo = checkDoMDo "a " "'do'"
624 checkMDo = checkDoMDo "an " "'mdo'"
626 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
627 checkDoMDo _ nm loc [] = parseError loc ("Empty " ++ nm ++ " construct")
628 checkDoMDo pre nm _ ss = do
631 check [L _ (ExprStmt e _ _)] = return ([], e)
632 check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
633 " construct must be an expression")
638 -- -------------------------------------------------------------------------
639 -- Checking Patterns.
641 -- We parse patterns as expressions and check for valid patterns below,
642 -- converting the expression into a pattern at the same time.
644 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
645 checkPattern e = checkLPat e
647 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
648 checkPatterns es = mapM checkPattern es
650 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
651 checkLPat e@(L l _) = checkPat l e []
653 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
654 checkPat loc (L l (HsVar c)) args
655 | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
656 checkPat loc e args -- OK to let this happen even if bang-patterns
657 -- are not enabled, because there is no valid
658 -- non-bang-pattern parse of (C ! e)
659 | Just (e', args') <- splitBang e
660 = do { args'' <- checkPatterns args'
661 ; checkPat loc e' (args'' ++ args) }
662 checkPat loc (L _ (HsApp f x)) args
663 = do { x <- checkLPat x; checkPat loc f (x:args) }
664 checkPat loc (L _ e) []
665 = do { p <- checkAPat loc e; return (L loc p) }
669 checkAPat :: SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
670 checkAPat loc e = case e of
671 EWildPat -> return (WildPat placeHolderType)
672 HsVar x | isQual x -> parseError loc ("Qualified variable in pattern: "
674 | otherwise -> return (VarPat x)
675 HsLit l -> return (LitPat l)
677 -- Overloaded numeric patterns (e.g. f 0 x = x)
678 -- Negation is recorded separately, so that the literal is zero or +ve
679 -- NB. Negative *primitive* literals are already handled by the lexer
680 HsOverLit pos_lit -> return (mkNPat pos_lit Nothing)
681 NegApp (L _ (HsOverLit pos_lit)) _
682 -> return (mkNPat pos_lit (Just noSyntaxExpr))
684 SectionR (L _ (HsVar bang)) e -- (! x)
686 -> do { bang_on <- extension bangPatEnabled
687 ; if bang_on then checkLPat e >>= (return . BangPat)
688 else parseError loc "Illegal bang-pattern (use -fbang-patterns)" }
690 ELazyPat e -> checkLPat e >>= (return . LazyPat)
691 EAsPat n e -> checkLPat e >>= (return . AsPat n)
692 -- view pattern is well-formed if the pattern is
693 EViewPat expr patE -> checkLPat patE >>= (return . (\p -> ViewPat expr p placeHolderType))
694 ExprWithTySig e t -> do e <- checkLPat e
695 -- Pattern signatures are parsed as sigtypes,
696 -- but they aren't explicit forall points. Hence
697 -- we have to remove the implicit forall here.
699 L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
701 return (SigPatIn e t')
704 OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
705 (L _ (HsOverLit lit@(HsIntegral _ _ _)))
707 -> return (mkNPlusKPat (L nloc n) lit)
709 OpApp l op _fix r -> do l <- checkLPat l
712 L cl (HsVar c) | isDataOcc (rdrNameOcc c)
713 -> return (ConPatIn (L cl c) (InfixCon l r))
716 HsPar e -> checkLPat e >>= (return . ParPat)
717 ExplicitList _ es -> do ps <- mapM checkLPat es
718 return (ListPat ps placeHolderType)
719 ExplicitPArr _ es -> do ps <- mapM checkLPat es
720 return (PArrPat ps placeHolderType)
722 ExplicitTuple es b -> do ps <- mapM checkLPat es
723 return (TuplePat ps b placeHolderType)
725 RecordCon c _ (HsRecFields fs dd)
726 -> do fs <- mapM checkPatField fs
727 return (ConPatIn c (RecCon (HsRecFields fs dd)))
728 HsQuasiQuoteE q -> return (QuasiQuotePat q)
730 HsType ty -> return (TypePat ty)
733 plus_RDR, bang_RDR :: RdrName
734 plus_RDR = mkUnqual varName FSLIT("+") -- Hack
735 bang_RDR = mkUnqual varName FSLIT("!") -- Hack
737 checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
738 checkPatField fld = do { p <- checkLPat (hsRecFieldArg fld)
739 ; return (fld { hsRecFieldArg = p }) }
741 patFail :: SrcSpan -> P a
742 patFail loc = parseError loc "Parse error in pattern"
745 ---------------------------------------------------------------------------
746 -- Check Equation Syntax
748 checkValDef :: LHsExpr RdrName
749 -> Maybe (LHsType RdrName)
750 -> Located (GRHSs RdrName)
751 -> P (HsBind RdrName)
753 checkValDef lhs (Just sig) grhss
754 -- x :: ty = rhs parses as a *pattern* binding
755 = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
757 checkValDef lhs opt_sig grhss
758 = do { mb_fun <- isFunLhs lhs
760 Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
761 fun is_infix pats opt_sig grhss
762 Nothing -> checkPatBind lhs grhss }
764 checkFunBind :: SrcSpan
768 -> Maybe (LHsType RdrName)
769 -> Located (GRHSs RdrName)
770 -> P (HsBind RdrName)
771 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
773 = parseError (getLoc fun) ("Qualified name in function definition: " ++
774 showRdrName (unLoc fun))
776 = do ps <- checkPatterns pats
777 let match_span = combineSrcSpans lhs_loc rhs_span
778 return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
779 -- The span of the match covers the entire equation.
780 -- That isn't quite right, but it'll do for now.
782 makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
783 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
784 makeFunBind fn is_infix ms
785 = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
786 fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
788 checkPatBind :: LHsExpr RdrName
789 -> Located (GRHSs RdrName)
790 -> P (HsBind RdrName)
791 checkPatBind lhs (L _ grhss)
792 = do { lhs <- checkPattern lhs
793 ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
799 checkValSig (L l (HsVar v)) ty
800 | isUnqual v && not (isDataOcc (rdrNameOcc v))
801 = return (TypeSig (L l v) ty)
802 checkValSig (L l _) _
803 = parseError l "Invalid type signature"
805 mkGadtDecl :: Located RdrName
806 -> LHsType RdrName -- assuming HsType
808 mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = mk_gadt_con name qvars cxt ty
809 mkGadtDecl name ty = mk_gadt_con name [] (noLoc []) ty
811 mk_gadt_con :: Located RdrName
812 -> [LHsTyVarBndr RdrName]
813 -> LHsContext RdrName
816 mk_gadt_con name qvars cxt ty
817 = ConDecl { con_name = name
818 , con_explicit = Implicit
821 , con_details = PrefixCon []
822 , con_res = ResTyGADT ty
823 , con_doc = Nothing }
824 -- NB: we put the whole constr type into the ResTyGADT for now;
825 -- the renamer will unravel it once it has sorted out
828 -- A variable binding is parsed as a FunBind.
831 -- The parser left-associates, so there should
832 -- not be any OpApps inside the e's
833 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
834 -- Splits (f ! g a b) into (f, [(! g), a, b])
835 splitBang (L loc (OpApp l_arg bang@(L _ (HsVar op)) _ r_arg))
836 | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
838 (arg1,argns) = split_bang r_arg []
839 split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
840 split_bang e es = (e,es)
841 splitBang _ = Nothing
843 isFunLhs :: LHsExpr RdrName
844 -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
845 -- Just (fun, is_infix, arg_pats) if e is a function LHS
847 -- The whole LHS is parsed as a single expression.
848 -- Any infix operators on the LHS will parse left-associatively
850 -- will parse (rather strangely) as
852 -- It's up to isFunLhs to sort out the mess
858 go (L loc (HsVar f)) es
859 | not (isRdrDataCon f) = return (Just (L loc f, False, es))
860 go (L _ (HsApp f e)) es = go f (e:es)
861 go (L _ (HsPar e)) es@(_:_) = go e es
863 -- For infix function defns, there should be only one infix *function*
864 -- (though there may be infix *datacons* involved too). So we don't
865 -- need fixity info to figure out which function is being defined.
866 -- a `K1` b `op` c `K2` d
868 -- (a `K1` b) `op` (c `K2` d)
869 -- The renamer checks later that the precedences would yield such a parse.
871 -- There is a complication to deal with bang patterns.
873 -- ToDo: what about this?
874 -- x + 1 `op` y = ...
876 go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
877 | Just (e',es') <- splitBang e
878 = do { bang_on <- extension bangPatEnabled
879 ; if bang_on then go e' (es' ++ es)
880 else return (Just (L loc' op, True, (l:r:es))) }
881 -- No bangs; behave just like the next case
882 | not (isRdrDataCon op) -- We have found the function!
883 = return (Just (L loc' op, True, (l:r:es)))
884 | otherwise -- Infix data con; keep going
885 = do { mb_l <- go l es
887 Just (op', True, j : k : es')
888 -> return (Just (op', True, j : op_app : es'))
890 op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
891 _ -> return Nothing }
892 go _ _ = return Nothing
894 ---------------------------------------------------------------------------
895 -- Miscellaneous utilities
897 checkPrecP :: Located Int -> P Int
899 | 0 <= i && i <= maxPrecedence = return i
900 | otherwise = parseError l "Precedence out of range"
905 -> ([HsRecField RdrName (LHsExpr RdrName)], Bool)
906 -> P (HsExpr RdrName)
908 mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) | isRdrDataCon c
909 = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd))
910 mkRecConstrOrUpdate exp loc (fs,dd)
911 | null fs = parseError loc "Empty record update"
912 | otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] [])
914 mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg
915 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
916 mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
918 mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec
919 -- The Maybe is becuase the user can omit the activation spec (and usually does)
920 mkInlineSpec Nothing True = alwaysInlineSpec -- INLINE
921 mkInlineSpec Nothing False = neverInlineSpec -- NOINLINE
922 mkInlineSpec (Just act) inl = Inline act inl
925 -----------------------------------------------------------------------------
926 -- utilities for foreign declarations
928 -- supported calling conventions
930 data CallConv = CCall CCallConv -- ccall or stdcall
933 -- construct a foreign import declaration
937 -> (Located FastString, Located RdrName, LHsType RdrName)
938 -> P (HsDecl RdrName)
939 mkImport (CCall cconv) safety (entity, v, ty) = do
940 importSpec <- parseCImport entity cconv safety v
941 return (ForD (ForeignImport v ty importSpec))
942 mkImport (DNCall ) _ (entity, v, ty) = do
943 spec <- parseDImport entity
944 return $ ForD (ForeignImport v ty (DNImport spec))
946 -- parse the entity string of a foreign import declaration for the `ccall' or
947 -- `stdcall' calling convention'
949 parseCImport :: Located FastString
954 parseCImport (L loc entity) cconv safety v
955 -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
956 | entity == FSLIT ("dynamic") =
957 return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
958 | entity == FSLIT ("wrapper") =
959 return $ CImport cconv safety nilFS nilFS CWrapper
960 | otherwise = parse0 (unpackFS entity)
962 -- using the static keyword?
963 parse0 (' ': rest) = parse0 rest
964 parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
965 parse0 rest = parse1 rest
966 -- check for header file name
967 parse1 "" = parse4 "" nilFS False nilFS
968 parse1 (' ':rest) = parse1 rest
969 parse1 str@('&':_ ) = parse2 str nilFS
970 parse1 str@('[':_ ) = parse3 str nilFS False
972 | ".h" `isSuffixOf` first = parse2 rest (mkFastString first)
973 | otherwise = parse4 str nilFS False nilFS
975 (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
976 -- check for address operator (indicating a label import)
977 parse2 "" header = parse4 "" header False nilFS
978 parse2 (' ':rest) header = parse2 rest header
979 parse2 ('&':rest) header = parse3 rest header True
980 parse2 str@('[':_ ) header = parse3 str header False
981 parse2 str header = parse4 str header False nilFS
982 -- check for library object name
983 parse3 (' ':rest) header isLbl = parse3 rest header isLbl
984 parse3 ('[':rest) header isLbl =
985 case break (== ']') rest of
986 (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib)
987 _ -> parseError loc "Missing ']' in entity"
988 parse3 str header isLbl = parse4 str header isLbl nilFS
989 -- check for name of C function
990 parse4 "" header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
991 parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib
992 parse4 str header isLbl lib
993 | all (== ' ') rest = build (mkFastString first) header isLbl lib
994 | otherwise = parseError loc "Malformed entity string"
996 (first, rest) = break (== ' ') str
998 build cid header False lib = return $
999 CImport cconv safety header lib (CFunction (StaticTarget cid))
1000 build cid header True lib = return $
1001 CImport cconv safety header lib (CLabel cid )
1004 -- Unravel a dotnet spec string.
1006 parseDImport :: Located FastString -> P DNCallSpec
1007 parseDImport (L loc entity) = parse0 comps
1009 comps = words (unpackFS entity)
1013 | x == "static" = parse1 True xs
1014 | otherwise = parse1 False (x:xs)
1017 parse1 isStatic (x:xs)
1018 | x == "method" = parse2 isStatic DNMethod xs
1019 | x == "field" = parse2 isStatic DNField xs
1020 | x == "ctor" = parse2 isStatic DNConstructor xs
1021 parse1 isStatic xs = parse2 isStatic DNMethod xs
1023 parse2 _ _ [] = d'oh
1024 parse2 isStatic kind (('[':x):xs) =
1027 vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
1029 parse2 isStatic kind xs = parse3 isStatic kind "" xs
1031 parse3 isStatic kind assem [x] =
1032 return (DNCallSpec isStatic kind assem x
1033 -- these will be filled in once known.
1034 (error "FFI-dotnet-args")
1035 (error "FFI-dotnet-result"))
1036 parse3 _ _ _ _ = d'oh
1038 d'oh = parseError loc "Malformed entity string"
1040 -- construct a foreign export declaration
1042 mkExport :: CallConv
1043 -> (Located FastString, Located RdrName, LHsType RdrName)
1044 -> P (HsDecl RdrName)
1045 mkExport (CCall cconv) (L _ entity, v, ty) = return $
1046 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
1048 entity' | nullFS entity = mkExtName (unLoc v)
1049 | otherwise = entity
1050 mkExport DNCall (L _ _, v, _) =
1051 parseError (getLoc v){-TODO: not quite right-}
1052 "Foreign export is not yet supported for .NET"
1054 -- Supplying the ext_name in a foreign decl is optional; if it
1055 -- isn't there, the Haskell name is assumed. Note that no transformation
1056 -- of the Haskell name is then performed, so if you foreign export (++),
1057 -- it's external name will be "++". Too bad; it's important because we don't
1058 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
1060 mkExtName :: RdrName -> CLabelString
1061 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
1065 -----------------------------------------------------------------------------
1069 showRdrName :: RdrName -> String
1070 showRdrName r = showSDoc (ppr r)
1072 parseError :: SrcSpan -> String -> P a
1073 parseError span s = failSpanMsgP span s