module Util.Messages(
alertMess,
errorMess,
warningMess,
confirmMess,
messageMess,
htkPresent,
textQuery,
errorMess2,
MessFns(..),
setMessFns,
) where
import System.IO
import Data.Char
import qualified Data.List as List
import qualified Data.Set as Set
import Control.Concurrent.MVar
import System.IO.Unsafe
import Util.Computation(done)
import Util.ExtendedPrelude
alertMess :: String -> IO ()
alertMess = getMessFn alertFn
errorMess :: String -> IO ()
errorMess = getMessFn errorFn
warningMess :: String -> IO ()
warningMess = getMessFn warningFn
confirmMess :: String -> IO Bool
confirmMess = getMessFn confirmFn
messageMess :: String -> IO ()
messageMess = getMessFn messageFn
htkPresent :: IO Bool
htkPresent = getMessValue htkPres
textQuery :: String -> IO String
textQuery query =
do
putStrLn query
reply <- getLine
return (trimSpaces reply)
data MessFns = MessFns {
alertFn :: String -> IO (),
errorFn :: String -> IO (),
warningFn :: String -> IO (),
confirmFn :: String -> IO Bool,
messageFn :: String -> IO (),
htkPres :: Bool
}
messFnsMVar :: MVar MessFns
messFnsMVar = unsafePerformIO (newMVar defaultMessFns)
setMessFns :: MessFns -> IO ()
setMessFns messFns =
do
takeMVar messFnsMVar
putMVar messFnsMVar messFns
getMessFn :: (MessFns -> (String -> IO a)) -> (String -> IO a)
getMessFn toFn str =
do
messFns <- getMessValue id
(toFn messFns) str
getMessValue :: (MessFns -> a) -> IO a
getMessValue toA =
do
messFns <- readMVar messFnsMVar
return (toA messFns)
defaultMessFns :: MessFns
defaultMessFns = MessFns {
alertFn = defaultAlert,
errorFn = defaultError,
warningFn = defaultWarning,
confirmFn = defaultConfirm,
messageFn = defaultMessage,
htkPres = False
}
defaultAlert :: String -> IO ()
defaultAlert str = putStrLn ("Alert: " ++ str)
defaultError :: String -> IO ()
defaultError str = hPutStrLn stderr ("Error: " ++ str)
defaultWarning :: String -> IO ()
defaultWarning str = putStrLn ("Warning: " ++ str)
defaultConfirm :: String -> IO Bool
defaultConfirm str =
do
putStrLn str
putStrLn ("O[K] or C[ancel]?")
let
getOC :: IO Bool
getOC =
do
oc <- readOC
case oc of
Just c -> return c
Nothing ->
do
putStrLn ("Type O (or some prefix of OK) or C "
++ "(or some prefix of CANCEL)")
getOC
readOC :: IO (Maybe Bool)
readOC =
do
result0 <- getLine
let
result1 = fmap toUpper (trimSpaces result0)
case (result1,isPrefix result1 "OK",isPrefix result1 "CANCEL")
of
("",_,_) -> return Nothing
(_,Just _,_) -> return (Just True)
(_,_,Just _) -> return (Just False)
(_,Nothing,Nothing) -> return Nothing
getOC
defaultMessage :: String -> IO ()
defaultMessage = putStrLn
pendingErrorMessagesMVar :: MVar [String]
pendingErrorMessagesMVar = unsafePerformIO (newMVar [])
errorMess2 :: String -> IO ()
errorMess2 message0 =
do
let
messages1 = reverse (lines message0)
modifyMVar_ pendingErrorMessagesMVar
(\ messages -> return (messages1 ++ messages))
clearPendingErrorMessages
clearPendingErrorMessages :: IO ()
clearPendingErrorMessages = cpe Set.empty
where
cpe :: Set.Set String -> IO ()
cpe alreadyDisplayedSet0 =
do
messages0 <- readMVar pendingErrorMessagesMVar
putStrLn (show (messages0,Set.toList alreadyDisplayedSet0))
let
messages1 = List.filter
(\ message -> not (Set.member message alreadyDisplayedSet0))
messages0
messages2 = uniqOrdOrder messages1
case messages2 of
[] -> done
_ ->
do
errorMess (unlines (reverse messages2))
let
alreadyDisplayedSet1 =
Set.union alreadyDisplayedSet0
(Set.fromList messages2)
cpe alreadyDisplayedSet1