{-# LANGUAGE OverloadedStrings #-}
module Swarm.App where
import Brick
import Brick.BChan
import Control.Carrier.Lift (runM)
import Control.Carrier.Throw.Either (runThrow)
import Control.Concurrent (forkIO, threadDelay)
import Control.Lens (view, (%~), (&), (?~))
import Control.Monad (forever, void, when)
import Control.Monad.IO.Class (liftIO)
import Data.IORef (newIORef, writeIORef)
import Data.Text qualified as T
import Data.Text.IO qualified as T
import Graphics.Vty qualified as V
import Swarm.Game.Failure (SystemFailure)
import Swarm.Language.Pretty (prettyText)
import Swarm.Log (LogSource (SystemLog), Severity (..))
import Swarm.ReadableIORef (mkReadonly)
import Swarm.TUI.Controller
import Swarm.TUI.Model
import Swarm.TUI.Model.StateUpdate
import Swarm.TUI.Model.UI (uiAttrMap)
import Swarm.TUI.View
import Swarm.Version (getNewerReleaseVersion)
import Swarm.Web
import System.IO (stderr)
type EventHandler = BrickEvent Name AppEvent -> EventM Name AppState ()
app :: EventHandler -> App AppState AppEvent Name
app :: EventHandler -> App AppState AppEvent Name
app EventHandler
eventHandler =
App
{ appDraw :: AppState -> [Widget Name]
appDraw = AppState -> [Widget Name]
drawUI
, appChooseCursor :: AppState -> [CursorLocation Name] -> Maybe (CursorLocation Name)
appChooseCursor = forall n.
AppState -> [CursorLocation n] -> Maybe (CursorLocation n)
chooseCursor
, appHandleEvent :: EventHandler
appHandleEvent = EventHandler
eventHandler
, appStartEvent :: EventM Name AppState ()
appStartEvent = forall n s. EventM n s ()
enablePasteMode
, appAttrMap :: AppState -> AttrMap
appAttrMap = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ Lens' AppState UIState
uiState forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' UIState AttrMap
uiAttrMap
}
appMain :: AppOpts -> IO ()
appMain :: AppOpts -> IO ()
appMain AppOpts
opts = do
Either SystemFailure AppState
res <- forall (m :: * -> *) a. LiftC m a -> m a
runM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. ThrowC e m a -> m (Either e a)
runThrow forall a b. (a -> b) -> a -> b
$ forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
AppOpts -> m AppState
initAppState AppOpts
opts
case Either SystemFailure AppState
res of
Left SystemFailure
err -> Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr (forall a. PrettyPrec a => a -> Text
prettyText @SystemFailure SystemFailure
err)
Right AppState
s -> do
BChan AppEvent
chan <- forall a. Int -> IO (BChan a)
newBChan Int
5
ThreadId
_ <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
Int -> IO ()
threadDelay Int
33_333
forall a. BChan a -> a -> IO ()
writeBChan BChan AppEvent
chan AppEvent
Frame
ThreadId
_ <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ do
Either NewReleaseFailure String
upRel <- Maybe GitInfo -> IO (Either NewReleaseFailure String)
getNewerReleaseVersion (AppOpts -> Maybe GitInfo
repoGitInfo AppOpts
opts)
forall a. BChan a -> a -> IO ()
writeBChan BChan AppEvent
chan (Either NewReleaseFailure String -> AppEvent
UpstreamVersion Either NewReleaseFailure String
upRel)
IORef AppState
appStateRef <- forall a. a -> IO (IORef a)
newIORef AppState
s
Either String Int
eport <-
Maybe Int
-> ReadableIORef AppState
-> BChan AppEvent
-> IO (Either String Int)
Swarm.Web.startWebThread
(AppOpts -> Maybe Int
userWebPort AppOpts
opts)
(forall a. IORef a -> ReadableIORef a
mkReadonly IORef AppState
appStateRef)
BChan AppEvent
chan
let logP :: a -> Notifications LogEntry -> Notifications LogEntry
logP a
p = LogSource
-> Severity
-> Text
-> Text
-> Notifications LogEntry
-> Notifications LogEntry
logEvent LogSource
SystemLog Severity
Info Text
"Web API" (Text
"started on :" forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show a
p))
let logE :: String -> Notifications LogEntry -> Notifications LogEntry
logE String
e = LogSource
-> Severity
-> Text
-> Text
-> Notifications LogEntry
-> Notifications LogEntry
logEvent LogSource
SystemLog Severity
Error Text
"Web API" (String -> Text
T.pack String
e)
let s' :: AppState
s' =
AppState
s
forall a b. a -> (a -> b) -> b
& Lens' AppState RuntimeState
runtimeState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ case Either String Int
eport of
Right Int
p -> (Lens' RuntimeState (Maybe Int)
webPort forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Int
p) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Lens' RuntimeState (Notifications LogEntry)
eventLog forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall {a}.
Show a =>
a -> Notifications LogEntry -> Notifications LogEntry
logP Int
p)
Left String
e -> Lens' RuntimeState (Notifications LogEntry)
eventLog forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ String -> Notifications LogEntry -> Notifications LogEntry
logE String
e
let eventHandler :: EventHandler
eventHandler BrickEvent Name AppEvent
e = do
AppState
curSt <- forall s (m :: * -> *). MonadState s m => m s
get
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef IORef AppState
appStateRef AppState
curSt
EventHandler
handleEvent BrickEvent Name AppEvent
e
let buildVty :: IO Vty
buildVty = Config -> IO Vty
V.mkVty forall a b. (a -> b) -> a -> b
$ Config
V.defaultConfig {colorMode :: Maybe ColorMode
V.colorMode = AppOpts -> Maybe ColorMode
colorMode AppOpts
opts}
Vty
initialVty <- IO Vty
buildVty
Output -> Mode -> Bool -> IO ()
V.setMode (Vty -> Output
V.outputIface Vty
initialVty) Mode
V.Mouse Bool
True
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall n e s.
Ord n =>
Vty -> IO Vty -> Maybe (BChan e) -> App s e n -> s -> IO s
customMain Vty
initialVty IO Vty
buildVty (forall a. a -> Maybe a
Just BChan AppEvent
chan) (EventHandler -> App AppState AppEvent Name
app EventHandler
eventHandler) AppState
s'
demoWeb :: IO ()
demoWeb :: IO ()
demoWeb = do
let demoPort :: Int
demoPort = Int
8080
Either SystemFailure AppState
res <-
forall (m :: * -> *) a. LiftC m a -> m a
runM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. ThrowC e m a -> m (Either e a)
runThrow forall a b. (a -> b) -> a -> b
$ forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
AppOpts -> m AppState
initAppState (AppOpts
defaultAppOpts {userScenario :: Maybe String
userScenario = Maybe String
demoScenario})
case Either SystemFailure AppState
res of
Left SystemFailure
err -> Text -> IO ()
T.putStrLn (forall a. PrettyPrec a => a -> Text
prettyText @SystemFailure SystemFailure
err)
Right AppState
s -> do
IORef AppState
appStateRef <- forall a. a -> IO (IORef a)
newIORef AppState
s
BChan AppEvent
chan <- forall a. Int -> IO (BChan a)
newBChan Int
5
Maybe (MVar WebStartResult)
-> Int -> ReadableIORef AppState -> BChan AppEvent -> IO ()
webMain
forall a. Maybe a
Nothing
Int
demoPort
(forall a. IORef a -> ReadableIORef a
mkReadonly IORef AppState
appStateRef)
BChan AppEvent
chan
where
demoScenario :: Maybe String
demoScenario = forall a. a -> Maybe a
Just String
"./data/scenarios/Testing/475-wait-one.yaml"
enablePasteMode :: EventM n s ()
enablePasteMode :: forall n s. EventM n s ()
enablePasteMode = do
Vty
vty <- forall n s. EventM n s Vty
getVtyHandle
let output :: Output
output = Vty -> Output
V.outputIface Vty
vty
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Output -> Mode -> Bool
V.supportsMode Output
output Mode
V.BracketedPaste) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
Output -> Mode -> Bool -> IO ()
V.setMode Output
output Mode
V.BracketedPaste Bool
True