module Network.Yogurt.Mud (
Mud, MudState, emptyMud,
Hook,
Destination(..),
Pattern,
Timer, Interval,
Result(..),
mkHook, mkPrioHook, setHook, rmHook, allHooks,
hPriority, hDestination, hPattern, hAction,
triggeredHook, matchedLine, before, group, after,
mkVar, setVar, readVar, modifyVar,
mkTimer, rmTimer, existsTimer, allTimers,
tAction, tInterval,
trigger, triggerJust, io, flushResults,
withIO, runIO
) where
import Prelude hiding (lookup)
import Data.IntMap (IntMap, empty, insert, delete, lookup, elems, member)
import Unsafe.Coerce
import Text.Regex.Posix
import Network.Yogurt.Ansi
import Control.Monad.State
import Data.List (sort)
import Data.Function (on)
import Data.Ord (comparing)
type Mud = State MudState
data MudState = MudState
{ hooks :: IntMap Hook
, vars :: IntMap Opaque
, timers :: IntMap Timer
, supply :: [Int]
, matchInfo :: Maybe MatchInfo
, results :: [Result]
}
emptyMud :: MudState
emptyMud = MudState empty empty empty [0..] Nothing []
data Hook = Hook
{ hId :: Int
, hPriority :: Int
, hDestination :: Destination
, hPattern :: Pattern
, hAction :: Mud ()
}
instance Eq Hook where
h1 == h2 = hId h1 == hId h2
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
instance Show Hook where
show (Hook hid prio dest pat _) = "Hook #" ++ show hid ++ " @" ++ show prio ++ " " ++ show dest ++ " [" ++ pat ++ "]"
data Destination
= Local
| Remote
deriving (Eq, Show, Read, Enum, Ord)
type Pattern = String
data MatchInfo = MatchInfo
{ mTriggeredHook :: Hook
, mMatchedLine :: String
, mBefore :: String
, mGroups :: [String]
, mAfter :: String
}
data Var a = Var Int
data Opaque = forall a. Opaque a
data Timer = Timer
{ tId :: Int
, tAction :: Mud ()
, tInterval :: Interval
}
type Interval = Int
data Result
= Send Destination String
| forall a. RunIO (IO a) (a -> Mud ())
| NewTimer Timer
mkId :: Mud Int
mkId = do
i <- gets (head . supply)
modify $ \s -> s { supply = tail (supply s) }
return i
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] }
flushResults :: Mud [Result]
flushResults = do
rs <- gets results
modify $ \s -> s { results = [] }
return rs
mkHook :: Destination -> Pattern -> Mud a -> Mud Hook
mkHook = mkPrioHook 0
mkPrioHook :: Int -> Destination -> Pattern -> Mud a -> Mud Hook
mkPrioHook prio dest pat act = do
hid <- mkId
let hook = Hook hid prio dest pat (act >> return ())
setHook hook
return hook
setHook :: Hook -> Mud ()
setHook hook = updateHooks $ insert (hId hook) hook
rmHook :: Hook -> Mud ()
rmHook = updateHooks . delete . hId
allHooks :: Mud [Hook]
allHooks = gets (sort . elems . hooks)
setMatchInfo :: Maybe MatchInfo -> Mud ()
setMatchInfo mi = modify $ \s -> s { matchInfo = mi }
getMatchInfo :: Mud MatchInfo
getMatchInfo = do
mi <- gets matchInfo
case mi of
Nothing -> fail "No match is available."
Just mi' -> return mi'
triggeredHook :: Mud Hook
triggeredHook = fmap mTriggeredHook getMatchInfo
matchedLine :: Mud String
matchedLine = fmap mMatchedLine getMatchInfo
before :: Mud String
before = fmap mBefore getMatchInfo
group :: Int -> Mud String
group n = fmap ((!! n) . mGroups) getMatchInfo
after :: Mud String
after = fmap mAfter getMatchInfo
mkVar :: a -> Mud (Var a)
mkVar val = do
i <- mkId
setVar (Var i) val
return (Var i)
setVar :: Var a -> a -> Mud ()
setVar (Var i) val = updateVars $ insert i (Opaque val)
readVar :: Var a -> Mud a
readVar (Var i) = do
varmap <- gets vars
Opaque val <- lookup i varmap
return (unsafeCoerce val)
modifyVar :: Var a -> (a -> a) -> Mud ()
modifyVar var f = readVar var >>= setVar var . f
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
rmTimer :: Timer -> Mud ()
rmTimer = updateTimers . delete . tId
existsTimer :: Timer -> Mud Bool
existsTimer (Timer ti _ _) = gets (member ti . timers)
allTimers :: Mud [Timer]
allTimers = gets (elems . timers)
trigger :: Destination -> String -> Mud ()
trigger = triggerJust (const True)
triggerJust :: (Hook -> Bool) -> Destination -> String -> Mud ()
triggerJust test dest message = do
hs <- allHooks
case filter ok hs of
[] -> io dest message
(hook:_) -> fire message hook
where
ok hook = test hook && hDestination hook == dest && rmAnsi message =~ hPattern hook
fire :: String -> Hook -> Mud ()
fire message hook = do
oldMatchInfo <- gets matchInfo
setMatchInfo $ Just $ MatchInfo hook message before (match : groups) after
hAction hook
setMatchInfo oldMatchInfo
where
(before, match, after, groups) = rmAnsi message =~ hPattern hook :: (String, String, String, [String])
io :: Destination -> String -> Mud ()
io ch message = addResult (Send ch message)
runIO :: IO a -> Mud ()
runIO io = withIO io (const $ return ())
withIO :: IO a -> (a -> Mud ()) -> Mud ()
withIO io act = addResult (RunIO io act)