[add FreeVars instances for types, create new type hoisting code, lets you select the variables to quantify over when converting haskell types to types
John Meacham <john@repetae.net>**20060214055148] {
hunk ./FrontEnd/KindInfer.hs 35
+import Support.FreeVars
hunk ./FrontEnd/KindInfer.hs 579
-hsTypeToType kt t = return $ aHsTypeToType kt (forallHoist t)
+hsTypeToType kt t = return $ hoistType $ aHsTypeToType kt t -- (forallHoist t)
+
+hsQualTypeToType :: Monad m =>
+    KindEnv            -- ^ the kind environment
+    -> Maybe [HsName]  -- ^ universally quantify free variables excepting those in list.
+    -> HsQualType      -- ^ the type to convert
+    -> m Sigma
+hsQualTypeToType kindEnv qs qualType = return $ hoistType $ tForAll quantOver ( ps' :=> t') where
+   newEnv = kiHsQualType kindEnv qualType
+   Just t' = hsTypeToType newEnv (hsQualTypeType qualType)
+   ps = hsQualTypeHsContext qualType
+   ps' = map (hsAsstToPred newEnv) ps
+   quantOver = nub $ freeVars ps' ++ fvs
+   fvs = case qs of
+       Nothing -> []
+       Just xs -> [ v | v <- freeVars t', nameName (tyvarName v) `notElem` xs]
+
+hoistType :: Type -> Type
+hoistType t = f t where
+    f t@TVar {} = t
+    f t@TCon {} = t
+    f t@TMetaVar {} = t
+    f t@TGen {} = t
+    f (TAp a b) = TAp (f a) (f b)
+    f (TForAll vs (ps :=> t))
+        | (TForAll vs' (ps' :=> t')) <- nt = f $ TForAll (vs ++ vs') ((ps ++ ps') :=> t')
+        | otherwise = TForAll vs (ps :=> nt)
+        where
+        nt = f t
+    f (TExists vs (ps :=> t))
+        | (TExists vs' (ps' :=> t')) <- nt = f $ TExists (vs ++ vs') ((ps ++ ps') :=> t')
+        | otherwise = TExists vs (ps :=> nt)
+        where
+        nt = f t
+    f (TArrow a b)
+        | TForAll vs (ps :=> t) <- nb = f $ TForAll vs (ps :=> TArrow na t)
+        | TExists vs (ps :=> t) <- na = f $ TForAll vs (ps :=> TArrow t nb)
+        | otherwise = TArrow na nb
+        where
+        na = f a
+        nb = f b
+
+
hunk ./FrontEnd/Tc/Class.hs 25
+import Support.CanType
hunk ./FrontEnd/Tc/Class.hs 132
-match' (TVar mv) t | kind mv == kind t = return [(mv,t)]
+match' (TVar mv) t | getType mv == getType t = return [(mv,t)]
hunk ./FrontEnd/Tc/Type.hs 3
-    HasKind(..),
hunk ./FrontEnd/Tc/Type.hs 28
+import Support.FreeVars
hunk ./FrontEnd/Tc/Type.hs 35
-type Box = IORef (Maybe Type)
hunk ./FrontEnd/Tc/Type.hs 42
-type MetaTV = Tyvar
hunk ./FrontEnd/Tc/Type.hs 58
-{-
-openBox :: MonadIO m => Box -> m (Maybe Sigma)
-openBox x = liftIO $ readIORef x
-
-fillBox :: MonadIO m => Box -> Type -> m ()
-fillBox x t  = liftIO $ do
-    t <- flattenType t
-    when (isBoxy t) $ error "filling with boxes"
-    ct <- readIORef x
-    case ct of
-        Just _ -> fail "box is already filled"
-        Nothing -> writeIORef x (Just t)
-fillBox x t = error "attempt to fillBox with boxy type"
--}
-
hunk ./FrontEnd/Tc/Type.hs 94
---extractMetaTV :: Monad m => Type -> m MetaTV
---extractMetaTV (TVar t) | isMetaTV t = return t
---extractMetaTV t = fail $ "not a metaTyVar:" ++ show t
hunk ./FrontEnd/Tc/Type.hs 254
-freeTyVars :: Type -> [Tyvar]
-freeTyVars t = filter (not . isMetaTV) $ allFreeVars t
-
-allFreeVars (TVar u)      = [u]
-allFreeVars (TAp l r)     = allFreeVars l `union` allFreeVars r
-allFreeVars (TArrow l r)  = allFreeVars l `union` allFreeVars r
-allFreeVars TCon {}       = []
-allFreeVars typ | (TForAll vs (_ :=> t)) <- typ = allFreeVars t List.\\ vs
-allFreeVars typ | ~(TExists vs (_ :=> t)) <- typ = allFreeVars t List.\\ vs
-
hunk ./FrontEnd/Tc/Type.hs 260
-freeMetaVars typ | (TForAll vs (_ :=> t)) <- typ = freeMetaVars t
-freeMetaVars typ | ~(TExists vs (_ :=> t)) <- typ = freeMetaVars t
+freeMetaVars (TForAll vs qt) = freeVars qt
+freeMetaVars (TExists vs qt) = freeVars qt
+
+instance FreeVars Type [Tyvar] where
+    freeVars (TVar u)      = [u]
+    freeVars (TAp l r)     = freeVars l `union` freeVars r
+    freeVars (TArrow l r)  = freeVars l `union` freeVars r
+    freeVars TCon {}       = []
+    freeVars TMetaVar {}   = []
+    freeVars (TForAll vs qt) = freeVars qt List.\\ vs
+    freeVars (TExists vs qt) = freeVars qt List.\\ vs
+
+instance FreeVars Type [MetaVar] where
+    freeVars t = freeMetaVars t
+
+instance (FreeVars t b,FreeVars Pred b) => FreeVars (Qual t) b where
+    freeVars (ps :=> t)  = freeVars t `mappend` freeVars ps
hunk ./FrontEnd/Tc/Type.hs 278
+instance FreeVars Type b =>  FreeVars Pred b where
+    freeVars (IsIn _c t)  = freeVars t
hunk ./FrontEnd/Tc/Unify.hs 191
-            tt <- newMetaVar Tau (kind tv1)
+            tt <- newMetaVar Tau (getType tv1)
}
