1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
|
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
--------------------------------------------------------------------------------
module Xanthous.Entities
( Draw(..)
, DrawCharacter(..)
, DrawStyledCharacter(..)
, Entity
, SomeEntity(..)
, downcastEntity
, entityIs
, Color(..)
, KnownColor(..)
, EntityChar(..)
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
--------------------------------------------------------------------------------
import Brick
import Data.Typeable
import qualified Graphics.Vty.Attributes as Vty
import qualified Graphics.Vty.Image as Vty
import Data.Aeson
--------------------------------------------------------------------------------
import Xanthous.Data
--------------------------------------------------------------------------------
class (Show a, Eq a, Draw a) => Entity a
instance (Show a, Eq a, Draw a) => Entity a
--------------------------------------------------------------------------------
data SomeEntity where
SomeEntity :: forall a. (Entity a, Typeable a) => a -> SomeEntity
instance Show SomeEntity where
show (SomeEntity e) = "SomeEntity (" <> show e <> ")"
instance Eq SomeEntity where
(SomeEntity (a :: ea)) == (SomeEntity (b :: eb)) = case eqT @ea @eb of
Just Refl -> a == b
_ -> False
instance Draw SomeEntity where
drawWithNeighbors ns (SomeEntity ent) = drawWithNeighbors ns ent
downcastEntity :: (Entity a, Typeable a) => SomeEntity -> Maybe a
downcastEntity (SomeEntity e) = cast e
entityIs :: forall a. (Entity a, Typeable a) => SomeEntity -> Bool
entityIs = isJust . downcastEntity @a
--------------------------------------------------------------------------------
class Draw a where
drawWithNeighbors :: Neighbors (Vector SomeEntity) -> a -> Widget n
drawWithNeighbors = const draw
draw :: a -> Widget n
draw = drawWithNeighbors $ pure mempty
newtype DrawCharacter (char :: Symbol) (a :: Type) where
DrawCharacter :: a -> DrawCharacter char a
instance KnownSymbol char => Draw (DrawCharacter char a) where
draw _ = str $ symbolVal @char Proxy
--------------------------------------------------------------------------------
data Color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White
class KnownColor (color :: Color) where
colorVal :: forall proxy. proxy color -> Vty.Color
instance KnownColor 'Black where colorVal _ = Vty.black
instance KnownColor 'Red where colorVal _ = Vty.red
instance KnownColor 'Green where colorVal _ = Vty.green
instance KnownColor 'Yellow where colorVal _ = Vty.yellow
instance KnownColor 'Blue where colorVal _ = Vty.blue
instance KnownColor 'Magenta where colorVal _ = Vty.magenta
instance KnownColor 'Cyan where colorVal _ = Vty.cyan
instance KnownColor 'White where colorVal _ = Vty.white
newtype DrawStyledCharacter (fg :: Color) (bg :: Color) (char :: Symbol) (a :: Type) where
DrawStyledCharacter :: a -> DrawStyledCharacter fg bg char a
instance
( KnownColor fg
, KnownColor bg
, KnownSymbol char
)
=> Draw (DrawStyledCharacter fg bg char a) where
draw _ = raw $ Vty.string attr $ symbolVal @char Proxy
where attr = Vty.Attr
{ Vty.attrStyle = Vty.Default
, Vty.attrForeColor = Vty.SetTo $ colorVal @fg Proxy
, Vty.attrBackColor = Vty.SetTo $ colorVal @bg Proxy
, Vty.attrURL = Vty.Default
}
--------------------------------------------------------------------------------
data EntityChar = EntityChar
{ _char :: Char
, _style :: Vty.Attr
}
deriving stock (Show, Eq, Generic)
deriving anyclass (NFData)
instance FromJSON EntityChar where
parseJSON (String (chr :< Empty)) = pure $ EntityChar chr Vty.defAttr
parseJSON (Object o) = do
(EntityChar _char _) <- o .: "char"
_style <- o .:? "style" >>= \case
Just styleO -> do
let attrStyle = Vty.Default -- TODO
attrURL = Vty.Default
attrForeColor <- styleO .:? "foreground" .!= Vty.Default
attrBackColor <- styleO .:? "background" .!= Vty.Default
pure Vty.Attr {..}
Nothing -> pure Vty.defAttr
pure EntityChar {..}
parseJSON _ = fail "Invalid type, expected string or object"
instance Draw EntityChar where
draw EntityChar{..} = raw $ Vty.string _style [_char]
--------------------------------------------------------------------------------
|
