diff --git a/cabal.project b/cabal.project index fa71fc4..652b161 100644 --- 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 new file mode 100644 index 0000000..a76654d --- /dev/null +++ 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 b/haskell/core/Monpad/JSON.hs similarity index 64% rename from haskell/src/Opts.hs rename to haskell/core/Monpad/JSON.hs index cee4ea4..1f19d65 100644 --- a/haskell/src/Opts.hs +++ b/haskell/core/Monpad/JSON.hs @@ -1,5 +1,4 @@ --- | Compile-time configuration. -module Opts where +module Monpad.JSON where import Deriving.Aeson (SumObjectWithSingleField) diff --git a/haskell/src/Util/ShowNewtype.hs b/haskell/core/Monpad/Util/ShowNewtype.hs similarity index 94% rename from haskell/src/Util/ShowNewtype.hs rename to haskell/core/Monpad/Util/ShowNewtype.hs index e01e0fb..ff5f3e1 100644 --- a/haskell/src/Util/ShowNewtype.hs +++ b/haskell/core/Monpad/Util/ShowNewtype.hs @@ -1,4 +1,4 @@ -module Util.ShowNewtype where +module Monpad.Util.ShowNewtype where import Data.Proxy import GHC.TypeLits diff --git a/haskell/core/Orphans.hs b/haskell/core/Orphans.hs new file mode 100644 index 0000000..ba21343 --- /dev/null +++ b/haskell/core/Orphans.hs @@ -0,0 +1,48 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Orphans where + +import Data.Aeson (FromJSON, ToJSON (toJSON)) +import Data.Aeson qualified as J +import Data.Colour (AlphaColour, alphaChannel, black, over) +import Data.Colour.SRGB (RGB (channelBlue, channelGreen, channelRed), toSRGB) +import Deriving.Aeson (CustomJSON (CustomJSON)) +import GHC.Generics (Generic) +import Linear.V2 (V2 (V2)) + +import Monpad.JSON + +data Vec2 a = Vec2 + { x :: a + , y :: a + } + deriving (Generic, ToJSON) + +instance ToJSON (V2 Int) where + toJSON = J.toJSON . \(V2 x y) -> Vec2 x y +instance ToJSON (V2 Word) where + toJSON = J.toJSON . \(V2 x y) -> Vec2 x y +instance ToJSON (V2 Double) where + toJSON = J.toJSON . \(V2 x y) -> Vec2 x y + +deriving instance FromJSON (V2 Double) + +instance ToJSON (AlphaColour Double) where + toJSON = + J.toJSON . \c -> + let rgb = toSRGB $ c `over` black + in Colour + { red = rgb.channelRed + , green = rgb.channelGreen + , blue = rgb.channelBlue + , alpha = alphaChannel c + } + +data Colour = Colour + { red :: Double + , green :: Double + , blue :: Double + , alpha :: Double + } + deriving (Show, Generic) + deriving (ToJSON) via CustomJSON JSON Colour diff --git a/haskell/frontend/Frontend.hs b/haskell/frontend/Frontend.hs new file mode 100644 index 0000000..28e447a --- /dev/null +++ b/haskell/frontend/Frontend.hs @@ -0,0 +1,1068 @@ +{-# LANGUAGE LexicalNegation #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-ambiguous-fields #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Frontend (app) where + +import Control.Monad (replicateM_) +import Control.Monad.IO.Class +import Control.Monad.State (get) +import Data.Aeson qualified as Aeson +import Data.Bool (bool) +import Data.Colour +import Data.Colour.SRGB +import Data.Foldable +import Data.Function (applyWhen) +import Data.List.Extra hiding ((!?)) +import Data.List.NonEmpty qualified as NE +import Data.Map (Map, (!?)) +import Data.Map qualified as Map +import Data.Maybe (fromMaybe) +import Data.Monoid +import Data.Ord (clamp) +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as T +import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) +import Data.Typeable (Typeable, cast) +import Diagrams.Backend.Miso +import Diagrams.Prelude hiding (Attribute, D, Empty, Last, clamp, element, getLast, outer, radius, size, small, text, width, (%=), (%~), (.=), (.~), (^.)) +import GHC.Generics (Generic) +import GHC.Records (HasField (getField)) +import Linear (unangle) +import Miso hiding (P, Text, back, for_, onMouseDown) +import Miso.String (ms) +import Monpad.Core hiding (Left, Right) +import Monpad.Core qualified +import Numeric (showHex) +import Optics hiding (Empty, both, element) +import Optics.State.Operators +import Util.Util (mwhen, showT) + +app :: JSM () +app = do + -- model <- case JD.decodeValue Auto.ElmFlags.decode f of + -- Err e -> Task.fail $ JsonError e + -- Ok flags -> load flags + (model, initialAction) <- load hardcodedElmFlags + startApp + App + { initialAction + , model + , update = flip $ foldlM \m a -> do + -- TODO for debugging - remove + -- case a of + -- ConsoleLog _ -> pure () + -- _ -> batchEff () $ pure $ pure [ConsoleLog $ ms $ show a] + fromTransition (updateModel a) m + , view = \model' -> + misoDia + ( def + & ( lensVL sizeSpec + .~ dims2D (fromIntegral model'.windowSize.x) (fromIntegral model'.windowSize.y) + ) + & ( lensVL svgAttributes + -- TODO viewbox should probably be part of the `diagrams-miso` API + -- oh actually, maybe we're better off doing this within `diagrams` + -- otherwise units will be all wrong, right? + -- but then how does `elm-collage` make it work? + .~ + -- mkViewbox + -- (viewBox.x) + -- -(fromIntegral viewBox.h + viewBox.y) + -- viewBox.w + -- viewBox.h + -- <> + [ ("width", show model'.windowSize.x <> "px") + , ("height", show model'.windowSize.y <> "px") + , ("style", "background-color: " <> sRGB24showA model'.layout.layout.backgroundColour) + ] + ) + ) + (viewModel model') + (forEventHandlers \e@(EventHandler _) -> handleHandler decoder' e) + , -- TODO `defaultEvents` seems totally arbitrary... + -- also, no docs on what the bool means (it eventually becomes `useCapture` arg to `addEventListener`) + -- docs for `on` should mention this, since the pre-defined handlers seem to correspond to `defaultEvents` + events = defaultEvents <> Map.fromList (forEventHandlers (\(EventHandler e) -> (getEventName e, False))) + , subs = + [ \f -> do + -- TODO put stuff from `Scratch.elm` here (configurably) + replicateM_ 5 do + -- t <- getCurrentTime + -- TODO delay doesn't work... + -- which makes it hard to test everything like we do in `Scratch.elm` + -- liftIO $ threadDelay 1_000_000 + liftIO $ f [ConsoleLog "ping"] + -- liftIO $ + -- f $ + -- map + -- ServerUpdate + -- [ SwitchLayout $ LayoutID "B" + -- , SetBackgroundColour $ black `withOpacity` 1 + -- , ResetLayout StateReset + -- , SetSliderPosition (ElementID "0") 0.7 + -- ] + ] + , mountPoint = Nothing + , logLevel = Off + } + +type D = QDiagram B V2 Double Ann + +-- viewModel :: (_) => Model -> D +-- viewModel :: (b ~ B) => Model -> D +viewModel :: Model -> D +viewModel model = + ( mconcatMap (viewElement model) (model.layout.layout.elements) + -- <> + -- -- TODO is there a better way? extend bounding box or envelope directly + -- -- TODO inconsistent with Elm in that we won't clip out overflowing elements + -- noAnn + -- ( rect + -- (fromIntegral model.layout.layout.viewBox.w) + -- (fromIntegral model.layout.layout.viewBox.h) + -- & fcA transparent + -- & lw 0 + -- ) + -- -- TODO arbitrary - make configurable? + -- -- also, this is consistent in a way that `elm-collage` never was, which is nice + -- & lw 3 + ) + & addAnn + ( Ann' (EventHandler EventPointerMove) \event -> + maybe [] (\c -> c.onMove.unwrap event) $ + Map.lookup event.pointerId model.layout.pointerCallbacks + ) + -- TODO this doesn't get triggered + -- that might be explainable by the way I think events in `diagrams-miso` work + -- fundamental issue? component we care about leaving isn't actually tracked (but it is in the SVG...) + -- I think I originally actually used "pointerup" in Elm version (would explain event name) + -- and then presumably changed for obvious reason, i.e. handler pointer being dragged offscreen + -- NB even "pointerup" version doesn't work with `jsaddle-warp` + -- & addAnn (Ann' (EventHandler EventPointerLeave) $ pure . PointerUp) + -- TODO we should call `preventDefault` here (and everywhere?) to prevent e.g. long-press right-click + -- this was difficult/impossible with elm-collage + & addAnn (Ann' (EventHandler EventPointerUp) $ pure . PointerUp) + +-- , style "background-color" <| toCssString <| fromRgba model.layout.layout.backgroundColour + +viewImage :: V2 Word -> Image -> D +viewImage size img = + fmap (annotate mempty) + . htmlDiagram size [style_ [("pointer-events", "none")]] + $ img_ [src_ img.url, width_ $ ms $ size.x, height_ $ ms size.y] + +-- TODO use `diagrams` text support instead? +-- `diagrams-miso` already supports it, and probably implements similarly to this + +{- | We use a flexbox to center the text. +Rather than attempting to calculate the actual text size, we just set it to the maximum possible +(which is the size of the viewbox). +-} +viewText :: V2 Word -> TextBox -> D +viewText size x = + fmap (annotate mempty) + . + -- ann mempty . + htmlDiagram size [style_ [("pointer-events", "none")]] + $ div_ + [ style_ + [ ("display", "flex") + , + ( "justify-content" + , case x.alignX of + Monpad.Core.Left -> "left" + Centre -> "center" + Monpad.Core.Right -> "right" + ) + , + ( "align-items" + , case x.alignY of + Top -> "start" + Middle -> "center" + Bottom -> "end" + ) + , ("height", "100%") + , ("user-select", "none") + ] + ] + [ pre_ + [textStyle x.style] + [text x.text] + ] + +elementSize :: Element () () -> V2 Word +elementSize = \case + Stick e -> square_ $ e.radius * 2 + Button e -> shapeSize e.shape + Slider e -> square_ $ e.radius * 2 + Indicator e -> shapeSize e.shape + Input e -> V2 e.width e.height + Empty v -> v + where + square_ x = V2 x x + shapeSize s = case s of + Circle r -> square_ $ r * 2 + Rectangle v -> v + +-- viewElement :: (_) => Model -> FullElement () () -> D +viewElement :: Model -> FullElement () () -> D +viewElement model element = + if element.hidden + then mempty + else + -- TODO clean up `P2`/`V2` usage + -- maybe also elsewhere + let toOffset = + let w = fromIntegral <$> model.windowSize + v = V2 (fromIntegral model.layout.layout.viewBox.w) (fromIntegral model.layout.layout.viewBox.h) + -- how far we need to scale v down to fit within w + sf = min (w.x / v.x) (w.y / v.y) + -- pagePos counts down from the top, whereas our other coordinate systems count up from the bottom + invertPagePos = (V2 0 w.y +) . reflectY + pageToSvg = + P + . (V2 (fromIntegral model.layout.layout.viewBox.x) (fromIntegral model.layout.layout.viewBox.y) +) + . (((v - (w ^* (1 / sf))) ^* (1 / 2)) +) + . (^* (1 / sf)) + . invertPagePos + in (.-^ (fromIntegral <$> element.location)) . pageToSvg . unP + in ( case element.element of + Button x -> + viewButton element.name x $ Set.member element.name model.layout.pressed + Stick x -> + viewStick element.name x toOffset $ + fromMaybe 0 (model.layout.stickPos !? element.name) + Slider x -> + viewSlider element.name x toOffset $ + fromMaybe x.initialPosition (model.layout.sliderPos !? element.name) + Indicator x -> + viewIndicator element.name x + Input x -> + viewInput element.name x + Empty _ -> mempty + ) + & maybe id ((<>) . viewImage (elementSize element.element)) element.image + & maybe id ((<>) . viewText (elementSize element.element)) element.text + & translate (fromIntegral <$> element.location) + +viewButton :: ElementID -> Button () -> Bool -> D +viewButton name button pressed = + let shape = case button.shape of + Circle (fromIntegral -> r) -> circle r + Rectangle (fmap fromIntegral -> v) -> rect v.x v.y + in shape + & fcA (applyWhen pressed (darken 0.1) button.colour) + & onPointerDown + (const $ ButtonDown name) + PointerCallbacks + { onMove = OnMove $ const [] + , onRelease = [ClientUpdate $ ButtonUp name] + } + +viewStick :: ElementID -> Stick () -> (P2 Double -> P2 Double) -> V2 Double -> D +viewStick name stick toOffset stickPos = + let range = + fromIntegral + stick.range + radius = + fromIntegral + stick.radius + getOffset event = + let + v0 = toOffset $ toPoint event + l = min range $ norm v0 + in + if l == 0 + then 0 -- (== v0) + else unP $ (l / range) *^ normalize v0 + big = circle range & fcA stick.backgroundColour + small = circle radius & fcA stick.stickColour + in ( (small & translate (range *^ stickPos)) + <> big + ) + & onPointerDown + (StickMove name . getOffset) + PointerCallbacks + { onMove = OnMove \event -> [ClientUpdate $ StickMove name $ getOffset event] + , onRelease = [ClientUpdate $ StickMove name 0] + } + +viewSlider :: ElementID -> Slider () -> (P2 Double -> P2 Double) -> Double -> D +viewSlider name slider toOffset pos = + let width = fromIntegral slider.width + r = fromIntegral slider.radius + v = fromIntegral <$> slider.offset + getOffset event = + let P (V2 x y) = toOffset $ toPoint event + in clamp (0, 1) $ (v.x * x + v.y * y) / quadrance v + stick = + circle r + & fcA slider.sliderColour + & translate (pos *^ v) + background = + roundedRect + width + (norm v + width) + (width / 2) + & fcA slider.backgroundColour + & rotate (unangle v - pi / 2 @@ rad) + & translate ((1 / 2) *^ v) + in (stick <> background) + -- & ann (EventPointerDown, \p -> ConsoleLog $ "slider clicked: " <> name.unwrap <> " " <> showT p) + -- & ann (Ann' (EventHandler EventPointerDown) \e -> [ClientUpdate $ SliderMove name $ getOffset e]) + & onPointerDown + (SliderMove name . getOffset) + PointerCallbacks + { onMove = OnMove \event -> [ClientUpdate $ SliderMove name $ getOffset event] + , onRelease = mwhen slider.resetOnRelease [ClientUpdate $ SliderMove name slider.initialPosition] + } + +-- TODO no need to use loads of line segments for indicator +-- unlike `elm-collage`, `diagrams` has great support for curves +viewIndicator :: ElementID -> Indicator -> D +viewIndicator _ ind = + noAnn + let a = ind.arcStart + b = + if ind.arcEnd < ind.arcStart + then ind.arcEnd + 1 + else ind.arcEnd + -- values in [0, 1) where we need a vertex + angles = takeWhile (\x -> x < b) $ dropWhile (\x -> x < a) case ind.shape of + Rectangle _ -> [(0 :: Double) .. 7] <&> \x -> (2 * x + 1) * 1 / 8 + Circle _ -> [(0 :: Double) .. 2 * nPoints - 1] <&> \x -> x / nPoints + where + nPoints = 256 + outer = + (a : angles <> [b]) <&> \t -> case ind.shape of + Rectangle _ -> V2 (f t) (f $ t - 0.25) + where + mod1 x = x - fromIntegral (floor @_ @Int x) + {- there's nothing I can tell you about this function that you can't get + from typing in to Wolfram Alpha: + min(1, max(-1, ((abs(mod(x, 1) - 0.5) * 2) - 0.5) * 4)) + -} + f x = clamp (-1, 1) $ ((abs (mod1 x - 0.5) * 2) - 0.5) * 4 + Circle _ -> V2 (cos t1) (sin t1) + where + t1 = t * 2 * pi + inner = + if b == a + 1 && ind.hollowness == 0 + then + -- Prevent ugly line in to the center. + -- Yes, these are float comparisons. + -- But we only need this workaround when the user has set exact integer values. + [] + else outer <&> (+ ind.centre) . (^* ind.hollowness) . (- ind.centre) + scale' = case ind.shape of + Rectangle v -> (* P ((fromIntegral <$> v) / 2)) + Circle r -> (^* fromIntegral r) + in (reverse outer <> inner) + & map P -- TODO we should do this conversion further up + & map scale' + & fromVertices + & fcA ind.colour + +viewInput :: ElementID -> Input -> D +viewInput name inp = + let + {- TODO + this is a bit of a hack, to allow us to reset the form + do we really have to go by ID - can't Elm give us a handle to the element? + -} + formId = "form-" <> name.unwrap + in + -- padding ts = + -- let size = ms (ts.size / 2) <> "px" + -- in [ ("padding-left", size) + -- , ("padding-right", size) + -- ] + + fmap (annotate mempty) + . htmlDiagram (fromIntegral <$> V2 inp.width inp.height) [] + $ form_ + [ style_ + [ ("display", "flex") + , ("justify-content", "center") + , ("width", "100%") + , ("height", "100%") + ] + , -- , onSubmit [ClientUpdate $ SubmitInput name, ResetForm id] + id_ formId + ] + [ input_ + [ type_ case inp.inputType of + CheckBox () -> + "checkbox" + Number _ -> + "number" + Text _ -> + "text" + , style_ + [ ("flex", "auto") + , ("width", "100%") + , ("height", "100%") + ] + -- , H.map List.singleton $ + -- case inp.inputType of + -- CheckBox () -> + -- onCheck (ClientUpdate << InputBool name) + -- Number _ -> + -- onInput $ + -- \s -> + -- case String.toInt s of + -- Just f -> + -- ClientUpdate $ InputNumber name f + -- Nothing -> + -- ConsoleLog $ "Failed to decode number input: " <> s + -- Text _ -> + -- onInput (ClientUpdate << InputText name) + ] + -- <> ( case inp.inputType of + -- CheckBox () -> + -- [] + -- Number opts -> + -- H.step (Maybe.unwrap "any" String.fromFloat opts.step) + -- : padding opts.textStyle + -- <> textStyle opts.textStyle + -- <> Maybe.unwrap [] (List.singleton << H.min << String.fromFloat) opts.min + -- <> Maybe.unwrap [] (List.singleton << H.max << String.fromFloat) opts.max + -- Text opts -> + -- padding opts.textStyle + -- <> textStyle opts.textStyle + -- <> Maybe.unwrap [] (List.singleton << H.minlength) opts.minLength + -- <> Maybe.unwrap [] (List.singleton << H.maxlength) opts.maxLength + -- ) + ] + +-- |> shift (unVec2 <| Vec2.scale range stickPos) + +-- \|> onPointerDown +-- (StickMove name << getOffset) +-- { onMove = \event -> [ClientUpdate <| StickMove name <| getOffset event] +-- , onRelease = [ClientUpdate <| StickMove name <| vec2 0 0] +-- } + +-- viewFullscreenButton : ViewBox -> Collage (List Msg) +-- viewFullscreenButton vb = +-- let +-- -- how much of the screen to cover +-- scale = +-- 1 / 6 + +-- size = +-- toFloat (min vb.w vb.h) * scale + +-- arrow = +-- let +-- width = +-- 0.16 + +-- shaft = +-- 0.2 + +-- head = +-- 0.4 + +-- gap = +-- 0.2 +-- in +-- scanl Vec2.add +-- (vec2 gap (-width / 2)) +-- [ vec2 0 width +-- , vec2 shaft 0 +-- , vec2 0 ((head - width) / 2) +-- , vec2 (head / 2) (-head / 2) +-- , vec2 (-head / 2) (-head / 2) +-- , vec2 0 ((head - width) / 2) +-- ] +-- |> List.map (unVec2 << Vec2.scale size) +-- |> polygon +-- |> styled1 (toRgba white) + +-- arrows = +-- range 0 3 +-- |> List.map (\x -> arrow |> rotate ((toFloat x + 0.5) * pi / 2)) +-- |> stack +-- in +-- rectangle size size +-- |> styled1 (toRgba black) +-- |> impose arrows +-- |> shift ( toFloat vb.x + size / 2, toFloat (vb.h + vb.y) - size / 2 ) +-- |> Collage.on "pointerdown" (JD.succeed [ GoFullscreen ]) + +-- {- Model -} + +data Model = Model + { username :: Text + , windowSize :: V2 Word + , fullscreen :: Bool + , encoding :: Encoding + , supportsFullscreen :: Bool + , windowTitle :: Text + , startTime :: POSIXTime + , layout :: LayoutState -- the active layout + , initialLayouts :: Map LayoutID (Layout () ()) + , layouts :: Map LayoutID LayoutState -- NB. the active layout doesn't get updated here until we switch out of it + } + deriving (Eq, Generic) + +data LayoutState = LayoutState + { layout :: Layout () () + , pressed :: Set ElementID -- buttons + , stickPos :: Map ElementID (V2 Double) + , sliderPos :: Map ElementID Double + , pointerCallbacks :: Map Int PointerCallbacks -- keys are the ids of the pointers currently held down + } + deriving (Eq, Generic) + +type Msgs = [Msg] + +data Msg + = NoOp + | ClientUpdate ClientUpdate + | ServerUpdate (ServerUpdate () ()) + | PointerDown Int PointerCallbacks + | PointerUp PointerEvent + | Resized (V2 Word) + | GoFullscreen + | FullscreenChange Bool + | ResetForm Text + | ConsoleLog Text + deriving (Eq, Show) + +-- TODO this is problematic due to Miso requiring `Eq` for model +-- having functions in Elm is heavily discouraged for similar reasons, so it's somewhat surprising that it ever worked +data PointerCallbacks = PointerCallbacks + { onMove :: OnMove + , onRelease :: [Msg] + } + deriving (Eq) +newtype OnMove = OnMove {unwrap :: PointerEvent -> [Msg]} +instance Eq OnMove where + _ == _ = False +instance Show PointerCallbacks where + show _ = "" + +-- data Error +-- = JsonError +-- () +-- | -- Aeson.Error +-- OtherError Text + +load :: ElmFlags -> JSM (Model, [Msg]) +load flags = do + startTime <- liftIO getPOSIXTime + -- windowSize <- getViewportSize + -- let windowSize = V2 1920 1080 + -- let windowSize = V2 1600 900 + -- let windowSize = V2 2000 1000 + let windowSize = V2 1000 500 + let layouts = Map.fromList $ (NE.toList flags.layouts) <&> \x -> (x.name, loadLayout x) + pure + ( Model + { username = flags.username + , layout = loadLayout $ NE.head flags.layouts + , windowSize + , fullscreen = False + , encoding = flags.encoding + , supportsFullscreen = flags.supportsFullscreen + , windowTitle = flags.windowTitle + , startTime + , initialLayouts = (.layout) <$> layouts + , layouts + } + , -- sendInit + [] + ) + +loadLayout :: Layout () () -> LayoutState +loadLayout layout = + LayoutState + { layout = layout + , stickPos = mempty + , pointerCallbacks = mempty + , pressed = mempty + , sliderPos = mempty + } + +updateModel :: Msg -> Transition Msgs Model () +updateModel = \case + NoOp -> pure () + ClientUpdate u -> + -- sendUpdate model.encoding u >> + case u of + ButtonUp b -> #layout % #pressed %= Set.delete b + ButtonDown b -> #layout % #pressed %= Set.insert b + StickMove t p -> #layout % #stickPos %= Map.insert t p + SliderMove t p -> #layout % #sliderPos %= Map.insert t p + InputBool _ _ -> pure () + InputNumber _ _ -> pure () + InputText _ _ -> pure () + SubmitInput _ -> pure () + Pong _ -> pure () + ServerUpdate u -> serverUpdate u + PointerDown pid callbacks -> #layout % #pointerCallbacks %= Map.insert pid callbacks + PointerUp event -> do + model <- get + -- TODO for debugging + -- scheduleIO $ pure $ pure $ ConsoleLog "released" + #layout + % #pointerCallbacks + %= Map.delete event.pointerId + -- TODO might be better to do this atomically, so use + scheduleIO + . pure + $ maybe [] (\c -> c.onRelease) + $ Map.lookup event.pointerId model.layout.pointerCallbacks + Resized v -> #windowSize .= v + GoFullscreen -> pure () + -- goFullscreen + FullscreenChange b -> #fullscreen .= b + ResetForm _ -> pure () + -- resetForm id' + ConsoleLog t -> scheduleIO_ $ consoleLog t + where + +serverUpdate :: ServerUpdate () () -> Transition Msgs Model () +serverUpdate = \case + -- -- this needs to be equivalent to the same handling in the Haskell code + -- TODO we can do this now - factor out somehow + -- TODO use more lenses (currently fairly direct Elm port) + PlayAudioURL _url -> pure () + -- playAudio url + Vibrate _intervals -> pure () + -- vibrate intervals + SetImageURL name u -> updateElementFull name \e -> e{image = fmap (\x -> x{url = u}) e.image} + AddImage name x -> updateElementFull name \e -> e{image = Just x} + DeleteImage name -> updateElementFull name \e -> e{image = Nothing} + SetText name t -> updateElementFull name \e -> e{text = fmap (\x -> x{text = t}) e.text} + SetTextStyle name style -> updateElementFull name \e -> e{text = fmap (\x -> x{style}) e.text} + SetTextSize name x -> updateTextStyle name \s -> s{size = x} + SetTextColour name x -> updateTextStyle name \s -> s{colour = x} + SetTextBold name x -> updateTextStyle name \s -> s{bold = x} + SetTextItalic name x -> updateTextStyle name \s -> s{italic = x} + SetTextUnderline name x -> updateTextStyle name \s -> s{underline = x} + SetTextShadow name x -> updateTextStyle name \s -> s{shadow = x} + SetTextFont name x -> updateTextStyle name \s -> s{font = x} + AddText name x -> updateElementFull name \e -> e{text = Just x} + DeleteText name -> updateElementFull name \e -> e{text = Nothing} + SetLayout l -> #layout .= loadLayout l + SwitchLayout l -> do + model <- get + case Map.lookup l model.layouts of + Just l' -> do + #layout .= l' + #layouts %= Map.insert model.layout.layout.name model.layout + Nothing -> scheduleIO $ pure [ConsoleLog $ "Unknown layout: " <> l.unwrap] + HideElement name -> updateElementFull name \e -> e{hidden = True} + ShowElement name -> updateElementFull name \e -> e{hidden = False} + AddElement e -> #layout % #layout % #elements %= (e :) + RemoveElement e -> + #layout %= \s -> + s + { pressed = Set.delete e s.pressed + , sliderPos = Map.delete e s.sliderPos + , stickPos = Map.delete e s.stickPos + , layout = s.layout{elements = filter (\x -> x.name /= e) s.layout.elements} + } + SetBackgroundColour c -> #layout % #layout % #backgroundColour .= c + SetIndicatorHollowness name x -> updateIndicator name \e -> e{hollowness = x} + SetIndicatorArcStart name x -> updateIndicator name \e -> e{arcStart = x} + SetIndicatorArcEnd name x -> updateIndicator name \e -> e{arcEnd = x} + SetIndicatorShape name x -> updateIndicator name \e -> e{shape = x} + SetIndicatorCentre name x -> updateIndicator name \e -> e{centre = x} + SetIndicatorColour name x -> updateIndicator name \e -> e{colour = x} + SetSliderPosition name x -> #layout % #sliderPos %= Map.insert name x + SetButtonColour name x -> updateButton name \e -> e{colour = x} + SetButtonPressed name x -> #layout % #pressed %= if x then Set.insert name else Set.delete name + ResetLayout x -> case x of + StateReset -> #layout %= \l -> loadLayout l.layout + FullReset -> do + model <- get + case Map.lookup model.layout.layout.name model.initialLayouts of + Just l -> #layout .= loadLayout l + Nothing -> + -- this really shouldn't happen, since we never remove anything from the dict + scheduleIO $ pure [ConsoleLog $ "Not in initial layouts: " <> model.layout.layout.name.unwrap] + -- performCmd [ ClientUpdate <| Pong t ] ) + Ping _t -> pure () + where + -- TODO type sig only needed due to record ambiguities + updateElementFull :: ElementID -> (FullElement () () -> FullElement () ()) -> Transition Msgs Model () + updateElementFull name f = #layout % #layout % #elements %= map \e -> if e.name == name then f e else e + updateElement name f = updateElementFull name \fe -> fe{element = f fe.element} + updateIndicator name f = updateElement name \e -> case e of + Indicator ind -> Indicator $ f ind + _ -> e + updateButton name f = updateElement name \e -> case e of + Button x -> Button $ f x + _ -> e + updateTextStyle name f = updateElementFull name $ #text %~ fmap (\x -> x{style = f x.style}) + +-- {- Util -} + +-- styled1 : Colour -> Collage.Shape -> Collage msg +-- styled1 c = +-- styled ( uniform <| fromRgba c, defaultLineStyle ) + +-- subLogErrors : String -> (a -> Msgs) -> Sub (Result JD.Error a) -> Sub Msgs +-- subLogErrors s f = +-- Sub.map +-- (either +-- (\err -> [ ConsoleLog <| "Failed to decode " <> s <> ": " <> JD.errorToString err ]) +-- f +-- ) + +onPointerDown :: + (PointerEvent -> ClientUpdate) -> + PointerCallbacks -> + QDiagram B V2 Double Any -> + D +onPointerDown f y = + ann + ( Ann' + (EventHandler EventPointerDown) + \e -> + [ PointerDown e.pointerId y + , ClientUpdate $ f e + ] + ) +textStyle :: TextStyle -> Attribute action +textStyle s = + style_ $ + [ ("font-size", showT s.size <> "px") + , ("font-weight", bool "normal" "bold" s.bold) + , ("font-style", bool "normal" "italic" s.italic) + , ("text-decoration", bool "none" "underline" s.underline) + , ("color", T.pack $ sRGB24showA s.colour) + , ("font-family", s.font) + , + ( "text-align" + , case s.align of + Monpad.Core.Left -> "left" + Centre -> "center" + Monpad.Core.Right -> "right" + ) + , ("margin", "0") + ] + -- Rotating text is broken on Safari etc. - see https://github.com/georgefst/monpad/issues/45. + -- We add a guard here so that it at least works when no rotation is actually set. + <> ( if s.rotation == 0 + then [] + else [("transform", "rotate(" <> showT s.rotation <> "rad)")] + ) + <> ( if null s.shadow + then [] + else + [ + ( "text-shadow" + , T.intercalate ", " $ + s.shadow <&> \shadow -> + T.intercalate + " " + [ showT shadow.offset.x <> "px" + , showT -shadow.offset.y <> "px" + , showT shadow.blur <> "px" + , T.pack $ sRGB24showA shadow.colour + ] + ) + ] + ) + +-- TODO don't hardcode (taken from Elm scratchpad for now) +-- get this from JS wrapper like in Elm version? we can probably do some of it here instead +-- also, rename the type +hardcodedElmFlags :: ElmFlags +hardcodedElmFlags = + ElmFlags + { username = "GT" + , encoding = JSONEncoding + , supportsFullscreen = False + , windowTitle = "monpad scratch" + , layouts = + NE.fromList + [ Layout + { elements = + [ FullElement + { location = V2 -600 0 + , image = Nothing + , text = Nothing + , name = ElementID "indicator" + , hidden = False + , element = + Indicator + Indicator' + { hollowness = 0.5 + , arcStart = 0 + , arcEnd = 2 / 3 + , centre = 0 + , colour = opaque $ sRGB 0.8 0 0.5 + , shape = Circle 300 + } + } + , FullElement + { location = V2 900 0 + , image = Nothing + , text = Nothing + , name = ElementID "powerbar" + , hidden = False + , element = + Indicator + Indicator' + { hollowness = 0 + , arcStart = 0.5 + , arcEnd = 1 + , centre = 0 + , colour = opaque purple + , shape = Rectangle $ V2 100 800 + } + } + , FullElement + { location = V2 600 0 + , image = Nothing + , text = Nothing + , name = ElementID "stick" + , hidden = False + , element = + Stick + Stick' + { radius = 80 + , range = 300 + , backgroundColour = opaque blue + , stickColour = opaque white + , stickDataX = () + , stickDataY = () + } + } + , FullElement + { location = V2 -300 -200 + , image = Nothing + , text = Nothing + , name = ElementID "slider" + , hidden = False + , element = + Slider + Slider' + { radius = 40 + , width = 80 + , offset = V2 600 400 + , initialPosition = 0.2 + , resetOnRelease = True + , backgroundColour = opaque green + , sliderColour = opaque white + , sliderData = () + } + } + , FullElement + { location = V2 0 350 + , image = Nothing + , name = ElementID "button" + , hidden = False + , text = + Just + TextBox + { style = + TextStyle + { bold = True + , italic = True + , underline = True + , colour = opaque darkgray + , size = 60 + , shadow = + [ TextShadow + { offset = V2 2 -1 + , blur = 2 + , colour = opaque black + } + ] + , rotation = 0.1 + , align = Centre + , font = "sans-serif" + } + , alignX = Centre + , alignY = Middle + , text = "c'est un\nbutton" + } + , element = + Button + Button' + { shape = Rectangle $ V2 300 100 + , colour = opaque yellow + , buttonData = () + } + } + , FullElement + { location = V2 -500 0 + , name = ElementID "image" + , hidden = False + , element = Empty $ V2 1000 1000 + , image = + Just + Image + { url = "https://upload.wikimedia.org/wikipedia/commons/c/c2/Hieronymus_prag_a.jpg" + } + , text = Nothing + } + ] + , viewBox = ViewBox{x = -1000, y = -500, w = 2000, h = 1000} + , backgroundColour = opaque $ sRGB 0.81 0.91 0.97 + , name = LayoutID "A" + } + , Layout + { elements = + [ FullElement + { location = V2 -600 0 + , image = Nothing + , text = Nothing + , name = ElementID "0" + , hidden = False + , element = + Slider + Slider' + { radius = 200 + , width = 200 + , offset = V2 (600 * 2) 0 + , backgroundColour = opaque red + , sliderColour = opaque white + , resetOnRelease = True + , initialPosition = 0 + , sliderData = () + } + } + ] + , viewBox = ViewBox{x = -1000, y = -500, w = 2000, h = 1000} + , backgroundColour = opaque white + , name = LayoutID "B" + } + ] + } + +-- inpired by https://github.com/cocreature/diagrams-miso/blob/master/example/src/Colors.hs +-- TODO could the library be improved to make all this a bit easier? +-- i.e. add some helpers hardcoded to using `action` as the annotation type +-- or `Decoder action` or whatever we end up with +-- TODO eugh this is getting horrible +-- could we somehow just attach handlers by ID or something instead? +-- maybe depends how well things like `pointerleave` work +-- DummySimpleEvent :: EventHandler' (P2 Double) +type Ann = [Ann'] +data Ann' where Ann' :: EventHandler e -> (e -> Msgs) -> Ann' +annotate :: (Monoid p) => p -> Any -> p +annotate c b = mwhen (getAny b) c +ann :: Ann' -> Diagram B -> D +ann a = fmap $ annotate $ pure a +noAnn :: Diagram B -> D +noAnn = fmap (annotate mempty) +addAnn :: Ann' -> D -> D +addAnn a x = fmap (a :) x +class Decodable e where + decoder' :: Decoder e +instance Decodable PointerEvent where + decoder' = pointerEventDecoder +data EventHandler e where + EventHandler :: (Typeable e, Decodable e, ToPoint e) => EventHandler' e -> EventHandler e +deriving instance Eq (EventHandler e) +data EventHandler' e where + EventPointerDown :: EventHandler' PointerEvent + EventPointerMove :: EventHandler' PointerEvent + EventPointerUp :: EventHandler' PointerEvent + EventPointerLeave :: EventHandler' PointerEvent +deriving instance Eq (EventHandler' e) +forEventHandlers :: (forall e. EventHandler e -> a) -> [a] +forEventHandlers f = + [ f $ EventHandler EventPointerDown + , f $ EventHandler EventPointerMove + , f $ EventHandler EventPointerUp + , f $ EventHandler EventPointerLeave + ] + where + _f :: EventHandler' e -> () + _f = \case + EventPointerDown -> () + EventPointerMove -> () + EventPointerUp -> () + EventPointerLeave -> () +class ToPoint a where + toPoint :: a -> P2 Double +instance ToPoint (P2 Double) where + toPoint = id +instance ToPoint PointerEvent where + toPoint e = p2 e.pagePos +getEventName :: EventHandler' e -> Text +getEventName = \case + EventPointerDown -> "pointerdown" + EventPointerMove -> "pointermove" + EventPointerUp -> "pointerup" + EventPointerLeave -> "pointerleave" +instance Functor Decoder where fmap f d@Decoder{decoder = d'} = d{decoder = fmap f . d'} +handleHandler :: forall e. (Typeable e, ToPoint e) => Decoder e -> EventHandler e -> DiaAttr Ann Msgs +handleHandler d e@(EventHandler e0) = + mkDiaAttr @_ @_ @Msgs + (getEventName e0) + d + toPoint + ( \p -> concatMap \case + -- TODO that's gonna be a lot of noops... + -- as well as just a lot of iterating through the same handlers + -- Last (Just (Ann' (EventHandler _) (cast -> Just a))) + Ann' (EventHandler (cast @_ @(EventHandler' e) -> Just e')) (cast -> Just a) + | e == (EventHandler e') -> a p + -- _ -> [NoOp] + _ -> [] + ) + +-- mkViewbox :: Int -> Int -> Word -> Word -> Attrs +-- mkViewbox x y w h = [("viewbox", unwords $ map show [x, y] <> map show [w, h])] + +-- https://github.com/ekmett/linear/issues/181 +instance HasField "x" (V2 a) a where + getField = (^. lensVL _x) +instance HasField "y" (V2 a) a where + getField = (^. lensVL _y) +instance HasField "x" (P2 a) a where + getField = (^. lensVL _x) +instance HasField "y" (P2 a) a where + getField = (^. lensVL _y) + +-- TODO is there a better way? +-- if not then this belongs in a library, maybe `colour` itself +sRGB24showA :: (RealFrac a, Floating a, Show a) => AlphaColour a -> String +sRGB24showA c = sRGB24show c' <> applyWhen (length a == 1) ('0' :) a + where + a = showHex (clamp (0, 255) $ floor @_ @Int $ alphaChannel c * 256) "" + -- TODO this isn't even right - it affects the RGB values, when I really just want to remove the alpha + -- low priority for now since we only actually use this for background color, which will be opaque in practice + c' = c `Data.Colour.over` black + +-- TODO +-- build more of these +-- try to upstream to Miso? +-- maybe copy from Elm? +-- check MDN for all fields +data PointerEvent = PointerEvent + { pointerId :: Int + , pagePos :: (Double, Double) + } + deriving (Eq, Show) +pointerEventDecoder :: Decoder PointerEvent +pointerEventDecoder = + Decoder + ( Aeson.withObject "event" $ \o -> + PointerEvent + <$> (o Aeson..: "pointerId") + <*> ( (,) + <$> (o Aeson..: "pageX") + <*> (o Aeson..: "pageY") + ) + ) + -- TODO could we actually make use of this? maybe not + (DecodeTarget []) diff --git a/haskell/frontend/Main.hs b/haskell/frontend/Main.hs new file mode 100644 index 0000000..5580d58 --- /dev/null +++ b/haskell/frontend/Main.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedRecordDot #-} + +#ifdef wasi_HOST_OS + +module MyMain (main) where + +import Frontend +import GHC.Wasm.Prim +import Language.Javascript.JSaddle.Wasm qualified as JSaddle.Wasm + +foreign export javascript "hs_start" main :: IO () + +main :: IO () +main = JSaddle.Wasm.run app + +#else + +module Main (main) where + +import Frontend +import Data.Text.Lazy.Encoding (encodeUtf8) +import Language.Javascript.JSaddle.Warp +import Network.Wai.Application.Static + +main :: IO () +main = debugOr + (Just $ encodeUtf8 "Monpad\n") + 8000 + app + (staticApp (defaultWebAppSettings "../frontend-hs")) + +#endif diff --git a/haskell/hie.yaml b/haskell/hie.yaml index a3acc63..bedfc6b 100644 --- a/haskell/hie.yaml +++ b/haskell/hie.yaml @@ -1,8 +1,14 @@ cradle: cabal: + - path: ./core + component: lib:monpad-core + - path: ./src component: lib:monpad + - path: ./frontend + component: exe:frontend + - path: ./app component: exe:monpad diff --git a/haskell/monpad.cabal b/haskell/monpad.cabal index 51def49..ea3dc45 100644 --- a/haskell/monpad.cabal +++ b/haskell/monpad.cabal @@ -28,17 +28,14 @@ common common -O0 ghc-options: -Wall - -threaded build-depends: georgefst-utils, - georgefst-utils:streamly-utils, base >= 4.16, ansi-terminal ^>= {0.11.1, 1.0, 1.1}, binary ^>= 0.8.9, bytestring ^>= {0.10.8, 0.11, 0.12}, composition ^>= 1.0.2.1, containers ^>= {0.6.2.1, 0.7}, - dhall ^>= 1.42, directory ^>= 1.3.3, either ^>= 5.0.1.1, extra ^>= {1.7.4, 1.8}, @@ -52,7 +49,6 @@ common common pretty-simple ^>= 4.1, random ^>= 1.2.0, safe ^>= 0.3.19, - streamly ^>= {0.8, 0.9, 0.10, 0.11}, streams ^>= 3.3, text ^>= {1.2.3, 1.3, 1.4, 1.5, 2.0, 2.1}, time ^>= {1.10, 1.11, 1.12, 1.13, 1.14}, @@ -98,9 +94,31 @@ common common TypeOperators ViewPatterns +common core + build-depends: + aeson ^>= {1.5, 2.0, 2.1, 2.2}, + colour ^>= 2.3.5, + deriving-aeson ^>= 0.2.6.1, + generic-functor ^>= {0.2, 1.1}, + +-- basically, stuff that's needed for frontend +-- TODO call this `monpad-types` or something? +library monpad-core + import: + common, + core, + exposed-modules: + Monpad.Core + Monpad.JSON + Monpad.Util.ShowNewtype + Orphans + hs-source-dirs: + core + library import: - common + common, + core, exposed-modules: Monpad Monpad.Plugins @@ -112,48 +130,45 @@ library other-modules: Test Embed - GenerateElm - GenerateElm.Via Layout - Opts Orphans.Colour Orphans.Generic Orphans.V2 - ServerUpdate Util Util.Prizm - Util.ShowNewtype hs-source-dirs: src if flag(release) build-depends: file-embed ^>= 0.0.11.2 build-depends: - aeson ^>= {1.5, 2.0, 2.1, 2.2}, + monpad:monpad-core, + georgefst-utils:streamly-utils, bifunctors ^>= {5.5.7, 5.6}, - colour ^>= 2.3.5, convertible ^>= 1.1.1, - deriving-aeson ^>= 0.2.6.1, + dhall ^>= 1.42, elm-syntax ^>= 0.3.0, exceptions ^>= 0.10.4, fsnotify ^>= 0.4, generic-data ^>= {0.9.2, 1.1}, - generic-functor ^>= {0.2, 1.1}, generics-sop ^>= 0.5.0, haskell-to-elm ^>= 0.3.1, hostname ^>= 1.0, http-types ^>= 0.12.3, + -- TODO this and qrcode libs cause errors for WASM even when in non-built component... + -- fortunately it's easy to stub out the dependent code (all one file - `Plugins/QR.hs`) JuicyPixels ^>= 3.3.5, lucid ^>= 2.11, monad-control ^>= 1.0.2.3, network ^>= {3.1.1.1, 3.2}, prettyprinter ^>= 1.7.0, prizm ^>= 3.0.0, - qrcode-core ^>= 0.9.4, - qrcode-juicypixels ^>= 0.8.2, + -- qrcode-core ^>= 0.9.4, + -- qrcode-juicypixels ^>= 0.8.2, servant ^>= 0.20, servant-lucid ^>= 0.9.0.1, servant-server ^>= 0.20, servant-websockets ^>= 2.0, + streamly ^>= {0.8, 0.9, 0.10, 0.11}, streamly-fsnotify ^>= 2.1, stm ^>= 2.5, transformers-base ^>= 0.4.5.2, @@ -184,3 +199,51 @@ executable monpad build-depends: monpad, optparse-applicative ^>= {0.15.1.0, 0.16, 0.17, 0.18}, + -- TODO DRY via a second `common`? + dhall ^>= 1.42, + streamly ^>= {0.8, 0.9, 0.10, 0.11}, + ghc-options: + -threaded + +executable frontend + import: + common, + core, + main-is: + Main.hs + other-modules: + Frontend + hs-source-dirs: + frontend + build-depends: + -- TODO DRY via `common` section(s) and add bounds + monpad:monpad-core, + base, + aeson, + containers, + diagrams-core, + diagrams-lib, + diagrams-miso, + ghc-experimental, + jsaddle, + jsaddle-wasm, + miso, + mtl, + random, + text, + if arch(wasm32) + build-depends: + ghc-experimental, + jsaddle-wasm, + ghc-options: + -no-hs-main -optl-mexec-model=reactor "-optl-Wl,--export=hs_start" + -- TODO do we need this? + -- crashes the build + -- then again, `threadDelay` isn't working... + -- -threaded + else + build-depends: + jsaddle-warp, + wai-app-static, + warp, + websockets, diff --git a/haskell/src/GenerateElm.hs b/haskell/src/GenerateElm.hs deleted file mode 100644 index ef840b1..0000000 --- a/haskell/src/GenerateElm.hs +++ /dev/null @@ -1,270 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -Wno-unused-top-binds #-} - --- | Auto-generate all required Elm code - types plus JSON encoders and decoders. -module GenerateElm (elm) where - -import Data.Aeson qualified as J -import Data.Colour (AlphaColour) -import Data.Foldable (for_) -import Data.HashMap.Strict qualified as HashMap -import Data.Maybe (catMaybes) -import Data.Text qualified as T -import Data.Text.IO qualified as T -import GHC.Generics (Generic) -import Generics.SOP qualified as SOP -import Language.Elm.Definition qualified as Def -import Language.Elm.Expression qualified as Expr -import Language.Elm.Name qualified as Name -import Language.Elm.Pretty qualified as Pretty -import Language.Elm.Simplification qualified as Simplify -import Language.Elm.Type qualified as Type -import Language.Haskell.To.Elm (HasElmDecoder (..), HasElmEncoder (..), HasElmType (..)) -import Prettyprinter (defaultLayoutOptions, layoutPretty) -import Prettyprinter.Render.Text (renderStrict) -import System.Directory (createDirectoryIfMissing, removeFile) -import System.FilePath (joinPath, (<.>), ()) -import Util.Util (listDirectory') - -import GenerateElm.Via -import Monpad -import Orphans.Colour () - -{- | Auto generate Elm datatypes, encoders/decoders etc. -It's best to run this via GHCI or HLS. -We could make it externally executable and fully integrate with the build process, but there wouldn't be much point -since the kinds of changes we're likely to make which would require re-running this, -are likely to require manual changes to Elm code anyway. -e.g. if we added an extra case to 'Update', it would need to be handled in various Elm functions. --} - --- >>> elm "elm" -elm :: FilePath -> IO () -elm pathToElm = writeDefs pathToElm $ mconcat - [ defAndEncoder @ClientUpdate - , defAndEncoder @(V2 Double) - , defAndDecoder @(ServerUpdate () ()) - , defAndDecoder @(Layout () ()) - , defAndDecoder @(FullElement () ()) - , defAndDecoder @(Element () ()) - , defAndDecoder @(Stick ()) - , defAndDecoder @(Slider ()) - , defAndDecoder @(Button ()) - , defAndDecoder @Input - , defAndDecoder @InputType - , defAndDecoder @NumberInput - , defAndDecoder @TextInput - , defAndDecoder @Image - , defAndDecoder @PosX - , defAndDecoder @PosY - , defAndDecoder @TextBox - , defAndDecoder @TextStyle - , defAndDecoder @TextShadow - , defAndDecoder @ResetLayout - , defAndDecoder @Encoding - , defAndDecoder @ElmFlags - , defAndDecoder @ViewBox - , defAndDecoder @(AlphaColour Double) - , defAndDecoder @Indicator - , defAndDecoder @Shape - , defAndDecoder @(V2 Int) - ] - -writeDefs :: FilePath -> [Def.Definition] -> IO () -writeDefs elmPath defs = do - createDirectoryIfMissing False autoFull - mapM_ removeFile =<< listDirectory' autoFull - for_ (HashMap.toList modules) \(moduleName, contents) -> - T.writeFile (src joinPath (map T.unpack moduleName) <.> "elm") $ - renderStrict $ layoutPretty defaultLayoutOptions contents - where - src = elmPath "src" - modules = Pretty.modules $ map Simplify.simplifyDefinition defs - autoFull = src T.unpack autoDir - --- | Like 'jsonDefinitions', but for types without decoders. -defAndEncoder :: forall t. HasElmEncoder J.Value t => [Def.Definition] -defAndEncoder = catMaybes - [ elmDefinition @t - , elmEncoderDefinition @J.Value @t - ] - --- | Like 'jsonDefinitions', but for types without encoders. -defAndDecoder :: forall t. HasElmDecoder J.Value t => [Def.Definition] -defAndDecoder = catMaybes - [ elmDefinition @t - , elmDecoderDefinition @J.Value @t - ] - -{- Instances for Monpad types -} - -deriving instance SOP.Generic ClientUpdate -deriving instance SOP.HasDatatypeInfo ClientUpdate -deriving via Via' "ClientUpdate" ClientUpdate instance HasElmType ClientUpdate -deriving via Via' "ClientUpdate" ClientUpdate instance HasElmEncoder J.Value ClientUpdate - -deriving instance SOP.Generic (ServerUpdate a b) -deriving instance SOP.HasDatatypeInfo (ServerUpdate a b) -deriving via Via2 ServerUpdate () () instance HasElmType (ServerUpdate a b) -deriving via Via2 ServerUpdate () () instance HasElmDecoder J.Value (ServerUpdate a b) - -deriving instance SOP.Generic (Layout a b) -deriving instance SOP.HasDatatypeInfo (Layout a b) -deriving via Via2 Layout () () instance HasElmType (Layout a b) -deriving via Via2 Layout () () instance HasElmDecoder J.Value (Layout a b) - -deriving instance SOP.Generic (FullElement a b) -deriving instance SOP.HasDatatypeInfo (FullElement a b) -deriving via Via2 FullElement () () instance HasElmType (FullElement a b) -deriving via Via2 FullElement () () instance HasElmDecoder J.Value (FullElement a b) - -deriving instance SOP.Generic (Element a b) -deriving instance SOP.HasDatatypeInfo (Element a b) -deriving via Via2 Element () () instance HasElmType (Element a b) -deriving via Via2 Element () () instance HasElmDecoder J.Value (Element a b) - -deriving instance SOP.Generic (Stick a) -deriving instance SOP.HasDatatypeInfo (Stick a) -deriving via Via1 Stick () instance HasElmType (Stick a) -deriving via Via1 Stick () instance HasElmDecoder J.Value (Stick a) - -deriving instance SOP.Generic (Slider a) -deriving instance SOP.HasDatatypeInfo (Slider a) -deriving via Via1 Slider () instance HasElmType (Slider a) -deriving via Via1 Slider () instance HasElmDecoder J.Value (Slider a) - -deriving instance SOP.Generic (Button a) -deriving instance SOP.HasDatatypeInfo (Button a) -deriving via Via1 Button () instance HasElmType (Button a) -deriving via Via1 Button () instance HasElmDecoder J.Value (Button a) - -deriving instance SOP.Generic Input -deriving instance SOP.HasDatatypeInfo Input -deriving via Via Input instance HasElmType Input -deriving via Via Input instance HasElmDecoder J.Value Input - -deriving instance SOP.Generic InputType -deriving instance SOP.HasDatatypeInfo InputType -deriving via Via InputType instance HasElmType InputType -deriving via Via InputType instance HasElmDecoder J.Value InputType - -deriving instance SOP.Generic NumberInput -deriving instance SOP.HasDatatypeInfo NumberInput -deriving via Via NumberInput instance HasElmType NumberInput -deriving via Via NumberInput instance HasElmDecoder J.Value NumberInput - -deriving instance SOP.Generic TextInput -deriving instance SOP.HasDatatypeInfo TextInput -deriving via Via TextInput instance HasElmType TextInput -deriving via Via TextInput instance HasElmDecoder J.Value TextInput - -deriving instance SOP.Generic Image -deriving instance SOP.HasDatatypeInfo Image -deriving via Via Image instance HasElmType Image -deriving via Via Image instance HasElmDecoder J.Value Image - -deriving instance SOP.Generic PosY -deriving instance SOP.HasDatatypeInfo PosY -deriving via Via PosY instance HasElmType PosY -deriving via Via PosY instance HasElmDecoder J.Value PosY - -deriving instance SOP.Generic PosX -deriving instance SOP.HasDatatypeInfo PosX -deriving via Via PosX instance HasElmType PosX -deriving via Via PosX instance HasElmDecoder J.Value PosX - -deriving instance SOP.Generic TextBox -deriving instance SOP.HasDatatypeInfo TextBox -deriving via Via TextBox instance HasElmType TextBox -deriving via Via TextBox instance HasElmDecoder J.Value TextBox - -deriving instance SOP.Generic TextStyle -deriving instance SOP.HasDatatypeInfo TextStyle -deriving via Via TextStyle instance HasElmType TextStyle -deriving via Via TextStyle instance HasElmDecoder J.Value TextStyle - -deriving instance SOP.Generic TextShadow -deriving instance SOP.HasDatatypeInfo TextShadow -deriving via Via TextShadow instance HasElmType TextShadow -deriving via Via TextShadow instance HasElmDecoder J.Value TextShadow - -deriving instance SOP.Generic ResetLayout -deriving instance SOP.HasDatatypeInfo ResetLayout -deriving via Via ResetLayout instance HasElmType ResetLayout -deriving via Via ResetLayout instance HasElmDecoder J.Value ResetLayout - -deriving instance SOP.Generic Encoding -deriving instance SOP.HasDatatypeInfo Encoding -deriving via Via Encoding instance HasElmType Encoding -deriving via Via Encoding instance HasElmDecoder J.Value Encoding - -deriving instance SOP.Generic ElmFlags -deriving instance SOP.HasDatatypeInfo ElmFlags -deriving via Via ElmFlags instance HasElmType ElmFlags -deriving via Via ElmFlags instance HasElmDecoder J.Value ElmFlags - -deriving instance SOP.Generic ViewBox -deriving instance SOP.HasDatatypeInfo ViewBox -deriving via Via ViewBox instance HasElmType ViewBox -deriving via Via ViewBox instance HasElmDecoder J.Value ViewBox - -deriving instance SOP.Generic Indicator -deriving instance SOP.HasDatatypeInfo Indicator -deriving via Via Indicator instance HasElmType Indicator -deriving via Via Indicator instance HasElmDecoder J.Value Indicator - -deriving instance SOP.Generic Shape -deriving instance SOP.HasDatatypeInfo Shape -deriving via Via Shape instance HasElmType Shape -deriving via Via Shape instance HasElmDecoder J.Value Shape - -{- Instances for third-party types -} - -elmUnit :: Name.Qualified -elmUnit = Name.Qualified ["Basics"] "()" -instance HasElmDecoder J.Value () where - elmDecoder = Expr.App (Expr.Global $ Name.Qualified ["Json", "Decode"] "succeed") (Expr.Global elmUnit) -instance HasElmType () where elmType = Type.Global elmUnit - --- NB we can decode but encoding would be unsafe -instance HasElmType Word where - elmType = "Basics.Int" -instance HasElmDecoder J.Value Word where - elmDecoder = "Json.Decode.int" - -data IntVec2 = IntVec2 - { x :: Int - , y :: Int - } - deriving (Generic, SOP.Generic, SOP.HasDatatypeInfo) - deriving (HasElmType, HasElmDecoder J.Value) via Via IntVec2 -data WordVec2 = WordVec2 - { x :: Word - , y :: Word - } - deriving (Generic, SOP.Generic, SOP.HasDatatypeInfo) - deriving (HasElmType, HasElmDecoder J.Value) via Via IntVec2 -data DoubleVec2 = DoubleVec2 - { x :: Double - , y :: Double - } - deriving (Generic, SOP.Generic, SOP.HasDatatypeInfo) - -instance HasElmDecoder J.Value (V2 Int) where - elmDecoderDefinition = elmDecoderDefinition @J.Value @IntVec2 -instance HasElmType (V2 Int) where - elmDefinition = elmDefinition @IntVec2 - -instance HasElmDecoder J.Value (V2 Word) where - elmDecoderDefinition = elmDecoderDefinition @J.Value @WordVec2 -instance HasElmType (V2 Word) where - elmDefinition = elmDefinition @WordVec2 - -instance HasElmDecoder J.Value (V2 Double) where - elmDecoder = Expr.Global $ Name.Qualified ["Util"] "decodeVec2" -instance HasElmEncoder J.Value (V2 Double) where - elmEncoder = Expr.Global $ Name.Qualified ["Util"] "encodeVec2" -instance HasElmType (V2 Double) where - elmType = Type.Global $ Name.Qualified ["Math", "Vector2"] "Vec2" diff --git a/haskell/src/GenerateElm/Via.hs b/haskell/src/GenerateElm/Via.hs deleted file mode 100644 index 367c812..0000000 --- a/haskell/src/GenerateElm/Via.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} - --- | All the ugly details -module GenerateElm.Via (autoDir, Via' (..), Via (..), Via1 (..), Via2 (..)) where - -import Data.Aeson qualified as J -import Data.List.NonEmpty (NonEmpty) -import Data.Text (Text) -import Deriving.Aeson (aesonOptions) -import GHC.Base (Symbol) -import GHC.TypeLits (KnownSymbol) -import Generics.SOP qualified as SOP -import Language.Elm.Definition qualified as Def -import Language.Elm.Name qualified as Name -import Type.Reflection (Typeable) -import Util.Util (symbolValT, typeRepT) - -import Language.Haskell.To.Elm - -import Opts qualified - -autoDir :: Text -autoDir = "Auto" - -newtype Via' (s :: Symbol) a = Via' a -instance (ED a a, KnownSymbol s) => HasElmType (Via' s a) where - elmDefinition = ed @a @a $ symbolValT @s -instance (EED a a, KnownSymbol s) => HasElmEncoder J.Value (Via' s a) where - elmEncoderDefinition = eed @a @a $ symbolValT @s -instance (EDD a a, KnownSymbol s) => HasElmDecoder J.Value (Via' s a) where - elmDecoderDefinition = edd @a @a $ symbolValT @s - -newtype Via a = Via a -instance (ED a a) => HasElmType (Via a) where - elmDefinition = ed @a @a (typeRepT @a) -instance (EED a a) => HasElmEncoder J.Value (Via a) where - elmEncoderDefinition = eed @a @a (typeRepT @a) -instance (EDD a a) => HasElmDecoder J.Value (Via a) where - elmDecoderDefinition = edd @a @a (typeRepT @a) - -newtype Via1 t a = Via1 (t a) -instance (ED t (t ())) => HasElmType (Via1 t a) where - elmDefinition = ed @t @(t ()) (typeRepT @t) -instance (EED t (t ())) => HasElmEncoder J.Value (Via1 t ()) where - elmEncoderDefinition = eed @t @(t ()) (typeRepT @t) -instance (EDD t (t ())) => HasElmDecoder J.Value (Via1 t ()) where - elmDecoderDefinition = edd @t @(t ()) (typeRepT @t) - -newtype Via2 t a b = Via2 (t a b) -instance (ED t (t () ())) => HasElmType (Via2 t a b) where - elmDefinition = ed @t @(t () ()) (typeRepT @t) -instance (EED t (t () ())) => HasElmEncoder J.Value (Via2 t () ()) where - elmEncoderDefinition = eed @t @(t () ()) (typeRepT @t) -instance (EDD t (t () ())) => HasElmDecoder J.Value (Via2 t () ()) where - elmDecoderDefinition = edd @t @(t () ()) (typeRepT @t) - -qual :: Text -> Text -> Name.Qualified -qual t = Name.Qualified [autoDir, t] -ed :: forall t a. Text -> (DeriveParameterisedElmTypeDefinition 0 a, Typeable t) => Maybe Def.Definition -ed t = Just $ deriveElmTypeDefinition @a defaultOptions $ qual t t -eed :: forall t a. Text -> (DeriveParameterisedElmEncoderDefinition 0 J.Value a, Typeable t) => Maybe Def.Definition -eed t = Just $ deriveElmJSONEncoder @a defaultOptions (aesonOptions @Opts.JSON) $ qual t "encode" -edd :: forall t a. Text -> (DeriveParameterisedElmDecoderDefinition 0 J.Value a, Typeable t) => Maybe Def.Definition -edd t = Just $ deriveElmJSONDecoder @a defaultOptions (aesonOptions @Opts.JSON) $ qual t "decode" - -type A f a = SOP.All2 f (SOP.Code a) -type ED t a = (SOP.HasDatatypeInfo a, A HasElmType a, Typeable t) -type EED t a = (ED t a, HasElmType a, A (HasElmEncoder J.Value) a) -type EDD t a = (ED t a, HasElmType a, A (HasElmDecoder J.Value) a) - -instance (HasElmType a) => HasElmType (NonEmpty a) where - elmType = elmType @[a] -instance (HasElmDecoder J.Value a) => HasElmDecoder J.Value (NonEmpty a) where - elmDecoder = elmDecoder @J.Value @[a] diff --git a/haskell/src/Layout.hs b/haskell/src/Layout.hs index c732c25..42f7549 100644 --- a/haskell/src/Layout.hs +++ b/haskell/src/Layout.hs @@ -1,27 +1,17 @@ +{-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Use newtype instead of data" #-} module Layout where import Control.Monad.Trans.Maybe (runMaybeT) -import Data.Aeson qualified as J -import Data.Aeson.Types (FromJSON, ToJSON) -import Data.Aeson.Types qualified as JSON -import Data.Bifunctor (Bifunctor) -import Data.Colour (AlphaColour) import Data.List.NonEmpty (NonEmpty) import Data.Text (Text) -import Deriving.Aeson (CustomJSON (CustomJSON)) import Dhall (FromDhall) -import GHC.Generics (Generic) -import Generic.Functor (GenericBifunctor (GenericBifunctor)) -import Language.Haskell.To.Elm (HasElmDecoder, HasElmEncoder, HasElmType) -import Linear.V2 (V2) import Orphans.V2 () -import Util.ShowNewtype (ShowNewtypeWithoutRecord (ShowNewtypeWithoutRecord)) +import Monpad.Core import Orphans.Colour () -import Opts qualified import Util -- | A (non-empty) list of 'Layout's. @@ -32,188 +22,24 @@ layoutsFromDhall write = runMaybeT . traverse \t -> do (l, _) <- dhallToHs write e pure (l, e) -newtype LayoutID = LayoutID {unwrap :: Text} - deriving newtype (Eq, Ord, Semigroup, Monoid, ToJSON, FromDhall, HasElmType, HasElmDecoder JSON.Value) - deriving Show via (ShowNewtypeWithoutRecord "LayoutID" Text) - -data Layout a b = Layout - { elements :: [FullElement a b] - , viewBox :: ViewBox - , backgroundColour :: AlphaColour Double - , name :: LayoutID - } - deriving (Show, Functor, Generic, FromDhall) - deriving (ToJSON) via CustomJSON Opts.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 (Show, Functor, Generic, FromDhall) - deriving (ToJSON) via CustomJSON Opts.JSON (FullElement a b) - deriving (Bifunctor) via GenericBifunctor FullElement - -newtype ElementID = ElementID {unwrap :: Text} - deriving stock (Eq, Ord) - deriving newtype (FromDhall, ToJSON, FromJSON, HasElmType, HasElmEncoder J.Value, HasElmDecoder J.Value) - 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 (Show, Functor, Generic, FromDhall) - deriving (ToJSON) via CustomJSON Opts.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 (Show, Functor, Generic, FromDhall) - deriving (ToJSON) via CustomJSON Opts.JSON (Stick a) - -data Button b = Button' - { shape :: Shape - , colour :: AlphaColour Double - , buttonData :: b - } - deriving (Show, Functor, Generic, FromDhall) - deriving (ToJSON) via CustomJSON Opts.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 (Show, Functor, Generic, FromDhall) - deriving (ToJSON) via CustomJSON Opts.JSON (Slider a) - -data Input = Input' - { width :: Word - , height :: Word - , inputType :: InputType - } - deriving (Show, Generic, FromDhall) - deriving (ToJSON) via CustomJSON Opts.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 (Show, Generic, FromDhall) - deriving (ToJSON) via CustomJSON Opts.JSON InputType -data NumberInput = NumberInput' - { textStyle :: TextStyle - , min :: Maybe Double - , max :: Maybe Double - , step :: Maybe Double - } - deriving (Show, Generic, FromDhall) - deriving (ToJSON) via CustomJSON Opts.JSON NumberInput -data TextInput = TextInput' - { textStyle :: TextStyle - , minLength :: Maybe Word - , maxLength :: Maybe Word - } - deriving (Show, Generic, FromDhall) - deriving (ToJSON) via CustomJSON Opts.JSON TextInput - -data Image = Image - { url :: Text - } - deriving (Show, Generic, FromDhall) - deriving (ToJSON) via CustomJSON Opts.JSON Image - -data PosX - = Left - | Centre - | Right - deriving (Show, Generic, FromDhall) - deriving (ToJSON) via CustomJSON Opts.JSON PosX -data PosY - = Top - | Middle - | Bottom - deriving (Show, Generic, FromDhall) - deriving (ToJSON) via CustomJSON Opts.JSON PosY - -data TextBox = TextBox - { text :: Text - , style :: TextStyle - , alignX :: PosX - , alignY :: PosY - } - deriving (Show, Generic, FromDhall) - deriving (ToJSON) via CustomJSON Opts.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 (Show, Generic, FromDhall) - deriving (ToJSON) via CustomJSON Opts.JSON Indicator - -data Shape - = Circle Word - | Rectangle (V2 Word) - deriving (Show, Generic, FromDhall) - deriving (ToJSON) via CustomJSON Opts.JSON Shape - -data ViewBox = ViewBox - { x :: Int - , y :: Int - , w :: Word - , h :: Word - } - deriving (Show, Generic, FromDhall) - deriving (ToJSON) via CustomJSON Opts.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 (Show, Generic, FromDhall) - deriving (ToJSON) via CustomJSON Opts.JSON TextStyle - -data TextShadow = TextShadow - { offset :: V2 Int - , blur :: Word - , colour :: AlphaColour Double - } - deriving (Show, Generic, FromDhall) - deriving (ToJSON) via CustomJSON Opts.JSON TextShadow +deriving newtype instance FromDhall (LayoutID) +deriving instance (FromDhall a, FromDhall b) => FromDhall (Layout a b) +deriving instance (FromDhall a, FromDhall b) => FromDhall (FullElement a b) +deriving newtype instance FromDhall ElementID +deriving instance (FromDhall a, FromDhall b) => FromDhall (Element a b) +deriving instance (FromDhall a) => FromDhall (Stick a) +deriving instance (FromDhall b) => FromDhall (Button b) +deriving instance (FromDhall a) => FromDhall (Slider a) +deriving instance FromDhall (Input) +deriving instance FromDhall (InputType) +deriving instance FromDhall (NumberInput) +deriving instance FromDhall (TextInput) +deriving instance FromDhall (Image) +deriving instance FromDhall (PosX) +deriving instance FromDhall (PosY) +deriving instance FromDhall (TextBox) +deriving instance FromDhall (Indicator) +deriving instance FromDhall (Shape) +deriving instance FromDhall (ViewBox) +deriving instance FromDhall (TextStyle) +deriving instance FromDhall (TextShadow) diff --git a/haskell/src/Monpad.hs b/haskell/src/Monpad.hs index 51abd9f..1e6b3a9 100644 --- a/haskell/src/Monpad.hs +++ b/haskell/src/Monpad.hs @@ -23,8 +23,6 @@ module Monpad ( ElementHash(..), Update, Update' (..), - ClientUpdate, - ClientUpdate' (..), ServerUpdate (..), ResetLayout (..), V2 (..), @@ -33,7 +31,7 @@ module Monpad ( warn, internalElementTag, module Layout, - module ServerUpdate, + module Monpad.Core, ) where import Control.Concurrent @@ -46,7 +44,7 @@ import Control.Monad.Except import Control.Monad.Reader import Control.Monad.State import Control.Monad.Trans.Control -import Data.Aeson (FromJSON, ToJSON, eitherDecode, encode) +import Data.Aeson (eitherDecode, encode) import Data.Aeson.Text (encodeToLazyText) import Data.Bifunctor import Data.Binary.Get qualified as B @@ -54,11 +52,8 @@ import Data.ByteString.Lazy qualified as BSL import Data.Colour (Colour) import Data.Foldable import Data.Functor -import Data.Hash.Murmur import Data.IORef -import Data.Int import Data.List.Extra (chunksOf) -import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NE import Data.Map (Map, (!?)) import Data.Map qualified as Map @@ -69,15 +64,13 @@ import Data.Set qualified as Set import Data.String (fromString) import Data.Text (Text) import Data.Text qualified as T -import Data.Text.Encoding (decodeUtf8', encodeUtf8) +import Data.Text.Encoding (encodeUtf8) import Data.Text.IO qualified as T import Data.Text.Lazy qualified as TL import Data.Time import Data.Time.Clock.POSIX import Data.Traversable import Data.Tuple.Extra hiding (first, second) -import Data.Word -import Deriving.Aeson (CustomJSON (CustomJSON)) import GHC.Generics (Generic) import Linear (V2 (..)) import Lucid hiding (for_) @@ -101,11 +94,10 @@ import Util.Streamly qualified as Stream import Util.Util import Embed -import Layout hiding (Left, Right) -import Opts qualified +import Layout +import Monpad.Core hiding (Left, Right) import Orphans.Colour () import Orphans.Generic () -import ServerUpdate import Util data Client = Client @@ -144,64 +136,6 @@ data Update' a b i | ServerUpdate (ServerUpdate a b) deriving (Show, Functor, Foldable, Traversable) --- | 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 Opts.JSON (ClientUpdate' m) - -data Encoding - = JSONEncoding - | BinaryEncoding - deriving (Show, Generic) - deriving (ToJSON) via CustomJSON Opts.JSON Encoding - -newtype ElementHash = ElementHash Word32 - deriving (Eq, Ord, Show, Generic) - deriving (FromJSON) via CustomJSON Opts.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 - --- | The arguments with which the frontend is initialised. -data ElmFlags = ElmFlags - { layouts :: NonEmpty (Layout () ()) - , username :: Text - , encoding :: Encoding - , supportsFullscreen :: Bool - , windowTitle :: Text - } - deriving (Show, Generic) - deriving (ToJSON) via CustomJSON Opts.JSON ElmFlags - type UsernameParam = "username" type ColourParam = "colour" type AssetsApi = Raw diff --git a/haskell/src/Monpad/Plugins/QR.hs b/haskell/src/Monpad/Plugins/QR.hs index 637e0cd..1f2448a 100644 --- a/haskell/src/Monpad/Plugins/QR.hs +++ b/haskell/src/Monpad/Plugins/QR.hs @@ -1,28 +1,29 @@ +{-# OPTIONS_GHC -Wno-unused-imports #-} module Monpad.Plugins.QR (plugin) where -import Codec.Picture +-- import Codec.Picture import Data.Functor import System.Directory import System.FilePath -import Codec.QRCode -import Codec.QRCode.JuicyPixels +-- import Codec.QRCode +-- import Codec.QRCode.JuicyPixels import Data.Text qualified as T import Monpad import Monpad.Plugins -plugin :: Logger -> FilePath -> Plugin a b -plugin path = Plugin . writeQR @() @() path +plugin :: forall a b. Logger -> FilePath -> Plugin a b +plugin _logger _path = Plugin $ mempty @(ServerConfig () () a b) -writeQR :: (Monoid e, Monoid s) => Logger -> FilePath -> ServerConfig e s a b -writeQR write path0 = mempty - { onStart = \url -> case encodeText (defaultQRCodeOptions M) Iso8859_1OrUtf8WithoutECI url of - Nothing -> write.log "Failed to encode URL as QR code" - Just qr -> do - path <- doesDirectoryExist path0 <&> \case - True -> path0 "monpad-address-qr.png" - False -> path0 - savePngImage path . ImageY8 $ toImage 4 100 qr - write.log $ "Server address encoded as: " <> T.pack path - } +-- writeQR :: (Monoid e, Monoid s) => Logger -> FilePath -> ServerConfig e s a b +-- writeQR write path0 = mempty +-- { onStart = \url -> case encodeText (defaultQRCodeOptions M) Iso8859_1OrUtf8WithoutECI url of +-- Nothing -> write.log "Failed to encode URL as QR code" +-- Just qr -> do +-- path <- doesDirectoryExist path0 <&> \case +-- True -> path0 "monpad-address-qr.png" +-- False -> path0 +-- savePngImage path . ImageY8 $ toImage 4 100 qr +-- write.log $ "Server address encoded as: " <> T.pack path +-- } diff --git a/haskell/src/Orphans/Colour.hs b/haskell/src/Orphans/Colour.hs index 71895e9..f28595d 100644 --- a/haskell/src/Orphans/Colour.hs +++ b/haskell/src/Orphans/Colour.hs @@ -2,50 +2,25 @@ module Orphans.Colour () where -import Data.Aeson (ToJSON (toJSON)) -import Data.Aeson qualified as J import Data.Bifunctor (first) -import Data.Colour (AlphaColour, alphaChannel, black, over, withOpacity) +import Data.Colour (AlphaColour, withOpacity) import Data.Colour qualified as Colour -import Data.Colour.SRGB (RGB (channelBlue, channelGreen, channelRed), sRGB, sRGB24reads, toSRGB) +import Data.Colour.SRGB (sRGB, sRGB24reads) import Data.Text qualified as T -import Deriving.Aeson (CustomJSON (CustomJSON)) import Dhall (FromDhall (autoWith), Generic) -import GenerateElm.Via qualified as Elm -import Generics.SOP qualified as SOP -import Language.Haskell.To.Elm (HasElmDecoder (elmDecoderDefinition), HasElmType (elmDefinition)) -import Opts qualified import Servant (FromHttpApiData (parseUrlPiece)) import Text.Read (readEither) -instance ToJSON (AlphaColour Double) where - toJSON = - J.toJSON . \c -> - let rgb = toSRGB $ c `over` black - in Colour - { red = rgb.channelRed - , green = rgb.channelGreen - , blue = rgb.channelBlue - , alpha = alphaChannel c - } - instance FromDhall (AlphaColour Double) where autoWith = fmap (\(c :: Colour) -> withOpacity (sRGB c.red c.green c.blue) c.alpha) . autoWith -instance HasElmDecoder J.Value (AlphaColour Double) where - elmDecoderDefinition = elmDecoderDefinition @J.Value @Colour -instance HasElmType (AlphaColour Double) where - elmDefinition = elmDefinition @Colour - data Colour = Colour { red :: Double , green :: Double , blue :: Double , alpha :: Double } - deriving (Show, Generic, FromDhall, SOP.Generic, SOP.HasDatatypeInfo) - deriving (ToJSON) via CustomJSON Opts.JSON Colour - deriving (HasElmType, HasElmDecoder J.Value) via Elm.Via Colour + deriving (Show, Generic, FromDhall) instance FromHttpApiData (Colour.Colour Float) where parseUrlPiece = first T.pack . readEither' . T.unpack diff --git a/haskell/src/Orphans/V2.hs b/haskell/src/Orphans/V2.hs index 9b737a3..51c130a 100644 --- a/haskell/src/Orphans/V2.hs +++ b/haskell/src/Orphans/V2.hs @@ -3,8 +3,7 @@ -- | Instances for working with JSON and Dhall. module Orphans.V2 () where -import Data.Aeson (FromJSON, ToJSON) -import Data.Aeson qualified as J +import Data.Aeson (ToJSON) import Dhall (FromDhall (autoWith)) import GHC.Generics (Generic) import Linear.V2 (V2 (V2)) @@ -15,18 +14,9 @@ data Vec2 a = Vec2 } deriving (Generic, FromDhall, ToJSON) -instance ToJSON (V2 Int) where - toJSON = J.toJSON . \(V2 x y) -> Vec2 x y -instance ToJSON (V2 Word) where - toJSON = J.toJSON . \(V2 x y) -> Vec2 x y -instance ToJSON (V2 Double) where - toJSON = J.toJSON . \(V2 x y) -> Vec2 x y - instance FromDhall (V2 Int) where autoWith = fmap (\(Vec2 x y) -> V2 x y) . autoWith instance FromDhall (V2 Word) where autoWith = fmap (\(Vec2 x y) -> V2 x y) . autoWith instance FromDhall (V2 Double) where autoWith = fmap (\(Vec2 x y) -> V2 x y) . autoWith - -deriving instance FromJSON (V2 Double) diff --git a/haskell/src/ServerUpdate.hs b/haskell/src/ServerUpdate.hs deleted file mode 100644 index cce592a..0000000 --- a/haskell/src/ServerUpdate.hs +++ /dev/null @@ -1,67 +0,0 @@ -module ServerUpdate where - -import Data.Aeson (ToJSON) -import Data.Bifunctor (Bifunctor) -import Data.Colour (AlphaColour) -import Data.Text (Text) -import Deriving.Aeson (CustomJSON (..)) -import GHC.Generics (Generic) -import Generic.Functor (GenericBifunctor (..)) -import Linear.V2 (V2) - -import Layout -import Opts qualified - --- | 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 (Show, Generic, Functor) - deriving (ToJSON) via CustomJSON Opts.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 (Show, Generic) - deriving (ToJSON) via CustomJSON Opts.JSON ResetLayout diff --git a/html/index.html b/html/index.html new file mode 100644 index 0000000..6c6526a --- /dev/null +++ b/html/index.html @@ -0,0 +1,13 @@ + + + + + + Monpad + + + + + + + diff --git a/js/index.js b/js/index.js new file mode 100644 index 0000000..526b133 --- /dev/null +++ b/js/index.js @@ -0,0 +1,27 @@ +import { + WASI, + OpenFile, + File, + ConsoleStdout, +} from "https://cdn.jsdelivr.net/npm/@bjorn3/browser_wasi_shim@0.2.21/dist/index.js"; +import ghc_wasm_jsffi from "./ghc_wasm_jsffi.js"; + +const args = []; +const env = []; +const fds = [ + new OpenFile(new File([])), // stdin + ConsoleStdout.lineBuffered((msg) => console.log(`[WASI stdout] ${msg}`)), + ConsoleStdout.lineBuffered((msg) => console.warn(`[WASI stderr] ${msg}`)), +]; +const options = { debug: false }; +const wasi = new WASI(args, env, fds, options); + +const instance_exports = {}; +const { instance } = await WebAssembly.instantiateStreaming(fetch("bin.wasm"), { + wasi_snapshot_preview1: wasi.wasiImport, + ghc_wasm_jsffi: ghc_wasm_jsffi(instance_exports), +}); +Object.assign(instance_exports, instance.exports); + +wasi.initialize(instance); +await instance.exports.hs_start(); diff --git a/run-wasm.sh b/run-wasm.sh new file mode 100755 index 0000000..b574eaf --- /dev/null +++ b/run-wasm.sh @@ -0,0 +1,27 @@ +# TODO move this logic to Shake script, +# and move other files in this dir elsewhere + +set -e + +rm -rf dist/wasm +mkdir dist/wasm + +wasm32-wasi-cabal --builddir=.build/hs/wasm build frontend + +hs_wasm_path=$(wasm32-wasi-cabal --builddir=.build/hs/wasm list-bin -v0 frontend) + +"$(wasm32-wasi-ghc --print-libdir)"/post-link.mjs --input "$hs_wasm_path" --output dist/wasm/ghc_wasm_jsffi.js + +wizer --allow-wasi --wasm-bulk-memory true --init-func _initialize -o dist/wasm/bin.wasm "$hs_wasm_path" + +# TODO make these optional +# wasm-opt -Oz dist/wasm/bin.wasm -o dist/wasm/bin.wasm +# wasm-tools strip -o dist/wasm/bin.wasm dist/wasm/bin.wasm +# brotli --best dist/wasm/bin.wasm -o dist/wasm/bin.wasm.br + +cp html/* dist/wasm/ +cp js/* dist/wasm/ +cp css/* dist/wasm/ + +# TODO remove? +python -m http.server 8002 -d ./dist/wasm