Remove a duplicate module import in BuildTyCl

[ghc-hetmet.git] / compiler / iface / BuildTyCl.lhs

diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs
index 534bc5f..8459edf 100644 (file)
--- a/compiler/iface/BuildTyCl.lhs
+++ b/compiler/iface/BuildTyCl.lhs
@@ -4,13 +4,6 @@
 %
 
 \begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
 module BuildTyCl (
        buildSynTyCon, buildAlgTyCon, buildDataCon,
        buildClass,
@@ -21,12 +14,10 @@ module BuildTyCl (
 #include "HsVersions.h"
 
 import IfaceEnv
-import TcRnMonad
 
 import DataCon
 import Var
 import VarSet
-import TysWiredIn
 import BasicTypes
 import Name
 import OccName
@@ -37,6 +28,7 @@ import Type
 import Coercion
 
 import TcRnMonad
+import Util            ( count )
 import Outputable
 
 import Data.List
@@ -210,13 +202,14 @@ buildDataCon src_name declared_infix arg_stricts field_lbls
                                     stupid_ctxt dc_ids
                dc_ids = mkDataConIds wrap_name work_name data_con
 
-       ; returnM data_con }
+       ; return data_con }
 
 
 -- The stupid context for a data constructor should be limited to
 -- the type variables mentioned in the arg_tys
 -- ToDo: Or functionally dependent on?  
 --      This whole stupid theta thing is, well, stupid.
+mkDataConStupidTheta :: TyCon -> [Type] -> [TyVar] -> [PredType]
 mkDataConStupidTheta tycon arg_tys univ_tvs
   | null stupid_theta = []     -- The common case
   | otherwise        = filter in_arg_tys stupid_theta
@@ -242,14 +235,17 @@ mkTyConSelIds tycon rhs
 
 ------------------------------------------------------
 \begin{code}
-buildClass :: Name -> [TyVar] -> ThetaType
+buildClass :: Bool                     -- True <=> do not include unfoldings 
+                                       --          on dict selectors
+                                       -- Used when importing a class without -O
+          -> Name -> [TyVar] -> ThetaType
           -> [FunDep TyVar]            -- Functional dependencies
           -> [TyThing]                 -- Associated types
           -> [(Name, DefMeth, Type)]   -- Method info
           -> RecFlag                   -- Info for type constructor
           -> TcRnIf m n Class
 
-buildClass class_name tvs sc_theta fds ats sig_stuff tc_isrec
+buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec
   = do { traceIf (text "buildClass")
        ; tycon_name <- newImplicitBinder class_name mkClassTyConOcc
        ; datacon_name <- newImplicitBinder class_name mkClassDataConOcc
@@ -261,7 +257,7 @@ buildClass class_name tvs sc_theta fds ats sig_stuff tc_isrec
 
          let { rec_tycon  = classTyCon rec_clas
              ; op_tys     = [ty | (_,_,ty) <- sig_stuff]
-             ; op_items   = [ (mkDictSelId op_name rec_clas, dm_info)
+             ; op_items   = [ (mkDictSelId no_unf op_name rec_clas, dm_info)
                             | (op_name, dm_info, _) <- sig_stuff ] }
                        -- Build the selector id and default method id
 
@@ -274,22 +270,31 @@ buildClass class_name tvs sc_theta fds ats sig_stuff tc_isrec
                                    op_tys
                                   rec_tycon
 
-       ; sc_sel_names <- mapM (newImplicitBinder class_name . mkSuperDictSelOcc) 
-                               [1..length (dataConDictTheta dict_con)]
+       ; let n_value_preds   = count (not . isEqPred) sc_theta
+             all_value_preds = n_value_preds == length sc_theta
+             -- We only make selectors for the *value* superclasses, 
+             -- not equality predicates 
+
+       ; sc_sel_names <- mapM  (newImplicitBinder class_name . mkSuperDictSelOcc) 
+                               [1..n_value_preds]
+        ; let sc_sel_ids = [mkDictSelId no_unf sc_name rec_clas | sc_name <- sc_sel_names]
              -- We number off the Dict superclass selectors, 1, 2, 3 etc so that we 
-             -- can construct names for the selectors.  Thus
+             -- can construct names for the selectors. Thus
              --      class (C a, C b) => D a b where ...
              -- gives superclass selectors
              --      D_sc1, D_sc2
              -- (We used to call them D_C, but now we can have two different
              --  superclasses both called C!)
-        ; let sc_sel_ids = [mkDictSelId sc_name rec_clas | sc_name <- sc_sel_names]
-
-               -- Use a newtype if the class constructor has exactly one field:
+             --
+       
+       ; let use_newtype = (n_value_preds + length sig_stuff == 1) && all_value_preds
+               -- Use a newtype if the data constructor has 
+               --      (a) exactly one value field
+               --      (b) no existential or equality-predicate fields
                -- i.e. exactly one operation or superclass taken together
-               -- Watch out: the sc_theta includes equality predicates,
-               --            which don't count for this purpose; hence dataConDictTheta
-       ; rhs <- if ((length $ dataConDictTheta dict_con) + length sig_stuff) == 1
+               -- See note [Class newtypes and equality predicates]
+
+       ; rhs <- if use_newtype
                 then mkNewTyConRhs tycon_name rec_tycon dict_con
                 else return (mkDataTyConRhs [dict_con])
 
@@ -316,4 +321,19 @@ buildClass class_name tvs sc_theta fds ats sig_stuff tc_isrec
        })}
 \end{code}
 
+Note [Class newtypes and equality predicates]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+       class (a ~ F b) => C a b where
+         op :: a -> b
+
+We cannot represent this by a newtype, even though it's not
+existential, and there's only one value field, because we do
+capture an equality predicate:
+
+       data C a b where
+         MkC :: forall a b. (a ~ F b) => (a->b) -> C a b
+
+We need to access this equality predicate when we get passes a C
+dictionary.  See Trac #2238