Report.hs

-----------------------------------------------------------------------------
-- Copyright 2019, Advise-Me project team. This file is distributed under 
-- the terms of the Apache License 2.0. For more information, see the files
-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer  :  bastiaan.heeren@ou.nl
-- Stability   :  provisional
-- Portability :  portable (depends on ghc)
--
-----------------------------------------------------------------------------

module Main.Report where

import Control.Monad
import Data.List
import Data.Maybe (fromMaybe)
import Data.Semigroup
import Main.Tasks
import Ideas.Common.Id
import Ideas.Text.HTML
import Ideas.Text.XML
import Ideas.Text.HTML.W3CSS
import Ideas.Encoding.Logging
import Recognize.Data.MathStoryProblem
import Recognize.Data.DiagnoseResult
import Recognize.Data.Diagnosis
import Recognize.Data.Entry
import Recognize.Data.Solution
import System.IO
import Util.Cache
import Util.Table

import Control.Exception

reportDatabase :: FilePath -> FilePath -> IO ()
reportDatabase inFile outFile = do
   hSetBuffering stdout NoBuffering
   solutions <-
      selectFrom inFile "requests" ["rowid","input"] $ \[rowid,txt] -> fallback (rowid, (defaultSolution [], newId "error")) . either error id $ do
         xml <- parseXML txt
         exid <- newId <$> findAttribute "exerciseid" xml
         sol  <- findChild "solution" xml >>= fromXML
         return (rowid, (sol, exid))
   results <-
      forM solutions $ \(nr, (sol, exid)) -> fallback (mempty, mempty) . either error id $ do
         Task t <- findTask exid
         let entry = diagnose t sol
         let html  = header (string $ '#' : show nr) (string $ show exid)
                     <> toHTML entry
         return (html, countEntry exid entry)

   let (outs, counts) = unzip results
   writeFile outFile $ showHTML $ w3css $ htmlPage inFile $ mconcat outs
   --writeCache "cache.txt"
   putStrLn ""
   print (percentage $ mconcat counts)


-- | This is how we'll deal with errors for now: we just present a fallback
-- value, mention the error, and continue.
fallback :: a -> a -> IO a
fallback def val = do
   action <- try (evaluate val)
   case action of
      Left err -> do
         putStrLn "Warning - something went wrong. Continuing with default value. The error was:"
         print (err :: SomeException)
         return def
      Right result' -> return result'



header :: BuildXML a => a -> a -> a
header x y = container $ background DarkGray $
   styleA "padding:0" <>
   (Ideas.Text.XML.tag "div" . left . padding Medium) x <>
   (Ideas.Text.XML.tag "div" . right . padding Medium) y

countEntry :: Id -> Entry -> Tables Count
countEntry n = mconcat . map (countResult n) . diagnoses

countResult :: Id -> DiagnoseResult -> Tables Count
countResult n r =
   let i = getInputId (originalInput r)
   in count (show i ++ "." ++ show n) . either (const "error") (show . category) . diagnosis $ r