Factor out parsing core to Grade.GradeIO

diff --git a/grade.cabal b/grade.cabal
index 06335f450b1bc0c03d3265b6fd4eee199f6556fa..b62ba7a50b0a75e78e1ca83a72c22bcac126a6e1 100644 (file)
--- a/grade.cabal
+++ b/grade.cabal
@@ -17,6 +17,7 @@ library
                        Grade.ParseUtils,
                        Grade.Parse,
                        Grade.Grade,
+                       Grade.GradeIO,
                        Grade.Score.Zeroing,
                        Grade.Score.Setting,
                        Grade.Score.Bounding,
@@ -37,6 +38,7 @@ library
                        parsers >=0.12 && <1,
                        text >=1.2 && <2,
                        trifecta >=1.5 && <2,
+                       ansi-wl-pprint >= 0.6 && <1,
                        wl-pprint-extras >=3.5 && <4
 
 executable grade

diff --git a/lib/Grade/GradeIO.hs b/lib/Grade/GradeIO.hs
new file mode 100644 (file)
index 0000000..6bb9b48
--- /dev/null
+++ b/lib/Grade/GradeIO.hs
@@ -0,0 +1,77 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+
+module Grade.GradeIO (
+  withDefines, withDefinesOrElse,
+  withReport, withReportDoc
+) where
+
+import           System.Exit (ExitCode(..), exitWith)
+import           System.IO (hPutStrLn, stderr)
+import qualified Text.PrettyPrint.ANSI.Leijen as TPP
+import qualified Text.PrettyPrint.Free        as PP
+import qualified Text.Trifecta                as T
+import qualified Text.Trifecta.Delta          as T
+
+import           Grade.Types
+import           Grade.Parse
+import           Grade.Print
+import           Grade.Grade
+
+
+withDefines :: T.Parser (ExSecCallback T.Parser)
+            -> FilePath
+            -> (Defines T.Parser T.Caret -> IO a)
+            -> IO (Either TPP.Doc a)
+withDefines sectys defi act = do
+  mdefines <- T.parseFromFileEx (parseDefns sectys) defi
+  case mdefines of
+    T.Failure f -> parseErr f
+    T.Success defs -> Right <$> act defs
+ where
+  parseErr f = pure $ Left (        "Error while parsing defines" TPP.<+> TPP.pretty defi TPP.<> ":"
+                            TPP.</> f)
+
+
+withDefinesOrElse :: T.Parser (ExSecCallback T.Parser)
+                  -> FilePath
+                  -> (Defines T.Parser T.Caret -> IO a)
+                  -> IO a
+withDefinesOrElse sectys defi act = withDefines sectys defi act >>= eh
+ where
+  eh (Left f) = do
+      hPutStrLn stderr (show f)
+      exitWith (ExitFailure 2)
+  eh (Right a) = pure a
+
+withReport :: Defines T.Parser T.Caret
+           -> FilePath
+           -> (ReportFile -> IO r)
+           -> IO (Either (PP.Doc e) r)
+withReport defs dati act = do
+  mdata <- T.parseFromFileEx (parseData defs) dati
+  case mdata of
+    T.Failure e -> parseErr (PP.pretty $ show e) -- XXX; sadness and woe
+    T.Success (dats, errs) ->
+      case errs of
+        [] -> case gradeOne defs dats of
+                Left e -> gradeErr (vmpesc e)
+                Right r -> Right <$> act r
+        _  -> parseErr (vmpesc errs)
+
+  where
+   parseErr e = pure $ Left ("Error while parsing data file" PP.<+> PP.pretty dati PP.<> ":" PP.</> e)
+   gradeErr e = pure $ Left ("Error while grading" PP.<+> PP.pretty dati PP.<> ":" PP.</> e)
+   vmpesc e = PP.vcat (map (printReportError showcaret) e)
+   showcaret = PP.text . show . TPP.pretty . T.delta
+
+withReportDoc :: Defines T.Parser T.Caret
+              -> FilePath
+              -> (forall e . PP.Doc e -> IO ())
+              -> IO Bool
+withReportDoc defs dati act = withReport defs dati (act . printReport) >>= eh
+ where
+  eh (Left d) = PP.hPutDoc stderr d >> pure False
+  eh (Right ()) = pure True
+
+

diff --git a/prog/Grade.hs b/prog/Grade.hs
index 195c6bc294d6d9f5eee1944ee018dd546ee7e2b9..dd3d44f980306990c9a1b732c662f417481b4c1b 100644 (file)
--- a/prog/Grade.hs
+++ b/prog/Grade.hs
@@ -1,7 +1,6 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Main where
@@ -9,10 +8,8 @@ module Main where
 import           Control.Monad (when)
 import           Data.Data (Data)
 
-import qualified Text.PrettyPrint.ANSI.Leijen as TPP
 import qualified Text.PrettyPrint.Free        as PP
 import qualified Text.Trifecta                as T
-import qualified Text.Trifecta.Delta          as T
 
 import qualified System.Console.CmdLib        as C
 import           System.Directory
@@ -21,9 +18,8 @@ import           System.Exit
 import           System.IO
 
 import           Grade.Parse
-import           Grade.Grade
 import           Grade.Skeleton
-import           Grade.Print
+import           Grade.GradeIO
 
 import qualified Grade.Score.EqualWeighted  as GSE
 import qualified Grade.Score.Simple         as GSS
@@ -66,50 +62,14 @@ doMakeSkeleton defi = do
     T.Failure f -> hPutStrLn stderr (show f)
     T.Success d -> print $ makeSkel d
 
-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 -> 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
+doGradeOne defi dati = withDefinesOrElse sectys defi $ \defs -> do
+  withReportDoc defs dati (\d -> PP.hPutDoc stdout d) >>= \case
     True  -> pure ()
     False -> exitWith (ExitFailure 1)
 
 doGradeDir :: Int -> String -> FilePath -> FilePath -> IO ()
-doGradeDir verbose defi datd outd = withDefinesOrElse defi $ \defs -> do
+doGradeDir verbose defi datd outd = withDefinesOrElse sectys defi $ \defs -> do
   createDirectoryIfMissing True outd
   dentries <- getDirectoryContents datd
   oks <- flip mapM dentries $ \dentry -> do
@@ -119,8 +79,8 @@ doGradeDir verbose defi datd outd = withDefinesOrElse defi $ \defs -> do
                  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)
+                 withReportDoc defs (datd </> dentry) $ \d ->
+                   withFile (outd </> dentry) WriteMode (flip PP.hPutDoc d)
   exitWith $ if and oks then ExitSuccess else ExitFailure 1
 
 data Cmd = MakeSkeleton { defines :: String }