{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts, ScopedTypeVariables, BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DeriveGeneric, DeriveAnyClass, MultiParamTypeClasses, FunctionalDependencies, KindSignatures, TypeFamilies, ConstraintKinds, UndecidableInstances, UndecidableSuperClasses, FlexibleInstances, PolyKinds #-}
{-# LANGUAGE AllowAmbiguousTypes, DerivingStrategies, StandaloneDeriving, GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fplugin=Control.Effects.Plugin #-}
module Main where

import Control.Monad.IO.Class
import Control.Monad
import Control.Effects.Signal
import Control.Effects.State
import Control.Effects.Early
import Control.Effects.Async
import Control.Effects.List
import Control.Effects.Yield
import Control.Effects.Resource
import Control.Effects.Newtype
import Control.Concurrent hiding (yield)
import System.IO
import GHC.Generics (Generic)
import Control.Monad.State hiding (State)
import Data.Kind
import Data.Function

-- Should infer
ex1 = signal True

-- Should compile
ex2 :: MonadEffect (Throw Bool) m => m ()
ex2 = throwSignal False

ex3 = do
    void $ discardAllExceptions ex1
    void $ showAllExceptions ex2
    handleException (\(_ :: Bool) -> return ()) ex2
    handleSignal (\(_ :: Bool) -> return $ Resume 5) ex1

-- Nested Early
testEarly1 :: Monad m => m Bool
testEarly1 = handleEarly $ do
    return ()
    _ <- earlyReturn True
    _ <- handleEarly $ do
        return ()
        earlyReturn (123 :: Int)
    _ <- testEarly2
    return True

testEarly2 :: Monad m => m Char
testEarly2 = handleEarly $
    earlyReturn 'a'

orderTest :: (MonadEffects '[HandleException Bool, Throw Bool, State Int] m, MonadIO m) => m ()
orderTest = do
    setState (1 :: Int)
    _ :: Either Bool () <- handleToEitherRecursive $ do
        setState (2 :: Int)
        void $ throwSignal True
        setState (3 :: Int)
    st :: Int <- getState
    liftIO (print st)

inc :: Int -> Int
inc !x = x + 1

task :: (MonadEffect (State Int) m) => m Int
task = do
    replicateM_ 10000000 (modifyState inc)
    st <- getState
    st `seq` return st

mainParallel :: IO ()
mainParallel = do
    orderTest & handleException (\(_ :: Bool) -> return ())
              & implementStateViaStateT (0 :: Int)
    orderTest & implementStateViaStateT (0 :: Int)
              & handleException (\(_ :: Bool) -> return ())
    putStrLn "Starting sequential test"
    replicateM_ 8 (implementStateViaStateT (0 :: Int) task >>= print)
    putStrLn "Sequential test done"
    putStrLn "Starting parallel test"
    implementStateViaStateT (0 :: Int) $ do
        res <- parallelMapM id (replicate 8 task)
        mapM_ (liftIO . print) res
    putStrLn "Parallel test done"

parallelTest ::
    (MonadEffects '[Async thread, NonDeterminism] m, MonadIO m) => m (thread m (Int, Char))
parallelTest = do
    n <- choose [1,2,3,4]
    async $ do
        liftIO $ threadDelay ((5 - n) * 1000000)
        l <- choose "ab"
        return (n, l)

mainAsync :: IO ()
mainAsync = do
    threads <- evaluateToList parallelTest
    forM_ threads $ \thread ->
        evaluateToList (do
            p <- waitAsync thread
            liftIO $ print p
            )

yieldTest ::
    (MonadEffects '[Yield Int, Async thread] m, MonadIO m) => m ()
yieldTest = do
    yield @Int 5
    t <- async $ do
        liftIO $ putStrLn "yielding 6"
        yield @Int 6
        liftIO $ putStrLn "yielding 10"
        yield @Int 10

    t2 <- async $ do
        liftIO $ putStrLn "yielding 8"
        yield @Int 8
        liftIO $ putStrLn "yielding 9"
        yield @Int 9
    yield @Int 7
    waitAsync t
    waitAsync t2
    return ()

mainYield :: IO ()
mainYield = do
    hSetBuffering stdout LineBuffering
    await <- implementYieldViaMVar @Int yieldTest
    traverseYielded_ await $ \res -> do
        print res
        void getLine

-- testResource = evaluateAll $ bracket
--     (choose [True, False] >>= \tf -> liftIO (putStrLn ("acq " ++ show tf)) >> return tf)
--     (\tf _ -> liftIO $ putStrLn ("cleaning " ++ show tf))
--     (\tf -> if tf then liftIO $ putStrLn "true" else error "io err" >> liftIO (putStrLn "false") )

main :: IO ()
main = return ()