Permalink
Browse files

Code cleanup.

  • Loading branch information...
1 parent bbbcc83 commit 58cb494c59ced19995953509dbe0f549a8a2e466 @dreixel dreixel committed Sep 26, 2011
Showing with 33 additions and 46 deletions.
  1. +10 −10 compiler/typecheck/TcDeriv.lhs
  2. +18 −19 compiler/typecheck/TcGenDeriv.lhs
  3. +5 −17 compiler/typecheck/TcInstDcls.lhs
@@ -314,16 +314,16 @@ tcDeriving tycl_decls inst_decls deriv_decls
; overlap_flag <- getOverlapFlag
; let (infer_specs, given_specs) = splitEithers early_specs
- ; insts1 <- flatMapBagM (genInst True overlap_flag) (listToBag given_specs)
- ; let (insts1',_) = partitionBagWith unDerivInst insts1
+ ; deriv1 <- flatMapBagM (genInst True overlap_flag) (listToBag given_specs)
+ ; let (insts,_) = partitionBagWith unDerivInst deriv1
- ; final_specs <- extendLocalInstEnv (map iSpec (bagToList insts1')) $
+ ; final_specs <- extendLocalInstEnv (map iSpec (bagToList insts)) $
inferInstanceContexts overlap_flag infer_specs
- ; insts2 <- flatMapBagM (genInst False overlap_flag) (listToBag final_specs)
+ ; deriv2 <- flatMapBagM (genInst False overlap_flag) (listToBag final_specs)
; (inst_info, rn_binds, rn_dus)
- <- renameDeriv is_boot (insts1 `unionBags` insts2)
+ <- renameDeriv is_boot (deriv1 `unionBags` deriv2)
; dflags <- getDOpts
; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
@@ -333,11 +333,11 @@ tcDeriving tycl_decls inst_decls deriv_decls
dumpDerivingInfo (ddump_deriving inst_info rn_binds)
-}
- ; let f (DerivGenMetaTyCons x) = Left (Right x)
- f (DerivGenRepTyCon x) = Left (Left x)
- f x = Right x
-
- (genBinds, _) = partitionBagWith f (insts1 `unionBags` insts2)
+ ; let unGenBinds (DerivGenMetaTyCons x) = Left (Right x)
+ unGenBinds (DerivGenRepTyCon x) = Left (Left x)
+ unGenBinds x = Right x
+ -- JPM: All this partitioning should perhaps be refactored
+ (genBinds, _) = partitionBagWith unGenBinds (deriv1 `unionBags` deriv2)
(repTyConsB, repMetaTysB) = partitionBagWith id genBinds
(repTyCons, repMetaTys) = (bagToList repTyConsB, bagToList repMetaTysB)
all_tycons = map ATyCon (repTyCons ++ concat (map metaTyCons2TyCons repMetaTys))
@@ -95,7 +95,6 @@ isDupAux (DerivTag2Con tc1) (DerivTag2Con tc2) = tc1 == tc2
isDupAux (DerivMaxTag tc1) (DerivMaxTag tc2) = tc1 == tc2
isDupAux (DerivDataCon dc1) (DerivDataCon dc2) = dc1 == dc2
isDupAux (DerivTyCon tc1) (DerivTyCon tc2) = tc1 == tc2
--- isDupAux (DerivGenRepTyCon tc1) (DerivGenRepTyCon tc2) = tc1 == tc2
-- We are certain we do not introduce duplicates for the other cases
isDupAux _ _ = False
@@ -177,7 +176,7 @@ instance ... Eq (Foo ...) where
\begin{code}
-gen_Eq_binds :: SrcSpan -> TyCon -> BagDerivStuff --(LHsBinds RdrName, DerivAuxBinds)
+gen_Eq_binds :: SrcSpan -> TyCon -> BagDerivStuff
gen_Eq_binds loc tycon
= method_binds `unionBags` aux_binds
where
@@ -335,7 +334,7 @@ gtResult OrdGE = true_Expr
gtResult OrdGT = true_Expr
------------
-gen_Ord_binds :: SrcSpan -> TyCon -> BagDerivStuff --(LHsBinds RdrName, DerivAuxBinds)
+gen_Ord_binds :: SrcSpan -> TyCon -> BagDerivStuff
gen_Ord_binds loc tycon
| null tycon_data_cons -- No data-cons => invoke bale-out case
= unitBag $ DerivHsBind $ mk_FunBind loc compare_RDR []
@@ -564,7 +563,7 @@ instance ... Enum (Foo ...) where
For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
\begin{code}
-gen_Enum_binds :: SrcSpan -> TyCon -> BagDerivStuff --(LHsBinds RdrName, DerivAuxBinds)
+gen_Enum_binds :: SrcSpan -> TyCon -> BagDerivStuff
gen_Enum_binds loc tycon
= method_binds `unionBags` aux_binds
where
@@ -643,7 +642,7 @@ gen_Enum_binds loc tycon
%************************************************************************
\begin{code}
-gen_Bounded_binds :: SrcSpan -> TyCon -> BagDerivStuff --(LHsBinds RdrName, DerivAuxBinds)
+gen_Bounded_binds :: SrcSpan -> TyCon -> BagDerivStuff
gen_Bounded_binds loc tycon
| isEnumerationTyCon tycon
= listToBag (map DerivHsBind [min_bound_enum, max_bound_enum])
@@ -730,7 +729,7 @@ we follow the scheme given in Figure~19 of the Haskell~1.2 report
(p.~147).
\begin{code}
-gen_Ix_binds :: SrcSpan -> TyCon -> BagDerivStuff --(LHsBinds RdrName, DerivAuxBinds)
+gen_Ix_binds :: SrcSpan -> TyCon -> BagDerivStuff
gen_Ix_binds loc tycon
| isEnumerationTyCon tycon
@@ -890,7 +889,7 @@ instance Read T where
\begin{code}
-gen_Read_binds :: FixityEnv -> SrcSpan -> TyCon -> BagDerivStuff --(LHsBinds RdrName, DerivAuxBinds)
+gen_Read_binds :: FixityEnv -> SrcSpan -> TyCon -> BagDerivStuff
gen_Read_binds get_fixity loc tycon
= listToBag (map DerivHsBind [read_prec, default_readlist, default_readlistprec])
@@ -1059,7 +1058,7 @@ Example
-- the most tightly-binding operator
\begin{code}
-gen_Show_binds :: FixityEnv -> SrcSpan -> TyCon -> BagDerivStuff --(LHsBinds RdrName, DerivAuxBinds)
+gen_Show_binds :: FixityEnv -> SrcSpan -> TyCon -> BagDerivStuff
gen_Show_binds get_fixity loc tycon
= listToBag (map DerivHsBind [shows_prec, show_list])
@@ -1431,7 +1430,7 @@ This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case:
$(cofmap 'a '(b -> c)) x = \b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b))
\begin{code}
-gen_Functor_binds :: SrcSpan -> TyCon -> BagDerivStuff --(LHsBinds RdrName, DerivAuxBinds)
+gen_Functor_binds :: SrcSpan -> TyCon -> BagDerivStuff
gen_Functor_binds loc tycon
= unitBag fmap_bind
where
@@ -1602,7 +1601,7 @@ Note that the arguments to the real foldr function are the wrong way around,
since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
\begin{code}
-gen_Foldable_binds :: SrcSpan -> TyCon -> BagDerivStuff --(LHsBinds RdrName, DerivAuxBinds)
+gen_Foldable_binds :: SrcSpan -> TyCon -> BagDerivStuff
gen_Foldable_binds loc tycon
= unitBag foldr_bind
where
@@ -1654,7 +1653,7 @@ gives the function: traverse f (T x y) = T <$> pure x <*> f y
instead of: traverse f (T x y) = T x <$> f y
\begin{code}
-gen_Traversable_binds :: SrcSpan -> TyCon -> BagDerivStuff --(LHsBinds RdrName, DerivAuxBinds)
+gen_Traversable_binds :: SrcSpan -> TyCon -> BagDerivStuff
gen_Traversable_binds loc tycon
= unitBag traverse_bind
where
@@ -1787,18 +1786,18 @@ genAuxBind loc (DerivDataCon dc) -- $cT1 etc
fixity | is_infix = infix_RDR
| otherwise = prefix_RDR
-genAuxBind _ _ = error "JPM: TODO"
+-- We know we do not call genAuxBind with the generics stuff
+genAuxBind _ _ = panic "genAuxBind"
genAuxBinds :: Monad m => SrcSpan -> BagDerivStuff -> m ( Bag (LHsBind RdrName)
, Bag (LSig RdrName))
genAuxBinds loc bs = mapAndUnzipBagM (return . genAuxBind loc) auxBinds where
- f x@(DerivGenMetaTyCons _) = Left x
- f x@(DerivGenRepTyCon _) = Left x
- f x@(DerivInst _) = Left x
- f x@(DerivHsBind _) = Left x
- f x = Right x
-
- (_, auxBinds) = partitionBagWith f bs
+ partf x@(DerivGenMetaTyCons _) = Left x
+ partf x@(DerivGenRepTyCon _) = Left x
+ partf x@(DerivInst _) = Left x
+ partf x@(DerivHsBind _) = Left x
+ partf x = Right x
+ (_, auxBinds) = partitionBagWith partf bs
mk_data_type_name :: TyCon -> RdrName -- "$tT"
mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
@@ -398,34 +398,22 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
failIfErrsM -- If the addInsts stuff gave any errors, don't
-- try the deriving stuff, because that may give
-- more errors still
-{-
- ; (deriv_inst_info, deriv_binds, deriv_dus, deriv_tys, deriv_ty_insts)
- <- tcDeriving tycl_decls inst_decls deriv_decls
--}
+
; (gbl_env, deriv_inst_info, deriv_binds)
<- tcDeriving tycl_decls inst_decls deriv_decls
- -- Extend the global environment also with the generated datatypes for
- -- the generic representation
-{-
- ; let all_tycons = map ATyCon (deriv_tys ++ deriv_ty_insts)
- ; gbl_env <- tcExtendGlobalEnv all_tycons $
- tcExtendGlobalEnvImplicit (concatMap implicitTyThings all_tycons) $
- addFamInsts deriv_ty_insts $
- addInsts deriv_inst_info getGblEnv
--}
-- Check that if the module is compiled with -XSafe, there are no
-- hand written instances of Typeable as then unsafe casts could be
- -- performed. Derivied instances are OK.
+ -- performed. Derived instances are OK.
; dflags <- getDOpts
; when (safeLanguageOn dflags) $
mapM_ (\x -> when (is_cls (iSpec x) `elem` typeableClassNames)
(addErrAt (getSrcSpan $ iSpec x) typInstErr))
local_info
- ; return ( gbl_env,
- (bagToList deriv_inst_info) ++ local_info,
- aux_binds `plusHsValBinds` deriv_binds)
+ ; return ( gbl_env
+ , (bagToList deriv_inst_info) ++ local_info
+ , aux_binds `plusHsValBinds` deriv_binds)
}}}
where
typInstErr = ptext $ sLit $ "Can't create hand written instances of Typeable in Safe"

0 comments on commit 58cb494

Please sign in to comment.