[make jhc use new typechecker always
John Meacham <john@repetae.net>**20051214052337] addfile ./FrontEnd/Tc/Module.hs
hunk ./E/FromHs.hs 36
+import FrontEnd.Tc.Type(prettyPrintType)
hunk ./E/FromHs.hs 420
-        gg' a b = error $ "specialization: " <> parens  (show a) <+> parens (show b) <+> "in spec" <+> hsep (map parens [show g, show s, show e])
+        gg' (TMetaVar a) (TMetaVar b) | a == b = []
+        gg' a b = error $ "specialization: " <> parens  (prettyPrintType a) <+> parens (prettyPrintType b) <+> "in spec" <+> hsep (map parens [prettyPrintType g, prettyPrintType s, show e])
hunk ./FrontEnd/FrontEnd.hs 23
+import qualified FrontEnd.Tc.Module
hunk ./FrontEnd/FrontEnd.hs 63
-    (ho',tiData) <- tiModules' ho ms
+    (ho',tiData) <- FrontEnd.Tc.Module.tiModules' ho ms
hunk ./FrontEnd/Tc/Main.hs 1
-module FrontEnd.Tc.Main (tiExpr, makeProgram ) where
+module FrontEnd.Tc.Main (tiExpr, tiProgram, makeProgram ) where
hunk ./FrontEnd/Tc/Main.hs 88
+    --typ <- flattenType typ
hunk ./FrontEnd/Tc/Main.hs 154
-            r <- lam (p:ps) e (b1 `fn` b2) rs
hunk ./FrontEnd/Tc/Main.hs 155
-            return r
+            lam (p:ps) e (b1 `fn` b2) rs
hunk ./FrontEnd/Tc/Main.hs 159
-            (p',env) <- tiPat p box
+            (p',env) <- tcPat p box
hunk ./FrontEnd/Tc/Main.hs 161
+                s2' <- findType s2'
hunk ./FrontEnd/Tc/Main.hs 246
-    (wheres', env) <- tcWheres wheres
-    localEnv env $ do
+    scrutinee <- findType scrutinee
hunk ./FrontEnd/Tc/Main.hs 248
+    localEnv env $ do
+    (wheres', env) <- tcWheres wheres
hunk ./FrontEnd/Tc/Main.hs 259
+    typ <- findType typ
hunk ./FrontEnd/Tc/Main.hs 265
+    typ <- findType typ
hunk ./FrontEnd/Tc/Main.hs 280
-        --v <- newTVar Star
-        (v) <- newBox Star
+        v <- newBox Star
hunk ./FrontEnd/Tc/Main.hs 282
+        addToCollectedEnv (Map.singleton (toName Val i) v)
hunk ./FrontEnd/Tc/Main.hs 306
+    --(foldr fn typ bs) `subsumes` s
hunk ./FrontEnd/Tc/Main.hs 313
+    --TAp tList v `subsumes` typ
hunk ./FrontEnd/Tc/Main.hs 391
-    (wheres', env) <- tcWheres wheres
-    localEnv env $ do
hunk ./FrontEnd/Tc/Main.hs 394
-            r <- lam (p:ps) (b1 `fn` b2) rs
hunk ./FrontEnd/Tc/Main.hs 395
-            return r
+            lam (p:ps) (b1 `fn` b2) rs
hunk ./FrontEnd/Tc/Main.hs 399
-            (p',env) <- tiPat p box
+            (p',env) <- tcPat p box
+            liftIO $ print (p',env)
hunk ./FrontEnd/Tc/Main.hs 402
+                s2' <- findType s2'
hunk ./FrontEnd/Tc/Main.hs 405
-            rhs <- tcRhs rhs typ
+            (wheres', env) <- tcWheres wheres
+            rhs <- localEnv env $ tcRhs rhs typ
hunk ./FrontEnd/Tc/Main.hs 409
-        lamPoly ps s@TBox {} rs = lam ps s rs
+        lamPoly ps s@TMetaVar {} rs = lam ps s rs
hunk ./FrontEnd/Tc/Main.hs 413
+    typ <- findType typ
hunk ./FrontEnd/Tc/Main.hs 658
+tiProgram ::  [BindGroup] -> Tc [HsDecl]
+tiProgram bgs = f bgs [] mempty where
+    f (bg:bgs) rs cenv  = do
+        (ds,env) <- tcBindGroup bg
+        localEnv env $ f bgs (ds ++ rs) (env `mappend` cenv)
+    f [] rs _cenv = return rs
hunk ./FrontEnd/Tc/Module.hs 1
+module FrontEnd.Tc.Module (tiModules') where
+
+import Char
+import Control.Monad.Writer
+import IO
+import List
+import Maybe
+import Monad
+import qualified Data.Map as Map
+import Text.PrettyPrint.HughesPJ as PPrint
+
+import Atom
+import Class
+import DataConsAssump     (dataConsEnv)
+import DataConstructors
+import DeclsDepends       (getDeclDeps, debugDeclBindGroups)
+import DependAnalysis     (getBindGroups)
+import DerivingDrift.Drift
+import Doc.PPrint as PPrint
+import FrontEnd.Desugar
+import FrontEnd.Infix
+import FrontEnd.KindInfer
+import FrontEnd.Rename
+import FrontEnd.SrcLoc
+import FrontEnd.Tc.Monad
+import FrontEnd.Tc.Main
+import FrontEnd.Tc.Type
+import FrontEnd.Utils
+import GenUtil
+import Ho
+import HsSyn
+import MultiModuleBasics
+import Name.Name as Name
+import Options
+import qualified FlagDump as FD
+import qualified HsPretty
+import Representation
+import TypeSigs           (collectSigs, listSigsToSigEnv)
+import TypeSynonyms
+import TypeSyns
+import Type
+import Util.Gen
+import TIModule(TiData(..))
+import Util.Inst()
+import Warning
+
+trimEnv env = Map.filterWithKey (\k _ -> isGlobal k) env -- (Map.fromList [ n | n@(name,_) <- Map.toList env,  isGlobal name ])
+
+getDeclNames ::  HsDecl -> [Name]
+getDeclNames (HsTypeSig _ ns _ ) =  map (toName Val) ns
+getDeclNames d = maybeGetDeclName d
+
+
+isGlobal x |  (_,(_::String,(h:_))) <- fromName x =  not $ isDigit h
+isGlobal _ = error "isGlobal"
+
+modInfoDecls = hsModuleDecls . modInfoHsModule
+
+getImports ModInfo { modInfoHsModule = mod }  = [  (hsImportDeclModule x) | x <-  hsModuleImports mod]
+
+pprintEnv :: PPrint Doc a => Map.Map Name a -> Doc
+pprintEnv env = pl global $+$ pl local_norm $+$ pl local_sys  where
+    es = Map.toList env
+    (local,global) = partition (\ (x,_) -> not (isGlobal x)) es -- isDigit $ head (hsIdentString (hsNameIdent x)) ) es
+    (local_sys,local_norm) = partition (\(x,_) -> last (show x) == '@' ) local
+    pl es = vcat [((pprint a) <+> (text "::") <+> (pprint b)) | (a, b) <- es]
+
+buildFieldMap :: Ho -> [ModInfo] -> FieldMap
+buildFieldMap ho ms = (ans',ans) where
+        theDefs = [ (x,z) | (x,_,z) <- concat $ map modInfoDefs ms, nameType x == DataConstructor ]
+        allDefs = theDefs ++ [ (x,z) | (x,(_,z)) <- Map.toList (hoDefs ho), nameType x == DataConstructor ]
+        ans = Map.fromList $ sortGroupUnderFG fst snd $ concat [ [ (y,(x,i)) |  y <- ys | i <- [0..] ]  | (x,ys) <-  allDefs ]
+        ans' = Map.fromList $ concatMap modInfoConsArity ms ++ getConstructorArities (hoDataTable ho)
+
+
+processModule :: FieldMap -> ModInfo -> IO ModInfo
+processModule defs m = do
+    when (dump FD.Parsed) $ do
+        putStrLn " \n ---- parsed code ---- \n";
+        putStrLn $ HsPretty.render
+            $ HsPretty.ppHsModule
+                $ modInfoHsModule m
+    zmod' <-  driftDerive (modInfoHsModule m)
+    let mod = desugarHsModule (zmod')
+    let (mod',errs) = runWriter $ renameModule defs (modInfoImport m)  mod
+    when (dump FD.Renamed) $ do
+        putStrLn " \n ---- renamed code ---- \n"
+        putStrLn $ HsPretty.render $ HsPretty.ppHsModule $  mod'
+    processErrors errs
+    return $ modInfoHsModule_s mod' m
+
+
+-- type check a set of mutually recursive modules.
+-- assume all dependencies are met in the
+-- ModEnv parameter and export lists have been calculated.
+
+or' :: [(a -> Bool)] -> a -> Bool
+or' fs x = or [ f x | f <- fs ]
+
+tiModules' ::  Ho -> [ModInfo] -> IO (Ho,TiData)
+tiModules' me ms = do
+    let importVarEnv = Map.fromList [ (x,y) | (x,y) <- Map.toList $ hoAssumps me, nameType x == Name.Val ]
+        importDConsEnv = Map.fromList [ (x,y) | (x,y) <- Map.toList $ hoAssumps me, nameType x ==  Name.DataConstructor ]
+        importClassHierarchy = hoClassHierarchy me
+        importKindEnv = hoKinds me
+    wdump FD.Progress $ do
+        putErrLn $ "Typing: " ++ show ([ m | Module m <- map modInfoName ms])
+    let fieldMap = buildFieldMap me ms
+    ms <- mapM (processModule fieldMap) ms
+    let thisFixityMap = buildFixityMap (concat [ filter isHsInfixDecl (hsModuleDecls $ modInfoHsModule m) | m <- ms])
+    let fixityMap = thisFixityMap `mappend` hoFixities me
+    let thisTypeSynonyms =  (declsToTypeSynonyms $ concat [ filter isHsTypeDecl (hsModuleDecls $ modInfoHsModule m) | m <- ms])
+    let ts = thisTypeSynonyms  `mappend` hoTypeSynonyms me
+    let f x = expandTypeSyns ts (modInfoHsModule x) >>= FrontEnd.Infix.infixHsModule fixityMap >>= \z -> return (modInfoHsModule_s ( z) x)
+    ms <- mapM f ms
+    processIOErrors
+    let ds = concat [ hsModuleDecls $ modInfoHsModule m | m <- ms ]
+
+    wdump FD.Decls $ do
+        putStrLn "  ---- processed decls ---- "
+        putStrLn $ HsPretty.render (HsPretty.ppHsDecls ds)
+
+
+    -- kind inference for all type constructors type variables and classes in the module
+    let classAndDataDecls = filter (or' [isHsDataDecl, isHsNewTypeDecl, isHsClassDecl]) ds  -- rDataDecls ++ rNewTyDecls ++ rClassDecls
+
+    wdump FD.Progress $ do
+        putErrLn $ "Kind inference"
+    kindInfo <- kiDecls importKindEnv classAndDataDecls
+
+    when (dump FD.Kind) $
+         do {putStrLn " \n ---- kind information ---- \n";
+             putStr $ PPrint.render $ pprint kindInfo}
+
+    -- collect types for data constructors
+
+    let localDConsEnv = dataConsEnv (error "modName") kindInfo classAndDataDecls -- (rDataDecls ++ rNewTyDecls)
+
+    when  (dump FD.Dcons) $
+         do {putStr "\n ---- data constructor assumptions ---- \n";
+             putStrLn $ PPrint.render $ pprint localDConsEnv}
+
+
+    let globalDConsEnv = localDConsEnv `Map.union` importDConsEnv
+
+
+    smallClassHierarchy <- makeClassHierarchy importClassHierarchy kindInfo ds
+    cHierarchyWithInstances <- return $ smallClassHierarchy `mappend` importClassHierarchy
+
+    when (dump FD.ClassSummary) $ do
+        putStrLn "  ---- class summary ---- "
+        printClassSummary cHierarchyWithInstances
+
+    when (dump FD.Class) $
+         do {putStrLn "  ---- class hierarchy ---- ";
+             printClassHierarchy smallClassHierarchy}
+
+    -- lift the instance methods up to top-level decls
+
+    let cDefBinds = concat [ [ z | z <- ds] | HsClassDecl _ _ ds <- ds]
+    let myClassAssumps = concat  [ classAssumps as | as <- (classRecords cHierarchyWithInstances)]
+        instanceEnv   = Map.fromList $ [ (x,y) | (x :>: y) <-  instAssumps ]
+        classDefs = snub (concatMap getDeclNames cDefBinds)
+        classEnv  = Map.fromList $ [ (x,y) | (x :>: y) <- myClassAssumps, x `elem` classDefs  ]
+        (liftedInstances,instAssumps) =  mconcatMap (instanceToTopDecls kindInfo cHierarchyWithInstances) ds -- rInstDecls
+
+
+    when (not (null liftedInstances) && (dump FD.Instance) ) $ do
+        putStrLn "  ---- lifted instance declarations ---- "
+        putStr $ unlines $ map (HsPretty.render . HsPretty.ppHsDecl) liftedInstances
+        putStrLn $ PPrint.render $ pprintEnvMap instanceEnv
+
+
+    let funPatBinds =  [ d | d <- ds, or' [isHsFunBind, isHsPatBind, isHsForeignDecl] d]
+    let rTySigs =  [ d | d <- ds, or' [isHsTypeSig] d]
+
+    -- build an environment of assumptions for all the type signatures
+    let allTypeSigs = collectSigs (funPatBinds ++ liftedInstances) ++ rTySigs
+
+    when (dump FD.Srcsigs) $
+         do {putStrLn " ---- type signatures from source code (after renaming) ---- ";
+             putStr $ unlines $ map (HsPretty.render . HsPretty.ppHsDecl) allTypeSigs}
+
+    let sigEnv = Map.unions [listSigsToSigEnv kindInfo allTypeSigs,instanceEnv, classEnv]
+    when (dump FD.Sigenv) $
+         do {putStrLn "  ---- initial sigEnv information ---- ";
+             --mapM_ (putStrLn . show) (envToList kindInfo);
+             putStrLn $ PPrint.render $ pprintEnvMap sigEnv}
+    let bindings = (funPatBinds ++ [ z | z <- cDefBinds, isHsFunBind z || isHsPatBind z] ++ liftedInstances)
+        classDefaults  = snub [ getDeclName z | z <- cDefBinds, isHsFunBind z || isHsPatBind z ]
+        classNoDefaults = snub (concat [ getDeclNames z | z <- cDefBinds ])  List.\\ classDefaults
+        noDefaultSigs = Map.fromList [ (n,maybe (error $ "sigEnv:"  ++ show n) id $ Map.lookup n sigEnv) | n <- classNoDefaults ]
+        fakeForeignDecls = [ [HsForeignDecl bogusASrcLoc ForeignPrimitive "" (nameName x) (HsUnQualType $ HsTyTuple []) ] | (x,_) <- Map.toList noDefaultSigs]
+    --when verbose2 $ putStrLn (show bindings)
+    let programBgs = getBindGroups bindings (nameName . getDeclName) getDeclDeps
+
+    when (dump FD.Bindgroups) $
+         do {putStrLn " \n ---- toplevel variable binding groups ---- ";
+             putStrLn " ---- Bindgroup # = [members] [vars depended on] [missing vars] ---- \n";
+             putStr $ debugDeclBindGroups programBgs}
+
+    let program = makeProgram (Map.map schemeToType sigEnv) ( fakeForeignDecls ++ programBgs )
+    when (dump FD.Program) $ do
+        putStrLn " ---- Program ---- "
+        mapM_ putStrLn $ map (PPrint.render . PPrint.pprint) $  program
+
+    -- type inference/checking for all variables
+
+    wdump FD.Progress $ do
+        putErrLn $ "Type inference"
+    let moduleName = modInfoName tms
+        (tms:_) = ms
+    let tcInfo = tcInfoEmpty {
+        tcInfoEnv = Map.map schemeToType (importVarEnv `mappend` globalDConsEnv),
+        tcInfoSigEnv = Map.map schemeToType $ sigEnv ,
+        tcInfoModName =  show moduleName,
+        tcInfoKindInfo = kindInfo,
+        tcInfoClassHierarchy = cHierarchyWithInstances
+        }
+
+    localVarEnv <- withOptionsT (modInfoOptions tms) $ runTc tcInfo $ do
+        ds <- tiProgram program
+        ce <- getCollectedEnv
+        liftIO $ mapM_ putStrLn [ show n ++  " :: " ++ prettyPrintType s |  (n,s) <- Map.toList ce]
+        return (Map.map typeToScheme ce)
+
+    when (dump FD.Types) $
+         do {putStrLn " ---- the types of identifiers ---- ";
+             putStrLn $ PPrint.render $ pprintEnv (if verbose2 then localVarEnv else trimEnv localVarEnv) }
+
+    --let externalEnv = Map.fromList [ v | v@(x@(Qual m i) ,s) <- Map.toList localVarEnv, isGlobal x, m `elem` map modInfoName ms ]  `Map.union` noDefaultSigs
+    let externalEnv = Map.filterWithKey (\ x _ -> isGlobal x && (fromJust (getModule x) `elem` map modInfoName ms)) localVarEnv `Map.union` noDefaultSigs
+    localVarEnv <- return $  localVarEnv `Map.union` noDefaultSigs
+    --let externalKindEnv = Map.fromList [ v | v@(x@(Qual m i) ,s) <- Map.toList kindInfo, isGlobal x, m `elem` map modInfoName ms ]
+    let externalKindEnv = restrictKindEnv (\ x  -> isGlobal x && (fromJust (getModule x) `elem` map modInfoName ms)) kindInfo
+
+    let pragmaProps = Map.fromListWith (\a b -> snub $ a ++ b ) [ (toName Name.Val x,[toAtom w]) |  HsPragmaProps _ w xs <- ds, x <- xs ]
+
+    let allAssumps = localDConsEnv `Map.union` localVarEnv -- Map.fromList $ [ (toName Name.DataConstructor x,y) | (x,y) <- Map.toList localDConsEnv ] ++ [ (toName Name.Val x,y) | (x,y) <- Map.toList localVarEnv ]
+        --expAssumps = M.fromList $ [ (toName Name.DataConstructor x,y) | (x,y) <- Env.toList localDConsEnv ] ++ [ (toName Name.Val x,y) | (x,y) <- Env.toList $ trimEnv localVarEnv ]
+        --expAssumps = Map.fromList $ [ (toName Name.DataConstructor x,y) | (x,y) <- Map.toList localDConsEnv ] ++ [ (toName Name.Val x,y) | (x,y) <- Map.toList $ externalEnv ]
+        expAssumps = localDConsEnv `Map.union` externalEnv -- Map.fromList $ [ (toName Name.DataConstructor x,y) | (x,y) <- Map.toList localDConsEnv ] ++ [ (toName Name.Val x,y) | (x,y) <- Map.toList $ externalEnv ]
+    let ho = mempty {
+        hoExports = Map.fromList [ (modInfoName m,modInfoExport m) | m <- ms ],
+        hoDefs =  Map.fromList [ (x,(y,z)) | (x,y,z) <- concat $ map modInfoDefs ms],
+        hoAssumps = expAssumps,
+        hoFixities = thisFixityMap,
+        --hoKinds = trimMapEnv kindInfo,
+        hoKinds = externalKindEnv,
+        --hoClassHierarchy = cHierarchyWithInstances,
+        hoClassHierarchy = smallClassHierarchy,
+        hoProps = pragmaProps,
+        hoTypeSynonyms = thisTypeSynonyms
+
+        }
+        tiData = TiData {
+            tiDataLiftedInstances = Map.fromList [ (getDeclName d,d) | d <- liftedInstances],
+            tiDataModules = [ (modInfoName m, modInfoHsModule m) |  m <- ms],
+            tiModuleOptions = [ (modInfoName m, modInfoOptions m) |  m <- ms],
+            tiAllAssumptions = allAssumps
+        }
+    return (ho,tiData)
+
hunk ./FrontEnd/Tc/Monad.hs 48
+import Doc.DocLike
hunk ./FrontEnd/Tc/Monad.hs 53
-import Util.Inst
hunk ./FrontEnd/Tc/Monad.hs 56
+import Util.Inst
hunk ./FrontEnd/Tc/Monad.hs 101
-    fmapM flattenType r
+    r <- fmapM flattenType r
hunk ./FrontEnd/Tc/Monad.hs 313
-                    Just r -> error $ "varBind: bining unfree: " ++ show (u,t,r)
+                    Just r -> error $ "varBind: binding unfree: " ++ tupled [pprint u,prettyPrintType t,prettyPrintType r]
hunk ./FrontEnd/Tc/Unify.hs 95
-    sub a b = fail $ "subsumes failure: " <> ppretty s1 <+> ppretty s2
+    sub a b = fail $ "subsumes failure: " <> ppretty a <+> ppretty b
hunk ./FrontEnd/Tc/Unify.hs 146
-        a `boxyMatch` foldl TAp (TCon ca) bs
hunk ./FrontEnd/Tc/Unify.hs 147
+        a `boxyMatch` foldl TAp (TCon ca) bs
hunk ./FrontEnd/Tc/Unify.hs 167
-        boxyMatch t a
hunk ./FrontEnd/Tc/Unify.hs 168
+        boxyMatch t a
hunk ./FrontEnd/Type.hs 44
+             typeToScheme,
hunk ./FrontEnd/Type.hs 49
-import Control.Monad.Trans
hunk ./FrontEnd/Type.hs 294
+typeToScheme :: Type -> Scheme
+typeToScheme (TForAll as qt) = quantify as qt
+typeToScheme t = toScheme t
hunk ./Interactive.hs 202
-    localVarEnv <- liftIO $ tiProgram
+    localVarEnv <- liftIO $ TIMain.tiProgram