Add grade-dir command for bulk processing

diff --git a/grade.cabal b/grade.cabal
index 126b613d1c23ff7407ae2b4ed1982e034de0d12e..b13d23db27637bae253dcc110fc0fd02792eb05b 100644 (file)
--- a/grade.cabal
+++ b/grade.cabal
@@ -45,6 +45,8 @@ executable grade
   other-extensions:    CPP
   build-depends:       base >=4.6 && <5,
                        cmdlib >= 0.3 && <1,
+                       directory >= 1.2 && <2,
+                       filepath >= 1.4 && <2,
                        trifecta >=1.5 && <2,
                        ansi-wl-pprint >= 0.6 && <1,
                        wl-pprint-extras >=3.5 && <4,

diff --git a/prog/Grade.hs b/prog/Grade.hs
index e7a867b983acba40afd532016f5e737439fe0952..195c6bc294d6d9f5eee1944ee018dd546ee7e2b9 100644 (file)
--- a/prog/Grade.hs
+++ b/prog/Grade.hs
@@ -1,8 +1,12 @@
 {-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Main where
 
+import           Control.Monad (when)
 import           Data.Data (Data)
 
 import qualified Text.PrettyPrint.ANSI.Leijen as TPP
@@ -11,6 +15,9 @@ import qualified Text.Trifecta                as T
 import qualified Text.Trifecta.Delta          as T
 
 import qualified System.Console.CmdLib        as C
+import           System.Directory
+import           System.FilePath
+import           System.Exit
 import           System.IO
 
 import           Grade.Parse
@@ -59,54 +66,102 @@ doMakeSkeleton defi = do
     T.Failure f -> hPutStrLn stderr (show f)
     T.Success d -> print $ makeSkel d
 
-doGradeOne :: String -> String -> IO ()
-doGradeOne defi dati = do
+withDefinesOrElse :: FilePath -> (Defines T.Parser T.Caret -> IO a) -> IO a
+withDefinesOrElse defi act = do
   mdefines <- T.parseFromFileEx (parseDefns sectys) defi
   case mdefines of
-    T.Failure f -> hPutStrLn stderr "Error while parsing defines:"
-                   *> hPutStrLn stderr (show f)
-    T.Success defs -> do
-      mdata <- T.parseFromFileEx (parseData defs) dati
-      case mdata of
-        T.Failure f -> hPutStrLn stderr "Error while parsing data:"
-                       *> hPutStrLn stderr (show f)
-        T.Success (dats, errs) -> case errs of
-                                    [] -> case gradeOne defs dats of
-                                            Left e -> do
-                                                       hPutStrLn stderr "Error while grading:"
-                                                       hPutStrLn stderr $ show $ PP.vcat
-                                                                        $ map (printReportError showcaret) e
-                                            Right r -> print $ printReport r
-                                    _  -> do
-                                           hPutStrLn stderr "Error while parsing data:"
-                                           hPutStrLn stderr $ show $ PP.vcat
-                                                            $ map (printReportError showcaret) errs
+    T.Failure f -> do
+      hPutStrLn stderr "Error while parsing defines:"
+      hPutStrLn stderr (show f)
+      exitWith (ExitFailure 2)
+    T.Success defs -> act defs
+
+grade :: Defines T.Parser T.Caret -> FilePath -> (forall e . PP.Doc e -> IO Bool) -> IO Bool
+grade defs dati act = do
+  mdata <- T.parseFromFileEx (parseData defs) dati
+  case mdata of
+    T.Failure f -> do
+       hPutStrLn stderr $ "Error while parsing data file " ++ dati ++ ":"
+       hPutStrLn stderr (show f)
+       pure False
+    T.Success (dats, errs) ->
+      case errs of
+        [] -> case gradeOne defs dats of
+                Left e -> do
+                  hPutStrLn stderr $ "Error while grading " ++ dati ++ ":"
+                  hPutStrLn stderr $ show $ PP.vcat
+                                   $ map (printReportError showcaret) e
+                  pure False
+                Right r -> act (printReport r)
+        _  -> do
+               hPutStrLn stderr $ "Error while parsing data file " ++ dati ++ ":"
+               hPutStrLn stderr $ show $ PP.vcat
+                                $ map (printReportError showcaret) errs
+               pure False
 
   where
    showcaret = PP.text . show . TPP.pretty . T.delta
 
+doGradeOne :: FilePath -> FilePath -> IO ()
+doGradeOne defi dati = withDefinesOrElse defi $ \defs -> do
+  grade defs dati (\d -> PP.hPutDoc stdout d *> pure True) >>= \case
+    True  -> pure ()
+    False -> exitWith (ExitFailure 1)
+
+doGradeDir :: Int -> String -> FilePath -> FilePath -> IO ()
+doGradeDir verbose defi datd outd = withDefinesOrElse defi $ \defs -> do
+  createDirectoryIfMissing True outd
+  dentries <- getDirectoryContents datd
+  oks <- flip mapM dentries $ \dentry -> do
+             doesFileExist (datd </> dentry) >>= \ case
+               False -> do
+                 when (verbose > 1) $ hPutStrLn stderr $ "Skipping " ++ dentry ++ ": is directory"
+                 pure True  -- Skip inner directories
+               True -> do
+                 when (verbose > 0) $ hPutStrLn stderr $ "Grading " ++ dentry
+                 grade defs (datd </> dentry)
+                       (\d -> withFile (outd </> dentry) WriteMode (flip PP.hPutDoc d) *> pure True)
+  exitWith $ if and oks then ExitSuccess else ExitFailure 1
 
 data Cmd = MakeSkeleton { defines :: String }
          | GradeOne { defines :: String, datafile :: String }
-         -- XXX TODO | GradeDir { defines :: String, in_dir :: String, out_dir :: String }
+         | GradeDir { defines :: String, inDir :: String, outDir :: String, verbose :: Int }
  deriving (Data,Eq,Show)
 instance C.Attributes Cmd
 instance C.RecordCommand Cmd where
   mode_summary (MakeSkeleton {}) = "Make grader skeleton from defines file"
   mode_summary (GradeOne {})     = "Grade one student file"
+  mode_summary (GradeDir {})     = "Grade a directory of student files"
 
-  rec_options (MakeSkeleton {}) = defines C.%> C.Default ("/dev/fd/0" :: String)
-                                          C.%+ C.Positional 0
-                                          C.%+ C.Required True
-  rec_options (GradeOne {})     = (defines C.%> C.Positional 0
-                                           C.%+ C.Required True)
+  rec_options (MakeSkeleton {}) = (defines  C.%> C.Default ("/dev/fd/0" :: String)
+                                            C.%+ C.Positional 0
+                                            C.%+ C.Required True)
+
+  rec_options (GradeOne {})     = (defines  C.%> C.Positional 0
+                                            C.%+ C.Required True)
                                   C.%%
                                   (datafile C.%> C.Long ["data"]
                                             C.%+ C.Help "grade data file"
                                             C.%+ C.Default ("/dev/fd/0" :: String))
 
-  run' (MakeSkeleton {defines = i}) _ = doMakeSkeleton i
-  run' (GradeOne { defines = defi, datafile = dati }) _ = doGradeOne defi dati
+  rec_options (GradeDir {})     = (defines  C.%> C.Positional 0
+                                            C.%+ C.Required True)
+                                  C.%%
+                                  (outDir   C.%> C.Positional 1
+                                            C.%+ C.Required True)
+                                  C.%%
+                                  (inDir    C.%> C.Positional 2
+                                            C.%+ C.Help "defaults to $PWD"
+                                            C.%+ C.Default ("." :: FilePath))
+                                  C.%%
+                                  (verbose  C.%> C.Long ["verbose"]
+                                            C.%+ C.ArgHelp "V"
+                                            C.%+ C.Help "be chatty (0 to 2)"
+                                            C.%+ C.Default (1 :: Int))
+
+  run' (MakeSkeleton {defines}) _ = doMakeSkeleton defines
+  run' (GradeOne {defines, datafile}) _ = doGradeOne defines datafile
+  run' (GradeDir {defines, inDir, outDir, verbose}) _ = doGradeDir verbose defines inDir outDir
 
 main' :: [String] -> IO ()
 main' ars = C.dispatchR [] ars >>= \(x :: Cmd) -> C.run' x []