georgefst · georgefst · Jan 26, 2025
diff --git a/cabal.project b/cabal.project
@@ -12,6 +12,19 @@ source-repository-package
   tag: fe615b57548c74767586244c27e0e2dfbd52f861
 allow-newer: haskell-to-elm:text
 
+-- using master due to lack of release: https://github.com/dmjio/miso/pull/752
+source-repository-package
+  type: git
+  location: https://github.com/dmjio/miso
+  tag: e411f3e2872465f37eb53b6de4542010a105b53a
+
+-- https://github.com/georgefst/diagrams-miso/tree/master
+-- https://github.com/cocreature/diagrams-miso/pull/7 and others
+source-repository-package
+  type: git
+  location: https://github.com/georgefst/diagrams-miso
+  tag: 4f95ed29fed23885f5d6fc22382fc09c154d14ab
+
 allow-newer:
   -- copied from georgefst-utils - unfortunately cabal solver isn't aware it should ignore some components
   okapi:*,
@@ -28,3 +41,47 @@ if impl(ghc >= 9.10)
     tag: b2047c3b89537f93a686ddd8cf1879ffb81a8f9a
     subdir: . core
   allow-newer: *:streamly, *:streamly-core
+
+if arch(wasm32)
+  -- default global config for Wasm adds `:override` for `head.hackage`, which can be pretty horrible
+  -- https://gitlab.haskell.org/haskell-wasm/ghc-wasm-meta/-/issues/9#note_553150
+  active-repositories: hackage.haskell.org, head.hackage.ghc.haskell.org
+
+  -- from ghc-wasm-miso-examples (can't this be specified by bounds?)
+  constraints: time installed
+  allow-newer: time
+
+  allow-newer:
+    -- unreleased: https://github.com/ekmett/lens/commit/8db6d9abb9e3e2e7ac8402a18a95654cc66340e4
+    lens:template-haskell,
+    -- https://github.com/haskell/haskeline/pull/188
+    haskeline:containers,
+    -- https://github.com/sdiehl/repline/pull/50
+    repline:containers,
+
+  -- https://github.com/diagrams/diagrams-lib/pull/372
+  source-repository-package
+    type: git
+    location: https://github.com/georgefst/diagrams-lib
+    tag: 19d9ebeb22385a7674ea7bec6856dc130b73350f
+
+  -- https://github.com/haskell/entropy/pull/86
+  source-repository-package
+    type: git
+    location: https://github.com/amesgen/entropy
+    tag: f771c8010f001b87c5ccf9b61703b6912f7062d5
+  allow-newer: entropy:Cabal
+
+  -- https://github.com/haskellari/splitmix/pull/73
+  source-repository-package
+    type: git
+    location: https://github.com/amesgen/splitmix
+    tag: 5f5b766d97dc735ac228215d240a3bb90bc2ff75
+
+else
+  -- https://github.com/ghcjs/jsaddle/pull/149
+  source-repository-package
+    type: git
+    location: https://github.com/georgefst/jsaddle
+    tag: 8ebf96891fe9580fc16e1fe99b0ca503b9cf2ed8
+    subdir: jsaddle jsaddle-warp
diff --git a/haskell/core/Monpad/Core.hs b/haskell/core/Monpad/Core.hs
@@ -0,0 +1,323 @@
+{- HLINT ignore "Use newtype instead of data" -}
+module Monpad.Core where
+
+import Data.Aeson.Types (FromJSON, ToJSON)
+import Data.Bifunctor (Bifunctor (second))
+import Data.Binary.Get qualified as B
+import Data.ByteString.Lazy qualified as BSL
+import Data.Colour (AlphaColour)
+import Data.Hash.Murmur
+import Data.Int (Int32)
+import Data.List.NonEmpty (NonEmpty)
+import Data.Text (Text)
+import Data.Text.Encoding (decodeUtf8', encodeUtf8)
+import Data.Tuple.Extra (thd3)
+import Data.Word (Word32)
+import Deriving.Aeson (CustomJSON (CustomJSON))
+import GHC.Generics (Generic)
+import Generic.Functor (GenericBifunctor (GenericBifunctor))
+import Linear.V2 (V2 (..))
+
+-- import Orphans.V2 ()
+import Monpad.Util.ShowNewtype (ShowNewtypeWithoutRecord (ShowNewtypeWithoutRecord))
+import Monpad.JSON
+import Orphans ()
+
+-- | A message generated by the server.
+data ServerUpdate a b
+    = PlayAudioURL Text
+    | Vibrate [Int]
+    -- ^ millisecond intervals: https://developer.mozilla.org/en-US/docs/Web/API/Vibration_API#vibration_patterns
+    | SetImageURL ElementID Text
+    | AddImage ElementID Image
+    | DeleteImage ElementID
+    | SetText ElementID Text
+    | SetTextStyle ElementID TextStyle
+    | SetTextSize ElementID Word
+    | SetTextColour ElementID (AlphaColour Double)
+    | SetTextBold ElementID Bool
+    | SetTextItalic ElementID Bool
+    | SetTextUnderline ElementID Bool
+    | SetTextShadow ElementID [TextShadow]
+    | SetTextFont ElementID Text
+    | AddText ElementID TextBox
+    | DeleteText ElementID
+    | SetLayout (Layout a b)
+    | SwitchLayout LayoutID
+    | HideElement ElementID
+    | ShowElement ElementID
+    -- ^ i.e. 'unhide'
+    | AddElement (FullElement a b)
+    | RemoveElement ElementID
+    | SetBackgroundColour (AlphaColour Double)
+    | SetIndicatorHollowness ElementID Double
+    | SetIndicatorArcStart ElementID Double
+    | SetIndicatorArcEnd ElementID Double
+    | SetIndicatorShape ElementID Shape
+    | SetIndicatorCentre ElementID (V2 Double)
+    | SetIndicatorColour ElementID (AlphaColour Double)
+    | SetSliderPosition ElementID Double
+    | SetButtonColour ElementID (AlphaColour Double)
+    | SetButtonPressed ElementID Bool
+    | ResetLayout ResetLayout
+    | Ping Text
+    -- ^ Send a ping with an identifier. Client will respond with a matching pong.
+    --
+    -- This is really designed for `--ext-ws` mode.
+    -- Otherwise we can use the PingIndicator plugin, which just uses the ping functionality of websockets.
+    deriving (Eq, Show, Generic, Functor)
+    deriving (ToJSON) via CustomJSON JSON (ServerUpdate a b)
+    deriving (Bifunctor) via GenericBifunctor ServerUpdate
+
+data ResetLayout
+    = StateReset
+    -- ^ just stick positions, buttons pressed, etc.
+    | FullReset
+    -- ^ return to the layout the program was initialised with (undo add/remove elements etc.)
+    deriving (Eq, Show, Generic)
+    deriving (ToJSON) via CustomJSON JSON ResetLayout
+
+-- | A message sent by a client.
+type ClientUpdate = ClientUpdate' ElementID
+data ClientUpdate' m
+    = ButtonUp m
+    | ButtonDown m
+    | StickMove m (V2 Double) -- always a vector within the unit circle
+    | SliderMove m Double -- between 0 and 1
+    | InputBool m Bool
+    | InputNumber m Int32
+    | InputText m Text
+    | SubmitInput m -- for number and text inputs
+    | Pong Text
+    -- ^ See 'ServerUpdate.Ping'.
+    deriving (Eq, Ord, Show, Generic, Functor, Foldable, Traversable)
+    deriving (FromJSON) via CustomJSON JSON (ClientUpdate' m)
+
+newtype ElementHash = ElementHash Word32
+    deriving (Eq, Ord, Show, Generic)
+    deriving (FromJSON) via CustomJSON JSON ElementHash
+hashElementID :: ElementID -> ElementHash
+hashElementID = ElementHash . fromIntegral . murmur3 0 . encodeUtf8 . (.unwrap)
+
+decodeUpdate :: BSL.ByteString -> Either (BSL.ByteString, B.ByteOffset, String) (ClientUpdate' ElementHash)
+decodeUpdate =
+    second thd3 . B.runGetOrFail do
+        B.getWord8 >>= \case
+            0 -> ButtonUp <$> getElemHash
+            1 -> ButtonDown <$> getElemHash
+            2 -> StickMove <$> getElemHash <*> getVec
+            3 -> SliderMove <$> getElemHash <*> B.getDoublele
+            4 -> InputBool <$> getElemHash <*> getBool
+            5 -> InputNumber <$> getElemHash <*> B.getInt32le
+            6 -> InputText <$> getElemHash <*> getRemainingText
+            7 -> SubmitInput <$> getElemHash
+            8 -> Pong <$> getRemainingText
+            _ -> fail "unknown constructor"
+  where
+    getElemHash = ElementHash <$> B.getWord32le
+    getVec = V2 <$> B.getDoublele <*> B.getDoublele
+    getBool = (/= 0) <$> B.getWord8
+    getRemainingText = either (fail . show) pure . decodeUtf8' . BSL.toStrict =<< B.getRemainingLazyByteString
+
+data Encoding
+    = JSONEncoding
+    | BinaryEncoding
+    deriving (Eq, Show, Generic)
+    deriving (ToJSON) via CustomJSON JSON Encoding
+
+-- | The arguments with which the frontend is initialised.
+data ElmFlags = ElmFlags
+    { layouts :: NonEmpty (Layout () ())
+    , username :: Text
+    , encoding :: Encoding
+    , supportsFullscreen :: Bool
+    , windowTitle :: Text
+    }
+    deriving (Eq, Show, Generic)
+    deriving (ToJSON) via CustomJSON JSON ElmFlags
+
+newtype LayoutID = LayoutID {unwrap :: Text}
+    deriving newtype (Eq, Ord, Semigroup, Monoid, ToJSON)
+    deriving Show via (ShowNewtypeWithoutRecord "LayoutID" Text)
+
+data Layout a b = Layout
+    { elements :: [FullElement a b]
+    , viewBox :: ViewBox
+    , backgroundColour :: AlphaColour Double
+    , name :: LayoutID
+    }
+    deriving (Eq, Show, Functor, Generic)
+    deriving (ToJSON) via CustomJSON JSON (Layout a b)
+    deriving (Bifunctor) via GenericBifunctor Layout
+
+data FullElement a b = FullElement
+    { element :: Element a b
+    , location :: V2 Int
+    , name :: ElementID
+    , text :: Maybe TextBox
+    , image :: Maybe Image
+    , hidden :: Bool
+    }
+    deriving (Eq, Show, Functor, Generic)
+    deriving (ToJSON) via CustomJSON JSON (FullElement a b)
+    deriving (Bifunctor) via GenericBifunctor FullElement
+
+newtype ElementID = ElementID {unwrap :: Text}
+    deriving stock (Eq, Ord)
+    deriving newtype (ToJSON, FromJSON)
+    deriving Show via (ShowNewtypeWithoutRecord "ElementID" Text)
+
+data Element a b
+    = Stick (Stick a)
+    | Button (Button b)
+    | Slider (Slider a)
+    | Indicator Indicator
+    | Input Input
+    | Empty (V2 Word) -- ^ dimensions are needed so that we can calculate an extent for text and image elements
+    deriving (Eq, Show, Functor, Generic)
+    deriving (ToJSON) via CustomJSON JSON (Element a b)
+    deriving (Bifunctor) via GenericBifunctor Element
+
+data Stick a = Stick'
+    { radius :: Word
+    , range :: Word
+    , stickColour :: AlphaColour Double
+    , backgroundColour :: AlphaColour Double
+    , stickDataX :: a
+    , stickDataY :: a
+    }
+    deriving (Eq, Show, Functor, Generic)
+    deriving (ToJSON) via CustomJSON JSON (Stick a)
+
+data Button b = Button'
+    { shape :: Shape
+    , colour :: AlphaColour Double
+    , buttonData :: b
+    }
+    deriving (Eq, Show, Functor, Generic)
+    deriving (ToJSON) via CustomJSON JSON (Button b)
+
+data Slider a = Slider'
+    { radius :: Word
+    , offset :: V2 Int
+    -- ^ where the slider ends (it starts at the element's location)
+    , width :: Word
+    , initialPosition :: Double
+    -- ^ 0 (start) to 1 (end)
+    , resetOnRelease :: Bool
+    , sliderColour :: AlphaColour Double
+    , backgroundColour :: AlphaColour Double
+    , sliderData :: a
+    }
+    deriving (Eq, Show, Functor, Generic)
+    deriving (ToJSON) via CustomJSON JSON (Slider a)
+
+data Input = Input'
+    { width :: Word
+    , height :: Word
+    , inputType :: InputType
+    }
+    deriving (Eq, Show, Generic)
+    deriving (ToJSON) via CustomJSON JSON Input
+data InputType
+    = CheckBox () --TODO this dummy field works around a bug in my PR: https://github.com/folq/haskell-to-elm/pull/18
+    | Number NumberInput
+    | Text TextInput
+    deriving (Eq, Show, Generic)
+    deriving (ToJSON) via CustomJSON JSON InputType
+data NumberInput = NumberInput'
+    { textStyle :: TextStyle
+    , min :: Maybe Double
+    , max :: Maybe Double
+    , step :: Maybe Double
+    }
+    deriving (Eq, Show, Generic)
+    deriving (ToJSON) via CustomJSON JSON NumberInput
+data TextInput = TextInput'
+    { textStyle :: TextStyle
+    , minLength :: Maybe Word
+    , maxLength :: Maybe Word
+    }
+    deriving (Eq, Show, Generic)
+    deriving (ToJSON) via CustomJSON JSON TextInput
+
+data Image = Image
+    { url :: Text
+    }
+    deriving (Eq, Show, Generic)
+    deriving (ToJSON) via CustomJSON JSON Image
+
+data PosX
+    = Left
+    | Centre
+    | Right
+    deriving (Eq, Show, Generic)
+    deriving (ToJSON) via CustomJSON JSON PosX
+data PosY
+    = Top
+    | Middle
+    | Bottom
+    deriving (Eq, Show, Generic)
+    deriving (ToJSON) via CustomJSON JSON PosY
+
+data TextBox = TextBox
+    { text :: Text
+    , style :: TextStyle
+    , alignX :: PosX
+    , alignY :: PosY
+    }
+    deriving (Eq, Show, Generic)
+    deriving (ToJSON) via CustomJSON JSON TextBox
+
+data Indicator = Indicator'
+    { hollowness :: Double
+    -- ^ [0, 1]
+    , arcStart :: Double
+    -- ^ [0, 1)
+    , arcEnd :: Double
+    -- ^ [0, arcStart + 1)
+    , centre :: V2 Double
+    -- ^ x and y in [-1, 1]
+    , colour :: AlphaColour Double
+    , shape :: Shape
+    }
+    deriving (Eq, Show, Generic)
+    deriving (ToJSON) via CustomJSON JSON Indicator
+
+data Shape
+    = Circle Word
+    | Rectangle (V2 Word)
+    deriving (Eq, Show, Generic)
+    deriving (ToJSON) via CustomJSON JSON Shape
+
+data ViewBox = ViewBox
+    { x :: Int
+    , y :: Int
+    , w :: Word
+    , h :: Word
+    }
+    deriving (Eq, Show, Generic)
+    deriving (ToJSON) via CustomJSON JSON ViewBox
+
+data TextStyle = TextStyle
+    { size :: Word
+    , colour :: AlphaColour Double
+    , bold :: Bool
+    , italic :: Bool
+    , underline :: Bool
+    , shadow :: [TextShadow]
+    , rotation :: Double
+    , align :: PosX
+    , font :: Text
+    -- ^ this is used directly as the value of the HTML `font-family` attribute
+    }
+    deriving (Eq, Show, Generic)
+    deriving (ToJSON) via CustomJSON JSON TextStyle
+
+data TextShadow = TextShadow
+    { offset :: V2 Int
+    , blur :: Word
+    , colour :: AlphaColour Double
+    }
+    deriving (Eq, Show, Generic)
+    deriving (ToJSON) via CustomJSON JSON TextShadow
diff --git a/haskell/src/Opts.hs → haskell/core/Monpad/JSON.hs b/haskell/src/Opts.hs → haskell/core/Monpad/JSON.hs
@@ -1,5 +1,4 @@
--- | Compile-time configuration.
-module Opts where
+module Monpad.JSON where
 
 import Deriving.Aeson (SumObjectWithSingleField)