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 import HsSyn -- Lots of it
62 import Class ( FunDep )
63 import TypeRep ( Kind )
64 import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc,
65 isRdrDataCon, isUnqual, getRdrName, isQual,
66 setRdrNameSpace, showRdrName )
67 import BasicTypes ( maxPrecedence, Activation, InlineSpec(..), alwaysInlineSpec, neverInlineSpec )
68 import Lexer ( P, failSpanMsgP, extension, standaloneDerivingEnabled, bangPatEnabled )
69 import TysWiredIn ( unitTyCon )
70 import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
71 DNCallSpec(..), DNKind(..), CLabelString )
72 import OccName ( srcDataName, varName, isDataOcc, isTcOcc,
74 import PrelNames ( forall_tv_RDR )
76 import OrdList ( OrdList, fromOL )
77 import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag )
81 import List ( isSuffixOf, nubBy )
82 import Monad ( unless )
86 %************************************************************************
88 \subsection{A few functions over HsSyn at RdrName}
90 %************************************************************************
92 extractHsTyRdrNames finds the free variables of a HsType
93 It's used when making the for-alls explicit.
96 extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName]
97 extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty [])
99 extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName]
100 -- This one takes the context and tau-part of a
101 -- sigma type and returns their free type variables
102 extractHsRhoRdrTyVars ctxt ty
103 = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty [])
105 extract_lctxt :: Located [LHsPred RdrName] -> [Located RdrName] -> [Located RdrName]
106 extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt)
108 extract_pred :: HsPred RdrName -> [Located RdrName] -> [Located RdrName]
109 extract_pred (HsClassP _ tys) acc = foldr extract_lty acc tys
110 extract_pred (HsEqualP ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
111 extract_pred (HsIParam _ ty ) acc = extract_lty ty acc
113 extract_lty :: LHsType RdrName -> [Located RdrName] -> [Located RdrName]
114 extract_lty (L loc ty) acc
116 HsTyVar tv -> extract_tv loc tv acc
117 HsBangTy _ ty -> extract_lty ty acc
118 HsAppTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
119 HsListTy ty -> extract_lty ty acc
120 HsPArrTy ty -> extract_lty ty acc
121 HsTupleTy _ tys -> foldr extract_lty acc tys
122 HsFunTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
123 HsPredTy p -> extract_pred p acc
124 HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
125 HsParTy ty -> extract_lty ty acc
127 HsSpliceTy _ -> acc -- Type splices mention no type variables
128 HsKindSig ty _ -> extract_lty ty acc
129 HsForAllTy _ [] cx ty -> extract_lctxt cx (extract_lty ty acc)
130 HsForAllTy _ tvs cx ty -> acc ++ (filter ((`notElem` locals) . unLoc) $
131 extract_lctxt cx (extract_lty ty []))
133 locals = hsLTyVarNames tvs
134 HsDocTy ty _ -> extract_lty ty acc
136 extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName]
137 extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc
140 extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName]
141 -- Get the type variables out of the type patterns in a bunch of
142 -- possibly-generic bindings in a class declaration
143 extractGenericPatTyVars binds
144 = nubBy eqLocated (foldrBag get [] binds)
146 get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms
149 get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
154 %************************************************************************
156 \subsection{Construction functions for Rdr stuff}
158 %************************************************************************
160 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
161 by deriving them from the name of the class. We fill in the names for the
162 tycon and datacon corresponding to the class, by deriving them from the
163 name of the class itself. This saves recording the names in the interface
164 file (which would be equally good).
166 Similarly for mkConDecl, mkClassOpSig and default-method names.
168 *** See "THE NAMING STORY" in HsDecls ****
171 mkClassDecl :: (LHsContext name, Located name, [LHsTyVarBndr name])
172 -> [Located (FunDep name)]
178 mkClassDecl (cxt, cname, tyvars) fds sigs mbinds ats docs
179 = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
187 mkTyData :: NewOrData
191 Maybe [LHsType name])
194 -> Maybe [LHsType name]
196 mkTyData new_or_data (context, tname, tyvars, typats) ksig data_cons maybe_deriv
197 = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
198 tcdTyVars = tyvars, tcdTyPats = typats, tcdCons = data_cons,
199 tcdKindSig = ksig, tcdDerivs = maybe_deriv }
202 %************************************************************************
204 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
206 %************************************************************************
208 Function definitions are restructured here. Each is assumed to be recursive
209 initially, and non recursive definitions are discovered by the dependency
214 -- | Groups together bindings for a single function
215 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
216 cvTopDecls decls = go (fromOL decls)
218 go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
220 go (L l (ValD b) : ds) = L l' (ValD b') : go ds'
221 where (L l' b', ds') = getMonoBind (L l b) ds
222 go (d : ds) = d : go ds
224 -- Declaration list may only contain value bindings and signatures.
225 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
227 = case cvBindsAndSigs binding of
228 (mbs, sigs, [], _) -> -- list of type decls *always* empty
231 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
232 -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl RdrName])
233 -- Input decls contain just value bindings and signatures
234 -- and in case of class or instance declarations also
235 -- associated type declarations. They might also contain Haddock comments.
236 cvBindsAndSigs fb = go (fromOL fb)
238 go [] = (emptyBag, [], [], [])
239 go (L l (SigD s) : ds) = (bs, L l s : ss, ts, docs)
240 where (bs, ss, ts, docs) = go ds
241 go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, docs)
242 where (b', ds') = getMonoBind (L l b) ds
243 (bs, ss, ts, docs) = go ds'
244 go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs)
245 where (bs, ss, ts, docs) = go ds
246 go (L l (DocD d) : ds) = (bs, ss, ts, (L l d) : docs)
247 where (bs, ss, ts, docs) = go ds
249 -----------------------------------------------------------------------------
250 -- Group function bindings into equation groups
252 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
253 -> (LHsBind RdrName, [LHsDecl RdrName])
254 -- Suppose (b',ds') = getMonoBind b ds
255 -- ds is a list of parsed bindings
256 -- b is a MonoBinds that has just been read off the front
258 -- Then b' is the result of grouping more equations from ds that
259 -- belong with b into a single MonoBinds, and ds' is the depleted
260 -- list of parsed bindings.
262 -- All Haddock comments between equations inside the group are
265 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
267 getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1,
268 fun_matches = MatchGroup mtchs1 _ })) binds
270 = go is_infix1 mtchs1 loc1 binds []
272 go is_infix mtchs loc
273 (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
274 fun_matches = MatchGroup mtchs2 _ })) : binds) _
275 | f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs)
276 (combineSrcSpans loc loc2) binds []
277 go is_infix mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls
278 = let doc_decls' = doc_decl : doc_decls
279 in go is_infix mtchs (combineSrcSpans loc loc2) binds doc_decls'
280 go is_infix mtchs loc binds doc_decls
281 = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), (reverse doc_decls) ++ binds)
282 -- Reverse the final matches, to get it back in the right order
283 -- Do the same thing with the trailing doc comments
285 getMonoBind bind binds = (bind, binds)
287 has_args :: [LMatch RdrName] -> Bool
288 has_args ((L _ (Match args _ _)) : _) = not (null args)
289 -- Don't group together FunBinds if they have
290 -- no arguments. This is necessary now that variable bindings
291 -- with no arguments are now treated as FunBinds rather
292 -- than pattern bindings (tests/rename/should_fail/rnfail002).
296 findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
297 findSplice ds = addl emptyRdrGroup ds
299 checkDecBrGroup :: [LHsDecl a] -> P (HsGroup a)
300 -- Turn the body of a [d| ... |] into a HsGroup
301 -- There should be no splices in the "..."
302 checkDecBrGroup decls
303 = case addl emptyRdrGroup decls of
304 (group, Nothing) -> return group
305 (_, Just (SpliceDecl (L loc _), _)) ->
306 parseError loc "Declaration splices are not permitted inside declaration brackets"
307 -- Why not? See Section 7.3 of the TH paper.
309 addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
310 -- This stuff reverses the declarations (again) but it doesn't matter
313 addl gp [] = (gp, Nothing)
314 addl gp (L l d : ds) = add gp l d ds
317 add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a]
318 -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
320 add gp _ (SpliceD e) ds = (gp, Just (e, ds))
322 -- Class declarations: pull out the fixity signatures to the top
323 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs})
326 let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
327 addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs}) ds
329 addl (gp { hs_tyclds = L l d : ts }) ds
331 -- Signatures: fixity sigs go a different place than all others
332 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
333 = addl (gp {hs_fixds = L l f : ts}) ds
334 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
335 = addl (gp {hs_valds = add_sig (L l d) ts}) ds
337 -- Value declarations: use add_bind
338 add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds
339 = addl (gp { hs_valds = add_bind (L l d) ts }) ds
341 -- The rest are routine
342 add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds
343 = addl (gp { hs_instds = L l d : ts }) ds
344 add gp@(HsGroup {hs_derivds = ts}) l (DerivD d) ds
345 = addl (gp { hs_derivds = L l d : ts }) ds
346 add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
347 = addl (gp { hs_defds = L l d : ts }) ds
348 add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
349 = addl (gp { hs_fords = L l d : ts }) ds
350 add gp@(HsGroup {hs_warnds = ts}) l (WarningD d) ds
351 = addl (gp { hs_warnds = L l d : ts }) ds
352 add gp@(HsGroup {hs_annds = ts}) l (AnnD d) ds
353 = addl (gp { hs_annds = L l d : ts }) ds
354 add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
355 = addl (gp { hs_ruleds = L l d : ts }) ds
358 = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds
360 add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
361 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
363 add_sig :: LSig a -> HsValBinds a -> HsValBinds a
364 add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
367 %************************************************************************
369 \subsection[PrefixToHS-utils]{Utilities for conversion}
371 %************************************************************************
375 -----------------------------------------------------------------------------
378 -- When parsing data declarations, we sometimes inadvertently parse
379 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
380 -- This function splits up the type application, adds any pending
381 -- arguments, and converts the type constructor back into a data constructor.
383 mkPrefixCon :: LHsType RdrName -> [LBangType RdrName]
384 -> P (Located RdrName, HsConDeclDetails RdrName)
388 split (L _ (HsAppTy t u)) ts = split t (u : ts)
389 split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc
390 return (data_con, PrefixCon ts)
391 split (L l _) _ = parseError l "parse error in data/newtype declaration"
393 mkRecCon :: Located RdrName ->
394 [([Located RdrName], LBangType RdrName, Maybe (LHsDoc RdrName))] ->
395 P (Located RdrName, HsConDeclDetails RdrName)
396 mkRecCon (L loc con) fields
397 = do data_con <- tyConToDataCon loc con
398 return (data_con, RecCon [ ConDeclField l t d | (ls, t, d) <- fields, l <- ls ])
400 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
401 tyConToDataCon loc tc
402 | isTcOcc (rdrNameOcc tc)
403 = return (L loc (setRdrNameSpace tc srcDataName))
405 = parseErrorSDoc loc (msg $$ extra)
407 msg = text "Not a data constructor:" <+> quotes (ppr tc)
408 extra | tc == forall_tv_RDR
409 = text "Perhaps you intended to use -XExistentialQuantification"
412 ----------------------------------------------------------------------------
413 -- Various Syntactic Checks
415 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
416 checkInstType (L l t)
418 HsForAllTy exp tvs ctxt ty -> do
419 dict_ty <- checkDictTy ty
420 return (L l (HsForAllTy exp tvs ctxt dict_ty))
422 HsParTy ty -> checkInstType ty
424 ty -> do dict_ty <- checkDictTy (L l ty)
425 return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
427 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
428 checkDictTy (L spn ty) = check ty []
430 check (HsTyVar t) args | not (isRdrTyVar t)
431 = return (L spn (HsPredTy (HsClassP t args)))
432 check (HsAppTy l r) args = check (unLoc l) (r:args)
433 check (HsParTy t) args = check (unLoc t) args
434 check _ _ = parseError spn "Malformed instance header"
436 -- Check whether the given list of type parameters are all type variables
437 -- (possibly with a kind signature). If the second argument is `False',
438 -- only type variables are allowed and we raise an error on encountering a
439 -- non-variable; otherwise, we allow non-variable arguments and return the
440 -- entire list of parameters.
442 checkTyVars :: [LHsType RdrName] -> P ()
443 checkTyVars tparms = mapM_ chk tparms
445 -- Check that the name space is correct!
446 chk (L _ (HsKindSig (L _ (HsTyVar tv)) _))
447 | isRdrTyVar tv = return ()
448 chk (L _ (HsTyVar tv))
449 | isRdrTyVar tv = return ()
451 parseError l "Type found where type variable expected"
453 -- Check whether the type arguments in a type synonym head are simply
454 -- variables. If not, we have a type family instance and return all patterns.
455 -- If yes, we return 'Nothing' as the third component to indicate a vanilla
458 checkSynHdr :: LHsType RdrName
459 -> Bool -- is type instance?
460 -> P (Located RdrName, -- head symbol
461 [LHsTyVarBndr RdrName], -- parameters
462 [LHsType RdrName]) -- type patterns
463 checkSynHdr ty isTyInst =
464 do { (_, tc, tvs, tparms) <- checkTyClHdr (noLoc []) ty
465 ; unless isTyInst $ checkTyVars tparms
466 ; return (tc, tvs, tparms) }
469 -- Well-formedness check and decomposition of type and class heads.
471 checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
472 -> P (LHsContext RdrName, -- the type context
473 Located RdrName, -- the head symbol (type or class name)
474 [LHsTyVarBndr RdrName], -- free variables of the non-context part
475 [LHsType RdrName]) -- parameters of head symbol
476 -- The header of a type or class decl should look like
477 -- (C a, D b) => T a b
481 -- With associated types, we can also have non-variable parameters; ie,
484 -- The unaltered parameter list is returned in the fourth component of the
488 -- ('()', 'T', ['a'], ['Int', '[a]'])
489 checkTyClHdr (L l cxt) ty
490 = do (tc, tvs, parms) <- gol ty []
492 return (L l cxt, tc, tvs, parms)
494 gol (L l ty) acc = go l ty acc
496 go l (HsTyVar tc) acc
497 | isRdrTc tc = do tvs <- extractTyVars acc
498 return (L l tc, tvs, acc)
499 go _ (HsOpTy t1 ltc@(L _ tc) t2) acc
500 | isRdrTc tc = do tvs <- extractTyVars (t1:t2:acc)
501 return (ltc, tvs, t1:t2:acc)
502 go _ (HsParTy ty) acc = gol ty acc
503 go _ (HsAppTy t1 t2) acc = gol t1 (t2:acc)
505 parseError l "Malformed head of type or class declaration"
507 -- The predicates in a type or class decl must be class predicates or
508 -- equational constraints. They need not all have variable-only
509 -- arguments, even in Haskell 98.
510 -- E.g. class (Monad m, Monad (t m)) => MonadT t m
511 chk_pred (L _ (HsClassP _ _)) = return ()
512 chk_pred (L _ (HsEqualP _ _)) = return ()
514 = parseError l "Malformed context in type or class declaration"
516 -- Extract the type variables of a list of type parameters.
518 -- * Type arguments can be complex type terms (needed for associated type
521 extractTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
522 extractTyVars tvs = collects tvs []
524 -- Collect all variables (2nd arg serves as an accumulator)
525 collect :: LHsType RdrName -> [LHsTyVarBndr RdrName]
526 -> P [LHsTyVarBndr RdrName]
527 collect (L l (HsForAllTy _ _ _ _)) =
528 const $ parseError l "Forall type not allowed as type parameter"
529 collect (L l (HsTyVar tv))
530 | isRdrTyVar tv = return . (L l (UserTyVar tv) :)
532 collect (L l (HsBangTy _ _ )) =
533 const $ parseError l "Bang-style type annotations not allowed as type parameter"
534 collect (L _ (HsAppTy t1 t2 )) = collect t2 >=> collect t1
535 collect (L _ (HsFunTy t1 t2 )) = collect t2 >=> collect t1
536 collect (L _ (HsListTy t )) = collect t
537 collect (L _ (HsPArrTy t )) = collect t
538 collect (L _ (HsTupleTy _ ts )) = collects ts
539 collect (L _ (HsOpTy t1 _ t2 )) = collect t2 >=> collect t1
540 collect (L _ (HsParTy t )) = collect t
541 collect (L _ (HsNumTy _ )) = return
542 collect (L l (HsPredTy _ )) =
543 const $ parseError l "Predicate not allowed as type parameter"
544 collect (L l (HsKindSig (L _ (HsTyVar tv)) k))
546 return . (L l (KindedTyVar tv k) :)
548 const $ parseError l "Kind signature only allowed for type variables"
549 collect (L l (HsSpliceTy _ )) =
550 const $ parseError l "Splice not allowed as type parameter"
552 -- Collect all variables of a list of types
554 collects (t:ts) = collects ts >=> collect t
556 (f >=> g) x = f x >>= g
558 -- Check that associated type declarations of a class are all kind signatures.
560 checkKindSigs :: [LTyClDecl RdrName] -> P ()
561 checkKindSigs = mapM_ check
564 | isFamilyDecl tydecl
565 || isSynDecl tydecl = return ()
567 parseError l "Type declaration in a class must be a kind signature or synonym default"
569 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
573 check (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
574 = do ctx <- mapM checkPred ts
577 check (HsParTy ty) -- to be sure HsParTy doesn't get into the way
580 check (HsTyVar t) -- Empty context shows up as a unit type ()
581 | t == getRdrName unitTyCon = return (L l [])
584 = do p <- checkPred (L l t)
588 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
589 -- Watch out.. in ...deriving( Show )... we use checkPred on
590 -- the list of partially applied predicates in the deriving,
591 -- so there can be zero args.
592 checkPred (L spn (HsPredTy (HsIParam n ty)))
593 = return (L spn (HsIParam n ty))
597 checkl (L l ty) args = check l ty args
599 check _loc (HsPredTy pred@(HsEqualP _ _))
601 = return $ L spn pred
602 check _loc (HsTyVar t) args | not (isRdrTyVar t)
603 = return (L spn (HsClassP t args))
604 check _loc (HsAppTy l r) args = checkl l (r:args)
605 check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
606 check _loc (HsParTy t) args = checkl t args
607 check loc _ _ = parseError loc
608 "malformed class assertion"
610 ---------------------------------------------------------------------------
611 -- Checking stand-alone deriving declarations
613 checkDerivDecl :: LDerivDecl RdrName -> P (LDerivDecl RdrName)
614 checkDerivDecl d@(L loc _) =
615 do stDerivOn <- extension standaloneDerivingEnabled
616 if stDerivOn then return d
617 else parseError loc "Illegal stand-alone deriving declaration (use -XStandaloneDeriving)"
619 ---------------------------------------------------------------------------
620 -- Checking statements in a do-expression
621 -- We parse do { e1 ; e2 ; }
622 -- as [ExprStmt e1, ExprStmt e2]
623 -- checkDo (a) checks that the last thing is an ExprStmt
624 -- (b) returns it separately
625 -- same comments apply for mdo as well
627 checkDo, checkMDo :: SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
629 checkDo = checkDoMDo "a " "'do'"
630 checkMDo = checkDoMDo "an " "'mdo'"
632 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
633 checkDoMDo _ nm loc [] = parseError loc ("Empty " ++ nm ++ " construct")
634 checkDoMDo pre nm _ ss = do
637 check [L _ (ExprStmt e _ _)] = return ([], e)
638 check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
639 " construct must be an expression")
644 -- -------------------------------------------------------------------------
645 -- Checking Patterns.
647 -- We parse patterns as expressions and check for valid patterns below,
648 -- converting the expression into a pattern at the same time.
650 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
651 checkPattern e = checkLPat e
653 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
654 checkPatterns es = mapM checkPattern es
656 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
657 checkLPat e@(L l _) = checkPat l e []
659 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
660 checkPat loc (L l (HsVar c)) args
661 | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
662 checkPat loc e args -- OK to let this happen even if bang-patterns
663 -- are not enabled, because there is no valid
664 -- non-bang-pattern parse of (C ! e)
665 | Just (e', args') <- splitBang e
666 = do { args'' <- checkPatterns args'
667 ; checkPat loc e' (args'' ++ args) }
668 checkPat loc (L _ (HsApp f x)) args
669 = do { x <- checkLPat x; checkPat loc f (x:args) }
670 checkPat loc (L _ e) []
671 = do { p <- checkAPat loc e; return (L loc p) }
675 checkAPat :: SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
676 checkAPat loc e = case e of
677 EWildPat -> return (WildPat placeHolderType)
678 HsVar x | isQual x -> parseError loc ("Qualified variable in pattern: "
680 | otherwise -> return (VarPat x)
681 HsLit l -> return (LitPat l)
683 -- Overloaded numeric patterns (e.g. f 0 x = x)
684 -- Negation is recorded separately, so that the literal is zero or +ve
685 -- NB. Negative *primitive* literals are already handled by the lexer
686 HsOverLit pos_lit -> return (mkNPat pos_lit Nothing)
687 NegApp (L _ (HsOverLit pos_lit)) _
688 -> return (mkNPat pos_lit (Just noSyntaxExpr))
690 SectionR (L _ (HsVar bang)) e -- (! x)
692 -> do { bang_on <- extension bangPatEnabled
693 ; if bang_on then checkLPat e >>= (return . BangPat)
694 else parseError loc "Illegal bang-pattern (use -XBangPatterns)" }
696 ELazyPat e -> checkLPat e >>= (return . LazyPat)
697 EAsPat n e -> checkLPat e >>= (return . AsPat n)
698 -- view pattern is well-formed if the pattern is
699 EViewPat expr patE -> checkLPat patE >>= (return . (\p -> ViewPat expr p placeHolderType))
700 ExprWithTySig e t -> do e <- checkLPat e
701 -- Pattern signatures are parsed as sigtypes,
702 -- but they aren't explicit forall points. Hence
703 -- we have to remove the implicit forall here.
705 L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
707 return (SigPatIn e t')
710 OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
711 (L _ (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
713 -> return (mkNPlusKPat (L nloc n) lit)
715 OpApp l op _fix r -> do l <- checkLPat l
718 L cl (HsVar c) | isDataOcc (rdrNameOcc c)
719 -> return (ConPatIn (L cl c) (InfixCon l r))
722 HsPar e -> checkLPat e >>= (return . ParPat)
723 ExplicitList _ es -> do ps <- mapM checkLPat es
724 return (ListPat ps placeHolderType)
725 ExplicitPArr _ es -> do ps <- mapM checkLPat es
726 return (PArrPat ps placeHolderType)
728 ExplicitTuple es b -> do ps <- mapM checkLPat es
729 return (TuplePat ps b placeHolderType)
731 RecordCon c _ (HsRecFields fs dd)
732 -> do fs <- mapM checkPatField fs
733 return (ConPatIn c (RecCon (HsRecFields fs dd)))
734 HsQuasiQuoteE q -> return (QuasiQuotePat q)
736 HsType ty -> return (TypePat ty)
739 plus_RDR, bang_RDR :: RdrName
740 plus_RDR = mkUnqual varName (fsLit "+") -- Hack
741 bang_RDR = mkUnqual varName (fsLit "!") -- Hack
743 checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
744 checkPatField fld = do { p <- checkLPat (hsRecFieldArg fld)
745 ; return (fld { hsRecFieldArg = p }) }
747 patFail :: SrcSpan -> P a
748 patFail loc = parseError loc "Parse error in pattern"
751 ---------------------------------------------------------------------------
752 -- Check Equation Syntax
754 checkValDef :: LHsExpr RdrName
755 -> Maybe (LHsType RdrName)
756 -> Located (GRHSs RdrName)
757 -> P (HsBind RdrName)
759 checkValDef lhs (Just sig) grhss
760 -- x :: ty = rhs parses as a *pattern* binding
761 = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
763 checkValDef lhs opt_sig grhss
764 = do { mb_fun <- isFunLhs lhs
766 Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
767 fun is_infix pats opt_sig grhss
768 Nothing -> checkPatBind lhs grhss }
770 checkFunBind :: SrcSpan
774 -> Maybe (LHsType RdrName)
775 -> Located (GRHSs RdrName)
776 -> P (HsBind RdrName)
777 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
779 = parseErrorSDoc (getLoc fun)
780 (ptext (sLit "Qualified name in function definition:") <+> ppr (unLoc fun))
782 = do ps <- checkPatterns pats
783 let match_span = combineSrcSpans lhs_loc rhs_span
784 return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
785 -- The span of the match covers the entire equation.
786 -- That isn't quite right, but it'll do for now.
788 makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
789 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
790 makeFunBind fn is_infix ms
791 = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
792 fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
794 checkPatBind :: LHsExpr RdrName
795 -> Located (GRHSs RdrName)
796 -> P (HsBind RdrName)
797 checkPatBind lhs (L _ grhss)
798 = do { lhs <- checkPattern lhs
799 ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
805 checkValSig (L l (HsVar v)) ty
806 | isUnqual v && not (isDataOcc (rdrNameOcc v))
807 = return (TypeSig (L l v) ty)
808 checkValSig (L l _) _
809 = parseError l "Invalid type signature"
811 mkGadtDecl :: Located RdrName
812 -> LHsType RdrName -- assuming HsType
814 mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = mk_gadt_con name qvars cxt ty
815 mkGadtDecl name ty = mk_gadt_con name [] (noLoc []) ty
817 mk_gadt_con :: Located RdrName
818 -> [LHsTyVarBndr RdrName]
819 -> LHsContext RdrName
822 mk_gadt_con name qvars cxt ty
823 = ConDecl { con_name = name
824 , con_explicit = Implicit
827 , con_details = PrefixCon []
828 , con_res = ResTyGADT ty
829 , con_doc = Nothing }
830 -- NB: we put the whole constr type into the ResTyGADT for now;
831 -- the renamer will unravel it once it has sorted out
834 -- A variable binding is parsed as a FunBind.
837 -- The parser left-associates, so there should
838 -- not be any OpApps inside the e's
839 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
840 -- Splits (f ! g a b) into (f, [(! g), a, b])
841 splitBang (L loc (OpApp l_arg bang@(L _ (HsVar op)) _ r_arg))
842 | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
844 (arg1,argns) = split_bang r_arg []
845 split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
846 split_bang e es = (e,es)
847 splitBang _ = Nothing
849 isFunLhs :: LHsExpr RdrName
850 -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
851 -- Just (fun, is_infix, arg_pats) if e is a function LHS
853 -- The whole LHS is parsed as a single expression.
854 -- Any infix operators on the LHS will parse left-associatively
856 -- will parse (rather strangely) as
858 -- It's up to isFunLhs to sort out the mess
864 go (L loc (HsVar f)) es
865 | not (isRdrDataCon f) = return (Just (L loc f, False, es))
866 go (L _ (HsApp f e)) es = go f (e:es)
867 go (L _ (HsPar e)) es@(_:_) = go e es
869 -- For infix function defns, there should be only one infix *function*
870 -- (though there may be infix *datacons* involved too). So we don't
871 -- need fixity info to figure out which function is being defined.
872 -- a `K1` b `op` c `K2` d
874 -- (a `K1` b) `op` (c `K2` d)
875 -- The renamer checks later that the precedences would yield such a parse.
877 -- There is a complication to deal with bang patterns.
879 -- ToDo: what about this?
880 -- x + 1 `op` y = ...
882 go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
883 | Just (e',es') <- splitBang e
884 = do { bang_on <- extension bangPatEnabled
885 ; if bang_on then go e' (es' ++ es)
886 else return (Just (L loc' op, True, (l:r:es))) }
887 -- No bangs; behave just like the next case
888 | not (isRdrDataCon op) -- We have found the function!
889 = return (Just (L loc' op, True, (l:r:es)))
890 | otherwise -- Infix data con; keep going
891 = do { mb_l <- go l es
893 Just (op', True, j : k : es')
894 -> return (Just (op', True, j : op_app : es'))
896 op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
897 _ -> return Nothing }
898 go _ _ = return Nothing
900 ---------------------------------------------------------------------------
901 -- Miscellaneous utilities
903 checkPrecP :: Located Int -> P Int
905 | 0 <= i && i <= maxPrecedence = return i
906 | otherwise = parseError l "Precedence out of range"
911 -> ([HsRecField RdrName (LHsExpr RdrName)], Bool)
912 -> P (HsExpr RdrName)
914 mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) | isRdrDataCon c
915 = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd))
916 mkRecConstrOrUpdate exp loc (fs,dd)
917 | null fs = parseError loc "Empty record update"
918 | otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] [])
920 mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg
921 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
922 mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
924 mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec
925 -- The Maybe is becuase the user can omit the activation spec (and usually does)
926 mkInlineSpec Nothing True = alwaysInlineSpec -- INLINE
927 mkInlineSpec Nothing False = neverInlineSpec -- NOINLINE
928 mkInlineSpec (Just act) inl = Inline act inl
931 -----------------------------------------------------------------------------
932 -- utilities for foreign declarations
934 -- supported calling conventions
936 data CallConv = CCall CCallConv -- ccall or stdcall
939 -- construct a foreign import declaration
943 -> (Located FastString, Located RdrName, LHsType RdrName)
944 -> P (HsDecl RdrName)
945 mkImport (CCall cconv) safety (entity, v, ty) = do
946 importSpec <- parseCImport entity cconv safety v
947 return (ForD (ForeignImport v ty importSpec))
948 mkImport (DNCall ) _ (entity, v, ty) = do
949 spec <- parseDImport entity
950 return $ ForD (ForeignImport v ty (DNImport spec))
952 -- parse the entity string of a foreign import declaration for the `ccall' or
953 -- `stdcall' calling convention'
955 parseCImport :: Located FastString
960 parseCImport (L loc entity) cconv safety v
961 -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
962 | entity == fsLit "dynamic" =
963 return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
964 | entity == fsLit "wrapper" =
965 return $ CImport cconv safety nilFS nilFS CWrapper
966 | otherwise = parse0 (unpackFS entity)
968 -- using the static keyword?
969 parse0 (' ': rest) = parse0 rest
970 parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
971 parse0 rest = parse1 rest
972 -- check for header file name
973 parse1 "" = parse4 "" nilFS False nilFS
974 parse1 (' ':rest) = parse1 rest
975 parse1 str@('&':_ ) = parse2 str nilFS
976 parse1 str@('[':_ ) = parse3 str nilFS False
978 | ".h" `isSuffixOf` first = parse2 rest (mkFastString first)
979 | otherwise = parse4 str nilFS False nilFS
981 (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
982 -- check for address operator (indicating a label import)
983 parse2 "" header = parse4 "" header False nilFS
984 parse2 (' ':rest) header = parse2 rest header
985 parse2 ('&':rest) header = parse3 rest header True
986 parse2 str@('[':_ ) header = parse3 str header False
987 parse2 str header = parse4 str header False nilFS
988 -- check for library object name
989 parse3 (' ':rest) header isLbl = parse3 rest header isLbl
990 parse3 ('[':rest) header isLbl =
991 case break (== ']') rest of
992 (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib)
993 _ -> parseError loc "Missing ']' in entity"
994 parse3 str header isLbl = parse4 str header isLbl nilFS
995 -- check for name of C function
996 parse4 "" header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
997 parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib
998 parse4 str header isLbl lib
999 | all (== ' ') rest = build (mkFastString first) header isLbl lib
1000 | otherwise = parseError loc "Malformed entity string"
1002 (first, rest) = break (== ' ') str
1004 build cid header False lib = return $
1005 CImport cconv safety header lib (CFunction (StaticTarget cid))
1006 build cid header True lib = return $
1007 CImport cconv safety header lib (CLabel cid )
1010 -- Unravel a dotnet spec string.
1012 parseDImport :: Located FastString -> P DNCallSpec
1013 parseDImport (L loc entity) = parse0 comps
1015 comps = words (unpackFS entity)
1019 | x == "static" = parse1 True xs
1020 | otherwise = parse1 False (x:xs)
1023 parse1 isStatic (x:xs)
1024 | x == "method" = parse2 isStatic DNMethod xs
1025 | x == "field" = parse2 isStatic DNField xs
1026 | x == "ctor" = parse2 isStatic DNConstructor xs
1027 parse1 isStatic xs = parse2 isStatic DNMethod xs
1029 parse2 _ _ [] = d'oh
1030 parse2 isStatic kind (('[':x):xs) =
1033 vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
1035 parse2 isStatic kind xs = parse3 isStatic kind "" xs
1037 parse3 isStatic kind assem [x] =
1038 return (DNCallSpec isStatic kind assem x
1039 -- these will be filled in once known.
1040 (error "FFI-dotnet-args")
1041 (error "FFI-dotnet-result"))
1042 parse3 _ _ _ _ = d'oh
1044 d'oh = parseError loc "Malformed entity string"
1046 -- construct a foreign export declaration
1048 mkExport :: CallConv
1049 -> (Located FastString, Located RdrName, LHsType RdrName)
1050 -> P (HsDecl RdrName)
1051 mkExport (CCall cconv) (L _ entity, v, ty) = return $
1052 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
1054 entity' | nullFS entity = mkExtName (unLoc v)
1055 | otherwise = entity
1056 mkExport DNCall (L _ _, v, _) =
1057 parseError (getLoc v){-TODO: not quite right-}
1058 "Foreign export is not yet supported for .NET"
1060 -- Supplying the ext_name in a foreign decl is optional; if it
1061 -- isn't there, the Haskell name is assumed. Note that no transformation
1062 -- of the Haskell name is then performed, so if you foreign export (++),
1063 -- it's external name will be "++". Too bad; it's important because we don't
1064 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
1066 mkExtName :: RdrName -> CLabelString
1067 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
1071 -----------------------------------------------------------------------------
1075 parseError :: SrcSpan -> String -> P a
1076 parseError span s = parseErrorSDoc span (text s)
1078 parseErrorSDoc :: SrcSpan -> SDoc -> P a
1079 parseErrorSDoc span s = failSpanMsgP span s