[remove old Class checking code, move instance declarations to a distinct type from qualified predicates, rename Class FrontEnd.Class
John Meacham <john@repetae.net>**20061017034944] addfile ./FrontEnd/Tc/Class.hs-boot
hunk ./DataConstructors.hs 36
-import Class(instanceName)
+import FrontEnd.Class(instanceName)
hunk ./E/FromHs.hs 28
-import Class
+import FrontEnd.Class
hunk ./E/FromHs.hs 237
-        as = [ rule  t | (_ :=> IsIn _ t ) <- snub (classInsts classRecord) ]
+        as = [ rule  t | Inst { instHead = _ :=> IsIn _ t }  <- snub (classInsts classRecord) ]
hunk ./E/FromHs.hs 265
-        as = concatMap cinst [ t | (_ :=> IsIn _ t ) <- classInsts classRecord]
+        as = concatMap cinst [ t | Inst { instHead = _ :=> IsIn _ t } <- classInsts classRecord]
hunk ./E/Program.hs 8
-import Class
+import FrontEnd.Class
hunk ./FrontEnd/Class.hs 32
-module Class(
+module FrontEnd.Class(
hunk ./FrontEnd/Class.hs 37
-    entails,
hunk ./FrontEnd/Class.hs 39
-    reduce,
-    split,
hunk ./FrontEnd/Class.hs 47
-    splitReduce,
-    toHnfs,
-    topDefaults,
hunk ./FrontEnd/Class.hs 49
-    simplify,
+    Inst(..),
hunk ./FrontEnd/Class.hs 58
-import qualified Data.Map as Map
hunk ./FrontEnd/Class.hs 59
+import qualified Data.Map as Map
hunk ./FrontEnd/Class.hs 65
+import FrontEnd.Tc.Type
hunk ./FrontEnd/Class.hs 76
-import qualified FlagOpts as FO
+import PrimitiveOperators(primitiveInsts)
hunk ./FrontEnd/Class.hs 81
-import PrimitiveOperators(primitiveInsts)
-import FrontEnd.Tc.Type
+import qualified FlagOpts as FO
hunk ./FrontEnd/Class.hs 85
--- Instance
-type Inst  = Qual Pred
hunk ./FrontEnd/Class.hs 87
-bySuper :: ClassHierarchy -> Pred -> [Pred]
-bySuper h p@(IsIn c t)
- = p : concat (map (bySuper h) supers)
-   where supers = [ IsIn c' t | c' <- supersOf h c ]
-
-byInst             :: Monad m => Pred -> Inst -> m [Pred]
-byInst p (ps :=> h) = do u <- matchPred h p
-                         return (map (apply u) ps)
-
-matchPred :: Monad m => Pred -> Pred -> m Subst
-matchPred x@(IsIn c t) y@(IsIn c' t')
-      | c == c'   = match t t'
-      | otherwise = fail $ "Classes do not match: " ++ show (x,y)
-
-reducePred :: Monad m => ClassHierarchy -> Pred -> m [Pred]
-reducePred h p@(IsIn c t)
-    | Just x <- foldr mplus Nothing poss = return x
-    | otherwise = fail "reducePred"
- where poss = map (byInst p) (instsOf h c)
-
------------------------------------------------------------------------------
-
-entails :: ClassHierarchy -> [Pred] -> Pred -> Bool
-entails h ps p = any (p `elem`) (map (bySuper h) ps) ||
-           case reducePred h p of
-             Nothing -> False
-             Just qs -> all (entails h ps) qs
-
------------------------------------------------------------------------------
-
--- the new class hierarchy
hunk ./FrontEnd/Class.hs 88
+newtype Inst = Inst {
+    instHead :: Qual Pred
+    } deriving(Typeable,Data,Eq,Ord,PPrint Doc,Show)
+    {-! derive: GhcBinary !-}
hunk ./FrontEnd/Class.hs 93
--- classname (superclasses, instances, properly qualified type-sigs of methods)
+emptyInstance = Inst { instHead = error "emptyInstance" }
hunk ./FrontEnd/Class.hs 142
-supersOf :: ClassHierarchy -> Class -> [Class]
-supersOf ch c = asksClassRecord ch c classSupers
-
-instsOf :: ClassHierarchy -> Class -> [Inst]
-instsOf ch c = asksClassRecord ch c classInsts
-
-
hunk ./FrontEnd/Class.hs 149
---makeDeriveInstances :: [Pred] -> Type -> [Class] -> [Inst]
---makeDeriveInstances context t [] = []
---makeDeriveInstances context t (c:cs)
---   | c `elem` derivableClasses
---        = (context :=> IsIn c t) : makeDeriveInstances context t cs
---   | otherwise
---        = error $ "makeDeriveInstances: attempt to make type " ++ pretty t ++
---                  "\nan instance of a non-derivable class " ++ show c
-
-{-
-toHsName (x,y) = Qual (Module x) (HsIdent y)
-instance ClassNames HsName where
-    classEq = toHsName classEq
-    classOrd = toHsName classOrd
-    classEnum = toHsName classEnum
-    classBounded = toHsName classBounded
-    classShow = toHsName classShow
-    classRead = toHsName classRead
-    classIx = toHsName classIx
-    classFunctor = toHsName classFunctor
-    classMonad = toHsName classMonad
-    classNum = toHsName classNum
-    classReal = toHsName classReal
-    classIntegral = toHsName classIntegral
-    classFractional = toHsName classFractional
-    classFloating = toHsName classFloating
-    classRealFrac = toHsName classRealFrac
-    classRealFloat = toHsName classRealFloat
--}
-
hunk ./FrontEnd/Class.hs 246
-addOneInstanceToHierarchy ch (x,inst@(cntxt :=> IsIn className _)) = modifyClassRecord f className ch where
+addOneInstanceToHierarchy ch (x,inst@Inst { instHead = cntxt :=> IsIn className _ }) = modifyClassRecord f className ch where
hunk ./FrontEnd/Class.hs 286
-        = return [(False,cntxt :=> IsIn className convertedArgType)]
+        = return [(False,emptyInstance { instHead = cntxt :=> IsIn className convertedArgType })]
hunk ./FrontEnd/Class.hs 564
-splitReduce :: OptionMonad m => ClassHierarchy -> [Tyvar] -> [Tyvar] -> [Pred] -> m ([Pred], [Pred], [(Tyvar,Type)])
-
-splitReduce h fs gs ps = do
-    (ds, rs) <- split h fs ps
-    (rs',sub) <- genDefaults h (fs++gs) rs
-    return (ds,rs',sub)
-
--- context reduction
--- This is the 'split' from THIH
-
-
-reduce :: OptionMonad m => ClassHierarchy -> [Tyvar] -> [Tyvar] -> [Pred] -> m ([Pred], [Pred])
-
-reduce h fs gs ps = do
-    (ds, rs) <- split h fs ps
-    rs' <-   useDefaults h (fs++gs) rs
-    return (ds,rs')
-
---------------------------------------------------------------------------------
-
--- context splitting
--- This is equivalant to a 'reduce' then a 'partition' in THIH
-
-split       :: Monad m => ClassHierarchy -> [Tyvar] -> [Pred] -> m ([Pred], [Pred])
-split h fs ps  = do
-    ps' <- (toHnfs h ps)
-    return $ partition (all (`elem` fs) . tv) $ simplify h  $ ps'
-
-toHnfs      :: Monad m => ClassHierarchy -> [Pred] -> m [Pred]
-toHnfs h ps =  mapM (toHnf h) ps >>= return . concat
-
-toHnf :: Monad m => ClassHierarchy -> Pred -> m [Pred]
-toHnf h p
-    | inHnf p = return [p]
-    | otherwise =  case reducePred h p of
-         Nothing -> fail $ "context reduction, no instance for: "  ++ render (pprint  p)
-         Just ps -> toHnfs h ps
-
-inHnf       :: Pred -> Bool
-inHnf (IsIn c t) = hnf t
- where hnf (TVar v)  = True
-       hnf (TCon tc) = False
-       hnf (TAp t _) = hnf t
-       hnf (TArrow _t1 _t2) = False
-       hnf TForAll {} = False
-
---simplify          :: ClassHierarchy -> [Pred] -> [Pred] -> [Pred]
---simplify h rs []     = rs
---simplify h rs (p:ps) = simplify h (p:(rs\\qs)) (ps\\qs)
--- where qs       = bySuper h p
---       rs \\ qs = [ r | r<-rs, r `notElem` qs ]
-
-simplify :: ClassHierarchy -> [Pred] -> [Pred]
-simplify h ps = loop [] ps where
-    loop rs []     = rs
-    loop rs (p:ps)
-        | entails h (rs ++ ps) p = loop rs ps
-        | otherwise = loop (p:rs) ps
---     where qs       = bySuper h p
---           rs \\ qs = [ r | r<-rs, r `notElem` qs ]
------------------------------------------------------------------------------
-
--- defaulting ambiguous constraints
-
-
--- ambiguities from THIH + call to candidates
-ambig :: ClassHierarchy -> [Tyvar] -> [Pred] -> [(Tyvar,[Pred],[Type])]
-
-ambig h vs ps
-  = [ (v, qs, defs h v qs) |
-         v <- tv ps \\ vs,
-         let qs = [ p | p<-ps, v `elem` tv p ] ]
-
--- 'candidates' from THIH
-defs     :: ClassHierarchy -> Tyvar -> [Pred] -> [Type]
-defs h v qs = [ t | all ((TVar v)==) ts,
-                  all (`elem` stdClasses) cs, -- XXX needs fixing
-                  any (`elem` numClasses) cs, -- XXX needs fixing
-                  -- False, -- XXX
-                  t <- defaults, -- XXX needs fixing
-                  and [ entails h [] (IsIn c t) | c <- cs ]]
- where cs = [ c | (IsIn c t) <- qs ]
-       ts = [ t | (IsIn c t) <- qs ]
-
-withDefaults     :: Monad m => ClassHierarchy ->  [Tyvar] -> [Pred] -> m [(Tyvar, [Pred], Type)]
-withDefaults h vs ps
-  | any null tss = fail $ "withDefaults.ambiguity: " ++ (render $ pprint ps) ++ show vs ++ show ps
---  | otherwise = fail $ "Zambiguity: " ++ (render $ pprint ps) ++  show (ps,ps',ams)
-  | otherwise    = return $ [ (v,qs,head ts) | (v,qs,ts) <- ams ]
-    where ams = ambig h vs ps
-          tss = [ ts | (v,qs,ts) <- ams ]
-
--- Return retained predicates and a defaulting substitution
-genDefaults :: Monad m => ClassHierarchy ->  [Tyvar] -> [Pred] -> m ([Pred],[(Tyvar,Type)])
-genDefaults h vs ps = do
-    ams <- withDefaults h vs ps
-    let ps' = [ p | (v,qs,ts) <- ams, p<-qs ]
-        vs  = [ (v,t)  | (v,qs,t) <- ams ]
-    return (ps \\ ps',  vs)
-
-useDefaults     :: OptionMonad m => ClassHierarchy -> [Tyvar] -> [Pred] -> m [Pred]
-useDefaults h vs ps = flagOpt FO.Defaulting >>= \b -> case b of
- --   False -> return ps
-    _
-      | any null tss -> fail $ "useDefaults.ambiguity: " ++ (render $ pprint ps) ++  show ps
-      | otherwise -> fail $ "Zambiguity: " ++ (render $ pprint ps) ++  show (ps,ps',ams)
---      | otherwise    = return $ ps \\ ps'
-        where ams = ambig h vs ps
-              tss = [ ts | (v,qs,ts) <- ams ]
-              ps' = [ p | (v,qs,ts) <- ams, p<-qs ]
-
-topDefaults     :: OptionMonad m => ClassHierarchy -> [Pred] -> m Subst
-topDefaults h ps  =  flagOpt FO.Defaulting >>= \b -> case b of
---    False -> return mempty
-    _
-      | any null tss -> fail $ " ambiguity " ++ (render $ pprint ps)
-      | otherwise    -> return $ Map.fromList (zip vs (map head tss))
-        where ams = ambig h [] ps
-              tss = [ ts | (v,qs,ts) <- ams ]
-              vs  = [ v  | (v,qs,ts) <- ams ]
-
-defaults    :: [Type]
-defaults
-    | not $ fopts FO.Defaulting = []
-    | otherwise = map (\name -> TCon (Tycon name Star)) [tc_Integer, tc_Double]
-
-
hunk ./FrontEnd/Class.hs 577
-            tell [ClassRecord { className = toName ClassName className, classSrcLoc = sl, classSupers = map fst $ hsContextToContext cntxt, classInsts = [ i | i@(_ :=> IsIn n _) <- primitiveInsts, nameName n == className], classDerives = [], classAssumps = qualifiedMethodAssumps }]
+            tell [ClassRecord { className = toName ClassName className, classSrcLoc = sl, classSupers = map fst $ hsContextToContext cntxt, classInsts = [ emptyInstance { instHead = i } | i@(_ :=> IsIn n _) <- primitiveInsts, nameName n == className], classDerives = [], classAssumps = qualifiedMethodAssumps }]
hunk ./FrontEnd/Class.hs 583
-        crs <- flip mapM [ (cn,i) | (_,i@(_ :=> 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/HsErrors.hs 7
-import Class
+import FrontEnd.Class
hunk ./FrontEnd/Tc/Class.hs 13
-
hunk ./FrontEnd/Tc/Class.hs 29
-import Class hiding(split,simplify,toHnfs,entails,splitReduce,topDefaults)
+import FrontEnd.Class
hunk ./FrontEnd/Tc/Class.hs 36
-type Inst = Qual Pred
hunk ./FrontEnd/Tc/Class.hs 108
-byInst p (ps :=> h) = do u <- matchPred h p
-                         return (map (inst mempty (Map.fromList [ (tyvarAtom mv,t) | (mv,t) <- u ])) ps)
+byInst p Inst { instHead = ps :=> h } = do
+    u <- matchPred h p
+    return (map (inst mempty (Map.fromList [ (tyvarAtom mv,t) | (mv,t) <- u ])) ps)
hunk ./FrontEnd/Tc/Class.hs-boot 1
+module FrontEnd.Tc.Class(simplify,FrontEnd.Class.ClassHierarchy) where
+
+import FrontEnd.Class
+import Representation
+
+
+simplify :: ClassHierarchy -> [Pred] -> [Pred]
hunk ./FrontEnd/Tc/Main.hs 11
-import Class(ClassHierarchy)
hunk ./FrontEnd/Tc/Module.hs 13
-import Class
+import FrontEnd.Class
hunk ./FrontEnd/Tc/Monad.hs 61
-import Class(ClassHierarchy,simplify)
+import {-# SOURCE #-} FrontEnd.Tc.Class(ClassHierarchy,simplify)
hunk ./FrontEnd/Tc/Monad.hs 370
-    return $ TForAll nvs (Class.simplify ch ps :=> r)
+    return $ TForAll nvs (FrontEnd.Tc.Class.simplify ch ps :=> r)
hunk ./Ho/Build.hs 29
-import Class
+import FrontEnd.Class
hunk ./Ho/Type.hs 6
-import Class(ClassHierarchy)
+import FrontEnd.Class(ClassHierarchy)
hunk ./Interactive.hs 33
-import Class
+import FrontEnd.Class
hunk ./Interactive.hs 236
-    let ps = Class.simplify (hoClassHierarchy ho) ps'
+    let ps = FrontEnd.Tc.Class.simplify (hoClassHierarchy ho) ps'
hunk ./Main.hs 20
-import Class
+import FrontEnd.Class
hunk ./Makefile 8
-GHCINC=  -iFrontEnd
+GHCINC=  -i. -iFrontEnd