X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fparser%2FRdrHsSyn.lhs;h=7373ec09b5c8deaaf5e8978801d293e7f6b1b3b3;hb=cb8044ebabb64a91d9bd7c857f0c60d8b034086d;hp=59651a46d8c20a9d39ccb5a5f7bb49bdafee1d8d;hpb=658372b8c24dee8c37a729c9a1500a3e3b9735d9;p=ghc-hetmet.git diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 59651a4..7373ec0 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -35,11 +35,12 @@ 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]) + 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]) - checkTopTyClD, -- LTyClDecl RdrName -> P (HsDecl RdrName) + 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 checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat] checkDo, -- [Stmt] -> P [Stmt] @@ -56,7 +57,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 ) @@ -70,6 +71,7 @@ import FastString import Panic import List ( isSuffixOf, nubBy ) +import Monad ( unless ) \end{code} @@ -213,7 +215,7 @@ cvBindsAndSigs :: OrdList (LHsDecl RdrName) -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl 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 cvBindsAndSigs fb = go (fromOL fb) where go [] = (emptyBag, [], []) @@ -377,31 +379,46 @@ checkInstType (L l t) ty -> do dict_ty <- checkDictTy (L l ty) return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty)) --- Check that the given list of type parameters are all type variables --- (possibly with a kind signature). +-- 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 tvs = mapM_ chk tvs +checkTyVars tparms = mapM_ chk tparms where -- Check that the name space is correct! chk (L l (HsKindSig (L _ (HsTyVar tv)) k)) - | isRdrTyVar tv = return () + | isRdrTyVar tv = return () chk (L l (HsTyVar tv)) - | isRdrTyVar tv = return () - 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, Just tparms) <- checkTyClHdr (noLoc []) ty - ; checkTyVars tparms - ; 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, -- the type context Located RdrName, -- the head symbol (type or class name) [LHsTyVarBndr RdrName], -- free variables of the non-context part - Maybe [LHsType RdrName]) -- parameters of head symbol; wrapped into - -- 'Maybe' for 'mkTyData' + [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 @@ -413,11 +430,11 @@ checkTyClHdr :: LHsContext RdrName -> LHsType RdrName -- 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 - return (L l cxt, tc, tvs, Just parms) + return (L l cxt, tc, tvs, parms) where gol (L l ty) acc = go l ty acc @@ -486,16 +503,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 - return $ TyClD d {tcdTyPats = Nothing} -checkTopTyClD (L _ d) = return $ TyClD d +checkKindSigs :: [LTyClDecl RdrName] -> P () +checkKindSigs = mapM_ check + where + check (L l tydecl) + | isKindSigDecl 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) @@ -543,6 +560,16 @@ checkDictTy (L spn ty) = check ty [] 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 -- We parse do { e1 ; e2 ; } @@ -704,7 +731,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 } checkPatBind lhs (L _ grhss) = do { lhs <- checkPattern lhs