import Control.Concurrent (
  Chan,
  ThreadId,
  forkIO,
  newChan,
  readChan,
  threadDelay,
  writeChan,
 )
import Control.Exception (SomeException, catch, evaluate)
import Control.Monad (forM, forever, void)
import Distribution.Simple.Build (repl)

-- import GenServer

data Server msg = Server ThreadId (Chan msg)

spawn :: (Chan msg -> IO ()) -> IO (Server msg)
spawn f = do
  c <- newChan
  fid <- forkIO $ f c
  pure $ Server fid c

send :: Chan msg -> msg -> IO ()
send = writeChan

receive :: Chan msg -> IO msg
receive = readChan

-- asynchronous
sendTo :: Server msg -> msg -> IO ()
sendTo (Server _ c) msg = send c msg

data ReplyChan a = ReplyChan (Chan a)

reply :: ReplyChan a -> a -> IO ()
reply (ReplyChan c) = send c

requestReply :: Server msg -> (ReplyChan a -> msg) -> IO a
requestReply server mkMsg = do
  rc <- newChan
  let msg = mkMsg $ ReplyChan rc
  sendTo server msg
  receive rc

--

type Seconds = Int

data Status a
  = Value a
  | Timeout
  | Error String
  deriving (Show)

data Async a = Async (Server (Msg a))

data Msg a
  = MsgWait (ReplyChan (Status a))
  | MsgPoll (ReplyChan (Maybe (Status a)))
  | MsgPutVal a
  | MsgTimeout
  | MsgError String

{-
serverLoopOld :: a -> Chan (Msg a) -> IO ()
serverLoopOld x c = do
  msg <- receive c
  case msg of
    MsgWait rc -> do
      reply rc x
      serverLoopOld x c
    MsgPoll rc -> do
      reply rc $ Just x
      serverLoopOld x c
    MsgPutVal a -> undefined
-}

-- State machine approach

serverLoopNoVal :: Chan (Msg a) -> [ReplyChan (Status a)] -> IO ()
serverLoopNoVal c waiters = do
  msg <- receive c
  case msg of
    MsgWait rc -> do
      serverLoopNoVal c (rc : waiters)
    MsgPoll rc -> do
      reply rc Nothing
      serverLoopNoVal c waiters
    MsgPutVal a -> do
      mapM_ (\rc -> reply rc (Value a)) waiters
      serverLoopVal (Value a) c
    MsgTimeout -> do
      mapM_ (\rc -> reply rc Timeout) waiters
      serverLoopNoVal c []
    MsgError e -> do
      mapM_ (\rc -> reply rc $ Error e) waiters
      serverLoopVal (Error e) c

serverLoopVal :: Status a -> Chan (Msg a) -> IO ()
serverLoopVal a c = do
  msg <- receive c
  case msg of
    MsgWait rc -> do
      reply rc $ a
      serverLoopVal a c
    MsgPoll rc -> do
      reply rc $ Just $ a
      serverLoopVal a c
    MsgPutVal _ ->
      serverLoopVal a c
    MsgTimeout -> do
      serverLoopVal a c
    MsgError _ -> do
      serverLoopVal a c

{-
-- will block only at wait, thx Haskell
asyncLazy :: (b -> a) -> b -> IO (Async a)
asyncLazy f x = do
  s <- spawn $ do
    let y = f x
    serverLoopOld y
  pure $ Async s

-- when serverLoop :: a -> Chan (Msg a) -> IO ()
asyncBlockServer :: (b -> a) -> b -> IO (Async a)
asyncBlockServer f x = do
  s <- spawn $ \c -> do
    y <- evaluate $ f x
    serverLoopOld y c
  pure $ Async s
-}

async :: (b -> a) -> b -> IO (Async a)
async f x = do
  s <- spawn $ \c -> do
    forkIO $ do
      y <- evaluate $ f x
      send c $ MsgPutVal y
    serverLoopNoVal c []
  pure $ Async s

asyncTimeout :: Seconds -> (b -> a) -> b -> IO (Async a)
asyncTimeout t f x = do
  s <- spawn $ \c -> do
    _ <- forkIO $ do
      let comp :: IO ()
          comp = do
            y <- evaluate $ f x
            send c $ MsgPutVal y
          handler :: SomeException -> IO ()
          handler e = do
            send c $ MsgError (show e)
      catch comp handler
    _ <- forkIO $ do
      threadDelay $ t * 1000000
      send c $ MsgTimeout
    serverLoopNoVal c []
  pure $ Async s

wait :: Async a -> IO (Status a)
wait (Async s) = requestReply s MsgWait

waitAny :: [Async a] -> IO (Status a)
waitAny [] = error "empty list"
waitAny [x] = wait x
waitAny (x : xs) = do
  c <- newChan
  forkIO $ do
    x' <- wait x
    send c x'
  forkIO $ do
    y' <- waitAny xs
    send c y'
  receive c

-- Check for computation finish
-- Should respond as quickly as possible
-- Won't work, cause the serverLoop does the job,
--   so it is blocked and cannot answer in time
pollSimple :: Async a -> IO (Maybe (Status a))
pollSimple (Async s) = requestReply s MsgPoll

poll :: Async a -> IO (Maybe (Status a))
poll (Async s) = requestReply s MsgPoll

-- DEMOS

fib :: Int -> Int
fib x
  | x == 0 = 1
  | x == 1 = 1
  | x < 0 = error ""
  | otherwise = (fib (x - 1)) + (fib (x - 2))

{-
demo1 :: IO ()
demo1 = do
  a <- asyncLazy fib 30
  res <- wait a -- continuation goes on, as the value is not used
  putStrLn "I got the result"
  putStrLn "Here it is:"
  putStrLn $ show res -- lazyness only force the actual blocking here

demo2 :: IO ()
demo2 = do
  a <- asyncBlockServer fib 30 -- will be eager evaluation at wait
  _ <- pollSimple a
  res <- wait a -- blocks here, as intended
  putStrLn "I got the result"
  putStrLn "Here it is:"
  putStrLn $ show res
-}

demo3 :: IO ()
demo3 = do
  a <- asyncTimeout 5 fib 30 -- will be eager evaluation at wait
  b <- poll a
  putStrLn $ "Poll returned: " ++ show b
  res <- wait a -- blocks here, as intended
  putStrLn "I got the result"
  putStrLn "Here it is:"
  putStrLn $ show res

-- No space

-- We are runnig aout of teaching

-- Written form exam
-- Dummy exam on the last week
-- Different size, and Maybe different difficulty (best guess according to him)

-- Finish of week7 exercise is expected, though marked [optional]

-- No idea how many questions
-- One TA is on it
-- Grading is not based on answer %

-- on week 8 and anything before exam: nothing planned
-- last lecture is on week 7

-- Exercise 7 is last year's exam