[allow various levels of statistics to be printed
John Meacham <john@repetae.net>**20060720022831] hunk ./E/SSimplify.hs 684
-                    mtick  (toAtom $ "E.Simplify.inline.atomic.{" ++ tvrShowName v  ++ "}")
+                    mtick  (toAtom $ "E.Simplify.inline.atomic/{" ++ tvrShowName v  ++ "}")
hunk ./E/SSimplify.hs 687
-                    mtick  (toAtom $ "E.Simplify.inline.Forced.{" ++ tvrShowName v  ++ "}")
+                    mtick  (toAtom $ "E.Simplify.inline.Forced/{" ++ tvrShowName v  ++ "}")
hunk ./E/SSimplify.hs 690
-                    mtick  (toAtom $ "E.Simplify.inline.forced.{" ++ tvrShowName v  ++ "}")
+                    mtick  (toAtom $ "E.Simplify.inline.forced/{" ++ tvrShowName v  ++ "}")
hunk ./E/SSimplify.hs 693
-                    mtick  (toAtom $ "E.Simplify.inline.OnceInLam.{" ++ showName (tvrIdent v)  ++ "}")
+                    mtick  (toAtom $ "E.Simplify.inline.OnceInLam/{" ++ showName (tvrIdent v)  ++ "}")
hunk ./E/SSimplify.hs 696
-                    mtick  (toAtom $ "E.Simplify.inline.ManyBranch.{" ++ showName (tvrIdent v)  ++ "}")
+                    mtick  (toAtom $ "E.Simplify.inline.ManyBranch/{" ++ showName (tvrIdent v)  ++ "}")
hunk ./E/SSimplify.hs 699
-                    mtick  (toAtom $ "E.Simplify.inline.Many.{" ++ showName (tvrIdent v)  ++ "}")
+                    mtick  (toAtom $ "E.Simplify.inline.Many/{" ++ showName (tvrIdent v)  ++ "}")
hunk ./E/SSimplify.hs 756
-                mtick $ "E.Simplify.inline.Once.{" ++ showName t ++ "}"
+                mtick $ "E.Simplify.inline.Once/{" ++ showName t ++ "}"
hunk ./Options.hs 74
+    optStatLevel   :: !Int,                    -- ^ Level to print statistics
hunk ./Options.hs 102
+    optStatLevel   = 1,
hunk ./Options.hs 113
-    [ Option ['V'] ["version"]   (NoArg  (optMode_s Version))    "print version info and exit"
+    [ Option ['V'] ["version"]   (NoArg  (optMode_s Version))          "print version info and exit"
hunk ./Options.hs 115
-    , Option ['v'] ["verbose"]   (NoArg  (optVerbose_u (+1)))    "chatty output on stderr"
+    , Option ['v'] ["verbose"]   (NoArg  (optVerbose_u (+1)))          "chatty output on stderr"
+    , Option ['z'] []            (NoArg  (optStatLevel_u (+1)))        "Increase verbosity of statistics"
hunk ./Options.hs 118
-    , Option ['f'] []            (ReqArg (\d -> optFOpts_u (d:)) "flag")  "set compilation options"
-    , Option ['o'] ["output"]    (ReqArg (optOutName_s) "FILE")  "output to FILE"
-    , Option ['i'] ["include"]   (ReqArg (optIncdirs_u . idu) "DIR") "library directory"
+    , Option ['f'] []            (ReqArg (\d -> optFOpts_u (d:)) "flag")      "set compilation options"
+    , Option ['o'] ["output"]    (ReqArg (optOutName_s) "FILE")        "output to FILE"
+    , Option ['i'] ["include"]   (ReqArg (optIncdirs_u . idu) "DIR")   "library directory"
hunk ./Options.hs 122
-    , Option []    ["progc"]     (ReqArg (\d -> optCC_s d) "CC") "c compiler to use"
+    , Option []    ["progc"]     (ReqArg (\d -> optCC_s d) "gcc")      "c compiler to use"
hunk ./Options.hs 124
-    , Option ['N'] ["noprelude"] (NoArg  (optPrelude_s False))   "no implicit prelude"
-    , Option ['C'] []            (NoArg  (optMode_s CompileHoGrin))   "Typecheck, compile ho and grin."
-    , Option ['c'] []            (NoArg  (optMode_s CompileHo))   "Typecheck and compile ho."
-    , Option ['I'] ["interpret"] (NoArg  (optMode_s Interpret)) "interpret."
-    , Option ['k'] ["keepgoing"] (NoArg  (optKeepGoing_s True))  "keep going on errors."
+    , Option ['N'] ["noprelude"] (NoArg  (optPrelude_s False))         "no implicit prelude"
+    , Option ['C'] []            (NoArg  (optMode_s CompileHoGrin))    "Typecheck, compile ho and grin."
+    , Option ['c'] []            (NoArg  (optMode_s CompileHo))        "Typecheck and compile ho."
+    , Option ['I'] ["interpret"] (NoArg  (optMode_s Interpret))        "interpret."
+    , Option ['k'] ["keepgoing"] (NoArg  (optKeepGoing_s True))        "keep going on errors."
hunk ./Options.hs 133
-    , Option []    ["debug"]     (NoArg  (optDebug_s True)) "debugging"
+    , Option []    ["debug"]     (NoArg  (optDebug_s True))            "debugging"
hunk ./Options.hs 135
-    , Option []    ["noauto"]    (NoArg  (optNoAuto_s True)) "Don't automatically load base and haskell98 packages"
+    , Option []    ["noauto"]    (NoArg  (optNoAuto_s True))           "Don't automatically load base and haskell98 packages"
hunk ./Options.hs 137
-    , Option ['L'] []            (ReqArg (optHlPath_u . idu) "path") "Look for haskell libraries in the given directory."
+    , Option ['L'] []            (ReqArg (optHlPath_u . idu) "path")   "Look for haskell libraries in the given directory."
hunk ./Options.hs 139
-    , Option []    ["interactive"] (NoArg  (optMode_s Interactive)) "run interactivly"
-    , Option []    ["ignore-ho"]  (NoArg  (optIgnoreHo_s True)) "Ignore existing haskell object files"
-    , Option []    ["nowrite-ho"] (NoArg  (optNoWriteHo_s True)) "Do not write new haskell object files"
-    , Option []    ["no-ho"]      (NoArg  (optNoWriteHo_s True . optIgnoreHo_s True)) "same as --ignore-ho and --nowrite-ho"
+    , Option []    ["interactive"] (NoArg  (optMode_s Interactive))    "run interactivly"
+    , Option []    ["ignore-ho"]   (NoArg  (optIgnoreHo_s True))       "Ignore existing haskell object files"
+    , Option []    ["nowrite-ho"]  (NoArg  (optNoWriteHo_s True))      "Do not write new haskell object files"
+    , Option []    ["no-ho"]       (NoArg  (optNoWriteHo_s True . optIgnoreHo_s True)) "same as --ignore-ho and --nowrite-ho"
hunk ./Options.hs 144
-    , Option []    ["selftest"]   (NoArg  (optMode_s SelfTest)) "Perform internal integrity testing"
-    , Option []    ["list-libraries"]   (NoArg  (optMode_s ListLibraries)) "List of installed libraries."
+    , Option []    ["selftest"]       (NoArg  (optMode_s SelfTest))    "Perform internal integrity testing"
+    , Option []    ["list-libraries"] (NoArg  (optMode_s ListLibraries)) "List of installed libraries."
hunk ./Stats.hs 1
-module Stats(Stats,new,tick,setPrintStats,ticks,getTicks,Stats.print,clear,MonadStats(..),combine, printStat, Stat, mtick, mticks, runStatT, runStatIO, tickStat, StatT, theStats,StatM,runStatM ) where
+module Stats(
+    -- mutable
+    Stats,
+    new,
+    tick,
+    setPrintStats,
+    ticks,
+    theStats,
+    getTicks,
+    Stats.print,
+    clear,
+    combine,
+    -- pure
+    printStat,
+    printLStat,
+    Stat,
+    prependStat,
+    -- monad
+    MonadStats(..),
+    StatT,
+    StatM,
+    mtick,
+    mticks,
+    runStatT,
+    runStatIO,
+    runStatM,
+    -- combined
+    tickStat
+    ) where
hunk ./Stats.hs 51
-data Stats = Stats !(IORef Int) !(H.HashTable Atom Int)
hunk ./Stats.hs 52
+-- Stateful stats
hunk ./Stats.hs 54
+data Stats = Stats !(IORef Int) !(H.HashTable Atom Int)
hunk ./Stats.hs 69
-    --c <- readIORef c2
-    --modifyIORef c1 (+ c)
hunk ./Stats.hs 73
-
hunk ./Stats.hs 84
-
hunk ./Stats.hs 99
-splitUp str = filter (not . null) (f str)  where
-    f str = case span (`notElem` ".{") str  of
+splitUp :: Int -> String -> [String]
+splitUp n str = filter (not . null) (f n str)  where
+    f 0 str = []
+    f n str = case span (`notElem` "/.{") str  of
hunk ./Stats.hs 104
-        (x,('.':rs)) -> x:f rs
+        (x,('/':rs)) -> x:f (n - 1) rs
+        (x,('.':rs)) -> x:f n rs
hunk ./Stats.hs 107
-            (a,'}':b) -> x:a:f b
+            (a,'}':b) -> x:a:f n b
hunk ./Stats.hs 115
-    --let fs = createForest 0 $ sort [(split (== '.') $ fromAtom x,y) | (x,y) <- l]
-    let fs = createForest 0 $ sort [(splitUp $ fromAtom x,y) | (x,y) <- l]
-    --CharIO.putErrLn greets
+    let fs = createForest 0 $ sort [(splitUp (-1) $ fromAtom x,y) | (x,y) <- l]
hunk ./Stats.hs 120
+
+
+
hunk ./Stats.hs 125
-    --[Node (concat $ intersperse "." (xs),y) [] | (xs,y) <- xs]
hunk ./Stats.hs 129
---createForest  xs = Node ("","") [ createTree [(xs,y)] | (xs,y) <- xs]
hunk ./Stats.hs 141
-tickStat ::  Stats -> Stat -> IO ()
-tickStat stats (Stat stat) = sequence_  [ ticks stats n a | (a,n) <- Map.toList stat]
-
-runStatIO :: MonadIO m =>  Stats -> StatT m a -> m a
-runStatIO stats action = do
-    (a,s) <- runStatT action
-    liftIO $ tickStat stats s
-    return a
hunk ./Stats.hs 142
-instance MonadStats IO where
-    mticks' 0 _ = return ()
-    mticks' n a = do
-        p <- readIORef printStats
-        when p (CharIO.putStrLn $ (show a ++ ": " ++ show n))
-        ticks theStats n a
hunk ./Stats.hs 148
+prependStat :: String -> Stat -> Stat
+prependStat name (Stat m) = Stat $ Map.fromList [ (toAtom $ "{" ++ name ++ "}." ++ fromAtom x,y) | (x,y) <- Map.toList m ]
+
hunk ./Stats.hs 152
-    let fs = createForest 0 $ sort [(splitUp $ fromAtom x,y) | (x,y) <- Map.toList s]
+    let fs = createForest 0 $ sort [(splitUp (-1) $ fromAtom x,y) | (x,y) <- Map.toList s]
hunk ./Stats.hs 157
-{-
-instance DocLike d => PPrint d Stat where
-    pprint (Stat s) =  ( draw . fmap p ) (Node (greets,0) fs)  where
-        fs = createForest 0 $ sort [(splitUp $ fromAtom x,y) | (x,y) <- Map.toList s]
+printLStat n greets (Stat s) = do
+    let fs = createForest 0 $ sort [(splitUp n $ fromAtom x,y) | (x,y) <- Map.toList s]
+    mapM_ CharIO.putErrLn $ ( draw . fmap p ) (Node (greets,0) fs)  where
hunk ./Stats.hs 162
--}
hunk ./Stats.hs 169
+-----------------
+-- pure + mutable
+-----------------
+
+
+tickStat ::  Stats -> Stat -> IO ()
+tickStat stats (Stat stat) = sequence_  [ ticks stats n a | (a,n) <- Map.toList stat]
+
+runStatIO :: MonadIO m =>  Stats -> StatT m a -> m a
+runStatIO stats action = do
+    (a,s) <- runStatT action
+    liftIO $ tickStat stats s
+    return a
+
+getStat :: Stats -> IO Stat
+getStat stats = do
+    ll <- toList stats
+    return (Stat $ Map.fromList ll)
+
+--------------
+-- monad stats
+--------------
+
+
+class Monad m => MonadStats m where
+    mticks' ::  Int -> Atom -> m ()
+
hunk ./Stats.hs 209
-class Monad m => MonadStats m where
-    mticks' ::  Int -> Atom -> m ()
hunk ./Stats.hs 213
-mtick k = mticks' 1 (toAtom k)
+mtick k = mticks 1 k
hunk ./Stats.hs 217
---instance (Monad m, Monad (t m), MonadTrans t, MonadReader r m) => MonadReader r (t m) where
---    ask = lift $ ask
-  --  (r -> r) ->  m a -> t m a
-  --  (r -> r) -> m a -> m a
-  --  local l m = local l m
-  --  mticks' n k = lift $ mticks' n k
hunk ./Stats.hs 232
+instance MonadStats IO where
+    mticks' 0 _ = return ()
+    mticks' n a = do
+        p <- readIORef printStats
+        when p (CharIO.putStrLn $ (show a ++ ": " ++ show n))
+        ticks theStats n a