Commit 8c1b6bd7 authored by simonpj's avatar simonpj

[project @ 2002-10-09 15:03:48 by simonpj]

-----------------------------------
	Lots more Template Haskell stuff
	-----------------------------------

At last!  Top-level declaration splices work!
Syntax is

	$(f x)

not "splice (f x)" as in the paper.

Lots jiggling around, particularly with the top-level plumbining.
Note the new data type HsDecls.HsGroup.
parent d04fb5dc
# -----------------------------------------------------------------------------
# $Id: Makefile,v 1.223 2002/09/16 10:16:14 simonmar Exp $
# $Id: Makefile,v 1.224 2002/10/09 15:03:48 simonpj Exp $
TOP = ..
......@@ -137,9 +137,9 @@ endif
# Only include GHCi if we're bootstrapping with at least version 411
ifeq "$(GhcWithInterpreter) $(bootstrapped)" "YES YES"
# Yes, include the interepreter, readline, and Template Haskell extensions
SRC_HC_OPTS += -DGHCI -package readline -package haskell-src
SRC_HC_OPTS += -DGHCI -package haskell-src
ifneq "$(TARGETPLATFORM)" "i386-unknown-mingw32"
SRC_HC_OPTS += -package unix
SRC_HC_OPTS += -package unix -package readline
endif
ALL_DIRS += ghci
else
......
......@@ -99,9 +99,11 @@ import Demand hiding( Demand, seqDemand )
import qualified Demand
import NewDemand
import Outputable
import Util ( listLengthCmp )
import Maybe ( isJust )
#ifdef OLD_STRICTNESS
import Util ( listLengthCmp )
import List ( replicate )
#endif
-- infixl so you can say (id `set` a `set` b)
infixl 1 `setSpecInfo`,
......
......@@ -373,13 +373,21 @@ type TyVarSubst = Subst -- TyVarSubst are expected to have range elements
-- it'll never be evaluated
mkTyVarSubst :: [TyVar] -> [Type] -> Subst
mkTyVarSubst tyvars tys = Subst (mkInScopeSet (tyVarsOfTypes tys))
(zip_ty_env tyvars tys emptySubstEnv)
(zipTyEnv tyvars tys)
-- mkTopTyVarSubst is called when doing top-level substitutions.
-- Here we expect that the free vars of the range of the
-- substitution will be empty.
mkTopTyVarSubst :: [TyVar] -> [Type] -> Subst
mkTopTyVarSubst tyvars tys = Subst emptyInScopeSet (zip_ty_env tyvars tys emptySubstEnv)
mkTopTyVarSubst tyvars tys = Subst emptyInScopeSet (zipTyEnv tyvars tys)
zipTyEnv tyvars tys
#ifdef DEBUG
| length tyvars /= length tys
= pprTrace "mkTopTyVarSubst" (ppr tyvars $$ ppr tys) emptySubstEnv
| otherwise
= zip_ty_env tyvars tys emptySubstEnv
#endif
zip_ty_env [] [] env = env
zip_ty_env (tv:tvs) (ty:tys) env = zip_ty_env tvs tys (extendSubstEnv env tv (DoneTy ty))
......
......@@ -54,9 +54,6 @@ dsMonoBinds auto_scc (AndMonoBinds binds_1 binds_2) rest
= dsMonoBinds auto_scc binds_2 rest `thenDs` \ rest' ->
dsMonoBinds auto_scc binds_1 rest'
dsMonoBinds _ (CoreMonoBind var core_expr) rest
= returnDs ((var, core_expr) : rest)
dsMonoBinds _ (VarMonoBind var expr) rest
= dsExpr expr `thenDs` \ core_expr ->
......
This diff is collapsed.
......@@ -40,8 +40,7 @@ import CoreSyn
import DsMonad
import CoreUtils ( exprType, mkIfThenElse, mkCoerce )
import PrelInfo ( iRREFUT_PAT_ERROR_ID )
import MkId ( mkReboxingAlt, mkNewTypeBody )
import MkId ( iRREFUT_PAT_ERROR_ID, mkReboxingAlt, mkNewTypeBody )
import Id ( idType, Id, mkWildId )
import Literal ( Literal(..), inIntRange, tARGET_MAX_INT )
import TyCon ( isNewTyCon, tyConDataCons )
......
......@@ -16,7 +16,7 @@ import HsSyn as Hs
( HsExpr(..), HsLit(..), ArithSeqInfo(..),
HsStmtContext(..),
Match(..), GRHSs(..), GRHS(..), HsPred(..),
HsDecl(..), TyClDecl(..), InstDecl(..), ConDecl(..),
HsDecl(..), InstDecl(..), ConDecl(..),
Stmt(..), HsBinds(..), MonoBinds(..), Sig(..),
Pat(..), HsConDetails(..), HsOverLit, BangType(..),
placeHolderType, HsType(..), HsTupCon(..),
......@@ -41,11 +41,12 @@ import Outputable
-------------------------------------------------------------------
convertToHsDecls :: [Meta.Dec] -> [HsDecl RdrName]
convertToHsDecls ds
= ValD (cvtdecs binds_and_sigs) : map cvt_top top_decls
where
(binds_and_sigs, top_decls) = partition sigOrBindP ds
convertToHsDecls ds = map cvt_top ds
cvt_top d@(Val _ _ _) = ValD (cvtd d)
cvt_top d@(Fun _ _) = ValD (cvtd d)
cvt_top (Data tc tvs constrs derivs)
= TyClD (mkTyData DataType
(noContext, tconName tc, cvt_tvs tvs)
......@@ -76,6 +77,8 @@ cvt_top (Instance tys ty decs)
(cvt_context tys)
(HsPredTy (cvt_pred ty))
cvt_top (Proto nm typ) = SigD (Sig (vName nm) (cvtType typ) loc0)
noContext = []
noExistentials = []
noFunDeps = []
......@@ -196,7 +199,7 @@ cvtp Pwild = WildPat void
cvt_tvs :: [String] -> [HsTyVarBndr RdrName]
cvt_tvs tvs = map (UserTyVar . tName) tvs
cvt_context :: Context -> HsContext RdrName
cvt_context :: Cxt -> HsContext RdrName
cvt_context tys = map cvt_pred tys
cvt_pred :: Typ -> HsPred RdrName
......@@ -205,15 +208,23 @@ cvt_pred ty = case split_ty_app ty of
other -> panic "Malformed predicate"
cvtType :: Meta.Typ -> HsType RdrName
cvtType (Tvar nm) = HsTyVar(tName nm)
cvtType (Tapp x y) = trans (root x [y])
where root (Tapp a b) zs = root a (b:zs)
root t zs = (t,zs)
trans (Tcon (Tuple n),args) = HsTupleTy (HsTupCon Boxed n) (map cvtType args)
trans (Tcon Arrow,[x,y]) = HsFunTy (cvtType x) (cvtType y)
trans (Tcon List,[x]) = HsListTy (cvtType x)
trans (Tcon (Name nm),args) = HsTyVar(tconName nm)
trans (t,args) = panic "bad type application"
cvtType ty = trans (root ty [])
where root (Tapp a b) zs = root a (cvtType b : zs)
root t zs = (t,zs)
trans (Tcon (Tuple n),args) | length args == n
= HsTupleTy (HsTupCon Boxed n) args
trans (Tcon Arrow, [x,y]) = HsFunTy x y
trans (Tcon List, [x]) = HsListTy x
trans (Tvar nm, args) = foldl HsAppTy (HsTyVar (tName nm)) args
trans (Tcon tc, args) = foldl HsAppTy (HsTyVar (tc_name tc)) args
tc_name (TconName nm) = tconName nm
tc_name Arrow = tconName "->"
tc_name List = tconName "[]"
tc_name (Tuple 0) = tconName "()"
tc_name (Tuple n) = tconName ("(" ++ replicate (n-1) ',' ++ ")")
split_ty_app :: Typ -> (Typ, [Typ])
split_ty_app ty = go ty []
......@@ -226,12 +237,6 @@ sigP :: Dec -> Bool
sigP (Proto _ _) = True
sigP other = False
sigOrBindP :: Dec -> Bool
sigOrBindP (Proto _ _) = True
sigOrBindP (Val _ _ _) = True
sigOrBindP (Fun _ _) = True
sigOrBindP other = False
-----------------------------------------------------------
-- some useful things
......
......@@ -125,9 +125,6 @@ data MonoBinds id
| VarMonoBind id -- TRANSLATION
(HsExpr id)
| CoreMonoBind id -- TRANSLATION
CoreExpr -- No zonking; this is a final CoreExpr with Ids and Types!
| AbsBinds -- Binds abstraction; TRANSLATION
[TyVar] -- Type variables
[id] -- Dicts
......@@ -212,9 +209,6 @@ ppr_monobind (FunMonoBind fun inf matches locn) = pprFunBind fun matches
ppr_monobind (VarMonoBind name expr)
= sep [pprBndr LetBind name <+> equals, nest 4 (pprExpr expr)]
ppr_monobind (CoreMonoBind name expr)
= sep [pprBndr LetBind name <+> equals, nest 4 (ppr expr)]
ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds)
= sep [ptext SLIT("AbsBinds"),
brackets (interpp'SP tyvars),
......
......@@ -9,13 +9,12 @@ Definitions for: @TyDecl@ and @oCnDecl@, @ClassDecl@,
\begin{code}
module HsDecls (
HsDecl(..), TyClDecl(..), InstDecl(..), RuleDecl(..), RuleBndr(..),
DefaultDecl(..),
DefaultDecl(..), HsGroup(..),
ForeignDecl(..), ForeignImport(..), ForeignExport(..),
CImportSpec(..), FoType(..),
ConDecl(..), CoreDecl(..),
BangType(..), getBangType, getBangStrictness, unbangedType,
DeprecDecl(..), DeprecTxt,
hsDeclName, instDeclName,
tyClDeclName, tyClDeclNames, tyClDeclTyVars,
isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl,
isTypeOrClassDecl, countTyClDecls,
......@@ -68,17 +67,17 @@ import Maybe ( isNothing, fromJust )
data HsDecl id
= TyClD (TyClDecl id)
| InstD (InstDecl id)
| ValD (MonoBinds id)
| SigD (Sig id)
| DefD (DefaultDecl id)
| ValD (HsBinds id)
| ForD (ForeignDecl id)
| FixD (FixitySig id)
| DeprecD (DeprecDecl id)
| RuleD (RuleDecl id)
| CoreD (CoreDecl id)
| SpliceD (HsExpr id) -- Top level splice
-- NB: all top-level fixity decls are contained EITHER
-- EITHER FixDs
-- EITHER SigDs
-- OR in the ClassDecls in TyClDs
--
-- The former covers
......@@ -89,42 +88,63 @@ data HsDecl id
-- d) top level decls
--
-- The latter is for class methods only
\end{code}
\begin{code}
#ifdef DEBUG
hsDeclName :: (NamedThing name, OutputableBndr name)
=> HsDecl name -> name
#endif
hsDeclName (TyClD decl) = tyClDeclName decl
hsDeclName (InstD decl) = instDeclName decl
hsDeclName (ForD decl) = foreignDeclName decl
hsDeclName (FixD (FixitySig name _ _)) = name
hsDeclName (CoreD (CoreDecl name _ _ _)) = name
-- Others don't make sense
#ifdef DEBUG
hsDeclName x = pprPanic "HsDecls.hsDeclName" (ppr x)
#endif
instDeclName :: InstDecl name -> name
instDeclName (InstDecl _ _ _ (Just name) _) = name
-- A [HsDecl] is categorised into a HsGroup before being
-- fed to the renamer.
data HsGroup id
= HsGroup {
hs_valds :: HsBinds id,
-- Before the renamer, this is a single big MonoBinds,
-- with all the bindings, and all the signatures.
-- The renamer does dependency analysis, using ThenBinds
-- to give the structure
hs_tyclds :: [TyClDecl id],
hs_instds :: [InstDecl id],
hs_fixds :: [FixitySig id],
-- Snaffled out of both top-level fixity signatures,
-- and those in class declarations
hs_defds :: [DefaultDecl id],
hs_fords :: [ForeignDecl id],
hs_depds :: [DeprecDecl id],
hs_ruleds :: [RuleDecl id],
hs_coreds :: [CoreDecl id]
}
\end{code}
\begin{code}
instance OutputableBndr name => Outputable (HsDecl name) where
ppr (TyClD dcl) = ppr dcl
ppr (ValD binds) = ppr binds
ppr (DefD def) = ppr def
ppr (InstD inst) = ppr inst
ppr (ForD fd) = ppr fd
ppr (FixD fd) = ppr fd
ppr (SigD sd) = ppr sd
ppr (RuleD rd) = ppr rd
ppr (DeprecD dd) = ppr dd
ppr (CoreD dd) = ppr dd
ppr (SpliceD e) = ptext SLIT("splice") <> parens (pprExpr e)
instance OutputableBndr name => Outputable (HsGroup name) where
ppr (HsGroup { hs_valds = val_decls,
hs_tyclds = tycl_decls,
hs_instds = inst_decls,
hs_fixds = fix_decls,
hs_depds = deprec_decls,
hs_fords = foreign_decls,
hs_defds = default_decls,
hs_ruleds = rule_decls,
hs_coreds = core_decls })
= vcat [ppr_ds fix_decls, ppr_ds default_decls,
ppr_ds deprec_decls, ppr_ds rule_decls,
ppr val_decls,
ppr_ds tycl_decls, ppr_ds inst_decls,
ppr_ds foreign_decls, ppr_ds core_decls]
where
ppr_ds [] = empty
ppr_ds ds = text "" $$ vcat (map ppr ds)
\end{code}
......
......@@ -9,7 +9,7 @@ module HsExpr where
#include "HsVersions.h"
-- friends:
import HsDecls ( HsDecl )
import HsDecls ( HsGroup )
import HsBinds ( HsBinds(..), nullBinds )
import HsPat ( Pat )
import HsLit ( HsLit, HsOverLit )
......@@ -670,7 +670,7 @@ pprComp brack stmts = brack $
\begin{code}
data HsBracket id = ExpBr (HsExpr id)
| PatBr (Pat id)
| DecBr [HsDecl id]
| DecBr (HsGroup id)
| TypBr (HsType id)
instance OutputableBndr id => Outputable (HsBracket id) where
......@@ -679,7 +679,7 @@ instance OutputableBndr id => Outputable (HsBracket id) where
pprHsBracket (ExpBr e) = thBrackets empty (ppr e)
pprHsBracket (PatBr p) = thBrackets (char 'p') (ppr p)
pprHsBracket (DecBr d) = thBrackets (char 'd') (vcat (map ppr d))
pprHsBracket (DecBr d) = thBrackets (char 'd') (ppr d)
pprHsBracket (TypBr t) = thBrackets (char 't') (ppr t)
......
......@@ -9,11 +9,9 @@ therefore, is almost nothing but re-exporting.
\begin{code}
module HsSyn (
-- NB: don't reexport HsCore
-- this module tells about "real Haskell"
module HsSyn,
module HsBinds,
module HsDecls,
module HsExpr,
......@@ -23,10 +21,11 @@ module HsSyn (
module HsTypes,
Fixity, NewOrData,
HsModule(..), hsModule, hsImports,
collectStmtsBinders,
collectHsBinders, collectLocatedHsBinders,
collectMonoBinders, collectLocatedMonoBinders,
collectSigTysFromHsBinds, collectSigTysFromMonoBinds,
hsModule, hsImports
collectSigTysFromHsBinds, collectSigTysFromMonoBinds
) where
#include "HsVersions.h"
......@@ -151,6 +150,13 @@ collectMonoBinders binds
go (AndMonoBinds bs1 bs2) acc = go bs1 (go bs2 acc)
\end{code}
%************************************************************************
%* *
\subsection{Getting patterns out of bindings}
%* *
%************************************************************************
Get all the pattern type signatures out of a bunch of bindings
\begin{code}
......
-----------------------------------------------------------------------------
-- $Id: DriverMkDepend.hs,v 1.23 2002/09/18 10:51:01 simonmar Exp $
-- $Id: DriverMkDepend.hs,v 1.24 2002/10/09 15:03:52 simonpj Exp $
--
-- GHC Driver
--
......@@ -22,7 +22,7 @@ import Finder ( findModuleDep )
import Util ( global )
import Panic
import DATA_IOREF ( IORef, newIORef, readIORef, writeIORef )
import DATA_IOREF ( IORef, readIORef, writeIORef )
import EXCEPTION
import Directory
......
......@@ -41,9 +41,8 @@ import Lex ( ParseResult(..), ExtFlags(..), mkPState )
import SrcLoc ( mkSrcLoc )
import TcRnDriver ( checkOldIface, tcRnModule, tcRnExtCore, tcRnIface )
import Rules ( emptyRuleBase )
import PrelInfo ( wiredInThingEnv, wiredInThings )
import PrelInfo ( wiredInThingEnv, wiredInThings, knownKeyNames )
import PrelRules ( builtinRules )
import PrelNames ( knownKeyNames )
import MkIface ( mkIface )
import InstEnv ( emptyInstEnv )
import Desugar
......
......@@ -34,7 +34,7 @@ ppSourceStats short (HsModule name version exports imports decls _ src_loc)
(" ImpAll ", import_all),
(" ImpPartial ", import_partial),
(" ImpHiding ", import_hiding),
("FixityDecls ", fixity_ds),
("FixityDecls ", fixity_sigs),
("DefaultDecls ", default_ds),
("TypeDecls ", type_ds),
("DataDecls ", data_ds),
......@@ -64,7 +64,8 @@ ppSourceStats short (HsModule name version exports imports decls _ src_loc)
trim ls = takeWhile (not.isSpace) (dropWhile isSpace ls)
fixity_ds = count (\ x -> case x of { FixD{} -> True; _ -> False}) decls
(fixity_sigs, bind_tys, _, bind_specs, bind_inlines)
= count_sigs [d | SigD d <- decls]
-- NB: this omits fixity decls on local bindings and
-- in class decls. ToDo
......@@ -83,8 +84,8 @@ ppSourceStats short (HsModule name version exports imports decls _ src_loc)
export_ds = n_exports - export_ms
export_all = case exports of { Nothing -> 1; other -> 0 }
(val_bind_ds, fn_bind_ds, bind_tys, bind_specs, bind_inlines)
= count_binds (foldr ThenBinds EmptyBinds val_decls)
(val_bind_ds, fn_bind_ds)
= foldr add2 (0,0) (map count_monobinds val_decls)
(import_no, import_qual, import_as, import_all, import_partial, import_hiding)
= foldr add6 (0,0,0,0,0,0) (map import_info imports)
......@@ -95,12 +96,6 @@ ppSourceStats short (HsModule name version exports imports decls _ src_loc)
(inst_method_ds, method_specs, method_inlines)
= foldr add3 (0,0,0) (map inst_info inst_decls)
count_binds EmptyBinds = (0,0,0,0,0)
count_binds (ThenBinds b1 b2) = count_binds b1 `add5` count_binds b2
count_binds (MonoBind b sigs _) = case (count_monobinds b, count_sigs sigs) of
((vs,fs),(ts,_,ss,is)) -> (vs,fs,ts,ss,is)
count_monobinds EmptyMonoBinds = (0,0)
count_monobinds (AndMonoBinds b1 b2) = count_monobinds b1 `add2` count_monobinds b2
count_monobinds (PatMonoBind (VarPat n) r _) = (1,0)
......@@ -110,13 +105,14 @@ ppSourceStats short (HsModule name version exports imports decls _ src_loc)
count_mb_monobinds (Just mbs) = count_monobinds mbs
count_mb_monobinds Nothing = (0,0)
count_sigs sigs = foldr add4 (0,0,0,0) (map sig_info sigs)
count_sigs sigs = foldr add5 (0,0,0,0,0) (map sig_info sigs)
sig_info (Sig _ _ _) = (1,0,0,0)
sig_info (ClassOpSig _ _ _ _) = (0,1,0,0)
sig_info (SpecSig _ _ _) = (0,0,1,0)
sig_info (InlineSig _ _ _ _) = (0,0,0,1)
sig_info _ = (0,0,0,0)
sig_info (FixSig _) = (1,0,0,0,0)
sig_info (Sig _ _ _) = (0,1,0,0,0)
sig_info (ClassOpSig _ _ _ _) = (0,0,1,0,0)
sig_info (SpecSig _ _ _) = (0,0,0,1,0)
sig_info (InlineSig _ _ _ _) = (0,0,0,0,1)
sig_info _ = (0,0,0,0,0)
import_info (ImportDecl _ _ qual as spec _)
= add6 (1, qual_info qual, as_info as, 0,0,0) (spec_info spec)
......@@ -134,13 +130,13 @@ ppSourceStats short (HsModule name version exports imports decls _ src_loc)
class_info decl@(ClassDecl {})
= case count_sigs (tcdSigs decl) of
(_,classops,_,_) ->
(_,_,classops,_,_) ->
(classops, addpr (count_mb_monobinds (tcdMeths decl)))
class_info other = (0,0)
inst_info (InstDecl _ inst_meths inst_sigs _ _)
= case count_sigs inst_sigs of
(_,_,ss,is) ->
(_,_,_,ss,is) ->
(addpr (count_monobinds inst_meths), ss, is)
addpr :: (Int,Int) -> Int
......
{- -*-haskell-*-
-----------------------------------------------------------------------------
$Id: Parser.y,v 1.105 2002/09/27 08:20:45 simonpj Exp $
$Id: Parser.y,v 1.106 2002/10/09 15:03:53 simonpj Exp $
Haskell grammar.
......@@ -19,7 +19,6 @@ import HsTypes ( mkHsTupCon )
import RdrHsSyn
import HscTypes ( ParsedIface(..), IsBootInterface )
import Lex
import ParseUtil
import RdrName
import PrelNames ( mAIN_Name, funTyConName, listTyConName,
parrTyConName, consDataConName, nilDataConName )
......@@ -280,7 +279,7 @@ top :: { ([RdrNameImportDecl], [RdrNameHsDecl]) }
| cvtopdecls { ([],$1) }
cvtopdecls :: { [RdrNameHsDecl] }
: topdecls { cvTopDecls (groupBindings $1)}
: topdecls { cvTopDecls $1 }
-----------------------------------------------------------------------------
-- Interfaces (.hi-boot files)
......@@ -307,30 +306,14 @@ ifacebody :: { [RdrNameTyClDecl] }
| layout_on ifacedecls close { $2 }
ifacedecls :: { [RdrNameTyClDecl] }
: ifacedecl ';' ifacedecls { $1 : $3 }
| ';' ifacedecls { $2 }
| ifacedecl { [$1] }
| {- empty -} { [] }
: ifacedecl ';' ifacedecls { $1 : $3 }
| ';' ifacedecls { $2 }
| ifacedecl { [$1] }
| {- empty -} { [] }
ifacedecl :: { RdrNameTyClDecl }
: srcloc 'data' tycl_hdr constrs
{ mkTyData DataType $3 (DataCons (reverse $4)) Nothing $1 }
| srcloc 'newtype' tycl_hdr '=' newconstr
{ mkTyData NewType $3 (DataCons [$5]) Nothing $1 }
| srcloc 'class' tycl_hdr fds where
{ let
(binds,sigs) = cvMonoBindsAndSigs cvClassOpSig
(groupBindings $5)
in
mkClassDecl $3 $4 sigs (Just binds) $1 }
| srcloc 'type' tycon tv_bndrs '=' ctype
{ TySynonym $3 $4 $6 $1 }
| srcloc var '::' sigtype
{ IfaceSig $2 $4 [] $1 }
: tycl_decl { $1 }
| srcloc var '::' sigtype { IfaceSig $2 $4 [] $1 }
-----------------------------------------------------------------------------
-- The Export List
......@@ -404,8 +387,7 @@ impspec :: { (Bool, [RdrNameIE]) }
prec :: { Int }
: {- empty -} { 9 }
| INTEGER {% checkPrec $1 `thenP_`
returnP (fromInteger $1) }
| INTEGER {% checkPrecP (fromInteger $1) }
infix :: { FixityDirection }
: 'infix' { InfixN }
......@@ -419,48 +401,43 @@ ops :: { [RdrName] }
-----------------------------------------------------------------------------
-- Top-Level Declarations
topdecls :: { [RdrBinding] }
: topdecls ';' topdecl { ($3 : $1) }
topdecls :: { [RdrBinding] } -- Reversed
: topdecls ';' topdecl { $3 : $1 }
| topdecls ';' { $1 }
| topdecl { [$1] }
topdecl :: { RdrBinding }
: tycl_decl { RdrHsDecl (TyClD $1) }
| srcloc 'instance' inst_type where
{ let (binds,sigs) = cvMonoBindsAndSigs $4
in RdrHsDecl (InstD (InstDecl $3 binds sigs Nothing $1)) }
| srcloc 'default' '(' comma_types0 ')' { RdrHsDecl (DefD (DefaultDecl $4 $1)) }
| 'foreign' fdecl { RdrHsDecl $2 }
| '{-# DEPRECATED' deprecations '#-}' { RdrBindings $2 }
| '{-# RULES' rules '#-}' { RdrBindings $2 }
| '$(' exp ')' { RdrHsDecl (SpliceD $2) }
| decl { $1 }
tycl_decl :: { RdrNameTyClDecl }
: srcloc 'type' syn_hdr '=' ctype
-- Note ctype, not sigtype.
-- We allow an explicit for-all but we don't insert one
-- in type Foo a = (b,b)
-- Instead we just say b is out of scope
{ let (tc,tvs) = $3
in RdrHsDecl (TyClD (TySynonym tc tvs $5 $1)) }
{ let (tc,tvs) = $3 in TySynonym tc tvs $5 $1 }
| srcloc 'data' tycl_hdr constrs deriving
{% returnP (RdrHsDecl (TyClD
(mkTyData DataType $3 (DataCons (reverse $4)) $5 $1))) }
{ mkTyData DataType $3 (DataCons (reverse $4)) $5 $1 }
| srcloc 'newtype' tycl_hdr '=' newconstr deriving
{% returnP (RdrHsDecl (TyClD
(mkTyData NewType $3 (DataCons [$5]) $6 $1))) }
{ mkTyData NewType $3 (DataCons [$5]) $6 $1 }
| srcloc 'class' tycl_hdr fds where
{% let
(binds,sigs) = cvMonoBindsAndSigs cvClassOpSig (groupBindings $5)
in
returnP (RdrHsDecl (TyClD
(mkClassDecl $3 $4 sigs (Just binds) $1))) }
| srcloc 'instance' inst_type where
{ let (binds,sigs)
= cvMonoBindsAndSigs cvInstDeclSig
(groupBindings $4)
in RdrHsDecl (InstD (InstDecl $3 binds sigs Nothing $1)) }
| srcloc 'default' '(' comma_types0 ')' { RdrHsDecl (DefD (DefaultDecl $4 $1)) }
| 'foreign' fdecl { RdrHsDecl $2 }
| '{-# DEPRECATED' deprecations '#-}' { $2 }
| '{-# RULES' rules '#-}' { $2 }
| '$(' exp ')' { RdrHsDecl (SpliceD $2) }
| decl { $1 }
{ let
(binds,sigs) = cvMonoBindsAndSigs $5
in
mkClassDecl $3 $4 (map cvClassOpSig sigs) (Just binds) $1 }
syn_hdr :: { (RdrName, [RdrNameHsTyVar]) } -- We don't retain the syntax of an infix
-- type synonym declaration. Oh well.
......@@ -479,94 +456,41 @@ tycl_hdr :: { (RdrNameContext, RdrName, [RdrNameHsTyVar]) }
| type {% checkTyClHdr $1 `thenP` \ (tc,tvs) ->
returnP ([], tc, tvs) }
{-
: '(' comma_types1 ')' '=>' gtycon tv_bndrs
{% mapP checkPred $2 `thenP` \ cxt ->
returnP (cxt, $5, $6) }
| '(' ')' '=>' gtycon tv_bndrs
{ ([], $4, $5) }
-- qtycon for the class below name would lead to many s/r conflicts
-- FIXME: does the renamer pick up all wrong forms and raise an
-- error