Skip to content

Commit c1faec3

Browse files
georgefstgeorgefst
committed
haskell WASM frontend WIP
1 parent 70cee7e commit c1faec3

File tree

20 files changed

+1732
-754
lines changed

20 files changed

+1732
-754
lines changed

‎cabal.project‎

Lines changed: 57 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -12,6 +12,19 @@ source-repository-package
1212
tag: fe615b57548c74767586244c27e0e2dfbd52f861
1313
allow-newer: haskell-to-elm:text
1414

15+
-- using master due to lack of release: https://github.com/dmjio/miso/pull/752
16+
source-repository-package
17+
type: git
18+
location: https://github.com/dmjio/miso
19+
tag: e411f3e2872465f37eb53b6de4542010a105b53a
20+
21+
-- https://github.com/georgefst/diagrams-miso/tree/master
22+
-- https://github.com/cocreature/diagrams-miso/pull/7 and others
23+
source-repository-package
24+
type: git
25+
location: https://github.com/georgefst/diagrams-miso
26+
tag: 4f95ed29fed23885f5d6fc22382fc09c154d14ab
27+
1528
allow-newer:
1629
-- copied from georgefst-utils - unfortunately cabal solver isn't aware it should ignore some components
1730
okapi:*,
@@ -28,3 +41,47 @@ if impl(ghc >= 9.10)
2841
tag: b2047c3b89537f93a686ddd8cf1879ffb81a8f9a
2942
subdir: . core
3043
allow-newer: *:streamly, *:streamly-core
44+
45+
if arch(wasm32)
46+
-- default global config for Wasm adds `:override` for `head.hackage`, which can be pretty horrible
47+
-- https://gitlab.haskell.org/haskell-wasm/ghc-wasm-meta/-/issues/9#note_553150
48+
active-repositories: hackage.haskell.org, head.hackage.ghc.haskell.org
49+
50+
-- from ghc-wasm-miso-examples (can't this be specified by bounds?)
51+
constraints: time installed
52+
allow-newer: time
53+
54+
allow-newer:
55+
-- unreleased: https://github.com/ekmett/lens/commit/8db6d9abb9e3e2e7ac8402a18a95654cc66340e4
56+
lens:template-haskell,
57+
-- https://github.com/haskell/haskeline/pull/188
58+
haskeline:containers,
59+
-- https://github.com/sdiehl/repline/pull/50
60+
repline:containers,
61+
62+
-- https://github.com/diagrams/diagrams-lib/pull/372
63+
source-repository-package
64+
type: git
65+
location: https://github.com/georgefst/diagrams-lib
66+
tag: 19d9ebeb22385a7674ea7bec6856dc130b73350f
67+
68+
-- https://github.com/haskell/entropy/pull/86
69+
source-repository-package
70+
type: git
71+
location: https://github.com/amesgen/entropy
72+
tag: f771c8010f001b87c5ccf9b61703b6912f7062d5
73+
allow-newer: entropy:Cabal
74+
75+
-- https://github.com/haskellari/splitmix/pull/73
76+
source-repository-package
77+
type: git
78+
location: https://github.com/amesgen/splitmix
79+
tag: 5f5b766d97dc735ac228215d240a3bb90bc2ff75
80+
81+
else
82+
-- https://github.com/ghcjs/jsaddle/pull/149
83+
source-repository-package
84+
type: git
85+
location: https://github.com/georgefst/jsaddle
86+
tag: 8ebf96891fe9580fc16e1fe99b0ca503b9cf2ed8
87+
subdir: jsaddle jsaddle-warp

‎haskell/core/Monpad/Core.hs‎

Lines changed: 323 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,323 @@
1+
{- HLINT ignore "Use newtype instead of data" -}
2+
module Monpad.Core where
3+
4+
import Data.Aeson.Types (FromJSON, ToJSON)
5+
import Data.Bifunctor (Bifunctor (second))
6+
import Data.Binary.Get qualified as B
7+
import Data.ByteString.Lazy qualified as BSL
8+
import Data.Colour (AlphaColour)
9+
import Data.Hash.Murmur
10+
import Data.Int (Int32)
11+
import Data.List.NonEmpty (NonEmpty)
12+
import Data.Text (Text)
13+
import Data.Text.Encoding (decodeUtf8', encodeUtf8)
14+
import Data.Tuple.Extra (thd3)
15+
import Data.Word (Word32)
16+
import Deriving.Aeson (CustomJSON (CustomJSON))
17+
import GHC.Generics (Generic)
18+
import Generic.Functor (GenericBifunctor (GenericBifunctor))
19+
import Linear.V2 (V2 (..))
20+
21+
-- import Orphans.V2 ()
22+
import Monpad.Util.ShowNewtype (ShowNewtypeWithoutRecord (ShowNewtypeWithoutRecord))
23+
import Monpad.JSON
24+
import Orphans ()
25+
26+
-- | A message generated by the server.
27+
data ServerUpdate a b
28+
= PlayAudioURL Text
29+
| Vibrate [Int]
30+
-- ^ millisecond intervals: https://developer.mozilla.org/en-US/docs/Web/API/Vibration_API#vibration_patterns
31+
| SetImageURL ElementID Text
32+
| AddImage ElementID Image
33+
| DeleteImage ElementID
34+
| SetText ElementID Text
35+
| SetTextStyle ElementID TextStyle
36+
| SetTextSize ElementID Word
37+
| SetTextColour ElementID (AlphaColour Double)
38+
| SetTextBold ElementID Bool
39+
| SetTextItalic ElementID Bool
40+
| SetTextUnderline ElementID Bool
41+
| SetTextShadow ElementID [TextShadow]
42+
| SetTextFont ElementID Text
43+
| AddText ElementID TextBox
44+
| DeleteText ElementID
45+
| SetLayout (Layout a b)
46+
| SwitchLayout LayoutID
47+
| HideElement ElementID
48+
| ShowElement ElementID
49+
-- ^ i.e. 'unhide'
50+
| AddElement (FullElement a b)
51+
| RemoveElement ElementID
52+
| SetBackgroundColour (AlphaColour Double)
53+
| SetIndicatorHollowness ElementID Double
54+
| SetIndicatorArcStart ElementID Double
55+
| SetIndicatorArcEnd ElementID Double
56+
| SetIndicatorShape ElementID Shape
57+
| SetIndicatorCentre ElementID (V2 Double)
58+
| SetIndicatorColour ElementID (AlphaColour Double)
59+
| SetSliderPosition ElementID Double
60+
| SetButtonColour ElementID (AlphaColour Double)
61+
| SetButtonPressed ElementID Bool
62+
| ResetLayout ResetLayout
63+
| Ping Text
64+
-- ^ Send a ping with an identifier. Client will respond with a matching pong.
65+
--
66+
-- This is really designed for `--ext-ws` mode.
67+
-- Otherwise we can use the PingIndicator plugin, which just uses the ping functionality of websockets.
68+
deriving (Eq, Show, Generic, Functor)
69+
deriving (ToJSON) via CustomJSON JSON (ServerUpdate a b)
70+
deriving (Bifunctor) via GenericBifunctor ServerUpdate
71+
72+
data ResetLayout
73+
= StateReset
74+
-- ^ just stick positions, buttons pressed, etc.
75+
| FullReset
76+
-- ^ return to the layout the program was initialised with (undo add/remove elements etc.)
77+
deriving (Eq, Show, Generic)
78+
deriving (ToJSON) via CustomJSON JSON ResetLayout
79+
80+
-- | A message sent by a client.
81+
type ClientUpdate = ClientUpdate' ElementID
82+
data ClientUpdate' m
83+
= ButtonUp m
84+
| ButtonDown m
85+
| StickMove m (V2 Double) -- always a vector within the unit circle
86+
| SliderMove m Double -- between 0 and 1
87+
| InputBool m Bool
88+
| InputNumber m Int32
89+
| InputText m Text
90+
| SubmitInput m -- for number and text inputs
91+
| Pong Text
92+
-- ^ See 'ServerUpdate.Ping'.
93+
deriving (Eq, Ord, Show, Generic, Functor, Foldable, Traversable)
94+
deriving (FromJSON) via CustomJSON JSON (ClientUpdate' m)
95+
96+
newtype ElementHash = ElementHash Word32
97+
deriving (Eq, Ord, Show, Generic)
98+
deriving (FromJSON) via CustomJSON JSON ElementHash
99+
hashElementID :: ElementID -> ElementHash
100+
hashElementID = ElementHash . fromIntegral . murmur3 0 . encodeUtf8 . (.unwrap)
101+
102+
decodeUpdate :: BSL.ByteString -> Either (BSL.ByteString, B.ByteOffset, String) (ClientUpdate' ElementHash)
103+
decodeUpdate =
104+
second thd3 . B.runGetOrFail do
105+
B.getWord8 >>= \case
106+
0 -> ButtonUp <$> getElemHash
107+
1 -> ButtonDown <$> getElemHash
108+
2 -> StickMove <$> getElemHash <*> getVec
109+
3 -> SliderMove <$> getElemHash <*> B.getDoublele
110+
4 -> InputBool <$> getElemHash <*> getBool
111+
5 -> InputNumber <$> getElemHash <*> B.getInt32le
112+
6 -> InputText <$> getElemHash <*> getRemainingText
113+
7 -> SubmitInput <$> getElemHash
114+
8 -> Pong <$> getRemainingText
115+
_ -> fail "unknown constructor"
116+
where
117+
getElemHash = ElementHash <$> B.getWord32le
118+
getVec = V2 <$> B.getDoublele <*> B.getDoublele
119+
getBool = (/= 0) <$> B.getWord8
120+
getRemainingText = either (fail . show) pure . decodeUtf8' . BSL.toStrict =<< B.getRemainingLazyByteString
121+
122+
data Encoding
123+
= JSONEncoding
124+
| BinaryEncoding
125+
deriving (Eq, Show, Generic)
126+
deriving (ToJSON) via CustomJSON JSON Encoding
127+
128+
-- | The arguments with which the frontend is initialised.
129+
data ElmFlags = ElmFlags
130+
{ layouts :: NonEmpty (Layout () ())
131+
, username :: Text
132+
, encoding :: Encoding
133+
, supportsFullscreen :: Bool
134+
, windowTitle :: Text
135+
}
136+
deriving (Eq, Show, Generic)
137+
deriving (ToJSON) via CustomJSON JSON ElmFlags
138+
139+
newtype LayoutID = LayoutID {unwrap :: Text}
140+
deriving newtype (Eq, Ord, Semigroup, Monoid, ToJSON)
141+
deriving Show via (ShowNewtypeWithoutRecord "LayoutID" Text)
142+
143+
data Layout a b = Layout
144+
{ elements :: [FullElement a b]
145+
, viewBox :: ViewBox
146+
, backgroundColour :: AlphaColour Double
147+
, name :: LayoutID
148+
}
149+
deriving (Eq, Show, Functor, Generic)
150+
deriving (ToJSON) via CustomJSON JSON (Layout a b)
151+
deriving (Bifunctor) via GenericBifunctor Layout
152+
153+
data FullElement a b = FullElement
154+
{ element :: Element a b
155+
, location :: V2 Int
156+
, name :: ElementID
157+
, text :: Maybe TextBox
158+
, image :: Maybe Image
159+
, hidden :: Bool
160+
}
161+
deriving (Eq, Show, Functor, Generic)
162+
deriving (ToJSON) via CustomJSON JSON (FullElement a b)
163+
deriving (Bifunctor) via GenericBifunctor FullElement
164+
165+
newtype ElementID = ElementID {unwrap :: Text}
166+
deriving stock (Eq, Ord)
167+
deriving newtype (ToJSON, FromJSON)
168+
deriving Show via (ShowNewtypeWithoutRecord "ElementID" Text)
169+
170+
data Element a b
171+
= Stick (Stick a)
172+
| Button (Button b)
173+
| Slider (Slider a)
174+
| Indicator Indicator
175+
| Input Input
176+
| Empty (V2 Word) -- ^ dimensions are needed so that we can calculate an extent for text and image elements
177+
deriving (Eq, Show, Functor, Generic)
178+
deriving (ToJSON) via CustomJSON JSON (Element a b)
179+
deriving (Bifunctor) via GenericBifunctor Element
180+
181+
data Stick a = Stick'
182+
{ radius :: Word
183+
, range :: Word
184+
, stickColour :: AlphaColour Double
185+
, backgroundColour :: AlphaColour Double
186+
, stickDataX :: a
187+
, stickDataY :: a
188+
}
189+
deriving (Eq, Show, Functor, Generic)
190+
deriving (ToJSON) via CustomJSON JSON (Stick a)
191+
192+
data Button b = Button'
193+
{ shape :: Shape
194+
, colour :: AlphaColour Double
195+
, buttonData :: b
196+
}
197+
deriving (Eq, Show, Functor, Generic)
198+
deriving (ToJSON) via CustomJSON JSON (Button b)
199+
200+
data Slider a = Slider'
201+
{ radius :: Word
202+
, offset :: V2 Int
203+
-- ^ where the slider ends (it starts at the element's location)
204+
, width :: Word
205+
, initialPosition :: Double
206+
-- ^ 0 (start) to 1 (end)
207+
, resetOnRelease :: Bool
208+
, sliderColour :: AlphaColour Double
209+
, backgroundColour :: AlphaColour Double
210+
, sliderData :: a
211+
}
212+
deriving (Eq, Show, Functor, Generic)
213+
deriving (ToJSON) via CustomJSON JSON (Slider a)
214+
215+
data Input = Input'
216+
{ width :: Word
217+
, height :: Word
218+
, inputType :: InputType
219+
}
220+
deriving (Eq, Show, Generic)
221+
deriving (ToJSON) via CustomJSON JSON Input
222+
data InputType
223+
= CheckBox () --TODO this dummy field works around a bug in my PR: https://github.com/folq/haskell-to-elm/pull/18
224+
| Number NumberInput
225+
| Text TextInput
226+
deriving (Eq, Show, Generic)
227+
deriving (ToJSON) via CustomJSON JSON InputType
228+
data NumberInput = NumberInput'
229+
{ textStyle :: TextStyle
230+
, min :: Maybe Double
231+
, max :: Maybe Double
232+
, step :: Maybe Double
233+
}
234+
deriving (Eq, Show, Generic)
235+
deriving (ToJSON) via CustomJSON JSON NumberInput
236+
data TextInput = TextInput'
237+
{ textStyle :: TextStyle
238+
, minLength :: Maybe Word
239+
, maxLength :: Maybe Word
240+
}
241+
deriving (Eq, Show, Generic)
242+
deriving (ToJSON) via CustomJSON JSON TextInput
243+
244+
data Image = Image
245+
{ url :: Text
246+
}
247+
deriving (Eq, Show, Generic)
248+
deriving (ToJSON) via CustomJSON JSON Image
249+
250+
data PosX
251+
= Left
252+
| Centre
253+
| Right
254+
deriving (Eq, Show, Generic)
255+
deriving (ToJSON) via CustomJSON JSON PosX
256+
data PosY
257+
= Top
258+
| Middle
259+
| Bottom
260+
deriving (Eq, Show, Generic)
261+
deriving (ToJSON) via CustomJSON JSON PosY
262+
263+
data TextBox = TextBox
264+
{ text :: Text
265+
, style :: TextStyle
266+
, alignX :: PosX
267+
, alignY :: PosY
268+
}
269+
deriving (Eq, Show, Generic)
270+
deriving (ToJSON) via CustomJSON JSON TextBox
271+
272+
data Indicator = Indicator'
273+
{ hollowness :: Double
274+
-- ^ [0, 1]
275+
, arcStart :: Double
276+
-- ^ [0, 1)
277+
, arcEnd :: Double
278+
-- ^ [0, arcStart + 1)
279+
, centre :: V2 Double
280+
-- ^ x and y in [-1, 1]
281+
, colour :: AlphaColour Double
282+
, shape :: Shape
283+
}
284+
deriving (Eq, Show, Generic)
285+
deriving (ToJSON) via CustomJSON JSON Indicator
286+
287+
data Shape
288+
= Circle Word
289+
| Rectangle (V2 Word)
290+
deriving (Eq, Show, Generic)
291+
deriving (ToJSON) via CustomJSON JSON Shape
292+
293+
data ViewBox = ViewBox
294+
{ x :: Int
295+
, y :: Int
296+
, w :: Word
297+
, h :: Word
298+
}
299+
deriving (Eq, Show, Generic)
300+
deriving (ToJSON) via CustomJSON JSON ViewBox
301+
302+
data TextStyle = TextStyle
303+
{ size :: Word
304+
, colour :: AlphaColour Double
305+
, bold :: Bool
306+
, italic :: Bool
307+
, underline :: Bool
308+
, shadow :: [TextShadow]
309+
, rotation :: Double
310+
, align :: PosX
311+
, font :: Text
312+
-- ^ this is used directly as the value of the HTML `font-family` attribute
313+
}
314+
deriving (Eq, Show, Generic)
315+
deriving (ToJSON) via CustomJSON JSON TextStyle
316+
317+
data TextShadow = TextShadow
318+
{ offset :: V2 Int
319+
, blur :: Word
320+
, colour :: AlphaColour Double
321+
}
322+
deriving (Eq, Show, Generic)
323+
deriving (ToJSON) via CustomJSON JSON TextShadow

‎haskell/src/Opts.hs‎ renamed to ‎haskell/core/Monpad/JSON.hs‎

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,4 @@
1-
-- | Compile-time configuration.
2-
module Opts where
1+
module Monpad.JSON where
32

43
import Deriving.Aeson (SumObjectWithSingleField)
54

0 commit comments

Comments
 (0)