Renamer part of stand-alone deriving extension.

[ghc-hetmet.git] / compiler / parser / RdrHsSyn.lhs

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index b66c759..87741b9 100644 (file)
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -36,10 +36,11 @@ module RdrHsSyn (
        checkContext,         -- HsType -> P HsContext
        checkPred,            -- HsType -> P HsPred
        checkTyClHdr,         -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName])
-       checkTyVars,          -- [LHsType RdrName] -> Bool -> P ()
-       checkSynHdr,          -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName], Maybe [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
        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}
 
 
@@ -310,6 +312,8 @@ add gp@(HsGroup {hs_valds  = ts}) l (ValD d) 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
@@ -378,25 +382,20 @@ checkInstType (L l t)
                   return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
 
 -- Check whether the given list of type parameters are all type variables
--- (possibly with a kind signature).  If the second argument is `False', we
+-- (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 return the entire list parameters iff at least
--- one is not a variable.
+-- non-variable; otherwise, we allow non-variable arguments and return the
+-- entire list of parameters.
 --
-checkTyVars :: [LHsType RdrName] -> Bool -> P (Maybe [LHsType RdrName])
-checkTyVars tparms nonVarsOk = 
-  do
-    areVars <- mapM chk tparms
-    return $ if and areVars then Nothing else Just tparms
+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 True
+       | isRdrTyVar tv    = return ()
     chk (L l (HsTyVar tv))
-        | isRdrTyVar tv    = return True
-    chk (L l other)
-        | nonVarsOk        = return False
-        | otherwise        = 
+        | 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
@@ -405,14 +404,14 @@ checkTyVars tparms nonVarsOk =
 -- indicate a vanilla type synonym.
 --
 checkSynHdr :: LHsType RdrName 
-           -> Bool                             -- non-variables admitted?
+           -> Bool                             -- is type instance?
            -> P (Located RdrName,              -- head symbol
                  [LHsTyVarBndr RdrName],       -- parameters
-                 Maybe [LHsType RdrName])      -- type patterns
-checkSynHdr ty nonVarsOk = 
+                 [LHsType RdrName])            -- type patterns
+checkSynHdr ty isTyInst = 
   do { (_, tc, tvs, tparms) <- checkTyClHdr (noLoc []) ty
-     ; typats <- checkTyVars tparms nonVarsOk
-     ; return (tc, tvs, typats) }
+     ; unless isTyInst $ checkTyVars tparms
+     ; return (tc, tvs, tparms) }
 
 
 -- Well-formedness check and decomposition of type and class heads.
@@ -563,6 +562,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 ; }
@@ -724,7 +733,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