{-# LANGUAGE InstanceSigs, ScopedTypeVariables #-}

-- Continuation passing style.

data Action =
  Stop
  | Atomic (IO Action)
  | Fork Action Action

  
scheduler :: [Action] -> IO ()
scheduler [] = return ()
scheduler (Stop:xs) = scheduler xs
scheduler (Atomic io : xs) = do
  a <- io
  scheduler (xs ++ [a])
scheduler (Fork a b : xs) = scheduler (xs ++ [a, b])


type Concurrent a = Cont Action a 

embed :: Action -> Concurrent ()
embed a = CT $ \ k -> Fork a (k ())   -- k :: () -> Action

atomic :: IO a -> Concurrent a
atomic io = CT $ \ k -> Atomic $ do{ 
                        x <- io;
                        return $ k x}

  -- (a -> Action) -> Action
  -- k :: a -> Action 

writeAction' :: String -> Concurrent ()
writeAction' [] = return ()
writeAction' (c:cs) = do
  atomic (putChar c)
  writeAction' cs

twoActions :: Concurrent ()
twoActions = do
  writeAction' "hello "
  writeAction' "world!\n"

manyActions :: Concurrent ()
manyActions = do
  fork (writeAction' "hello")
  fork (writeAction' "world")
  writeAction' "finish"
  writeAction' "earth"
  writeAction' "color\n"


fork :: Concurrent () -> Concurrent ()
fork (CT f) =  -- f :: (() -> Action) -> Action
  embed $ Fork (f (\ x -> Stop)) Stop 
  

runConcurrent :: Concurrent a -> IO ()
runConcurrent (CT f) = scheduler [f (\ x -> Stop)]

-- f :: (a -> Action) -> Action

writeAction :: String -> Action
writeAction [] = Stop
writeAction (c:cs) =
  Atomic $ do
    putChar c
    return $ writeAction cs


data Cont r a = CT ((a -> r) -> r)

runCont :: Cont r a -> (a -> r) -> r
runCont (CT g) = g

instance Functor (Cont r) where
  fmap :: (a -> b) -> Cont r a -> Cont r b
  fmap f (CT c) = CT $ \ k -> c (\ x -> k (f x))

  -- (b -> r) -> r
    -- k :: b -> r
    -- f :: a -> b
    -- c :: (a -> r) -> r
    -- c (\ x -> k (f x))

instance Applicative (Cont r) where


instance Monad (Cont r) where
  return :: a -> Cont r a
  return x = CT $ \ k -> k x
  -- (a -> r) -> r
  (>>=) :: Cont r a -> (a -> Cont r b) -> Cont r b
  CT g >>= f = CT $ \ k -> g (\ x -> let CT h = f x in h k)

    -- (b -> r) -> r
    -- g :: (a -> r) -> r
    -- f :: a -> Cont r b
    -- f x :: Cont r b
    -- h :: (b -> r) -> r
    
f'' :: Int -> Int -> Cont r Int
f'' x y = do
  xs <- square'' x
  ys <- square'' y
  add'' xs ys