[Fix kind inference + test
Samuel Bronson <naesten@gmail.com>**20090107225726
 Also, comment out the case in kindOf that makes things look fine when
 they aren't -- unless of course * isn't the right kind
] addfile ./regress/tests/2_language/KindInference.expected.stdout
addfile ./regress/tests/2_language/KindInference.hs
hunk ./regress/tests/2_language/KindInference.hs 1
+class Arrow a where
+    arr :: (b -> c) -> a b c
+    (>>>) :: a b c -> a c d -> a b d
+
+newtype Kleisli m a b = Kleisli { runKleisli :: a -> m b }
+
+instance Monad m => Arrow (Kleisli m) where
+    arr f = Kleisli (return . f)
+    Kleisli f >>> Kleisli g = Kleisli (\x -> f x >>= g)
+
+main :: IO ()
+main = return ()
hunk ./FrontEnd/Class.hs 312
-qtToClassHead kt (HsQualType cntx (HsTyApp (HsTyCon className) ty)) = (map (hsAsstToPred kt) cntx,(toName ClassName className,[runIdentity $ hsTypeToType kt ty]))
+qtToClassHead kt qt@(HsQualType cntx (HsTyApp (HsTyCon className) ty)) =
+    trace ("qtToClassHead" <+> show qt) $
+    let res = (map (hsAsstToPred kt) cntx,(toName ClassName className,
+                                           [runIdentity $ hsTypeToType (kiHsQualType kt (HsQualType cntx (HsTyTuple []))) ty]))
+    in trace ("=" <+> show res) res
+
hunk ./FrontEnd/KindInfer.hs 12
+    kiHsQualType,
hunk ./FrontEnd/KindInfer.hs 179
-constrain KindQuestQuest  (KBase KQuest) = fail "cannot constraint ? to be ??"
+constrain KindQuestQuest  (KBase KQuest) = fail "cannot constrain ? to be ??"
hunk ./FrontEnd/KindInfer.hs 433
-            Nothing | nameType name `elem` [TypeConstructor,TypeVal] -> kindStar
+--          Nothing | nameType name `elem` [TypeConstructor,TypeVal] -> kindStar
hunk ./FrontEnd/KindInfer.hs 496
-hsAsstToPred kt (HsAsstEq t1 t2) = IsEq (runIdentity $ hsTypeToType kt t1) (runIdentity $ hsTypeToType kt t2)
+hsAsstToPred kt (HsAsstEq t1 t2) = IsEq (runIdentity $ hsTypeToType' kt t1) (runIdentity $ hsTypeToType' kt t2)
hunk ./FrontEnd/KindInfer.hs 503
-hsTypeToType kt t = return $ hoistType $ aHsTypeToType kt t -- (forallHoist t)
+hsTypeToType kt t = return $ unsafePerformIO $ runKI kt $
+                    do kv <- newKindVar KindAny
+                       kiType (KVar kv) t
+                       kt' <- postProcess =<< getEnv
+                       hsTypeToType' kt' t
+
+
+hsTypeToType' :: Monad m => KindEnv -> HsType -> m Type
+hsTypeToType' kt t = return $ hoistType $ aHsTypeToType kt t -- (forallHoist t)
hunk ./FrontEnd/KindInfer.hs 521
-   Just t' = hsTypeToType newEnv (hsQualTypeType qualType)
+   Just t' = hsTypeToType' newEnv (hsQualTypeType qualType)