-- |
-- Description: Outputting Messages
--
-- This module contains the hooks for displaying messages to the user
-- (errors, alerts, warnings and the like) and getting yes\/no responses.
--
-- The idea is that these are by default textual, and go via
-- 'stdin', 'stdout' and 'stderr' .  However if the DialogWin function
-- 'useHTk' is invoked, windows will pop up.
module Util.Messages(
   -- Functions for displaying messages
   alertMess, -- :: String -> IO ()
   errorMess, -- :: String -> IO ()
   warningMess, -- :: String -> IO ()
   confirmMess, -- :: String -> IO Bool
   messageMess, -- :: String -> IO ()

   -- Miscellaneous
   htkPresent,
      -- :: IO Bool
      -- If True, indicates that the flag corresponding to a graphical mode
      -- has been set.  This is used occasionally for deciding whether to
      -- ask the user something on stdout, stdin or via a window.

   textQuery,
      -- :: String -> IO String
      -- queries the user on stdout getting the answer from stdin.
      -- Leading and trailing spaces are trimmed from the result.

   errorMess2,
      -- :: String -> IO ()
      -- Attempt to reduce the number of error messages displayed by the
      -- imports stuff.

   -- Interface used by HTk for setting a graphical mode

   MessFns(..),  -- versions of the above functions
   setMessFns, -- :: MessFns -> IO ()
   ) 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

-- ------------------------------------------------------------------------
-- Displaying Messages & Miscellaneous
-- ------------------------------------------------------------------------

-- | Display an alert
alertMess :: String -> IO ()
alertMess :: String -> IO ()
alertMess = (MessFns -> String -> IO ()) -> String -> IO ()
forall a. (MessFns -> String -> IO a) -> String -> IO a
getMessFn MessFns -> String -> IO ()
alertFn

-- | Display an error
errorMess :: String -> IO ()
errorMess :: String -> IO ()
errorMess = (MessFns -> String -> IO ()) -> String -> IO ()
forall a. (MessFns -> String -> IO a) -> String -> IO a
getMessFn MessFns -> String -> IO ()
errorFn

-- | Display a warning message
warningMess :: String -> IO ()
warningMess :: String -> IO ()
warningMess = (MessFns -> String -> IO ()) -> String -> IO ()
forall a. (MessFns -> String -> IO a) -> String -> IO a
getMessFn MessFns -> String -> IO ()
warningFn

-- | Confirm something with the user.
confirmMess :: String -> IO Bool
confirmMess :: String -> IO Bool
confirmMess = (MessFns -> String -> IO Bool) -> String -> IO Bool
forall a. (MessFns -> String -> IO a) -> String -> IO a
getMessFn MessFns -> String -> IO Bool
confirmFn

-- | Display some informational message.
messageMess :: String -> IO ()
messageMess :: String -> IO ()
messageMess = (MessFns -> String -> IO ()) -> String -> IO ()
forall a. (MessFns -> String -> IO a) -> String -> IO a
getMessFn MessFns -> String -> IO ()
messageFn

-- | If True, indicates that the flag corresponding to a graphical mode
-- has been set.  This is used occasionally for deciding whether to
-- ask the user something on stdout, stdin or via a window.
htkPresent :: IO Bool
htkPresent :: IO Bool
htkPresent = (MessFns -> Bool) -> IO Bool
forall a. (MessFns -> a) -> IO a
getMessValue MessFns -> Bool
htkPres

-- | queries the user on stdout getting the answer from stdin.
-- Leading and trailing spaces are trimmed from the result.
textQuery :: String -> IO String
textQuery :: String -> IO String
textQuery String
query =
   do
      String -> IO ()
putStrLn String
query
      String
reply <- IO String
getLine
      String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> String
trimSpaces String
reply)

-- ------------------------------------------------------------------------
-- MessFns
-- ------------------------------------------------------------------------

data MessFns = MessFns {
   MessFns -> String -> IO ()
alertFn :: String -> IO (),
   MessFns -> String -> IO ()
errorFn :: String -> IO (),
   MessFns -> String -> IO ()
warningFn :: String -> IO (),
   MessFns -> String -> IO Bool
confirmFn :: String -> IO Bool,
   MessFns -> String -> IO ()
messageFn :: String -> IO (),
   MessFns -> Bool
htkPres :: Bool
   }

messFnsMVar :: MVar MessFns
messFnsMVar :: MVar MessFns
messFnsMVar = IO (MVar MessFns) -> MVar MessFns
forall a. IO a -> a
unsafePerformIO (MessFns -> IO (MVar MessFns)
forall a. a -> IO (MVar a)
newMVar MessFns
defaultMessFns)
{-# NOINLINE messFnsMVar #-}

setMessFns :: MessFns -> IO ()
setMessFns :: MessFns -> IO ()
setMessFns MessFns
messFns =
   do
      MVar MessFns -> IO MessFns
forall a. MVar a -> IO a
takeMVar MVar MessFns
messFnsMVar
      MVar MessFns -> MessFns -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar MessFns
messFnsMVar MessFns
messFns

getMessFn :: (MessFns -> (String -> IO a)) -> (String -> IO a)
getMessFn :: (MessFns -> String -> IO a) -> String -> IO a
getMessFn MessFns -> String -> IO a
toFn String
str =
   do
      MessFns
messFns <- (MessFns -> MessFns) -> IO MessFns
forall a. (MessFns -> a) -> IO a
getMessValue MessFns -> MessFns
forall a. a -> a
id
      (MessFns -> String -> IO a
toFn MessFns
messFns) String
str

getMessValue :: (MessFns -> a) -> IO a
getMessValue :: (MessFns -> a) -> IO a
getMessValue MessFns -> a
toA =
   do
      MessFns
messFns <- MVar MessFns -> IO MessFns
forall a. MVar a -> IO a
readMVar MVar MessFns
messFnsMVar
      a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (MessFns -> a
toA MessFns
messFns)

-- ------------------------------------------------------------------------
-- The default messFns
-- ------------------------------------------------------------------------

defaultMessFns :: MessFns
defaultMessFns :: MessFns
defaultMessFns = MessFns :: (String -> IO ())
-> (String -> IO ())
-> (String -> IO ())
-> (String -> IO Bool)
-> (String -> IO ())
-> Bool
-> MessFns
MessFns {
   alertFn :: String -> IO ()
alertFn = String -> IO ()
defaultAlert,
   errorFn :: String -> IO ()
errorFn = String -> IO ()
defaultError,
   warningFn :: String -> IO ()
warningFn = String -> IO ()
defaultWarning,
   confirmFn :: String -> IO Bool
confirmFn = String -> IO Bool
defaultConfirm,
   messageFn :: String -> IO ()
messageFn = String -> IO ()
defaultMessage,
   htkPres :: Bool
htkPres = Bool
False
   }

defaultAlert :: String -> IO ()
defaultAlert :: String -> IO ()
defaultAlert String
str = String -> IO ()
putStrLn (String
"Alert: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str)

defaultError :: String -> IO ()
defaultError :: String -> IO ()
defaultError String
str = Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
"Error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str)

defaultWarning :: String -> IO ()
defaultWarning :: String -> IO ()
defaultWarning String
str = String -> IO ()
putStrLn (String
"Warning: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str)

defaultConfirm :: String -> IO Bool
defaultConfirm :: String -> IO Bool
defaultConfirm String
str =
   do
      String -> IO ()
putStrLn String
str
      String -> IO ()
putStrLn (String
"O[K] or C[ancel]?")
      let
         getOC :: IO Bool
         getOC :: IO Bool
getOC =
            do
               Maybe Bool
oc <- IO (Maybe Bool)
readOC
               case Maybe Bool
oc of
                  Just Bool
c -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
c
                  Maybe Bool
Nothing ->
                     do
                        String -> IO ()
putStrLn (String
"Type O (or some prefix of OK) or C "
                           String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(or some prefix of CANCEL)")
                        IO Bool
getOC

         readOC :: IO (Maybe Bool)
         readOC :: IO (Maybe Bool)
readOC =
            do
               String
result0 <- IO String
getLine
               let
                  result1 :: String
result1 = (Char -> Char) -> String -> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Char
toUpper (String -> String
trimSpaces String
result0)

               case (String
result1,String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
isPrefix String
result1 String
"OK",String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
isPrefix String
result1 String
"CANCEL")
                     of
                  (String
"",Maybe String
_,Maybe String
_) -> Maybe Bool -> IO (Maybe Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Bool
forall a. Maybe a
Nothing
                  (String
_,Just String
_,Maybe String
_) -> Maybe Bool -> IO (Maybe Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True)
                  (String
_,Maybe String
_,Just String
_) -> Maybe Bool -> IO (Maybe Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False)
                  (String
_,Maybe String
Nothing,Maybe String
Nothing) -> Maybe Bool -> IO (Maybe Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Bool
forall a. Maybe a
Nothing
      IO Bool
getOC

defaultMessage :: String -> IO ()
defaultMessage :: String -> IO ()
defaultMessage = String -> IO ()
putStrLn

-- ------------------------------------------------------------------------
-- Reducing the number of error messages.
-- ------------------------------------------------------------------------

pendingErrorMessagesMVar :: MVar [String]
pendingErrorMessagesMVar :: MVar [String]
pendingErrorMessagesMVar = IO (MVar [String]) -> MVar [String]
forall a. IO a -> a
unsafePerformIO ([String] -> IO (MVar [String])
forall a. a -> IO (MVar a)
newMVar [])
{-# NOINLINE pendingErrorMessagesMVar #-}

-- | Display a series of one-line messages, separated by newline characters,
-- attempting to combine them together and eliminate duplicates as much as
-- possible.  If other identical messages come in while the error message
-- is being delayed, we throw them away.
errorMess2 :: String -> IO ()
errorMess2 :: String -> IO ()
errorMess2 String
message0 =
   do
      let
         messages1 :: [String]
messages1 = [String] -> [String]
forall a. [a] -> [a]
reverse (String -> [String]
lines String
message0)

      MVar [String] -> ([String] -> IO [String]) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar [String]
pendingErrorMessagesMVar
         (\ [String]
messages -> [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String]
messages1 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
messages))
      IO ()
clearPendingErrorMessages

clearPendingErrorMessages :: IO ()
clearPendingErrorMessages :: IO ()
clearPendingErrorMessages = Set String -> IO ()
cpe Set String
forall a. Set a
Set.empty
   where
      cpe :: Set.Set String -> IO ()
      cpe :: Set String -> IO ()
cpe Set String
alreadyDisplayedSet0 =
         do
            [String]
messages0 <- MVar [String] -> IO [String]
forall a. MVar a -> IO a
readMVar MVar [String]
pendingErrorMessagesMVar
            String -> IO ()
putStrLn (([String], [String]) -> String
forall a. Show a => a -> String
show ([String]
messages0,Set String -> [String]
forall a. Set a -> [a]
Set.toList Set String
alreadyDisplayedSet0))
            let
               messages1 :: [String]
messages1 = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
List.filter
                  (\ String
message -> Bool -> Bool
not (String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member String
message Set String
alreadyDisplayedSet0))
                  [String]
messages0

               messages2 :: [String]
messages2 = [String] -> [String]
forall a. Ord a => [a] -> [a]
uniqOrdOrder [String]
messages1

            case [String]
messages2 of
               [] -> IO ()
forall (m :: * -> *). Monad m => m ()
done
               [String]
_ ->
                  do
                     String -> IO ()
errorMess ([String] -> String
unlines ([String] -> [String]
forall a. [a] -> [a]
reverse [String]
messages2))

                     let
                        alreadyDisplayedSet1 :: Set String
alreadyDisplayedSet1 =
                           Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set String
alreadyDisplayedSet0
                                  ([String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList [String]
messages2)

                     Set String -> IO ()
cpe Set String
alreadyDisplayedSet1