2
\$\begingroup\$

I've written a vocabulary trainer which does a lot of passing state around, as I have an ACID-database and a temporary state.

In my experience with Haskell I've learnt that overusing IO () is a code smell, I think that this is also true for state.

Please have a look at the following Main.hs, which is improvable in my opinion. The whole project is available at GitHub; feel free to clone it. git clone

module Main (main) where

import VocabularyData
import Database
import FreqTable
import Trainer

import Control.Exception (bracket)
import Control.Lens
import Control.Monad.Trans.State
import Data.Acid
import Data.Maybe (listToMaybe)
import Data.Char (toUpper)
import System.Exit (exitSuccess)
import System.IO (hFlush, stdout)

main :: IO ()
main = do
    let test = initTestState
    lang <- getSourceOrTarget "from"
    test' <- execStateT (source.=lang) test
    lang' <- getSourceOrTarget "to"
    test'' <- execStateT (target.=lang') test'
    bracket (openLocalState emptyLearntList)
            (closeAcidState)
            (\db -> command db test'')

command :: AcidState LearntList -> TestState -> IO ()
command db test = do putStrLn "+===================================================+"
                     putStrLn "|                                                   |"
                     putStrLn "| what to do next? (type: \"help\" for help screen)   |"
                     putStrLn "|                                                   |"
                     putStrLn "+===================================================+"
                     cmd <- getLine
                     control db test cmd

control :: AcidState LearntList -> TestState -> String -> IO ()
control db test "help"          = do print_help
                                     command db test

control db test "next"          = do len <- query db LengthVocabulary
                                     if (len <=0)
                                       then do putStrLn "No vocabulary in list."
                                               putStrLn "Use \"add word\" to insert."
                                               command db test
                                       else do idx <- randomListIndex (fromIntegral len)
                                               f   <- query db (LookupFrequency idx)
                                               test' <- execStateT (currentWord.=freqTable!!(f-1)) test
                                               -- putStrLn $ "vocabulary list len: "++show len      --   _   _  _       _  --
                                               -- putStrLn $ "random index: "++show idx             --  | \ |_ |_⟩ | | | _ --
                                               -- putStrLn $ "frequency to the index: "++show       --  |_/ |_ |_⟩ |_| |_| --
                                               -- print test'                                       --                     --
                                               guess db test'

control db test "change source" = do lang <- getSourceOrTarget "from"
                                     test' <- execStateT (source.=lang) test
                                     -- print test'
                                     command db test'

control db test "change target" = do lang <- getSourceOrTarget "to"
                                     test' <- execStateT (target.=lang) test
                                     -- print test'
                                     command db test'

control db test ('a':'d':'d':' ':'w':'o':'r':'d':xs) =
    do let times = maybeRead xs :: Maybe Int
       _repeat db test times

control db test "clear all"     = do putStrLn "Are you sure to delete all learnt vocabularies?"
                                     putStrLn "Type \"yes\" or \"no\" to confirm."
                                     yesNo <- getLine
                                     yesNoElse db test yesNo

control db _    "exit"          = do closeAcidState db
                                     exitSuccess

control db test "print db"      = do frqKnowList <- query db ViewAllVocabulary
                                     print frqKnowList
                                     command db test

control db test _               = do putStrLn "Invalid Input"
                                     command db test

guess :: AcidState LearntList -> TestState -> IO ()
guess db test = do putStr $ "What is ("++show (test^.source)++"): "
                   putStrLn $ vocab (test^.currentWord) (test^.source)
                   putStr $ "Your answer ("++show (test^.target)++") is: "
                   hFlush stdout
                   answer <- getLine
                   let is_hinted = (test^.hinted)
                       is_correct = correct (test^.currentWord) (test^.target) answer
                       f = test^.currentWord.frq
                   if is_hinted
                     then if is_correct
                             then do _ <- update db (UpdateKnowledge f 3)
                                     putStrLn "Correct, +3 Knowledge!"
                                     putStr "Full Answer: "
                                     putStrLn (vocab (test^.currentWord) (test^.target))
                                     command db test
                             else do _ <- update db (UpdateKnowledge f (-2))
                                     putStrLn "Wrong, -2 Knowledge!"
                                     putStr "Correct Answer: "
                                     putStrLn (vocab (test^.currentWord) (test^.target))
                                     test' <- execStateT (hinted.=False) test
                                     command db test'
                     else if is_correct
                             then do _ <- update db (UpdateKnowledge f 5)
                                     putStrLn "Correct, +5 Knowledge!"
                                     putStr "Full Answer: "
                                     putStrLn (vocab (test^.currentWord) (test^.target))
                                     command db test
                             else do test' <- execStateT (hinted.=True) test
                                     putStr "Hint: "
                                     putStrLn (hint (test'^.currentWord) (test'^.source))
                                     guess db test'


_repeat :: AcidState LearntList -> TestState -> Maybe Int -> IO ()
_repeat db test (Just n)| n<=0 = command db test
                                | otherwise = do _ <- update db AddVocabulary
                                                 _repeat db test (Just (n-1))
_repeat db test Nothing = do _ <- update db AddVocabulary
                             command db test


yesNoElse :: AcidState LearntList -> TestState -> String -> IO ()
yesNoElse db test "yes" = do _ <- update db ClearVocabulary;command db test
yesNoElse db test "no"  = command db test
yesNoElse db test  _    = control db test "clear all"

print_help :: IO ()
print_help = do putStrLn ""
                putStr "| |_| |" ; putStrLn "help          -> prints this text"
                putStr "| | | |" ; putStrLn ""
                putStr "|  _  |" ; putStrLn "next          -> next random vocabulary"
                putStr "| |_  |" ; putStrLn "add word      -> adds a new vocabulary to the list of learnt words"
                putStr "| |_  |" ; putStrLn "clear all     -> clears all vocabulary from the list of learnt words"
                putStr "|     |" ; putStrLn ""
                putStr "| |   |" ; putStrLn "change source -> changes the source language"
                putStr "| |_  |" ; putStrLn "change target -> changes the target language"
                putStr "|  _  |" ; putStrLn ""
                putStr "| |_| |" ; putStrLn "print db      -> prints the database"
                putStr "| |   |" ; putStrLn "exit          -> guess what \"exits the program\""
--                 putStrLn "print test    -> prints the current test"
initTestState :: TestState
initTestState = TestState { _currentWord = freqTable!!0
                          , _source      = F
                          , _target      = D
                          , _hinted      = False }

langOptions :: IO ()
langOptions = do putStrLn "\tF/f for Français/French/Französisch"
                 putStrLn "\tD/d for Allemande/German/Deutsch"
                 putStrLn "\tE/e for Anglais/English/Englisch"

getSourceOrTarget :: String -> IO Language
getSourceOrTarget toOrFrom = do
    putStrLn $ "Which language do you want to translate "++toOrFrom++"?"
    langOptions
    lang <- getLine
    case (maybeRead . map toUpper . take 1) lang of Just l  -> return l
                                                    Nothing -> do putStrLn "Invalid Input"
                                                                  getSourceOrTarget toOrFrom

maybeRead :: Read a => String -> Maybe a
maybeRead = fmap fst . listToMaybe . reads

hint :: Word -> Language -> String
hint w F = w^.phrase
hint w D = w^.satz
hint w E = w^.sentence

vocab :: Word-> Language -> String
vocab w F = w^.fra
vocab w D = w^.deu
vocab w E = w^.eng

correct :: Word-> Language -> String -> Bool
correct w F str = elem str $ (subst2 . words . subst) (w^.fra)
correct w D str = elem str $ (subst2 . words . subst) (w^.deu)
correct w E str = elem str $ (subst2 . words . subst) (w^.eng)

subst ::String -> String
subst = map subst_
      where subst_ :: Char -> Char
            subst_ ';' = ' '
            subst_ '.' = ' '
            subst_ ',' = ' '
            subst_ '/' = ' '
            subst_ a = a

subst2 :: [String] -> [String]
subst2 = map (map subst_)
       where subst_ :: Char -> Char
             subst_ '_' = ' '
             subst_ a = a
\$\endgroup\$
1
  • 1
    \$\begingroup\$ I believe the prompt monad would be an answer to your problem. See this post and this paper. \$\endgroup\$
    – Petr
    Sep 10, 2013 at 12:28

1 Answer 1

2
\$\begingroup\$

I have a few suggestions:

  1. Instead of functions recursively call each other, have a single master dispatching function that calls command, control, guess etc. This will give a central overview how the whole process works. Otherwise it's very difficult to comprehend the flow of the program.
  2. Pattern matching on Strings is very error prone and you can't give meaningful error messages if a user types a wrong command. So instead I'd suggest to introduce a data type that holds all possible user commands and create a parser that parses user input into commands (for example using parsec). Something like

    data Command = Help | Next | AddWords Int | ...
    
  3. There are many options how to avoid having everything inside IO. One possibility is to use the prompt monad (see my comment). As an example, let's modify guess using MonadPrompt. First, we'll create a data type that represents all possible actions guess can perform:

    data GuessPrompt a where
        AskWord           :: String -> GuessPrompt String
        Say               :: String -> GuessPrompt ()
        DbUpdateKnowledge :: Int -> Int -> GuessPrompt ()
        AltTestState      :: State TestState a -> GuessPrompt a
    

    (we'll need GADTs for this). Each constructor represents an action that takes a given set of parameters and returns some result to the caller. It will be convenient to have corresponding helper functions so that we don't have to write prompt . ... everywhere:

    askWord                 = prompt . AskWord
    say                     = prompt . Say
    dbUpdateKnowledge f n   = prompt (DbUpdateKnowledge f n)
    altTestState            = prompt . AltTestState
    

    Now we can rewrite guess as follows. It doesn't carry around any state nor database and runs in any monad that is an instance of MonadPrompt GuessPrompt (this signature requires FlexibleContexts).

    import Control.Monad.State as S (MonadState(..))
    -- ...
    
    guess' :: (MonadPrompt GuessPrompt m) => m ()
    guess' = do
        test <- altTestState S.get
        answer <- askWord $ "What is ("++show (test^.source)++"): " ++
                            vocab (test^.currentWord) (test^.source) ++ "\n" ++
                            "Your answer ("++show (test^.target)++") is: "
        let is_hinted = (test^.hinted)
            is_correct = correct (test^.currentWord) (test^.target) answer
            f = test^.currentWord.frq
        if is_hinted
          then if is_correct
            then do
              dbUpdateKnowledge f 3
              say $ "Correct, +3 Knowledge!\n" ++
                     "Full Answer: " ++
                     (vocab (test^.currentWord) (test^.target)) ++ "\n" ++
                     "Translated Hint: " ++
                     hint (test^.currentWord) (test^.target)
              altTestState $ hinted.=False
            else do
              dbUpdateKnowledge f (-2)
              say $ "Wrong, -2 Knowledge!\n" ++
                     "Correct Answer: " ++
                     vocab (test^.currentWord) (test^.target) ++ "\n" ++
                     "Translated Hint: " ++
                     hint (test^.currentWord) (test^.target)
              altTestState $ hinted.=False
          else if is_correct
            then do
              dbUpdateKnowledge f 5
              say $ "Correct, +5 Knowledge!\n" ++
                     "Full Answer: " ++
                     vocab (test^.currentWord) (test^.target)
            else do
              test' <- altTestState $ hinted.=True >> S.get
              say $ "Hint: " ++
                    hint (test'^.currentWord) (test'^.source)
              guess'
    

    Now guess' has no reference to IO or other particular monad, it only uses our given set of actions. For example, we could create a testing instance that simulates user input, checks that it returns (Says) the correct reply, checks how guess' updates the database etc.

    If we converted the whole Main module, we'd most likely add all the actions our functions need and we'd let the main dispatcher provide the correct implementations. Since we converted only guess, we could implement the old guess type as

    guess :: AcidState LearntList -> TestState -> IO ()
    guess db test = evalStateT (runPromptM actions guess') test
      where
        actions :: GuessPrompt a -> StateT TestState IO a
        actions (AskWord msg)           = lift $ putStrLn msg >> getLine
        actions (Say msg)               = lift $ putStrLn msg
        actions (DbUpdateKnowledge f n) = lift $ update db (UpdateKnowledge f n)
        actions (AltTestState s)        = mapStateT (return . runIdentity) s
    

    which describes in one place how the actions are actually executed inside IO and TestState.

\$\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.