Commit cb8044eb authored by bjorn@bringert.net's avatar bjorn@bringert.net
Browse files

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

parent 52f8fed4
...@@ -9,7 +9,7 @@ Definitions for: @TyDecl@ and @oCnDecl@, @ClassDecl@, ...@@ -9,7 +9,7 @@ Definitions for: @TyDecl@ and @oCnDecl@, @ClassDecl@,
\begin{code} \begin{code}
module HsDecls ( module HsDecls (
HsDecl(..), LHsDecl, TyClDecl(..), LTyClDecl, HsDecl(..), LHsDecl, TyClDecl(..), LTyClDecl,
InstDecl(..), LInstDecl, NewOrData(..), InstDecl(..), LInstDecl, DerivDecl(..), LDerivDecl, NewOrData(..),
RuleDecl(..), LRuleDecl, RuleBndr(..), RuleDecl(..), LRuleDecl, RuleBndr(..),
DefaultDecl(..), LDefaultDecl, SpliceDecl(..), DefaultDecl(..), LDefaultDecl, SpliceDecl(..),
ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..), ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
...@@ -67,6 +67,7 @@ type LHsDecl id = Located (HsDecl id) ...@@ -67,6 +67,7 @@ type LHsDecl id = Located (HsDecl id)
data HsDecl id data HsDecl id
= TyClD (TyClDecl id) = TyClD (TyClDecl id)
| InstD (InstDecl id) | InstD (InstDecl id)
| DerivD (DerivDecl id)
| ValD (HsBind id) | ValD (HsBind id)
| SigD (Sig id) | SigD (Sig id)
| DefD (DefaultDecl id) | DefD (DefaultDecl id)
...@@ -153,6 +154,7 @@ instance OutputableBndr name => Outputable (HsDecl name) where ...@@ -153,6 +154,7 @@ instance OutputableBndr name => Outputable (HsDecl name) where
ppr (ValD binds) = ppr binds ppr (ValD binds) = ppr binds
ppr (DefD def) = ppr def ppr (DefD def) = ppr def
ppr (InstD inst) = ppr inst ppr (InstD inst) = ppr inst
ppr (DerivD deriv) = ppr deriv
ppr (ForD fd) = ppr fd ppr (ForD fd) = ppr fd
ppr (SigD sd) = ppr sd ppr (SigD sd) = ppr sd
ppr (RuleD rd) = ppr rd ppr (RuleD rd) = ppr rd
...@@ -713,6 +715,23 @@ instDeclATs :: InstDecl name -> [LTyClDecl name] ...@@ -713,6 +715,23 @@ instDeclATs :: InstDecl name -> [LTyClDecl name]
instDeclATs (InstDecl _ _ _ ats) = ats instDeclATs (InstDecl _ _ _ ats) = ats
\end{code} \end{code}
%************************************************************************
%* *
\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} \subsection[DefaultDecl]{A @default@ declaration}
......
...@@ -27,7 +27,7 @@ module Lexer ( ...@@ -27,7 +27,7 @@ module Lexer (
failLocMsgP, failSpanMsgP, srcParseFail, failLocMsgP, failSpanMsgP, srcParseFail,
popContext, pushCurrentContext, setLastToken, setSrcLoc, popContext, pushCurrentContext, setLastToken, setSrcLoc,
getLexState, popLexState, pushLexState, getLexState, popLexState, pushLexState,
extension, bangPatEnabled extension, glaExtsEnabled, bangPatEnabled
) where ) where
#include "HsVersions.h" #include "HsVersions.h"
......
...@@ -455,9 +455,8 @@ topdecl :: { OrdList (LHsDecl RdrName) } ...@@ -455,9 +455,8 @@ topdecl :: { OrdList (LHsDecl RdrName) }
: cl_decl { unitOL (L1 (TyClD (unLoc $1))) } : cl_decl { unitOL (L1 (TyClD (unLoc $1))) }
| ty_decl { unitOL (L1 (TyClD (unLoc $1))) } | ty_decl { unitOL (L1 (TyClD (unLoc $1))) }
| 'instance' inst_type where | 'instance' inst_type where
{ let (binds, sigs, ats) = cvBindsAndSigs (unLoc $3) { let (binds,sigs) = cvBindsAndSigs (unLoc $3)
in unitOL (L (comb3 $1 $2 $3) in unitOL (L (comb3 $1 $2 $3) (InstD (InstDecl $2 binds sigs))) }
(InstD (InstDecl $2 binds sigs ats))) }
| 'default' '(' comma_types0 ')' { unitOL (LL $ DefD (DefaultDecl $3)) } | 'default' '(' comma_types0 ')' { unitOL (LL $ DefD (DefaultDecl $3)) }
| 'foreign' fdecl { unitOL (LL (unLoc $2)) } | 'foreign' fdecl { unitOL (LL (unLoc $2)) }
| '{-# DEPRECATED' deprecations '#-}' { $2 } | '{-# DEPRECATED' deprecations '#-}' { $2 }
......
...@@ -40,6 +40,7 @@ module RdrHsSyn ( ...@@ -40,6 +40,7 @@ module RdrHsSyn (
checkSynHdr, -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName]) checkSynHdr, -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName])
checkKindSigs, -- [LTyClDecl RdrName] -> P () checkKindSigs, -- [LTyClDecl RdrName] -> P ()
checkInstType, -- HsType -> P HsType checkInstType, -- HsType -> P HsType
checkDerivDecl, -- LDerivDecl RdrName -> P (LDerivDecl RdrName)
checkPattern, -- HsExp -> P HsPat checkPattern, -- HsExp -> P HsPat
checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat] checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat]
checkDo, -- [Stmt] -> P [Stmt] checkDo, -- [Stmt] -> P [Stmt]
...@@ -56,7 +57,7 @@ import RdrName ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc, ...@@ -56,7 +57,7 @@ import RdrName ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc,
isRdrDataCon, isUnqual, getRdrName, isQual, isRdrDataCon, isUnqual, getRdrName, isQual,
setRdrNameSpace ) setRdrNameSpace )
import BasicTypes ( maxPrecedence, Activation, InlineSpec(..), alwaysInlineSpec, neverInlineSpec ) import BasicTypes ( maxPrecedence, Activation, InlineSpec(..), alwaysInlineSpec, neverInlineSpec )
import Lexer ( P, failSpanMsgP, extension, bangPatEnabled ) import Lexer ( P, failSpanMsgP, extension, glaExtsEnabled, bangPatEnabled )
import TysWiredIn ( unitTyCon ) import TysWiredIn ( unitTyCon )
import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..), import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
DNCallSpec(..), DNKind(..), CLabelString ) DNCallSpec(..), DNKind(..), CLabelString )
...@@ -559,6 +560,16 @@ checkDictTy (L spn ty) = check ty [] ...@@ -559,6 +560,16 @@ checkDictTy (L spn ty) = check ty []
check (HsParTy t) args = check (unLoc t) args check (HsParTy t) args = check (unLoc t) args
check _ _ = parseError spn "Malformed context in instance header" 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 -- Checking statements in a do-expression
-- We parse do { e1 ; e2 ; } -- We parse do { e1 ; e2 ; }
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment