[add more support for existentials. get rid of absurdization pass.
John Meacham <john@repetae.net>**20060216074059] hunk ./E/FromHs.hs 89
+    f (TVar Tyvar { tyvarRef = Just {}, tyvarKind = k}) = tAbsurd (kind k)
hunk ./E/FromHs.hs 97
+    cvar Tyvar { tyvarRef = Just {}, tyvarKind = k}= error "tyvar is metaref"
hunk ./FrontEnd/HsPretty.hs 344
+mprintExists :: HsConDecl -> Doc
+mprintExists hcd = case hsConDeclExists hcd of
+    [] -> empty
+    vs -> text "exists" <+> hsep (map (return . pprint) vs) <+> char '.'
+
hunk ./FrontEnd/HsPretty.hs 350
-ppHsConstr (HsRecDecl { hsConDeclName = name, hsConDeclRecArg = fieldList }) =
-	 ppHsName name
+ppHsConstr cd@HsRecDecl { hsConDeclName = name, hsConDeclRecArg = fieldList } =
+	 mprintExists cd <+> ppHsName name
hunk ./FrontEnd/HsPretty.hs 353
-ppHsConstr (HsConDecl { hsConDeclName = name, hsConDeclConArg = typeList})
+ppHsConstr cd@HsConDecl { hsConDeclName = name, hsConDeclConArg = typeList}
hunk ./FrontEnd/HsPretty.hs 356
-	 myFsep [ppHsBangType l, ppHsName name, ppHsBangType r]
-     | otherwise =
-	 mySep $ (ppHsName name) :
-		 map ppHsBangType typeList
+	 mprintExists cd <+> myFsep [ppHsBangType l, ppHsName name, ppHsBangType r]
+     | otherwise = mprintExists cd <+> (mySep $ (ppHsName name) :
+		 map ppHsBangType typeList)
hunk ./FrontEnd/KindInfer.hs 242
-        dataBodyKinds <- mapM (kiType True) dataBodies        -- vars must be seen previously here (hence True)
-        --mapM_ (\k -> unify k Star) dataBodyKinds
+        dataBodyKinds <- mapM (kiType False) dataBodies        -- vars must be seen previously here (hence True)
+        --mapM_ (\k -> unify k Star) dataBodyKinds                set to true for existentials
hunk ./FrontEnd/KindInfer.hs 393
-   = snub $ namesFromContext cntxt ++ (concatMap namesFromType $ concatMap conDeclToTypes condecls)
+   = snub $ namesFromContext cntxt ++ (concatMap namesFromType $ concatMap conDeclToTypes condecls) ++ concatMap conDeclNames condecls
hunk ./FrontEnd/KindInfer.hs 395
-   = snub $ namesFromContext cntxt ++ (concatMap namesFromType $ conDeclToTypes condecl)
+   = snub $ namesFromContext cntxt ++ (concatMap namesFromType $ conDeclToTypes condecl) ++ conDeclNames condecl
hunk ./FrontEnd/KindInfer.hs 421
+-- data KindGroup = KindGroup {
+--     kgClassDecls :: [(HsName,[HsName])],
+--     kgDataDecls ::[DataDeclHead],
+--     kgContexts ::HsContext,
+--     kgTypes ::[HsType],
+--     kgQualTypes ::[HsQualType]
+--     }
hunk ./FrontEnd/KindInfer.hs 478
+
+conDeclNames :: HsConDecl -> [Name]
+conDeclNames rd = map (toName TypeVal) $ map hsTyVarBindName $ hsConDeclExists rd
hunk ./FrontEnd/Tc/Main.hs 14
+import Doc.DocLike
hunk ./FrontEnd/Tc/Main.hs 279
---tiPat :: HsPat -> TI ([Pred], Map.Map Name Scheme, Type)
hunk ./FrontEnd/Tc/Main.hs 281
-tcPat p typ = do
+tcPat p typ = withContext (makeMsg "in the pattern: " $ render $ ppHsPat p) $ do
hunk ./FrontEnd/Tc/Main.hs 323
-    bs <- sequence [ newBox Star | _ <- pats ]
hunk ./FrontEnd/Tc/Main.hs 324
-    s `subsumes` (foldr fn typ bs)
-    pats' <- sequence [ tcPat a r | r <- bs | a <- pats ]
-    return (HsPApp conName (fsts pats'), mconcat (snds pats'))
+    nn <- deconstructorInstantiate s
+    let f (p:pats) (a `TArrow` rs) (ps,env) = do
+            (np,res) <- tiPat p a
+            f pats rs (np:ps,env `mappend` res)
+        f (p:pats) rs _ = do
+            fail $ "constructor applied to too many arguments:" <+> show p <+> prettyPrintType rs
+        f [] (_ `TArrow` _) _ = do
+            fail "constructor not applied to enough arguments"
+        f [] rs (ps,env) = do
+            rs `subsumes` typ
+            unBox typ
+            return (HsPApp conName (reverse ps), env)
+    f pats nn mempty
+    --bs <- sequence [ newBox Star | _ <- pats ]
+    --s `subsumes` (foldr fn typ bs)
+    --pats' <- sequence [ tcPat a r | r <- bs | a <- pats ]
+    --return (HsPApp conName (fsts pats'), mconcat (snds pats'))
hunk ./FrontEnd/Tc/Main.hs 395
-    (res,ps) <- censor (const mempty) $ listen $ localEnv (Map.fromList [  (getDeclName d,s) | d <- bs | s <- ts]) $ sequence [ tcDecl d s | d <- bs | s <- ts ]
+    (res,ps) <- listenPreds $ localEnv (Map.fromList [  (getDeclName d,s) | d <- bs | s <- ts]) $ sequence [ tcDecl d s | d <- bs | s <- ts ]
hunk ./FrontEnd/Tc/Main.hs 436
-                    (e1,ps) <- censor (const mempty) $ listen (tcExpr e1 tr)
+                    (e1,ps) <- listenPreds (tcExpr e1 tr)
hunk ./FrontEnd/Tc/Main.hs 438
-                    (e2,ps) <- censor (const mempty) $ listen (tcExpr e2 tr)
+                    (e2,ps) <- listenPreds (tcExpr e2 tr)
hunk ./FrontEnd/Tc/Main.hs 520
-    (ret,ps) <- censor (const mempty) $ listen (tcDecl decl typ)
+    (ret,ps) <- listenPreds (tcDecl decl typ)
hunk ./FrontEnd/Tc/Main.hs 732
-        (r,ps) <- censor (const mempty) $ listen $ f bgs [] mempty
+        (r,ps) <- listenPreds $ f bgs [] mempty
hunk ./FrontEnd/Tc/Main.hs 743
-        ((ds,env),ps) <- censor (const mempty) $ listen (tcBindGroup bg)
+        ((ds,env),ps) <- listenPreds (tcBindGroup bg)
hunk ./FrontEnd/Tc/Main.hs 752
-        ((),ps) <- censor (const mempty) $ listen $ mapM_ tcPragmaDecl es
+        ((),ps) <- listenPreds $ mapM_ tcPragmaDecl es
hunk ./FrontEnd/Tc/Module.hs 139
-    when  (dump FD.Dcons) $
-         do {putStr "\n ---- data constructor assumptions ---- \n";
-             putStrLn $ PPrint.render $ pprint localDConsEnv}
+    wdump FD.Dcons $ do
+        putStr "\n ---- data constructor assumptions ---- \n"
+        mapM_ putStrLn [ show n ++  " :: " ++ prettyPrintType (schemeToType s) |  (n,s) <- Map.toList localDConsEnv]
hunk ./FrontEnd/Tc/Monad.hs 13
+    deconstructorInstantiate,
hunk ./FrontEnd/Tc/Monad.hs 32
+    listenPreds,
hunk ./FrontEnd/Tc/Monad.hs 55
+import Support.FreeVars
hunk ./FrontEnd/Tc/Monad.hs 83
-newtype Tc a = Tc (ReaderT TcEnv (WriterT [Pred] IO) a)
-    deriving(MonadFix,MonadIO,MonadReader TcEnv,MonadWriter [Pred],Functor)
+data Output = Output {
+    collectedPreds   :: Preds,
+    existentialPreds :: Preds,
+    existentialVars  :: [Tyvar]
+    }
+   {-! derive: update, Monoid !-}
+
+newtype Tc a = Tc (ReaderT TcEnv (WriterT Output IO) a)
+    deriving(MonadFix,MonadIO,MonadReader TcEnv,MonadWriter Output,Functor)
hunk ./FrontEnd/Tc/Monad.hs 104
-localEnv te | isGood = local (tcCurrentEnv_u (te `Map.union`)) where
-    isGood = not $ any isBoxy (Map.elems te)
-localEnv te = fail $ "localEnv error!\n" ++ show te
-
--- | run a computation with a local environment
---localScopeEnv :: [Tyvar] -> Tc a -> Tc a
---localScopeEnv te = local (tcCurrentScope_u (te `Set.union`))
+localEnv te act = do
+    te' <- mapM (\ (x,y) -> do y <- flattenType y; return (x,y)) (Map.toList te)
+    if any isBoxy (snds te') then
+        fail $ "localEnv error!\n" ++ show te
+     else local (tcCurrentEnv_u (Map.fromList te' `Map.union`)) act
hunk ./FrontEnd/Tc/Monad.hs 250
-addPreds :: [Pred] -> Tc ()
-addPreds ps = Tc $ tell ps
+addPreds :: Preds -> Tc ()
+addPreds ps = Tc $ tell mempty { collectedPreds = ps }
+
+
+listenPreds :: Tc a -> Tc (a,Preds)
+listenPreds action = censor (\x -> x { collectedPreds = mempty }) $ listens collectedPreds action
hunk ./FrontEnd/Tc/Monad.hs 290
+deconstructorInstantiate :: Sigma -> Tc Rho'
+deconstructorInstantiate tfa@TForAll {} = do
+    TForAll vs qt@(_ :=> t) <- freshSigma tfa
+    let f (_ `TArrow` b) = f b
+        f b = b
+        eqvs = vs List.\\ freeVars (f t)
+    tell mempty { existentialVars = eqvs }
+    freshInstance Sigma (TForAll (vs List.\\ eqvs) qt)
+deconstructorInstantiate x = return x
+
hunk ./Interactive.hs 5
-import Control.Monad.Writer
hunk ./Interactive.hs 233
-    (_,ps') <- listen $ tiExpr e box
+    (_,ps') <- listenPreds $ tiExpr e box
hunk ./Main.hs 303
-    let g (TVr { tvrIdent = 0 }) = error "absurded zero"
-        g tvr@(TVr { tvrIdent = n, tvrType = k})
-            | sortStarLike k =  tAbsurd k
-            | otherwise = EVar tvr
-    fvs <- return $ foldr Map.delete (freeVars lc)  inscope
-    when (Map.size fvs > 0 && dump FD.Progress) $ do
-        putDocM putErr $ parens $ text "Absurded vars:" <+> align (hsep $ map pprint (Map.elems fvs))
+--    let g (TVr { tvrIdent = 0 }) = error "absurded zero"
+--        g tvr@(TVr { tvrIdent = n, tvrType = k})
+--            | sortStarLike k =  tAbsurd k
+--            | otherwise = EVar tvr
+--    fvs <- return $ foldr Map.delete (freeVars lc)  inscope
+ --   when (Map.size fvs > 0 && dump FD.Progress) $ do
+  --      putDocM putErr $ parens $ text "Absurded vars:" <+> align (hsep $ map pprint (Map.elems fvs))
hunk ./Main.hs 311
-    lc <- mangle (return ()) False ("Absurdize") (return . substMap (Map.map g fvs)) lc
+    --lc <- mangle (return ()) False ("Absurdize") (return . substMap (Map.map g fvs)) lc