Lab1.hs

module MPS.Lab1 where

import Control.Concurrent
import Control.Concurrent.STM
import MPS.Env hiding (mod, read, length, drop, at)
import Prelude ()

import Data.Maybe
import Rika.Type.Default

import qualified Data.StateVar as StateVar

import Data.List ( genericDrop, genericLength )
import qualified Prelude as P

import Text.JSON.Generic
import Text.JSON.String

import qualified Control.Monad as Monad

import System.Exit ( exitWith, ExitCode(ExitSuccess) )

import Data.StateVar

import MPS.Extra (now)

import Data.Time.Clock.POSIX
import System.Exit
import Data.IORef
import MPS.Extra

at :: (Show a) => Int -> [a] -> a
at i xs = if i P.< xs.length
  then xs !! i
  else error - show xs ++ " at " ++ show i ++ " failed"
  
atom :: STM a -> IO a
atom = atomically

void :: (Monad m) => m a -> m ()
void x = x >>= const () > return

don't :: (Monad m) => m a -> m ()
don't = const - return ()

want :: (Monad m, Default b) => (Maybe a) -> (a -> m b) -> m b
want = flip - maybe (return def)

wantM :: (Monad m, Default b) => m (Maybe a) -> (a -> m b) -> m b
wantM x f = do
  x' <- x
  x'.want - f

length :: (Num i) => [a] -> i
length = genericLength

drop :: (Integral i) => i -> [a] -> [a]
drop = genericDrop

to_f :: (Real a, Fractional b) => a -> b
to_f = realToFrac 

sleep :: (RealFrac a) => a -> IO ()
sleep x = threadDelay - round - (x * 1000000)

append_maybe :: a -> Maybe [a] -> Maybe [a]
append_maybe x Nothing = Just [x]
append_maybe x (Just xs) = Just - x:xs

first_or :: a -> [a] -> a
first_or x xs = case xs of
  [] -> x
  (y:_) -> y
  
maybe_first :: [a] -> Maybe a
maybe_first xs = case xs of
  [] -> Nothing
  (y:_) -> Just y
  
    
update_list :: (a -> Bool) -> (a -> a) -> [a] -> [a]
update_list p f xs = do
  x <- xs
  let y = if p x then f x else x
  return y

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


exit_success :: IO ()
exit_success = exitWith ExitSuccess

decode_json :: (Data a) => String -> Either String a
decode_json s =
    case runGetJSON readJSValue s of
    Left msg -> Left msg
    Right j ->
        case fromJSON j of
        Error msg -> Left msg
        Ok x -> Right x

fork :: IO a -> IO ()
fork io = void - forkIO - void io


insert_unique :: (Eq a) => a -> [a] -> [a]
insert_unique x xs = x : xs.reject (is x)

squeeze :: (Monad m) => m (m a) -> m a
squeeze = Monad.join

end :: (Monad m) => m ()
end = return ()


mapT :: (HasGetter g, HasSetter g) => (a -> a) -> [g a] -> IO [g a]
mapT f xs = xs.mapM (\o -> do
  o $~ f
  return o
  )

filterT :: (HasGetter g) => (a -> Bool) -> [g a] -> IO [g a]
filterT f xs = xs.mapM (\o -> do
  object <- get o
  if f object
    then return - Just o
    else return - Nothing
  )
  .fmap catMaybes

findT :: (HasGetter g) => (a -> Bool) -> [g a] -> IO (Maybe (g a))
findT f xs = filterT f xs ^ listToMaybe

find_or_fail_with_message_T :: (HasGetter g) => String -> (a -> Bool) -> [g a] -> IO (g a)
find_or_fail_with_message_T msg f xs = do
  r <- findT f xs
  case r of
    Nothing -> error msg
    Just _r -> return _r



now_in_micro_seconds :: IO Integer
now_in_micro_seconds = 
  now ^ (utcTimeToPOSIXSeconds > (* 1000000) > floor)

now_in_milli_seconds :: IO Integer
now_in_milli_seconds = 
  now ^ (utcTimeToPOSIXSeconds > (* 1000) > floor)

return_after :: (RealFrac a) => a -> IO ExitCode -> IO ExitCode
return_after secs io = do
  exit_code_ref <- newTVarIO Nothing
  
  thread_id <- forkIO - do
    exit_code <- io 
    atom - writeTVar exit_code_ref - Just exit_code

  bomb_time <- now ^ t2f ^ (P.+ secs)
  
  let { wait_loop = do
      exit_code <- atom - readTVar exit_code_ref
    
      case exit_code of
        Just code -> return code
        Nothing -> do
          time_stamp <- now ^ t2f
          
          if time_stamp >= bomb_time
            then do
              -- killThread thread_id
              return - ExitFailure (-1)
            else do
              -- putStrLn "sleeping ..."
              sleep 0.1
              wait_loop
    }

  wait_loop