X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FRdrHsSyn.lhs;h=ac1a02826d6b803b4d5f00592e91f0b8af4d3236;hp=e0e8c3c211e339b8ece7f98f7f31ddf674ea71c0;hb=fd9f6472d9bb9b521533fdb0cd4a4bf0a742b840;hpb=6f8ff0bbad3b9fa389c960ad1b5a267a1ae502f1

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index e0e8c3c..ac1a028 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -70,6 +70,7 @@ import FastString
 import Maybes
 
 import Control.Applicative ((<$>))       
+import Control.Monad
 import Text.ParserCombinators.ReadP as ReadP
 import Data.List        ( nubBy )
 import Data.Char
@@ -128,7 +129,6 @@ extract_lty (L loc ty) acc
       HsNumTy _                 -> acc
       HsQuasiQuoteTy {}	        -> acc  -- Quasi quotes mention no type variables
       HsSpliceTy {}           	-> acc	-- Type splices mention no type variables
-      HsSpliceTyOut {}         	-> acc	-- Type splices mention no type variables
       HsKindSig ty _            -> extract_lty ty acc
       HsForAllTy _ [] cx ty     -> extract_lctxt cx (extract_lty ty acc)
       HsForAllTy _ tvs cx ty    -> acc ++ (filter ((`notElem` locals) . unLoc) $
@@ -173,13 +173,14 @@ Similarly for mkConDecl, mkClassOpSig and default-method names.
   
 \begin{code}
 mkClassDecl :: SrcSpan
-            -> Located (LHsContext RdrName, LHsType RdrName) 
+            -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
             -> Located [Located (FunDep RdrName)]
             -> Located (OrdList (LHsDecl RdrName))
 	    -> P (LTyClDecl RdrName)
 
-mkClassDecl loc (L _ (cxt, tycl_hdr)) fds where_cls
+mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
   = do { let (binds, sigs, ats, docs) = cvBindsAndSigs (unLoc where_cls)
+       ; let cxt = fromMaybe (noLoc []) mcxt
        ; (cls, tparams) <- checkTyClHdr tycl_hdr
        ; tyvars <- checkTyVars tparams      -- Only type vars allowed
        ; checkKindSigs ats
@@ -190,14 +191,16 @@ mkClassDecl loc (L _ (cxt, tycl_hdr)) fds where_cls
 mkTyData :: SrcSpan
          -> NewOrData
 	 -> Bool		-- True <=> data family instance
-         -> Located (LHsContext RdrName, LHsType RdrName)
+         -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
          -> Maybe Kind
          -> [LConDecl RdrName]
          -> Maybe [LHsType RdrName]
          -> P (LTyClDecl RdrName)
-mkTyData loc new_or_data is_family (L _ (cxt, tycl_hdr)) ksig data_cons maybe_deriv
+mkTyData loc new_or_data is_family (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
   = do { (tc, tparams) <- checkTyClHdr tycl_hdr
 
+       ; checkDatatypeContext mcxt
+       ; let cxt = fromMaybe (noLoc []) mcxt
        ; (tyvars, typats) <- checkTParams is_family tparams
        ; return (L loc (TyData { tcdND = new_or_data, tcdCtxt = cxt, tcdLName = tc,
 	                  	 tcdTyVars = tyvars, tcdTyPats = typats, 
@@ -232,8 +235,8 @@ mkTopSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName
 --      f x            then behave as if she'd written $(f x)
 --		       ie a SpliceD
 mkTopSpliceDecl (L _ (HsQuasiQuoteE qq))            = QuasiQuoteD qq
-mkTopSpliceDecl (L _ (HsSpliceE (HsSplice _ expr))) = SpliceD (SpliceDecl expr)
-mkTopSpliceDecl other_expr                          = SpliceD (SpliceDecl other_expr)
+mkTopSpliceDecl (L _ (HsSpliceE (HsSplice _ expr))) = SpliceD (SpliceDecl expr       Explicit)
+mkTopSpliceDecl other_expr                          = SpliceD (SpliceDecl other_expr Implicit)
 \end{code}
 
 %************************************************************************
@@ -503,8 +506,7 @@ checkTParams is_family tparams
   = do { tyvars <- checkTyVars tparams
        ; return (tyvars, Nothing) }
   | otherwise		 -- Family case (b)
-  = do { let tyvars = [L l (UserTyVar tv) 
-                      | L l tv <- extractHsTysRdrTyVars tparams]
+  = do { let tyvars = userHsTyVarBndrs (extractHsTysRdrTyVars tparams)
        ; return (tyvars, Just tparams) }
 
 checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
@@ -519,10 +521,17 @@ checkTyVars tparms = mapM chk tparms
     chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
 	| isRdrTyVar tv    = return (L l (KindedTyVar tv k))
     chk (L l (HsTyVar tv))
-        | isRdrTyVar tv    = return (L l (UserTyVar tv))
+        | isRdrTyVar tv    = return (L l (UserTyVar tv placeHolderKind))
     chk (L l _)            =
 	  parseError l "Type found where type variable expected"
 
+checkDatatypeContext :: Maybe (LHsContext RdrName) -> P ()
+checkDatatypeContext Nothing = return ()
+checkDatatypeContext (Just (L loc _))
+    = do allowed <- extension datatypeContextsEnabled
+         unless allowed $
+             parseError loc "Illegal datatype context (use -XDatatypeContexts)"
+
 checkTyClHdr :: LHsType RdrName
              -> P (Located RdrName,	     -- the head symbol (type or class name)
 	           [LHsType RdrName])        -- parameters of head symbol
@@ -719,10 +728,10 @@ checkAPat dynflags loc e = case e of
    HsType ty          -> return (TypePat ty) 
    _                  -> patFail loc
 
-placeHolderPunRhs :: HsExpr RdrName
+placeHolderPunRhs :: LHsExpr RdrName
 -- The RHS of a punned record field will be filled in by the renamer
 -- It's better not to make it an error, in case we want to print it when debugging
-placeHolderPunRhs = HsVar pun_RDR
+placeHolderPunRhs = noLoc (HsVar pun_RDR)
 
 plus_RDR, bang_RDR, pun_RDR :: RdrName
 plus_RDR = mkUnqual varName (fsLit "+")	-- Hack