X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FRdrHsSyn.lhs;h=f03a50e6c5be714b696ef590ac74829fffb635d7;hp=1867ce6755548cffd5a8674fc63e4415f80b306e;hb=17b297d97d327620ed6bfab942f8992b2446f1bf;hpb=589ba227fff5946de91cf3a9b88c80953d95f9c7 diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 1867ce6..f03a50e 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -4,20 +4,27 @@ Functions over HsSyn specialised to RdrName. \begin{code} +{-# OPTIONS_GHC -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings +-- for details + module RdrHsSyn ( extractHsTyRdrTyVars, extractHsRhoRdrTyVars, extractGenericPatTyVars, mkHsOpApp, mkClassDecl, - mkHsNegApp, mkHsIntegral, mkHsFractional, + mkHsIntegral, mkHsFractional, mkHsIsString, mkHsDo, mkHsSplice, mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec, mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp cvBindGroup, - cvBindsAndSigs, + cvBindsAndSigs, cvTopDecls, - findSplice, mkGroup, + findSplice, checkDecBrGroup, -- Stuff to do with Foreign declarations CallConv(..), @@ -36,11 +43,13 @@ module RdrHsSyn ( checkContext, -- HsType -> P HsContext checkPred, -- HsType -> P HsPred checkTyClHdr, -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName]) - checkTyVars, -- [LHsType RdrName] -> Bool -> P () - checkSynHdr, -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName], Maybe [LHsType RdrName]) - checkTopTyClD, -- LTyClDecl RdrName -> P (HsDecl RdrName) + checkTyVars, -- [LHsType RdrName] -> P () + checkSynHdr, -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName]) + checkKindSigs, -- [LTyClDecl RdrName] -> P () checkInstType, -- HsType -> P HsType + checkDerivDecl, -- LDerivDecl RdrName -> P (LDerivDecl RdrName) checkPattern, -- HsExp -> P HsPat + bang_RDR, checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat] checkDo, -- [Stmt] -> P [Stmt] checkMDo, -- [Stmt] -> P [Stmt] @@ -52,11 +61,11 @@ module RdrHsSyn ( #include "HsVersions.h" import HsSyn -- Lots of it -import RdrName ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc, +import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, isRdrDataCon, isUnqual, getRdrName, isQual, setRdrNameSpace ) import BasicTypes ( maxPrecedence, Activation, InlineSpec(..), alwaysInlineSpec, neverInlineSpec ) -import Lexer ( P, failSpanMsgP, extension, bangPatEnabled ) +import Lexer ( P, failSpanMsgP, extension, standaloneDerivingEnabled, bangPatEnabled ) import TysWiredIn ( unitTyCon ) import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..), DNCallSpec(..), DNKind(..), CLabelString ) @@ -67,9 +76,9 @@ import OrdList ( OrdList, fromOL ) import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag ) import Outputable import FastString -import Panic import List ( isSuffixOf, nubBy ) +import Monad ( unless ) \end{code} @@ -94,8 +103,9 @@ extractHsRhoRdrTyVars ctxt ty extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt) -extract_pred (HsClassP cls tys) acc = foldr extract_lty acc tys -extract_pred (HsIParam n ty) acc = extract_lty ty acc +extract_pred (HsClassP cls tys) acc = foldr extract_lty acc tys +extract_pred (HsEqualP ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc) +extract_pred (HsIParam n ty ) acc = extract_lty ty acc extract_lty (L loc ty) acc = case ty of @@ -117,6 +127,7 @@ extract_lty (L loc ty) acc extract_lctxt cx (extract_lty ty [])) where locals = hsLTyVarNames tvs + HsDocTy ty doc -> extract_lty ty acc extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName] extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc @@ -153,12 +164,13 @@ Similarly for mkConDecl, mkClassOpSig and default-method names. *** See "THE NAMING STORY" in HsDecls **** \begin{code} -mkClassDecl (cxt, cname, tyvars) fds sigs mbinds ats +mkClassDecl (cxt, cname, tyvars) fds sigs mbinds ats docs = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, tcdMeths = mbinds, - tcdATs = ats + tcdATs = ats, + tcdDocs = docs } mkTyData new_or_data (context, tname, tyvars, typats) ksig data_cons maybe_deriv @@ -167,18 +179,6 @@ mkTyData new_or_data (context, tname, tyvars, typats) ksig data_cons maybe_deriv tcdKindSig = ksig, tcdDerivs = maybe_deriv } \end{code} -\begin{code} -mkHsNegApp :: LHsExpr RdrName -> HsExpr RdrName --- RdrName If the type checker sees (negate 3#) it will barf, because negate --- can't take an unboxed arg. But that is exactly what it will see when --- we write "-3#". So we have to do the negation right now! -mkHsNegApp (L loc e) = f e - where f (HsLit (HsIntPrim i)) = HsLit (HsIntPrim (-i)) - f (HsLit (HsFloatPrim i)) = HsLit (HsFloatPrim (-i)) - f (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i)) - f expr = NegApp (L loc e) noSyntaxExpr -\end{code} - %************************************************************************ %* * \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.} @@ -201,29 +201,30 @@ cvTopDecls decls = go (fromOL decls) where (L l' b', ds') = getMonoBind (L l b) ds go (d : ds) = d : go ds --- Declaration list may only contain value bindings and signatures --- +-- Declaration list may only contain value bindings and signatures. cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName cvBindGroup binding = case cvBindsAndSigs binding of - (mbs, sigs, []) -> -- list of type decls *always* empty + (mbs, sigs, [], _) -> -- list of type decls *always* empty ValBindsIn mbs sigs cvBindsAndSigs :: OrdList (LHsDecl RdrName) - -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName]) + -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl RdrName]) -- Input decls contain just value bindings and signatures -- and in case of class or instance declarations also --- associated data or synonym definitions +-- associated type declarations. They might also contain Haddock comments. cvBindsAndSigs fb = go (fromOL fb) where - go [] = (emptyBag, [], []) - go (L l (SigD s) : ds) = (bs, L l s : ss, ts) - where (bs, ss, ts) = go ds - go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts) + go [] = (emptyBag, [], [], []) + go (L l x@(SigD s) : ds) = (bs, L l s : ss, ts, docs) + where (bs, ss, ts, docs) = go ds + go (L l x@(ValD b) : ds) = (b' `consBag` bs, ss, ts, docs) where (b', ds') = getMonoBind (L l b) ds - (bs, ss, ts) = go ds' - go (L l (TyClD t): ds) = (bs, ss, L l t : ts) - where (bs, ss, ts) = go ds + (bs, ss, ts, docs) = go ds' + go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs) + where (bs, ss, ts, docs) = go ds + go (L l (DocD d) : ds) = (bs, ss, ts, (L l d) : docs) + where (bs, ss, ts, docs) = go ds ----------------------------------------------------------------------------- -- Group function bindings into equation groups @@ -238,21 +239,28 @@ getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName] -- belong with b into a single MonoBinds, and ds' is the depleted -- list of parsed bindings. -- +-- All Haddock comments between equations inside the group are +-- discarded. +-- -- No AndMonoBinds or EmptyMonoBinds here; just single equations getMonoBind (L loc1 bind@(FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1, fun_matches = MatchGroup mtchs1 _ })) binds | has_args mtchs1 - = go is_infix1 mtchs1 loc1 binds + = go is_infix1 mtchs1 loc1 binds [] where go is_infix mtchs loc (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2, - fun_matches = MatchGroup mtchs2 _ })) : binds) + fun_matches = MatchGroup mtchs2 _ })) : binds) _ | f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs) - (combineSrcSpans loc loc2) binds - go is_infix mtchs loc binds - = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), binds) + (combineSrcSpans loc loc2) binds [] + go is_infix mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls + = let doc_decls' = doc_decl : doc_decls + in go is_infix mtchs (combineSrcSpans loc loc2) binds doc_decls' + go is_infix mtchs loc binds doc_decls + = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), (reverse doc_decls) ++ binds) -- Reverse the final matches, to get it back in the right order + -- Do the same thing with the trailing doc comments getMonoBind bind binds = (bind, binds) @@ -267,14 +275,15 @@ has_args ((L _ (Match args _ _)) : _) = not (null args) findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a])) findSplice ds = addl emptyRdrGroup ds -mkGroup :: [LHsDecl a] -> HsGroup a -mkGroup ds = addImpDecls emptyRdrGroup ds - -addImpDecls :: HsGroup a -> [LHsDecl a] -> HsGroup a --- The decls are imported, and should not have a splice -addImpDecls group decls = case addl group decls of - (group', Nothing) -> group' - other -> panic "addImpDecls" +checkDecBrGroup :: [LHsDecl a] -> P (HsGroup a) +-- Turn the body of a [d| ... |] into a HsGroup +-- There should be no splices in the "..." +checkDecBrGroup decls + = case addl emptyRdrGroup decls of + (group, Nothing) -> return group + (_, Just (SpliceDecl (L loc _), _)) -> + parseError loc "Declaration splices are not permitted inside declaration brackets" + -- Why not? See Section 7.3 of the TH paper. addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a])) -- This stuff reverses the declarations (again) but it doesn't matter @@ -290,10 +299,11 @@ add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a] add gp l (SpliceD e) ds = (gp, Just (e, ds)) -- Class declarations: pull out the fixity signatures to the top -add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds +add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) + l (TyClD d) ds | isClassDecl d = let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in - addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs }) ds + addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs}) ds | otherwise = addl (gp { hs_tyclds = L l d : ts }) ds @@ -310,15 +320,20 @@ add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds -- The rest are routine add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds = addl (gp { hs_instds = L l d : ts }) ds +add gp@(HsGroup {hs_derivds = ts}) l (DerivD d) ds + = addl (gp { hs_derivds = L l d : ts }) ds add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds = addl (gp { hs_defds = L l d : ts }) ds -add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds +add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds = addl (gp { hs_fords = L l d : ts }) ds add gp@(HsGroup {hs_depds = ts}) l (DeprecD d) ds = addl (gp { hs_depds = L l d : ts }) ds add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds = addl (gp { hs_ruleds = L l d : ts }) ds +add gp l (DocD d) ds + = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds + add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs) \end{code} @@ -340,7 +355,7 @@ add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs) -- arguments, and converts the type constructor back into a data constructor. mkPrefixCon :: LHsType RdrName -> [LBangType RdrName] - -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName)) + -> P (Located RdrName, HsConDeclDetails RdrName) mkPrefixCon ty tys = split ty tys where @@ -349,11 +364,12 @@ mkPrefixCon ty tys return (data_con, PrefixCon ts) split (L l _) _ = parseError l "parse error in data/newtype declaration" -mkRecCon :: Located RdrName -> [([Located RdrName], LBangType RdrName)] - -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName)) +mkRecCon :: Located RdrName -> + [([Located RdrName], LBangType RdrName, Maybe (LHsDoc RdrName))] -> + P (Located RdrName, HsConDeclDetails RdrName) mkRecCon (L loc con) fields = do data_con <- tyConToDataCon loc con - return (data_con, RecCon [ (l,t) | (ls,t) <- fields, l <- ls ]) + return (data_con, RecCon [ ConDeclField l t d | (ls, t, d) <- fields, l <- ls ]) tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName) tyConToDataCon loc tc @@ -377,42 +393,46 @@ checkInstType (L l t) ty -> do dict_ty <- checkDictTy (L l ty) return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty)) +checkDictTy :: LHsType RdrName -> P (LHsType RdrName) +checkDictTy (L spn ty) = check ty [] + where + check (HsTyVar t) args | not (isRdrTyVar t) + = return (L spn (HsPredTy (HsClassP t args))) + check (HsAppTy l r) args = check (unLoc l) (r:args) + check (HsParTy t) args = check (unLoc t) args + check _ _ = parseError spn "Malformed instance header" + -- Check whether the given list of type parameters are all type variables --- (possibly with a kind signature). If the second argument is `False', we +-- (possibly with a kind signature). If the second argument is `False', -- only type variables are allowed and we raise an error on encountering a --- non-variable; otherwise, we return the entire list parameters iff at least --- one is not a variable. +-- non-variable; otherwise, we allow non-variable arguments and return the +-- entire list of parameters. -- -checkTyVars :: [LHsType RdrName] -> Bool -> P (Maybe [LHsType RdrName]) -checkTyVars tparms nonVarsOk = - do - areVars <- mapM chk tparms - return $ if and areVars then Nothing else Just tparms +checkTyVars :: [LHsType RdrName] -> P () +checkTyVars tparms = mapM_ chk tparms where -- Check that the name space is correct! chk (L l (HsKindSig (L _ (HsTyVar tv)) k)) - | isRdrTyVar tv = return True + | isRdrTyVar tv = return () chk (L l (HsTyVar tv)) - | isRdrTyVar tv = return True - chk (L l other) - | nonVarsOk = return False - | otherwise = + | isRdrTyVar tv = return () + chk (L l other) = parseError l "Type found where type variable expected" -- Check whether the type arguments in a type synonym head are simply --- variables. If not, we have a type equation of a type function and return --- all patterns. If yes, we return 'Nothing' as the third component to --- indicate a vanilla type synonym. +-- variables. If not, we have a type family instance and return all patterns. +-- If yes, we return 'Nothing' as the third component to indicate a vanilla +-- type synonym. -- checkSynHdr :: LHsType RdrName - -> Bool -- non-variables admitted? + -> Bool -- is type instance? -> P (Located RdrName, -- head symbol [LHsTyVarBndr RdrName], -- parameters - Maybe [LHsType RdrName]) -- type patterns -checkSynHdr ty nonVarsOk = + [LHsType RdrName]) -- type patterns +checkSynHdr ty isTyInst = do { (_, tc, tvs, tparms) <- checkTyClHdr (noLoc []) ty - ; typats <- checkTyVars tparms nonVarsOk - ; return (tc, tvs, typats) } + ; unless isTyInst $ checkTyVars tparms + ; return (tc, tvs, tparms) } -- Well-formedness check and decomposition of type and class heads. @@ -429,11 +449,12 @@ checkTyClHdr :: LHsContext RdrName -> LHsType RdrName -- etc -- With associated types, we can also have non-variable parameters; ie, -- T Int [a] +-- or Int :++: [a] -- The unaltered parameter list is returned in the fourth component of the -- result. Eg, for -- T Int [a] -- we return --- ('()', 'T', ['a'], Just ['Int', '[a]']) +-- ('()', 'T', ['a'], ['Int', '[a]']) checkTyClHdr (L l cxt) ty = do (tc, tvs, parms) <- gol ty [] mapM_ chk_pred cxt @@ -441,22 +462,23 @@ checkTyClHdr (L l cxt) ty where gol (L l ty) acc = go l ty acc - go l (HsTyVar tc) acc - | not (isRdrTyVar tc) = do - tvs <- extractTyVars acc - return (L l tc, tvs, acc) - go l (HsOpTy t1 tc t2) acc = do - tvs <- extractTyVars (t1:t2:acc) - return (tc, tvs, acc) + go l (HsTyVar tc) acc + | isRdrTc tc = do tvs <- extractTyVars acc + return (L l tc, tvs, acc) + go l (HsOpTy t1 ltc@(L _ tc) t2) acc + | isRdrTc tc = do tvs <- extractTyVars (t1:t2:acc) + return (ltc, tvs, t1:t2:acc) go l (HsParTy ty) acc = gol ty acc go l (HsAppTy t1 t2) acc = gol t1 (t2:acc) go l other acc = parseError l "Malformed head of type or class declaration" - -- The predicates in a type or class decl must all - -- be HsClassPs. They need not all be type variables, - -- even in Haskell 98. E.g. class (Monad m, Monad (t m)) => MonadT t m - chk_pred (L l (HsClassP _ args)) = return () + -- The predicates in a type or class decl must be class predicates or + -- equational constraints. They need not all have variable-only + -- arguments, even in Haskell 98. + -- E.g. class (Monad m, Monad (t m)) => MonadT t m + chk_pred (L l (HsClassP _ _)) = return () + chk_pred (L l (HsEqualP _ _)) = return () chk_pred (L l _) = parseError l "Malformed context in type or class declaration" @@ -506,16 +528,16 @@ extractTyVars tvs = collects [] tvs tvs' <- collects tvs ts collect tvs' t --- Wrap a toplevel type or class declaration into 'TyClDecl' after ensuring --- that all type parameters are variables only (which is in contrast to --- associated type declarations). +-- Check that associated type declarations of a class are all kind signatures. -- -checkTopTyClD :: LTyClDecl RdrName -> P (HsDecl RdrName) -checkTopTyClD (L _ d@TyData {tcdTyPats = Just typats}) = - do - checkTyVars typats False - return $ TyClD d {tcdTyPats = Nothing} -checkTopTyClD (L _ d) = return $ TyClD d +checkKindSigs :: [LTyClDecl RdrName] -> P () +checkKindSigs = mapM_ check + where + check (L l tydecl) + | isFamilyDecl tydecl + || isSynDecl tydecl = return () + | otherwise = + parseError l "Type declaration in a class must be a kind signature or synonym default" checkContext :: LHsType RdrName -> P (LHsContext RdrName) checkContext (L l t) @@ -547,21 +569,25 @@ checkPred (L spn ty) where checkl (L l ty) args = check l ty args + check _loc (HsPredTy pred@(HsEqualP _ _)) + args | null args + = return $ L spn pred check _loc (HsTyVar t) args | not (isRdrTyVar t) = return (L spn (HsClassP t args)) check _loc (HsAppTy l r) args = checkl l (r:args) check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args) check _loc (HsParTy t) args = checkl t args - check loc _ _ = parseError loc "malformed class assertion" + check loc _ _ = parseError loc + "malformed class assertion" -checkDictTy :: LHsType RdrName -> P (LHsType RdrName) -checkDictTy (L spn ty) = check ty [] - where - check (HsTyVar t) args | not (isRdrTyVar t) - = return (L spn (HsPredTy (HsClassP t args))) - check (HsAppTy l r) args = check (unLoc l) (r:args) - check (HsParTy t) args = check (unLoc t) args - check _ _ = parseError spn "Malformed context in instance header" +--------------------------------------------------------------------------- +-- Checking stand-alone deriving declarations + +checkDerivDecl :: LDerivDecl RdrName -> P (LDerivDecl RdrName) +checkDerivDecl d@(L loc _) = + do stDerivOn <- extension standaloneDerivingEnabled + if stDerivOn then return d + else parseError loc "Illegal stand-alone deriving declaration (use -XStandaloneDeriving)" --------------------------------------------------------------------------- -- Checking statements in a do-expression @@ -626,8 +652,7 @@ checkAPat loc e = case e of -- Overloaded numeric patterns (e.g. f 0 x = x) -- Negation is recorded separately, so that the literal is zero or +ve - -- NB. Negative *primitive* literals are already handled by - -- RdrHsSyn.mkHsNegApp + -- NB. Negative *primitive* literals are already handled by the lexer HsOverLit pos_lit -> return (mkNPat pos_lit Nothing) NegApp (L _ (HsOverLit pos_lit)) _ -> return (mkNPat pos_lit (Just noSyntaxExpr)) @@ -672,8 +697,9 @@ checkAPat loc e = case e of ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps -> return (TuplePat ps b placeHolderType) - RecordCon c _ fs -> mapM checkPatField fs >>= \fs -> - return (ConPatIn c (RecCon fs)) + RecordCon c _ (HsRecFields fs dd) + -> mapM checkPatField fs >>= \fs -> + return (ConPatIn c (RecCon (HsRecFields fs dd))) -- Generics HsType ty -> return (TypePat ty) _ -> patFail loc @@ -682,10 +708,9 @@ plus_RDR, bang_RDR :: RdrName plus_RDR = mkUnqual varName FSLIT("+") -- Hack bang_RDR = mkUnqual varName FSLIT("!") -- Hack -checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName) -checkPatField (n,e) = do - p <- checkLPat e - return (n,p) +checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName)) +checkPatField fld = do { p <- checkLPat (hsRecFieldArg fld) + ; return (fld { hsRecFieldArg = p }) } patFail loc = parseError loc "Parse error in pattern" @@ -724,7 +749,7 @@ makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too makeFunBind fn is_infix ms = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms, - fun_co_fn = idCoercion, bind_fvs = placeHolderNames } + fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing } checkPatBind lhs (L _ grhss) = do { lhs <- checkPattern lhs @@ -752,7 +777,8 @@ mk_gadt_con name qvars cxt ty , con_qvars = qvars , con_cxt = cxt , con_details = PrefixCon [] - , con_res = ResTyGADT ty } + , con_res = ResTyGADT ty + , con_doc = Nothing } -- NB: we put the whole constr type into the ResTyGADT for now; -- the renamer will unravel it once it has sorted out -- operator fixities @@ -763,7 +789,7 @@ mk_gadt_con name qvars cxt ty -- The parser left-associates, so there should -- not be any OpApps inside the e's splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName]) --- Splits (f ! g a b) into (f, [(! g), a, g]) +-- Splits (f ! g a b) into (f, [(! g), a, b]) splitBang (L loc (OpApp l_arg bang@(L loc' (HsVar op)) _ r_arg)) | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns) where @@ -775,6 +801,16 @@ splitBang other = Nothing isFunLhs :: LHsExpr RdrName -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName])) -- Just (fun, is_infix, arg_pats) if e is a function LHS +-- +-- The whole LHS is parsed as a single expression. +-- Any infix operators on the LHS will parse left-associatively +-- E.g. f !x y !z +-- will parse (rather strangely) as +-- (f ! x y) ! z +-- It's up to isFunLhs to sort out the mess +-- +-- a .!. !b + isFunLhs e = go e [] where go (L loc (HsVar f)) es @@ -824,15 +860,17 @@ checkPrecP (L l i) mkRecConstrOrUpdate :: LHsExpr RdrName -> SrcSpan - -> HsRecordBinds RdrName + -> ([HsRecField RdrName (LHsExpr RdrName)], Bool) -> P (HsExpr RdrName) -mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c - = return (RecordCon (L l c) noPostTcExpr fs) -mkRecConstrOrUpdate exp loc fs@(_:_) - = return (RecordUpd exp fs placeHolderType placeHolderType) -mkRecConstrOrUpdate _ loc [] - = parseError loc "Empty record update" +mkRecConstrOrUpdate (L l (HsVar c)) loc (fs,dd) | isRdrDataCon c + = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd)) +mkRecConstrOrUpdate exp loc (fs,dd) + | null fs = parseError loc "Empty record update" + | otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] []) + +mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing } +mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) } mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec -- The Maybe is becuase the user can omit the activation spec (and usually does)