forking ConcMs

Author: Intrets

src/Command/Commands.hs

@@ -14,18 +14,15 @@ import Bot.Random
 import Command
 import Command.CursedCommand
 import Conc
-import Control.Monad
-import Data.Function ((&))
 import Data.List (intercalate)
 import Data.Maybe (fromMaybe)
 import Data.Monoid ((<>))
-import qualified Data.Text as T (pack, unpack, words)
+import qualified Data.Text as T (pack, unpack)
 import qualified Data.Text.Encoding as TE
 import Data.Time.Clock.POSIX
 import MessageQueue
 import Text.Read (readMaybe)
 
-import Control.Arrow
 import Control.Monad.IO.Class
 import qualified Data.HashMap.Strict as M
 
@@ -60,7 +57,7 @@ commandList =
     burselfParrotCommand
   , Command
     "dicegolf"
-    ["!dicegolf"]
+    ["!dicegolf", "!dg"]
     (CommandOptions 2 2 True True (const True))
     dicegolfCommand
   , Command

src/Command/CursedCommand.hs

@@ -22,10 +22,12 @@ import Network.HTTP.Types.Status
 import MessageQueue
 import Data.Text as T
 import qualified Data.List as L (head)
+import Control.Concurrent
 
 dubiousFact :: ConcM App ()
 dubiousFact = do
   cont <- taskM $ do
+    threadDelay 10000000
     man <- newManager tlsManagerSettings
     let req = "http://opentdb.com/api.php?amount=1&type=boolean"
     jsonResult <- httpLbs req man

src/Conc.hs

@@ -2,45 +2,45 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE InstanceSigs #-}
 
 module Conc where
 
 import Control.Concurrent
 import Control.Concurrent.STM
 import Control.Monad
 import Control.Monad.IO.Class
-import qualified Control.Category as C
-import Control.Arrow
 
 data ConcM m c
   = EndM c
-  | forall b. IOtaskM (IO b) (b -> ConcM m c)
+  | forall b. TaskM (IO b) (b -> ConcM m c)
   | forall b. PureM (m b) (b -> ConcM m c)
 
 instance (Monad m) => Functor (ConcM m) where
-  fmap f (EndM c         ) = EndM $ f c
-  fmap f (IOtaskM io cont) = IOtaskM io (fmap f . cont)
-  fmap f (PureM   p  cont) = PureM p (fmap f . cont)
+  fmap f (EndM c       ) = EndM $ f c
+  fmap f (TaskM io cont) = TaskM io (fmap f . cont)
+  fmap f (PureM p  cont) = PureM p (fmap f . cont)
 
 instance (Monad m) => Applicative (ConcM m) where
   pure = EndM
-  t                 <*> (IOtaskM io cont) = IOtaskM io (\c -> t <*> cont c)
-  t                 <*> (PureM   p  cont) = PureM p (\c -> t <*> cont c)
-  (EndM f         ) <*> (EndM c         ) = EndM (f c)
-  (IOtaskM io cont) <*> (EndM c) = IOtaskM io (\c2 -> cont c2 <*> EndM c)
-  (PureM   p  cont) <*> (EndM c         ) = PureM p (\c2 -> cont c2 <*> EndM c)
+  -- t               <*> (TaskM io cont) = TaskM io ((t <*>) . cont)
+  -- t               <*> (PureM p  cont) = PureM p ((t <*>) . cont)
+  -- (EndM f       ) <*> (EndM c       ) = EndM (f c)
+  -- (TaskM io cont) <*> (EndM c       ) = TaskM io ((<*> EndM c) . cont)
+  -- (PureM p  cont) <*> (EndM c       ) = PureM p (\c2 -> cont c2 <*> EndM c)
+  (EndM f       ) <*> t = fmap f t
+  (TaskM io cont) <*> t = TaskM io ((<*> t) . cont)
+  (PureM p  cont) <*> t = PureM p ((<*> t) . cont)
 
 instance (Monad m) => Monad (ConcM m) where
-  (EndM a          ) >>= cont  = PureM (pure a) cont
-  (IOtaskM io cont1) >>= cont2 = IOtaskM io (\a -> cont1 a >>= cont2)
-  (PureM   p  cont1) >>= cont2 = PureM p (\a -> cont1 a >>= cont2)
+  (EndM a        ) >>= cont  = PureM (pure a) cont
+  (TaskM io cont1) >>= cont2 = TaskM io ((>>= cont2) . cont1)
+  (PureM p  cont1) >>= cont2 = PureM p ((>>= cont2) . cont1)
 
 pureM :: m c -> ConcM m c
 pureM x = PureM x EndM
 
 taskM :: IO c -> ConcM m c
-taskM x = IOtaskM x EndM
+taskM x = TaskM x EndM
 
 runConcM :: (Monad a, MonadIO a) => [ConcM a ()] -> a ()
 runConcM q_ = do
@@ -52,8 +52,8 @@ runConcM q_ = do
     case q of
       [] -> liftIO $ threadDelay 100000
       _  -> forM_ q $ \case
-        EndM _          -> return ()
-        IOtaskM io cont -> void . liftIO . forkIO $ do
+        EndM _        -> return ()
+        TaskM io cont -> void . liftIO . forkIO $ do
           a <- io
           atomically $ modifyTVar queue (cont a :)
         PureM p cont -> do