diff --git a/spago.dhall b/spago.dhall index ee78370..a331c25 100644 --- a/spago.dhall +++ b/spago.dhall @@ -17,14 +17,17 @@ to generate this file without the comments in this block. , "effect" , "either" , "exceptions" + , "foldable-traversable" , "integers" , "lists" , "maybe" , "numbers" + , "ordered-collections" , "prelude" , "tuples" , "web-dom" , "web-dom-parser" + , "web-events" , "web-html" ] , packages = ./packages.dhall diff --git a/src/Main.purs b/src/Main.purs index 1a86053..bc91e9e 100644 --- a/src/Main.purs +++ b/src/Main.purs @@ -2,14 +2,21 @@ module Main where import Prelude -import Data.Maybe (Maybe(..)) import Data.Either (Either(..)) +import Data.Int as Int +import Data.Foldable as Foldable +import Data.Map as Map +import Data.Maybe (Maybe(..)) +import Data.Number.Format (toString) +import Data.Tuple as Tup import Effect (Effect) import Effect.Console (log) import Effect.Class (liftEffect) import Effect.Exception (throw) import TernaryGraph (ternaryGraph) import Web.DOM.Document (contentType + , createElement + , Document , getElementsByClassName , importNode , toNode @@ -18,15 +25,102 @@ import Web.DOM.Document (contentType , url ) import Web.DOM.DOMParser (makeDOMParser, parseSVGFromString) -import Web.DOM.Element (toNode) as Element -import Web.DOM.Node (appendChild, nodeName, setTextContent) +import Web.DOM.Element as Element -- (Element, setAttribute, toEventTarget, toNode) as Element +import Web.DOM.Node (appendChild, Node, nodeName, setTextContent) import Web.DOM.NonElementParentNode (getElementById) import Web.DOM.ParentNode (firstElementChild) +import Web.Event.Event (Event, EventType(..)) +import Web.Event.EventTarget (addEventListener, eventListener) import Web.HTML (window) +import Web.HTML.HTMLInputElement as HTMLInput import Web.HTML.HTMLDocument (toDocument) import Web.HTML.Window (document) --- Consider DOM.Simple.Types +myGetElementById :: Document -> String -> Effect Element.Element +myGetElementById doc id = do + elementMay <- getElementById id $ toNonElementParentNode doc + case elementMay of + Nothing -> throw $ "Unable to find element with ID '" <> id <> "'" + Just e -> pure e + +getNodeById :: Document -> String -> Effect Node +getNodeById doc id = do + elementMay <- getElementById id $ toNonElementParentNode doc + case elementMay of + Nothing -> throw $ "Unable to find element with ID '" <> id <> "'" + Just e -> pure $ Element.toNode e + +type Dimension = + { widthPx :: Number + , heightPx :: Number + } + +type TextStyle = + { typeface :: String + , sizePx :: Number + } + +getTextDimensions :: Document -> TextStyle -> String -> Effect Dimension +getTextDimensions doc style text = do + el :: Element.Element <- createElement "span" doc + let styleText = ( + "font" <> style.typeface + <> ";font: " <> style.typeface + <> ";fontSize: " <> (toString style.sizePx) <> "px" + <> ";height: " <> "auto" + <> ";width: " <> "auto" + <> ";position: " <> "absolute" + <> ";whiteSpace: " <> "no-wrap" + ) + + Element.setAttribute "style" styleText el + setTextContent text (Element.toNode el) + width <- Element.clientWidth el + height <- Element.clientHeight el + pure { widthPx: width, heightPx: height } + +converter :: Document -> (Map.Map (Tup.Tuple String TextStyle) Dimension) -> (Tup.Tuple String TextStyle) -> Effect (Map.Map (Tup.Tuple String TextStyle) Dimension) +converter doc map textTuple = do + let text = Tup.fst textTuple + let style = Tup.snd textTuple + dimension <- getTextDimensions doc style text + pure $ Map.insert textTuple dimension map + +getAllTextDimensions :: forall f. Foldable.Foldable f => Document -> f (Tup.Tuple String TextStyle) -> Effect (Map.Map (Tup.Tuple String TextStyle) Dimension) +getAllTextDimensions doc strings = + Foldable.foldM (converter doc) Map.empty strings + +update :: Event -> Effect Unit +update e = do + w <- window + d <- document w + let document = toDocument d + domParser <- makeDOMParser + + log "update" + inputElement <- myGetElementById document "ticks" + inputHTMLElement <- case HTMLInput.fromElement inputElement of + Nothing -> throw "'ticks' element is not an input tag" + Just e -> pure e + ticks <- (liftM1 Int.round) $ HTMLInput.valueAsNumber inputHTMLElement + + svgContainer <- getNodeById document "svg-container" + + let mySVG = ternaryGraph 100.0 50.0 50.0 ticks + svgDocMay <- parseSVGFromString mySVG domParser + svgDoc <- case svgDocMay of + Left error -> throw error + Right doc -> pure doc + + elMay <- firstElementChild $ toParentNode svgDoc + svgNode <- case elMay of + Nothing -> throw "no child in svg doc" + Just el -> pure $ Element.toNode el + + -- TODO: remove existing node? + + newNode <- importNode svgNode true document + appendChild newNode svgContainer main :: Effect Unit main = do @@ -35,11 +129,7 @@ main = do let dd = toDocument d domParser <- makeDOMParser - let containerID = "svg-container" - maybeElement <- getElementById containerID $ toNonElementParentNode dd - node <- case maybeElement of - Nothing -> throw $ "Unable to find " <> containerID - Just e -> pure $ Element.toNode e + svgContainer <- getNodeById dd "svg-container" let mySVG = ternaryGraph 100.0 50.0 50.0 10 svgDocMay <- parseSVGFromString mySVG domParser @@ -53,4 +143,14 @@ main = do Just el -> pure $ Element.toNode el newNode <- importNode svgNode true dd - appendChild newNode node + appendChild newNode svgContainer + + listener <- eventListener update + + inputElement <- myGetElementById dd "ticks" + addEventListener (EventType "input") listener true (Element.toEventTarget inputElement) + log "20250727T183907" + --inputMay <- getElementById "ticks" $ toNonElementParentNode dd + --inputNode <- case inputMay of + --Nothing -> throw $ "Unable to find " <> containerID + --Just e -> pure $ Element.toNode e \ No newline at end of file