[clean up code, add simple stack backtrace to help find bugs, fix duplicate instance
John Meacham <john@repetae.net>**20120130035517
 Ignore-this: ef47496f7fdc2bffab7ba60059912b69
] hunk ./lib/base/Control/Monad.hs 16
-
hunk ./lib/base/Control/Monad.hs 25
-
hunk ./lib/base/Control/Monad.hs 27
-
hunk ./lib/base/Control/Monad.hs 86
-
hunk ./lib/base/Control/Monad.hs 101
-
hunk ./lib/jhc/Prelude/Text.hs 96
-instance (Read a) => Read (Maybe a) where
-    readsPrec d input =
-	      (\ inp -> [((Nothing) , rest) | ("Nothing" , rest) <- lex inp])
-	      input
-	      ++
-	      readParen (d > 9)
-	      (\ inp ->
-	       [((Just aa) , rest) | ("Just" , inp) <- lex inp ,
-		(aa , rest) <- readsPrec 10 inp])
-	      input
+--instance (Read a) => Read (Maybe a) where
+--    readsPrec d input =
+--	      (\ inp -> [((Nothing) , rest) | ("Nothing" , rest) <- lex inp])
+--	      input
+--	      ++
+--	      readParen (d > 9)
+--	      (\ inp ->
+--	       [((Just aa) , rest) | ("Just" , inp) <- lex inp ,
+--		(aa , rest) <- readsPrec 10 inp])
+--	      input
hunk ./src/E/E.hs 91
-tvrShowName t = maybe ('x':(show $ tvrIdent t)) show (tvrName t)
+tvrShowName t = show (tvrIdent t)
hunk ./src/E/E.hs 93
-modAbsurd = "Jhc@.Absurd"
-modBox    = "Jhc@.Box"
+modAbsurd = toModule "Jhc@.Absurd"
+modBox    = toModule "Jhc@.Box"
hunk ./src/E/E.hs 96
-nameConjured :: String -> E -> Name
+nameConjured :: Module -> E -> Name
hunk ./src/E/E.hs 102
-fromConjured :: Monad m => String -> Name -> m E
+fromConjured :: Monad m => Module -> Name -> m E
hunk ./src/E/Lint.hs 29
+import Support.TempDir
hunk ./src/E/Lint.hs 49
+    withStackStatus ("transformProgram: " ++ name) $ do
hunk ./src/E/Main.hs 45
+import Support.TempDir
hunk ./src/E/Main.hs 71
-processInitialHo accumho aho = do
+processInitialHo accumho aho = withStackStatus "processInitialHo" $ do
hunk ./src/E/Main.hs 98
-processDecls cho ho' tiData = do
+processDecls cho ho' tiData = withStackStatus "processDecls" $  do
hunk ./src/E/Main.hs 163
-    let entryPoints = fromList . execWriter $ programMapDs_ (\ (t,_) -> when (getProperty prop_EXPORTED t || getProperty prop_INSTANCE t || getProperty prop_SPECIALIZATION t)  (tell [tvrIdent t])) prog
+    let entryPoints = fromList . execWriter $ programMapDs_ (\ (t,_) -> when 
+            (getProperty prop_EXPORTED t || getProperty prop_INSTANCE t || getProperty prop_SPECIALIZATION t)  (tell [tvrIdent t])) prog
hunk ./src/E/Main.hs 199
+        withStackStatus ("fint: " ++ names) $ do
hunk ./src/E/Main.hs 364
-            return $ SS.programSSimplify sopt  nprog
+            lintCheckProgram (putErrLn "AfterOccurance") nprog
+            return $ SS.programSSimplify sopt nprog
hunk ./src/E/Main.hs 371
-    when (dodump && (dump FD.Progress || coreSteps)) $ Stats.printLStat (optStatLevel options) ("Total: " ++ name) (progStats prog)
+    when (dodump && (dump FD.Progress || coreSteps)) $ 
+        Stats.printLStat (optStatLevel options) ("Total: " ++ name) (progStats prog)
hunk ./src/E/Program.hs 20
-import Util.Gen hiding(putErrLn)
hunk ./src/E/Program.hs 27
-    progExternalNames  :: IdSet,
-    progCombinators    :: [Comb],
-    progDataTable      :: DataTable,
-    progEntry          :: IdSet,
-    progMain           :: Id,
-    progModule         :: Module,
-    progPasses         :: [String],    -- ^ record of passes the program goes through
-    progUsedIds        :: IdSet,       -- ^ filled in by occurance info collection
-    progFreeIds        :: IdSet,       -- ^ filled in by occurance info collection
-    progSeasoning      :: IdSet,       -- ^ these ids are depended on by external names via RULES
-    progType           :: ProgramType,
-    progCombMap        :: IdMap Comb,  -- progCombMap is always (fromList . progCombinators)
-    progStats          :: !Stats.Stat
+    progExternalNames :: IdSet,
+    progCombinators   :: [Comb],
+    progDataTable     :: DataTable,
+    progEntry         :: IdSet,
+    progMain          :: Id,
+    progModule        :: Module,
+    progPasses        :: [String],    -- ^ record of passes the program goes through
+    progUsedIds       :: IdSet,       -- ^ filled in by occurance info collection
+    progFreeIds       :: IdSet,       -- ^ filled in by occurance info collection
+    progSeasoning     :: IdSet,       -- ^ these ids are depended on by external names via RULES
+    progType          :: ProgramType,
+    progCombMap       :: IdMap Comb,  -- progCombMap is always (fromList . progCombinators)
+    progStats         :: !Stats.Stat
hunk ./src/E/Program.hs 43
-    progExternalNames  = mempty,
-    progCombinators    = mempty,
-    progDataTable      = mempty,
-    progEntry          = mempty,
-    progMain           = emptyId,
-    progModule         = mainModule,
-    progPasses         = [],
-    progUsedIds        = mempty,
-    progFreeIds        = mempty,
-    progSeasoning      = mempty,
-    progType           = MainProgram,
-    progCombMap        = mempty,
-    progStats          = mempty
+    progExternalNames = mempty,
+    progCombinators   = mempty,
+    progDataTable     = mempty,
+    progEntry         = mempty,
+    progMain          = emptyId,
+    progModule        = mainModule,
+    progPasses        = [],
+    progUsedIds       = mempty,
+    progFreeIds       = mempty,
+    progSeasoning     = mempty,
+    progType          = MainProgram,
+    progCombMap       = mempty,
+    progStats         = mempty
hunk ./src/E/Program.hs 67
-programDs prog = [ (t,e)  | Comb { combHead = t, combBody = e }  <- progCombinators prog]
+programDs prog = [ (t,e)  | Comb { combHead = t,
+                                   combBody = e } <- progCombinators prog]
hunk ./src/E/Program.hs 70
-progCombinators_u f prog = programUpdate prog { progCombinators = f $ progCombinators prog }
+progCombinators_u f prog =
+    programUpdate prog { progCombinators = f $ progCombinators prog }
hunk ./src/E/Program.hs 75
-programUpdate prog = check $ ucache prog where
-    ds = progCombinators prog
-    ucache prog = prog { progCombMap = fromList [ (combIdent c,c) | c <- ds ] }
-    check x
-        | not flint = x
-        | hasRepeatUnder combIdent ds = error $ "programSetDs: program has redundant definitions: \n" ++ names
-        | any (not . isJust . fromId) (map combIdent ds) = error $ "programSetDs: trying to set non unique top level name: \n" ++ names
-        | otherwise = x
-    names = intercalate "\n"  (sort $ map (show . tvrShowName . combHead) ds)
+programUpdate prog = ucache prog where
+    ucache prog = prog { progCombMap =
+        fromList [ (combIdent c,c) | c <- progCombinators prog ] }
hunk ./src/E/Program.hs 80
-programSetDs' ds prog = progCombinators_s [ combRules_s (lupRules (tvrIdent t)) $ bindComb (t,e) | (t,e) <- ds ] prog where
+programSetDs' ds prog = progCombinators_s newDs prog where
+    newDs = [ combRules_s (lupRules (tvrIdent t)) $ bindComb (t,e) | (t,e) <- ds ]
hunk ./src/E/Program.hs 116
-    sequence_ $ intersperse (hPutStrLn fh "") [ hPrintCheckName fh dataTable v e | Comb { combHead = v, combBody = e } <- cs]
+    sequence_ $ intersperse (hPutStrLn fh "") [ hPrintCheckName fh dataTable v e |
+                                                Comb { combHead = v, combBody = e } <- cs]
hunk ./src/E/SSimplify.hs 124
-            Nothing -> tell (tfvs,mempty) >>  return (EPi tvr { tvrIdent =  emptyId, tvrType = a } b)
+            Nothing -> tell (tfvs,mempty) >> return (EPi tvr { tvrIdent = emptyId, tvrType = a } b)
hunk ./src/E/SSimplify.hs 171
-        return $ caseUpdate ec { eCaseScrutinee = scrut', eCaseAlts = as', eCaseBind = annbind' fidm b, eCaseType = ct, eCaseDefault = d'}
+        return $ caseUpdate ec { eCaseScrutinee = scrut', eCaseAlts = as',
+            eCaseBind = annbind' fidm b, eCaseType = ct, eCaseDefault = d'}
hunk ./src/E/SSimplify.hs 268
-andOcc x y = UseInfo { useOccurance = Many, minimumArgs = min (minimumArgs x) (minimumArgs y) }
+andOcc x y = UseInfo { useOccurance = Many,
+    minimumArgs = min (minimumArgs x) (minimumArgs y) }
hunk ./src/E/SSimplify.hs 271
-orMaps ms = OMap $ fmap orMany $ foldl (unionWith (++)) mempty (map (fmap (:[])) (map unOMap ms)) where
-    unOMap (OMap m) = m
+orMaps ms = OMap $ fmap orMany $ foldl (unionWith (++)) mempty (map (fmap (:[]))
+    (map unOMap ms)) where unOMap (OMap m) = m
hunk ./src/E/SSimplify.hs 305
-    so_cachedScope = cacheSubst (extendScope initScope mempty { envSubst = mapMaybeIdMap bb  (so_boundVars opts), envRules = rules })
+    so_cachedScope = cacheSubst (extendScope initScope mempty {
+        envSubst = mapMaybeIdMap bb (so_boundVars opts), envRules = rules })
hunk ./src/E/SSimplify.hs 352
-fixInline finalPhase v bt@IsBoundTo {} = bt { inlineForced = inlineForced bt `mappend` calcForced finalPhase v }  where
+fixInline finalPhase v bt@IsBoundTo {} = bt {
+    inlineForced = inlineForced bt `mappend` calcForced finalPhase v }
hunk ./src/E/SSimplify.hs 380
-insertSuspSubst' t e env = cacheSubst env { envSubst = minsert t (susp e (envSubst env)) (envSubst env) }
+insertSuspSubst' t e env = cacheSubst env {
+    envSubst = minsert t (susp e (envSubst env)) (envSubst env) }
hunk ./src/Support/TempDir.hs 10
+    withStackStatus,
hunk ./src/Support/TempDir.hs 37
-putLog = putStrLn
---log _ = return ()
+--putLog = putStrLn
+putLog _ = return ()
hunk ./src/Support/TempDir.hs 132
+        ss <- readIORef stackRef
hunk ./src/Support/TempDir.hs 138
+        unless (null ss) $
+            forM_ ("Stack:":ss) (hPutStrLn stderr)
hunk ./src/Support/TempDir.hs 168
+
+{-# NOINLINE stackRef #-}
+stackRef :: IORef [String]
+stackRef = unsafePerformIO $ newIORef []
+
+withStackStatus :: String -> IO a -> IO a
+withStackStatus s action = do
+    cs <- readIORef stackRef
+    writeIORef stackRef (s:cs)
+    r <- action
+    writeIORef stackRef cs
+    return r
+
+