[add kind subtyping needed to type unboxed tuples properly
John Meacham <john@repetae.net>**20061108011551] hunk ./FrontEnd/KindInfer.hs 20
+import Data.Maybe
hunk ./FrontEnd/KindInfer.hs 37
+import FrontEnd.Tc.Kind
hunk ./FrontEnd/KindInfer.hs 112
+mgu k1 k2 | isJust $ kindCombine k1 k2 = return nullSubst
hunk ./FrontEnd/KindInfer.hs 357
+kiType varExist tap@(HsTyUnboxedTuple ts) = do
+        withContext ("kiType: " ++ show tap) $ do
+        tsKs <- mapM (kiType varExist) ts
+        mapM_ (\k -> unify k Star) tsKs
+        return KUTuple
hunk ./FrontEnd/KindInfer.hs 423
+namesFromType (HsTyUnboxedTuple ts) = concatMap namesFromType ts
hunk ./FrontEnd/Rename.hs 487
+    rt (HsTyUnboxedTuple hsTypes) subTable = do
+        hsTypes' <- mapRename rt hsTypes subTable
+        return (HsTyUnboxedTuple hsTypes')
hunk ./FrontEnd/Rename.hs 1433
+            HsTyUnboxedTuple  typs ->
+                HsTyUnboxedTuple  # typs
hunk ./FrontEnd/Rename.hs 1473
+            HsUnboxedTuple  exps ->
+                HsUnboxedTuple  # exps
hunk ./FrontEnd/Rename.hs 1522
+            HsPUnboxedTuple  pats ->
+                HsPUnboxedTuple  # pats
hunk ./FrontEnd/Representation.hs 236
+    z@KUTuple -> newLookupName (map (('u':) . show) [0 :: Int ..]) z t
+    z@KFunRet -> newLookupName (map (('r':) . show) [0 :: Int ..]) z t
hunk ./FrontEnd/Tc/Kind.hs 4
+    kindCombine,
hunk ./FrontEnd/Tc/Kind.hs 9
+import Control.Monad
hunk ./FrontEnd/Tc/Kind.hs 15
+{-
+
+ KFunRet = ??
+ KUTuple = (#)
+ Star    = *
+ Kfun    = (->)
+
+ we have the following subkinding going on
+
+   ??
+  /  \
+ *   (#)
+
+
+-}
+
hunk ./FrontEnd/Tc/Kind.hs 34
+           | KFunRet                    -- ^ either a * or a (#)
hunk ./FrontEnd/Tc/Kind.hs 39
+kindCombine :: Monad m => Kind -> Kind -> m Kind
+kindCombine x y = f x y where
+    f Star Star = return Star
+    f KUTuple KUTuple = return KUTuple
+    f KFunRet KFunRet = return KFunRet
+
+    f KFunRet Star = return Star
+    f Star KFunRet = return Star
+    f KFunRet KUTuple = return KUTuple
+    f KUTuple KFunRet = return KUTuple
+    f (Kfun a b) (Kfun a' b') = return Kfun `ap` f a a' `ap` f b b'
+    f x y = fail $ "kindCombine: " ++ show (x,y)
+
+
hunk ./FrontEnd/Tc/Kind.hs 62
+   pprint KFunRet = text "??"
hunk ./FrontEnd/Tc/Kind.hs 65
+   pprint (Kfun KFunRet k2)   = text "?? -> " <> pprint k2  -- ^ this is invalid
hunk ./FrontEnd/Tc/Kind.hs 68
+   pprint (Kfun k1   KFunRet) = text "(" <> pprint k1 <> text ")" <> text " -> ??"
hunk ./FrontEnd/Tc/Main.hs 145
-    scrutinee <- newBox Star
+    scrutinee <- newBox KFunRet
hunk ./FrontEnd/Tc/Main.hs 233
-            withMetaVars mv [Star,Star] (\ [a,b] -> a `fn` b) $ \ [a,b] -> lam (p:ps) e (a `fn` b) rs
+            withMetaVars mv [Star,KFunRet] (\ [a,b] -> a `fn` b) $ \ [a,b] -> lam (p:ps) e (a `fn` b) rs
hunk ./FrontEnd/Tc/Main.hs 653
-            withMetaVars mv [Star,Star] (\ [a,b] -> a `fn` b) $ \ [a,b] -> lam (p:ps) (a `fn` b) rs
+            withMetaVars mv [Star,KFunRet] (\ [a,b] -> a `fn` b) $ \ [a,b] -> lam (p:ps) (a `fn` b) rs
hunk ./FrontEnd/Tc/Monad.hs 45
+    zonkKind,
hunk ./FrontEnd/Tc/Monad.hs 72
+import FrontEnd.Tc.Kind
hunk ./FrontEnd/Tc/Monad.hs 394
-    nvs <- mapM (newVar . metaKind) vs
+    nvs <- mapM (newVar . id . metaKind) vs
hunk ./FrontEnd/Tc/Monad.hs 400
+-- turn all ?? into * types, as we can't abstract over unboxed types
+fixKind :: Kind -> Kind
+fixKind KFunRet = Star
+fixKind (a `Kfun` b) = fixKind a `Kfun` fixKind b
+fixKind x = x
+
hunk ./FrontEnd/Tc/Monad.hs 438
-    | getType u /= getType t = error $ "varBind: kinds do not match:" ++ show (u,t)
+--    | getType u /= getType t = error $ "varBind: kinds do not match:" ++ show (u,t)
hunk ./FrontEnd/Tc/Monad.hs 440
+        kindCombine (getType u) (getType t)
hunk ./FrontEnd/Tc/Monad.hs 444
-        tt <- flattenType tt
-        when (u `elem` freeMetaVars tt) $ unificationError (TMetaVar u) tt -- occurs check
+        tt <- evalFullType tt
+        when (dump FD.BoxySteps) $ liftIO $ putStrLn $ "varBind: " ++ pprint u <+> text ":=" <+> prettyPrintType tt
+        when (u `elem` freeMetaVars tt) $ do
+            unificationError (TMetaVar u) tt -- occurs check
hunk ./FrontEnd/Tc/Monad.hs 453
-                when (dump FD.BoxySteps) $ putStrLn $ "varBind: " ++ pprint u <+> text ":=" <+> prettyPrintType t
+                --when (dump FD.BoxySteps) $ putStrLn $ "varBind: " ++ pprint u <+> text ":=" <+> prettyPrintType t
hunk ./FrontEnd/Tc/Monad.hs 456
+
+zonkKind :: Kind -> MetaVar -> Tc MetaVar
+zonkKind nk mv = do
+    fk <- kindCombine nk (metaKind mv)
+    if fk == metaKind mv then return mv else do
+        nref <- liftIO $ newIORef Nothing
+        let nmv = mv { metaKind = fk, metaRef = nref }
+        liftIO $ modifyIORef (metaRef mv) (\Nothing -> Just $ TMetaVar nmv)
+        return nmv
+
hunk ./FrontEnd/Tc/Unify.hs 19
+import FrontEnd.Tc.Kind
hunk ./FrontEnd/Tc/Unify.hs 115
-    tt <- flattenType t
+    tt <- evalFullType t
hunk ./FrontEnd/Tc/Unify.hs 267
-    when (getType tv1 /= getType tv2) $ error "BBEQ boxyMatch kinds"
-    f tv1 tv2
+--    when (getType tv1 /= getType tv2) $ error "BBEQ boxyMatch kinds"
+    k <- kindCombine (getType tv1) (getType tv2)
+    f k tv1 tv2
hunk ./FrontEnd/Tc/Unify.hs 271
-    f tv1 tv2 | tv1 == tv2 = return ()
-    f tv1 tv2 | isBoxyMetaVar tv1 && isBoxyMetaVar tv2 = do
+    f k tv1 tv2 | tv1 == tv2 = zonkKind k tv1 >> return ()
+    f k tv1 tv2 | isBoxyMetaVar tv1 && isBoxyMetaVar tv2 = do
hunk ./FrontEnd/Tc/Unify.hs 274
-            tt <- newMetaVar Tau (getType tv1)
+            tt <- newMetaVar Tau k
hunk ./FrontEnd/Tc/Unify.hs 277
-    f tv1 tv2 | isBoxyMetaVar tv1  = do
+    f k tv1 tv2 | isBoxyMetaVar tv1  = do
hunk ./FrontEnd/Tc/Unify.hs 280
-    f tv1 tv2 | isBoxyMetaVar tv2  = do
+            zonkKind k tv2
+            return ()
+    f k tv1 tv2 | isBoxyMetaVar tv2  = do
hunk ./FrontEnd/Tc/Unify.hs 285
-    f tv1 tv2  = do
+            zonkKind k tv1
+            return ()
+    f k tv1 tv2  = do
hunk ./FrontEnd/Tc/Unify.hs 290
+            zonkKind k tv1
+            return ()
hunk ./FrontEnd/TypeSyns.hs 221
+    rt (HsTyUnboxedTuple hsTypes) subTable = do
+        hsTypes' <- mapRename rt hsTypes subTable
+        return (HsTyUnboxedTuple hsTypes')
hunk ./FrontEnd/TypeSyns.hs 534
+getHsNamesFromHsPat (HsPUnboxedTuple hsPats) = concat (map getHsNamesFromHsPat hsPats)
hunk ./FrontEnd/TypeSyns.hs 566
+getHsNamesFromHsType (HsTyUnboxedTuple hsTypes) = concat $ map getHsNamesFromHsType hsTypes
hunk ./FrontEnd/TypeSyns.hs 742
+            HsTyUnboxedTuple  typs ->
+                HsTyUnboxedTuple  # typs
hunk ./FrontEnd/TypeSyns.hs 782
+            HsUnboxedTuple  exps ->
+                HsUnboxedTuple  # exps
hunk ./FrontEnd/TypeSyns.hs 831
+            HsPUnboxedTuple  pats ->
+                HsPUnboxedTuple  # pats