Commit 4a8695c5 authored by bjorn@bringert.net's avatar bjorn@bringert.net

Merged stand-alone deriving with FC stuff.

parent 9c5aa098
...@@ -456,8 +456,10 @@ topdecl :: { OrdList (LHsDecl RdrName) } ...@@ -456,8 +456,10 @@ 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) = cvBindsAndSigs (unLoc $3) { let (binds, sigs, ats) = cvBindsAndSigs (unLoc $3)
in unitOL (L (comb3 $1 $2 $3) (InstD (InstDecl $2 binds sigs))) } in unitOL (L (comb3 $1 $2 $3)
(InstD (InstDecl $2 binds sigs ats))) }
| stand_alone_deriving { unitOL (LL (DerivD (unLoc $1))) }
| '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 }
......
...@@ -386,7 +386,11 @@ makeDerivEqns overlap_flag tycl_decls deriv_decls ...@@ -386,7 +386,11 @@ makeDerivEqns overlap_flag tycl_decls deriv_decls
mk_eqn_help loc orig gla_exts new_or_data tycon deriv_tvs clas tys mk_eqn_help loc orig gla_exts new_or_data tycon deriv_tvs clas tys
------------------------------------------------------------------ ------------------------------------------------------------------
mk_eqn_help gla_exts DataType tycon deriv_tvs clas tys -- data/newtype T a = ... deriving( C t1 t2 )
-- leads to a call to mk_eqn_help with
-- tycon = T, deriv_tvs = ftv(t1,t2), clas = C, tys = [t1,t2]
mk_eqn_help loc orig gla_exts DataType tycon deriv_tvs clas tys
| Just err <- checkSideConditions gla_exts tycon deriv_tvs clas tys | Just err <- checkSideConditions gla_exts tycon deriv_tvs clas tys
= bale_out (derivingThingErr clas tys tycon (tyConTyVars tycon) err) = bale_out (derivingThingErr clas tys tycon (tyConTyVars tycon) err)
| otherwise | otherwise
......
...@@ -179,16 +179,19 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls ...@@ -179,16 +179,19 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
-- (3) Instances from generic class declarations -- (3) Instances from generic class declarations
; generic_inst_info <- getGenericInstances clas_decls ; generic_inst_info <- getGenericInstances clas_decls
-- (3) Compute instances from "deriving" clauses; -- Next, construct the instance environment so far, consisting
-- This stuff computes a context for the derived instance decl, so it -- of
-- needs to know about all the instances possible; hence inst_env4 -- a) local instance decls
tcDeriving tycl_decls `thenM` \ (deriv_inst_info, deriv_binds) -> -- b) generic instances
addInsts deriv_inst_info $ -- c) local family instance decls
; addInsts local_info $ do {
; addInsts generic_inst_info $ do {
; addFamInsts at_idx_tycon $ do {
-- (4) Compute instances from "deriving" clauses; -- (4) Compute instances from "deriving" clauses;
-- This stuff computes a context for the derived instance -- This stuff computes a context for the derived instance
-- decl, so it needs to know about all the instances possible -- decl, so it needs to know about all the instances possible
; (deriv_inst_info, deriv_binds) <- tcDeriving tycl_decls ; (deriv_inst_info, deriv_binds) <- tcDeriving tycl_decls deriv_decls
; addInsts deriv_inst_info $ do { ; addInsts deriv_inst_info $ do {
; gbl_env <- getGblEnv ; gbl_env <- getGblEnv
......
...@@ -2162,7 +2162,7 @@ tcSimplifyDeriv orig tc tyvars theta ...@@ -2162,7 +2162,7 @@ tcSimplifyDeriv orig tc tyvars theta
-- The main loop may do unification, and that may crash if -- The main loop may do unification, and that may crash if
-- it doesn't see a TcTyVar, so we have to instantiate. Sigh -- it doesn't see a TcTyVar, so we have to instantiate. Sigh
-- ToDo: what if two of them do get unified? -- ToDo: what if two of them do get unified?
newDicts DerivOrigin (substTheta tenv theta) `thenM` \ wanteds -> newDictBndrsO orig (substTheta tenv theta) `thenM` \ wanteds ->
simpleReduceLoop doc reduceMe wanteds `thenM` \ (frees, _, irreds) -> simpleReduceLoop doc reduceMe wanteds `thenM` \ (frees, _, irreds) ->
ASSERT( null frees ) -- reduceMe never returns Free ASSERT( null frees ) -- reduceMe never returns Free
......
...@@ -673,6 +673,7 @@ tcSplitPhiTy ty = split ty ty [] ...@@ -673,6 +673,7 @@ tcSplitPhiTy ty = split ty ty []
| Just p <- tcSplitPredTy_maybe arg = split res res (p:ts) | Just p <- tcSplitPredTy_maybe arg = split res res (p:ts)
split orig_ty ty ts = (reverse ts, orig_ty) split orig_ty ty ts = (reverse ts, orig_ty)
tcSplitSigmaTy :: Type -> ([TyVar], ThetaType, Type)
tcSplitSigmaTy ty = case tcSplitForAllTys ty of tcSplitSigmaTy ty = case tcSplitForAllTys ty of
(tvs, rho) -> case tcSplitPhiTy rho of (tvs, rho) -> case tcSplitPhiTy rho of
(theta, tau) -> (tvs, theta, tau) (theta, tau) -> (tvs, theta, tau)
......
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