From 7fbba2eb68ec5855d7af0adcf4fe0d6948177a43 Mon Sep 17 00:00:00 2001
From: Arnaud Bailly <arnaud@pankzsoft.com>
Date: Wed, 5 Nov 2025 06:24:21 +0100
Subject: increase grade with succesful answer

---
 lambda-calcul/haskell/src/Minilang/App.hs | 40 +++++++++++++++++++++----------
 1 file changed, 28 insertions(+), 12 deletions(-)

(limited to 'lambda-calcul/haskell/src/Minilang/App.hs')

diff --git a/lambda-calcul/haskell/src/Minilang/App.hs b/lambda-calcul/haskell/src/Minilang/App.hs
index 908e090..57c1fd6 100644
--- a/lambda-calcul/haskell/src/Minilang/App.hs
+++ b/lambda-calcul/haskell/src/Minilang/App.hs
@@ -31,14 +31,16 @@ import System.Random (StdGen)
 
 data Env = Env
   { gen :: TVar StdGen,
-    users :: TVar (Map Token Score)
+    users :: TVar (Map Token Score),
+    challenges :: [Challenge]
   }
 
-makeEnv :: StdGen -> IO Env
-makeEnv gen =
+makeEnv :: StdGen -> [Challenge] -> IO Env
+makeEnv gen challenges =
   Env
     <$> newTVarIO gen
     <*> newTVarIO mempty
+    <*> pure challenges
 
 newtype AppM a = AppM {runAppM :: ReaderT Env IO a}
   deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader Env)
@@ -95,9 +97,7 @@ getChallenge :: (MonadReader Env m, MonadIO m) => Maybe Token -> m Challenge
 getChallenge Nothing = liftIO $ throwM $ err400 {errBody = "Missing token"}
 getChallenge (Just token) = do
   checkUserToken token
-  now <- liftIO getCurrentTime
-  updateUserLastTest token now
-  pure $ Challenge 0 "x"
+  getCurrentChallenge token
 
 checkUserToken :: (MonadReader Env m, MonadIO m) => Token -> m ()
 checkUserToken token = do
@@ -106,8 +106,9 @@ checkUserToken token = do
     Nothing -> liftIO $ throwM $ err400 {errBody = "Token " <> LBS.fromStrict (encodeUtf8 (unToken token)) <> " does not exist"}
     Just _ -> pure ()
 
-updateUserLastTest :: (MonadIO m, MonadReader Env m) => Token -> UTCTime -> m ()
-updateUserLastTest token time =
+updateUserLastTest :: (MonadIO m, MonadReader Env m) => Token -> m ()
+updateUserLastTest token = do
+  time <- liftIO getCurrentTime
   asks users >>= \user -> liftIO $ atomically $ do
     usersMap <- readTVar user
     case Map.lookup token usersMap of
@@ -121,25 +122,40 @@ postAnswer :: (MonadReader Env m, MonadIO m) => Maybe Token -> Text -> m ()
 postAnswer Nothing _ = liftIO $ throwM $ err400 {errBody = "Missing token"}
 postAnswer (Just token) expected = do
   checkUserToken token
+  updateUserLastTest token
   Challenge {expr} <- getCurrentChallenge token
   let PurerEnv {outputs} = withInputs initialREPL [In expr]
   case outputs of
-    [Bye, Evaluated ast _ _] ->
+    [Bye, Evaluated ast _ _] -> do
       when (pretty ast /= expected) $
         liftIO $
           throwM $
             err400 {errBody = "Incorrect answer"}
+      upgradeUserChallenge token
     [Bye, Msg msg] -> liftIO $ throwM $ err400 {errBody = "Evaluation error: " <> LBS.fromStrict (encodeUtf8 msg)}
     _ -> liftIO $ throwM $ err500 {errBody = "Unexpected REPL output: " <> LBS.fromStrict (encodeUtf8 (pack $ show outputs))}
 
-getCurrentChallenge :: (MonadIO m, MonadReader Env m) => Token -> m Challenge
-getCurrentChallenge token =
+upgradeUserChallenge :: (MonadIO m, MonadReader Env m) => Token -> m ()
+upgradeUserChallenge token = do
   asks users >>= \user -> liftIO $ atomically $ do
     usersMap <- readTVar user
+    case Map.lookup token usersMap of
+      Nothing -> throwM $ err400 {errBody = "Cannot update last test: Invalid token"}
+      Just score -> do
+        let updatedScore = score {grade = succ (grade score)}
+            updatedMap = Map.insert token updatedScore usersMap
+        writeTVar user updatedMap
+
+
+getCurrentChallenge :: (MonadIO m, MonadReader Env m) => Token -> m Challenge
+getCurrentChallenge token = do
+  Env{users, challenges} <- ask
+  liftIO $ atomically $ do
+    usersMap <- readTVar users
     case Map.lookup token usersMap of
       Nothing -> throwM $ err400 {errBody = "Cannot find challenge: Invalid token"}
       Just Score {grade} ->
-        pure $ Challenge grade "x" -- TODO: Return actual challenge based on grade
+        pure $ challenges !! grade
 
 -- | Serve static resources under `public/` directory
 staticResources :: Application
-- 
cgit v1.3.1