Commit 3ad8f84f authored by bjorn@bringert.net's avatar bjorn@bringert.net

New syntax for stand-alone deriving. Implemented fully.

parent 15486d73
......@@ -731,11 +731,11 @@ instDeclATs (InstDecl _ _ _ ats) = ats
type LDerivDecl name = Located (DerivDecl name)
data DerivDecl name
= DerivDecl (Located name) (LHsType name)
= DerivDecl (LHsType name) (Located name)
instance (OutputableBndr name) => Outputable (DerivDecl name) where
ppr (DerivDecl cls ty)
= hsep [ptext SLIT("deriving"), ppr cls, ppr ty]
ppr (DerivDecl ty n)
= hsep [ptext SLIT("deriving"), ppr ty, ptext SLIT("for"), ppr n]
\end{code}
%************************************************************************
......
......@@ -345,6 +345,7 @@ data Token
| ITderiving
| ITdo
| ITelse
| ITfor
| IThiding
| ITif
| ITimport
......@@ -488,6 +489,7 @@ isSpecial :: Token -> Bool
-- not as a keyword.
isSpecial ITas = True
isSpecial IThiding = True
isSpecial ITfor = True
isSpecial ITqualified = True
isSpecial ITforall = True
isSpecial ITexport = True
......@@ -521,6 +523,7 @@ reservedWordsFM = listToUFM $
( "deriving", ITderiving, 0 ),
( "do", ITdo, 0 ),
( "else", ITelse, 0 ),
( "for", ITfor, 0 ),
( "hiding", IThiding, 0 ),
( "if", ITif, 0 ),
( "import", ITimport, 0 ),
......
......@@ -159,6 +159,7 @@ incorrect.
'deriving' { L _ ITderiving }
'do' { L _ ITdo }
'else' { L _ ITelse }
'for' { L _ ITfor }
'hiding' { L _ IThiding }
'if' { L _ ITif }
'import' { L _ ITimport }
......@@ -661,6 +662,16 @@ tycl_hdr :: { Located (LHsContext RdrName,
: context '=>' type {% checkTyClHdr $1 $3 >>= return.LL }
| type {% checkTyClHdr (noLoc []) $1 >>= return.L1 }
-----------------------------------------------------------------------------
-- Stand-alone deriving
-- Glasgow extension: stand-alone deriving declarations
stand_alone_deriving :: { LDerivDecl RdrName }
: 'deriving' qtycon 'for' qtycon {% do { p <- checkInstType (fmap HsTyVar $2)
; checkDerivDecl (LL (DerivDecl p $4)) } }
| 'deriving' '(' inst_type ')' 'for' qtycon {% checkDerivDecl (LL (DerivDecl $3 $6)) }
-----------------------------------------------------------------------------
-- Nested declarations
......
......@@ -377,11 +377,11 @@ extendTyVarEnvForMethodBinds tyvars thing_inside
\begin{code}
rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars)
rnSrcDerivDecl (DerivDecl cls ty)
= do cls' <- lookupLocatedOccRn cls
ty' <- rnLHsType (text "a deriving decl") ty
let fvs = extractHsTyNames ty'
return (DerivDecl cls' ty', fvs)
rnSrcDerivDecl (DerivDecl ty n)
= do ty' <- rnLHsType (text "a deriving decl") ty
n' <- lookupLocatedOccRn n
let fvs = extractHsTyNames ty' `addOneFV` unLoc n'
return (DerivDecl ty' n', fvs)
\end{code}
%*********************************************************
......
......@@ -18,7 +18,7 @@ import TcRnMonad
import TcMType ( checkValidInstance )
import TcEnv ( newDFunName, pprInstInfoDetails,
InstInfo(..), InstBindings(..), simpleInstInfoClsTy,
tcLookupClass, tcLookupTyCon, tcExtendTyVarEnv
tcLookupClass, tcLookupTyCon, tcLookupLocatedTyCon, tcExtendTyVarEnv
)
import TcGenDeriv -- Deriv stuff
import InstEnv ( Instance, OverlapFlag, mkLocalInstance, instanceHead, extendInstEnvList )
......@@ -41,7 +41,7 @@ import Name ( Name, getSrcLoc )
import NameSet ( duDefs )
import Type ( splitKindFunTys )
import TyCon ( tyConTyVars, tyConDataCons, tyConArity, tyConHasGenerics,
tyConStupidTheta, isProductTyCon, isDataTyCon, newTyConRhs,
tyConStupidTheta, isProductTyCon, isDataTyCon, isNewTyCon, newTyConRhs,
isEnumerationTyCon, isRecursiveTyCon, TyCon
)
import TcType ( TcType, ThetaType, mkTyVarTys, mkTyConApp, tcTyConAppTyCon,
......@@ -50,7 +50,7 @@ import TcType ( TcType, ThetaType, mkTyVarTys, mkTyConApp, tcTyConAppTyCon,
import Var ( TyVar, tyVarKind, varName )
import VarSet ( mkVarSet, disjointVarSet )
import PrelNames
import SrcLoc ( srcLocSpan, Located(..) )
import SrcLoc ( srcLocSpan, Located(..), unLoc )
import Util ( zipWithEqual, sortLe, notNull )
import ListSetOps ( removeDups, assocMaybe )
import Outputable
......@@ -206,15 +206,17 @@ And then translate it to:
\begin{code}
tcDeriving :: [LTyClDecl Name] -- All type constructors
-> [LDerivDecl Name] -- All stand-alone deriving declarations
-> TcM ([InstInfo], -- The generated "instance decls"
HsValBinds Name) -- Extra generated top-level bindings
tcDeriving tycl_decls
tcDeriving tycl_decls deriv_decls
= recoverM (returnM ([], emptyValBindsOut)) $
do { -- Fish the "deriving"-related information out of the TcEnv
-- and make the necessary "equations".
overlap_flag <- getOverlapFlag
; (ordinary_eqns, newtype_inst_info) <- makeDerivEqns overlap_flag tycl_decls
; (ordinary_eqns, newtype_inst_info)
<- makeDerivEqns overlap_flag tycl_decls deriv_decls
; (ordinary_inst_info, deriv_binds)
<- extendLocalInstEnv (map iSpec newtype_inst_info) $
......@@ -337,12 +339,15 @@ when the dict is constructed in TcInstDcls.tcInstDecl2
\begin{code}
makeDerivEqns :: OverlapFlag
-> [LTyClDecl Name]
-> [LDerivDecl Name]
-> TcM ([DerivEqn], -- Ordinary derivings
[InstInfo]) -- Special newtype derivings
makeDerivEqns overlap_flag tycl_decls
= mapAndUnzipM mk_eqn derive_these `thenM` \ (maybe_ordinaries, maybe_newtypes) ->
returnM (catMaybes maybe_ordinaries, catMaybes maybe_newtypes)
makeDerivEqns overlap_flag tycl_decls deriv_decls
= do derive_these_top_level <- mapM top_level_deriv deriv_decls >>= return . catMaybes
(maybe_ordinaries, maybe_newtypes)
<- mapAndUnzipM mk_eqn (derive_these ++ derive_these_top_level)
return (catMaybes maybe_ordinaries, catMaybes maybe_newtypes)
where
------------------------------------------------------------------
derive_these :: [(NewOrData, Name, LHsType Name)]
......@@ -352,7 +357,15 @@ makeDerivEqns overlap_flag tycl_decls
tcdDerivs = Just preds }) <- tycl_decls,
pred <- preds ]
top_level_deriv :: LDerivDecl Name -> TcM (Maybe (NewOrData, Name, LHsType Name))
top_level_deriv d@(L l (DerivDecl inst ty_name)) = recoverM (returnM Nothing) $ setSrcSpan l $
do tycon <- tcLookupLocatedTyCon ty_name
let new_or_data = if isNewTyCon tycon then NewType else DataType
traceTc (text "Stand-alone deriving:" <+> ppr (new_or_data, unLoc ty_name, inst))
return $ Just (new_or_data, unLoc ty_name, inst)
------------------------------------------------------------------
-- takes (whether newtype or data, name of data type, partially applied type class)
mk_eqn :: (NewOrData, Name, LHsType Name) -> TcM (Maybe DerivEqn, Maybe InstInfo)
-- We swizzle the tyvars and datacons out of the tycon
-- to make the rest of the equation
......
......@@ -146,12 +146,13 @@ Gather up the instance declarations from their various sources
tcInstDecls1 -- Deal with both source-code and imported instance decls
:: [LTyClDecl Name] -- For deriving stuff
-> [LInstDecl Name] -- Source code instance decls
-> [LDerivDecl Name] -- Source code stand-alone deriving decls
-> TcM (TcGblEnv, -- The full inst env
[InstInfo], -- Source-code instance decls to process;
-- contains all dfuns for this module
HsValBinds Name) -- Supporting bindings for derived instances
tcInstDecls1 tycl_decls inst_decls
tcInstDecls1 tycl_decls inst_decls deriv_decls
= checkNoErrs $
do { -- Stop if addInstInfos etc discovers any errors
-- (they recover, so that we get more than one error each
......@@ -178,14 +179,11 @@ tcInstDecls1 tycl_decls inst_decls
-- (3) Instances from generic class declarations
; generic_inst_info <- getGenericInstances clas_decls
-- Next, construct the instance environment so far, consisting
-- of
-- a) local instance decls
-- b) generic instances
-- c) local family instance decls
; addInsts local_info $ do {
; addInsts generic_inst_info $ do {
; addFamInsts at_idx_tycon $ do {
-- (3) Compute instances from "deriving" clauses;
-- This stuff computes a context for the derived instance decl, so it
-- needs to know about all the instances possible; hence inst_env4
tcDeriving tycl_decls `thenM` \ (deriv_inst_info, deriv_binds) ->
addInsts deriv_inst_info $
-- (4) Compute instances from "deriving" clauses;
-- This stuff computes a context for the derived instance
......
......@@ -473,7 +473,8 @@ tcRnHsBootDecls decls
-- Typecheck instance decls
; traceTc (text "Tc3")
; (tcg_env, inst_infos, _binds) <- tcInstDecls1 tycl_decls (hs_instds rn_group)
; (tcg_env, inst_infos, _binds)
<- tcInstDecls1 tycl_decls (hs_instds rn_group) (hs_derivds rn_group)
; setGblEnv tcg_env $ do {
-- Typecheck value declarations
......@@ -629,6 +630,7 @@ tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
tcTopSrcDecls boot_details
(HsGroup { hs_tyclds = tycl_decls,
hs_instds = inst_decls,
hs_derivds = deriv_decls,
hs_fords = foreign_decls,
hs_defds = default_decls,
hs_ruleds = rule_decls,
......@@ -649,7 +651,8 @@ tcTopSrcDecls boot_details
-- Source-language instances, including derivings,
-- and import the supporting declarations
traceTc (text "Tc3") ;
(tcg_env, inst_infos, deriv_binds) <- tcInstDecls1 tycl_decls inst_decls ;
(tcg_env, inst_infos, deriv_binds)
<- tcInstDecls1 tycl_decls inst_decls deriv_decls;
setGblEnv tcg_env $ do {
-- Foreign import declarations next. No zonking necessary
......
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