X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FRdrHsSyn.lhs;h=382b333e2b75f9cf1e7114f11aa4329ef47c12f8;hp=b4d0e85a84ba493eafb68c5558332ba27e6f682c;hb=4bc25e8c30559b7a6a87b39afcc79340ae778788;hpb=ecdaf6bc29d23bd704df8c65442ee08032a585fc diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index b4d0e85..382b333 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -4,13 +4,6 @@ Functions over HsSyn specialised to RdrName. \begin{code} -{-# OPTIONS -fno-warn-incomplete-patterns #-} --- 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/Commentary/CodingStyle#Warnings --- for details - module RdrHsSyn ( extractHsTyRdrTyVars, extractHsRhoRdrTyVars, extractGenericPatTyVars, @@ -42,7 +35,8 @@ 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], [LHsType 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 () @@ -63,8 +57,10 @@ import Class ( FunDep ) import TypeRep ( Kind ) import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, isRdrDataCon, isUnqual, getRdrName, isQual, - setRdrNameSpace ) -import BasicTypes ( maxPrecedence, Activation, InlineSpec(..), alwaysInlineSpec, neverInlineSpec ) + setRdrNameSpace, showRdrName ) +import BasicTypes ( maxPrecedence, Activation, RuleMatchInfo, + InlinePragma(..), InlineSpec(..), + alwaysInlineSpec, neverInlineSpec ) import Lexer ( P, failSpanMsgP, extension, standaloneDerivingEnabled, bangPatEnabled ) import TysWiredIn ( unitTyCon ) import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..), @@ -80,6 +76,8 @@ import FastString import List ( isSuffixOf, nubBy ) import Monad ( unless ) + +#include "HsVersions.h" \end{code} @@ -225,8 +223,8 @@ cvTopDecls decls = go (fromOL decls) cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName cvBindGroup binding = case cvBindsAndSigs binding of - (mbs, sigs, [], _) -> -- list of type decls *always* empty - ValBindsIn mbs sigs + (mbs, sigs, tydecls, _) -> ASSERT( null tydecls ) + ValBindsIn mbs sigs cvBindsAndSigs :: OrdList (LHsDecl RdrName) -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl RdrName]) @@ -237,14 +235,15 @@ cvBindsAndSigs fb = go (fromOL fb) where go [] = (emptyBag, [], [], []) go (L l (SigD s) : ds) = (bs, L l s : ss, ts, docs) - where (bs, ss, ts, docs) = go ds + where (bs, ss, ts, docs) = go ds go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, docs) - where (b', ds') = getMonoBind (L l b) ds - (bs, ss, ts, docs) = go ds' + 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 l (DocD d) : ds) = (bs, ss, ts, (L l d) : docs) - where (bs, ss, ts, docs) = go ds + 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 + go (L _ d : _) = pprPanic "cvBindsAndSigs" (ppr d) ----------------------------------------------------------------------------- -- Group function bindings into equation groups @@ -285,6 +284,7 @@ getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1, getMonoBind bind binds = (bind, binds) has_args :: [LMatch RdrName] -> Bool +has_args [] = panic "RdrHsSyn:has_args" has_args ((L _ (Match args _ _)) : _) = not (null args) -- Don't group together FunBinds if they have -- no arguments. This is necessary now that variable bindings @@ -347,8 +347,10 @@ 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_depds = ts}) l (DeprecD d) ds - = addl (gp { hs_depds = L l d : ts }) ds +add gp@(HsGroup {hs_warnds = ts}) l (WarningD d) ds + = addl (gp { hs_warnds = L l d : ts }) ds +add gp@(HsGroup {hs_annds = ts}) l (AnnD d) ds + = addl (gp { hs_annds = L l d : ts }) ds add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds = addl (gp { hs_ruleds = L l d : ts }) ds @@ -357,9 +359,11 @@ add gp l (DocD d) ds add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs +add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind" add_sig :: LSig a -> HsValBinds a -> HsValBinds a -add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs) +add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs) +add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig" \end{code} %************************************************************************ @@ -539,13 +543,14 @@ extractTyVars tvs = collects tvs [] collect (L _ (HsNumTy _ )) = return collect (L l (HsPredTy _ )) = const $ parseError l "Predicate not allowed as type parameter" - collect (L l (HsKindSig (L _ (HsTyVar tv)) k)) - | isRdrTyVar tv = - return . (L l (KindedTyVar tv k) :) - | otherwise = - const $ parseError l "Kind signature only allowed for type variables" + collect (L l (HsKindSig (L _ ty) k)) + | HsTyVar tv <- ty, isRdrTyVar tv + = return . (L l (KindedTyVar tv k) :) + | otherwise + = const $ parseError l "Kind signature only allowed for type variables" collect (L l (HsSpliceTy _ )) = const $ parseError l "Splice not allowed as type parameter" + collect (L _ (HsDocTy t _ )) = collect t -- Collect all variables of a list of types collects [] = return @@ -632,6 +637,7 @@ checkDoMDo _ nm loc [] = parseError loc ("Empty " ++ nm ++ " construct") checkDoMDo pre nm _ ss = do check ss where + check [] = panic "RdrHsSyn:checkDoMDo" check [L _ (ExprStmt e _ _)] = return ([], e) check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++ " construct must be an expression") @@ -689,7 +695,7 @@ checkAPat loc e = case e of | 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)" } + else parseError loc "Illegal bang-pattern (use -XBangPatterns)" } ELazyPat e -> checkLPat e >>= (return . LazyPat) EAsPat n e -> checkLPat e >>= (return . AsPat n) @@ -919,11 +925,13 @@ mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg 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 +mkInlineSpec :: Maybe Activation -> RuleMatchInfo -> Bool -> InlineSpec -- The Maybe is becuase the user can omit the activation spec (and usually does) -mkInlineSpec Nothing True = alwaysInlineSpec -- INLINE -mkInlineSpec Nothing False = neverInlineSpec -- NOINLINE -mkInlineSpec (Just act) inl = Inline act inl +mkInlineSpec Nothing match_info True = alwaysInlineSpec match_info + -- INLINE +mkInlineSpec Nothing match_info False = neverInlineSpec match_info + -- NOINLINE +mkInlineSpec (Just act) match_info inl = Inline (InlinePragma act match_info) inl ----------------------------------------------------------------------------- @@ -1070,9 +1078,6 @@ mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm)) -- Misc utils \begin{code} -showRdrName :: RdrName -> String -showRdrName r = showSDoc (ppr r) - parseError :: SrcSpan -> String -> P a parseError span s = parseErrorSDoc span (text s)