Change to Reader Config IO (#53)

Author: jhb563

app/Main.hs

@@ -1,7 +1,8 @@
 module Main where
 
-import           Data.Map           (empty)
-import           Data.Tuple.Extra   (uncurry3)
+import           Control.Monad.Reader
+import           Data.Map             (empty)
+import           Data.Tuple.Extra     (uncurry3)
 import           System.Environment
 import           System.IO
 
@@ -27,20 +28,20 @@ main = do
           Left NoStackPackageDbError -> putStrLn "Couldn't find an appropriate stack package DB!"
           Right paths -> do
             let config = uncurry3 ProgramConfig paths mainProjectExercisesDir stdin stdout stderr empty
-            runCommand config (tail args) (head args)
+            runReaderT (runCommand (tail args) (head args)) config
 
-runCommand :: ProgramConfig -> [String] -> String -> IO ()
-runCommand config restArgs command = case command of
+runCommand :: [String] -> String -> ReaderT ProgramConfig IO ()
+runCommand restArgs command = case command of
   "run" -> if null restArgs
-    then progPutStrLn config "Run command requires an exercise name!"
-    else runExercise config (head restArgs)
-  "watch" -> watchExercises config
+    then progPutStrLn "Run command requires an exercise name!"
+    else runExercise (head restArgs)
+  "watch" -> watchExercises
   "exec" -> if null restArgs
-    then progPutStrLn config "Exec command requires an exercise name!"
-    else execExercise config (head restArgs)
-  "version" -> putStrLn haskellingsVersion
-  "list" -> listExercises config
+    then progPutStrLn "Exec command requires an exercise name!"
+    else execExercise (head restArgs)
+  "version" -> progPutStrLn haskellingsVersion
+  "list" -> listExercises
   "hint" -> if null restArgs
-    then progPutStrLn config "Hint command requires an exercise name!"
-    else hintExercise config (head restArgs)
-  _ -> runHelp
+    then progPutStrLn "Hint command requires an exercise name!"
+    else hintExercise (head restArgs)
+  _ -> lift runHelp

haskellings.cabal

@@ -44,6 +44,7 @@ library
     , extra
     , filepath
     , fsnotify
+    , mtl
     , tasty
     , tasty-hunit
     , process
@@ -65,6 +66,7 @@ executable haskellings
     , containers
     , extra
     , haskellings
+    , mtl
   default-language: Haskell2010
 
 test-suite haskellings-tests
@@ -81,6 +83,7 @@ test-suite haskellings-tests
     , haskellings
     , hspec
     , HUnit
+    , mtl
     , time
   default-language: Haskell2010
 

src/DirectoryUtils.hs

@@ -1,17 +1,21 @@
-{- Utility functions for manipulating filepaths and directories.
--}
+{- Utility functions for manipulating filepaths and directories. -}
+
+{-# LANGUAGE FlexibleContexts #-}
+
 module DirectoryUtils where
 
 import           Control.Concurrent
-import           Control.Exception  (catch)
+import           Control.Exception          (catch)
+import           Control.Monad.IO.Class
+import           Control.Monad.Reader.Class
 import           Data.Char
-import           Data.List          (isSuffixOf)
-import           Data.List.Extra    (upper)
-import qualified Data.Map           as M
-import qualified Data.Sequence      as S
+import           Data.List                  (isSuffixOf)
+import           Data.List.Extra            (upper)
+import qualified Data.Map                   as M
+import qualified Data.Sequence              as S
 import           System.Directory
-import           System.FilePath    (takeBaseName, takeFileName, (</>))
-import           System.Info        (os)
+import           System.FilePath            (takeBaseName, takeFileName, (</>))
+import           System.Info                (os)
 
 import           Types
 
@@ -40,22 +44,24 @@ fullExerciseFp :: FilePath -> FilePath -> ExerciseInfo -> FilePath
 fullExerciseFp projectRoot exercisesExt (ExerciseInfo exName exDir _ _) =
   projectRoot </> exercisesExt </> exDir </> haskellFileName exName
 
-withFileLock :: FilePath -> ProgramConfig -> IO a -> IO a
-withFileLock fp config action = case M.lookup fp (fileLocks config) of
-  Nothing -> action
-  Just lock -> do
-    putMVar lock ()
-    result <- action
-    takeMVar lock
-    return result
+withFileLock :: (MonadIO m, MonadReader ProgramConfig m) => FilePath -> m a -> m a
+withFileLock fp action = do
+  maybeLock <- M.lookup fp <$> asks fileLocks
+  case maybeLock of
+    Nothing -> action
+    Just lock -> do
+      liftIO $ putMVar lock ()
+      result <- action
+      liftIO $ takeMVar lock
+      return result
 
 -- Create a directory. Run the action depending on that directory,
 -- and then clean the directory up.
-withDirectory :: FilePath -> IO a -> IO a
+withDirectory :: (MonadIO m) => FilePath -> m a -> m a
 withDirectory dirPath action = do
-  createDirectoryIfMissing True dirPath
+  liftIO $ createDirectoryIfMissing True dirPath
   res <- action
-  removeDirectoryRecursive dirPath
+  liftIO $ removeDirectoryRecursive dirPath
   return res
 
 returnIfDirExists :: FilePath -> IO (Maybe FilePath)

src/Processor.hs

@@ -5,40 +5,40 @@
 -}
 module Processor where
 
-import           Control.Monad   (forM_, void, when)
-import           Data.Maybe      (fromJust, isJust)
+import           Control.Monad.Reader
+import           Data.Maybe           (fromJust, isJust)
 import           System.Exit
-import           System.FilePath ((</>))
+import           System.FilePath      ((</>))
 import           System.IO
 import           System.Process
 
 import           DirectoryUtils
 import           TerminalUtils
 import           Types
 
-executeExercise :: ProgramConfig -> ExerciseInfo -> IO ()
-executeExercise config exInfo@(ExerciseInfo exerciseName _ _ _) = do
-  let (processSpec, genDirPath, genExecutablePath) = createExerciseProcess config exInfo
-  let exFilename = haskellFileName exerciseName
+executeExercise :: ExerciseInfo -> ReaderT ProgramConfig IO ()
+executeExercise exInfo@(ExerciseInfo exerciseName _ _ _) = do
+  config <- ask
+  let (processSpec, genDirPath, genExecutablePath, exFilename) = createExerciseProcess config exInfo
   withDirectory genDirPath $ do
-    (_, _, procStdErr, procHandle) <- createProcess (processSpec { std_out = CreatePipe, std_err = CreatePipe })
-    exitCode <- waitForProcess procHandle
+    (_, _, procStdErr, procHandle) <- lift $ createProcess (processSpec { std_out = CreatePipe, std_err = CreatePipe })
+    exitCode <- lift $ waitForProcess procHandle
     case exitCode of
-      ExitFailure code -> void $ onCompileFailure config exFilename procStdErr
+      ExitFailure code -> void $ onCompileFailure exFilename procStdErr
       ExitSuccess -> do
-        progPutStrLnSuccess config $ "Successfully compiled: " ++ exFilename
-        progPutStrLn config $ "----- Executing file: " ++ exFilename ++ " -----"
+        progPutStrLnSuccess $ "Successfully compiled: " ++ exFilename
+        progPutStrLn $ "----- Executing file: " ++ exFilename ++ " -----"
         let execSpec = shell genExecutablePath
-        (_, _, _, execProcHandle) <- createProcess execSpec
-        void $ waitForProcess execProcHandle
+        (_, _, _, execProcHandle) <- lift $ createProcess execSpec
+        void $ lift $ waitForProcess execProcHandle
 
 -- Produces 3 Elements for running our exercise:
 -- 1. The 'CreateProcess' that we can run for the compilation.
 -- 2. The directory path for the generated files
 -- 3. The path of the executable we would run (assuming the exercise is executable).
-createExerciseProcess :: ProgramConfig -> ExerciseInfo -> (CreateProcess, FilePath, FilePath)
+createExerciseProcess :: ProgramConfig -> ExerciseInfo -> (CreateProcess, FilePath, FilePath, FilePath)
 createExerciseProcess config (ExerciseInfo exerciseName exDirectory exType _) =
-  (processSpec, genDirPath, genExecutablePath)
+  (processSpec, genDirPath, genExecutablePath, haskellFileName exerciseName)
   where
     exIsRunnable = exType /= CompileOnly
     exFilename = haskellFileName exerciseName
@@ -51,88 +51,87 @@ createExerciseProcess config (ExerciseInfo exerciseName exDirectory exType _) =
     finalArgs = execArgs ++ ["-package-db", packageDb config]
     processSpec = proc (ghcPath config) finalArgs
 
-onCompileFailure :: ProgramConfig -> String -> Maybe Handle -> IO RunResult
-onCompileFailure config exFilename errHandle = withTerminalFailure $ do
-  progPutStrLn config $ "Couldn't compile : " ++ exFilename
+onCompileFailure :: String -> Maybe Handle -> ReaderT ProgramConfig IO RunResult
+onCompileFailure exFilename errHandle = withTerminalFailure $ do
+  progPutStrLn $ "Couldn't compile : " ++ exFilename
   case errHandle of
     Nothing -> return ()
-    Just h  -> hGetContents h >>= progPutStrLn config
+    Just h  -> lift (hGetContents h) >>= progPutStrLn
   return CompileError
 
-runUnitTestExercise :: ProgramConfig -> FilePath -> String -> IO RunResult
-runUnitTestExercise config genExecutablePath exFilename = do
+runUnitTestExercise :: FilePath -> String -> ReaderT ProgramConfig IO RunResult
+runUnitTestExercise genExecutablePath exFilename = do
   let execSpec = shell genExecutablePath
-  (_, execStdOut, execStdErr, execProcHandle) <- createProcess (execSpec { std_out = CreatePipe, std_err = CreatePipe })
-  execExit <- waitForProcess execProcHandle
+  (_, execStdOut, execStdErr, execProcHandle) <- lift $ createProcess (execSpec { std_out = CreatePipe, std_err = CreatePipe })
+  execExit <- lift $ waitForProcess execProcHandle
   case execExit of
     ExitFailure code -> withTerminalFailure $ do
-      progPutStrLn config $ "Tests failed on exercise : " ++ exFilename
+      progPutStrLn $ "Tests failed on exercise : " ++ exFilename
       case execStdErr of
         Nothing -> return ()
-        Just h  -> hGetContents h >>= progPutStrLn config
+        Just h  -> lift (hGetContents h) >>= progPutStrLn
       case execStdOut of
         Nothing -> return ()
-        Just h  -> hGetContents h >>= progPutStrLn config
+        Just h  -> lift (hGetContents h) >>= progPutStrLn
       return TestFailed
     ExitSuccess -> do
-      progPutStrLnSuccess config $ "Successfully ran : " ++ exFilename
+      progPutStrLnSuccess $ "Successfully ran : " ++ exFilename
       return RunSuccess
 
 runExecutableExercise
-  :: ProgramConfig
-  -> FilePath
+  :: FilePath
   -> String
   -> [String]
   -> ([String] -> Bool)
-  -> IO RunResult
-runExecutableExercise config genExecutablePath exFilename inputs outputPred = do
+  -> ReaderT ProgramConfig IO RunResult
+runExecutableExercise genExecutablePath exFilename inputs outputPred = do
   let execSpec = shell genExecutablePath
-  (execStdIn, execStdOut, execStdErr, execProcHandle) <- createProcess
+  (execStdIn, execStdOut, execStdErr, execProcHandle) <- lift $ createProcess
     (execSpec { std_out = CreatePipe, std_err = CreatePipe, std_in = CreatePipe })
-  when (isJust execStdIn) $ forM_ inputs $ \i -> hPutStrLn (fromJust execStdIn) i
-  execExit <- waitForProcess execProcHandle
+  when (isJust execStdIn) $ forM_ inputs $ \i -> lift $ hPutStrLn (fromJust execStdIn) i
+  execExit <- lift $ waitForProcess execProcHandle
   case execExit of
     ExitFailure code -> withTerminalFailure $ do
-      progPutStrLn config $ "Encountered error running exercise: " ++ exFilename
+      progPutStrLn $ "Encountered error running exercise: " ++ exFilename
       case execStdOut of
         Nothing -> return ()
-        Just h  -> hGetContents h >>= progPutStrLn config
+        Just h  -> lift (hGetContents h) >>= progPutStrLn
       case execStdErr of
         Nothing -> return ()
-        Just h  -> hGetContents h >>= progPutStrLn config
-      progPutStrLn config "Check the Sample Input and Sample Output in the file."
-      progPutStrLn config $ "Then try running it for yourself with 'haskellings exec" ++ haskellModuleName exFilename ++ "'."
+        Just h  -> lift (hGetContents h) >>= progPutStrLn
+      progPutStrLn "Check the Sample Input and Sample Output in the file."
+      progPutStrLn $ "Then try running it for yourself with 'haskellings exec" ++ haskellModuleName exFilename ++ "'."
       return TestFailed
     ExitSuccess -> do
       passes <- case execStdOut of
         Nothing -> return (outputPred [])
-        Just h  -> (lines <$> hGetContents h) >>= (return . outputPred)
+        Just h  -> (lines <$> lift (hGetContents h)) >>= (return . outputPred)
       if passes
         then withTerminalSuccess $ do
-          progPutStrLn config $ "Successfully ran : " ++ exFilename
-          progPutStrLn config $ "You can run this code for yourself with 'haskellings exec " ++ haskellModuleName exFilename ++ "'."
+          progPutStrLn $ "Successfully ran : " ++ exFilename
+          progPutStrLn $ "You can run this code for yourself with 'haskellings exec " ++ haskellModuleName exFilename ++ "'."
           return RunSuccess
         else withTerminalFailure $ do
-          progPutStrLn config $ "Unexpected output for exercise: " ++ exFilename
-          progPutStrLn config "Check the Sample Input and Sample Output in the file."
-          progPutStrLn config $ "Then try running it for yourself with 'haskellings exec " ++ haskellModuleName exFilename ++ "'."
+          progPutStrLn $ "Unexpected output for exercise: " ++ exFilename
+          progPutStrLn "Check the Sample Input and Sample Output in the file."
+          progPutStrLn $ "Then try running it for yourself with 'haskellings exec " ++ haskellModuleName exFilename ++ "'."
           return TestFailed
 
-compileAndRunExercise :: ProgramConfig -> ExerciseInfo -> IO RunResult
-compileAndRunExercise config exInfo@(ExerciseInfo exerciseName exDirectory exType _) = do
-  let (processSpec, genDirPath, genExecutablePath) = createExerciseProcess config exInfo
-  let exFilename = haskellFileName exerciseName
+compileAndRunExercise :: ExerciseInfo -> ReaderT ProgramConfig IO RunResult
+compileAndRunExercise exInfo@(ExerciseInfo exerciseName exDirectory exType _) = do
+  config <- ask
+  let (processSpec, genDirPath, genExecutablePath, exFilename) = createExerciseProcess config exInfo
   withDirectory genDirPath $ do
-    (_, _, procStdErr, procHandle) <- createProcess (processSpec { std_out = CreatePipe, std_err = CreatePipe })
-    exitCode <- waitForProcess procHandle
+    (_, _, procStdErr, procHandle) <- lift $ createProcess (processSpec { std_out = CreatePipe, std_err = CreatePipe })
+    exitCode <- lift $ waitForProcess procHandle
     case exitCode of
-      ExitFailure code -> onCompileFailure config exFilename procStdErr
+      ExitFailure code -> onCompileFailure exFilename procStdErr
       ExitSuccess -> do
-        progPutStrLnSuccess config $ "Successfully compiled : " ++ exFilename
+        progPutStrLnSuccess $ "Successfully compiled : " ++ exFilename
         case exType of
           CompileOnly -> return RunSuccess
-          UnitTests -> runUnitTestExercise config genExecutablePath exFilename
-          Executable inputs outputPred -> runExecutableExercise config genExecutablePath exFilename inputs outputPred
+          UnitTests -> runUnitTestExercise genExecutablePath exFilename
+          Executable inputs outputPred -> runExecutableExercise genExecutablePath exFilename inputs outputPred
 
-compileAndRunExercise_ :: ProgramConfig -> ExerciseInfo -> IO ()
-compileAndRunExercise_ config ex = void $ compileAndRunExercise config ex
+compileAndRunExercise_ :: ExerciseInfo -> ReaderT ProgramConfig IO ()
+compileAndRunExercise_ ex = void $ compileAndRunExercise ex