summaryrefslogtreecommitdiffstats
path: root/app/Ui.hs
diff options
context:
space:
mode:
Diffstat (limited to 'app/Ui.hs')
-rw-r--r--app/Ui.hs59
1 files changed, 13 insertions, 46 deletions
diff --git a/app/Ui.hs b/app/Ui.hs
index fa1b38e..808c3c1 100644
--- a/app/Ui.hs
+++ b/app/Ui.hs
@@ -11,10 +11,9 @@
module Ui
( Ui (Ui),
+ Block,
lit,
fill,
- sens,
- initUi,
pollUi,
Env (..),
Ui',
@@ -24,72 +23,40 @@ module Ui
)
where
-import Control.Concurrent.STM
-import Control.Monad.Identity
import Control.Monad.Reader
import Control.Monad.State (evalStateT, get, modify)
import Data.Default
-import Data.Dynamic
import Data.Map qualified as M
import Data.Maybe
+import Data.Sensor qualified as S
import GHC.Generics (Generic)
import Graphics.X11 qualified as X
import Graphics.X11.Xft qualified as X
import Graphics.X11.Xrender qualified as X
import Pretty qualified as P
-import Sensor hiding (io)
-data Ui f a = Ui [Block f a]
+data Ui a = Ui [a] deriving (Eq, Functor, Foldable, Traversable, Show)
-instance Eq (Ui Identity P.Doc) where
- Ui bs == Ui bs' = bs == bs'
-
-data Block f a
- = Lit P.Doc
+data Block a
+ = Lit a
| Fill
- | forall o. (Typeable o) => Sens (o -> a) (f o)
-
-instance Eq (Block Identity P.Doc) where
- (Lit doc) == (Lit doc') = doc == doc'
- Fill == Fill = True
- Sens toOut (Identity x) == Sens toOut' (Identity x') = toOut x == toOut' x'
- _ == _ = False
+ deriving (Eq, Functor, Show)
-lit :: (P.Pretty a) => a -> Block f P.Doc
+lit :: (P.Pretty a) => a -> Block P.Doc
lit = Lit . P.pretty
-fill :: Block f a
+fill :: Block a
fill = Fill
-sens :: (P.Pretty o, Typeable o) => f o -> Block f P.Doc
-sens = Sens P.pretty
-
-initUi ::
- Ui Sensor P.Doc ->
- SensorM (Ui TVar P.Doc)
-initUi (Ui bs) = Ui <$> mapM go bs
- where
- go (Lit s) = pure (Lit s)
- go Fill = pure Fill
- go (Sens toOut s) = Sens toOut <$> poll s
-
pollUi ::
- Ui TVar P.Doc ->
- STM (Ui Identity P.Doc)
-pollUi (Ui bs) = Ui <$> mapM go bs
- where
- go (Lit s) = pure (Lit s)
- go Fill = pure Fill
- go (Sens toOut vT) = Sens toOut . Identity <$> readTVar vT
-
-layOutUi ::
- Env ->
- Ui Identity P.Doc ->
- IO Ui'
+ Ui (S.Sensor (S.SensorT IO) () (Block P.Doc)) ->
+ S.Sensor (S.SensorT IO) () (Ui (Block P.Doc))
+pollUi = sequence
+
+layOutUi :: Env -> Ui (Block P.Doc) -> IO Ui'
layOutUi env (Ui bs) = layOut env (Ui' (concatMap go bs))
where
go (Lit doc) = go' doc
- go (Sens toOut (runIdentity -> toOut -> doc)) = go' doc
go Fill =
[ C
{ rect = def,