Compare.hs 2.79 KB
Newer Older
Ben Gamari's avatar
Ben Gamari committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92
import Data.Align
import Data.Maybe
import Data.These
import Data.List (intercalate)
import Data.Foldable
import Numeric
import qualified Data.Tree as Tree
import Data.Tree (Tree)
import qualified Data.Map.Strict as M
import System.FilePath
import Text.Tabular
import Text.Tabular.AsciiArt
import Options.Applicative

import qualified MeasurementTree as MTree
import MeasurementTree (MeasurementTree')

args :: Parser [FilePath]
args = some $ argument str (metavar "FILE" <> help "results.json file")

-- | Hackily align decimal numbers.
padDecimal :: RealFloat a
           => Int    -- ^ how many columns before the point
           -> Int    -- ^ how many digits after the point
           -> a -> String
padDecimal before after x =
    let s = showGFloat (Just after) x ""
        pad = before - length (takeWhile (/= '.') s)
     in replicate pad ' ' ++ s
    

main :: IO ()
main = do
    files <- execParser $ info (helper <*> args) mempty
    mtrees <- mapM (fmap fromJust . MTree.readFile) files
    let aligned = alignMany $ M.fromList $ zip (map takeFileName files) mtrees
    putStrLn 
        $ unlines
        [ unlines
          [ ""
          , intercalate "/" $ map MTree.getLabel path
          , replicate 20 '='
          , ""
          , render MTree.getLabel id (maybe "-" (\x -> showGFloat (Just 3) x "")) table
          ]
        | (path, table) <- Tree.flatten $ toTables aligned
        , Table _ _ (_:_) <- pure table
        ]

alignMany :: Ord k => M.Map k (MeasurementTree' a) -> MeasurementTree' (M.Map k a)
alignMany mtrees =
    foldl1 (alignWith (mergeThese M.union))
    [ fmap (M.singleton label) mtree
    | (label, mtree) <- M.toList mtrees
    ]

toGroupTree :: MeasurementTree' (M.Map k a)
            -> Maybe (Tree ([MTree.Label], M.Map MTree.Label (M.Map k a)))
toGroupTree = toTree []
  where
    toTree :: [MTree.Label]
           -> MeasurementTree' (M.Map k a)
           -> Maybe (Tree ([MTree.Label], M.Map MTree.Label (M.Map k a)))
    toTree path (MTree.Group children) =
        Just $ Tree.Node (reverse path, samples) subgroups
      where
        samples = M.mapMaybe MTree.isSample children
        subgroups = mapMaybe (\(k, xs) -> toTree (k:path) xs) (M.toList children)
    toTree path _ = Nothing

toTables 
    :: Ord k
    => MeasurementTree' (M.Map k a)
    -> Tree ([MTree.Label], Table MTree.Label k (Maybe a))
toTables mtree
  | Just tree <- toGroupTree mtree = fmap (fmap toTable) tree
  | otherwise = error "empty measurement tree"

toTable :: (Ord r, Ord c)
        => M.Map r (M.Map c a)
        -> Table r c (Maybe a)
toTable xs =
    Table
        (Group NoLine $ map Header $ M.keys xs)
        (Group NoLine $ map Header allKeys)
        [ [ M.lookup k ys
          | k <- allKeys
          ]
        | ys <- M.elems xs
        ]
  where
    allKeys = toList $ foldMap M.keysSet xs