[type check classes properly on implicit and explicit signatures. apply defaulting rules
John Meacham <john@repetae.net>**20060213154950] addfile ./FrontEnd/Tc/Class.hs
hunk ./FrontEnd/Class.hs 51
+    toHnfs,
hunk ./FrontEnd/Class.hs 93
-listToFM = Map.fromList
-
hunk ./FrontEnd/Class.hs 109
-    | Just x <- foldr (|||) Nothing poss = return x
+    | Just x <- foldr mplus Nothing poss = return x
hunk ./FrontEnd/Class.hs 112
-       Nothing ||| y = y
-       Just x  ||| y = Just x
hunk ./FrontEnd/Class.hs 295
-{-
-genClassHierarchy :: [(HsDecl)] -> ClassHierarchy
-genClassHierarchy classes
-   = foldl (flip addClassToHierarchy) stdClassHierarchy classes
-   where
-   -- stdClassHierarchy = classListToHierarchy stdClasses
-   stdClassHierarchy = listToFM preludeClasses
--}
hunk ./FrontEnd/Class.hs 649
---       hnf (TTuple _args) = False
hunk ./FrontEnd/Class.hs 720
-      | otherwise    -> return $ listToFM (zip vs (map head tss))
+      | otherwise    -> return $ Map.fromList (zip vs (map head tss))
hunk ./FrontEnd/Representation.hs 102
+    (TMetaVar a) == (TMetaVar b) = a == b
hunk ./FrontEnd/Tc/Class.hs 1
+module FrontEnd.Tc.Class(
+    Pred,
+    ClassHierarchy(),
+    splitPreds,
+    generalize,
+    splitReduce,
+    freeMetaVarsPreds,
+    simplify,
+    assertEntailment,
+    Preds
+
+    )where
+
+import Control.Monad.Trans
+import Data.Monoid
+import List
+import Monad
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import Representation(Class)
+
+import Name.Names
+import Options
+import qualified FlagOpts as FO
+import Class hiding(split,simplify,toHnfs,entails,splitReduce)
+import FrontEnd.Tc.Type
+import FrontEnd.Tc.Monad
+import Doc.PPrint
+
+
+type Inst = Qual Pred
+
+generalize :: [Pred] -> Rho -> Tc Sigma
+generalize ps r = do
+    ch <- getClassHierarchy
+    r <- flattenType r
+    fmvenv <- freeMetaVarsEnv
+    let mvs =  [ v  | v <- freeMetaVars r, not $ v `Set.member` fmvenv ]
+    --(nps,rp) <- splitPreds ch (Set.toList fmvenv) ps
+    (nps,rp) <- splitReduce (Set.toList fmvenv) mvs (simplify ch ps)
+    addPreds nps
+    quantify mvs rp r
+
+freeMetaVarsPreds :: Preds -> [MetaVar]
+freeMetaVarsPreds ps = concat [ freeMetaVars t | IsIn _ t <- ps ]
+
+freeMetaVarsPred :: Pred -> [MetaVar]
+freeMetaVarsPred (IsIn _ t) = freeMetaVars t
+
+-- | split predicates into ones that only mention metavars in the list vs other ones
+splitPreds :: Monad m => ClassHierarchy -> [MetaVar] -> Preds -> m (Preds, Preds)
+splitPreds h fs ps  = do
+    ps' <- toHnfs h ps
+    return $ partition (all (`elem` fs) . freeMetaVarsPred) $ 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: "  ++ (pprint  p)
+         Just ps -> toHnfs h ps
+
+inHnf       :: Pred -> Bool
+inHnf (IsIn c t) = hnf t
+ where hnf (TVar v)  = True
+       hnf TMetaVar {} = True
+       hnf (TCon tc) = False
+       hnf (TAp t _) = hnf t
+       hnf (TArrow _t1 _t2) = False
+       hnf TForAll {} = False
+       hnf TExists {} = False
+       hnf TGen {} = False
+
+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)
+
+
+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
+
+
+-- | returns true when set of predicates implies some other predicate is satisfied.
+entails :: ClassHierarchy -> [Pred] -> Pred -> Bool
+entails h ps p = (p `elem` concatMap (bySuper h) ps) ||
+           case reducePred h p of
+             Nothing -> False
+             Just qs -> all (entails h ps) qs
+
+bySuper :: ClassHierarchy -> Pred -> [Pred]
+bySuper h p@(IsIn c t)
+ = p : concatMap (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 (inst mempty (Map.fromList [ (tyvarAtom mv,t) | (mv,t) <- u ])) ps)
+
+matchPred :: Monad m => Pred -> Pred -> m [(Tyvar,Type)]
+matchPred x@(IsIn c t) y@(IsIn c' t')
+      | c == c'   = match t t'
+      | otherwise = fail $ "Classes do not match: " ++ show (x,y)
+
+supersOf :: ClassHierarchy -> Class -> [Class]
+supersOf ch c = asksClassRecord ch c classSupers
+instsOf :: ClassHierarchy -> Class -> [Inst]
+instsOf ch c = asksClassRecord ch c classInsts
+
+
+match :: Monad m => Type -> Type -> m [(Tyvar,Type)]
+match x y = do match' x y
+match' (TAp l r) (TAp l' r') = do
+    sl <- match l l'
+    sr <- match r r'
+    return $ mappend sl sr
+match' (TArrow l r) (TArrow l' r') = do
+    sl <- match l l'
+    sr <- match r r'
+    return $ mappend sl sr
+match' (TVar u) (TVar t) | u == t = return mempty
+match' (TVar mv) t | kind mv == kind t = return [(mv,t)]
+--match' (TMetaVar mv) t | kind mv == kind t = return [(mv,t)]
+match' (TCon tc1) (TCon tc2) | tc1==tc2 = return mempty
+match' t1 t2  = fail $ "match: " ++ show (t1,t2)
+
+
+splitReduce :: [MetaVar] -> [MetaVar] -> [Pred] -> Tc ([Pred], [Pred])
+splitReduce fs gs ps = do
+    h <- getClassHierarchy
+    --liftIO $ putStrLn $ pprint (fs,gs,ps) 
+    (ds, rs) <- splitPreds h fs ps
+    (rs',sub) <- genDefaults h (fs++gs) rs
+    sequence_ [ varBind x y | (x,y) <- sub]
+    return (ds,rs')
+
+withDefaults     :: Monad m => ClassHierarchy ->  [MetaVar] -> [Pred] -> m [(MetaVar, [Pred], Type)]
+withDefaults h vs ps
+  | any null tss = fail $ "withDefaults.ambiguity: " ++ (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 ->  [MetaVar] -> [Pred] -> m ([Pred],[(MetaVar,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)
+
+-- ambiguities from THIH + call to candidates
+ambig :: ClassHierarchy -> [MetaVar] -> [Pred] -> [(MetaVar,[Pred],[Type])]
+
+ambig h vs ps
+  = [ (v, qs, defs h v qs) |
+         v <- freeMetaVarsPreds ps \\ vs,
+         let qs = [ p | p<-ps, v `elem` freeMetaVarsPred p ] ]
+
+
+assertEntailment :: Preds -> Preds -> Tc ()
+assertEntailment qs ps = do
+    ch <- getClassHierarchy
+    let ns = [ p  | p <- ps, not $ entails ch qs p ] 
+    if null ns then return () else
+        fail $ "Signature too Weak: " ++ pprint ns
+{-
+
+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')
+-}
+
+-- 'candidates' from THIH
+defs     :: ClassHierarchy -> MetaVar -> [Pred] -> [Type]
+defs h v qs = [ t | all ((TMetaVar v)==) ts,
+                  all (`elem` stdClasses) cs, -- XXX needs fixing
+                  any (`elem` numClasses) cs, -- XXX needs fixing
+                  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 ]
+
+
+defaults    :: [Type]
+defaults
+    | not $ fopts FO.Defaulting = []
+    | otherwise = map (\name -> TCon (Tycon name Star)) [tc_Integer, tc_Double]
+
hunk ./FrontEnd/Tc/Main.hs 7
+import qualified Data.Set as Set
hunk ./FrontEnd/Tc/Main.hs 9
-import Class(ClassHierarchy, entails, split, topDefaults, splitReduce,simplify)
+import Class(ClassHierarchy)
hunk ./FrontEnd/Tc/Main.hs 21
+import FrontEnd.Tc.Class
hunk ./FrontEnd/Tc/Main.hs 58
-    (_,t) <- skolomize t
+    (_,_,t) <- skolomize t
hunk ./FrontEnd/Tc/Main.hs 167
-            (_,s) <- skolomize s
+            (_,_,s) <- skolomize s
hunk ./FrontEnd/Tc/Main.hs 385
-    ps <- mapM flattenType ps
-    ch <- getClassHierarchy
-    ps <- return $ Class.simplify ch ps
+    ps <- flattenType ps
+    --ch <- getClassHierarchy
+    --ps <- return $ Class.simplify ch ps
hunk ./FrontEnd/Tc/Main.hs 486
-            (_,s) <- skolomize s
+            (_,_,s) <- skolomize s
hunk ./FrontEnd/Tc/Main.hs 501
-    --tcDecl decl sc
-    --sc <- freshSigma sc
-    (_,typ) <- skolomize sc
-    tcDecl decl typ
+    (_,qs,typ) <- skolomize sc
+    (ret,ps) <- censor (const mempty) $ listen (tcDecl decl typ)
+    ps <- flattenType ps
+    ch <- getClassHierarchy
+    env <- freeMetaVarsEnv
+    (ds,rs) <- splitReduce (Set.toList env) (freeMetaVarsPreds qs) ps
+    --liftIO $ putStrLn $ pprint ds
+    --addPreds ds
+    assertEntailment qs (rs ++ ds)
+    return ret
hunk ./FrontEnd/Tc/Main.hs 751
-        ps <- return $ Class.simplify ch ps
+        ps <- return $ simplify ch ps
hunk ./FrontEnd/Tc/Monad.hs 10
-    generalize,
hunk ./FrontEnd/Tc/Monad.hs 28
+    inst,
hunk ./FrontEnd/Tc/Monad.hs 30
+    freeMetaVarsEnv,
hunk ./FrontEnd/Tc/Monad.hs 37
-import Control.Monad.Trans
hunk ./FrontEnd/Tc/Monad.hs 53
-import Support.CanType
hunk ./FrontEnd/Tc/Monad.hs 59
+import Support.CanType
hunk ./FrontEnd/Tc/Monad.hs 264
-skolomize :: Sigma' -> Tc ([SkolemTV],Rho')
-skolomize (TForAll vs (_ :=> rho)) = return (vs,rho)
+skolomize :: Sigma' -> Tc ([SkolemTV],Preds,Rho')
+skolomize (TForAll vs (ps :=> rho)) = return (vs,ps,rho)
hunk ./FrontEnd/Tc/Monad.hs 269
-skolomize s = return ([],s)
+skolomize s = return ([],[],s)
hunk ./FrontEnd/Tc/Monad.hs 293
-generalize :: [Pred] -> Rho -> Tc Sigma
-generalize ps r = do
-    ch <- getClassHierarchy
-    r <- flattenType r
-    fmvenv <- freeMetaVarsEnv
-    -- liftIO $ mapM_ (putStrLn . pprint) (Set.toList fmvenv)
-    let mvs =  [ v  | v <- freeMetaVars r, not $ v `Set.member` fmvenv ]
-    let (rp,nps) = partition (\ (IsIn c t) -> any (`elem` mvs) (freeMetaVars t)) ps
-    addPreds nps
-    quantify mvs rp r
+
hunk ./FrontEnd/Tc/Type.hs 15
+    Preds(),
hunk ./FrontEnd/Tc/Type.hs 47
+type Preds = [Pred]
+
hunk ./FrontEnd/Tc/Type.hs 183
+instance DocLike d => PPrint d Pred where
+    pprint (IsIn c t) = text (show c) <+> prettyPrintType t
+
hunk ./FrontEnd/Tc/Unify.hs 41
-        (_,r2) <- skolomize fa
+        (_,_,r2) <- skolomize fa
hunk ./Interactive.hs 30
+import FrontEnd.Tc.Class