[clean up code dealing with classes
John Meacham <john@repetae.net>**20061107025228] hunk ./FrontEnd/Class.hs 14
-    --makeInstanceEnvironment,
-    stdClasses,
hunk ./FrontEnd/Class.hs 16
-    Inst(..),
-    numClasses
+    Inst(..)
hunk ./FrontEnd/Class.hs 23
-import List((\\), partition)
+import Data.List((\\),partition,nub)
hunk ./FrontEnd/Class.hs 57
+    instSrcLoc :: SrcLoc,
+    instDerived :: Bool,   -- ^ whether this instance was derived
hunk ./FrontEnd/Class.hs 69
-emptyInstance = Inst { instHead = error "emptyInstance", instAssocs = [] }
+emptyInstance = Inst { instSrcLoc = bogusASrcLoc, instHead = error "emptyInstance", instAssocs = [] }
+
+-- | a class record is either a class along with instances, or just instances.
+-- you can tell the difference by the presence of the classArgs field
hunk ./FrontEnd/Class.hs 81
-    classAssocs :: [(Tycon,[Tyvar],Maybe Sigma)],
-    classDerives :: [Inst]
+    classAssocs :: [(Tycon,[Tyvar],Maybe Sigma)]
hunk ./FrontEnd/Class.hs 92
-    classAssocs = [],
-    classDerives = []
+    classAssocs = []
hunk ./FrontEnd/Class.hs 102
-    classDerives = snub $ classDerives cra ++ classDerives crb,
hunk ./FrontEnd/Class.hs 114
-        ans = [ ((tyconName tc,tyconName ca),(is,rs,e)) | (tc,is,rs,e) <- as]
-        (TCon ca,_) = fromTAp tt
+        ans = [ ((tyconName tc,getTypeHead tt),(is,rs,e)) | (tc,is,rs,e) <- as]
hunk ./FrontEnd/Class.hs 117
+getTypeHead th = case fromTAp th of
+    (TCon c,_) -> tyconName c
+    _ -> error $ "getTypeHead: " ++ show th
hunk ./FrontEnd/Class.hs 121
-{-
-makeInstanceEnvironment :: ClassHierarchy -> [Qual Pred]
-makeInstanceEnvironment (ClassHierarchy ch) = concatMap f (Map.elems ch) where
-    f cr@ClassRecord { classSupers = supers, className = cname } = concatMap (g cr) (classInsts cr) ++ [ [IsIn cname var] :=> IsIn s var | s <- supers ] where
-        var = let [v] = classArgs cr in TVar v
-    g cr Inst { instHead = ih@(_ :=> (IsIn _cname what)), instAssocs = as } | _cname == className cr = ans where
-        ans = ih:[ [] :=> IsEq (foldl TAp (TAp (TCon tc) what) (map TVar rs)) e | (tc,rs,e) <- as]
--}
-
-
---([Class], [Inst], [Assump])
-
hunk ./FrontEnd/Class.hs 128
+classRecords :: ClassHierarchy -> [ClassRecord]
hunk ./FrontEnd/Class.hs 143
-
-
-toHsQualType qt = qt
-
hunk ./FrontEnd/Class.hs 188
---    pb (n,Star) = pprint n
---    pb (n,k) = parens (pprint n <+> text "::" <+> pprint k)
-
hunk ./FrontEnd/Class.hs 200
-addOneInstanceToHierarchy :: ClassHierarchy -> (Bool,Inst) -> ClassHierarchy
-addOneInstanceToHierarchy ch (x,inst@Inst { instHead = cntxt :=> IsIn className _ }) = modifyClassRecord f className ch where
-    f c
-        | x = c { classInsts = inst:classInsts c, classDerives = inst:classDerives c }
-        | otherwise = c { classInsts = inst:classInsts c  }
+addOneInstanceToHierarchy :: ClassHierarchy -> Inst -> ClassHierarchy
+addOneInstanceToHierarchy ch inst@Inst { instHead = cntxt :=> IsIn className _ } = modifyClassRecord f className ch where
+    f c = c { classInsts = inst:classInsts c }
hunk ./FrontEnd/Class.hs 205
-hsInstDeclToInst :: Monad m => KindEnv -> (HsDecl) -> m [(Bool,Inst)]
+hsInstDeclToInst :: Monad m => KindEnv -> HsDecl -> m [Inst]
hunk ./FrontEnd/Class.hs 208
-        = return [(False,emptyInstance { instHead = cntxt :=> IsIn className convertedArgType, instAssocs = assocs })]
+        = return [emptyInstance { instDerived = False, instHead = cntxt :=> IsIn className convertedArgType, instAssocs = assocs }]
hunk ./FrontEnd/Class.hs 218
+hsInstDeclToInst _ _ = return []
hunk ./FrontEnd/Class.hs 221
+{-
hunk ./FrontEnd/Class.hs 253
-hsInstDeclToInst _ _ = return []
+-}
hunk ./FrontEnd/Class.hs 275
-makeDerivation kt ch name args cs ds = ([],[])
-makeDerivation kt ch name args cs ds = ([],concatMap f ds) where
-    f n
-        | n == class_Enum = [cia $  v_toEnum, cia $ v_fromEnum]
-        | n == class_Bounded = [cia  ( v_minBound), cia $  v_maxBound]
-        | otherwise = error "cannot derive"
-        where
-        cia = createInstanceAssump kt methodSigs [] n arg
-        methodSigs = asksClassRecord ch n classAssumps
-    arg = foldr HsTyApp (HsTyCon name) (map HsTyVar args)
-
hunk ./FrontEnd/Class.hs 299
-    = unzip $ map (methodToTopDecls kt cacntxt crecord methodSigs qualType) $ methodGroups where
+    = unzip $ map (methodToTopDecls kt [] crecord qualType) $ methodGroups where
hunk ./FrontEnd/Class.hs 301
-    cacntxt = []
-    --cacntxt = [ IsEq (TAp (TCon tcon) th) (tsubst na cvar v) | (tcon,[na],~(Just v)) <- createClassAssocs kt methods]
-    (_,(className,[th@(~(TAp _ cvar))])) = qtToClassHead kt qualType
+    (_,(className,_)) = qtToClassHead kt qualType
hunk ./FrontEnd/Class.hs 305
-    methodSigs = classAssumps crecord
hunk ./FrontEnd/Class.hs 307
-instanceToTopDecls kt classHierarchy decl@HsDataDecl {} =
-     (makeDerivation kt classHierarchy (hsDeclName decl) (hsDeclArgs decl) (hsDeclCons decl)) (map (toName ClassName) $ hsDeclDerives decl)
-instanceToTopDecls kt classHierarchy decl@HsNewTypeDecl {} =
-    (makeDerivation kt classHierarchy (hsDeclName decl) (hsDeclArgs decl) [(hsDeclCon decl)]) (map (toName ClassName) $ hsDeclDerives decl)
hunk ./FrontEnd/Class.hs 328
-createInstanceAssump :: KindEnv -> [Assump] -> HsContext -> Class -> HsType -> Name -> Assump
-createInstanceAssump kt methodSigs cntxt className argType methodName
-   = (newMethodName,instantiatedSig) where
-    newMethodName = instanceName methodName (getHsTypeCons argType)
-    [sigFromClass] = [ s | (n,s) <- methodSigs, n == methodName]
-    instantiatedSig = newMethodSig' kt methodName (map (hsAsstToPred kt) cntxt) sigFromClass argType
hunk ./FrontEnd/Class.hs 329
-methodToTopDecls :: KindEnv -> [Pred] -> ClassRecord -> [Assump] -> HsQualType -> (Name, HsDecl) -> (HsDecl,Assump)
+methodToTopDecls ::
+    KindEnv            -- ^ the kindenv
+    -> [Pred]          -- ^ random extra predicates to add
+    -> ClassRecord     -- ^ the class we are lifting methods from
+    -> HsQualType
+    -> (Name, HsDecl)
+    -> (HsDecl,Assump)
hunk ./FrontEnd/Class.hs 337
-methodToTopDecls kt preds crecord methodSigs qt@(HsQualType cntxt classApp) (methodName, methodDecls)
+methodToTopDecls kt preds crecord qt (methodName, methodDecls)
hunk ./FrontEnd/Class.hs 339
-    (HsTyApp (HsTyCon className) argType) = classApp
---    (cntxt,(className,[argType])) = qtToClassHead qt
-    newMethodName = instanceName methodName (getHsTypeCons argType)
-    sigFromClass = case [ s | (n, s) <- methodSigs, n == methodName] of
+    (cntxt,(className,[argType])) = qtToClassHead kt qt
+    newMethodName = instanceName methodName (getTypeHead argType)
+    sigFromClass = case [ s | (n, s) <- classAssumps crecord, n == methodName] of
hunk ./FrontEnd/Class.hs 343
-        _ -> error $ "sigFromClass: " ++ pprint methodSigs ++ " " ++ show  methodName
-    instantiatedSig = newMethodSig' kt methodName (preds ++ map (hsAsstToPred kt) cntxt) sigFromClass argType
+        _ -> error $ "sigFromClass: " ++ pprint (classAssumps crecord) ++ " " ++ show  methodName
+    instantiatedSig = newMethodSig' kt methodName (preds ++ cntxt) sigFromClass argType
hunk ./FrontEnd/Class.hs 373
-newMethodSig' :: KindEnv -> Name -> [Pred] -> Sigma -> HsType -> Sigma
+newMethodSig' :: KindEnv -> Name -> [Pred] -> Sigma -> Type -> Sigma
hunk ./FrontEnd/Class.hs 381
-   foo = "_" ++ (show methodName ++ show (getHsTypeCons instanceType)) ++ "@@"
-   newQualType = everywhere (mkT at) $ tForAll (freeVars qt) qt
+   foo = "_" ++ (show methodName ++ show (getTypeHead instanceType)) ++ "@@"
+   newQualType = everywhere (mkT at) $ tForAll (nub $ freeVars qt) qt
hunk ./FrontEnd/Class.hs 387
-   ct n | n == classArg =  runIdentity $ hsTypeToType kt instanceType
+   ct n | n == classArg = instanceType
hunk ./FrontEnd/Class.hs 411
-            tell [ClassRecord { classArgs = classArgs, classAssocs = classAssocs, className = toName ClassName className, classSrcLoc = sl, classSupers = [ toName ClassName x | HsAsst x _ <- cntxt], classInsts = [ emptyInstance { instHead = i } | i@(_ :=> IsIn n _) <- primitiveInsts, nameName n == className], classDerives = [], classAssumps = qualifiedMethodAssumps }]
+            tell [ClassRecord { classArgs = classArgs, classAssocs = classAssocs, className = toName ClassName className, classSrcLoc = sl, classSupers = [ toName ClassName x | HsAsst x _ <- cntxt], classInsts = [ emptyInstance { instHead = i } | i@(_ :=> IsIn n _) <- primitiveInsts, nameName n == className], classAssumps = qualifiedMethodAssumps }]
hunk ./FrontEnd/Class.hs 414
-        HsQualType cntxt tbody = toHsQualType t
+        HsQualType cntxt tbody = t
hunk ./FrontEnd/Class.hs 419
-        crs <- flip mapM [ (cn,i) | (_,i@Inst { instHead = _ :=> IsIn cn _}) <- insts] $ \ (x,inst) -> case Map.lookup x ch of
+        crs <- flip mapM [ (cn,i) | i@Inst { instHead = _ :=> IsIn cn _} <- insts] $ \ (x,inst) -> case Map.lookup x ch of
hunk ./FrontEnd/Class.hs 474
-derivableClasses,numClasses,stdClasses ::  [Name]
-
-stdClasses = [
-    class_Eq,
-    class_Ord,
-    class_Enum,
-    class_Bounded,
-    class_Show,
-    class_Read,
-    class_Ix,
-    class_Functor,
-    class_Monad,
-    class_Num ,
-    class_Real,
-    class_Integral,
-    class_Fractional,
-    class_Floating,
-    class_RealFrac,
-    class_RealFloat
-    ]
-
-numClasses = [
-    class_Num ,
-    class_Real,
-    class_Integral,
-    class_Fractional,
-    class_Floating,
-    class_RealFrac,
-    class_RealFloat
-    ]
-
+derivableClasses ::  [Name]
hunk ./FrontEnd/Representation.hs 268
-    y@(Star `Kfun` Star) -> newName (map (('f':) . show) [0 :: Int ..]) y t
+    y@(Star `Kfun` Star) -> newLookupName (map (('f':) . show) [0 :: Int ..]) y t
hunk ./FrontEnd/Representation.hs 285
-        --ts' <- mapM (newLookupName ['a'..] ()) vs
-        --ts' <- mapM newTyvarName vs
hunk ./FrontEnd/Representation.hs 294
-        --ts' <- mapM (newLookupName ['a'..] ()) vs
-        --ts' <- mapM newTyvarName vs
hunk ./FrontEnd/Tc/Class.hs 28
+import Name.Name
hunk ./FrontEnd/Tc/Class.hs 236
+numClasses,stdClasses :: [Name]
+
+stdClasses = [
+    class_Eq,
+    class_Ord,
+    class_Enum,
+    class_Bounded,
+    class_Show,
+    class_Read,
+    class_Ix,
+    class_Functor,
+    class_Monad,
+    class_Num ,
+    class_Real,
+    class_Integral,
+    class_Fractional,
+    class_Floating,
+    class_RealFrac,
+    class_RealFloat
+    ]
+
+numClasses = [
+    class_Num ,
+    class_Real,
+    class_Integral,
+    class_Fractional,
+    class_Floating,
+    class_RealFrac,
+    class_RealFloat
+    ]
+