module Glazier.Example where
import Control.Category
import Control.Lens
import Control.Monad.Reader
import Data.Foldable
import Data.List
import Data.Semigroup
import Glazier
import Glazier.Strict
import Prelude hiding (id, (.))
newtype Action a = Action { getAction :: a }
class AsAction s a | s -> a where
_Action :: Prism' s (Action a)
instance AsAction (Action a) a where
_Action = id
newtype ConsAction a = ConsAction { getConsAction :: a }
class AsConsAction s a | s -> a where
_ConsAction :: Prism' s (ConsAction a)
instance AsConsAction (ConsAction a) a where
_ConsAction = id
data Reset = Reset
class AsReset s where
_Reset :: Prism' s Reset
instance AsReset Reset where
_Reset = id
data Tail = Tail
class AsTail s where
_Tail :: Prism' s Tail
instance AsTail Tail where
_Tail = id
newtype Set a = Set { getSet :: a }
class AsSet s a | s -> a where
_Set :: Prism' s (Set a)
instance AsSet (Set a) a where
_Set = id
optionalExample ::
( Monoid v
, Monoid c
, Semigroup v
, Semigroup c
, AsSet a s
, AsReset a
, AsAction a (Maybe s -> Maybe s)
, Monad m
)
=> Prism' a a' -> Widget s v m a' c -> Widget (Maybe s) v m a c
optionalExample p w =
(
implant _Just
>>> dispatch p
) w
<> statically mempty
<> dynamically
( dispatch _Set (review _Gadget $ \a _ -> pure (mempty,Just $ getSet a))
<> dispatch _Action (review _Gadget $ \(Action f) s -> pure (mempty, f s))
<> dispatch _Reset (review _Gadget $ \_ _ -> pure (mempty, Nothing))
)
listExample ::
( Monoid v
, Monoid c
, Semigroup v
, Semigroup c
, AsTail a
, AsConsAction a s
, AsAction a ([s] -> [s])
, Monad m
)
=> Prism' b a -> Widget s v m a c -> Widget [s] v m b c
listExample p (Widget (Window d) u) =
statically (Window . ReaderT $ \ss -> do
ss' <- traverse (runReaderT d) ss
pure (fold $ intersperse separator ss'))
<> dynamically
( implant (ix 0) u
<> dispatch _Tail (review _Gadget $ \_ s -> pure (mempty, tail s))
<> dispatch _ConsAction (review _Gadget $ \(ConsAction a) s -> pure (mempty, a : s))
<> dispatch _Action (review _Gadget $ \(Action f) s -> pure (mempty, f s))
)
& dispatch p
where separator = mempty
indexedExample ::
( Monoid v
, Monoid c
, Field2 b b a a
, Field1 b b (Index (t s)) (Index (t s))
, Ixed (t s)
, Semigroup v
, Semigroup c
, AsAction b (t s -> t s)
, IxValue (t s) ~ s
, Monad m
, Traversable t
)
=> Widget s v m a c -> Widget (t s) v m b c
indexedExample (Widget (Window d) g) =
statically (Window . ReaderT $ \ss -> do
ss' <- traverse (runReaderT d) ss
pure (fold ss'))
<>
dynamically
(
(do
x <- ask
let k = x ^. _1
zoom (ix k) (magnify _2 g)
)
<>
dispatch _Action (review _Gadget $ \(Action f) s -> pure (mempty, f s))
)