3
\$\begingroup\$

Basically, you just run main and it allows the client to "log in", and extract their number from a map, increment their own number, and log out.

It all compiles and works fine, but how can I decouple this code, and make it more composable? I'm finding it's difficult to separate concerns, ex between the logic, and the IO + State effects.

What would be a better, more idiomatic way to right this, which would allow me to add features, such as a password, or decrement option?

Possible Actions: login <ENTER> name, inc, get, logout

{-# LANGUAGE FlexibleContexts #-}

import System.IO
import Data.Map
import Control.Monad.State

import Control.Lens.Tuple
import Control.Lens.Setter
import Control.Lens.Getter

import Prelude hiding (lookup) -- Data.Map has one I want

-- Features:
--   User can login, see their number, increment it ad lib, and log out
--
--   login
--     new username --> new map entry
--     old username --> display map entry
--   inc - increment current user's entry in map
--   logout - empties the current username
--   stop - close IO
--   bad input - just ask for another action

type DB       = Map String Int
type Username = String
type AppState = (Username, DB)

db = fromList [("a", 0),
               ("b", 99),
               ("c", 152)] :: DB

-- increment a key in a map
incDB ::  String -> DB -> DB
incDB k = (update (\x -> Just (x + 1)) k)
-- λ> inc "a" $ inc "a" $ inc "a" db

-- increment current user in a State Monad
--  (Num a, Ord k, MonadState (k, (Map k a)) m) => m x
incUser :: (MonadState AppState m) => m ()
incUser = do user <- gets $ view _1
             modify $ over _2 (incDB user)
-- λ> runState incUser ("b", db)

-- 1. update logged-in user name, 2. add new entry to db if it's a new user
login :: (MonadState AppState m) => String -> m ()
login newuser = do modify $ set _1 newuser
                   modify $ over _2 $ insertWithKey (\k new old -> old) newuser 0 -- inserts new user if necessary
-- λ> runState (login "d") ("", db)
--    ((),("d",fromList [("a",0),("b",99),("c",152),("d",0)]))

-- get the number of the currently-logged-in user
getNum ::(MonadState AppState m) => m (Maybe Int)
getNum = do user <- gets $ view _1
            db <- gets $ view _2
            return $ lookup user db
-- λ> runState (do login "b"; incState; getNum) ("", db)
--    (Just 100,("b",fromList [("a",0),("b",100),("c",152)]))

-- remove the currently logged-in user from the appstate (not the db though, of course)
logout :: (MonadState AppState m) => m ()
logout = modify $ set _1 ""
-- λ> runState (do login "b"; getNum; logout ) ("", db)
--    ((),("",fromList [("a",0),("b",99),("c",152)]))
-- λ> runState (do login "b"; incUser; incUser; logout ) ("", db)
--    ((),("",fromList [("a",0),("b",101),("c",152)]))


run :: StateT AppState IO ()
run = do liftIO $ putStr "next action: "
         liftIO $ hFlush stdout
         action <- liftIO $ getLine
         case action of
           "inc"    -> do incUser
           "login"  -> do liftIO $ putStr "enter username:"
                          user <- liftIO $ getLine
                          login user
           "get"    -> do n <- getNum
                          liftIO $ putStr $ "current num: " ++ (show n) ++ "\n"
                          -- liftIO $ hFlush stdout

           "logout" -> logout
           otherwise -> return ()
         if action == "stop"
         then
             return ()
         else
             run

main = do execStateT run ("", db)
\$\endgroup\$

1 Answer 1

3
\$\begingroup\$

I would inline, eta-reduce and use more library functions to make the code short enough that adding another command is trivial. Perhaps give the fields names so adding another can't mess up numbering, and you need less comments because the code describes itself.

Edit: I'll use non, making the map not add a value for new users until they want to change it. This way we don't need to initialize with db . at user %= (<|> Just 0) on logging in, and we can get rid of the Just returned by the "get" action without needing to promise we already initialized. (Which we don't necessarily have, as the initial ""!)

{#- LANGUAGE TemplateHaskell, LambdaCase -#}
import Control.Lens -- batteries included
import Control.Monad.Trans.Maybe
import Control.Applicative -- (<$>), (<*>), empty, (<|>)
import qualified Data.Map as M -- Data.Map's name collisions with prelude are customarily handled by qualification

data AppState = AppState
  { _appStateUsername :: String
  , _appStateDb :: M.Map String Int
  }

makeFields ''AppState

-- Here's one we can actually outline, because it's used more than once, and it allows us to pull out the liftIO, and it shows us that we forgot the hFlush and the trailing ' ' one of the times.
prompt :: MonadIO m => String -> m String
prompt s = liftIO $ do
  putStr $ s ++ ": "
  hFlush stdout
  getLine

main = runMaybeT $ (`execStateT` AppState "" M.empty) $ forever $ do
  prompt "next action" >>= \case
    "inc" -> do
      user <- use username
      db . at user . non 0 += 1
    "login" -> do
      user <- prompt "enter username"
      username .= user
    "get" -> do
      n <- M.findWithDefault 0 <$> use username <*> use db
      liftIO $ putStrLn $ "current num: " ++ show n -- Note that this includes the Maybe, even though at this point we're always just, unless we're still the initial "".
    "logout" -> do
      username .= "" -- Note that this makes for shenanigans if someone logs in as "".
    "stop" -> empty -- MaybeT helps us out with the control flow to get rid of the special case and recursion.
    _ -> liftIO $ putStrLn $ "usage: ehhh just look at the code mmkay"
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.