Merge branch 'no-pred-ty'
authorMax Bolingbroke <batterseapower@hotmail.com>
Fri, 9 Sep 2011 12:45:41 +0000 (13:45 +0100)
committerMax Bolingbroke <batterseapower@hotmail.com>
Fri, 9 Sep 2011 13:11:00 +0000 (14:11 +0100)
Conflicts:
compiler/iface/BuildTyCl.lhs
compiler/iface/MkIface.lhs
compiler/iface/TcIface.lhs
compiler/typecheck/TcTyClsDecls.lhs
compiler/types/Class.lhs
compiler/utils/Util.lhs

22 files changed:
1  2 
compiler/basicTypes/OccName.lhs
compiler/deSugar/DsMeta.hs
compiler/hsSyn/Convert.lhs
compiler/iface/BinIface.hs
compiler/iface/BuildTyCl.lhs
compiler/iface/IfaceSyn.lhs
compiler/iface/MkIface.lhs
compiler/iface/TcIface.lhs
compiler/parser/Parser.y.pp
compiler/parser/RdrHsSyn.lhs
compiler/rename/RnSource.lhs
compiler/simplCore/Simplify.lhs
compiler/specialise/SpecConstr.lhs
compiler/typecheck/TcClassDcl.lhs
compiler/typecheck/TcEnv.lhs
compiler/typecheck/TcInstDcls.lhs
compiler/typecheck/TcMType.lhs
compiler/typecheck/TcRnDriver.lhs
compiler/typecheck/TcTyClsDecls.lhs
compiler/types/Class.lhs
compiler/utils/Util.lhs
docs/users_guide/glasgow_exts.xml

@@@ -51,10 -51,10 +51,10 @@@ module OccName 
        mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkGenDefMethodOcc,
        mkDerivedTyConOcc, mkNewTyCoOcc, mkClassOpAuxOcc,
          mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
-       mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, 
+       mkClassDataConOcc, mkDictOcc, mkIPOcc, 
        mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
        mkGenD, mkGenR, mkGenRCo, mkGenC, mkGenS,
 -      mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc,
 +        mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc,
        mkSuperDictSelOcc, mkLocalOcc, mkMethodOcc, mkInstTyTcOcc,
        mkInstTyCoOcc, mkEqPredCoOcc,
          mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc,
Simple merge
Simple merge
Simple merge
@@@ -236,10 -236,9 +236,9 @@@ buildClass :: Bool                -- True <=> do not 
           -> RecFlag                      -- Info for type constructor
           -> TcRnIf m n Class
  
- buildClass no_unf class_name tvs sc_theta fds at_items sig_stuff tc_isrec
 -buildClass no_unf tycon_name tvs sc_theta fds ats sig_stuff tc_isrec
++buildClass no_unf tycon_name tvs sc_theta fds at_items sig_stuff tc_isrec
    = do        { traceIf (text "buildClass")
-       ; tycon_name <- newImplicitBinder class_name mkClassTyConOcc
-       ; datacon_name <- newImplicitBinder class_name mkClassDataConOcc
+       ; datacon_name <- newImplicitBinder tycon_name mkClassDataConOcc
                -- The class name is the 'parent' for this datacon, not its tycon,
                -- because one should import the class to get the binding for 
                -- the datacon
                -- [If we don't make it a recursive newtype, we'll expand the
                -- newtype like a synonym, but that will lead to an infinite
                -- type]
 -            ; atTyCons = [tycon | ATyCon tycon <- ats]
  
-             ; result = mkClass class_name tvs fds 
+             ; result = mkClass tvs fds 
 -                               sc_theta sc_sel_ids atTyCons
 +                               sc_theta sc_sel_ids at_items
                                 op_items tycon
              }
        ; traceIf (text "buildClass" <+> ppr tycon) 
@@@ -85,10 -85,10 +86,10 @@@ data IfaceDec
      }
  
    | IfaceClass { ifCtxt    :: IfaceContext,     -- Context...
-                  ifName    :: OccName,          -- Name of the class
+                  ifName    :: OccName,          -- Name of the class TyCon
                   ifTyVars  :: [IfaceTvBndr],    -- Type variables
                   ifFDs     :: [FunDep FastString], -- Functional dependencies
 -                 ifATs     :: [IfaceDecl],      -- Associated type families
 +                 ifATs     :: [IfaceAT],      -- Associated type families
                   ifSigs    :: [IfaceClassOp],   -- Method signatures
                   ifRec     :: RecFlag           -- Is newtype/datatype associated
                                                  --   with the class recursive?
@@@ -394,9 -382,9 +393,9 @@@ ifaceDeclSubBndrs (IfaceClass {ifCtxt 
      --    no wrapper (class dictionaries never have a wrapper)
      [dc_occ, dcww_occ] ++
      -- associated types
 -    [ifName at | at <- ats ] ++
 +    [ifName at | IfaceAT at _ <- ats ] ++
      -- superclass selectors
-     [mkSuperDictSelOcc n cls_occ | n <- [1..n_ctxt]] ++
+     [mkSuperDictSelOcc n cls_tc_occ | n <- [1..n_ctxt]] ++
      -- operation selectors
      [op | IfaceClassOp op  _ _ <- sigs]
    where
@@@ -737,17 -722,10 +739,17 @@@ freeNamesIfTcFam Nothing 
    emptyNameSet
  
  freeNamesIfContext :: IfaceContext -> NameSet
- freeNamesIfContext = fnList freeNamesIfPredType
+ freeNamesIfContext = fnList freeNamesIfType
  
 -freeNamesIfDecls :: [IfaceDecl] -> NameSet
 -freeNamesIfDecls = fnList freeNamesIfDecl
 +freeNamesIfAT :: IfaceAT -> NameSet
 +freeNamesIfAT (IfaceAT decl defs)
 +  = freeNamesIfDecl decl &&&
 +    fnList fn_at_def defs
 +  where
 +    fn_at_def (IfaceATD tvs pat_tys ty)
 +      = freeNamesIfTvBndrs tvs &&&
 +        fnList freeNamesIfType pat_tys &&&
 +        freeNamesIfType ty
  
  freeNamesIfClsSig :: IfaceClassOp -> NameSet
  freeNamesIfClsSig (IfaceClassOp _n _dm ty) = freeNamesIfType ty
@@@ -1433,6 -1396,39 +1397,47 @@@ tyThingToIfaceDecl (ADataCon dc
   = pprPanic "toIfaceDecl" (ppr dc)    -- Should be trimmed out earlier
  
  
 -                 ifATs    = map (tyThingToIfaceDecl . ATyCon) clas_ats,
+ classToIfaceDecl :: Class -> IfaceDecl
+ classToIfaceDecl clas
+   = IfaceClass { ifCtxt   = toIfaceContext sc_theta,
+                  ifName   = getOccName (classTyCon clas),
+                  ifTyVars = toIfaceTvBndrs clas_tyvars,
+                  ifFDs    = map toIfaceFD clas_fds,
++                 ifATs    = map toIfaceAT clas_ats,
+                  ifSigs   = map toIfaceClassOp op_stuff,
+                  ifRec    = boolToRecFlag (isRecursiveTyCon tycon) }
+   where
+     (clas_tyvars, clas_fds, sc_theta, _, clas_ats, op_stuff) 
+       = classExtraBigSig clas
+     tycon = classTyCon clas
++    toIfaceAT :: ClassATItem -> IfaceAT
++    toIfaceAT (tc, defs)
++      = IfaceAT (tyThingToIfaceDecl (ATyCon tc))
++                (map to_if_at_def defs)
++      where
++        to_if_at_def (ATD tvs pat_tys ty)
++          = IfaceATD (toIfaceTvBndrs tvs) (map toIfaceType pat_tys) (toIfaceType ty)
++
+     toIfaceClassOp (sel_id, def_meth)
+         = ASSERT(sel_tyvars == clas_tyvars)
+           IfaceClassOp (getOccName sel_id) (toDmSpec def_meth) (toIfaceType op_ty)
+         where
+                 -- Be careful when splitting the type, because of things
+                 -- like         class Foo a where
+                 --                op :: (?x :: String) => a -> a
+                 -- and          class Baz a where
+                 --                op :: (Ord a) => a -> a
+           (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
+           op_ty                = funResultTy rho_ty
+     toDmSpec NoDefMeth      = NoDM
+     toDmSpec (GenDefMeth _) = GenericDM
+     toDmSpec (DefMeth _)    = VanillaDM
+     toIfaceFD (tvs1, tvs2) = (map getFS tvs1, map getFS tvs2)
  getFS :: NamedThing a => a -> FastString
  getFS x = occNameFS (getOccName x)
  
@@@ -479,9 -480,9 +480,9 @@@ tc_iface_decl _parent ignore_prag
      ; sigs <- mapM tc_sig rdr_sigs
      ; fds  <- mapM tc_fd rdr_fds
      ; cls  <- fixM $ \ cls -> do
 -              { ats  <- mapM (tc_iface_decl (AssocFamilyTyCon cls) ignore_prags) rdr_ats
 +              { ats  <- mapM (tc_at cls) rdr_ats
-               ; buildClass ignore_prags cls_name tyvars ctxt fds ats sigs tc_isrec }
-     ; return (AClass cls) }
+               ; buildClass ignore_prags tc_name tyvars ctxt fds ats sigs tc_isrec }
+     ; return (ATyCon (classTyCon cls)) }
    where
     tc_sig (IfaceClassOp occ dm rdr_ty)
       = do { op_name <- lookupIfaceTop occ
Simple merge
@@@ -566,18 -557,16 +558,17 @@@ checkKindSigs :: [LTyClDecl RdrName] -
  checkKindSigs = mapM_ check
    where
      check (L l tydecl) 
 -      | isFamilyDecl tydecl  = return ()
 +      | isFamilyDecl tydecl
 +        || isTypeDecl tydecl = return ()
        | otherwise          = 
 -      parseErrorSDoc l (text "Type declaration in a class must be a kind signature:" $$ ppr tydecl)
 +      parseErrorSDoc l (text "Type declaration in a class must be a kind signature or synonym default:" $$ ppr tydecl)
  
  checkContext :: LHsType RdrName -> P (LHsContext RdrName)
- checkContext (L l t)
-   = check t
+ checkContext (L l orig_t)
+   = check orig_t
   where
    check (HsTupleTy _ ts)      -- (Eq a, Ord b) shows up as a tuple type
-     = do ctx <- mapM checkPred ts
-        return (L l ctx)
+     = return (L l ts)
  
    check (HsParTy ty)  -- to be sure HsParTy doesn't get into the way
      = check (unLoc ty)
Simple merge
Simple merge
Simple merge
Simple merge
Simple merge
Simple merge
Simple merge
@@@ -712,21 -724,11 +724,21 @@@ checkBootTyCon tc1 tc
             eqTypeX env op_ty1 op_ty2 &&
             def_meth1 == def_meth2
           where
-         (_, rho_ty1) = splitForAllTys (idType id1)
-         op_ty1 = funResultTy rho_ty1
-         (_, rho_ty2) = splitForAllTys (idType id2)
+           (_, rho_ty1) = splitForAllTys (idType id1)
+           op_ty1 = funResultTy rho_ty1
+           (_, rho_ty2) = splitForAllTys (idType id2)
            op_ty2 = funResultTy rho_ty2
  
 +       eqAT (tc1, def_ats1) (tc2, def_ats2)
 +         = checkBootTyCon tc1 tc2 &&
 +           eqListBy eqATDef def_ats1 def_ats2
 +
 +       eqATDef (ATD tvs1 ty_pats1 ty1) (ATD tvs2 ty_pats2 ty2)
 +         = eqListBy same_kind tvs1 tvs2 &&
 +           eqListBy (eqTypeX env) ty_pats1 ty_pats2 &&
 +           eqTypeX env ty1 ty2
 +         where env = rnBndrs2 env0 tvs1 tvs2
 +
         eqFD (as1,bs1) (as2,bs2) = 
           eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) &&
           eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2)
          ||   -- Above tests for an "abstract" class
          eqListBy (eqPredX env) sc_theta1 sc_theta2 &&
          eqListBy eqSig op_stuff1 op_stuff2 &&
 -        eqListBy checkBootTyCon ats1 ats2)
 +        eqListBy eqAT ats1 ats2) 
  
- checkBootDecl (ADataCon dc1) (ADataCon _)
-   = pprPanic "checkBootDecl" (ppr dc1)
- checkBootDecl _ _ = False -- probably shouldn't happen
- ----------------
- checkBootTyCon :: TyCon -> TyCon -> Bool
- checkBootTyCon tc1 tc2
-   | not (eqKind (tyConKind tc1) (tyConKind tc2))
-   = False     -- First off, check the kind
    | isSynTyCon tc1 && isSynTyCon tc2
    = ASSERT(tc1 == tc2)
      let tvs1 = tyConTyVars tc1; tvs2 = tyConTyVars tc2
@@@ -515,29 -506,21 +514,27 @@@ tcTyClDecl1 _parent calc_isre
      h98_syntax = consUseH98Syntax cons
  
  tcTyClDecl1 _parent calc_isrec 
-   (ClassDecl {tcdLName = L _ class_name, tcdTyVars = tvs, 
+   (ClassDecl {tcdLName = L _ class_tycon_name, tcdTyVars = tvs, 
              tcdCtxt = ctxt, tcdMeths = meths,
 -            tcdFDs = fundeps, tcdSigs = sigs, tcdATs = ats} )
 +            tcdFDs = fundeps, tcdSigs = sigs, tcdATs = ats, tcdATDefs = at_defs} )
    = ASSERT( isNoParent _parent )
      tcTyVarBndrs tvs          $ \ tvs' -> do 
    { ctxt' <- tcHsKindedContext ctxt
    ; fds' <- mapM (addLocM tc_fundep) fundeps
-   ; (sig_stuff, gen_dm_env) <- tcClassSigs class_name sigs meths
+   ; (sig_stuff, gen_dm_env) <- tcClassSigs class_tycon_name sigs meths
    ; clas <- fixM $ \ clas -> do
 -          { let tc_isrec = calc_isrec class_tycon_name
 -          ; atss' <- mapM (addLocM $ tcTyClDecl1 (AssocFamilyTyCon clas) (const Recursive)) ats
 -            -- NB: 'ats' only contains "type family" and "data family"
 -            --     declarations as well as type family defaults
 +          { let       -- This little knot is just so we can get
 +                      -- hold of the name of the class TyCon, which we
 +                      -- need to look up its recursiveness
 +                  tycon_name = tyConName (classTyCon clas)
 +                  tc_isrec = calc_isrec tycon_name
-             ; traceTc "tcTyClDecl1:before ATs" (ppr class_name)
++            
 +            ; at_stuff <- tcClassATs clas tvs' ats at_defs
 +            -- NB: 'ats' only contains "type family" and "data family" declarations
 +            -- and 'at_defs' only contains associated-type defaults
-             ; traceTc "tcTyClDecl1:before build class" (ppr class_name)
++            
              ; buildClass False {- Must include unfoldings for selectors -}
-                        class_name tvs' ctxt' fds' at_stuff
 -                       class_tycon_name tvs' ctxt' fds' (concat atss')
++                       class_tycon_name tvs' ctxt' fds' at_stuff
                         sig_stuff tc_isrec }
  
    ; let gen_dm_ids = [ AnId (mkExportedLocalId gen_dm_name gen_dm_ty)
@@@ -23,8 -22,8 +23,8 @@@ module Class 
  #include "Typeable.h"
  #include "HsVersions.h"
  
- import {-# SOURCE #-} TyCon   ( TyCon )
+ import {-# SOURCE #-} TyCon   ( TyCon, tyConName, tyConUnique )
 -import {-# SOURCE #-} TypeRep ( PredType )
 +import {-# SOURCE #-} TypeRep ( Type, PredType )
  
  import Var
  import Name
@@@ -63,13 -66,10 +67,10 @@@ data Clas
                                        --   superclasses from a 
                                        --   dictionary of this class
        -- Associated types
 -        classATs     :: [TyCon],      -- Associated type families
 +        classATStuff :: [ClassATItem],        -- Associated type families
  
          -- Class operations (methods, not superclasses)
-       classOpStuff :: [ClassOpItem],  -- Ordered by tag
-       classTyCon :: TyCon             -- The data type constructor for
-                                       -- dictionaries of this class
+       classOpStuff :: [ClassOpItem]   -- Ordered by tag
       }
    deriving Typeable
  
@@@ -110,18 -99,18 +111,18 @@@ defMethSpecOfDefMeth met
  The @mkClass@ function fills in the indirect superclasses.
  
  \begin{code}
- mkClass :: Name -> [TyVar]
+ mkClass :: [TyVar]
        -> [([TyVar], [TyVar])]
        -> [PredType] -> [Id]
 -      -> [TyCon]
 +      -> [ClassATItem]
        -> [ClassOpItem]
        -> TyCon
        -> Class
  
- mkClass name tyvars fds super_classes superdict_sels at_stuff
 -mkClass tyvars fds super_classes superdict_sels ats 
++mkClass tyvars fds super_classes superdict_sels at_stuff
        op_stuff tycon
-   = Class {   classKey     = getUnique name
-               className    = name,
+   = Class {   classKey     = tyConUnique tycon
+               className    = tyConName tycon,
                classTyVars  = tyvars,
                classFunDeps = fds,
                classSCTheta = super_classes,
@@@ -239,5 -222,4 +240,4 @@@ instance Data.Data Class wher
      toConstr _   = abstractConstr "Class"
      gunfold _ _  = error "gunfold"
      dataTypeOf _ = mkNoRepType "Class"
 -\end{code}
 +\end{code}
@@@ -32,7 -32,7 +32,8 @@@ module Util 
  
          -- * Tuples
          fstOf3, sndOf3, thirdOf3,
+         firstM, first3M,
 +        uncurry3,
  
          -- * List operations controlled by another list
          takeList, dropList, splitAtList, split,
@@@ -209,11 -209,16 +210,19 @@@ thirdOf3 :: (a,b,c) -> 
  fstOf3      (a,_,_) =  a
  sndOf3      (_,b,_) =  b
  thirdOf3    (_,_,c) =  c
 +
 +uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
 +uncurry3 f (a, b, c) = f a b c
  \end{code}
  
+ \begin{code}
+ firstM :: Monad m => (a -> m c) -> (a, b) -> m (c, b)
+ firstM f (x, y) = liftM (\x' -> (x', y)) (f x)
+ first3M :: Monad m => (a -> m d) -> (a, b, c) -> m (d, b, c)
+ first3M f (x, y, z) = liftM (\x' -> (x', y, z)) (f x)
+ \end{code}
  %************************************************************************
  %*                                                                      *
  \subsection[Utils-lists]{General list processing}
Simple merge