-- Copyright (c) 2019-2021 China University of Water Resources and Electric Power,
-- All rights reserved.
{-# LANGUAGE OverloadedStrings #-}

module Main (
    main      -- IO()
    ) where

import Control.Monad
import qualified System.IO.Streams as S
import System.IO
import Database.MySQL.Base
import Corpus
import SentParse
import Database
import Statistics

{- This program create syntactic and semantic parsing results for Chinese sentences. Please run MySQL Workbench or other similiar tools, connecting MySQL database 'ccg4c', and querying table 'corpus' for revising parts of speech as well as CCG syntactic types, and the MySQL server is running on a certain compute in Hua-shui campus. The program includes commands for parsing sentences and storing results in database 'ccg4c', as following.
    ?   Display this message.
    1   Get the raw part-of-speech marked sentence (namely column raw_sent) given by value of column 'serial_num'.
    2   Copy column 'raw_sent' to column 'raw_sent2' to be revised for a given row. After executing this command, part-of-speech of every word in this sentence should be revised, then set column 'pos_check' as 1. If the value of column 'pos_check' of this row is 0, this child command will be banned.
    3   Get the part-of-speech marks revised sentence (namely column raw_sent2) given by value of column 'serial_num'.
    4   Create categorial column 'cate_sent' from part-of-speech column 'raw_sent2' for a given row. Before executing this child command, parts of speech of all words in this sentence should be revised, and set column 'pos_check' as 1. If the value of column 'pos_check' of this row is 0, this child command will be banned.
    5   Copy categorial column 'cate_sent' to column 'cate_sent2' to be revised for a given row. After executing this command, CCG-syntactic types of every words in this sentence should be revised, then set column 'cate_check' as 1.
    6   Get the CCG-marked sentence (namely column cate_sent) given by value of column 'serial_num'.
    7   Get the CCG mark-revised sentence (namely column cate_sent2) given by value of column 'serial_num'.
    8   Parse the sentence given by value of column 'serial_num'.
    9   Display parsing result of the sentence given by value of column 'serial_num'.
    A   Statistically analyze the database table 'corpus' and 'stru_gene'.
    0   Quit from this program.
 -}
main :: IO ()
main = do
    hSetBuffering stdout NoBuffering               -- Set buffering mode for stdout as no buffering.
    hSetBuffering stdin LineBuffering              -- Set buffering mode for stdin as line buffering.
    hSetEncoding stdout utf8                       -- Set encoding for stdout as UTF8
    hFlush stdout                                  -- Flush buffered data to assure changing the encoding.

    putStrLn " Chinese CCG parser (build 0.2.5.0)"
    putStrLn " Copyright (c) 2019-2021 China University of Water Resources and Electric Power, All rights reserved."

    (username, ok) <- login 1
    if ok
      then interpreter username
      else return ()

-- The n'th User authentication, returns user name and its authentication result.
login :: Int -> IO (String, Bool)
login 4 = do
    putStrLn " Login failed! input attempts have reached maximal times."
    return ("", False)
login n = do
    putStr " Login: "
    username <- getLine
    putStr " Password: "
    password <- getLine

    conn <- getConn
    stmt <- prepareStmt conn "select * from user where name = ? && password = ?"
    (defs, is) <- queryStmt conn stmt [toMySQLText username, toMySQLText password]   --([ColumnDef], InputStream [MySQLValue])
    row <- S.read is
    let row' = case row of
                 Just x -> x
                 Nothing -> []
    skipToEof is
    if row' == []
      then do
        putStrLn " User or password is error."
        login (n + 1)
      else do
        putStrLn $ " Welcome " ++ fromMySQLText (row'!!1) ++ " :)"    -- The second element is true name of this user.
        return (username, True)

-- Check whether current user is intellectual property creator (IPC) of the row indicated by serial_num.
checkIpc :: Int -> String -> IO Bool
checkIpc sn username = do
    conn <- getConn
    stmt <- prepareStmt conn "select ipc from corpus where serial_num = ? "
    (defs, is) <- queryStmt conn stmt [toMySQLInt32 sn]
    row <- S.read is
    let row' = case row of
                 Just x -> x
                 Nothing -> []
    skipToEof is
    if row' == []
      then do
        putStrLn "checkIpc: No this row."
        return False
      else do
        if (fromMySQLText (row'!!0) == username)
          then return True
          else return False

-- Command interpreter for given user.
interpreter :: String -> IO ()
interpreter username = do
    putStrLn " ? -> Display command list."
    putStrLn " 1 -> Get raw part-of-speech marked sentence indicated by serial_num."
    putStrLn " 2 -> Copy raw sentence indicated by serial_num to column raw_sent2"
    putStrLn " 3 -> Get the revised part-of-speech marked sentence indicated by serial_num."
    putStrLn " 4 -> Create CCG-marked sentence from its revised part-of-speech marks."
    putStrLn " 5 -> Get CCG-marked sentence indicated by serial_num."
    putStrLn " 6 -> Copy CCG-marked sentence indicated by serial_num to column cate_sent2."
    putStrLn " 7 -> Get revised CCG-marked sentence indicated by serial_num."
    putStrLn " 8 -> Parse the sentence indicated by serial_num."
    putStrLn " 9 -> Display parsing Trees of the sentence indicated by serial_num."
    putStrLn " A -> Statistically analyze the database table corpus and stru_gene"
    putStrLn " 0 -> doQuit"
    putStr "Please input command: "
    line <- getLine
    if notElem line ["?","1","2","3","4","5","6","7","8","9","A","0"]
      then do
             putStrLn "Invalid input."
             interpreter username
      else case line of
             "?" -> interpreter username
             "1" -> doGetRawSentForASent username
             "2" -> doCopyRawSentForASent username
             "3" -> doGetRawSent2ForASent username
             "4" -> doPosToCateForASent username
             "5" -> doGetCateSentForASent username
             "6" -> doCopyCateForASent username
             "7" -> doGetCateSent2ForASent username
             "8" -> doParseSent username
             "9" -> doDisplayTreesForASent username
             "A" -> doStatisticalAnalysis username
             "0" -> doQuit

-- 1. Get raw part-of-speech marked sentence indicated by serial_num.
doGetRawSentForASent :: String -> IO ()
doGetRawSentForASent username = do
    putStr "Please input value of 'serial_num': "
    line <- getLine
    let sn = read line :: Int
    getRawSentForASent sn >>= putStrLn
    interpreter username

{- 2. Copy raw sentence indicated by serial_num to column 'raw_sent2', here 'username' MUST
   be the intellectual property creator (ipc) of the row indicated by serial_num.
 -}
doCopyRawSentForASent :: String -> IO ()
doCopyRawSentForASent username = do
    putStr "Please input value of 'serial_num': "
    line <- getLine
    let sn = read line :: Int

    ok <- checkIpc sn username
    if ok
      then do                          -- Pass authentication!
        conn <- getConn
        stmt <- prepareStmt conn "select pos_check from corpus where serial_num = ?"
        (defs, is) <- queryStmt conn stmt [toMySQLInt32 sn]            --([ColumnDef], InputStream [MySQLValue])
        pos_check <- S.read is
        let pos_check' = case pos_check of
                           Just x -> fromMySQLInt8 (head x)
                           Nothing -> error "doCopyRawSentForASent: No pos_check was read."
        skipToEof is                                                   -- Go to the end of the stream.
        if pos_check' == 1
          then do
             putStrLn "Creating column 'raw_sent2' failed because column 'pos_check' is 1."
             interpreter username
          else if pos_check' == 0
                 then do
                   copyRawSentForASent sn
                   interpreter username
                 else do
                   putStrLn "pos_check value is abnormal."
                   interpreter username
      else do
        putStrLn "Copying failed! you are not the intellectual property creator of this sentence."
        interpreter username

-- 3. Get the revised part-of-speech marked sentence indicated by serial_num.
doGetRawSent2ForASent :: String -> IO ()
doGetRawSent2ForASent username = do
    putStr "Please input value of 'serial_num': "
    line <- getLine
    let sn = read line :: Int
    getRawSent2ForASent sn >>= putStrLn
    interpreter username

{- 4. Create CCG-marked sentence from its revised part-of-speech marks, here 'username' MUST
   be the intellectual property creator (ipc) of the row indicated by serial_num.
 -}
doPosToCateForASent :: String -> IO ()
doPosToCateForASent username = do
    putStr "Please input value of 'serial_num': "
    line <- getLine
    let sn = read line :: Int

    ok <- checkIpc sn username
    if ok
      then do                          -- Pass authentication!
        conn <- getConn
        stmt <- prepareStmt conn "select pos_check from corpus where serial_num = ?"
        (defs, is) <- queryStmt conn stmt [toMySQLInt32 sn]            --([ColumnDef], InputStream [MySQLValue])
        pos_check <- S.read is
        let pos_check' = case pos_check of
                           Just x -> fromMySQLInt8 (head x)
                           Nothing -> error "doPosToCateForASent: No pos_check was read."
        skipToEof is                                                   -- Go to the end of the stream.
        if pos_check' == 0
          then do
             putStrLn "Creating column 'cate_sent' failed because column 'pos_check' is 0."
             interpreter username
          else if pos_check' == 1
                 then do
                   posToCateForASent sn
                   interpreter username
                 else do
                   putStrLn "pos_check value is abnormal."
                   interpreter username
      else do
        putStrLn "Creating CCG marks failed! you are not the intellectual property creator of this sentence."
        interpreter username

-- 5. Get CCG-marked sentence indicated by serial_num.
doGetCateSentForASent :: String -> IO ()
doGetCateSentForASent username = do
    putStr "Please input value of 'serial_num': "
    line <- getLine
    let sn = read line :: Int
    getCateSentForASent sn >>= putStrLn
    interpreter username

{- 6. Copy CCG-marked sentence indicated by serial_num to column cate_sent2, here 'username' MUST
   be the intellectual property creator (ipc) of the row indicated by serial_num.
 -}
doCopyCateForASent :: String -> IO ()
doCopyCateForASent username = do
    putStr "Please input value of 'serial_num': "
    line <- getLine
    let sn = read line :: Int

    ok <- checkIpc sn username
    if ok
      then do                          -- Pass authentication!
        conn <- getConn
        stmt <- prepareStmt conn "select cate_check from corpus where serial_num = ?"
        (defs, is) <- queryStmt conn stmt [toMySQLInt32 sn]            --([ColumnDef], InputStream [MySQLValue])
        cate_check <- S.read is
        let cate_check' = case cate_check of
                            Just x -> fromMySQLInt8 (head x)
                            Nothing -> error "doCopyCateForASent: No cate_check was read."
        skipToEof is                                                   -- Go to the end of the stream.
        if cate_check' == 1
          then do
             putStrLn "Creating column 'cate_sent2' failed because column 'cate_check' is 1."
             interpreter username
          else if cate_check' == 0
             then do
               copyCateForASent sn
               interpreter username
             else do
               putStrLn "cate_check value is abnormal."
               interpreter username
      else do
        putStrLn "Copying failed! you are not the intellectual property creator of this sentence."
        interpreter username

-- 7. Get revised CCG-marked sentence indicated by serial_num.".
doGetCateSent2ForASent :: String -> IO ()
doGetCateSent2ForASent username = do
    putStr "Please input value of 'serial_num': "
    line <- getLine
    let sn = read line :: Int
    getCateSent2ForASent sn >>= putStrLn
    interpreter username

{- 8. Parse the sentence indicated by serial_num, here 'username' MUST
   be the intellectual property creator (ipc) of the row indicated by serial_num.
 -}
doParseSent :: String -> IO ()
doParseSent username = do
    putStr "Please input value of 'serial_num': "
    line <- getLine
    let sn = read line :: Int

    ok <- checkIpc sn username
    if ok
      then do                          -- Pass authentication!
        conn <- getConn
        stmt <- prepareStmt conn "select cate_check, tree_check from corpus where serial_num = ?"
        (defs, is) <- queryStmt conn stmt [toMySQLInt32 sn]            --([ColumnDef], InputStream [MySQLValue])
        cate_tree_check <- S.read is
        let cate_tree_check' = case cate_tree_check of
                                 Just x -> x
                                 Nothing -> error "doParseSent: No cate_tree_check was read."
        skipToEof is                                                   -- Go to the end of the stream.
        let cate_check = fromMySQLInt8 (cate_tree_check'!!0)
        let tree_check = fromMySQLInt8 (cate_tree_check'!!1)
        if (cate_check == 0 || tree_check == 1)
          then do
             putStrLn $ "Parsing failed because cate_check = " ++ (show cate_check) ++ ", tree_check = " ++ (show tree_check)
             interpreter username
          else if (cate_check == 1 && tree_check == 0)
                 then do
                   getSentFromDB sn >>= getSent >>= parseSent sn
                   interpreter username
                 else do
                   putStrLn "Value of cate_check or tree_check is abnormal."
                   interpreter username
      else do
        putStrLn "Parsing failed! you are not the intellectual property creator of this sentence."
        interpreter username

-- 9. Display parsing Trees of the sentence indicated by serial_num.
doDisplayTreesForASent :: String -> IO ()
doDisplayTreesForASent username = do
    putStr "Please input value of 'serial_num': "
    line <- getLine
    let sn = read line :: Int
    readTree_String sn >>= sentToClauses >>= dispTree
    interpreter username

-- A. Do statistical analysis about Table corpus and stru_gene, and display results.
doStatisticalAnalysis :: String -> IO ()
doStatisticalAnalysis username = do
    putStrLn " ? -> Display command list."
    putStrLn " 1 -> Count in table 'corpus'."
    putStrLn " 2 -> Count in table 'stru_gene'."
    putStrLn " 0 -> Go back to the upper layer."
    putStr "Please input command: "
    line <- getLine
    if notElem line ["?","1","2","0"]
       then do
         putStrLn "Invalid input."
         doStatisticalAnalysis username
    else case line of
         "?" -> doStatisticalAnalysis username
         "1" -> doCountInCorpus username
         "2" -> doCountInStruGene username
         "0" -> interpreter username

-- A1. Do count in corpus and display results. 't' means from field 'tree', and 's' means from 'script'.
doCountInCorpus :: String -> IO ()
doCountInCorpus username = do
    putStrLn " ? -> Display command list."
    putStrLn " t1 -> Get total number of sentences."
    putStrLn " t2 -> Get clausal number in every sentence."
    putStrLn " t3 -> Get averge clausal number per sentence."
    putStrLn " t4 -> Get length of every clause in every sentence."
    putStrLn " t5 -> Get phrase number of every clause in every sentence."
    putStrLn " t6 -> Get clausal number of different clausal lengths."
    putStrLn " t7 -> Get clausal number of different parsing-tree depths."
    putStrLn " t8 -> Get frequency total and normalized frequencies of different CCG tags."
    putStrLn " t9 -> Get frequency total and normalized frequencies of different phrasal structures."
    putStrLn " tA -> Get frequency total and normalized frequencies of different type-tag-stru(s)."
    putStrLn " s1 -> Get transitive times of every clause in all sentences."
    putStrLn " s2 -> Get frequencies of different ransitive times in all clause parsing."
    putStrLn " s3 -> Get conversion-ruled list in parsing every clause."
    putStrLn " s4 -> Get number of abandoned phrases in parsing every clause."
    putStrLn " s5 -> Get number of abandoned not-recognizable phrases in parsing every clause."
    putStrLn " 0 -> Go back to the upper layer."

    putStr "Please input command: "
    line <- getLine
    if notElem line ["?","t1","t2","t3","t4","t5","t6","t7","t8","t9","tA","s1","s2","s3","s4","s5","0"]
       then do
         putStrLn "Invalid input."
         doCountInCorpus username
       else case line of
         "?" -> doCountInCorpus username
         "t1" -> doCountInTree username 1
         "t2" -> doCountInTree username 2
         "t3" -> doCountInTree username 3
         "t4" -> doCountInTree username 4
         "t5" -> doCountInTree username 5
         "t6" -> doCountInTree username 6
         "t7" -> doCountInTree username 7
         "t8" -> doCountInTree username 8
         "t9" -> doCountInTree username 9
         "tA" -> doCountInTree username 10
         "s1" -> doCountInScript username 1
         "s2" -> doCountInScript username 2
         "s3" -> doCountInScript username 3
         "s4" -> doCountInScript username 4
         "s5" -> doCountInScript username 5
         "0" -> interpreter username

-- A1_1. Display statistical results from field 'tree' in table 'corpus'.
doCountInTree :: String -> Int -> IO ()
doCountInTree username funcIndex = do
    putStr "Please input the value of 'serial_num' of start sentence: "
    line <- getLine
    let bottomSn = read line :: Int
    putStr "Please input the value of 'serial_num' of end sentence: "
    line <- getLine
    let topSn = (read line :: Int) + 1
    countInTree bottomSn topSn funcIndex
    doCountInCorpus username

-- A1_2. Display statistical results from field 'script' in table 'corpus'.
doCountInScript :: String -> Int -> IO ()
doCountInScript username funcIndex = do
    putStr "Please input the value of 'serial_num' of start sentence: "
    line <- getLine
    let bottomSn = read line :: Int
    putStr "Please input the value of 'serial_num' of end sentence: "
    line <- getLine
    let topSn = (read line :: Int) + 1
    countInScript bottomSn topSn funcIndex
    doCountInCorpus username

-- A2. Display statistical results from table 'struGene'.
doCountInStruGene :: String  -> IO ()
doCountInStruGene username = do
    putStrLn " ? -> Display command list."
    putStrLn " 1 -> Get total number of structural genes."
    putStrLn " 2 -> Get frequencies of different overlapping types."
    putStrLn " 3 -> Get frequencies of most common phrasal overlapping (LROs) by given common proportion."
    putStrLn " 4 -> Get frequencies of most common phrasal overlapping (LROPs) by given common proportion."
    putStrLn " 5 -> Get clausal number of different clausal lengths."
    putStrLn " 6 -> Get clausal number of different parsing-tree depths."
    putStrLn " 7 -> Get frequency total and normalized frequencies of different CCG tags."
    putStrLn " 8 -> Get frequency total and normalized frequencies of different phrasal structures."
    putStrLn " 9 -> Get frequency total and normalized frequencies of different type-tag-stru(s)."
    putStrLn " 0 -> Go back to the upper layer."

    putStr "Please input command: "
    line <- getLine
    if notElem line ["?","1","2","3","4","5","6","7","8","9","0"]
      then do
        putStrLn "Invalid input."
        doCountInStruGene username
      else case line of
        "?" -> doCountInStruGene username
        "1" -> doCountInStruGene' username 1
        "2" -> doCountInStruGene' username 2
        "3" -> doCountInStruGene' username 3
        "4" -> doCountInStruGene' username 4
        "5" -> doCountInTree username 5
        "6" -> doCountInTree username 6
        "7" -> doCountInTree username 7
        "8" -> doCountInTree username 8
        "9" -> doCountInTree username 9
        "0" -> interpreter username

-- A2_1. Display statistical results from table 'stru_gene'.
doCountInStruGene' :: String -> Int -> IO ()
doCountInStruGene' username funcIndex = do
    countInStruGene funcIndex
    doCountInStruGene username

-- 0. Quit from this program.
doQuit :: IO ()
doQuit = putStrLn "Bye!"


{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLabels #-}

module NotificationCenter where

import NotificationCenter.Notification
  (DisplayingNotificaton(..), showNotification, updateNoti)
import NotificationCenter.Notifications
  (NotifyState(..), startNotificationDaemon, Notification(..)
  , hideAllNotis)
import NotificationCenter.Glade (glade, style)
import NotificationCenter.Button
  (Button(..), createButton, setButtonState)
import TransparentWindow
import Helpers
import NotificationCenter.Notifications.Data

import Prelude

import Data.Int (Int32(..))
import Data.Tuple.Sequence (sequenceT)
import Data.Maybe
import Data.IORef
import Data.List
import Data.List.Split (splitOn)
import Data.Time
import Data.Time.LocalTime
import qualified Data.Text as Text
import qualified Data.ByteString.Char8 as BS
import qualified Data.Map as Map
import Data.Complex
import Data.Monoid ((<>))

import Control.Monad
import Control.Applicative
import Control.Concurrent (forkIO, threadDelay, ThreadId(..))
import Control.Concurrent.STM
  ( readTVarIO, modifyTVar', TVar(..), atomically, newTVarIO )

import System.Process (runCommand)
import System.Locale.Read
import System.Posix.Signals (sigUSR1)
import System.Posix.Daemonize (serviced, daemonize)
import System.Directory (getHomeDirectory)

import DBus ( fromVariant )

import GI.Gtk
       (widgetSetHalign, widgetSetHexpand, buttonNew, setWidgetMargin, buttonSetRelief, widgetSetSizeRequest, widgetShowAll, widgetShow, widgetHide, onWidgetDestroy
       , windowSetDefaultSize, setWindowTitle, boxPackStart, boxNew
       , setWindowWindowPosition, WindowPosition(..), windowMove
       , frameSetShadowType, aspectFrameNew
       , widgetGetAllocatedHeight, widgetGetAllocatedWidth, onWidgetDraw
       , onWidgetLeaveNotifyEvent, onWidgetMotionNotifyEvent
       , widgetAddEvents, alignmentSetPadding, alignmentNew, rangeSetValue
       , scaleSetDigits, scaleSetValuePos, rangeGetValue
       , afterScaleButtonValueChanged, scaleNewWithRange, containerAdd
       , buttonBoxNew, mainQuit, onButtonActivate
       , toggleButtonGetActive, onToggleButtonToggled, buttonSetUseStock
       , toggleButtonNewWithLabel, onButtonClicked
       , buttonNewWithLabel, widgetQueueDraw, drawingAreaNew
       , windowNew, widgetDestroy, dialogRun, setAboutDialogComments
       , setAboutDialogAuthors, setAboutDialogVersion
       , setAboutDialogProgramName, aboutDialogNew, labelNew, get
       , afterWindowSetFocus, labelSetText
       , onWidgetFocusOutEvent, onWidgetKeyReleaseEvent, widgetGetParentWindow
       , onButtonClicked, windowGetScreen, boxNew, widgetSetValign)
import qualified GI.Gtk as Gtk (containerAdd, Window(..), Box(..), Label(..), Button(..))

import qualified GI.Gtk as GI (init, main)
import GI.GLib (sourceRemove, timeoutAdd, unixSignalAdd)
import GI.GLib.Constants
import GI.Gdk.Constants
import GI.Gdk.Flags (EventMask(..))
import GI.Gtk.Enums
       (Orientation(..), WindowType(..), ShadowType(..)
       , PositionType(..), ReliefStyle(..), Align(..))
import Data.GI.Base.BasicConversions (gflagsToWord)
import qualified GI.Gdk.Objects.Window

data State = State
  { stMainWindow :: Gtk.Window
  , stNotiBox :: Gtk.Box
  , stTimeLabel :: Gtk.Label
  , stDateLabel :: Gtk.Label
  , stDeleteAll :: Gtk.Button
  , stUserButtons :: [ Button ]
  , stNotiState :: TVar NotifyState
  , stDisplayingNotiList :: [ DisplayingNotificaton ]
  , stNotisForMe :: [ Notification ]
  , stCenterShown :: Bool
  }

setTime :: TVar State -> IO Bool
setTime tState = do
  state <- readTVarIO tState
  now <- zonedTimeToLocalTime <$> getZonedTime
  zone <- System.Locale.Read.getCurrentLocale
  let format = Text.pack . flip (formatTime zone) now
  labelSetText (stTimeLabel state) $ format "%H:%M"
  labelSetText (stDateLabel state) $ format "%A, %x"
  return False

startSetTimeThread :: TVar State -> IO ()
startSetTimeThread tState = do
  runAfterDelay 1000 (startSetTimeThread' tState)
  return ()

startSetTimeThread' :: TVar State -> IO ()
startSetTimeThread' tState = do
  addSource (setTime tState)
  time <- fromIntegral <$> diffTimeToPicoseconds <$> utctDayTime <$> getCurrentTime
  let delay = (60 * 1000000) - ((ceiling (time / 1000000)) `mod` (1000000 * 60))
  runAfterDelay delay (startSetTimeThread' tState)
  return ()

createNotiCenter :: TVar State -> Config -> IO ()
createNotiCenter tState config = do
  objs <- createTransparentWindow (Text.pack glade)
    [ "main_window"
    , "label_time"
    , "label_date"
    , "box_notis"
    , "box_buttons"
    , "button_deleteAll" ]
    (Just "Notification area")

  mainWindow <- window objs "main_window"
  notiBox <- box objs "box_notis"
  buttonBox <- box objs "box_buttons"
  timeL <- label objs "label_time"
  timeD <- label objs "label_date"
  deleteButton <- button objs "button_deleteAll"

  screen <- windowGetScreen mainWindow
  setStyle screen $ BS.pack $
    replaceColors config style
--  (Just mainWindowGDK) <- widgetGetParentWindow mainWindow

  onButtonClicked deleteButton $ do
    displayList <- stDisplayingNotiList <$> readTVarIO tState
    mapM (removeNoti tState) displayList
    return ()

  let buttons = zip
        (split $ removeOuterLetters $ configLabels config)
        (split $ removeOuterLetters $ configCommands config)
      (buttonLabels, buttonCommands) = unzip buttons
      margin = fromIntegral $ configButtonMargin config
      width = fromIntegral (((configWidth config) - 20)
                            `div` (configButtonsPerRow config))
              - margin * 2
      height = fromIntegral $ configButtonHeight config
      linesNeeded = fromIntegral $ ceiling
        $ ((fromIntegral $ length buttons) / (fromIntegral $ configButtonsPerRow config))
  lines' <- sequence $ take linesNeeded $ repeat $ boxNew OrientationHorizontal 0
  buttons' <- sequence $ map
    (\(label, command) -> createButton config width height command label)
    buttons

  sequence $ map (\(box, buttons'') ->
                    sequence $ Gtk.containerAdd box <$> buttons'')
    $ zip (reverse lines') (splitEvery (configButtonsPerRow config)
                            $ (buttonButton <$> buttons'))
  sequence $ Gtk.containerAdd buttonBox <$> lines'
  sequence $ widgetShowAll <$> lines'

  atomically $ modifyTVar' tState $
    \state -> state { stMainWindow = mainWindow
                      , stNotiBox = notiBox
                      , stTimeLabel = timeL
                      , stDateLabel = timeD
                      , stDeleteAll = deleteButton
                      , stNotisForMe = []
                      , stUserButtons = buttons' }

  startSetTimeThread tState

  onWidgetLeaveNotifyEvent mainWindow $ \(_) -> do
    hideNotiCenter tState
    return True

  --  (screenH, screenW) <- getScreenProportions mainWindow
  (screenW, screenY, screenH) <- getScreenPos mainWindow
    (fromIntegral $ configNotiCenterMonitor config)

  windowSetDefaultSize mainWindow
    (fromIntegral $ configWidth config) -- w
    (screenH - barHeight) -- h
  windowMove mainWindow
    (screenW - (fromIntegral $ configWidth config)) -- x
    (screenY + barHeight)  -- y
  onWidgetDestroy mainWindow mainQuit
  return ()
    where barHeight = fromIntegral $ configBarHeight config

parseNotisForMe tState = do
  state <- readTVarIO tState
  -- do stuff
  let buttons = stUserButtons state
      notisForMe = stNotisForMe state
      myNotiHints = notiHints <$> notisForMe
      maybeIds = Map.lookup "id" <$> myNotiHints
      ids = join <$> map (\id' -> fromVariant <$> id') maybeIds :: [ Maybe Int32 ]
      ids' = map checkId ids
        where
          checkId (Just id)
            | id < (fromIntegral $ length buttons) = Just id
            | otherwise = Nothing
          checkId Nothing = Nothing
      maybeStates = Map.lookup "state" <$> myNotiHints
      states = join <$> map (\id' -> fromVariant <$> id') maybeStates :: [ Maybe Bool ]
      comb = sequenceT <$> (zip
                            (map
                             (\id -> (!!) buttons <$> (fromIntegral <$> id))
                             ids') states) :: [ Maybe (Button, Bool) ]
  sequence $ map (\comb' -> sequence $
                    (\(button, state) ->
                           setButtonState button state) <$> comb') comb
  atomically $ modifyTVar' tState
    (\state -> state { stNotisForMe = [] })
  return False

hideNotiCenter tState = do
  state <- readTVarIO tState
  mainWindow <- stMainWindow <$> readTVarIO tState
  widgetHide mainWindow
  atomically $ modifyTVar' tState
    (\state -> state { stCenterShown = False })

showNotiCenter tState notiState = do
  state <- readTVarIO tState
  mainWindow <- stMainWindow <$> readTVarIO tState
  newShown <- if stCenterShown state then
    do
      widgetHide mainWindow
      return False
    else
    do
      hideAllNotis $ stNotiState state
      widgetShow mainWindow
      return True
  atomically $ modifyTVar' tState
    (\state -> state {stCenterShown = newShown })
  return True

updateNotisForMe :: TVar State -> IO()
updateNotisForMe tState = do
  state <- readTVarIO tState
  notiState <- readTVarIO $ stNotiState state
  atomically $ modifyTVar' (stNotiState state) (
    \state -> state { notiForMeList = [] })
  atomically $ modifyTVar' tState (
    \state -> state { stNotisForMe = notiForMeList notiState
                                     ++ stNotisForMe state})

  addSource (parseNotisForMe tState)
  return ()

updateNotis :: Config -> TVar State -> IO()
updateNotis config tState = do
  state <- readTVarIO tState
  notiState <- readTVarIO $ stNotiState state

  let newNotis = filter (
        \n -> (find (\nd -> dNotiId nd == notiId n )
               (stDisplayingNotiList state))
              == Nothing
              && ((configIgnoreTransient config) || (not $ notiTransient n)))
                 $ notiStList notiState
  newNotis' <- mapM (
    \n -> do
      let newNoti = DisplayingNotificaton
                    { dNotiId = notiId n }
      showNotification config
        (stNotiBox state) newNoti
        (stNotiState state) $ removeNoti tState
    ) newNotis

  let delNotis = filter (\nd -> (find (\n -> dNotiId nd == notiId n)
                                $ notiStList notiState) == Nothing)
                 $ stDisplayingNotiList state
  atomically $ modifyTVar' tState (
    \state -> state { stDisplayingNotiList =
                      newNotis' ++ stDisplayingNotiList state
                    })
  setDeleteAllState tState
  mapM (removeNoti tState) $ delNotis
  when (stCenterShown state) $
    do
      hideAllNotis $ stNotiState state
  return ()

removeNoti :: TVar State -> DisplayingNotificaton -> IO ()
removeNoti tState dNoti = do
  state <- readTVarIO tState
  atomically $ modifyTVar' tState $ \state ->
    state { stDisplayingNotiList =
            filter ((/=) dNoti) $ stDisplayingNotiList state}
  setDeleteAllState tState
  atomically $ modifyTVar' (stNotiState state) $ \state ->
    state { notiStList = filter
                         (\n -> notiId n /= dNotiId dNoti) $
                         notiStList state }
  addSource $ do
    dNotiDestroy dNoti
    return False
  return ()

setDeleteAllState tState = do
  addSource $ do
    state <- readTVarIO tState
    if (length $ stDisplayingNotiList state) > 1 then
      widgetShow $ stDeleteAll state
      else
      widgetHide $ stDeleteAll state
    return False
  return ()

getConfig p =
  Config
  {
    -- notification-center
    configBarHeight = r 0 p nCenter "marginTop"
  , configWidth = r 500 p nCenter "width"
  , configStartupCommand = r' "" p nCenter "startupCommand"
  , configNotiCenterMonitor = r 0 p nCenter "monitor"
  , configNotiCenterNewFirst = r'' True p nCenter "newFirst"
  , configIgnoreTransient = r'' False p nCenter "ignoreTransient"
  , configMatchingRules = zip3 match (modify ++ repeat id) $ run ++ repeat Nothing -- run
  , configNotiMarkup = r'' True p nCenter "useMarkup"
  , configSendNotiClosedDbusMessage = r'' False p nCenter "configSendNotiClosedDbusMessage"

    -- notification-center-notification-popup
  , configNotiDefaultTimeout = r 10000 p nPopup "notiDefaultTimeout"
  , configDistanceTop = r 50 p nPopup "distanceTop"
  , configDistanceRight = r 50 p nPopup "distanceRight"
  , configDistanceBetween = r 20 p nPopup "distanceBetween"
  , configWidthNoti = r 300 p nPopup "width"
  , configNotiMonitor = r 0 p nPopup "monitor"

    -- buttons
  , configButtonsPerRow = r 5 p buttons "buttonsPerRow"
  , configButtonHeight = r 60 p buttons "buttonHeight"
  , configButtonMargin = r 2 p buttons "buttonMargin"
  , configLabels = r' "" p buttons "labels"
  , configCommands = r' "" p buttons "commands"
  , configUserButtonColor = r' "#fee" p buttons "buttonColor"
  , configUserButtonHover = r' "rgba(0, 20, 20, 0.2)" p buttons "buttonHover"
  , configUserButtonHoverColor = r' "#fee" p buttons "buttonHoverColor"
  , configUserButtonBackground = r' "rgba(255, 255, 255, 0.15)" p buttons "buttonBackground"
  , configUserButtonTextSize = r' "12px" p buttons "buttonTextSize"
  , configUserButtonState1 = r' "rgba(255,255,255,0.5)" p buttons "buttonState1"
  , configUserButtonState2 = r' "rgba(255,255,255,0.3)" p buttons "buttonState2"
  , configUserButtonState1Color = r' "#fff" p buttons "buttonState1Color"
  , configUserButtonState2Color = r' "#fff" p buttons "buttonState2Color"
  , configUserButtonState1Hover = r' "rgba(0, 20, 20, 0.4)" p buttons "buttonState1Hover"
  , configUserButtonState2Hover = r' "rgba(0, 20, 20, 0.3)" p buttons "buttonState2Hover"
  , configUserButtonState1HoverColor = r' "#fee" p buttons "buttonState1HoverColor"
  , configUserButtonState2HoverColor = r' "#fee" p buttons "buttonState2HoverColor"

    -- colors
  , configBackground = r' "rgba(29, 27, 20, 0.6)" p colors "background"
  , configBackgroundNoti = r' "rgba(9, 0, 0, 0.5)" p colors "notiBackground"
  , configNotiLabelColor = r' "#fef3f6" p colors "notiColor"
  , configCritical = r' "rgba(255, 0, 0, 0.5)" p colors "critical"
  , configCriticalInCenter = r' "rgba(155, 0, 20, 0.5)" p colors "criticalInCenter"
  , configButtonColor = r' "#FFFFFF" p colors "buttonColor"
  , configButtonHover = r' "rgba(0, 20, 20, 0.2)" p colors "buttonHover"
  , configButtonHoverColor = r' "#fee" p colors "buttonHoverColor"
  , configButtonBackground = r' "transparent" p colors "buttonBackground"
  , configLabelColor = r' "#eae2e0" p colors "labelColor"
  , configCriticalColor = r' "#FFFFFF" p colors "criticalColor"
  , configCriticalInCenterColor = r' "#FFFFFF" p colors "criticalInCenterColor"
  }
  where nPopup = "notification-center-notification-popup"
        nCenter = "notification-center"
        colors = "colors"
        buttons = "buttons"
        r = readConfig
        r' = readConfig
        r'' = readConfig
        keys conditions = map (\c -> if length (splitted c) == 2
                                     then (splitted c) else ["", ""]) conditions
          where splitted condition = splitOn "=" condition

        match = map (matcherFunction) $ splitOn ";" <$>
                (split $ removeOuterLetters $ r' "" p nCenter "match")
                where lookupFun name noti = Text.unpack $ fromMaybe (Text.pack "")
                        ((lookup name
                          [ ("title", notiSummary)
                          , ("body", notiBody)
                          , ("app", notiAppName)
                          , ("time", notiTime)
                          , ("icon", notiIcon) ]) <*> (Just noti))
                      matcherFunction conditions = \noti -> foldl (
                        \matches (k:v:[]) -> matches && ((v == lookupFun k noti)))
                                                      True (keys conditions)
        modify = map (matcherFunction) $ splitOn ";" <$>
                 (split $ removeOuterLetters $ r' "" p nCenter "modify")
          where matcherFunction condition = \noti -> foldl (
                  \noti (k:v:[]) -> switch k v noti) noti (keys condition)
                        where switch k v noti
                                | k == "title" = noti { notiSummary = Text.pack v }
                                | k == "body" = noti { notiBody = Text.pack v }
                                | k == "app" = noti { notiAppName = Text.pack v }
                                | k == "time" = noti { notiTime = Text.pack v }
                                | k == "icon" = noti { notiIcon = Text.pack v }
                                | k == "transient" && v == "true" = noti { notiTransient = True }
                                | k == "transient" && v == "false" = noti { notiTransient = False }
                                | k == "noClosedMsg" && v == "true" = noti { notiSendClosedMsg = False }
                                | otherwise = noti

        run = [Nothing]

replaceColors config style =
  replace "replaceme0000" (configBackground config) $
  replace "replaceme0001" (configCritical config) $
  replace "replaceme0002" (configCriticalInCenter config) $
  replace "replaceme0003" (configButtonColor config) $
  replace "replaceme0004" (configButtonHover config) $
  replace "replaceme0005" (configButtonHoverColor config) $
  replace "replaceme0006" (configButtonBackground config) $
  replace "replaceme0007" (configLabelColor config) $
  replace "replaceme0008" (configCriticalColor config) $
  replace "replaceme0009" (configCriticalInCenterColor config) $
  replace "replaceme0010" (configBackgroundNoti config) $
  replace "replaceme0011" (configNotiLabelColor config) $
  replace "replaceme0012" (configUserButtonTextSize config) $
  replace "replaceme0013" (configUserButtonBackground config) $
  replace "replaceme0014" (configUserButtonColor config) $
  replace "replaceme0015" (configUserButtonHover config) $
  replace "replaceme0016" (configUserButtonHoverColor config) $
  replace "replaceme0017" (configUserButtonState1 config) $
  replace "replaceme0018" (configUserButtonState2 config) $
  replace "replaceme0019" (configUserButtonState1Color config) $
  replace "replaceme0020" (configUserButtonState2Color config) $
  replace "replaceme0021" (configUserButtonState1Hover config) $
  replace "replaceme0022" (configUserButtonState2Hover config) $
  replace "replaceme0023" (configUserButtonState1HoverColor config) $
  replace "replaceme0024" (configUserButtonState2HoverColor config) style

getInitialState = do
  newTVarIO $ State
    { stDisplayingNotiList = []
    , stCenterShown = False}

main' :: IO ()
main' = do
  GI.init Nothing

  homeDir <- getHomeDirectory
  config <- getConfig <$> (readConfigFile
    (homeDir ++ "/.config/deadd/deadd.conf"))

  istate <- getInitialState
  notiState <- startNotificationDaemon config
    (updateNotis config istate) (updateNotisForMe istate)

  atomically $ modifyTVar' istate $
    \istate' -> istate' { stNotiState = notiState }
  createNotiCenter istate config

  unixSignalAdd PRIORITY_HIGH (fromIntegral sigUSR1)
    (showNotiCenter istate notiState)

  runCommand $ configStartupCommand config

  GI.main

main :: IO ()
main = do
--  daemonize main'
  main'


-----------------------------------------------------------------------------
-- |
-- Module      : Berp.Base.SemanticTypes
-- Copyright   : (c) 2010 Bernie Pope
-- License     : BSD-style
-- Maintainer  : florbitous@gmail.com
-- Stability   : experimental
-- Portability : ghc
--
-- The core types used to represent the state of Python programs. We put
-- them all here in one file because they tend to be mutually recursive.
-- Using one file for such types tends to avoid problems with unbreakable
-- cycles in the Haskell module imports. Try not to put functions in here
-- (except perhaps type class instances).
--
-----------------------------------------------------------------------------

module Berp.Base.SemanticTypes
   ( Procedure, ControlStack (..), EvalState (..), Object (..), Eval, ObjectRef
   , HashTable, HashSet, ListArray, Arity, ModuleCache
   , initState )  where

import Data.Typeable (Typeable)
import Control.Monad.State.Strict (StateT)
import Control.Monad.Cont (ContT)
import Data.IntMap (IntMap)
import Data.Map as Map (Map, empty)
import Data.IORef (IORef)
import Data.Complex (Complex)
import Data.Array.IO (IOArray)
import Berp.Base.Identity (Identity)

data ControlStack
   = EmptyStack
   | ProcedureCall
     { procedure_return :: Object -> Eval Object
     , control_stack_tail :: ControlStack
     }
   | ExceptionHandler
     { exception_handler :: Maybe (Object -> Eval Object)
     , exception_finally :: Maybe (Eval Object)
     , control_stack_tail :: ControlStack
     }
   | WhileLoop
     { loop_start :: Eval Object
     , loop_end :: Eval Object
     , control_stack_tail :: ControlStack
     }
   | GeneratorCall
     { generator_yield :: Object -> Eval Object
     , generator_object :: Object
     , control_stack_tail :: ControlStack
     }

instance Show ControlStack where
   show EmptyStack = "EmptyStack"
   show (ProcedureCall {}) = "ProcedureCall"
   show (ExceptionHandler {}) = "ExceptionHandler"
   show (WhileLoop {}) = "WhileLoop"
   show (GeneratorCall {}) = "GeneratorCall"

data EvalState =
   EvalState
   { state_control_stack :: !ControlStack
   , state_builtins :: !HashTable
   , state_moduleCache :: !ModuleCache
   }

initState :: HashTable -> EvalState
initState builtins =
   EvalState
   { state_control_stack = EmptyStack
   , state_builtins = builtins
   , state_moduleCache = Map.empty
   }

type ModuleCache = Map String Object

type Eval a = StateT EvalState (ContT Object IO) a

type ObjectRef = IORef Object
type Procedure = [Object] -> Eval Object

-- XXX maybe this should be:
-- IORef (IntMap (IORef [(Object, Object)]))
-- or even:
-- IORef (IntMap (IORef [(Object, ObjectRef)]))
-- type HashTable = IORef (IntMap [(Object, Object)])

type HashTable = IORef (IntMap [(Object, ObjectRef)])
type HashSet = IORef (IntMap [Object])

type ListArray = IOArray Integer Object
type Arity = Int

{-
-- Here's another possible encoding of objects which is more abstract.
-- It would make it easier to add new object types, and they could be added
-- in separate modules. The problem is that it would make it slower for
-- detecting the kind of object we have, compared to the Alegabraic approach
-- which gives us a tag to match against.

class ObjectLike t where
   identity :: t -> Identity
   ...

data Object = forall t . (ObjectLike t, Typeable t) => O t

instance ObjectLike Object where
   identity (O x) = identity x
   ...
-}

-- XXX probably need Bound Methods.
data Object
   = Object
     { object_identity :: !Identity
     , object_type :: !Object -- type
     , object_dict :: !Object -- dictionary
     }
   | Type
     { object_identity :: !Identity
     , object_type :: Object  -- type, is this needed? Is the type of all types == type?
     , object_dict :: !Object  -- dictionary
     , object_bases :: !Object -- tuple
     , object_constructor :: !Procedure
     , object_type_name :: !Object -- string
     , object_mro :: !Object -- tuple. Method Resolution Order.
     }
   | Integer
     { object_identity :: !Identity
     , object_integer :: !Integer
     }
   | Float
     { object_identity :: !Identity
     , object_float :: !Double
     }
   | Complex
     { object_identity :: !Identity
     , object_complex :: Complex Double
     }
   | Bool
     { object_identity :: !Identity
     , object_bool :: !Bool
     }
   | Tuple
     { object_identity :: !Identity
     , object_tuple :: ![Object]
     , object_length :: !Int
     }
   -- We must allow the contents and the size of an array to change.
   | List
     { object_identity :: !Identity
     , object_list_elements :: !(IORef ListArray)
     , object_list_num_elements :: !(IORef Integer)
     }
   | Function
     { object_identity :: !Identity
     , object_procedure :: !Procedure
     , object_arity :: !Arity
     , object_dict :: !Object -- dictionary
     }
   | String
     { object_identity :: !Identity
     , object_string :: !String
     }
   | Dictionary
     { object_identity :: !Identity
     , object_hashTable :: !HashTable
     }
   | Set
     { object_identity :: !Identity
     , object_hashSet :: !HashSet
     }
   | Generator
     { object_identity :: !Identity
     , object_continuation :: !(IORef (Eval Object))
     , object_stack_context :: !(IORef (ControlStack -> ControlStack))
     }
     -- Modules probably need names and source information.
   | Module
     { object_identity :: !Identity
     , object_dict :: !Object -- dictionary
     }
   | None

-- For debugging only
instance Show Object where
   show obj@(Object {}) = "object of (" ++ show (object_type obj) ++ ")"
   show obj@(Type {}) = "type(" ++ show (object_type_name obj) ++ ")"
   show obj@(Integer {}) = "integer(" ++ show (object_integer obj) ++ ")"
   show obj@(Float {}) = "float(" ++ show (object_float obj) ++ ")"
   show obj@(Bool {}) = "bool(" ++ show (object_bool obj) ++ ")"
   show (Tuple {}) = "tuple"
   show (List {}) = "list"
   show (Function {}) = "function"
   show obj@(String {}) = "string(" ++ show (object_string obj) ++ ")"
   show (Dictionary {}) = "dictionary"
   show (Set {}) = "set"
   show (Generator {}) = "generator"
   show obj@(Complex {}) = "complex(" ++ show (object_complex obj) ++ ")"
   show (Module {}) = "module"
   show (None {}) = "None"

-- equality instance for objects
-- NOTE: use with care. This does not call the user defined equality
-- on the object. It only uses identity equality.

instance Eq Object where
   None {} == None {} = True
   obj1 == obj2 = object_identity obj1 == object_identity obj2


import qualified Network as N
import qualified Network.Socket as NS
import qualified Utils as U
import qualified OrderDistribution as OD
import qualified StatisticsMaster as Stat
import qualified SortMaster as Sort

import System.IO
import System.Environment
import System.Directory
import Control.Concurrent
import Control.Monad

import Data.String

main :: IO ()
main = do
    orders <- newChan
    orderType <- newEmptyMVar
    registering <- newChan
    registered <- newMVar []
    workStatus <- newChan
    workFiltering <- newChan
    okToProcess <- newChan
    filteredWork <- newMVar []
    jobCount <- newMVar 0
    forkIO $ receiveOrders orders orderType workStatus
    forkIO $ receiveRegistrations registering
    forkIO $ sortRegistrations registering registered
    forkIO $ sendOrders orders registered jobCount
    forkIO $ receiveWork workFiltering okToProcess jobCount
    forkIO $ filterWork workFiltering filteredWork
    forkIO $ processWork okToProcess filteredWork orderType workStatus
    forever $ do
        putStrLn "Master is active..."
        threadDelay 5000000

-- |Receives connections from messengers
receiveOrders :: Chan [String]    -- ^ Channel used for broadcasting orders across threads
              -> MVar String      -- ^ Variable used to define the type of order to be executed by each slave (keyword research or statistics)
              -> Chan String      -- ^ Channel used for broadcasting status of work
              -> IO ()
receiveOrders orders orderType workStatus = do
    socket <- N.listenOn (N.PortNumber 4445)
    putStrLn "Receiving orders on 4445..."
    forever $ N.accept socket >>= handleOrders orders orderType workStatus

{-|
    Reads order from messenger and broadcasts order to orders channel.
    Upon order's completion or failure, the function sends a status reply to messenger.
-}
handleOrders :: Chan [String]                        -- ^ Channel used for broadcasting orders across threads
             -> MVar String                          -- ^ Variable used to define the type of order to be executed by each slave (keyword research or statistics)
             -> Chan String                          -- ^ Channel used for broadcasting status of work
             -> (Handle, NS.HostName, NS.PortNumber) -- ^ Returned by N.accept method
             -> IO ()
handleOrders orders orderType workStatus (handle, hostName, portNumber) = do
    hSetBuffering handle LineBuffering
    code <- hGetLine handle
    let order = read code :: [String]
    let typeOfOrder = order !! 0
    putMVar orderType typeOfOrder
    print $ "Received orders : " ++ (show order)
    writeChan orders order
    status <- readChan workStatus -- "OK" or "KO"
    hPutStrLn handle status
    hClose handle

-- |Opens port no. 4444 for slave registration
receiveRegistrations :: Chan String -- ^ Channel used for broadcasting registering slaves
                     -> IO ()
receiveRegistrations registering = do
    socket <- N.listenOn (N.PortNumber 4444)
    putStrLn "Receiving registrations on 4444..."
    forever $ NS.accept socket >>= (handleRegistrations registering)

-- |Receives connections from registering slaves
handleRegistrations :: Chan String              -- ^ Channel used for broadcasting registering slaves
                    -> (NS.Socket, NS.SockAddr) -- ^ Returned by NS.accept method
                    -> IO ()
handleRegistrations registering (socket, sockaddr) = do
    let socketAddress = sockaddr
    let ipAddress = U.stripIP socketAddress
    print $ "New slave registering from " ++ ipAddress
    writeChan registering ipAddress

{-|
    Sorts registering slaves by ensuring that there are no duplicate IPs in slave IP address table
-}
sortRegistrations :: Chan String      -- ^ Channel used for broadcasting registering slaves
                  -> MVar [String]    -- ^ Variable containing all registered slaves
                  -> IO()
sortRegistrations registering registered = do
    newAddress <- readChan registering
    registered' <- takeMVar registered
    if (elem newAddress registered')
        then do
            putMVar registered registered'
            sortRegistrations registering registered
        else do
            let currentlyRegistered = registered' ++ [newAddress]
            print $ "Slaves currently registered : " ++ (show currentlyRegistered)
            putMVar registered currentlyRegistered
            sortRegistrations registering registered

-- |Checks if slaves are present. If so, orders are dispatched to slaves.
sendOrders :: Chan [String] -- ^ Channel used for broadcasting orders across threads
           -> MVar [String] -- ^ Variable containing all registered slaves
           -> MVar Int      -- ^ Variable indicating the number of jobs currently sent out. This mitigates the possibility that there be more slaves than jobs available.
           -> IO ()
sendOrders orders registered jobCount = do
    orders' <- readChan orders
    print $ "Orders to be parsed : " ++ (show orders')
    registered' <- takeMVar registered
    putMVar registered registered'
    let numberOfRegistered = length registered'
    if numberOfRegistered > 0
        then do
            let parsedOrders = OD.parseArguments orders' numberOfRegistered
            print $ "Parsed orders : " ++ (show parsedOrders)
            dispatchOrders parsedOrders registered' jobCount
            sendOrders orders registered jobCount
        else do
            putStrLn "No slaves available!"
            writeChan orders orders'
            threadDelay 5000000
            sendOrders orders registered jobCount

-- |Dispatches orders to all slaves
dispatchOrders :: [[[String]]]     -- ^ Parsed orders
               -> [String]         -- ^ slave IP address table
               -> MVar Int         -- ^ Variable indicating the number of jobs currently sent out. This mitigates the possibility that there be more slaves than jobs available.
               -> IO ()
dispatchOrders _ [] _ = putStrLn "All orders dispatched or no slaves available"
dispatchOrders [] _ _ = putStrLn "All orders dispatched or no parsed orders"
dispatchOrders (x:xs) (y:ys) jobCount = do
    print $ "Dispatching orders to " ++ (show (y:ys))
    dispatchOrder x y jobCount
    print $ "Dispatched order to : " ++ y
    dispatchOrders xs ys jobCount

-- |Dispatches order to a slave
dispatchOrder :: [[String]]   -- ^ Order
              -> String       -- ^ IP address of a particular slave
              -> MVar Int     -- ^ Variable indicating the number of jobs currently sent out. This mitigates the possibility that there be more slaves than jobs available.
              -> IO ()
dispatchOrder o a jobCount = do
    jobCount' <- takeMVar jobCount
    putMVar jobCount (jobCount' + 1)
    print $ "Attempting to connect to : " ++ a
    handle <- N.connectTo a (N.PortNumber 5000)
    print $ "Connected to slave @ " ++ a
    hPutStrLn handle (show o)
    hClose handle

{-|
    Function intercepting all incoming work from slaves.
    Each slave has its work transferred to the workFiltering channel.
    The function then reads all work on the workFiltering channel and generates
    a large table which is then used for JSON creation.
-}
receiveWork :: Chan String      -- ^ Channel where work from slaves is deposited on
            -> Chan String      -- ^ Channel used to indicated all expected work has arrived
            -> MVar Int         -- ^ Variable indicating the number of jobs currently sent out. This mitigates the possibility that there be more slaves than jobs available.
            -> IO ()
receiveWork workFiltering okToProcess jobCount = do
    slaveCountReception <- newMVar 1
    socket <- N.listenOn (N.PortNumber 4446)
    forever $ N.accept socket >>= forkIO . (handleWork workFiltering okToProcess slaveCountReception jobCount)

-- |Transfers each slave's work onto workFiltering channel
handleWork :: Chan String                           -- ^ Channel where work from slaves is deposited on
           -> Chan String                           -- ^ Channel used to indicated all expected work has arrived
           -> MVar Int                              -- ^ Variable/counter of all slaves who have currently deposited work
           -> MVar Int                              -- ^ Variable indicating the number of jobs currently sent out. This mitigates the possibility that there be more slaves than jobs available.
           -> (Handle, NS.HostName, NS.PortNumber)  -- ^ Result of N.accept
           -> IO ()
handleWork workFiltering okToProcess slaveCountReception jobCount (handle, hostName, portNumber) = do
    putStrLn "Slave ready to return work"
    code <- hGetLine handle
    hClose handle
    print $ "Work retrieved : " ++ code
    writeChan workFiltering code
    jobCount' <- takeMVar jobCount
    print $ "Number of jobs sent out : " ++ (show jobCount')
    slaveCountReception' <- takeMVar slaveCountReception
    print $ "Number of slaves who have sent back work : " ++ (show slaveCountReception')
    if slaveCountReception' == jobCount'
        then do
            putMVar slaveCountReception 1
            putMVar jobCount 0
            writeChan okToProcess "OK"
            putStrLn "Ok to process"
        else do
            putMVar slaveCountReception (slaveCountReception' + 1)
            putMVar jobCount jobCount'

-- |Filters incoming work by reading workFiltering channel and adding work to the filteredWork table variable.
filterWork :: Chan String   -- ^ Channel where work from slaves is deposited on
           -> MVar [String] -- ^ Variable containing all currently received work from slaves
           -> IO ()
filterWork workFiltering filteredWork = do
    work <- readChan workFiltering
    filteredWork' <- takeMVar filteredWork
    if (elem work filteredWork')
        then do
            putStrLn "Duplicated work detected!"
            putMVar filteredWork filteredWork'
            filterWork workFiltering filteredWork
        else do
            putMVar filteredWork (work : filteredWork')
            filterWork workFiltering filteredWork

{-|
    Extracts filteredWork variable and sends it to the appropriate function (statistics or keyword)
    depending on the first argument of the order.
-}
processWork :: Chan String      -- ^ Channel used to indicated all expected work has arrived
            -> MVar [String]    -- ^ Variable containing all currently received work from slaves
            -> MVar String      -- ^ Variable used to define the type of order to be executed by each slave (keyword research or statistics)
            -> Chan String      -- ^ Channel used for broadcasting status of work
            -> IO ()
processWork okToProcess filteredWork orderType workStatus = do
    status <- readChan okToProcess
    if status == "OK"
        then do
            allOfTheWork <- takeMVar filteredWork
            orderType' <- takeMVar orderType
            if orderType' == "N/A"
                then statistics allOfTheWork
                else keyword allOfTheWork
            writeChan workStatus "OK"
            putMVar filteredWork []
            processWork okToProcess filteredWork orderType workStatus
        else do
            putStrLn "Waiting for all slaves to submit work"
            processWork okToProcess filteredWork orderType workStatus

-- |Creates JSON for statistics display
statistics  :: [String] -- ^ Extracted value from filteredWork mvar
            -> IO ()
statistics work = do
    putStrLn "Working on statistics"
    path <- getCurrentDirectory
    let jsonPath =  (take ((length path) - 7) ) path ++ "public\\views\\json"
    writeFile (jsonPath ++ "\\" ++ "statistics.json") (Stat.concatStatistics work)
    putStrLn "Statistics done"

-- |Creates JSON for keyword display
keyword :: [String] -- ^ Extracted value from filteredWork mvar
        -> IO ()
keyword work = do
    putStrLn "Working on keywords"
    path <- getCurrentDirectory
    let jsonPath =  (take ((length path) - 7) ) path ++ "public\\views\\json"
    writeFile (jsonPath ++ "\\" ++ "chronological.json") (Sort.concatChronologicalSort work)
    writeFile (jsonPath ++ "\\" ++ "per-season.json") (Sort.concatSeasonSort work)
    writeFile (jsonPath ++ "\\" ++ "pertinence.json") (Sort.concatRelevanceSort work)
    putStrLn "Keywords done"