diff --git a/src/MA/Algorithm.hs b/src/MA/Algorithm.hs index b5d62cca02c627da65c743a4dfa6fcb9f6875aae..9158032ac718e21f1557c100a3b18355b44f1299 100644 --- a/src/MA/Algorithm.hs +++ b/src/MA/Algorithm.hs @@ -37,6 +37,6 @@ refine Proxy encoding = do (blocks, state) <- initialize @f encoding mapM_ (Queue.enqueue queue) blocks - processQueue queue state + processQueue queue state Partition.freeze (partition state) diff --git a/src/main/Main.hs b/src/main/Main.hs index 210fc01ebee3ecd17c92caa53403256182717211..30b019b184ec4caf5057341d754d68f646e4e35a 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -119,27 +119,36 @@ data Stats = Stats } initStats :: Bool -> Bool -> IO Stats -initStats statsText statsJson = case (statsText, statsJson) of - (False, False) -> return (Stats NoStats undefined) - (True, False) -> return (Stats TextStats undefined) - (False, True) -> Stats JsonStats <$> newIORef M.empty - (True, True) -> do - hPutStrLn stderr "Invalid command line options: --stats and --stats-json cannot be used together." - exitFailure +initStats statsText statsJson = + case (statsText, statsJson) of + (False, False) -> return (Stats NoStats undefined) + (True, False) -> return (Stats TextStats undefined) + (False, True) -> Stats JsonStats <$> newIORef M.empty + (True, True) -> do + hPutStrLn + stderr + "Invalid command line options: --stats and --stats-json cannot be used together." + exitFailure logStat :: Stats -> Text -> Text -> IO () -logStat stats key value = case statsType stats of - NoStats -> return () - TextStats -> T.hPutStrLn stderr $ key <> ": " <> value - JsonStats -> modifyIORef (statsState stats) (M.insert key value) +logStat stats key value = + case statsType stats of + NoStats -> return () + TextStats -> T.hPutStrLn stderr $ key <> ": " <> value + JsonStats -> modifyIORef (statsState stats) (M.insert key value) finalizeStats :: Stats -> IO () -finalizeStats stats = case statsType stats of - JsonStats -> do - m <- readIORef (statsState stats) - let json = toJSObject (map (T.unpack *** (JSString . toJSString . T.unpack)) (M.toList m)) - hPutStrLn stderr $ showJSObject json "" - _ -> return () +finalizeStats stats = + case statsType stats of + JsonStats -> do + m <- readIORef (statsState stats) + let json = + toJSObject + (map + (T.unpack *** (JSString . toJSString . T.unpack)) + (M.toList m)) + hPutStrLn stderr $ showJSObject json "" + _ -> return () ---------------------------------------------------------------------- -- File handling @@ -182,12 +191,18 @@ main = do logStat stats "edges" (T.pack $ show (Encoding.numEdges encoding)) let isFirstSort x = sortedSort x == 1 - logStat stats "explicit-states" (T.pack $ show (length (V.filter isFirstSort (Encoding.structure encoding)))) + logStat + stats + "explicit-states" + (T.pack $ show (length (V.filter isFirstSort (Encoding.structure encoding)))) partition <- withTime stats "refine-duration" (stToIO (refine f encoding)) - logStat stats "final-partition-size" (T.pack $ show (Partition.numBlocks partition)) + logStat + stats + "final-partition-size" + (T.pack $ show (Partition.numBlocks partition)) withTime stats "output-duration" (outputPartition (refineOutputFile r) encoding symbolTable partition)