[add type checking of tuples, improve printing of types
John Meacham <john@repetae.net>**20051211052321] hunk ./FrontEnd/Class.hs 659
+       hnf TForAll {} = False
hunk ./FrontEnd/Tc/Main.hs 26
---import Representation
-import Type
hunk ./FrontEnd/Tc/Main.hs 37
-instance Types a => Types (Name, a) where
-   apply s (x, y) = (x, apply s y)
-   tv (_, y) = tv y
hunk ./FrontEnd/Tc/Main.hs 38
-instance Types TypeEnv where
-   apply s = Map.map (\e -> apply s e)
-   tv env = tv $ Map.elems env
+--tcApps e as typ = f e as typ [] where
+--    f e (a:as) typ rs = do
+--        (e1,e2) <- tcApp e a typ
hunk ./FrontEnd/Tc/Main.hs 43
+
hunk ./FrontEnd/Tc/Main.hs 152
---tiExpr env tuple@(HsTuple exps@(_:_)) typ = withContext (makeMsg "in the tuple" $ render $ ppHsExp tuple) $ do
---    psasts <- mapM tiExpr exps
---    let typeList = map trd3 psasts
---    let preds = concatMap fst3 psasts
---    let env1 = Map.unions $ map snd3 psasts
---    return (preds, env1, tTTuple typeList)
+tiExpr tuple@(HsTuple exps@(_:_)) typ = withContext (makeMsg "in the tuple" $ render $ ppHsExp tuple) $ do
+    apps <- tiExpr (foldl HsApp (HsCon (toTuple (length exps))) exps) typ
+    let f (HsApp a b) exps = f a (b:exps)
+        f (HsCon {}) exps = reverse exps
+    return $ HsTuple (f apps [])
+    --psasts <- mapM tiExpr exps
+    --let typeList = map trd3 psasts
+    --let preds = concatMap fst3 psasts
+    --let env1 = Map.unions $ map snd3 psasts
+    --return (preds, env1, tTTuple typeList)
hunk ./FrontEnd/Tc/Main.hs 164
--- tuples can't be empty, () is not a tuple
---tiExpr env tuple@(HsTuple exps@(_:_)) typ = withContext (makeMsg "in the tuple" $ render $ ppHsExp tuple) $ do
---    psasts <- mapM tiExpr exps
---    let typeList = map trd3 psasts
---    let preds = concatMap fst3 psasts
---    let env1 = Map.unions $ map snd3 psasts
---    return (preds, env1, tTTuple typeList)
hunk ./FrontEnd/Tc/Main.hs 167
-        v <- newTVar Star
-        (TAp tList v) `subsumes` typ
+        --v <- newTVar Star
+        (_,box) <- newBox Star
+        (TAp tList box) `subsumes` typ
hunk ./FrontEnd/Tc/Main.hs 187
+    ch <- getClassHierarchy
hunk ./FrontEnd/Tc/Main.hs 189
-    u' <- tiExpr u tb
+    (u',ds) <- listen $ tiExpr u tb
hunk ./FrontEnd/Tc/Main.hs 191
-    rr <- flattenType rr
-    rr <- generalize rr
+    ds :=> rr <- flattenType (ds :=> rr)
+    let tvs = freeMetaVars rr
+    (ds,rs) <- (split ch tvs ds)
+    addPreds ds
+    rr <- quantify tvs rs rr
hunk ./FrontEnd/Tc/Main.hs 295
- tiExpr (HsCase e alts) typ = withContext (simpleMsg $ "in the case expression\n   case " ++ show e ++ " of ...") $ do
+tiExpr (HsCase e alts) typ = withContext (simpleMsg $ "in the case expression\n   case " ++ show e ++ " of ...") $ do
hunk ./FrontEnd/Tc/Main.hs 311
-{-
-tiExpr expr@(HsInfixApp e1 e2 e3) = withContext (makeMsg "in the infix application" $ render $ ppHsExp expr) $ do
-       (ps, env1, te1) <- tiExpr env e1
-       (qs, env2, te2) <- tiExpr env e2
-       (rs, env3, te3) <- tiExpr env e3
-       tout      <- newTVar Star
-       unify (te1 `fn` (te3 `fn` tout)) te2
-       return (ps ++ qs ++ rs, env1 `Map.union` env2 `Map.union` env3, tout)
-       -}
hunk ./FrontEnd/Tc/Main.hs 312
- -}
hunk ./FrontEnd/Tc/Main.hs 313
-
-{-
-
-tiExpr env (HsVar v) | Just sc <- Map.lookup (toName Val v) env = do
-          (ty@(ps :=> t)) <- freshInst sc
-          --addInstance ((v,n),ty)
-          return (ps, Map.empty, t)
-tiExpr env (HsVar v) = error $ "tiExpr: could not find type scheme for: " ++ show v ++ " " ++ show env
-
-{-
-
- = do let sc = case lookupEnv v env of
-                  Nothing -> error $ "tiExpr: could not find type scheme for: " ++
-		                     show v ++ " " ++ showEnv env
-                  Just scheme -> scheme
-      (ty@(ps :=> t)) <- freshInst sc
-      --addInstance ((v,n),ty)
-      return (ps, Map.empty, t)
--}
-
-tiExpr env (HsCon conName)
- = do
-      sc <- dConScheme (toName DataConstructor conName)
-      (ty@(ps :=> t)) <- freshInst sc
-      --addInstance ((conName,n),ty)
-      return (ps, Map.empty, t)
-
-tiExpr _env (HsLit l)
- = do (ps,t) <- tiLit l
-      return (ps, Map.empty, t)
hunk ./FrontEnd/Tc/Type.hs 29
+import Name.Names
+import Name.VConsts
hunk ./FrontEnd/Tc/Type.hs 84
-    f t rs = (t,reverse rs)
+    f t rs = (t,rs)
hunk ./FrontEnd/Tc/Type.hs 99
---    fp :: DocLike d => Pred -> VarName Atom Char (Unparse d)
hunk ./FrontEnd/Tc/Type.hs 102
---    f :: DocLike d => Type -> VarName Atom Char (Unparse d)
+    f (TForAll [] ([] :=> t)) = f t
hunk ./FrontEnd/Tc/Type.hs 107
-        return $ fixitize (N,-3) $ pop (text "forall" <+> hsep (map char ts') <+> text ". " <> if null ps then empty else tupled (map unparse ps') <+> text "=> ")  (atomize t')
+        return $ case ps' of
+            [] ->  fixitize (N,-3) $ pop (text "forall" <+> hsep (map char ts') <+> text ". ")  (atomize t')
+            [p] -> fixitize (N,-3) $ pop (text "forall" <+> hsep (map char ts') <+> text "." <+> unparse p <+> text "=> ")  (atomize t')
+            ps ->  fixitize (N,-3) $ pop (text "forall" <+> hsep (map char ts') <+> text "." <+> tupled (map unparse ps) <+> text "=> ")  (atomize t')
hunk ./FrontEnd/Tc/Type.hs 115
-           -- check for the Prelude.[] special case
hunk ./FrontEnd/Tc/Type.hs 116
-        --vo <- newLookupName ['a' .. ] () tyvar
hunk ./FrontEnd/Tc/Type.hs 117
-    --f t | Just tyvar <- extractMetaTV t = do
-    --    vo <- newLookupName ['a' .. ] () tyvar
-    --    return $ atom $  text (vo:"'")
-           -- check for the Prelude.[] special case
+    f (TAp (TCon (Tycon n _)) x) | n == tc_List = do
+        x <- f x
+        return $ atom (char '[' <> unparse x <> char ']')
+    f ta@(TAp {}) | (TCon (Tycon c _),xs) <- fromTAp ta, Just _ <- fromTupname c = do
+        xs <- mapM f xs
+        return $ atom (tupled (map unparse xs))
hunk ./Name/Names.hs 52
+instance FromTupname Name where
+    fromTupname name | m == "Prelude" = fromTupname (nn::String) where
+        (_,(m,nn)) = fromName name
+    fromTupname _ = fail "not a tuple"
+
+