From: bjorn@bringert.net <unknown>
Date: Sun, 17 Sep 2006 00:09:56 +0000 (+0000)
Subject: Added parser and abstract syntax support for stand-alone deriving declarations.
X-Git-Tag: 2006-10-05~16
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=cb8044ebabb64a91d9bd7c857f0c60d8b034086d

Added parser and abstract syntax support for stand-alone deriving declarations.
---

diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index 2128ad3..2310551 100644
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -9,7 +9,7 @@ Definitions for: @TyDecl@ and @oCnDecl@, @ClassDecl@,
 \begin{code}
 module HsDecls (
 	HsDecl(..), LHsDecl, TyClDecl(..), LTyClDecl, 
-	InstDecl(..), LInstDecl, NewOrData(..),
+	InstDecl(..), LInstDecl, DerivDecl(..), LDerivDecl, NewOrData(..),
 	RuleDecl(..), LRuleDecl, RuleBndr(..),
 	DefaultDecl(..), LDefaultDecl, SpliceDecl(..),
 	ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
@@ -67,6 +67,7 @@ type LHsDecl id = Located (HsDecl id)
 data HsDecl id
   = TyClD	(TyClDecl id)
   | InstD	(InstDecl  id)
+  | DerivD      (DerivDecl id)
   | ValD	(HsBind id)
   | SigD	(Sig id)
   | DefD	(DefaultDecl id)
@@ -153,6 +154,7 @@ instance OutputableBndr name => Outputable (HsDecl name) where
     ppr (ValD binds) = ppr binds
     ppr (DefD def)   = ppr def
     ppr (InstD inst) = ppr inst
+    ppr (DerivD deriv) = ppr deriv
     ppr (ForD fd)    = ppr fd
     ppr (SigD sd)    = ppr sd
     ppr (RuleD rd)   = ppr rd
@@ -715,6 +717,23 @@ instDeclATs (InstDecl _ _ _ ats) = ats
 
 %************************************************************************
 %*									*
+\subsection[DerivDecl]{A stand-alone instance deriving declaration
+%*									*
+%************************************************************************
+
+\begin{code}
+type LDerivDecl name = Located (DerivDecl name)
+
+data DerivDecl name
+  = DerivDecl (Located name) (LHsType name)
+
+instance (OutputableBndr name) => Outputable (DerivDecl name) where
+    ppr (DerivDecl cls ty)
+      = hsep [ptext SLIT("deriving"), ppr cls, ppr ty]
+\end{code}
+
+%************************************************************************
+%*									*
 \subsection[DefaultDecl]{A @default@ declaration}
 %*									*
 %************************************************************************
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 45da0d0..f9e74a8 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -27,7 +27,7 @@ module Lexer (
    failLocMsgP, failSpanMsgP, srcParseFail,
    popContext, pushCurrentContext, setLastToken, setSrcLoc,
    getLexState, popLexState, pushLexState,
-   extension, bangPatEnabled
+   extension, glaExtsEnabled, bangPatEnabled
   ) where
 
 #include "HsVersions.h"
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 0fd1b4d..c0c783f 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -455,9 +455,8 @@ topdecl :: { OrdList (LHsDecl RdrName) }
   	: cl_decl			{ unitOL (L1 (TyClD (unLoc $1))) }
   	| ty_decl			{ unitOL (L1 (TyClD (unLoc $1))) }
 	| 'instance' inst_type where
-		{ let (binds, sigs, ats) = cvBindsAndSigs (unLoc $3)
-		  in unitOL (L (comb3 $1 $2 $3) 
-			    (InstD (InstDecl $2 binds sigs ats))) }
+		{ let (binds,sigs) = cvBindsAndSigs (unLoc $3)
+		  in unitOL (L (comb3 $1 $2 $3) (InstD (InstDecl $2 binds sigs))) }
 	| 'default' '(' comma_types0 ')'	{ unitOL (LL $ DefD (DefaultDecl $3)) }
 	| 'foreign' fdecl			{ unitOL (LL (unLoc $2)) }
 	| '{-# DEPRECATED' deprecations '#-}'	{ $2 }
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index ace6fd0..7373ec0 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -40,6 +40,7 @@ module RdrHsSyn (
 	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 )
@@ -559,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 ; }