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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 ; }