content: {-# LANGUAGE ExistentialQuantification #-}
  {-# LANGUAGE NamedFieldPuns #-}
  
  import Control.Applicative hiding (optional, many)
  import Control.Monad
  import System.Directory
  import Text.ParserCombinators.ReadP
  import Data.Char
  import Data.List
  import Text.PrettyPrint hiding (char)
  import Text.Printf
  import Data.Monoid
  import System.Environment
  
  type Bytes = Integer
  type MegaBytes = Integer
  type Seconds = Float
  type Percent = Float
  type BytesPerSecond = Bytes
  type Metas = Integer
  
  data Statistics = Stats
        { command              :: String
        , memoryInUse          :: MegaBytes
        , totalTime            :: Seconds
        , numberOfMetas        :: Metas
        , attemptedConstraints :: Integer
        , maxMetas             :: Integer
        , maxConstraints       :: Integer
        }
  
  instance Show Statistics where
    show (Stats _ mem time meta cs maxMeta maxCs) =
      printf "%6.2fs - %4dMB - %5d (%3d) metas - %5d (%3d) constraints" time mem meta maxMeta cs maxCs
  
  noStats = Stats "true" 0 0
  
  notP :: ReadP a -> ReadP ()
  notP p = do
    s <- look
    case readP_to_S p s of
      []  -> return ()
      _   -> pfail
  
  -- Greedy version of many
  many' :: ReadP a -> ReadP [a]
  many' p = many p <* notP p
  
  orElse :: ReadP a -> ReadP a -> ReadP a
  orElse p q = p +++ (notP p *> q)
  
  munchTo :: Char -> ReadP String
  munchTo c = munch (c /=) <* char c
  
  lineP :: ReadP String
  lineP = munchTo '\n'
  
  integerP :: ReadP Integer
  integerP = do
    skipSpaces
    s <- filter (/=',') <$> munch1 (`elem` (',':['0'..'9']))
    guard (not $ null s)
    return $ read s
  
  bytesP :: ReadP Bytes
  bytesP = integerP <* skipSpaces <* string "bytes"
  
  megaBytesP :: ReadP MegaBytes
  megaBytesP = integerP <* skipSpaces <* (string "Mb" +++ string "MB" +++ string "MiB")
  
  floatP :: ReadP Float
  floatP = do
    skipSpaces
    s <- munch1 (`elem` ('.':['0'..'9']))
    return $ read s
  
  timeP :: ReadP Seconds
  timeP = floatP <* char 's'
  
  percentP :: ReadP Percent
  percentP = floatP <* char '%'
  
  metaP :: ReadP Metas
  metaP = munchTo ':' *> integerP <* string " metas" <* lineP
  
  collectionP :: ReadP (Integer, Seconds)
  collectionP = (,) <$> integerP <* munchTo '(' <*> timeP <* lineP
  
  data Ticks = Tick String Integer
    deriving (Show)
  
  tickP = Tick <$> label <*> integerP <* lineP
    where
      label = unwords <$> many (munch (== ' ') *> munch1 (not . isSpace))
  
  ticksP =
    string "Accumulated statistics" *> lineP *> many' tickP
  
  statsP :: ReadP Statistics
  statsP = do
    ticks <- ticksP `orElse` return []
    let numberOfMetas        = sum [ n | Tick "metas" n <- ticks ]
        attemptedConstraints = sum [ n | Tick "attempted-constraints" n <- ticks ]
        maxMetas             = maximum $ 0 : [ n | Tick "max-open-metas" n <- ticks ]
        maxConstraints       = maximum $ 0 : [ n | Tick "max-open-constraints" n <- ticks ]
    command <- lineP
    many lineP
    memoryInUse <- skipSpaces *> megaBytesP <* skipSpaces <* string "total memory" <* lineP
    let timeReport s = skipSpaces *> string s *> skipSpaces *> string "time" *> timeP <* lineP
    many lineP
    totalTime <- timeReport "Total"
    many lineP
    return $ Stats
      { command
      , memoryInUse
      , totalTime
      , numberOfMetas
      , attemptedConstraints
      , maxMetas
      , maxConstraints
      }
  
  file = "logs/ulf-norells-macbook-pro-20081126-12.59/syntax1"
  
  runReadP p s =
    case readP_to_S p s of
      (x, _):_ -> x
      []       -> error $ "no parse:\n" ++ s
  
  parseFile file = do
    s <- readFile file
    case readP_to_S statsP s of
      (stats, s'):_ -> return stats
      []            -> error $ "no parse: " ++ file ++ "\n" ++ s
  
  isProperFile ('.':_)  = False
  isProperFile "README" = False
  isProperFile _        = True
  
  dirContents dir = filter isProperFile <$> getDirectoryContents dir
  
  logDirs :: IO [FilePath]
  logDirs = dirContents "logs"
  
  logs :: IO [Log]
  logs = map read <$> logDirs
  
  readLogs :: Log -> IO [(FilePath, Statistics)]
  readLogs l = do
    let dir = "logs/" ++ logDir l
    xs <- dirContents dir
    mapM (\s -> (,) s <$> parseFile (dir ++ "/" ++ s)) xs
  
  data Log = Log { machine   :: String
                 , timeStamp :: String
                 }
    deriving (Show)
  
  logDir :: Log -> FilePath
  logDir (Log m t) = t ++ "-" ++ m
  
  instance Read Log where
    readsPrec _ = readP_to_S $ do
      d <- count 8 $ satisfy isDigit
      char '-'
      hh <- count 2 $ satisfy isDigit
      char '.'
      mm <- count 2 $ satisfy isDigit
      char '-'
      m <- many1 get
      return $ Log m (d ++ "-" ++ hh ++ "." ++ mm)
  
  data Attr = forall a. Show a => Attr String (Statistics -> a)
  
  stats :: (Log -> Bool) -> (FilePath -> Bool) -> [Attr] -> IO ()
  stats goodLog goodCase attrs = do
    ls <- filter goodLog <$> logs
    mapM_ printStat ls
    where
      printStat l = do
        putStrLn $ logDir l
        cs <- filter (goodCase . fst) <$> readLogs l
        let w = maximum $ 0 : [ length name | (name, _) <- cs ]
        print $ vcat $ map (prAttrs w) cs
      prAttrs w (c, s) = nest 2 $ text (pad c) <+> vcat (map (prAttr s) attrs)
        where
          pad s = s ++ replicate (w - length s) ' ' ++ ":"
      prAttr s (Attr name f) = text (show (f s))
  
  time = stats (const True) (const True) [Attr "time" totalTime]
  mem  = stats (const True) (const True) [Attr "space" memoryInUse]
  
  summary = stats (const True) (const True) [Attr "stats" id]
  
  main = do
    args <- getArgs
    case args of
      []  -> summary
      [l] -> stats ((l `isInfixOf`) . logDir) (const True) [Attr "stats" id]
      _   -> do
        prog <- getProgName
        putStrLn $ "Usage: " ++ prog ++ " [LOG]"
  
  