X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fparser%2FRdrHsSyn.lhs;h=687ffd2bbcf7d1da95a968210e38f2ac6a338cf3;hb=e3dd39bf230380f02d73efc287226117bb2eb47f;hp=8d59e2b22ce3a40db205647e4329afdec991477f;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 8d59e2b..687ffd2 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -8,14 +8,14 @@ module RdrHsSyn ( extractHsTyRdrTyVars, extractHsRhoRdrTyVars, extractGenericPatTyVars, - mkHsOpApp, mkClassDecl, + mkHsOpApp, mkClassDecl, mkHsNegApp, mkHsIntegral, mkHsFractional, mkHsDo, mkHsSplice, mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec, mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp cvBindGroup, - cvBindsAndSigs, + cvBindsAndSigs, cvTopDecls, findSplice, mkGroup, @@ -35,10 +35,14 @@ module RdrHsSyn ( checkPrecP, -- Int -> P Int checkContext, -- HsType -> P HsContext checkPred, -- HsType -> P HsPred - checkTyClHdr, -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName]) - checkSynHdr, -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName]) + checkTyClHdr, -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName], [LHsType 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] @@ -54,7 +58,7 @@ import RdrName ( RdrName, isRdrTyVar, 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, glaExtsEnabled, bangPatEnabled ) import TysWiredIn ( unitTyCon ) import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..), DNCallSpec(..), DNKind(..), CLabelString ) @@ -68,6 +72,7 @@ import FastString import Panic import List ( isSuffixOf, nubBy ) +import Monad ( unless ) \end{code} @@ -92,8 +97,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 @@ -115,6 +121,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 @@ -151,16 +158,18 @@ Similarly for mkConDecl, mkClassOpSig and default-method names. *** See "THE NAMING STORY" in HsDecls **** \begin{code} -mkClassDecl (cxt, cname, tyvars) fds sigs mbinds +mkClassDecl (cxt, cname, tyvars) fds sigs mbinds ats docs = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, - tcdMeths = mbinds + tcdMeths = mbinds, + tcdATs = ats, + tcdDocs = docs } -mkTyData new_or_data (context, tname, tyvars) ksig data_cons maybe_deriv +mkTyData new_or_data (context, tname, tyvars, typats) ksig data_cons maybe_deriv = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname, - tcdTyVars = tyvars, tcdCons = data_cons, + tcdTyVars = tyvars, tcdTyPats = typats, tcdCons = data_cons, tcdKindSig = ksig, tcdDerivs = maybe_deriv } \end{code} @@ -198,23 +207,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. cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName cvBindGroup binding - = case (cvBindsAndSigs binding) of { (mbs, sigs) -> - ValBindsIn mbs sigs - } + = case cvBindsAndSigs binding of + (mbs, sigs, [], _) -> -- list of type decls *always* empty + ValBindsIn mbs sigs cvBindsAndSigs :: OrdList (LHsDecl RdrName) - -> (Bag (LHsBind RdrName), [LSig RdrName]) + -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [DocEntity RdrName]) -- Input decls contain just value bindings and signatures +-- and in case of class or instance declarations also +-- 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) - where (bs,ss) = go ds - go (L l (ValD b) : ds) = (b' `consBag` bs, ss) - where (b',ds') = getMonoBind (L l b) ds - (bs,ss) = go ds' + go [] = (emptyBag, [], [], []) + go (L l x@(SigD s) : ds) = (bs, L l s : ss, ts, add_doc x docs) + where (bs, ss, ts, docs) = go ds + go (L l x@(ValD b) : ds) = (b' `consBag` bs, ss, ts, add_doc x docs) + where (b', ds') = getMonoBind (L l b) 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 _ (DocD d) : ds) = (bs, ss, ts, DocEntity d : docs) + where (bs, ss, ts, docs) = go ds ----------------------------------------------------------------------------- -- Group function bindings into equation groups @@ -222,25 +238,35 @@ cvBindsAndSigs fb = go (fromOL fb) getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName] -> (LHsBind RdrName, [LHsDecl RdrName]) -- Suppose (b',ds') = getMonoBind b ds --- ds is a *reversed* list of parsed bindings +-- ds is a list of parsed bindings -- b is a MonoBinds that has just been read off the front -- Then b' is the result of grouping more equations from ds that -- 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 loc bind@(FunBind { fun_id = L _ f, fun_matches = MatchGroup mtchs _ })) binds - | has_args mtchs - = go mtchs loc binds +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 [] where - go mtchs1 loc1 (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_matches = MatchGroup mtchs2 _ })) : binds) - | f == f2 = go (mtchs2++mtchs1) loc binds - where loc = combineSrcSpans loc1 loc2 - go mtchs1 loc binds - = (L loc (bind { fun_matches = mkMatchGroup (reverse mtchs1) }), binds) + go is_infix mtchs loc + (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2, + fun_matches = MatchGroup mtchs2 _ })) : binds) _ + | f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs) + (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) @@ -278,35 +304,50 @@ 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, hs_docs = docs}) + l decl@(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, + hs_docs = add_doc decl docs}) ds + | isFamInstDecl d = + addl (gp { hs_tyclds = L l d : ts }) ds | otherwise = - addl (gp { hs_tyclds = L l d : ts }) ds + addl (gp { hs_tyclds = L l d : ts, + hs_docs = add_doc decl docs }) ds -- Signatures: fixity sigs go a different place than all others add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds = addl (gp {hs_fixds = L l f : ts}) ds -add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds - = addl (gp {hs_valds = add_sig (L l d) ts}) ds +add gp@(HsGroup {hs_valds = ts, hs_docs = docs}) l x@(SigD d) ds + = addl (gp {hs_valds = add_sig (L l d) ts, hs_docs = add_doc x docs}) ds -- Value declarations: use add_bind -add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds - = addl (gp { hs_valds = add_bind (L l d) ts }) ds +add gp@(HsGroup {hs_valds = ts, hs_docs = docs}) l x@(ValD d) ds + = addl (gp { hs_valds = add_bind (L l d) ts, hs_docs = add_doc x docs }) 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 - = addl (gp { hs_fords = L l d : ts }) ds +add gp@(HsGroup {hs_fords = ts, hs_docs = docs}) l x@(ForD d) ds + = addl (gp { hs_fords = L l d : ts, hs_docs = add_doc x docs }) 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 = DocEntity d : (hs_docs gp) }) ds + +add_doc decl docs = case getMainDeclBinder decl of + Just name -> DeclEntity name : docs + Nothing -> docs + add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs) \end{code} @@ -337,11 +378,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, HsConDetails RdrName (LBangType 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 [ (HsRecField l t d) | (ls, t, d) <- fields, l <- ls ]) tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName) tyConToDataCon loc tc @@ -365,53 +407,152 @@ checkInstType (L l t) ty -> do dict_ty <- checkDictTy (L l ty) return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty)) -checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName] -checkTyVars tvs - = mapM chk tvs +checkDictTy :: LHsType RdrName -> P (LHsType RdrName) +checkDictTy (L spn ty) = check ty [] where - -- Check that the name space is correct! + 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', +-- only type variables are allowed and we raise an error on encountering a +-- non-variable; otherwise, we allow non-variable arguments and return the +-- entire list of parameters. +-- +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 (L l (KindedTyVar tv k)) + | isRdrTyVar tv = return () chk (L l (HsTyVar tv)) - | isRdrTyVar tv = return (L l (UserTyVar tv)) - chk (L l other) - = parseError l "Type found where type variable expected" - -checkSynHdr :: LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName]) -checkSynHdr ty = do { (_, tc, tvs) <- checkTyClHdr (noLoc []) ty - ; return (tc, tvs) } - + | 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. +-- +checkSynHdr :: LHsType RdrName + -> Bool -- is type instance? + -> P (Located RdrName, -- head symbol + [LHsTyVarBndr RdrName], -- parameters + [LHsType RdrName]) -- type patterns +checkSynHdr ty isTyInst = + do { (_, tc, tvs, tparms) <- checkTyClHdr (noLoc []) ty + ; unless isTyInst $ checkTyVars tparms + ; return (tc, tvs, tparms) } + + +-- Well-formedness check and decomposition of type and class heads. +-- checkTyClHdr :: LHsContext RdrName -> LHsType RdrName - -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName]) + -> P (LHsContext RdrName, -- the type context + Located RdrName, -- the head symbol (type or class name) + [LHsTyVarBndr RdrName], -- free variables of the non-context part + [LHsType RdrName]) -- parameters of head symbol -- The header of a type or class decl should look like -- (C a, D b) => T a b -- or T a b -- or a + b -- etc +-- With associated types, we can also have non-variable parameters; ie, +-- T Int [a] +-- The unaltered parameter list is returned in the fourth component of the +-- result. Eg, for +-- T Int [a] +-- we return +-- ('()', 'T', ['a'], ['Int', '[a]']) checkTyClHdr (L l cxt) ty - = do (tc, tvs) <- gol ty [] + = do (tc, tvs, parms) <- gol ty [] mapM_ chk_pred cxt - return (L l cxt, tc, tvs) + return (L l cxt, tc, tvs, parms) where gol (L l ty) acc = go l ty acc go l (HsTyVar tc) acc - | not (isRdrTyVar tc) = checkTyVars acc >>= \ tvs -> - return (L l tc, tvs) - go l (HsOpTy t1 tc t2) acc = checkTyVars (t1:t2:acc) >>= \ tvs -> - return (tc, tvs) + | 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 (HsParTy ty) acc = gol ty acc go l (HsAppTy t1 t2) acc = gol t1 (t2:acc) - go l other acc = parseError l "Malformed LHS to type of 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 () + go l other acc = + parseError l "Malformed head of type or class declaration" + + -- 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" - +-- Extract the type variables of a list of type parameters. +-- +-- * Type arguments can be complex type terms (needed for associated type +-- declarations). +-- +extractTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName] +extractTyVars tvs = collects [] tvs + where + -- Collect all variables (1st arg serves as an accumulator) + collect tvs (L l (HsForAllTy _ _ _ _)) = + parseError l "Forall type not allowed as type parameter" + collect tvs (L l (HsTyVar tv)) + | isRdrTyVar tv = return $ L l (UserTyVar tv) : tvs + | otherwise = return tvs + collect tvs (L l (HsBangTy _ _ )) = + parseError l "Bang-style type annotations not allowed as type parameter" + collect tvs (L l (HsAppTy t1 t2 )) = do + tvs' <- collect tvs t2 + collect tvs' t1 + collect tvs (L l (HsFunTy t1 t2 )) = do + tvs' <- collect tvs t2 + collect tvs' t1 + collect tvs (L l (HsListTy t )) = collect tvs t + collect tvs (L l (HsPArrTy t )) = collect tvs t + collect tvs (L l (HsTupleTy _ ts )) = collects tvs ts + collect tvs (L l (HsOpTy t1 _ t2 )) = do + tvs' <- collect tvs t2 + collect tvs' t1 + collect tvs (L l (HsParTy t )) = collect tvs t + collect tvs (L l (HsNumTy t )) = return tvs + collect tvs (L l (HsPredTy t )) = + parseError l "Predicate not allowed as type parameter" + collect tvs (L l (HsKindSig (L _ (HsTyVar tv)) k)) + | isRdrTyVar tv = + return $ L l (KindedTyVar tv k) : tvs + | otherwise = + parseError l "Kind signature only allowed for type variables" + collect tvs (L l (HsSpliceTy t )) = + parseError l "Splice not allowed as type parameter" + + -- Collect all variables of a list of types + collects tvs [] = return tvs + collects tvs (t:ts) = do + tvs' <- collects tvs ts + collect tvs' t + +-- Check that associated type declarations of a class are all kind signatures. +-- +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) = check t @@ -442,21 +583,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 glaExtOn <- extension glaExtsEnabled + if glaExtOn then return d + else parseError loc "Illegal stand-alone deriving declaration (use -fglasgow-exts)" --------------------------------------------------------------------------- -- Checking statements in a do-expression @@ -527,8 +672,12 @@ checkAPat loc e = case e of NegApp (L _ (HsOverLit pos_lit)) _ -> return (mkNPat pos_lit (Just noSyntaxExpr)) - SectionR (L _ (HsVar bang)) e - | bang == bang_RDR -> checkLPat e >>= (return . BangPat) + SectionR (L _ (HsVar bang)) e -- (! x) + | bang == bang_RDR + -> do { bang_on <- extension bangPatEnabled + ; if bang_on then checkLPat e >>= (return . BangPat) + else parseError loc "Illegal bang-pattern (use -fbang-patterns)" } + ELazyPat e -> checkLPat e >>= (return . LazyPat) EAsPat n e -> checkLPat e >>= (return . AsPat n) ExprWithTySig e t -> checkLPat e >>= \e -> @@ -564,7 +713,7 @@ checkAPat loc e = case e of return (TuplePat ps b placeHolderType) RecordCon c _ fs -> mapM checkPatField fs >>= \fs -> - return (ConPatIn c (RecCon fs)) + return (ConPatIn c (RecCon (map (uncurry mkRecField) fs))) -- Generics HsType ty -> return (TypePat ty) _ -> patFail loc @@ -589,6 +738,10 @@ checkValDef :: LHsExpr RdrName -> Located (GRHSs RdrName) -> P (HsBind RdrName) +checkValDef lhs (Just sig) grhss + -- x :: ty = rhs parses as a *pattern* binding + = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss + checkValDef lhs opt_sig grhss = do { mb_fun <- isFunLhs lhs ; case mb_fun of @@ -603,12 +756,16 @@ checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss) | otherwise = do ps <- checkPatterns pats let match_span = combineSrcSpans lhs_loc rhs_span - matches = mkMatchGroup [L match_span (Match ps opt_sig grhss)] - return (FunBind { fun_id = fun, fun_infix = is_infix, fun_matches = matches, - fun_co_fn = idCoercion, bind_fvs = placeHolderNames }) + return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)]) -- The span of the match covers the entire equation. -- That isn't quite right, but it'll do for now. +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 = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing } + checkPatBind lhs (L _ grhss) = do { lhs <- checkPattern lhs ; return (PatBind lhs grhss placeHolderType placeHolderNames) } @@ -623,30 +780,23 @@ checkValSig (L l (HsVar v)) ty checkValSig (L l other) ty = parseError l "Invalid type signature" -mkGadtDecl - :: Located RdrName - -> LHsType RdrName -- assuming HsType - -> ConDecl RdrName -mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = ConDecl - { con_name = name - , con_explicit = Implicit - , con_qvars = qvars - , con_cxt = cxt - , con_details = PrefixCon args - , con_res = ResTyGADT res - } - where - (args, res) = splitHsFunType ty -mkGadtDecl name ty = ConDecl - { con_name = name - , con_explicit = Implicit - , con_qvars = [] - , con_cxt = noLoc [] - , con_details = PrefixCon args - , con_res = ResTyGADT res - } - where - (args, res) = splitHsFunType ty +mkGadtDecl :: Located RdrName + -> LHsType RdrName -- assuming HsType + -> ConDecl RdrName +mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = mk_gadt_con name qvars cxt ty +mkGadtDecl name ty = mk_gadt_con name [] (noLoc []) ty + +mk_gadt_con name qvars cxt ty + = ConDecl { con_name = name + , con_explicit = Implicit + , con_qvars = qvars + , con_cxt = cxt + , con_details = PrefixCon [] + , 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 -- A variable binding is parsed as a FunBind. @@ -672,15 +822,29 @@ isFunLhs e = go e [] | not (isRdrDataCon f) = return (Just (L loc f, False, es)) go (L _ (HsApp f e)) es = go f (e:es) go (L _ (HsPar e)) es@(_:_) = go e es + + -- For infix function defns, there should be only one infix *function* + -- (though there may be infix *datacons* involved too). So we don't + -- need fixity info to figure out which function is being defined. + -- a `K1` b `op` c `K2` d + -- must parse as + -- (a `K1` b) `op` (c `K2` d) + -- The renamer checks later that the precedences would yield such a parse. + -- + -- There is a complication to deal with bang patterns. + -- + -- ToDo: what about this? + -- x + 1 `op` y = ... + go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es | Just (e',es') <- splitBang e = do { bang_on <- extension bangPatEnabled ; if bang_on then go e' (es' ++ es) else return (Just (L loc' op, True, (l:r:es))) } -- No bangs; behave just like the next case - | not (isRdrDataCon op) + | not (isRdrDataCon op) -- We have found the function! = return (Just (L loc' op, True, (l:r:es))) - | otherwise + | otherwise -- Infix data con; keep going = do { mb_l <- go l es ; case mb_l of Just (op', True, j : k : es') @@ -734,10 +898,10 @@ mkImport :: CallConv -> P (HsDecl RdrName) mkImport (CCall cconv) safety (entity, v, ty) = do importSpec <- parseCImport entity cconv safety v - return (ForD (ForeignImport v ty importSpec False)) + return (ForD (ForeignImport v ty importSpec)) mkImport (DNCall ) _ (entity, v, ty) = do spec <- parseDImport entity - return $ ForD (ForeignImport v ty (DNImport spec) False) + return $ ForD (ForeignImport v ty (DNImport spec)) -- parse the entity string of a foreign import declaration for the `ccall' or -- `stdcall' calling convention' @@ -838,7 +1002,7 @@ mkExport :: CallConv -> (Located FastString, Located RdrName, LHsType RdrName) -> P (HsDecl RdrName) mkExport (CCall cconv) (L loc entity, v, ty) = return $ - ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False) + ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv))) where entity' | nullFS entity = mkExtName (unLoc v) | otherwise = entity