[create Ho.Collected, use it, change around how hos are collected.
John Meacham <john@repetae.net>**20080219151312] addfile ./Ho/Collected.hs
hunk ./FrontEnd/FrontEnd.hs 16
+import Ho.Collected
hunk ./FrontEnd/Tc/Module.hs 31
+import Ho.Collected
hunk ./Ho/Build.hs 49
+import Info.Types
hunk ./Ho/Build.hs 53
+import Ho.Collected
hunk ./Ho/Build.hs 62
+import qualified Info.Info as Info
hunk ./Ho/Build.hs 349
-
-
hunk ./Ho/Collected.hs 1
+module Ho.Collected(
+    CollectedHo(..),
+    choHo
+    )where
+
+import Data.Monoid
+import Control.Monad.Identity
+
+import Util.SetLike
+import Ho.Type
+import E.E
+import DataConstructors
+import Info.Types
+import E.Annotate
+import qualified Info.Info as Info
+import qualified Data.Map as Map
+
+instance Monoid CollectedHo where
+    mempty = CollectedHo {
+        choExternalNames = mempty,
+        choOrphanRules = mempty,
+        choHoMap = Map.singleton "Prim@" pho,
+        choVarMap = mempty
+        } where pho = mempty { hoBuild = mempty { hoDataTable = dataTablePrims } }
+    a `mappend` b = CollectedHo {
+        choExternalNames = choExternalNames a `mappend` choExternalNames b,
+        choVarMap = choVarMap a `mergeChoVarMaps` choVarMap b,
+        choOrphanRules = choOrphanRules a `mappend` choOrphanRules b,
+        choHoMap = Map.union (choHoMap a) (choHoMap b)
+        }
+
+choHo cho = hoBuild_u (hoEs_u f) . mconcat . Map.elems $ choHoMap cho where
+    f ds = runIdentity $ annotateDs mmap  (\_ -> return) (\_ -> return) (\_ -> return) (map g ds) where
+        mmap = mfilterWithKey (\k _ -> (k `notElem` (map (tvrIdent . fst) ds))) (choVarMap cho)
+    g (t,e) = case mlookup (tvrIdent t) (choVarMap cho) of
+        Just (Just (EVar t')) -> (t',e)
+        _ -> (t,e)
+    ae = runIdentity . annotate (choVarMap cho) (\_ -> return) (\_ -> return) (\_ -> return)
+
+-- this will have to merge rules and properties.
+mergeChoVarMaps :: IdMap (Maybe E) -> IdMap (Maybe E) -> IdMap (Maybe E)
+mergeChoVarMaps x y = munionWith f x y where
+    f (Just (EVar x)) (Just (EVar y)) = Just . EVar $ merge x y
+    f x y = error "mergeChoVarMaps: bad merge."
+    merge ta tb = ta { tvrInfo = minfo' }   where
+        minfo = tvrInfo ta `mappend` tvrInfo tb
+        minfo' = dex (undefined :: ARules) . dex (undefined :: Properties) $ minfo
+        dex dummy y = g (Info.lookup (tvrInfo tb) `asTypeOf` Just dummy) where
+            g Nothing = y
+            g (Just x) = Info.insertWith mappend x y
+
hunk ./Ho/Type.hs 6
-import StringTable.Atom
hunk ./Ho/Type.hs 29
+    -- this is a list of external names that are valid but that we may not know anything else about
+    -- it is used to recognize invalid ids.
hunk ./Ho/Type.hs 32
+    -- this is a map of ids to their full TVrs with all rules and whatnot attached.
hunk ./Ho/Type.hs 34
-    choHoMap :: Map.Map String Ho,
-    choHo :: Ho
+    -- these are rules that may need to be retroactively applied to other modules
+    choOrphanRules :: Rules,
+    -- the hos
+    choHoMap :: Map.Map String Ho
hunk ./Ho/Type.hs 41
-updateCollectedHo cho = cho { choHo = mconcat $ Map.elems (choHoMap cho) }
-
-instance Monoid CollectedHo where
-    mempty = CollectedHo {
-        choExternalNames = mempty,
-        choHo = pho,
-        choHoMap = Map.singleton "Prim@" pho,
-        choVarMap = mempty
-        } where pho = mempty { hoBuild = mempty { hoDataTable = dataTablePrims } }
-    a `mappend` b = CollectedHo {
-        choExternalNames = choExternalNames a `mappend` choExternalNames b,
-        choVarMap = choVarMap a `mappend` choVarMap b,
-        choHoMap = newHoMap,
-        choHo = mconcat $ Map.elems newHoMap
-        } where newHoMap = Map.union (choHoMap a) (choHoMap b)
-
-choDataTable cho = hoDataTable $ hoBuild (choHo cho)
-
-
hunk ./Interactive.hs 33
+import Ho.Collected
hunk ./Main.hs 35
-import E.Subst(subst)
+import E.Subst(subst,substMap'')
hunk ./Main.hs 56
+import Ho.Collected
hunk ./Main.hs 65
+import Support.CanType(getType)
+import Util.HasSize
hunk ./Main.hs 167
+
hunk ./Main.hs 173
-    let ho' = reprocessHo (hoRules ho) mempty ho
-        ho = hoBuild aho
-        -- XXX do we need to do this?
-    let-- rules' = runIdentity $ mapBodies (annotate imapRules (\_ nfo -> return nfo) (\_ -> return) (\_ -> return)) (hoRules ho)
-        --imapRules = choVarMap accumho  `mappend` newVarMap
-        --accumho' = reprocessCho rules' mempty accumho
-    let ds = runIdentity $ annotateDs (choVarMap accumho) (\_ -> return) letann lamann (hoEs ho')
-
-        prog = etaAnnotateProgram (programSetDs ds program { progDataTable = choDataTable accumho `mappend` hoDataTable ho })
-        newVarMap = fromList [ (tvrIdent t,Just (EVar t)) | (t,_) <- programDs prog ]
+    let finalVarMap = mappend (fromList [(tvrIdent tvr,Just $ EVar tvr) | tvr <- newTVrs ]) $ reRule (choVarMap accumho)
+        newTVrs = map annTVr . fsts $ hoEs (hoBuild aho)
+        annTVr t = dorule rules' t
hunk ./Main.hs 177
+        --reRule x = if isEmpty orphanRules then x else fmap (fmap rr) x where
+        reRule x = fmap (fmap rr) x where
+            rr ~(EVar t) = EVar $ dorule rules' t
+        dorule rules t = tvrInfo_u (g (tvrIdent t)) t where
+            g id = runIdentity . idann rules mempty id
+        orphanRules = findOrphanRules (Map.keys . hoExports $ hoExp aho) rules'
+        --rules' = (hoRules (hoBuild aho))
+        --rules' = mapRuleBodies (substfmap) (hoRules (hoBuild aho))
+        rules' = mapRuleBodies (substMap'' $ choVarMap accumho) (hoRules (hoBuild aho))
+        substfmap = runIdentity . annotate finalVarMap (\_ -> return) letann lamann
hunk ./Main.hs 188
+    let ds = runIdentity $ annotateDs (choVarMap accumho) (\_ -> return) letann lamann (hoEs ho')
+        ho' = reprocessHo rules' mempty (hoBuild aho)
+        prog = etaAnnotateProgram (programSetDs ds program { progDataTable = hoDataTable (hoBuild $ choHo accumho) `mappend` hoDataTable (hoBuild aho) })
hunk ./Main.hs 192
+    return $ mempty {
+        choVarMap = finalVarMap,
+        choExternalNames = fromList . map tvrIdent $ newTVrs,
+        choHoMap = Map.singleton (show mod) $ hoBuild_u (hoEs_s $ programDs prog) aho
+        } `mappend` accumho
hunk ./Main.hs 198
-    --lintCheckProgram (putStrLn "processInitialHo") prog
-    return $ updateCollectedHo $ accumho `mappend` mempty { choVarMap = newVarMap, choExternalNames = idMapToIdSet newVarMap, choHoMap = Map.singleton (show mod) aho { hoBuild = ho { hoEs = programDs prog } } }
+--    let ho' = reprocessHo (hoRules ho) mempty ho
+--        ho = hoBuild aho
+--        -- XXX do we need to do this? YES!
+--    let-- rules' = runIdentity $ mapBodies (annotate imapRules (\_ nfo -> return nfo) (\_ -> return) (\_ -> return)) (hoRules ho)
+--        --imapRules = choVarMap accumho  `mappend` newVarMap
+--        --accumho' = reprocessCho rules' mempty accumho
+--    let ds = runIdentity $ annotateDs (choVarMap accumho) (\_ -> return) letann lamann (hoEs ho')
+--
+--        prog = etaAnnotateProgram (programSetDs ds program { progDataTable = choDataTable accumho `mappend` hoDataTable ho })
+--        newVarMap = fromList [ (tvrIdent t,Just (EVar t)) | (t,_) <- programDs prog ]
+--
+--
+--        (mod:_) = Map.keys $ hoExports $ hoExp aho
+--
+--    --lintCheckProgram (putStrLn "processInitialHo") prog
+--    return $ updateCollectedHo $ accumho `mappend` mempty { choVarMap = newVarMap, choExternalNames = idMapToIdSet newVarMap, choHoMap = Map.singleton (show mod) aho { hoBuild = ho { hoEs = programDs prog } } }
hunk ./Main.hs 222
-reprocessCho rules ps cho = updateCollectedHo $ choHoMap_u (Map.map $ hoBuild_u (hoEs_u (map f))) $ choVarMap_u (fmap h) cho where
+reprocessCho rules ps cho = choHoMap_u (Map.map $ hoBuild_u (hoEs_u (map f))) $ choVarMap_u (fmap h) cho where
hunk ./Main.hs 510
-    wdump FD.Core $ printProgram prog
-
hunk ./Main.hs 532
-    putErrLn "!!!!!"
hunk ./Main.hs 533
-    putErrLn "!!!!!"
hunk ./Main.hs 537
-    putErrLn "!!!!!"
hunk ./Main.hs 553
---    putStrLn "Type analyzed methods"
---    flip mapM_ (programDs prog) $ \ (t,e) -> do
---        let (_,ts) = fromLam e
---            ts' = takeWhile (sortKindLike . getType) ts
---        when (not (null ts')) $ putStrLn $ (pprint t) ++ " \\" ++ concat [ "(" ++ show  (Info.fetch (tvrInfo t) :: Typ) ++ ")" | t <- ts' ]
+    putStrLn "Type analyzed methods"
+    flip mapM_ (programDs prog) $ \ (t,e) -> do
+        let (_,ts) = fromLam e
+            ts' = takeWhile (sortKindLike . getType) ts
+        when (not (null ts')) $ putStrLn $ (pprint t) ++ " \\" ++ concat [ "(" ++ show  (Info.fetch (tvrInfo t) :: Typ) ++ ")" | t <- ts' ]
hunk ./Makefile.am 45
-	 StringTable/Atom.hsc Util/Util.hs Support/MD5.hs
+	 StringTable/Atom.hsc Util/Util.hs Support/MD5.hs Ho/Collected.hs