X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FRdrHsSyn.lhs;h=96088f400d0642a6cc9dad8af32af9d512012e9f;hp=03d4c413a149b38b594b961573108a8204b8c2d0;hb=b1ab4b8a607addc4d097588db5761313c996a41f;hpb=e343a6ca48114f26ac8bb90af543c6ec5bd5a2d4 diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 03d4c41..96088f4 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -9,7 +9,7 @@ module RdrHsSyn ( extractHsRhoRdrTyVars, extractGenericPatTyVars, mkHsOpApp, mkClassDecl, - mkHsNegApp, mkHsIntegral, mkHsFractional, + mkHsNegApp, mkHsIntegral, mkHsFractional, mkHsIsString, mkHsDo, mkHsSplice, mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec, mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp @@ -17,7 +17,7 @@ module RdrHsSyn ( cvBindGroup, cvBindsAndSigs, cvTopDecls, - findSplice, mkGroup, + findSplice, checkDecBrGroup, -- Stuff to do with Foreign declarations CallConv(..), @@ -54,7 +54,7 @@ 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 ) @@ -69,7 +69,6 @@ import OrdList ( OrdList, fromOL ) import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag ) import Outputable import FastString -import Panic import List ( isSuffixOf, nubBy ) import Monad ( unless ) @@ -97,8 +96,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 @@ -214,21 +214,21 @@ cvBindGroup binding ValBindsIn mbs sigs cvBindsAndSigs :: OrdList (LHsDecl RdrName) - -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [DocEntity 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 type declarations. They might also contain Haddock comments. cvBindsAndSigs fb = go (fromOL fb) where go [] = (emptyBag, [], [], []) - go (L l x@(SigD s) : ds) = (bs, L l s : ss, ts, add_doc x docs) + 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, add_doc x docs) + go (L l x@(ValD b) : ds) = (b' `consBag` bs, ss, ts, 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) + go (L l (DocD d) : ds) = (bs, ss, ts, (L l d) : docs) where (bs, ss, ts, docs) = go ds ----------------------------------------------------------------------------- @@ -280,14 +280,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 @@ -303,28 +304,23 @@ 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, hs_docs = docs}) - l decl@(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, - hs_docs = add_doc decl docs}) ds - | isIdxTyDecl d = - addl (gp { hs_tyclds = L l d : ts }) ds + addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs}) ds | otherwise = - addl (gp { hs_tyclds = L l d : ts, - hs_docs = add_doc decl docs }) ds + addl (gp { hs_tyclds = L l d : ts }) 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, 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 +add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds + = addl (gp {hs_valds = add_sig (L l d) ts}) ds -- Value declarations: use add_bind -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 +add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds + = addl (gp { hs_valds = add_bind (L l d) ts }) ds -- The rest are routine add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds @@ -333,20 +329,16 @@ 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, 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_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 = DocEntity d : (hs_docs gp) }) ds + = addl (gp { hs_docs = (L l 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} @@ -406,6 +398,15 @@ 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', -- only type variables are allowed and we raise an error on encountering a @@ -465,22 +466,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, 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" @@ -536,7 +538,7 @@ checkKindSigs :: [LTyClDecl RdrName] -> P () checkKindSigs = mapM_ check where check (L l tydecl) - | isKindSigDecl tydecl + | isFamilyDecl tydecl || isSynDecl tydecl = return () | otherwise = parseError l "Type declaration in a class must be a kind signature or synonym default" @@ -571,22 +573,16 @@ 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" - -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" - + check loc _ _ = parseError loc + "malformed class assertion" --------------------------------------------------------------------------- -- Checking stand-alone deriving declarations @@ -706,8 +702,8 @@ 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 (map (uncurry mkRecField) fs))) + RecordCon c _ (HsRecordBinds fs) -> mapM checkPatField fs >>= \fs -> + return (ConPatIn c (RecCon (map (uncurry mkRecField) fs))) -- Generics HsType ty -> return (TypePat ty) _ -> patFail loc @@ -798,7 +794,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 @@ -810,6 +806,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 @@ -864,9 +870,9 @@ mkRecConstrOrUpdate 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 [] +mkRecConstrOrUpdate exp loc fs@(HsRecordBinds (_:_)) + = return (RecordUpd exp fs [] [] []) +mkRecConstrOrUpdate _ loc (HsRecordBinds []) = parseError loc "Empty record update" mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec