packages feed

Yogurt 0.2 → 0.3

raw patch · 7 files changed

+150/−219 lines, 7 files

Files

LICENSE view
@@ -8,11 +8,11 @@     * Redistributions in binary form must reproduce the above copyright       notice, this list of conditions and the following disclaimer in the       documentation and/or other materials provided with the distribution.-    * Neither the name of Martijn van Steenbergen nor the-      names of its contributors may be used to endorse or promote products+    * Neither the name of the author nor the+      names of his contributors may be used to endorse or promote products       derived from this software without specific prior written permission. -THIS SOFTWARE IS PROVIDED BY Martijn van Steenbergen ``AS IS'' AND ANY+THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <copyright holder> BE LIABLE FOR ANY
Network/Yogurt.hs view
@@ -1,8 +1,10 @@--- | Re-exports Network.Yogurt.Mud and Network.Yogurt.Engine.+-- | Re-exports the other three modules. module Network.Yogurt (   module Network.Yogurt.Mud,-  module Network.Yogurt.Engine+  module Network.Yogurt.Engine,+  module Network.Yogurt.Utils   ) where  import Network.Yogurt.Mud+import Network.Yogurt.Utils import Network.Yogurt.Engine
Network/Yogurt/Engine.hs view
@@ -1,5 +1,7 @@-module Network.Yogurt.Engine (connect, Environment, Output, runMud) where+{-# LANGUAGE RecursiveDo #-} +module Network.Yogurt.Engine (connect, runMud) where+ import Network.Yogurt.Mud import System.IO import Network@@ -8,35 +10,35 @@ import System.Console.Readline import Network.Yogurt.IO import Data.Char (isSpace)+import System.Process  --- | Used by 'runMud' to output messages and update the state during execution.-type Environment = (Output, MVar MudState)---- | Provides a way to output messages.-type Output = Destination -> String -> IO ()- -- | @connect hostname port program@ connects to a MUD and executes the specified program. Input is read from @stdin@, and output is written to @stdout@. connect :: String -> Int -> Mud () -> IO ()-connect host port mud = do+connect host port mud = mdo   -- Connect.   putStrLn $ "Connecting to " ++ host ++ " port " ++ show port ++ "..."   h <- connectTo host (PortNumber (fromIntegral port))    -- Create shared mud state, executing initial commands.-  vState <- newMVar (execState mud emptyMud)--  -- Start child threads.   let out ch msg = case ch of         Local  -> writeToTTY msg         Remote -> do hPutStr h msg; hFlush h-  let env = (out, vState)-  forkIO (handleSource env localInput Remote)-  handleSource env (remoteInput h) Local+  let state0 = emptyMud (runMud vState) out+  state1 <- execStateT mud state0+  vState <- newMVar state1 +  -- Start child threads.+  forkIO (handleSource vState localInput Remote)+  handleSource vState (remoteInput h) Local+  +  -- Clean.+  runCommand "stty echo" >>= waitForProcess+  return () + -- Watches an input source and updates the mud state whenever a new message arrives.-handleSource :: Environment ->        -- to run mud computations+handleSource :: MVar MudState ->      -- to run mud computations                 IO (Maybe String) ->  -- input source                 Destination ->        -- target destination                 IO ()@@ -65,59 +67,14 @@ -- Remote input using a connection handle. remoteInput :: Handle -> IO (Maybe String) remoteInput h = do-  input <- maybeInput (hGetImpatientLine h 50)+  input <- maybeInput (hGetImpatientLine h 10)   return input   -- | Runs a Mud computation, executes the results (such as sending messages to the screen or the MUD) and returns the computation's result. The MVar is updated.-runMud :: Environment -> Mud a -> IO a-runMud env@(_, vState) prog = do-  s1 <- takeMVar vState-  let (rv, s2) = runState prog s1-  let (rs, s3) = runState flushResults s2-  putMVar vState s3-  executeResults env rs+runMud :: MVar MudState -> Mud a -> IO a+runMud vState prog = do+  s <- takeMVar vState+  (rv, s') <- runStateT prog s+  putMVar vState s'   return rv----- Executes results in sequence.-executeResults :: Environment -> [Result] -> IO ()-executeResults env = sequence_ . map (executeResult env)----- Executes one result.-executeResult :: Environment -> Result -> IO ()-executeResult env@(out, _) res = case res of--    Send ch msg -> do-      -- debug $ "Send " ++ show ch ++ " " ++ show msg-      out ch msg--    RunIO io actf -> do-      -- debug "RunIO"-      x <- io-      runMud env (actf x)--    NewTimer timer -> do-      -- debug "NewTimer"-      forkIO (runTimer env timer)-      return ()----- Called whenever a new timer is created.-runTimer :: Environment -> Timer -> IO ()-runTimer env timer = loop where-  loop = do-    -- Sleep.-    threadDelay (1000 * tInterval timer)  -- interval in ms, threadDelay expects micros--    -- Execute timer action only if timer hasn't been removed in the meantime.-    ok <- runMud env (existsTimer timer)-    when ok (runMud env $ tAction timer)--    -- Maybe the timer's action removed the timer. If not, run again.-    again <- runMud env (existsTimer timer)-    when again loop--debug :: String -> IO ()-debug = appendFile "debug.log" . (++ "\n")
Network/Yogurt/IO.hs view
@@ -8,7 +8,7 @@  import System.IO import System.Console.Readline-import Control.Monad (when)+import Control.Monad (when, liftM) import Data.List (elemIndices)  writeToTTY :: String -> IO ()@@ -35,9 +35,9 @@   redisplay  -- Splits a message x in two submessages y and z such that:--- * x == y ++ z--- * all (/= '\n') z--- * null y || last y == '\n'  (i.e. z is maximal)+-- * @x == y ++ z@+-- * @'all' (/= '\n') z@+-- * @'null' y || 'last' y == '\n'@  (i.e. z is maximal) splitAtPrompt :: String -> (String, String) splitAtPrompt cs = case elemIndices '\n' cs of   [] -> ("", cs)@@ -58,6 +58,5 @@       else do         b <- hWaitForInput h patience         if b-          then rec >>= return . (c:)+          then liftM (c:) rec           else return [c]-
Network/Yogurt/Mud.hs view
@@ -5,73 +5,81 @@    -- * Types   Mud, MudState, emptyMud,+  RunMud, Output,   Hook,   Destination(..),   Pattern,-  Timer, Interval,-  Result(..),+  Var,    -- * Hooks-  -- | A hook watches a channel for messages matching a specific regular expression. When a hook fires, the triggering message is consumed and the hook's action is executed. When a message doesn't trigger any hooks, it is sent on to its destination. A hook's action may query for match-specific data; see section Match Information. At most one hook fires for each message, unless the hook's action explicitly sends the message through 'trigger' again. If several hooks match, only the hook with the highest priority fires. If there is still a tie, the hook that was defined last (using 'mkHook') fires.+  -- | A hook watches a channel for messages matching a specific regular expression.+  -- When a hook fires, the triggering message is consumed and the hook's action is executed.+  -- When a message doesn't trigger any hooks, it is sent on to its destination.+  -- A hook's action may query for match-specific data; see section Match information.+  -- At most one hook fires for each message, unless the hook's action explicitly sends the message through 'trigger' again. If several hooks match, only the hook with the highest priority fires. If there is still a tie, the hook that was defined last (using 'mkHook') fires.   mkHook, mkPrioHook, setHook, rmHook, allHooks,      -- ** Hook record fields   -- | Use these in combination with 'setHook' to update hooks.   hPriority, hDestination, hPattern, hAction, -  -- * Match information-  -- | #MatchInformation# Functions for querying the currently firing hook. These functions should only be called from within a hook's body.+  -- ** Match information+  -- | #MatchInformation# Functions for querying the currently firing hook. These functions can only be called from within a hook's body.   triggeredHook, matchedLine, before, group, after,    -- * Variables   mkVar, setVar, readVar, modifyVar, -  -- * Timers-  mkTimer, rmTimer, existsTimer, allTimers,-  -- ** Timer record fields-  tAction, tInterval,-   -- * Triggering hooks-  trigger, triggerJust, io, flushResults,--  -- * IO-  withIO, runIO+  trigger, triggerJust, io,+  liftIO, forkWithCallback    ) where  import Prelude hiding (lookup)-import Data.IntMap (IntMap, empty, insert, delete, lookup, elems, member)-import Unsafe.Coerce-import Text.Regex.Posix+import Data.IntMap (IntMap, empty, insert, delete, elems)+import Text.Regex.Posix ((=~)) import Network.Yogurt.Ansi import Control.Monad.State import Data.List (sort) import Data.Function (on) import Data.Ord (comparing)+import Data.Monoid (mconcat)+import Data.IORef+import Control.Concurrent (forkIO, ThreadId)    -- Section: Types.  --- | The Mud monad is a simple state monad.-type Mud = State MudState+-- | The Mud monad is a state monad over IO.+type Mud = StateT MudState IO +-- | Run a Mud computation in IO.+type RunMud = forall a. Mud a -> IO a++-- | Provides a way to output messages.+type Output = Destination -> String -> IO ()+ -- | State internal to the Mud monad. data MudState = MudState   { hooks     :: IntMap Hook-  , vars      :: IntMap Opaque-  , timers    :: IntMap Timer   , supply    :: [Int]   , matchInfo :: Maybe MatchInfo-  , results   :: [Result]+  , mRunMud   :: RunMud+  , mOutput   :: Output   }  -- | The initial state of the Mud monad.-emptyMud :: MudState-emptyMud = MudState empty empty empty [0..] Nothing []+emptyMud :: RunMud -> Output -> MudState+emptyMud = MudState empty [0..] Nothing --- | The abstract Hook type. Two hooks are considered equal if they were created (using 'mkHook') at the same time. Hook h1 < hook h2 if h1 will match earlier than h2.+-- | The abstract @Hook@ type. For every pair of hooks @(h1, h2)@:+--+-- * @h1 == h2@ iff they were created by the same call to 'mkHook'.+--+-- * @h1 < h2@ iff @h1@ will match earlier than @h2@. data Hook = Hook   { hId          :: Int   , hPriority    :: Int          -- ^ Yields the hook's priority. @@ -81,30 +89,21 @@   }  instance Eq Hook where-  h1 == h2 = hId h1 == hId h2+  (==) = (==) `on` hId  instance Ord Hook where-  compare h1 h2 = rev $-    case compare (hPriority h1) (hPriority h2) of-      EQ -> compare (hId h1) (hId h2)-      x  -> x--rev :: Ordering -> Ordering-rev x = case x of-  LT -> GT-  EQ -> EQ-  GT -> LT+  compare = flip $ mconcat [comparing hPriority, comparing hId]  instance Show Hook where   show (Hook hid prio dest pat _) = "Hook #" ++ show hid ++ " @" ++ show prio ++ " " ++ show dest ++ " [" ++ pat ++ "]" --- | Used to distinguish between messages going in different directions.+-- | The direction in which a message is going. data Destination   = Local   -- ^ The message is headed towards the user's terminal.   | Remote  -- ^ The message is headed towards the remote MUD server.   deriving (Eq, Show, Read, Enum, Ord) --- | A Pattern is a regular expression.+-- | A @Pattern@ is a regular expression. type Pattern = String  data MatchInfo = MatchInfo@@ -116,33 +115,16 @@   }  -- | Variables hold temporary, updatable, typed data.-data Var a = Var Int--data Opaque = forall a. Opaque a---- Timers.--- | The abstract Timer type.-data Timer = Timer-  { tId     :: Int-  , tAction :: Mud ()      -- ^ Yields the timer's action.-  , tInterval :: Interval  -- ^ Yields the timer's interval.-  }---- | Interval in milliseconds.-type Interval = Int+newtype Var a = Var (IORef a) --- | A @Result@ is a consequence of executing a @Mud@ program.-data Result-  = Send Destination String  -- no implicit newlines!-  | forall a. RunIO (IO a) (a -> Mud ())-  | NewTimer Timer+type Id = Int    -- Section: Helper functions for querying and manipulating state.  -mkId :: Mud Int+mkId :: Mud Id mkId = do   i <- gets (head . supply)   modify $ \s -> s { supply = tail (supply s) }@@ -151,24 +133,8 @@ updateHooks :: (IntMap Hook -> IntMap Hook) -> Mud () updateHooks f = modify $ \s -> s { hooks = f (hooks s) } -updateVars :: (IntMap Opaque -> IntMap Opaque) -> Mud ()-updateVars f = modify $ \s -> s { vars = f (vars s) } -updateTimers :: (IntMap Timer -> IntMap Timer) -> Mud ()-updateTimers f = modify $ \s -> s { timers = f (timers s) } -addResult :: Result -> Mud ()-addResult r = modify $ \s -> s { results = results s ++ [r] }---- | Yields all accumulated results and removes them from the state. Used by "Network.Yogurt.Engine" in @runMud@.-flushResults :: Mud [Result]-flushResults = do-  rs <- gets results-  modify $ \s -> s { results = [] }-  return rs--- -- Section: Hooks.  @@ -232,55 +198,24 @@ after = fmap mAfter getMatchInfo  + -- Section: Variables.  -- | Creates a variable with an initial value. mkVar :: a -> Mud (Var a)-mkVar val = do-  i <- mkId-  setVar (Var i) val-  return (Var i)+mkVar = liftM Var . liftIO . newIORef  -- | Updates a variable to a new value. setVar :: Var a -> a -> Mud ()-setVar (Var i) val = updateVars $ insert i (Opaque val)+setVar (Var var) = liftIO . writeIORef var  -- | Yields the variable's current value. readVar :: Var a -> Mud a-readVar (Var i) = do-  varmap <- gets vars-  Opaque val <- lookup i varmap-  return (unsafeCoerce val)+readVar (Var var) = liftIO $ readIORef var  -- | Updates the variable using the update function. modifyVar :: Var a -> (a -> a) -> Mud ()-modifyVar var f = readVar var >>= setVar var . f------ Section: Timers.----- | @mkTimer interval prog@ creates a timer that executes @prog@ every @interval@ milliseconds.-mkTimer :: Interval -> Mud a -> Mud Timer-mkTimer interval prog = do-  i <- mkId-  let timer = Timer i (prog >> return ()) interval-  updateTimers $ insert i timer-  addResult (NewTimer timer)-  return timer---- | Disables the timer.-rmTimer :: Timer -> Mud ()-rmTimer = updateTimers . delete . tId---- | Checks whether a timer is active.-existsTimer :: Timer -> Mud Bool-existsTimer (Timer ti _ _) = gets (member ti . timers)---- | Yields all currently active timers.-allTimers :: Mud [Timer]-allTimers = gets (elems . timers)+modifyVar (Var var) = liftIO . modifyIORef var   @@ -312,17 +247,17 @@  -- | Immediately write a message to a destination, without triggering hooks. io :: Destination -> String -> Mud ()-io ch message = addResult (Send ch message)------ Section: IO.----- | Invokes withIO, discarding the IO's result.-runIO :: IO a -> Mud ()-runIO io = withIO io (const $ return ())+-- io ch = addResult . Send ch+io to msg = do+  out <- gets mOutput+  liftIO $ out to msg --- | Executes the IO action soon. The computation's result is passed to the function, and the resulting Mud computation is executed.-withIO :: IO a -> (a -> Mud ()) -> Mud ()-withIO io act = addResult (RunIO io act)+-- | Used when you want a forked thread to be able to call back into the @Mud@ monad.+-- Note that when using the @RunMud@ argument, the forked thread will have to contend+-- with the threads for the user input and MUD input, because only one @Mud@ computation+-- can run at any given time. The id of the forked thread is returned.+forkWithCallback :: (RunMud -> IO ()) -> Mud ThreadId+forkWithCallback action = do+  -- Note: compiler complains if mRunMud is written point-free.+  s <- get+  liftIO . forkIO . action $ mRunMud s
Network/Yogurt/Utils.hs view
@@ -2,14 +2,13 @@  -- | Convenience functions on top of "Yogurt.Mud". module Network.Yogurt.Utils (-  -- * Re-exports-  module Network.Yogurt.Mud,-   -- * Hook and timer derivatives   mkTrigger, mkTriggerOnce,   mkAlias, mkArgAlias, mkCommand,-  mkTimerOnce, +  -- * Timers+  Timer, Interval, mkTimer, mkTimerOnce, rmTimer, isTimerActive,+   -- * Sending messages   receive, sendln, echo, echoln, echorln, bell, @@ -17,14 +16,14 @@   Logger, startLogging, stopLogging,    -- * Miscellaneous-  matchMore, matchMoreOn, matchMoreOn',-  system+  matchMore, matchMoreOn, matchMoreOn'    ) where  import Network.Yogurt.Mud-import qualified System.Cmd as Cmd-import System.IO.Unsafe+import Control.Concurrent+import Control.Monad+ import Data.Time.Format (formatTime) import System.Locale (defaultTimeLocale) import Data.Time.LocalTime (getZonedTime)@@ -60,14 +59,54 @@ mkCommand :: String -> Mud a -> Mud Hook mkCommand pat = mkHook Remote ("^" ++ pat ++ "($| .*$)") +++-- Section: Timers.+++-- | The abstract Time type.+newtype Timer = Timer (Var Bool)++-- | Interval in milliseconds.+type Interval = Int++-- | @mkTimer interval prog@ creates a timer that executes @prog@ every @interval@ milliseconds.+mkTimer :: Interval -> Mud a -> Mud Timer+mkTimer interval prog = do+    vActive <- mkVar True+    +    let timerCycle :: RunMud -> IO ()+        timerCycle runMud = do+          threadDelay (1000 * interval)  -- interval in ms, threadDelay expects micros++          -- Execute timer action only if timer hasn't been deactivated in the meantime.+          runMud $ do+            active <- readVar vActive+            when active (prog >> return ())++          -- Maybe the timer's action removed the timer. If not, run again.+          again <- runMud (readVar vActive)+          when again (timerCycle runMud)++    forkWithCallback timerCycle+    return (Timer vActive)+ -- | Creates a timer that fires only once. mkTimerOnce :: Interval -> Mud a -> Mud Timer mkTimerOnce interval act = mdo   t <- mkTimer interval (act >> rmTimer t)   return t +-- | Disables the timer.+rmTimer :: Timer -> Mud ()+rmTimer (Timer vActive) = setVar vActive False +-- | Checks whether a timer is active. A timer is deactivated by 'rmTimer'.+isTimerActive :: Timer -> Mud Bool+isTimerActive (Timer vActive) = readVar vActive ++ -- Sending messages.  @@ -104,12 +143,11 @@ -- | @startLogging name@ causes all messages to be logged in a file called @name-yyyymmdd-hhmm.log@. The used hooks have priority 100. startLogging :: String -> Mud Logger startLogging name = do-  let suffix = unsafePerformIO $-        fmap (formatTime defaultTimeLocale "-%Y%m%d-%H%M.log") getZonedTime+  suffix <- liftIO $ fmap (formatTime defaultTimeLocale "-%Y%m%d-%H%M.log") getZonedTime   let filename = name ++ suffix   let record dest = mkPrioHook 100 dest "^" $ do         line <- matchedLine-        runIO (appendFile filename line)+        liftIO $ appendFile filename line         matchMore   r <- record Remote   l <- record Local@@ -126,7 +164,10 @@ -- Miscellaneous.  --- | When called from a hook body, gives hooks that haven't been considered yet a chance to match on the currently triggering message. Useful if you want to build a hook that only has a side-effect and doesn't want to directly affect the other active hooks.+-- | When called from a hook body, gives hooks that haven't been considered yet+-- a chance to match on the currently triggering message. Useful if you want to+-- build a hook that only has a side-effect and doesn't want to directly affect+-- the other active hooks. matchMore :: Mud () matchMore = matchedLine >>= matchMoreOn @@ -141,7 +182,3 @@ matchMoreOn' message = do   h <- triggeredHook   triggerJust (>= h) (hDestination h) message---- | Executes a shell command.-system :: String -> Mud ()-system = runIO . Cmd.system
Yogurt.cabal view
@@ -1,11 +1,12 @@ Name:           Yogurt-Version:        0.2+Version:        0.3 Synopsis:       A MUD client library Description:    A MUD client library for Haskell. Features prioritized, regex-based hooks, variables and timers.  Author:         Martijn van Steenbergen Maintainer:     martijn@van.steenbergen.nl-Copyright:      Copyright (c) 2008 Martijn van Steenbergen+Stability:      Experimental+Copyright:      Some Rights Reserved (CC) 2008-2009 Martijn van Steenbergen Homepage:       http://martijn.van.steenbergen.nl/projects/yogurt/  Cabal-Version:  >= 1.2@@ -15,6 +16,6 @@ Build-type:     Simple  Library-  Build-Depends:    base, mtl, regex-posix, containers, time, old-locale, process, readline, network+  Build-Depends:    base, mtl, regex-posix, containers, time, old-locale, readline, network, process   Exposed-Modules:  Network.Yogurt, Network.Yogurt.Mud, Network.Yogurt.Utils, Network.Yogurt.Engine   Other-Modules:    Network.Yogurt.Ansi, Network.Yogurt.IO