├── .gitignore ├── .gitmodules ├── License.txt ├── README.md ├── docs ├── CNAME ├── PSD3-logo.png ├── bundle.css ├── bundle.js ├── code-examples │ ├── 3LC-xFromIndex │ ├── GUP │ ├── GUPHandleActions │ ├── LesMisAccessors │ ├── LesMisHandleActions │ ├── LesMisScript │ ├── MetaTreeDraw │ ├── MetaTreeEvaluator │ ├── MetaTreeHandleActions │ ├── PrintTreeHandleActions │ ├── TLCDatum_ │ ├── TLCParabola │ ├── TLCSimple │ └── TreeDraw ├── d3 │ ├── d3-color.js │ ├── d3-interpolate.js │ ├── d3-scale-chromatic.js │ └── d3.js ├── data │ ├── flare-2.json │ ├── miserables.json │ ├── spago-data │ │ ├── LOC.json │ │ ├── lsdeps.jsonlines │ │ ├── modules.json │ │ └── packages.json │ └── spago-small │ │ ├── LOC.json │ │ ├── lsdeps.jsonlines │ │ ├── modules.json │ │ └── packages.json ├── index-no-cdn.html ├── index.css ├── index.html ├── prism.css └── prism.js ├── notes ├── PSmapD3.org ├── long-form-notes.html ├── long-form-notes.md ├── long-form-notes.pdf ├── resources.md └── spago-schemas ├── package-lock.json ├── package.json ├── packages.dhall ├── spago.dhall ├── src ├── DemoApp │ ├── Blocks │ │ ├── Button.purs │ │ ├── Card.purs │ │ ├── Expandable.purs │ │ ├── FormField.purs │ │ └── Toggle.purs │ ├── Main.purs │ ├── Ocelot │ │ ├── Blocks │ │ │ ├── Builder.purs │ │ │ ├── Button.purs │ │ │ ├── Checkbox.purs │ │ │ ├── FormField.purs │ │ │ ├── Format.purs │ │ │ ├── Icon.purs │ │ │ ├── Radio.purs │ │ │ └── Table.purs │ │ ├── HTML │ │ │ └── Properties.purs │ │ └── ui-guide │ │ │ └── Backdrop.purs │ ├── Snippets.purs │ ├── Stories │ │ ├── GUP.purs │ │ ├── Index.purs │ │ ├── LesMis.purs │ │ ├── MetaTree.purs │ │ ├── PrintTree.purs │ │ ├── Spago │ │ │ ├── Actions.purs │ │ │ ├── Forces.purs │ │ │ ├── HTML.purs │ │ │ ├── Lenses.purs │ │ │ ├── Spago.purs │ │ │ └── State.purs │ │ ├── ThreeLittleCircles.purs │ │ ├── Trees.purs │ │ ├── Types.purs │ │ ├── Utilities.js │ │ └── Utilities.purs │ ├── Viz │ │ ├── GUP.purs │ │ ├── LesMis │ │ │ ├── File.js │ │ │ ├── File.purs │ │ │ ├── LesMiserables.purs │ │ │ ├── Model.purs │ │ │ └── Unsafe.purs │ │ ├── MetaTree │ │ │ ├── MetaTree.purs │ │ │ ├── Model.purs │ │ │ └── Unsafe.purs │ │ ├── Spago │ │ │ ├── Attributes.purs │ │ │ ├── Draw.purs │ │ │ ├── Files.js │ │ │ ├── Files.purs │ │ │ ├── Model.js │ │ │ ├── Model.purs │ │ │ ├── Tree.purs │ │ │ └── Unsafe.purs │ │ ├── ThreeLittleCircles.purs │ │ └── Tree │ │ │ ├── Draw.purs │ │ │ ├── Model.purs │ │ │ ├── TreeConfigure.purs │ │ │ └── Unsafe.purs │ └── css │ │ ├── package.json │ │ ├── postcss.config.js │ │ ├── src │ │ ├── composite-rules.css │ │ ├── examples │ │ │ ├── GUP.css │ │ │ ├── common.css │ │ │ ├── spago-cluster.css │ │ │ ├── spago-graph.css │ │ │ ├── spago-initial.css │ │ │ └── spago-tree.css │ │ ├── fonts.css │ │ ├── icons.css │ │ ├── index.css │ │ ├── ocelot-1.css │ │ └── ocelot-2.css │ │ └── tailwind.config.js ├── lib │ ├── D3 │ │ ├── Attributes │ │ │ ├── Instances.purs │ │ │ └── Sugar.purs │ │ ├── Data │ │ │ ├── Graph.purs │ │ │ ├── Node.purs │ │ │ ├── Tree.js │ │ │ ├── Tree.purs │ │ │ ├── Types.purs │ │ │ └── Utility.purs │ │ ├── FFI │ │ │ ├── FFI.js │ │ │ └── FFI.purs │ │ ├── Layouts │ │ │ ├── Hierarchical │ │ │ │ ├── Hierarchical.js │ │ │ │ └── Hierarchical.purs │ │ │ └── Simulation │ │ │ │ ├── Config.purs │ │ │ │ ├── Forces.purs │ │ │ │ ├── Functions.purs │ │ │ │ └── Types.purs │ │ ├── Scales │ │ │ ├── Scales.js │ │ │ └── Scales.purs │ │ └── Selection │ │ │ ├── Functions.purs │ │ │ ├── Selection.purs │ │ │ └── Zoom.purs │ ├── Data │ │ └── Tree.purs │ └── Interpreters │ │ ├── Capabilities.purs │ │ ├── D3 │ │ ├── Selection.purs │ │ ├── Simulation.purs │ │ └── Utility.purs │ │ ├── MetaTree │ │ ├── Meta.js │ │ └── Meta.purs │ │ └── String │ │ ├── String.js │ │ └── String.purs └── scripts │ ├── snippets3.pl │ └── tiny.pl ├── test └── Main.purs └── yarn.lock /.gitignore: -------------------------------------------------------------------------------- 1 | /bower_components/ 2 | /node_modules/ 3 | /.pulp-cache/ 4 | /output/ 5 | /generated-docs/ 6 | /.psc-package/ 7 | /.psc* 8 | /.purs* 9 | /.psa* 10 | /.spago 11 | /dist/bundle.js 12 | /.vscode/settings.json 13 | /dist/PSD3-logo.psd 14 | /dist/PSD3-logo-2.psd 15 | /dist/PSD3-logo-3.psd 16 | /src/css/node_modules 17 | /src/css/yarn.lock 18 | .DS_Store 19 | /docs/foo.db3 20 | *.psd 21 | /dist/PSD3-logo-4.psd 22 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/afcondon/purescript-d3-tagless-II/70942aa8ed59dac0bd4ab54351c87a82e0b53c6a/.gitmodules -------------------------------------------------------------------------------- /License.txt: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2022 Andrew Condon 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /docs/CNAME: -------------------------------------------------------------------------------- 1 | tagless-d3.purescri.pt 2 | -------------------------------------------------------------------------------- /docs/PSD3-logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/afcondon/purescript-d3-tagless-II/70942aa8ed59dac0bd4ab54351c87a82e0b53c6a/docs/PSD3-logo.png -------------------------------------------------------------------------------- /docs/code-examples/3LC-xFromIndex: -------------------------------------------------------------------------------- 1 | -- | simple utility function used in all three of these examples 2 | xFromIndex :: Datum_ -> Index_ -> Number 3 | xFromIndex _ i = ((indexIsNumber i) * 100.0) 4 | where 5 | indexIsNumber :: Index_ -> Number 6 | indexIsNumber = unsafeCoerce 7 | -------------------------------------------------------------------------------- /docs/code-examples/GUP: -------------------------------------------------------------------------------- 1 | type Model = Array Char 2 | 3 | -- in the interests of brevity these unsafe functions are defined here with the "script" 4 | -- however, in a larger program both Model and Unsafe would be their own modules 5 | datumIsChar :: Datum_ -> Char 6 | datumIsChar = unsafeCoerce 7 | 8 | indexIsNumber :: Index_ -> Number 9 | indexIsNumber = unsafeCoerce 10 | 11 | keyFunction :: Datum_ -> Index_ -- for this very simple example, the data (Char) can be used directly as the key 12 | keyFunction = unsafeCoerce 13 | 14 | exGeneralUpdatePattern :: forall m. SelectionM D3Selection_ m => Selector D3Selection_-> m ((Array Char) -> m D3Selection_) 15 | exGeneralUpdatePattern selector = do 16 | root <- attach selector 17 | svg <- appendTo root Svg [ viewBox 0.0 0.0 650.0 650.0, classed "d3svg gup" ] 18 | letterGroup <- appendTo svg Group [] 19 | 20 | pure $ \letters -> do 21 | enterSelection <- openSelection letterGroup "text" 22 | updateSelections <- updateJoin enterSelection Text letters keyFunction 23 | setAttributes updateSelections.exit exit 24 | setAttributes updateSelections.update update 25 | 26 | newlyEntered <- appendTo updateSelections.enter Text [] 27 | setAttributes newlyEntered enter 28 | 29 | pure newlyEntered 30 | 31 | where 32 | transition :: SelectionAttribute 33 | transition = transitionWithDuration $ Milliseconds 2000.0 34 | 35 | xFromIndex :: Datum_ -> Index_ -> Number 36 | xFromIndex _ i = 50.0 + ((indexIsNumber i) * 48.0) -- letters enter at this position, and then must transition to new position on each update 37 | 38 | enter = [ classed "enter" 39 | , fill "green" 40 | , x xFromIndex 41 | , y 0.0 42 | , text (singleton <<< datumIsChar) 43 | , fontSize 96.0 ] 44 | `andThen` (transition `to` [ y 200.0 ]) 45 | 46 | update = [ classed "update", fill "gray", y 200.0 ] 47 | `andThen` (transition `to` [ x xFromIndex ] ) 48 | 49 | exit = [ classed "exit", fill "brown"] 50 | `andThen` (transition `to` [ y 400.0, remove ]) 51 | -------------------------------------------------------------------------------- /docs/code-examples/GUPHandleActions: -------------------------------------------------------------------------------- 1 | handleAction :: forall m. Bind m => MonadAff m => MonadState State m => 2 | Action -> m Unit 3 | handleAction = case _ of 4 | ToggleCard _cardState -> _cardState %= not 5 | 6 | Initialize -> do 7 | text1 <- H.liftAff $ readSnippetFiles "GUP" 8 | _drawCode .= text1 9 | text2 <- H.liftAff $ readSnippetFiles "GUPHandleActions" 10 | _handlerCode .= text2 11 | 12 | updateFn <- runGeneralUpdatePattern 13 | 14 | fiber <- H.liftAff $ forkAff $ forever $ runUpdate updateFn 15 | 16 | H.modify_ (\state -> state { status = Running, fiber = Just fiber, update = Just updateFn }) 17 | 18 | SetStatus status -> H.modify_ (\state -> state { status = status }) 19 | ToggleStatus -> do 20 | currentStatus <- H.gets _.status 21 | case currentStatus of 22 | Running -> pauseUpdating 23 | _ -> startUpdating 24 | 25 | Finalize -> do 26 | maybeFiber <- H.gets _.fiber 27 | _ <- case maybeFiber of 28 | Nothing -> pure unit 29 | (Just fiber) -> H.liftAff $ killFiber (error "Cancelling fiber and terminating computation") fiber 30 | -- is it necessary to remove the component from the DOM? don't think it is 31 | H.modify_ (\state -> state { status = Paused, fiber = Nothing, update = Nothing }) 32 | -------------------------------------------------------------------------------- /docs/code-examples/LesMisAccessors: -------------------------------------------------------------------------------- 1 | link_ = { 2 | source: _.source <<< unboxD3SimLink 3 | , target: _.target <<< unboxD3SimLink 4 | , value: _.value <<< unboxD3SimLink 5 | , color: d3SchemeCategory10N_ <<< toNumber <<< _.target.group <<< unboxD3SimLink 6 | } 7 | 8 | datum_ = { 9 | -- direct accessors to fields of the datum (BOILERPLATE) 10 | id : _.id <<< unboxD3SimNode -- NB the id in this case is a String 11 | , x : _.x <<< unboxD3SimNode 12 | , y : _.y <<< unboxD3SimNode 13 | , group : _.group <<< unboxD3SimNode 14 | 15 | , colorByGroup: d3SchemeCategory10N_ <<< toNumber <<< _.group <<< unboxD3SimNode 16 | } 17 | -------------------------------------------------------------------------------- /docs/code-examples/LesMisHandleActions: -------------------------------------------------------------------------------- 1 | handleAction :: forall m. 2 | Bind m => 3 | MonadAff m => 4 | MonadState State m => 5 | Action -> m Unit 6 | handleAction = case _ of 7 | 8 | ToggleCard _cardState -> _cardState %= not 9 | 10 | Initialize -> do 11 | notebook' <- traverse substituteSnippetCells lesMisNotebook 12 | _notebook .= notebook' 13 | 14 | response <- H.liftAff $ AJAX.get ResponseFormat.string "./data/miserables.json" 15 | let graph = readGraphFromFileContents response 16 | 17 | (_forceStatuses <<< _forceStatus forceNames.center) %= (const ForceActive) 18 | (_forceStatuses <<< _forceStatus forceNames.manyBodyNeg) %= (const ForceActive) 19 | (_forceStatuses <<< _forceStatus forceNames.collision) %= (const ForceActive) 20 | (_forceStatuses <<< _forceStatus forceNames.links) %= (const ForceActive) 21 | 22 | (_forceStatuses <<< _forceStatus forceNames.manyBodyPos) %= (const ForceDisabled) 23 | 24 | runWithD3_Simulation do 25 | statuses <- use _forceStatuses 26 | actualizeForces statuses 27 | LesMis.draw graph "div.svg-container" 28 | 29 | Finalize -> pure unit 30 | 31 | ToggleForce name -> do 32 | toggleForceByName name 33 | runWithD3_Simulation do 34 | statuses <- use _forceStatuses 35 | actualizeForces statuses 36 | setConfigVariable $ Alpha 0.7 37 | start 38 | 39 | Freeze -> runWithD3_Simulation $ setConfigVariable $ Alpha 0.0 40 | Reheat -> do 41 | runWithD3_Simulation do 42 | setConfigVariable $ Alpha 0.7 43 | start 44 | -------------------------------------------------------------------------------- /docs/code-examples/LesMisScript: -------------------------------------------------------------------------------- 1 | -- | recipe for this force layout graph 2 | draw :: forall row m. 3 | Bind m => 4 | MonadEffect m => 5 | MonadState { simulation :: D3SimulationState_ | row } m => 6 | SimulationM D3Selection_ m => 7 | LesMisRawModel -> Selector D3Selection_ -> m Unit 8 | draw model selector = do 9 | (Tuple w h) <- liftEffect getWindowWidthHeight 10 | (root :: D3Selection_) <- attach selector 11 | svg <- appendTo root Svg [ viewBox (-w / 2.0) (-h / 2.0) w h, classed "lesmis" ] 12 | linksGroup <- appendTo svg Group [ classed "link", strokeColor "#999", strokeOpacity 0.6 ] 13 | nodesGroup <- appendTo svg Group [ classed "node", strokeColor "#fff", strokeOpacity 1.5 ] 14 | 15 | -- in contrast to a simple SelectionM function, we have additional typeclass capabilities for simulation 16 | -- which we use here to introduce the nodes and links to the simulation 17 | nodesInSim <- setNodes model.nodes -- no staging here, we just load the nodes straight into Sim 18 | linksInSim <- setLinks model.links model.nodes keyIsID_ 19 | 20 | -- joining the data from the model after it has been put into the simulation 21 | nodesSelection <- simpleJoin nodesGroup Circle nodesInSim keyIsID_ 22 | setAttributes nodesSelection [ radius 5.0, fill datum_.colorByGroup ] 23 | linksSelection <- simpleJoin linksGroup Line linksInSim keyIsID_ 24 | setAttributes linksSelection [ strokeWidth (sqrt <<< link_.value), strokeColor link_.color ] 25 | 26 | -- both links and nodes are updated on each step of the simulation, 27 | -- in this case it's a simple translation of underlying (x,y) data for the circle centers 28 | -- tick functions have names, in this case "nodes" and "links" 29 | addTickFunction "nodes" $ Step nodesSelection [ cx datum_.x, cy datum_.y ] 30 | addTickFunction "links" $ Step linksSelection [ x1 (_.x <<< link_.source) 31 | , y1 (_.y <<< link_.source) 32 | , x2 (_.x <<< link_.target) 33 | , y2 (_.y <<< link_.target) 34 | ] 35 | -- use default drag function (simply drags the element that's clicked on) 36 | _ <- nodesSelection `on` Drag (CustomDrag "lesmis" simdrag) 37 | -- TODO create inner and apply the zoom functionality to it 38 | _ <- svg `on` Zoom { extent : ZoomExtent { top: 0.0, left: 0.0 , bottom: h, right: w } 39 | , scale : ScaleExtent 1.0 4.0 -- wonder if ScaleExtent ctor could be range operator `..` 40 | , name : "LesMis" 41 | , target : svg 42 | } 43 | setConfigVariable $ Alpha 1.0 44 | pure unit 45 | -------------------------------------------------------------------------------- /docs/code-examples/MetaTreeDraw: -------------------------------------------------------------------------------- 1 | -- | "script" to produce the documentation-ready rendering of another script's structure 2 | -- | (could also be the basis for graphical editor of scripts / trees) 3 | draw :: forall m selection. Bind m => SelectionM selection m => 4 | Tuple Number Number -> MetaTreeNode -> m selection 5 | draw (Tuple w h) tree = do 6 | let 7 | -- configure dimensions 8 | numberOfLevels = (hNodeHeight_ tree) + 1.0 9 | spacing = { interChild: (w/5.0), interLevel: h / numberOfLevels} 10 | layoutFn = (getLayout TidyTree) `treeSetNodeSize_` [ spacing.interChild, spacing.interLevel ] 11 | laidOutRoot_ = layoutFn `runLayoutFn_` tree 12 | { xMin, xMax, yMin, yMax } = treeMinMax_ laidOutRoot_ 13 | xExtent = abs $ xMax - xMin -- ie if tree spans from -50 to 200, it's extent is 250 14 | yExtent = abs $ yMax - yMin -- ie if tree spans from -50 to 200, it's extent is 250 15 | vtreeYOffset = (abs (h - yExtent)) / 2.0 16 | vtreeXOffset = pad xMin -- the left and right sides might be different so (xExtent / 2) would not necessarily be right 17 | pad n = n * 1.2 18 | 19 | 20 | -- "script" 21 | root <- attach ".svg-container" 22 | svg <- appendTo root Svg [ viewBox vtreeXOffset (-vtreeYOffset) (pad xExtent) (pad yExtent) 23 | , preserveAspectRatio $ AspectRatio XMin YMid Meet 24 | , width w 25 | , height h 26 | , classed "metatree" ] 27 | container <- appendTo svg Group [ fontFamily "sans-serif" 28 | , fontSize 18.0 29 | ] 30 | links <- appendTo container Group [ classed "links"] 31 | nodes <- appendTo container Group [ classed "nodes"] 32 | 33 | theLinks_ <- simpleJoin links Path (links_ tree) keyIsID_ 34 | setAttributes theLinks_ 35 | [ strokeWidth 1.5, strokeColor "black", strokeOpacity 0.4, fill "none", verticalLink] 36 | 37 | nodeJoin_ <- simpleJoin nodes Group (descendants_ tree) keyIsID_ 38 | setAttributes nodeJoin_ [ transform [ datum_.positionXY ] ] 39 | 40 | 41 | theNodes <- appendTo nodeJoin_ 42 | Circle [ fill "blue" 43 | , radius 20.0 44 | , strokeColor "white" 45 | , strokeWidth 3.0 46 | ] 47 | 48 | labelsWhite <- appendTo nodeJoin_ 49 | Text [ x 0.0 50 | , y 3.0 51 | , textAnchor "middle" 52 | , text datum_.symbol 53 | , fill "white" 54 | ] 55 | 56 | labelsGray <- appendTo nodeJoin_ 57 | Text [ x 22.0 58 | , y 3.0 59 | , textAnchor "start" 60 | , text datum_.param1 61 | , fill "gray" 62 | ] 63 | 64 | pure svg 65 | -------------------------------------------------------------------------------- /docs/code-examples/MetaTreeEvaluator: -------------------------------------------------------------------------------- 1 | -- | evaluate a tree first using the "metatree" interpreter, then draw the RESULTING (syntax) tree using D3 interpreter 2 | drawMetaTree :: TreeJson_ -> Aff Unit 3 | drawMetaTree json = 4 | MetaTree.drawTree =<< makeModel TidyTree Vertical =<< Tree.getMetaTreeJSON =<< makeModel TidyTree Radial json 5 | -------------------------------------------------------------------------------- /docs/code-examples/MetaTreeHandleActions: -------------------------------------------------------------------------------- 1 | handleAction :: forall m. Bind m => MonadAff m => MonadState State m => 2 | Action -> m Unit 3 | handleAction = case _ of 4 | ToggleCard _cardState -> _cardState %= not 5 | 6 | Initialize -> do 7 | text <- H.liftAff $ readSnippetFiles "MetaTreeDraw" 8 | _drawCode .= text 9 | text <- H.liftAff $ readSnippetFiles "MetaTreeEvaluator" 10 | _evaluatorCode .= text 11 | text <- H.liftAff $ readSnippetFiles "MetaTreeHandleActions" 12 | _handlerCode .= text 13 | detached <- H.liftEffect $ eval_D3M $ removeExistingSVG "div.d3story" 14 | 15 | treeJSON <- H.liftAff $ getTreeViaAJAX "./data/flare-2.json" 16 | 17 | case treeJSON of 18 | (E.Left err) -> pure unit 19 | (E.Right (tree :: TreeJson_)) -> do 20 | _ <- H.liftAff $ drawMetaTree tree 21 | pure unit 22 | pure unit 23 | -------------------------------------------------------------------------------- /docs/code-examples/PrintTreeHandleActions: -------------------------------------------------------------------------------- 1 | handleAction :: forall m. Bind m => MonadAff m => MonadState State m => 2 | Action -> m Unit 3 | handleAction = case _ of 4 | ToggleCard _cardState -> _cardState %= not 5 | 6 | Initialize -> do 7 | detached <- H.liftEffect $ eval_D3M $ removeExistingSVG "div.svg-container" 8 | 9 | text <- H.liftAff $ readSnippetFiles "PrintTreeHandleActions" 10 | _handlerCode .= text 11 | 12 | treeJSON <- H.liftAff $ getTreeViaAJAX "./data/flare-2.json" 13 | 14 | case treeJSON of 15 | (E.Left err) -> pure unit 16 | (E.Right (tree :: TreeJson_)) -> do 17 | textRep <- H.liftAff $ Tree.getPrintTree =<< makeModel TidyTree Radial tree 18 | H.modify_ (\st -> st { tree = textRep } ) 19 | pure unit 20 | pure unit 21 | -------------------------------------------------------------------------------- /docs/code-examples/TLCDatum_: -------------------------------------------------------------------------------- 1 | type Model = Array Int -- not strictly necessary in such a simple example, of course 2 | 3 | datum_ :: -- a record containing all the accessor functions needed for attributes 4 | { color :: Datum_ -> String 5 | , x :: Datum_ -> Index_ -> Number 6 | , y :: Datum_ -> Number 7 | } 8 | datum_ = 9 | let 10 | -- we bury the unsafe functions inside the datum_ record, unsafeCoerce yes, but very restricted how it can be used 11 | getDatum :: Datum_ -> Int 12 | getDatum = unsafeCoerce 13 | getIndex :: Index_ -> Int 14 | getIndex = unsafeCoerce 15 | in { 16 | x : \_ i -> (toNumber $ getIndex i) * 20.0 17 | , y : \d -> 100.0 - (toNumber $ getDatum d) / 5.0 18 | , color : \d -> d3SchemePairedN_ ((toNumber $ getDatum d) / 100.0) 19 | } 20 | -------------------------------------------------------------------------------- /docs/code-examples/TLCParabola: -------------------------------------------------------------------------------- 1 | drawWithData :: forall m. SelectionM D3Selection_ m => Model -> Selector D3Selection_-> m D3Selection_ 2 | drawWithData circleData selector = do 3 | 4 | let circleAttributes = [ 5 | strokeColor datum_.color 6 | , strokeWidth 3.0 7 | , fill "none" 8 | , cx datum_.x 9 | , cy datum_.y 10 | , radius 10.0 ] 11 | 12 | root <- attach selector 13 | svg <- appendTo root Svg [ viewBox (-100.0) (-100.0) 650.0 650.0, classed "d3svg gup" ] 14 | circleGroup <- appendTo svg Group [] 15 | 16 | circles <- simpleJoin circleGroup Circle circleData keyIsID_ 17 | setAttributes circles circleAttributes 18 | 19 | pure circles 20 | -------------------------------------------------------------------------------- /docs/code-examples/TLCSimple: -------------------------------------------------------------------------------- 1 | -- | Pretty much the most basic example imaginable, three ints represented by three circles 2 | drawThreeCircles :: forall m. SelectionM D3Selection_ m => Selector D3Selection_-> m D3Selection_ 3 | drawThreeCircles selector = do 4 | 5 | let circleAttributes = [ fill "green", cx xFromIndex, cy 50.0, radius 20.0 ] 6 | 7 | root <- attach selector 8 | svg <- appendTo root Svg [ viewBox (-100.0) (-100.0) 650.0 650.0, classed "d3svg gup" ] 9 | circleGroup <- appendTo svg Group [] 10 | circles <- simpleJoin circleGroup Circle [32, 57, 293] keyIsID_ 11 | setAttributes circles circleAttributes 12 | 13 | pure circles 14 | -------------------------------------------------------------------------------- /docs/code-examples/TreeDraw: -------------------------------------------------------------------------------- 1 | draw :: forall m selection. Bind m => SelectionM selection m => 2 | ScriptConfig -> FlareTreeNode -> m selection 3 | draw config tree = do 4 | root <- attach config.selector 5 | svg <- appendTo root Svg (config.viewbox <> 6 | [ classed "tree", width config.svg.width, height config.svg.height ]) 7 | container <- appendTo svg Group [ fontFamily "sans-serif", fontSize 10.0 ] 8 | links <- appendTo container Group [ classed "links"] 9 | nodes <- appendTo container Group [ classed "nodes"] 10 | 11 | theLinks_ <- simpleJoin links Path (links_ tree) keyIsID_ 12 | setAttributes theLinks_ [ strokeWidth 1.5, strokeColor config.color, strokeOpacity 0.4, fill "none", config.linkPath ] 13 | 14 | -- we make a group to hold the node circle and the label text 15 | nodeJoin_ <- simpleJoin nodes Group (descendants_ tree) keyIsID_ 16 | setAttributes nodeJoin_ config.nodeTransform 17 | 18 | theNodes <- appendTo nodeJoin_ Circle 19 | [ fill (\(d :: Datum_) -> if treeDatum_.hasChildren d then "#999" else "#555") 20 | , radius 2.5 21 | , strokeColor "white" 22 | ] 23 | 24 | theLabels <- appendTo nodeJoin_ Text 25 | [ dy 0.31 26 | , x (treeDatum_.textX config.layout) 27 | , textAnchor (treeDatum_.textAnchor config.layout) 28 | , text treeDatum_.name 29 | , fill config.color 30 | ] 31 | pure svg 32 | -------------------------------------------------------------------------------- /docs/data/spago-data/lsdeps.jsonlines: -------------------------------------------------------------------------------- 1 | {"packageName":"aff","version":"v6.0.0","repo":{"tag":"Remote","contents":"https://github.com/purescript-contrib/purescript-aff.git"}} 2 | {"packageName":"affjax","version":"v12.0.0","repo":{"tag":"Remote","contents":"https://github.com/purescript-contrib/purescript-affjax.git"}} 3 | {"packageName":"arrays","version":"v6.0.0","repo":{"tag":"Remote","contents":"https://github.com/purescript/purescript-arrays.git"}} 4 | {"packageName":"bifunctors","version":"v5.0.0","repo":{"tag":"Remote","contents":"https://github.com/purescript/purescript-bifunctors.git"}} 5 | {"packageName":"console","version":"v5.0.0","repo":{"tag":"Remote","contents":"https://github.com/purescript/purescript-console.git"}} 6 | {"packageName":"datetime","version":"v5.0.0","repo":{"tag":"Remote","contents":"https://github.com/purescript/purescript-datetime.git"}} 7 | {"packageName":"debug","version":"v5.0.0","repo":{"tag":"Remote","contents":"https://github.com/garyb/purescript-debug.git"}} 8 | {"packageName":"effect","version":"v3.0.0","repo":{"tag":"Remote","contents":"https://github.com/purescript/purescript-effect.git"}} 9 | {"packageName":"either","version":"v5.0.0","repo":{"tag":"Remote","contents":"https://github.com/purescript/purescript-either.git"}} 10 | {"packageName":"foldable-traversable","version":"v5.0.0","repo":{"tag":"Remote","contents":"https://github.com/purescript/purescript-foldable-traversable.git"}} 11 | {"packageName":"functions","version":"v5.0.0","repo":{"tag":"Remote","contents":"https://github.com/purescript/purescript-functions.git"}} 12 | {"packageName":"graphs","version":"c4a3189e39579102b8be3cff9bcde63a9d4ef322","repo":{"tag":"Remote","contents":"https://github.com/colehaus/purescript-graphs.git"}} 13 | {"packageName":"integers","version":"v5.0.0","repo":{"tag":"Remote","contents":"https://github.com/purescript/purescript-integers.git"}} 14 | {"packageName":"lists","version":"v6.0.0","repo":{"tag":"Remote","contents":"https://github.com/purescript/purescript-lists.git"}} 15 | {"packageName":"math","version":"v3.0.0","repo":{"tag":"Remote","contents":"https://github.com/purescript/purescript-math.git"}} 16 | {"packageName":"maybe","version":"v5.0.0","repo":{"tag":"Remote","contents":"https://github.com/purescript/purescript-maybe.git"}} 17 | {"packageName":"nullable","version":"v5.0.0","repo":{"tag":"Remote","contents":"https://github.com/purescript-contrib/purescript-nullable.git"}} 18 | {"packageName":"numbers","version":"v8.0.0","repo":{"tag":"Remote","contents":"https://github.com/purescript/purescript-numbers.git"}} 19 | {"packageName":"ordered-collections","version":"v2.0.0","repo":{"tag":"Remote","contents":"https://github.com/purescript/purescript-ordered-collections.git"}} 20 | {"packageName":"prelude","version":"v5.0.0","repo":{"tag":"Remote","contents":"https://github.com/purescript/purescript-prelude.git"}} 21 | {"packageName":"psci-support","version":"v5.0.0","repo":{"tag":"Remote","contents":"https://github.com/purescript/purescript-psci-support.git"}} 22 | {"packageName":"random","version":"v5.0.0","repo":{"tag":"Remote","contents":"https://github.com/purescript/purescript-random.git"}} 23 | {"packageName":"strings","version":"v5.0.0","repo":{"tag":"Remote","contents":"https://github.com/purescript/purescript-strings.git"}} 24 | {"packageName":"tailrec","version":"v5.0.0","repo":{"tag":"Remote","contents":"https://github.com/purescript/purescript-tailrec.git"}} 25 | {"packageName":"transformers","version":"v5.0.0","repo":{"tag":"Remote","contents":"https://github.com/purescript/purescript-transformers.git"}} 26 | {"packageName":"tuples","version":"v6.0.0","repo":{"tag":"Remote","contents":"https://github.com/purescript/purescript-tuples.git"}} 27 | {"packageName":"unsafe-coerce","version":"v5.0.0","repo":{"tag":"Remote","contents":"https://github.com/purescript/purescript-unsafe-coerce.git"}} 28 | {"packageName":"web-events","version":"v3.0.0","repo":{"tag":"Remote","contents":"https://github.com/purescript-web/purescript-web-events.git"}} 29 | {"packageName":"web-html","version":"v3.0.1","repo":{"tag":"Remote","contents":"https://github.com/purescript-web/purescript-web-html.git"}} 30 | -------------------------------------------------------------------------------- /docs/data/spago-small/LOC.json: -------------------------------------------------------------------------------- 1 | { 2 | "loc": [ 3 | { 4 | "loc": 501, 5 | "path": "src/Main.purs" 6 | }, 7 | { 8 | "loc": 406, 9 | "path": ".spago/p1/A.purs" 10 | }, 11 | { 12 | "loc": 800, 13 | "path": ".spago/p1/B.purs" 14 | }, 15 | { 16 | "loc": 1901, 17 | "path": ".spago/p2/C.purs" 18 | }, 19 | { 20 | "loc": 600, 21 | "path": ".spago/p3/D.purs" 22 | } 23 | ] 24 | } -------------------------------------------------------------------------------- /docs/data/spago-small/lsdeps.jsonlines: -------------------------------------------------------------------------------- 1 | {"packageName":"p1","version":"v6.0.0","repo":{"tag":"Remote","contents":"https://github.com/purescript-contrib/purescript-aff.git"}} 2 | {"packageName":"p2","version":"v12.0.0","repo":{"tag":"Remote","contents":"https://github.com/purescript-contrib/purescript-affjax.git"}} 3 | {"packageName":"p3","version":"v6.0.0","repo":{"tag":"Remote","contents":"https://github.com/purescript/purescript-arrays.git"}} 4 | {"packageName":"p4","version":"v5.0.0","repo":{"tag":"Remote","contents":"https://github.com/purescript/purescript-bifunctors.git"}} 5 | -------------------------------------------------------------------------------- /docs/data/spago-small/modules.json: -------------------------------------------------------------------------------- 1 | { 2 | "Main": { 3 | "path": "src/Main.purs", 4 | "depends": [ "A", "B" ] 5 | }, 6 | "A": { 7 | "path": ".spago/p1/A.purs", 8 | "depends": [ "C" ] 9 | }, 10 | "B": { 11 | "path": ".spago/p1/B.purs", 12 | "depends": [ "C" ] 13 | }, 14 | "C": { 15 | "path": ".spago/p2/C.purs", 16 | "depends": [ "D" ] 17 | }, 18 | "D": { 19 | "path": ".spago/p3/D.purs", 20 | "depends": [ ] 21 | } 22 | } 23 | -------------------------------------------------------------------------------- /docs/data/spago-small/packages.json: -------------------------------------------------------------------------------- 1 | { 2 | "p1": { 3 | "depends": [ "p2" ] 4 | }, 5 | "p2": { 6 | "depends": [ "p3" ] 7 | }, 8 | "p3": { 9 | "depends": [] 10 | }, 11 | "src": { 12 | "depends": [ "p1", "p2", "p3" ] 13 | } 14 | } 15 | -------------------------------------------------------------------------------- /docs/index-no-cdn.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | Document 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | -------------------------------------------------------------------------------- /docs/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | Document 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | -------------------------------------------------------------------------------- /docs/prism.css: -------------------------------------------------------------------------------- 1 | /* 2 | 3 | Name: Base16 Atelier Forest Light 4 | Author: Bram de Haan (http://atelierbram.github.io/syntax-highlighting/atelier-schemes/forest) 5 | 6 | Prism template by Bram de Haan (http://atelierbram.github.io/syntax-highlighting/prism/) 7 | Original Base16 color scheme by Chris Kempson (https://github.com/chriskempson/base16) 8 | 9 | */ 10 | code[class*="language-"], 11 | pre[class*="language-"] { 12 | font-family: Consolas, Menlo, Monaco, "Andale Mono WT", "Andale Mono", "Lucida Console", "Lucida Sans Typewriter", "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Liberation Mono", "Nimbus Mono L", "Courier New", Courier, monospace; 13 | font-size: 14px; 14 | line-height: 1.375; 15 | direction: ltr; 16 | text-align: left; 17 | white-space: pre; 18 | word-spacing: normal; 19 | word-break: normal; 20 | -moz-tab-size: 4; 21 | -o-tab-size: 4; 22 | tab-size: 4; 23 | -webkit-hyphens: none; 24 | -ms-hyphens: none; 25 | hyphens: none; 26 | background: #f1efee; 27 | color: #68615e; 28 | } 29 | 30 | pre[class*="language-"]::-moz-selection, pre[class*="language-"] ::-moz-selection, 31 | code[class*="language-"]::-moz-selection, code[class*="language-"] ::-moz-selection { 32 | text-shadow: none; 33 | background: #e6e2e0; 34 | } 35 | 36 | pre[class*="language-"]::selection, pre[class*="language-"] ::selection, 37 | code[class*="language-"]::selection, code[class*="language-"] ::selection { 38 | text-shadow: none; 39 | background: #e6e2e0; 40 | } 41 | 42 | /* Code blocks */ 43 | pre[class*="language-"] { 44 | padding: 1em; 45 | margin: .5em 0; 46 | overflow: auto; 47 | } 48 | 49 | /* Inline code */ 50 | :not(pre) > code[class*="language-"] { 51 | padding: .1em; 52 | border-radius: .3em; 53 | } 54 | 55 | .token.comment, 56 | .token.prolog, 57 | .token.doctype, 58 | .token.cdata { 59 | color: #9c9491; 60 | } 61 | 62 | .token.punctuation { 63 | color: #68615e; 64 | } 65 | 66 | .token.namespace { 67 | opacity: .7; 68 | } 69 | 70 | .token.operator, 71 | .token.boolean, 72 | .token.number { 73 | color: #df5320; 74 | } 75 | 76 | .token.property { 77 | color: #c38418; 78 | } 79 | 80 | .token.tag { 81 | color: #407ee7; 82 | } 83 | 84 | .token.string { 85 | color: #3d97b8; 86 | } 87 | 88 | .token.selector { 89 | color: #6666ea; 90 | } 91 | 92 | .token.attr-name { 93 | color: #df5320; 94 | } 95 | 96 | .token.entity, 97 | .token.url, 98 | .language-css .token.string, 99 | .style .token.string { 100 | color: #3d97b8; 101 | } 102 | 103 | .token.attr-value, 104 | .token.keyword, 105 | .token.control, 106 | .token.directive, 107 | .token.unit { 108 | color: #7b9726; 109 | } 110 | 111 | .token.statement, 112 | .token.regex, 113 | .token.atrule { 114 | color: #3d97b8; 115 | } 116 | 117 | .token.placeholder, 118 | .token.variable { 119 | color: #407ee7; 120 | } 121 | 122 | .token.deleted { 123 | text-decoration: line-through; 124 | } 125 | 126 | .token.inserted { 127 | border-bottom: 1px dotted #1b1918; 128 | text-decoration: none; 129 | } 130 | 131 | .token.italic { 132 | font-style: italic; 133 | } 134 | 135 | .token.important, 136 | .token.bold { 137 | font-weight: bold; 138 | } 139 | 140 | .token.important { 141 | color: #f22c40; 142 | } 143 | 144 | .token.entity { 145 | cursor: help; 146 | } 147 | 148 | pre > code.highlight { 149 | outline: 0.4em solid #f22c40; 150 | outline-offset: .4em; 151 | } 152 | 153 | .line-numbers .line-numbers-rows { 154 | border-right-color: #e6e2e0 !important; 155 | } 156 | 157 | .line-numbers-rows > span:before { 158 | color: #a8a19f !important; 159 | } 160 | 161 | .line-highlight { 162 | background: rgba(27, 25, 24, 0.2) !important; 163 | background: -webkit-linear-gradient(left, rgba(27, 25, 24, 0.2) 70%, rgba(27, 25, 24, 0)) !important; 164 | background: linear-gradient(to right, rgba(27, 25, 24, 0.2) 70%, rgba(27, 25, 24, 0)) !important; 165 | } -------------------------------------------------------------------------------- /notes/PSmapD3.org: -------------------------------------------------------------------------------- 1 | * PS<$>D3 2 | 3 | ** BUGS 4 | *** TODO initial XY on entry, need to parameterize whether continuity is desired or not 5 | **** alternative approach is to pull from current simulation nodes 6 | **** generalization might be directionality per field 7 | *** TODO display links is actually putting links into simulation and only filter links is doing filtering 8 | *** TODO exploding a package in "package graph" scene results in offscreen modules 9 | 10 | ** Updates 11 | *** TODO update which changes only attributes 12 | **** back and forth between color schemes 13 | **** buttons to match 14 | **** stretch goal: transitions, ie size of circle, fade on remove etc 15 | 16 | *** add buttons to unpin 17 | **** { all, modules, packages, tree, unused } sorts of filters 18 | 19 | *** make vertical XY the default so that radial is only one transform 20 | 21 | ** Features 22 | *** multiphase scenes 23 | **** example: package graph 24 | ***** pin packages 25 | ***** run with fast cooling for a second or two 26 | ***** unpin packages -------------------------------------------------------------------------------- /notes/long-form-notes.md: -------------------------------------------------------------------------------- 1 | # About this repo 2 | 3 | ## Project Overview: Functional Programming and Data Visualization (EXPLANATION) 4 | 5 | ### Compact summary of project 6 | 7 | * goals 8 | * non-goals 9 | * what's here 10 | 11 | ### Data Visualization for Functional Programmers 12 | 13 | ### Functional Programming for Data Visualizers 14 | 15 | ### Next steps: guide to other docs 16 | 17 | * TUTORIALS 18 | * HOW-TO 19 | * Spago example from scratch 20 | * EXPLANATION software enginering and technology considerations 21 | * roles and responsabilities 22 | * finally tagless as a method / approach 23 | * alternatives / extensions / future-work 24 | * REFERENCE library architecture 25 | 26 | ------------------------------------------------------------------ 27 | 28 | ## Finally Tagless Visualization (EXPLANATION) 29 | 30 | ### What it is 31 | 32 | ### Super simple examples from earlier repo 33 | 34 | ### Why it's useful: extensibility and multiple-interpreters 35 | 36 | ### In visualization: graphs, meta-trees and printers 37 | 38 | ------------------------------------------------------------------ 39 | 40 | ## Roles and responsibilities (EXPLANATION) 41 | 42 | ### Visualization as "decoration" vs "core" 43 | 44 | Maintainability, closed loops, longer lived code, life-cycles, interaction design 45 | 46 | ### Role 1: data to data-structure 47 | 48 | File handling, AJAX, conversion and validation of JSON or CSV, calculating derived data, accessors to provide rich API for data visualisation. Concerned with the semantic representation of the data. 49 | 50 | ### Role 2: data-to-DOM 51 | 52 | The part that is closest to the traditional D3.js script: declarative but highly sequential. Concerned with the visual representation of the data. 53 | 54 | ### Role 3: web app development 55 | 56 | Tying it all together. Treating the data visualization as a component, even if it is completely interactive. Example framework: Halogen. 57 | 58 | ------------------------------------------------------------------ 59 | 60 | ## Library architecture: three DSLs (REFERENCE) 61 | 62 | ### The Selection and Simulation Monads 63 | 64 | ### The FFI 65 | 66 | ### Callbacks, attributes, delegation thru functions to allow out of monad calls (pros and cons) 67 | 68 | ------------------------------------------------------------------ 69 | 70 | ## Tutorials (TUTORIAL / HOW-TO) 71 | 72 | ### Three Little Circles (TUTORIAL) 73 | 74 | * just walk thru the process in a standalone version of the TLC example 75 | 76 | ### General Update Pattern (TUTORIAL) 77 | 78 | * motivation for considering enter-exit-update separately 79 | * introduction of transitions (discussion) 80 | * walk thru the code of GUP 81 | 82 | ### Graph: Toy example, Les Mis (TUTORIAL) 83 | 84 | * intro to the domain / problem 85 | * the JSON (miserables.json) 86 | * reading the JSON via AJAX and making a graph from it 87 | * writing the "script" part to draw the graph 88 | * adding simple interaction: drag, zoom (interaction contained within the visualization) 89 | * adding more complex interaction: folding and/or near-neighbour highlighting (interaction raises action to the web app: subscriptions, callbacks) 90 | 91 | ------------------------------------------------------------------ 92 | 93 | ## So you want to build an app with strongly integrated visualization (TUTORIAL / HOW-TO) 94 | 95 | ### Graph: Spago example (HOW-TO) 96 | 97 | * intro to the domain / problemthe JSON (multiple sources, need to synthesize, generating trees from graphs etc) 98 | * (reading the JSON, same as Les Mis) 99 | * building accessors, hiding the unsafe coercions 100 | * writing the script part to draw the graph 101 | * managing a complex model 102 | 103 | ------------------------------------------------------------------ 104 | 105 | ## Swapping out, re-writing or augmenting D3.js (EXPLANATION) 106 | 107 | Using graphviz or other layouts, replacing the Selection and/or simulation FFIs 108 | 109 | Removing the unsafe coercions completely, advantages etc. Imposition of opaque type due to FFI (check that there is no way around this?) 110 | -------------------------------------------------------------------------------- /notes/long-form-notes.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/afcondon/purescript-d3-tagless-II/70942aa8ed59dac0bd4ab54351c87a82e0b53c6a/notes/long-form-notes.pdf -------------------------------------------------------------------------------- /notes/resources.md: -------------------------------------------------------------------------------- 1 | # Resources 2 | 3 | * Halogen 4 | * Tailwind 5 | * (Ocelot) - copied over rather than depended on 6 | * (twpurs) - not in use but might be needed to enable JIT 7 | * purgecss 8 | * postcss 9 | * postcss-nesting 10 | * postcss-import 11 | * autoprefixer -------------------------------------------------------------------------------- /notes/spago-schemas: -------------------------------------------------------------------------------- 1 | 2 | create table module (module varchar(128) primary key, path varchar(128) not null); 3 | 4 | create table module_dependency (module varchar(128) REFERENCES module(module), 5 | dependent varchar(128) REFERENCES module(module), 6 | PRIMARY KEY (module,dependent) 7 | ); 8 | 9 | create table package (package varchar(128) primary key); 10 | 11 | create table package_dependency (package varchar(128) REFERENCES package(package), 12 | dependent varchar(128) REFERENCES package(package), 13 | PRIMARY KEY (package,dependent) 14 | ); 15 | 16 | create table package_version (package varchar(128) primary key REFERENCES package(package), version varchar(128) not null); -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "purescript-ocelot", 3 | "version": "0.30.0", 4 | "private": true, 5 | "scripts": { 6 | "build": "spago build", 7 | "install": "spago install", 8 | "upgrade-set": "spago upgrade-set", 9 | "snippets": "cd docs/code-examples; perl ../../src/scripts/snippets3.pl ../../src/DemoApp/Viz/*/*.purs ../../src/DemoApp/Viz/*.purs ../../src/DemoApp/Stories/*/*.purs ../../src/DemoApp/Stories/*.purs", 10 | "bundle": "spago bundle-app --to docs/bundle.js", 11 | "build-css": "cd src/DemoApp/css; postcss src/index.css -o ../../../docs/bundle.css" 12 | }, 13 | "devDependencies": { 14 | "autoprefixer": "^10.2.6", 15 | "cssnano": "^5.0.6", 16 | "postcss-cli": "^8.3.1", 17 | "postcss-import": "^14.0.2", 18 | "postcss-nesting": "^8.0.1", 19 | "tailwindcss": "^2.1.4" 20 | }, 21 | "dependencies": { 22 | "d3": "^7.0.1", 23 | "d3-color": "^3.0.1", 24 | "d3-interpolate": "^3.0.1", 25 | "d3-scale-chromatic": "^3.0.0", 26 | "esbuild": "^0.14.47", 27 | "purescript": "^0.15.0", 28 | "spago": "^0.20.9", 29 | "yarn": "^1.22.10" 30 | } 31 | } 32 | -------------------------------------------------------------------------------- /packages.dhall: -------------------------------------------------------------------------------- 1 | {- 2 | Welcome to your new Dhall package-set! 3 | 4 | Below are instructions for how to edit this file for most use 5 | cases, so that you don't need to know Dhall to use it. 6 | 7 | ## Warning: Don't Move This Top-Level Comment! 8 | 9 | Due to how `dhall format` currently works, this comment's 10 | instructions cannot appear near corresponding sections below 11 | because `dhall format` will delete the comment. However, 12 | it will not delete a top-level comment like this one. 13 | 14 | ## Use Cases 15 | 16 | Most will want to do one or both of these options: 17 | 1. Override/Patch a package's dependency 18 | 2. Add a package not already in the default package set 19 | 20 | This file will continue to work whether you use one or both options. 21 | Instructions for each option are explained below. 22 | 23 | ### Overriding/Patching a package 24 | 25 | Purpose: 26 | - Change a package's dependency to a newer/older release than the 27 | default package set's release 28 | - Use your own modified version of some dependency that may 29 | include new API, changed API, removed API by 30 | using your custom git repo of the library rather than 31 | the package set's repo 32 | 33 | Syntax: 34 | where `entityName` is one of the following: 35 | - dependencies 36 | - repo 37 | - version 38 | ------------------------------- 39 | let upstream = -- 40 | in upstream 41 | with packageName.entityName = "new value" 42 | ------------------------------- 43 | 44 | Example: 45 | ------------------------------- 46 | let upstream = -- 47 | in upstream 48 | with halogen.version = "master" 49 | with halogen.repo = "https://example.com/path/to/git/repo.git" 50 | 51 | with halogen-vdom.version = "v4.0.0" 52 | ------------------------------- 53 | 54 | ### Additions 55 | 56 | Purpose: 57 | - Add packages that aren't already included in the default package set 58 | 59 | Syntax: 60 | where `` is: 61 | - a tag (i.e. "v4.0.0") 62 | - a branch (i.e. "master") 63 | - commit hash (i.e. "701f3e44aafb1a6459281714858fadf2c4c2a977") 64 | ------------------------------- 65 | let upstream = -- 66 | in upstream 67 | with new-package-name = 68 | { dependencies = 69 | [ "dependency1" 70 | , "dependency2" 71 | ] 72 | , repo = 73 | "https://example.com/path/to/git/repo.git" 74 | , version = 75 | "" 76 | } 77 | ------------------------------- 78 | 79 | Example: 80 | ------------------------------- 81 | let upstream = -- 82 | in upstream 83 | with benchotron = 84 | { dependencies = 85 | [ "arrays" 86 | , "exists" 87 | , "profunctor" 88 | , "strings" 89 | , "quickcheck" 90 | , "lcg" 91 | , "transformers" 92 | , "foldable-traversable" 93 | , "exceptions" 94 | , "node-fs" 95 | , "node-buffer" 96 | , "node-readline" 97 | , "datetime" 98 | , "now" 99 | ] 100 | , repo = 101 | "https://github.com/hdgarrood/purescript-benchotron.git" 102 | , version = 103 | "v7.0.0" 104 | } 105 | ------------------------------- 106 | let halogen-renderless = 107 | { dependencies = [ "prelude", "control" ] 108 | , repo = 109 | "https://github.com/purescript-deprecated/purescript-halogen-renderless" 110 | , version = "v0.0.4" 111 | } 112 | 113 | let svg-parser = 114 | { dependencies = [ "prelude", "string-parsers" ] 115 | , repo = "https://github.com/citizennet/purescript-svg-parser.git" 116 | , version = "v2.0.0" 117 | } 118 | 119 | let svg-parser-halogen = 120 | { dependencies = [ "svg-parser", "halogen" ] 121 | , repo = "https://github.com/rnons/purescript-svg-parser-halogen.git" 122 | , version = "v2.0.0-rc.1" 123 | } 124 | let graphs = 125 | { repo = "https://github.com/colehaus/purescript-graphs.git" 126 | , version = "c4a3189e39579102b8be3cff9bcde63a9d4ef322" 127 | , dependencies = [ "ordered-collections", "catenable-lists" ] 128 | } 129 | -} 130 | 131 | 132 | let html-parser-halogen = 133 | { dependencies = [ "string-parsers", "halogen" ] 134 | , repo = "https://github.com/afcondon/purescript-html-parser-halogen.git" 135 | , version = "esmodules" 136 | } 137 | 138 | 139 | let overrides = {=} 140 | 141 | let additions = 142 | { -- graphs 143 | -- , halogen-renderless 144 | html-parser-halogen 145 | -- , svg-parser 146 | -- , svg-parser-halogen 147 | } 148 | 149 | let upstream = 150 | https://github.com/purescript/package-sets/releases/download/psc-0.15.2-20220624/packages.dhall 151 | sha256:08989ed9f53e381f879f1b7012ad7684b1ed64d7164c4ad75e306d3210a46c92 152 | 153 | in upstream // overrides // additions 154 | -------------------------------------------------------------------------------- /spago.dhall: -------------------------------------------------------------------------------- 1 | {- 2 | Welcome to a Spago project! 3 | You can edit this file as you like. 4 | -} 5 | { name = "my-project" 6 | , dependencies = 7 | [ "aff" 8 | , "affjax" 9 | , "affjax-web" 10 | , "arrays" 11 | , "bifunctors" 12 | , "console" 13 | , "const" 14 | , "datetime" 15 | , "debug" 16 | , "dom-indexed" 17 | , "effect" 18 | , "either" 19 | , "exceptions" 20 | , "foldable-traversable" 21 | , "foreign-object" 22 | , "functions" 23 | , "graphs" 24 | , "halogen" 25 | , "halogen-subscriptions" 26 | , "halogen-svg-elems" 27 | , "halogen-vdom" 28 | , "html-parser-halogen" 29 | , "integers" 30 | , "lists" 31 | , "maybe" 32 | , "newtype" 33 | , "nullable" 34 | , "numbers" 35 | , "ordered-collections" 36 | , "prelude" 37 | , "profunctor" 38 | , "profunctor-lenses" 39 | , "psci-support" 40 | , "random" 41 | , "read" 42 | , "strings" 43 | , "tailrec" 44 | , "transformers" 45 | , "tuples" 46 | , "typelevel-prelude" 47 | , "unsafe-coerce" 48 | , "web-events" 49 | , "web-html" 50 | ] 51 | , packages = ./packages.dhall 52 | , sources = [ "src/**/*.purs", "test/**/*.purs" ] 53 | } 54 | -------------------------------------------------------------------------------- /src/DemoApp/Blocks/Card.purs: -------------------------------------------------------------------------------- 1 | module D3Tagless.Block.Card where 2 | 3 | import Prelude 4 | 5 | import DOM.HTML.Indexed (HTMLdiv) 6 | import Halogen.HTML as HH 7 | import Halogen.HTML.Properties as HP 8 | import Ocelot.HTML.Properties ((<&>)) 9 | 10 | baseCardClasses :: Array HH.ClassName 11 | baseCardClasses = HH.ClassName <$> 12 | [ "bg-white" 13 | , "mb-6" 14 | , "rounded" 15 | , "clearfix" 16 | ] 17 | 18 | innerCardClasses :: Array HH.ClassName 19 | innerCardClasses = HH.ClassName <$> 20 | [ "m-6" 21 | ] 22 | 23 | baseCard 24 | :: ∀ p i 25 | . Array (HH.IProp HTMLdiv i) 26 | -> Array (HH.HTML p i) 27 | -> HH.HTML p i 28 | baseCard iprops = 29 | HH.div 30 | ( [ HP.classes baseCardClasses ] <&> iprops ) 31 | 32 | baseCard_ 33 | :: ∀ p i 34 | . Array (HH.HTML p i) 35 | -> HH.HTML p i 36 | baseCard_ = baseCard [] 37 | 38 | 39 | innerCard 40 | :: ∀ p i 41 | . Array (HH.IProp HTMLdiv i) 42 | -> Array (HH.HTML p i) 43 | -> HH.HTML p i 44 | innerCard iprops = 45 | HH.div 46 | ( [ HP.classes innerCardClasses ] <&> iprops ) 47 | 48 | innerCard_ 49 | :: ∀ p i 50 | . Array (HH.HTML p i) 51 | -> HH.HTML p i 52 | innerCard_ = innerCard [] 53 | 54 | card 55 | :: ∀ p i 56 | . Array (HH.IProp HTMLdiv i) 57 | -> Array (HH.HTML p i) 58 | -> HH.HTML p i 59 | card iprops html = 60 | baseCard iprops [ innerCard_ html ] 61 | 62 | card_ 63 | :: ∀ p i 64 | . Array (HH.HTML p i) 65 | -> HH.HTML p i 66 | card_ = card [] 67 | -------------------------------------------------------------------------------- /src/DemoApp/Blocks/Expandable.purs: -------------------------------------------------------------------------------- 1 | module D3Tagless.Block.Expandable where 2 | 3 | import Prelude 4 | 5 | import DOM.HTML.Indexed (HTMLdiv, HTMLspan, Interactive) 6 | import Data.Array (snoc) 7 | import Data.Bifunctor (lmap, rmap) 8 | import Data.Foldable (foldr) 9 | import Data.Maybe (Maybe(..), fromMaybe) 10 | import Data.String.Read (class Read, read) 11 | import Data.Tuple (Tuple(..)) 12 | import Halogen.HTML (PropName(..)) 13 | import Halogen.HTML as HH 14 | import Halogen.HTML.Core (class IsProp, Prop(..), PropValue) 15 | import Halogen.HTML.Properties as HP 16 | import Halogen.VDom.DOM.Prop (propFromString) 17 | import Ocelot.Block.Icon as Icon 18 | import Ocelot.HTML.Properties ((<&>)) 19 | import Unsafe.Coerce (unsafeCoerce) 20 | 21 | data Status 22 | = Collapsed 23 | | Expanded 24 | 25 | instance read :: Read Status where 26 | read = case _ of 27 | "collapsed" -> pure Collapsed 28 | "expanded" -> pure Expanded 29 | otherwise -> Nothing 30 | 31 | instance isPropStatus :: IsProp Status where 32 | toPropValue = propFromString <<< toProp 33 | 34 | toProp :: Status -> String 35 | toProp = case _ of 36 | Collapsed -> "collapsed" 37 | Expanded -> "expanded" 38 | 39 | toBoolean :: Status -> Boolean 40 | toBoolean Collapsed = false 41 | toBoolean Expanded = true 42 | 43 | fromBoolean :: Boolean -> Status 44 | fromBoolean false = Collapsed 45 | fromBoolean true = Expanded 46 | 47 | instance heytingAlgebraStatus :: HeytingAlgebra Status where 48 | ff = Collapsed 49 | tt = Expanded 50 | implies a b = not a || b 51 | conj Expanded Expanded = Expanded 52 | conj _ _ = Collapsed 53 | disj Expanded _ = Expanded 54 | disj _ Expanded = Expanded 55 | disj _ _ = Collapsed 56 | not Expanded = Collapsed 57 | not Collapsed = Expanded 58 | 59 | headingClasses :: Array HH.ClassName 60 | headingClasses = HH.ClassName <$> 61 | [ "flex" 62 | , "justify-between" 63 | , "cursor-pointer" 64 | ] 65 | 66 | headingInnerClasses :: Array HH.ClassName 67 | headingInnerClasses = HH.ClassName <$> 68 | [ "flex-initial" 69 | ] 70 | 71 | chevronClasses :: Array HH.ClassName 72 | chevronClasses = HH.ClassName <$> 73 | [ "text-grey-70" 74 | , "text-lg" 75 | , "leading-loose" 76 | ] 77 | 78 | contentSharedClasses :: Array HH.ClassName 79 | contentSharedClasses = HH.ClassName <$> 80 | [] 81 | 82 | contentClasses :: Status -> Array HH.ClassName 83 | contentClasses status_ = contentSharedClasses <> 84 | ( case status_ of 85 | Collapsed -> HH.ClassName <$> 86 | [ "max-h-0" 87 | , "opacity-0" 88 | , "w-0" -- TODO this should be a parameter, and actually all classes here should be @apply's 89 | , "overflow-hidden" 90 | , "transition-1/2-in" 91 | ] 92 | Expanded -> HH.ClassName <$> 93 | [ "max-h-full" 94 | , "opacity-100" 95 | , "transition-1/2-out" 96 | ] 97 | ) 98 | 99 | type HTMLexpandable = Interactive ( expanded :: Status ) 100 | 101 | status :: ∀ r i. Status -> HP.IProp ( expanded :: Status | r ) i 102 | status = HP.prop (PropName "expanded") 103 | 104 | -- Takes a row of `IProps` containing the `expanded` label 105 | -- and returns a `Tuple` containing the extracted value as 106 | -- well as the original row, minus the `expanded` label 107 | extractStatus 108 | :: ∀ r i 109 | . Array (HH.IProp ( expanded :: Status | r) i) 110 | -> Tuple Status (Array (HH.IProp r i)) 111 | extractStatus = 112 | foldr f (Tuple Expanded []) 113 | where 114 | f (HP.IProp (Property "expanded" expanded)) = 115 | lmap (const $ coerceExpanded expanded) 116 | f iprop = rmap $ (flip snoc) $ coerceR iprop 117 | 118 | coerceExpanded :: PropValue -> Status 119 | coerceExpanded = fromMaybe Expanded <<< read <<< unsafeCoerce 120 | 121 | coerceR :: HH.IProp ( expanded :: Status | r ) i -> HH.IProp r i 122 | coerceR = unsafeCoerce 123 | 124 | heading 125 | :: ∀ p i 126 | . Array (HH.IProp HTMLexpandable i) 127 | -> Array (HH.HTML p i) 128 | -> HH.HTML p i 129 | heading iprops html = 130 | let (Tuple status_ iprops') = extractStatus iprops in 131 | HH.header 132 | ( [ HP.classes headingClasses ] <&> iprops' ) 133 | [ HH.div 134 | [ HP.classes headingInnerClasses ] 135 | html 136 | , HH.div_ 137 | [ chevron_ status_ ] 138 | ] 139 | 140 | chevron 141 | :: ∀ p i 142 | . Status 143 | -> Array (HH.IProp HTMLspan i) 144 | -> HH.HTML p i 145 | chevron status_ iprops = 146 | ( case status_ of 147 | Collapsed -> Icon.expand 148 | Expanded -> Icon.collapse 149 | ) 150 | ( [ HP.classes chevronClasses ] <&> iprops ) 151 | 152 | chevron_ 153 | :: ∀ p i 154 | . Status 155 | -> HH.HTML p i 156 | chevron_ status_ = chevron status_ [] 157 | 158 | content 159 | :: ∀ p i 160 | . Status 161 | -> Array (HH.IProp HTMLdiv i) 162 | -> Array (HH.HTML p i) 163 | -> HH.HTML p i 164 | content status_ iprops = 165 | HH.div 166 | ( [ HP.classes $ contentClasses status_ ] <&> iprops ) 167 | 168 | content_ 169 | :: ∀ p i 170 | . Status 171 | -> Array (HH.HTML p i) 172 | -> HH.HTML p i 173 | content_ status_ = content status_ [] 174 | -------------------------------------------------------------------------------- /src/DemoApp/Blocks/FormField.purs: -------------------------------------------------------------------------------- 1 | module D3Tagless.Block.FormField where 2 | 3 | import Prelude 4 | 5 | import DOM.HTML.Indexed (HTMLdiv) 6 | import Halogen.HTML as HH 7 | import Halogen.HTML.Properties as HP 8 | import Ocelot.Block.Format as Format 9 | import Ocelot.HTML.Properties (css, (<&>)) 10 | 11 | fieldClasses :: Array HH.ClassName 12 | fieldClasses = HH.ClassName <$> 13 | [ "w-full" 14 | -- , "mb-10" 15 | ] 16 | 17 | helpTextClasses :: Array HH.ClassName 18 | helpTextClasses = Format.mutedClasses <> 19 | ( HH.ClassName <$> 20 | [ "block" 21 | , "font-light" 22 | , "pt-3" 23 | ] 24 | ) 25 | 26 | errorTextClasses :: Array HH.ClassName 27 | errorTextClasses = HH.ClassName <$> 28 | [ "block" 29 | , "text-red" 30 | , "font-medium" 31 | , "pt-3" 32 | ] 33 | 34 | labelClasses :: Array HH.ClassName 35 | labelClasses = HH.ClassName <$> 36 | [ "block" 37 | , "font-medium" 38 | , "leading-loose" 39 | , "text-black-20" 40 | ] 41 | 42 | type FieldConfig p i = 43 | { label :: HH.PlainHTML 44 | , inputId :: String 45 | , helpText :: Array (HH.HTML p i) 46 | , error :: Array (HH.HTML p i) 47 | } 48 | 49 | field' 50 | :: ∀ p i 51 | . FieldConfig p i 52 | -> Array (HH.IProp HTMLdiv i) 53 | -> HH.HTML p i 54 | -> HH.HTML p i 55 | field' config iprops html = 56 | HH.div 57 | ( [ HP.classes fieldClasses ] <&> iprops ) 58 | [ HH.label 59 | [ HP.classes labelClasses 60 | , HP.for config.inputId 61 | ] 62 | [ HH.fromPlainHTML config.label ] 63 | , html 64 | , error_ config.error 65 | , helpText_ config.helpText 66 | ] 67 | 68 | field 69 | :: ∀ p i 70 | . FieldConfig p i 71 | -> Array (HH.IProp HTMLdiv i) 72 | -> Array (HH.HTML p i) 73 | -> HH.HTML p i 74 | field config iprops html = 75 | field' 76 | config 77 | iprops 78 | ( HH.div [ css "my-1" ] html ) 79 | 80 | field_ 81 | :: ∀ p i 82 | . FieldConfig p i 83 | -> Array (HH.HTML p i) 84 | -> HH.HTML p i 85 | field_ config = field config [] 86 | 87 | fieldSmall 88 | :: ∀ p i 89 | . FieldConfig p i 90 | -> Array (HH.IProp HTMLdiv i) 91 | -> Array (HH.HTML p i) 92 | -> HH.HTML p i 93 | fieldSmall config iprops html = 94 | field' 95 | config 96 | iprops 97 | ( HH.div [ css "my-1 md:w-1/4" ] html ) 98 | 99 | fieldSmall_ 100 | :: ∀ p i 101 | . FieldConfig p i 102 | -> Array (HH.HTML p i) 103 | -> HH.HTML p i 104 | fieldSmall_ config = fieldSmall config [] 105 | 106 | fieldMid 107 | :: ∀ p i 108 | . FieldConfig p i 109 | -> Array (HH.IProp HTMLdiv i) 110 | -> Array (HH.HTML p i) 111 | -> HH.HTML p i 112 | fieldMid config iprops html = 113 | field' 114 | config 115 | iprops 116 | ( HH.div [ css "my-1 md:w-1/2" ] html ) 117 | 118 | fieldMid_ 119 | :: ∀ p i 120 | . FieldConfig p i 121 | -> Array (HH.HTML p i) 122 | -> HH.HTML p i 123 | fieldMid_ config = fieldMid config [] 124 | 125 | fieldset 126 | :: ∀ p i 127 | . FieldConfig p i 128 | -> Array (HH.IProp HTMLdiv i) 129 | -> Array (HH.HTML p i) 130 | -> HH.HTML p i 131 | fieldset config iprops html = 132 | HH.div 133 | ( [ HP.classes fieldClasses ] <&> iprops ) 134 | [ HH.fieldset 135 | [] 136 | [ HH.legend 137 | [ HP.classes labelClasses ] 138 | [ HH.fromPlainHTML config.label ] 139 | , HH.div 140 | [ css "my-1" ] 141 | html 142 | , error_ config.error 143 | , helpText_ config.helpText 144 | ] 145 | ] 146 | 147 | fieldset_ 148 | :: ∀ p i 149 | . FieldConfig p i 150 | -> Array (HH.HTML p i) 151 | -> HH.HTML p i 152 | fieldset_ config = fieldset config [] 153 | 154 | error 155 | :: ∀ p i 156 | . Array (HH.IProp HTMLdiv i) 157 | -> Array (HH.HTML p i) 158 | -> HH.HTML p i 159 | error iprops = HH.div $ [ HP.classes errorTextClasses ] <&> iprops 160 | 161 | error_ 162 | :: ∀ p i 163 | . Array (HH.HTML p i) 164 | -> HH.HTML p i 165 | error_ = error [] 166 | 167 | helpText 168 | :: ∀ p i 169 | . Array (HH.IProp HTMLdiv i) 170 | -> Array (HH.HTML p i) 171 | -> HH.HTML p i 172 | helpText iprops = HH.div $ [ HP.classes helpTextClasses ] <&> iprops 173 | 174 | helpText_ 175 | :: ∀ p i 176 | . Array (HH.HTML p i) 177 | -> HH.HTML p i 178 | helpText_ = helpText [] 179 | -------------------------------------------------------------------------------- /src/DemoApp/Blocks/Toggle.purs: -------------------------------------------------------------------------------- 1 | module D3Tagless.Block.Toggle (toggle) where 2 | 3 | import Prelude 4 | 5 | import DOM.HTML.Indexed (HTMLinput) 6 | import DOM.HTML.Indexed.InputType (InputType(InputCheckbox)) 7 | import Halogen.HTML as HH 8 | import Halogen.HTML.Properties as HP 9 | 10 | type ToggleProps = 11 | { label :: String } 12 | 13 | labelClasses :: Array HH.ClassName 14 | labelClasses = HH.ClassName <$> 15 | [ "flex" 16 | , "flex-row" 17 | , "items-center" 18 | , "inline-block" 19 | , "py-1" 20 | , "cursor-pointer" 21 | , "leading-loose" 22 | , "text-black-20" 23 | ] 24 | 25 | inputClasses :: Array HH.ClassName 26 | inputClasses = HH.ClassName <$> 27 | [ "checked:sibling:bg-blue-88" 28 | , "checked:sibling:pl-5" 29 | , "!checked:sibling:bg-grey-80" 30 | , "!checked:sibling:pr-5" 31 | , "offscreen" 32 | ] 33 | 34 | toggleClasses :: Array HH.ClassName 35 | toggleClasses = HH.ClassName <$> 36 | [ "transition-1/8" 37 | , "inline-flex" 38 | , "justify-center" 39 | , "items-center" 40 | , "content-box" 41 | , "h-5" 42 | , "w-5" 43 | , "p-1" 44 | , "rounded-full" 45 | , "mr-3" 46 | , "before:bg-white" 47 | , "before:h-full" 48 | , "before:w-full" 49 | , "before:rounded-full" 50 | , "before:no-content" 51 | , "before:shadow" 52 | ] 53 | 54 | toggle 55 | :: ∀ p i 56 | . Array (HH.IProp HTMLinput i) 57 | -> HH.HTML p i 58 | toggle iprops = 59 | HH.label 60 | [ HP.classes labelClasses ] 61 | [ HH.input iprops' 62 | , HH.span [ HP.classes toggleClasses ] [] 63 | ] 64 | where 65 | iprops' = iprops <> 66 | [ HP.classes inputClasses 67 | , HP.type_ InputCheckbox 68 | ] 69 | -------------------------------------------------------------------------------- /src/DemoApp/Ocelot/Blocks/Builder.purs: -------------------------------------------------------------------------------- 1 | module Ocelot.Block.Builder where 2 | 3 | import Prelude 4 | 5 | import Halogen.HTML as HH 6 | import Halogen.HTML.Properties as HP 7 | import Ocelot.HTML.Properties (IProp, (<&>)) 8 | 9 | blockBuilder 10 | :: ∀ r p i 11 | . ( Array (IProp r i) 12 | -> Array (HH.HTML p i) 13 | -> HH.HTML p i 14 | ) 15 | -> Array HH.ClassName 16 | -> Array (IProp r i) 17 | -> Array (HH.HTML p i) 18 | -> HH.HTML p i 19 | blockBuilder elem classes iprops = 20 | elem $ [ HP.classes classes ] <&> iprops 21 | -------------------------------------------------------------------------------- /src/DemoApp/Ocelot/Blocks/Checkbox.purs: -------------------------------------------------------------------------------- 1 | module Ocelot.Block.Checkbox where 2 | 3 | import Prelude 4 | 5 | import DOM.HTML.Indexed (HTMLinput, HTMLlabel) 6 | import DOM.HTML.Indexed.InputType (InputType(..)) 7 | import Halogen.HTML as HH 8 | import Halogen.HTML.Properties as HP 9 | import Ocelot.HTML.Properties ((<&>)) 10 | 11 | labelClasses :: Array HH.ClassName 12 | labelClasses = HH.ClassName <$> 13 | [ "flex" 14 | , "flex-row" 15 | , "inline-block" 16 | , "py-2" 17 | , "cursor-pointer" 18 | , "text-black-20" 19 | , "items-center" 20 | , "text-left" -- styles get messed up otherwise 21 | ] 22 | 23 | inputClasses :: Array HH.ClassName 24 | inputClasses = HH.ClassName <$> 25 | -- start shared custom classes defined for radios -- 26 | [ "!disabled:sibling:bg-white" 27 | , "disabled:sibling:bg-grey-95" 28 | , "checked:sibling:before:opacity-100" 29 | , "checked:sibling:before:scale-1" 30 | , "checked:!disabled:sibling:border-blue-88" 31 | , "focus:sibling:border-blue-88" 32 | , "!checked:sibling:before:opacity-0" 33 | , "!checked:sibling:before:scale-0" 34 | , "!focus:hover:!checked:!disabled:sibling:border-grey-70" 35 | , "focus:sibling:shadow" 36 | , "checked:!disabled:sibling:before:bg-blue-88" 37 | , "checked:disabled:sibling:before:bg-grey-80" 38 | , "checked:disabled:sibling:border-grey-80" 39 | , "offscreen" 40 | -- end shared custom radio classes -- 41 | , "checked:sibling:after:opacity-100" 42 | , "checked:sibling:after:scale-1" 43 | , "!checked:sibling:after:opacity-0" 44 | , "!checked:sibling:after:scale-0" 45 | ] 46 | 47 | checkboxClasses :: Array HH.ClassName 48 | checkboxClasses = HH.ClassName <$> 49 | [ "relative" 50 | , "content-box" 51 | , "border-2" 52 | , "border-solid" 53 | , "h-5" 54 | , "w-5" 55 | , "flex-none" 56 | , "no-content" 57 | , "mr-3" 58 | , "rounded" 59 | , "before:transition-1/4-bounce" 60 | , "before:absolute" 61 | , "before:h-full" 62 | , "before:w-full" 63 | , "before:no-content" 64 | , "after:transition-1/4-bounce" 65 | , "after:absolute" 66 | , "after:w-full" 67 | , "after:h-2" 68 | , "after:border-l-2" 69 | , "after:border-b-2" 70 | , "after:border-white" 71 | , "after:no-content" 72 | , "after:rotate-315" 73 | , "after:shadow" 74 | ] 75 | 76 | checkbox 77 | :: ∀ p i 78 | . Array (HH.IProp HTMLlabel i) 79 | -> Array (HH.IProp HTMLinput i) 80 | -> Array (HH.HTML p i) 81 | -> HH.HTML p i 82 | checkbox iprops inprops html = 83 | HH.label 84 | ( [ HP.classes labelClasses ] <&> iprops ) 85 | ( [ HH.input 86 | ( [ HP.classes inputClasses 87 | , HP.type_ InputCheckbox 88 | ] <&> inprops 89 | ) 90 | , HH.span [ HP.classes checkboxClasses ] [] 91 | ] 92 | <> html 93 | ) 94 | 95 | checkbox_ 96 | :: ∀ p i 97 | . Array (HH.IProp HTMLinput i) 98 | -> Array (HH.HTML p i) 99 | -> HH.HTML p i 100 | checkbox_ = checkbox [] 101 | -------------------------------------------------------------------------------- /src/DemoApp/Ocelot/Blocks/FormField.purs: -------------------------------------------------------------------------------- 1 | module Ocelot.Block.FormField where 2 | 3 | import Prelude 4 | 5 | import DOM.HTML.Indexed (HTMLdiv) 6 | import Halogen.HTML as HH 7 | import Halogen.HTML.Properties as HP 8 | import Ocelot.Block.Format as Format 9 | import Ocelot.HTML.Properties (css, (<&>)) 10 | 11 | fieldClasses :: Array HH.ClassName 12 | fieldClasses = HH.ClassName <$> 13 | [ "w-full" 14 | , "mb-10" 15 | ] 16 | 17 | helpTextClasses :: Array HH.ClassName 18 | helpTextClasses = Format.mutedClasses <> 19 | ( HH.ClassName <$> 20 | [ "block" 21 | , "font-light" 22 | , "pt-3" 23 | ] 24 | ) 25 | 26 | errorTextClasses :: Array HH.ClassName 27 | errorTextClasses = HH.ClassName <$> 28 | [ "block" 29 | , "text-red" 30 | , "font-medium" 31 | , "pt-3" 32 | ] 33 | 34 | labelClasses :: Array HH.ClassName 35 | labelClasses = HH.ClassName <$> 36 | [ "block" 37 | , "font-medium" 38 | , "leading-loose" 39 | , "text-black-20" 40 | ] 41 | 42 | type FieldConfig p i = 43 | { label :: HH.PlainHTML 44 | , inputId :: String 45 | , helpText :: Array (HH.HTML p i) 46 | , error :: Array (HH.HTML p i) 47 | } 48 | 49 | field' 50 | :: ∀ p i 51 | . FieldConfig p i 52 | -> Array (HH.IProp HTMLdiv i) 53 | -> HH.HTML p i 54 | -> HH.HTML p i 55 | field' config iprops html = 56 | HH.div 57 | ( [ HP.classes fieldClasses ] <&> iprops ) 58 | [ HH.label 59 | [ HP.classes labelClasses 60 | , HP.for config.inputId 61 | ] 62 | [ HH.fromPlainHTML config.label ] 63 | , html 64 | , error_ config.error 65 | , helpText_ config.helpText 66 | ] 67 | 68 | field 69 | :: ∀ p i 70 | . FieldConfig p i 71 | -> Array (HH.IProp HTMLdiv i) 72 | -> Array (HH.HTML p i) 73 | -> HH.HTML p i 74 | field config iprops html = 75 | field' 76 | config 77 | iprops 78 | ( HH.div [ css "my-1" ] html ) 79 | 80 | field_ 81 | :: ∀ p i 82 | . FieldConfig p i 83 | -> Array (HH.HTML p i) 84 | -> HH.HTML p i 85 | field_ config = field config [] 86 | 87 | fieldSmall 88 | :: ∀ p i 89 | . FieldConfig p i 90 | -> Array (HH.IProp HTMLdiv i) 91 | -> Array (HH.HTML p i) 92 | -> HH.HTML p i 93 | fieldSmall config iprops html = 94 | field' 95 | config 96 | iprops 97 | ( HH.div [ css "my-1 md:w-1/4" ] html ) 98 | 99 | fieldSmall_ 100 | :: ∀ p i 101 | . FieldConfig p i 102 | -> Array (HH.HTML p i) 103 | -> HH.HTML p i 104 | fieldSmall_ config = fieldSmall config [] 105 | 106 | fieldMid 107 | :: ∀ p i 108 | . FieldConfig p i 109 | -> Array (HH.IProp HTMLdiv i) 110 | -> Array (HH.HTML p i) 111 | -> HH.HTML p i 112 | fieldMid config iprops html = 113 | field' 114 | config 115 | iprops 116 | ( HH.div [ css "my-1 md:w-1/2" ] html ) 117 | 118 | fieldMid_ 119 | :: ∀ p i 120 | . FieldConfig p i 121 | -> Array (HH.HTML p i) 122 | -> HH.HTML p i 123 | fieldMid_ config = fieldMid config [] 124 | 125 | fieldset 126 | :: ∀ p i 127 | . FieldConfig p i 128 | -> Array (HH.IProp HTMLdiv i) 129 | -> Array (HH.HTML p i) 130 | -> HH.HTML p i 131 | fieldset config iprops html = 132 | HH.div 133 | ( [ HP.classes fieldClasses ] <&> iprops ) 134 | [ HH.fieldset 135 | [] 136 | [ HH.legend 137 | [ HP.classes labelClasses ] 138 | [ HH.fromPlainHTML config.label ] 139 | , HH.div 140 | [ css "my-1" ] 141 | html 142 | , error_ config.error 143 | , helpText_ config.helpText 144 | ] 145 | ] 146 | 147 | fieldset_ 148 | :: ∀ p i 149 | . FieldConfig p i 150 | -> Array (HH.HTML p i) 151 | -> HH.HTML p i 152 | fieldset_ config = fieldset config [] 153 | 154 | error 155 | :: ∀ p i 156 | . Array (HH.IProp HTMLdiv i) 157 | -> Array (HH.HTML p i) 158 | -> HH.HTML p i 159 | error iprops = HH.div $ [ HP.classes errorTextClasses ] <&> iprops 160 | 161 | error_ 162 | :: ∀ p i 163 | . Array (HH.HTML p i) 164 | -> HH.HTML p i 165 | error_ = error [] 166 | 167 | helpText 168 | :: ∀ p i 169 | . Array (HH.IProp HTMLdiv i) 170 | -> Array (HH.HTML p i) 171 | -> HH.HTML p i 172 | helpText iprops = HH.div $ [ HP.classes helpTextClasses ] <&> iprops 173 | 174 | helpText_ 175 | :: ∀ p i 176 | . Array (HH.HTML p i) 177 | -> HH.HTML p i 178 | helpText_ = helpText [] 179 | -------------------------------------------------------------------------------- /src/DemoApp/Ocelot/Blocks/Format.purs: -------------------------------------------------------------------------------- 1 | module Ocelot.Block.Format where 2 | 3 | import Prelude 4 | 5 | import DOM.HTML.Indexed (HTMLh1, HTMLh2, HTMLh3, HTMLh4, HTMLp) 6 | import Halogen.HTML as HH 7 | import Halogen.HTML.Properties as HP 8 | import Ocelot.HTML.Properties ((<&>)) 9 | 10 | headingClasses :: Array HH.ClassName 11 | headingClasses = HH.ClassName <$> 12 | [ "mb-6" 13 | , "text-3xl" 14 | , "font-normal" 15 | , "leading-loose" 16 | , "flex" 17 | , "items-center" 18 | ] 19 | 20 | headingDarkClasses :: Array HH.ClassName 21 | headingDarkClasses = headingClasses <> 22 | ( HH.ClassName <$> 23 | [ "text-white" 24 | ] 25 | ) 26 | 27 | subHeadingClasses :: Array HH.ClassName 28 | subHeadingClasses = HH.ClassName <$> 29 | [ "text-xl" 30 | , "font-medium" 31 | , "leading-loose" 32 | , "flex" 33 | , "items-center" 34 | , "mb-6" 35 | ] 36 | 37 | subHeadingDarkClasses :: Array HH.ClassName 38 | subHeadingDarkClasses = subHeadingClasses <> 39 | ( HH.ClassName <$> 40 | [ "text-white" 41 | ] 42 | ) 43 | 44 | contentHeadingClasses :: Array HH.ClassName 45 | contentHeadingClasses = HH.ClassName <$> 46 | [ "mb-6" 47 | , "text-lg" 48 | , "font-normal" 49 | , "leading-loose" 50 | , "flex" 51 | , "items-center" 52 | ] 53 | 54 | captionClasses :: Array HH.ClassName 55 | captionClasses = HH.ClassName <$> 56 | [ "block" 57 | , "font-light" 58 | , "mb-6" 59 | , "text-grey-70" 60 | , "text-sm" 61 | , "tracking-wide" 62 | , "uppercase" 63 | ] 64 | 65 | linkClasses :: Array HH.ClassName 66 | linkClasses = HH.ClassName <$> 67 | [ "text-blue-75" 68 | , "hover:text-blue-65" 69 | , "no-underline" 70 | , "font-medium" 71 | , "cursor-pointer" 72 | ] 73 | 74 | linkDarkClasses :: Array HH.ClassName 75 | linkDarkClasses = HH.ClassName <$> 76 | [ "text-grey-light" 77 | , "hover:text-grey-lighter" 78 | , "no-underline" 79 | , "font-medium" 80 | , "cursor-pointer" 81 | ] 82 | 83 | mutedClasses :: Array HH.ClassName 84 | mutedClasses = HH.ClassName <$> 85 | [ "text-grey-50" 86 | ] 87 | 88 | pClasses :: Array HH.ClassName 89 | pClasses = HH.ClassName <$> 90 | [ "mb-6" 91 | ] 92 | 93 | heading 94 | :: ∀ p i 95 | . Array (HH.IProp HTMLh1 i) 96 | -> Array (HH.HTML p i) 97 | -> HH.HTML p i 98 | heading iprops = 99 | HH.h1 100 | ( [ HP.classes headingClasses ] <&> iprops ) 101 | 102 | heading_ 103 | :: ∀ p i 104 | . Array (HH.HTML p i) 105 | -> HH.HTML p i 106 | heading_ = heading [] 107 | 108 | headingDark 109 | :: ∀ p i 110 | . Array (HH.IProp HTMLh1 i) 111 | -> Array (HH.HTML p i) 112 | -> HH.HTML p i 113 | headingDark iprops = 114 | HH.h1 115 | ( [ HP.classes headingDarkClasses ] <&> iprops ) 116 | 117 | headingDark_ 118 | :: ∀ p i 119 | . Array (HH.HTML p i) 120 | -> HH.HTML p i 121 | headingDark_ = headingDark [] 122 | 123 | subHeading 124 | :: ∀ p i 125 | . Array (HH.IProp HTMLh2 i) 126 | -> Array (HH.HTML p i) 127 | -> HH.HTML p i 128 | subHeading iprops html = 129 | HH.h2 130 | ( [ HP.classes subHeadingClasses ] <&> iprops ) 131 | html 132 | 133 | subHeading_ 134 | :: ∀ p i 135 | . Array (HH.HTML p i) 136 | -> HH.HTML p i 137 | subHeading_ = subHeading [] 138 | 139 | subHeadingDark 140 | :: ∀ p i 141 | . Array (HH.IProp HTMLh2 i) 142 | -> Array (HH.HTML p i) 143 | -> HH.HTML p i 144 | subHeadingDark iprops = 145 | HH.h2 146 | ( [ HP.classes subHeadingDarkClasses ] <&> iprops ) 147 | 148 | subHeadingDark_ 149 | :: ∀ p i 150 | . Array (HH.HTML p i) 151 | -> HH.HTML p i 152 | subHeadingDark_ = subHeadingDark [] 153 | 154 | contentHeading 155 | :: ∀ p i 156 | . Array (HH.IProp HTMLh3 i) 157 | -> Array (HH.HTML p i) 158 | -> HH.HTML p i 159 | contentHeading iprops = 160 | HH.h3 161 | ( [ HP.classes contentHeadingClasses ] <&> iprops ) 162 | 163 | contentHeading_ 164 | :: ∀ p i 165 | . Array (HH.HTML p i) 166 | -> HH.HTML p i 167 | contentHeading_ = contentHeading [] 168 | 169 | caption 170 | :: ∀ p i 171 | . Array (HH.IProp HTMLh4 i) 172 | -> Array (HH.HTML p i) 173 | -> HH.HTML p i 174 | caption iprops = 175 | HH.h4 176 | ( [ HP.classes captionClasses ] <&> iprops ) 177 | 178 | caption_ 179 | :: ∀ p i 180 | . Array (HH.HTML p i) 181 | -> HH.HTML p i 182 | caption_ = caption [] 183 | 184 | p 185 | :: ∀ p i 186 | . Array (HH.IProp HTMLp i) 187 | -> Array (HH.HTML p i) 188 | -> HH.HTML p i 189 | p iprops = 190 | HH.p 191 | ( [ HP.classes pClasses ] <&> iprops ) 192 | 193 | p_ 194 | :: ∀ p i 195 | . Array (HH.HTML p i) 196 | -> HH.HTML p i 197 | p_ = p [] 198 | -------------------------------------------------------------------------------- /src/DemoApp/Ocelot/Blocks/Radio.purs: -------------------------------------------------------------------------------- 1 | module Ocelot.Block.Radio where 2 | 3 | import Prelude 4 | 5 | import DOM.HTML.Indexed (HTMLinput, HTMLlabel) 6 | import DOM.HTML.Indexed.InputType (InputType(InputRadio)) 7 | import Halogen.HTML as HH 8 | import Halogen.HTML.Properties as HP 9 | import Ocelot.HTML.Properties ((<&>)) 10 | 11 | labelClasses :: Array HH.ClassName 12 | labelClasses = HH.ClassName <$> 13 | [ "flex" 14 | , "flex-row" 15 | , "inline-block" 16 | , "py-2" 17 | , "cursor-pointer" 18 | , "text-black-20" 19 | , "items-center" 20 | , "text-left" -- styles get messed up otherwise 21 | ] 22 | 23 | inputClasses :: Array HH.ClassName 24 | inputClasses = HH.ClassName <$> 25 | [ "!disabled:sibling:bg-white" 26 | , "disabled:sibling:bg-grey-95" 27 | , "checked:sibling:before:opacity-100" 28 | , "checked:sibling:before:scale-1" 29 | , "checked:!disabled:sibling:border-blue-88" 30 | , "focus:sibling:border-blue-88" 31 | , "!checked:sibling:before:opacity-0" 32 | , "!checked:sibling:before:scale-0" 33 | , "!focus:hover:!checked:!disabled:sibling:border-grey-70" 34 | , "focus:sibling:shadow" 35 | , "checked:!disabled:sibling:before:bg-blue-88" 36 | , "checked:disabled:sibling:before:bg-grey-80" 37 | , "checked:disabled:sibling:border-grey-80" 38 | , "offscreen" 39 | ] 40 | 41 | radioClasses :: Array HH.ClassName 42 | radioClasses = HH.ClassName <$> 43 | [ "inline-flex" 44 | , "justify-center" 45 | , "items-center" 46 | , "content-box" 47 | , "border-2" 48 | , "border-solid" 49 | , "h-4" 50 | , "w-4" 51 | , "p-1" 52 | , "flex-none" 53 | , "no-content" 54 | , "rounded-full" 55 | , "mr-3" 56 | , "before:transition-1/4-bounce" 57 | , "before:h-full" 58 | , "before:w-full" 59 | , "before:bg-blue-88" 60 | , "before:no-content" 61 | , "before:rounded-full" 62 | , "before:shadow" 63 | ] 64 | 65 | radio 66 | :: ∀ p i 67 | . Array (HH.IProp HTMLlabel i) 68 | -> Array (HH.IProp HTMLinput i) 69 | -> Array (HH.HTML p i) 70 | -> HH.HTML p i 71 | radio iprops inprops html = 72 | HH.label 73 | ( [ HP.classes labelClasses ] <&> iprops ) 74 | ( [ HH.input 75 | ( [ HP.classes inputClasses 76 | , HP.type_ InputRadio 77 | ] <&> inprops 78 | ) 79 | , HH.span [ HP.classes radioClasses ] [] 80 | ] 81 | <> html 82 | ) 83 | 84 | radio_ 85 | :: ∀ p i 86 | . Array (HH.IProp HTMLinput i) 87 | -> Array (HH.HTML p i) 88 | -> HH.HTML p i 89 | radio_ = radio [] 90 | -------------------------------------------------------------------------------- /src/DemoApp/Ocelot/Blocks/Table.purs: -------------------------------------------------------------------------------- 1 | module Ocelot.Block.Table where 2 | 3 | import Prelude 4 | 5 | import DOM.HTML.Indexed (HTMLtable, HTMLtd, HTMLth, HTMLtr) 6 | import Halogen.HTML (HTML, IProp) 7 | import Halogen.HTML as HH 8 | import Ocelot.Block.Builder (blockBuilder) 9 | 10 | tableClasses :: Array HH.ClassName 11 | tableClasses = HH.ClassName <$> 12 | [ "w-full" 13 | , "text-left" 14 | , "border-collapse" 15 | ] 16 | 17 | table 18 | :: ∀ p i 19 | . Array (IProp HTMLtable i) 20 | -> Array (HTML p i) 21 | -> HTML p i 22 | table = blockBuilder HH.table tableClasses 23 | 24 | table_ 25 | :: ∀ p i 26 | . Array (HTML p i) 27 | -> HTML p i 28 | table_ = table [] 29 | 30 | row 31 | :: ∀ p i 32 | . Array (IProp HTMLtr i) 33 | -> Array (HTML p i) 34 | -> HTML p i 35 | row = HH.tr 36 | 37 | row_ 38 | :: ∀ p i 39 | . Array (HTML p i) 40 | -> HTML p i 41 | row_ = HH.tr_ 42 | 43 | headerClasses :: Array HH.ClassName 44 | headerClasses = HH.ClassName <$> 45 | [ "bg-grey-90" 46 | , "py-4" 47 | , "px-5" 48 | , "font-medium" 49 | , "text-black-20" 50 | ] 51 | 52 | header 53 | :: ∀ p i 54 | . Array (IProp HTMLth i) 55 | -> Array (HTML p i) 56 | -> HTML p i 57 | header = blockBuilder HH.th headerClasses 58 | 59 | header_ 60 | :: ∀ p i 61 | . Array (HTML p i) 62 | -> HTML p i 63 | header_ = header [] 64 | 65 | cellClasses :: Array HH.ClassName 66 | cellClasses = HH.ClassName <$> 67 | [ "bg-white" 68 | , "p-5" 69 | , "min-h-20" 70 | , "border-b" 71 | , "border-grey-95" 72 | ] 73 | 74 | cell 75 | :: ∀ p i 76 | . Array (IProp HTMLtd i) 77 | -> Array (HTML p i) 78 | -> HTML p i 79 | cell = blockBuilder HH.td cellClasses 80 | 81 | cell_ 82 | :: ∀ p i 83 | . Array (HTML p i) 84 | -> HTML p i 85 | cell_ = cell [] 86 | -------------------------------------------------------------------------------- /src/DemoApp/Ocelot/HTML/Properties.purs: -------------------------------------------------------------------------------- 1 | module Ocelot.HTML.Properties 2 | ( IProp(..) 3 | , appendIProps 4 | , css 5 | , extract 6 | , style 7 | , testId 8 | , (<&>) 9 | ) where 10 | 11 | import Prelude 12 | 13 | import Data.Array (elem, foldl, nubByEq) 14 | import Data.Bifunctor (lmap, rmap) 15 | import Data.String (Pattern(..), null, split) 16 | import Data.String as Data.String 17 | import Data.String.CodeUnits (length, take, drop) 18 | import Data.Tuple (Tuple(..)) 19 | import Foreign.Object as Foreign.Object 20 | import Halogen.HTML as HH 21 | import Halogen.HTML as Halogen.HTML 22 | import Halogen.HTML.Core (Prop(..), PropValue) 23 | import Halogen.HTML.Properties as HP 24 | import Halogen.HTML.Properties as Halogen.HTML.Properties 25 | import Unsafe.Coerce (unsafeCoerce) 26 | 27 | type IProp r i = HH.IProp ("class" :: String | r) i 28 | 29 | testId 30 | :: ∀ r i 31 | . String 32 | -> IProp r i 33 | testId = HP.attr (HH.AttrName "data-testid") 34 | 35 | css 36 | :: ∀ r i 37 | . String 38 | -> IProp r i 39 | css = HP.class_ <<< HH.ClassName 40 | 41 | style :: forall r i. Foreign.Object.Object String -> IProp r i 42 | style = 43 | Halogen.HTML.Properties.attr (Halogen.HTML.AttrName "style") 44 | <<< Data.String.joinWith ";" 45 | <<< Foreign.Object.foldMap 46 | (\key value -> [ key <> ":" <> value ]) 47 | 48 | appendIProps 49 | :: ∀ r i 50 | . Array (IProp r i) 51 | -> Array (IProp r i) 52 | -> Array (IProp r i) 53 | appendIProps ip ip' = 54 | iprops <> iprops' <> classNames 55 | where 56 | (Tuple classes iprops) = extract ip 57 | (Tuple classes' iprops') = extract ip' 58 | classNames = 59 | pure 60 | <<< HP.classes 61 | $ HH.ClassName 62 | <$> nubByEq 63 | (\c c' -> classify c == classify c') 64 | (classes' <> classes) 65 | 66 | infixr 5 appendIProps as <&> 67 | 68 | extract 69 | :: ∀ r i 70 | . Array (IProp r i) 71 | -> Tuple (Array String) (Array (IProp r i)) 72 | extract = 73 | foldl f (Tuple [] []) 74 | where 75 | f acc (HP.IProp (Property "className" className)) = 76 | lmap (_ <> (split (Pattern " ") $ coerceClassName className)) acc 77 | f acc iprop = rmap (_ <> [iprop]) acc 78 | 79 | coerceClassName :: PropValue -> String 80 | coerceClassName = unsafeCoerce 81 | 82 | classify 83 | :: String 84 | -> String 85 | classify str 86 | | startsWith "p" str && not null (classifySide $ drop 1 str) 87 | = "padding" <-> classifySide (drop 1 str) 88 | | startsWith "m" str && not null (classifySide $ drop 1 str) 89 | = "margin" <-> classifySide (drop 1 str) 90 | | startsWith "-m" str && not null (classifySide $ drop 2 str) 91 | = "margin" <-> classifySide (drop 2 str) 92 | | startsWith "min-" str = "min" <-> classify (drop 4 str) 93 | | startsWith "max-" str = "max" <-> classify (drop 4 str) 94 | | startsWith "w-" str = "width" 95 | | startsWith "h-" str = "height" 96 | | startsWith "overflow-" str && (classifyOverflow $ drop 9 str) /= drop 9 str 97 | = "overflow" <-> (classifyOverflow $ drop 9 str) 98 | | otherwise = str 99 | 100 | classifySide 101 | :: String 102 | -> String 103 | classifySide str 104 | | startsWith "t-" str = "top" 105 | | startsWith "r-" str = "right" 106 | | startsWith "b-" str = "bottom" 107 | | startsWith "l-" str = "left" 108 | | startsWith "x-" str = "horizontal" 109 | | startsWith "y-" str = "vertical" 110 | | startsWith "-" str = "all" 111 | | otherwise = "" 112 | 113 | classifyOverflow 114 | :: String 115 | -> String 116 | classifyOverflow str 117 | | startsWith "x-" str = "horizontal" <-> (classifyOverflow $ drop 2 str) 118 | | startsWith "y-" str = "vertical" <-> (classifyOverflow $ drop 2 str) 119 | | elem str ["auto", "hidden", "visible", "scroll"] = "" 120 | | otherwise = str 121 | 122 | append' 123 | :: String 124 | -> String 125 | -> String 126 | append' x "" = x 127 | append' x y = x <> "-" <> y 128 | 129 | infixr 5 append' as <-> 130 | 131 | -- | WARN: Not tested, written during 0.12 migration 132 | startsWith 133 | :: String 134 | -> String 135 | -> Boolean 136 | startsWith str0 str1 = str0 == (take (length str0) str1) 137 | -------------------------------------------------------------------------------- /src/DemoApp/Ocelot/ui-guide/Backdrop.purs: -------------------------------------------------------------------------------- 1 | module UIGuide.Block.Backdrop where 2 | 3 | import Prelude 4 | 5 | import DOM.HTML.Indexed (HTMLdiv) 6 | import Halogen.HTML as HH 7 | import Halogen.HTML.Properties as HP 8 | import Ocelot.HTML.Properties ((<&>)) 9 | 10 | 11 | backdropClasses :: Array HH.ClassName 12 | backdropClasses = HH.ClassName <$> 13 | [ "p-6" 14 | , "flex" 15 | , "flex-1" 16 | ] 17 | 18 | backdropDefaultClasses :: Array HH.ClassName 19 | backdropDefaultClasses = backdropClasses <> 20 | ( HH.ClassName <$> 21 | [ "bg-grey-95" 22 | ] 23 | ) 24 | 25 | backdropWhiteClasses :: Array HH.ClassName 26 | backdropWhiteClasses = backdropClasses <> 27 | ( HH.ClassName <$> 28 | [ "bg-white" 29 | ] 30 | ) 31 | 32 | backdropDarkClasses :: Array HH.ClassName 33 | backdropDarkClasses = backdropClasses <> 34 | ( HH.ClassName <$> 35 | [ "bg-black" 36 | , "text-grey-lighter" 37 | ] 38 | ) 39 | 40 | contentClasses :: Array HH.ClassName 41 | contentClasses = HH.ClassName <$> 42 | [ "flex-1" 43 | , "mx-6" 44 | , "mt-6" 45 | ] 46 | 47 | backdrop 48 | :: ∀ p i 49 | . Array (HH.IProp HTMLdiv i) 50 | -> Array (HH.HTML p i) 51 | -> HH.HTML p i 52 | backdrop iprops html = 53 | HH.div 54 | ( [ HP.classes backdropDefaultClasses ] <&> iprops ) 55 | html 56 | 57 | backdrop_ 58 | :: ∀ p i 59 | . Array (HH.HTML p i) 60 | -> HH.HTML p i 61 | backdrop_ = backdrop [] 62 | 63 | backdropWhite 64 | :: ∀ p i 65 | . Array (HH.IProp HTMLdiv i) 66 | -> Array (HH.HTML p i) 67 | -> HH.HTML p i 68 | backdropWhite iprops html = 69 | HH.div 70 | ( [ HP.classes backdropWhiteClasses ] <&> iprops ) 71 | html 72 | 73 | backdropWhite_ 74 | :: ∀ p i 75 | . Array (HH.HTML p i) 76 | -> HH.HTML p i 77 | backdropWhite_ = backdropWhite [] 78 | 79 | backdropDark 80 | :: ∀ p i 81 | . Array (HH.IProp HTMLdiv i) 82 | -> Array (HH.HTML p i) 83 | -> HH.HTML p i 84 | backdropDark iprops html = 85 | HH.div 86 | ( [ HP.classes backdropDarkClasses ] <&> iprops ) 87 | html 88 | 89 | backdropDark_ 90 | :: ∀ p i 91 | . Array (HH.HTML p i) 92 | -> HH.HTML p i 93 | backdropDark_ = backdropDark [] 94 | 95 | content 96 | :: ∀ p i 97 | . Array (HH.IProp HTMLdiv i) 98 | -> Array (HH.HTML p i) 99 | -> HH.HTML p i 100 | content iprops html = 101 | HH.div 102 | ( [ HP.classes contentClasses ] <&> iprops ) 103 | html 104 | 105 | content_ 106 | :: ∀ p i 107 | . Array (HH.HTML p i) 108 | -> HH.HTML p i 109 | content_ = content [] 110 | -------------------------------------------------------------------------------- /src/DemoApp/Snippets.purs: -------------------------------------------------------------------------------- 1 | module Snippets where 2 | 3 | import Prelude 4 | 5 | import Affjax.Web (printError) 6 | import Affjax.Web as AJAX 7 | import Affjax.ResponseFormat as ResponseFormat 8 | import Control.Monad.State (class MonadState) 9 | import Data.Either (Either(..)) 10 | import Debug (spy) 11 | import Effect.Aff (Aff) 12 | import Effect.Aff.Class (class MonadAff) 13 | import Effect.Aff.Class as H 14 | import Halogen.HTML as HH 15 | import Halogen.HTML.Properties as HP 16 | import Html.Renderer.Halogen as RH 17 | import Stories.Utilities (highlightString_) 18 | 19 | data Cell state w i = 20 | Blurb String 21 | | SnippetFile String -- could analyse the extension here and choose highlighter? 22 | | Snippet { file :: String, text :: String, language :: String } 23 | | PreRendered (HH.HTML w i) 24 | | RenderWithState (state -> HH.HTML w i) 25 | 26 | type Notebook state w i = Array (Cell state w i) 27 | 28 | renderNotebook :: forall state w i. state -> Notebook state w i -> Array (HH.HTML w i) 29 | renderNotebook state notebook = (renderCell state) <$> notebook 30 | 31 | renderNotebook_ :: forall w i. Notebook Unit w i -> Array (HH.HTML w i) 32 | renderNotebook_ notebook = (renderCell unit) <$> notebook 33 | 34 | renderCell :: forall state w i. state -> Cell state w i -> HH.HTML w i 35 | renderCell _ (Blurb b) = 36 | HH.p [ HP.classes [ HH.ClassName "m-2" ] ] 37 | [ HH.text b ] 38 | renderCell _ (Snippet s) = 39 | HH.pre [ HP.class_ $ HH.ClassName s.language ] 40 | [ HH.code_ [ RH.render_ $ highlightString_ s.text ] ] 41 | 42 | renderCell _ (SnippetFile filename) = 43 | HH.p [ HP.classes [ HH.ClassName "m-2" ] ] 44 | [ HH.text $ "Snippet file not loaded: " <> filename <> " Did you remember to call substituteSnippetCells on your Notebook?"] 45 | 46 | renderCell _ (PreRendered html) = html 47 | 48 | renderCell state (RenderWithState fn) = fn state 49 | 50 | substituteSnippetCells :: forall w i m state state'. Bind m => MonadAff m => MonadState state m => 51 | Cell state' w i -> m (Cell state' w i) 52 | substituteSnippetCells (SnippetFile snippet) = do -- TODO check extension to get language setting 53 | snippetText <- H.liftAff $ readSnippetFiles snippet 54 | pure $ Snippet { file: snippet, text: snippetText, language: "language-purescript" } -- REVIEW lang is hardwired here 55 | substituteSnippetCells cell = pure cell -- no change to other cells 56 | 57 | readSnippetFiles :: String -> Aff String 58 | readSnippetFiles name = do 59 | response <- AJAX.get ResponseFormat.string $ "./code-examples/" <> name 60 | case response of 61 | (Left err) -> spy "couldn't read snippet, error: " $ pure (printError err) 62 | (Right r) -> spy "read snippet: " $ pure r.body 63 | -------------------------------------------------------------------------------- /src/DemoApp/Stories/Index.purs: -------------------------------------------------------------------------------- 1 | module Stories.Index where 2 | 3 | import Prelude 4 | 5 | import Halogen as H 6 | import Halogen.HTML as HH 7 | import Halogen.HTML.Properties as HP 8 | 9 | type State = Unit 10 | 11 | initialState :: State 12 | initialState = unit 13 | 14 | render :: forall m. State -> H.ComponentHTML Void () m 15 | render state = 16 | HH.div_ 17 | [ HH.h3_ 18 | [ HH.text "PureScript DSL for Data Driven Interfaces" ] 19 | , HH.p_ 20 | [ HH.text "See " 21 | , HH.a 22 | [ HP.href "https://github.com/rnons/purescript-halogen-storybook" ] 23 | [ HH.text "README" ] 24 | , HH.text " for details." 25 | ] 26 | ] 27 | 28 | component :: forall q m. H.Component q Unit Void m 29 | component = H.mkComponent 30 | { initialState: const initialState 31 | , render 32 | , eval: H.mkEval $ H.defaultEval 33 | } 34 | -------------------------------------------------------------------------------- /src/DemoApp/Stories/Spago/Actions.purs: -------------------------------------------------------------------------------- 1 | module Stories.Spago.Actions where 2 | 3 | 4 | import D3.Attributes.Instances (Label) 5 | import D3.Data.Tree (TreeLayout) 6 | import D3.Data.Types (Datum_) 7 | import D3.Examples.Spago.Draw.Attributes (SpagoSceneAttributes) 8 | import D3.Examples.Spago.Files (NodeType, SpagoGraphLinkID) 9 | import D3.Examples.Spago.Model (SpagoSimNode) 10 | import D3.Node (NodeID) 11 | import D3.Simulation.Types (SimVariable) 12 | 13 | data Scene = PackageGrid | PackageGraph | ModuleTree TreeLayout | LayerSwarm 14 | data StyleChange = TopLevelCSS String | GraphStyle SpagoSceneAttributes 15 | data FilterData = LinkShowFilter (SpagoGraphLinkID -> Boolean) 16 | | LinkForceFilter (Datum_ -> Boolean) -- because this is post- putting in the DOM, it's a filter on the opaque type 17 | | NodeFilter (SpagoSimNode -> Boolean) 18 | data Action 19 | = Initialize 20 | | Finalize 21 | | Scene Scene 22 | | ToggleForce Label 23 | | Filter FilterData 24 | | ChangeStyling StyleChange 25 | | ChangeSimConfig SimVariable 26 | | StopSim 27 | | StartSim 28 | | EventFromVizualization VizEvent 29 | | ToggleChildrenOfNode NodeID 30 | | SpotlightNode NodeID 31 | | UnToggleChildrenOfNode NodeID 32 | 33 | data VizEvent = NodeClick NodeType NodeID 34 | -- to be added: 35 | -- | DragFinished 36 | -- | LinkClick 37 | -- and whatever other events are meaningful in terms of the graphics objects and DOM events on them -------------------------------------------------------------------------------- /src/DemoApp/Stories/Spago/Forces.purs: -------------------------------------------------------------------------------- 1 | module Stories.Spago.Forces where 2 | 3 | import Prelude 4 | 5 | import D3.Attributes.Instances (Label) 6 | import D3.Examples.Spago.Model (datum_) 7 | import D3.Simulation.Config as F 8 | import D3.Simulation.Forces (createForce, createLinkForce, initialize) 9 | import D3.Simulation.Types (Force, ForceFilter(..), ForceType(..), RegularForceType(..), allNodes) 10 | import Data.Int (toNumber) 11 | import Data.Map (Map) 12 | import Data.Maybe (Maybe(..)) 13 | import Data.Number (infinity) 14 | 15 | -- | table of all the forces that are used in the Spago component 16 | forceLibrary :: Map Label Force 17 | forceLibrary = initialize [ 18 | createForce "center" (RegularForce ForceCenter) allNodes [ F.strength 0.5, F.x 0.0, F.y 0.0 ] 19 | , createForce "x" (RegularForce ForceX) allNodes [ F.strength 0.05, F.x 0.0 ] 20 | , createForce "y" (RegularForce ForceY) allNodes [ F.strength 0.07, F.y 0.0 ] 21 | 22 | , createForce "collide1" (RegularForce ForceCollide) allNodes [ F.strength 1.0, F.radius datum_.collideRadius ] 23 | , createForce "collide2" (RegularForce ForceCollide) allNodes [ F.strength 0.7, F.radius datum_.collideRadiusBig ] 24 | , createForce "charge1" (RegularForce ForceManyBody) allNodes [ F.strength (-50.0), F.theta 0.9, F.distanceMin 1.0, F.distanceMax infinity ] 25 | , createForce "charge2" (RegularForce ForceManyBody) allNodes [ F.strength (-100.0), F.theta 0.9, F.distanceMin 1.0, F.distanceMax 400.0 ] 26 | , createForce "chargetree" (RegularForce ForceManyBody) treeExceptLeaves [ F.strength (-100.0), F.theta 0.9, F.distanceMin 1.0, F.distanceMax 400.0 ] 27 | 28 | , createForce "clusterx_M" (RegularForce ForceX) modulesOnly [ F.strength 0.2, F.x datum_.gridPointX ] 29 | , createForce "clustery_M" (RegularForce ForceY) modulesOnly [ F.strength 0.2, F.y datum_.gridPointY ] 30 | 31 | , createForce "clusterx_P" (RegularForce ForceX) packagesOnly [ F.strength 0.8, F.x datum_.gridPointX ] 32 | , createForce "clustery_P" (RegularForce ForceY) packagesOnly [ F.strength 0.8, F.y datum_.gridPointY ] 33 | 34 | , createForce "htreeNodesX" (RegularForce ForceX) (Just $ ForceFilter "tree only" \d -> datum_.connected d) 35 | [ F.strength 0.4, F.x datum_.treePointX ] 36 | , createForce "htreeNodesY" (RegularForce ForceY) (Just $ ForceFilter "tree only" \d -> datum_.connected d) 37 | [ F.strength 0.4, F.y datum_.treePointY ] 38 | , createForce "vtreeNodesX" (RegularForce ForceX) (Just $ ForceFilter "tree only" \d -> datum_.connected d) 39 | [ F.strength 0.4, F.x datum_.treePointY ] 40 | , createForce "vtreeNodesY" (RegularForce ForceY) (Just $ ForceFilter "tree only" \d -> datum_.connected d) 41 | [ F.strength 0.4, F.y datum_.treePointX ] 42 | 43 | , createForce "packageOrbit" (RegularForce ForceRadial) packagesOnly 44 | [ F.strength 0.7, F.x 0.0, F.y 0.0, F.radius 500.0 ] 45 | , createForce "unusedOrbit" (RegularForce ForceRadial) unusedModulesOnly 46 | [ F.strength 0.8, F.x 0.0, F.y 0.0, F.radius 900.0 ] 47 | , createForce "moduleOrbit" (RegularForce ForceRadial) usedModulesOnly 48 | [ F.strength 0.8, F.x 0.0, F.y 0.0, F.radius 600.0 ] 49 | 50 | , createLinkForce Nothing [ F.strength 0.5, F.distance 0.0, F.numKey (toNumber <<< datum_.id) ] 51 | ] 52 | where 53 | packagesOnly = Just $ ForceFilter "all packages" datum_.isPackage 54 | modulesOnly = Just $ ForceFilter "all modules" datum_.isModule 55 | unusedModulesOnly = Just $ ForceFilter "unused modules only" datum_.isUnusedModule 56 | usedModulesOnly = Just $ ForceFilter "used modules only" datum_.isUsedModule 57 | treeExceptLeaves = Just $ ForceFilter "tree parent nodes only" datum_.isTreeParent 58 | 59 | useGridXY d _ = datum_.gridPoint d 60 | centerXY _ _ = { x: 0.0, y: 0.0 } 61 | treeXY d _ = datum_.treePoint d 62 | 63 | -- | NOTES 64 | 65 | -- gridForceSettings :: Array String 66 | -- gridForceSettings = [ "packageGrid", "clusterx", "clustery", "collide1" ] 67 | 68 | -- gridForceSettings2 :: Array String 69 | -- gridForceSettings2 = [ "center", "collide2", "x", "y" ] 70 | 71 | -- packageForceSettings :: Array String 72 | -- packageForceSettings = [ "centerNamedNode", "center", "collide2", "charge2", "links"] 73 | 74 | -- treeForceSettings :: Array String 75 | -- treeForceSettings = ["links", "center", "charge1", "collide1" ] 76 | 77 | -- these are the force settings for the force-layout radial tree in Observables 78 | -- .force("link", d3.forceLink(links).id(d => d.id).distance(0).strength(1)) 79 | -- .force("charge", d3.forceManyBody().strength(-50)) 80 | -- .force("x", d3.forceX()) 81 | -- .force("y", d3.forceY()); 82 | 83 | -------------------------------------------------------------------------------- /src/DemoApp/Stories/Spago/Lenses.purs: -------------------------------------------------------------------------------- 1 | module Stories.Spago.Lenses where 2 | 3 | 4 | import Data.Lens (Lens') 5 | import Data.Lens.Record (prop) 6 | import Type.Proxy (Proxy(..)) 7 | 8 | -- chooseSimNodes :: (SpagoSimNode -> Boolean) -> State -> Maybe (Array SpagoSimNode) 9 | -- chooseSimNodes fn state = filter fn <$> preview _modelNodes state 10 | 11 | -- chooseSimLinks :: (SpagoGraphLinkID -> Boolean) -> State -> Maybe (Array SpagoGraphLinkID) 12 | -- chooseSimLinks fn state = filter fn <$> preview _modelLinks state 13 | 14 | -- COMPOSITIONs of optics 15 | 16 | -- -- BOILERPLATE record field accessors 17 | -- _selections :: forall a r. Lens' { selections :: a | r } a 18 | -- _selections = prop (Proxy :: Proxy "selections") 19 | 20 | -- _data :: forall a r. Lens' { "data" :: a | r } a 21 | -- _data = prop (Proxy :: Proxy "data") 22 | 23 | -- _graph :: forall a r. Lens' { graph :: a | r } a 24 | -- _graph = prop (Proxy :: Proxy "graph") 25 | 26 | -- _tree :: forall a r. Lens' { tree :: a | r } a 27 | -- _tree = prop (Proxy :: Proxy "tree") 28 | 29 | -- _maps :: forall a r. Lens' { maps :: a | r } a 30 | -- _maps = prop (Proxy :: Proxy "maps") 31 | 32 | -- _key :: forall a r. Lens' { key :: a | r } a 33 | -- _key = prop (Proxy :: Proxy "key") 34 | 35 | 36 | 37 | -- _inSim :: forall a r. Lens' { simDataCooked :: a | r } a 38 | -- _inSim = prop (Proxy :: Proxy "simDataCooked") 39 | 40 | -- _forces :: forall a r. Lens' { activeForces :: a | r } a 41 | -- _forces = prop (Proxy :: Proxy "activeForces") 42 | 43 | 44 | -- _nodesForSim :: forall p. 45 | -- Strong p 46 | -- => Choice p 47 | -- => p (Array SpagoSimNode) (Array SpagoSimNode) 48 | -- -> p State State 49 | -- _nodesForSim = _forSim <<< _Just <<< _data <<< _nodes 50 | 51 | -- _linksForSim :: forall p. 52 | -- Strong p 53 | -- => Choice p 54 | -- => p (Array SpagoGraphLinkID) (Array SpagoGraphLinkID) 55 | -- -> p State State 56 | -- _linksForSim = _forSim <<< _Just <<< _data <<< _links 57 | 58 | -- _nodesInSim :: forall p. 59 | -- Strong p 60 | -- => Choice p 61 | -- => p (Array SpagoSimNode) (Array SpagoSimNode) 62 | -- -> p State State 63 | -- _nodesInSim = _inSim <<< _Just <<< _data <<< _nodes 64 | 65 | -- _linksInSim :: forall t378 p t394 t397. 66 | -- Strong p => 67 | -- Choice p => 68 | -- p (Array SpagoGraphLinkRecord) (Array SpagoGraphLinkRecord) -> 69 | -- p { simDataCooked :: Maybe { "data" :: { links :: (Array SpagoGraphLinkRecord) | t397 } | t394 } | t378 } 70 | -- { simDataCooked :: Maybe { "data" :: { links :: (Array SpagoGraphLinkRecord) | t397 } | t394 } | t378 } 71 | -- _linksInSim = _inSim <<< _Just <<< _data <<< _links 72 | 73 | -- _countDataNodes :: State -> Int 74 | -- _countDataNodes state = length $ fromMaybe [] $ preview _nodesInSim state 75 | 76 | -- _countDataLinks :: State -> Int 77 | -- _countDataLinks state = length $ fromMaybe [] $ preview _linksInSim state 78 | 79 | -- _nodeSelection :: forall p. 80 | -- Strong p 81 | -- => Choice p 82 | -- => p D3Selection_ D3Selection_ 83 | -- -> p State State 84 | -- _nodeSelection = _inSim <<< _Just <<< _selections <<< _nodes 85 | 86 | -- _linksShown :: forall p. 87 | -- Strong p 88 | -- => Choice p 89 | -- => p D3Selection_ D3Selection_ 90 | -- -> p State State 91 | -- _linksShown = _inSim <<< _Just <<< _selections <<< _links 92 | -- _forSim :: forall a r. Lens' { Staging :: a | r } a 93 | -- _forSim = prop (Proxy :: Proxy "Staging") 94 | 95 | -- _state :: forall a r. Lens' { simulationState :: a | r } a 96 | -- _state = prop (Proxy :: Proxy "simulationState") 97 | 98 | -- BOILERPLATE - getters and setters 99 | -- _nodeSelectionGet :: State -> Maybe D3Selection_ 100 | -- _nodeSelectionGet = preview _nodeSelection 101 | 102 | -- _nodeSelectionSet :: (D3Selection_ -> D3Selection_) -> State -> State 103 | -- _nodeSelectionSet = over _nodeSelection 104 | 105 | -- _linksShownGet :: State -> Maybe D3Selection_ 106 | -- _linksShownGet = preview _linksShown 107 | 108 | -- _linksShownSet :: (D3Selection_ -> D3Selection_) -> State -> State 109 | -- _linksShownSet = over _linksShown 110 | 111 | -- _nodeDataGet :: State -> Maybe (Array SpagoSimNode) 112 | -- _nodeDataGet = preview _dataNodes 113 | 114 | -- _nodeDataSet :: (Array SpagoSimNode -> Array SpagoSimNode) -> State -> State 115 | -- _nodeDataSet = over _dataNodes 116 | 117 | -- _linkDataGet :: State -> Maybe (Array (D3LinkSwizzled SpagoSimNode SpagoLinkData)) 118 | -- _linkDataGet :: State -> Maybe (Array SpagoGraphLinkID) 119 | -- _linkDataGet = preview _dataLinks 120 | 121 | -- _linkDataSet :: (Array (D3LinkSwizzled SpagoSimNode SpagoLinkData) -> Array (D3LinkSwizzled SpagoSimNode SpagoLinkData)) -> State -> State 122 | -- _linkDataSet = over _dataLinks 123 | -------------------------------------------------------------------------------- /src/DemoApp/Stories/ThreeLittleCircles.purs: -------------------------------------------------------------------------------- 1 | module Stories.ThreeLittleCircles where 2 | 3 | import Prelude 4 | 5 | import Control.Monad.State (class MonadState, modify_) 6 | import D3.Examples.ThreeLittleCircles as Circles 7 | import D3Tagless.Block.Button as Button 8 | import D3Tagless.Block.Expandable as Expandable 9 | import D3Tagless.Block.FormField as FormField 10 | import D3Tagless.Block.Toggle as Toggle 11 | import D3Tagless.Instance.Selection (eval_D3M) 12 | import D3Tagless.Utility (removeExistingSVG) 13 | import Data.Lens (Lens', view, (%=), (.=)) 14 | import Data.Lens.Record (prop) 15 | import Data.Maybe (Maybe(..)) 16 | import Data.Traversable (traverse) 17 | import Effect.Aff.Class (class MonadAff) 18 | import Halogen as H 19 | import Halogen.HTML as HH 20 | import Halogen.HTML.Events as HE 21 | import Halogen.HTML.Properties as HP 22 | import Snippets (Cell(..), Notebook, renderNotebook_, substituteSnippetCells) 23 | import Stories.Utilities as Utils 24 | import Type.Proxy (Proxy(..)) 25 | 26 | data Action 27 | = Initialize 28 | | Finalize 29 | | ToggleCard (Lens' State Expandable.Status) 30 | | ToggleExample 31 | 32 | type State = { 33 | toggle :: Boolean -- Toggle between ultra simple and merely super-simple examples 34 | , code :: Expandable.Status 35 | , notebooks :: forall w. { simple :: Notebook Unit w Action, parabola :: Notebook Unit w Action} 36 | } 37 | 38 | -- some lenses definitions to make setting and using the snippet easier 39 | _code = prop (Proxy :: Proxy "code") 40 | _notebooks = prop (Proxy :: Proxy "notebooks") 41 | _simple = _notebooks <<< prop (Proxy :: Proxy "simple") 42 | _parabola = _notebooks <<< prop (Proxy :: Proxy "parabola") 43 | 44 | component :: forall query output m. MonadAff m => H.Component query Unit output m 45 | component = H.mkComponent 46 | { initialState: const initialState 47 | , render 48 | , eval: H.mkEval $ H.defaultEval 49 | { handleAction = handleAction 50 | , initialize = Just Initialize 51 | , finalize = Just Finalize } 52 | } 53 | where 54 | 55 | initialState :: State 56 | initialState = { 57 | toggle: true 58 | , code: Expandable.Expanded 59 | , notebooks: { simple, parabola } 60 | } 61 | 62 | render :: State -> H.ComponentHTML Action () m 63 | render state = 64 | HH.div [ Utils.tailwindClass "story-container" ] 65 | [ HH.div 66 | [ Utils.tailwindClass "story-panel-code"] 67 | [ FormField.field_ 68 | { label: HH.text "(hide this panel if screen too small)" 69 | , helpText: [] 70 | , error: [] 71 | , inputId: "show-code" 72 | } 73 | [ Toggle.toggle 74 | [ HP.id "show-code" 75 | , HP.checked 76 | $ Expandable.toBoolean state.code 77 | , HE.onChange \_ -> ToggleCard _code 78 | ] 79 | ] 80 | , Expandable.content_ state.code $ 81 | if state.toggle 82 | then renderNotebook_ (view _simple state) 83 | else renderNotebook_ (view _parabola state) 84 | ] 85 | , HH.div [ Utils.tailwindClass "svg-container" ] [] 86 | ] 87 | 88 | handleAction :: forall m. Bind m => MonadAff m => MonadState State m => 89 | Action -> m Unit 90 | handleAction = case _ of 91 | ToggleCard _cardState -> _cardState %= not 92 | 93 | Initialize -> do 94 | simple' <- traverse substituteSnippetCells simple 95 | _simple .= simple' 96 | parabola' <- traverse substituteSnippetCells parabola 97 | _parabola .= parabola' 98 | _ <- H.liftEffect $ eval_D3M $ Circles.drawThreeCircles "div.svg-container" 99 | pure unit 100 | 101 | ToggleExample -> do 102 | toggle <- H.gets _.toggle 103 | let toggle' = not toggle 104 | container = "div.svg-container" 105 | void $ H.liftEffect $ eval_D3M $ removeExistingSVG container 106 | void $ H.liftEffect $ eval_D3M $ 107 | if toggle' 108 | then Circles.drawThreeCircles container 109 | else Circles.drawWithData [310, 474, 613, 726, 814, 877, 914, 926, 914, 877, 814, 726, 613, 474, 310] container 110 | modify_ (\s -> s { toggle = toggle' }) 111 | 112 | Finalize -> pure unit 113 | 114 | -- simple :: forall w i. Notebook w i 115 | simple :: forall w. Notebook Unit w Action 116 | simple = [ 117 | Blurb "Simplest possible example, just to show syntax." 118 | , SnippetFile "TLCSimple" 119 | , Blurb "Click the button to see a slightly more realistic example." 120 | , PreRendered $ 121 | Button.buttonVertical 122 | [ HE.onClick $ const ToggleExample ] 123 | [ HH.text "Simple" ] 124 | ] 125 | 126 | parabola :: forall w. Notebook Unit w Action 127 | parabola = [ 128 | Blurb "This extends the super-simple model in the direction one would go for a more real-world example." 129 | , SnippetFile "TLCParabola" 130 | 131 | , Blurb """In this example, the data is passed in and must match the type 132 | specified in the Model. Because the data loses its type information when 133 | put into D3 we recover the type of Datum and Index using a couple of 134 | functions to wrap unsafeCoerce. These functions are then used to write 135 | any attribute setters that are derived from the data elements themselves, 136 | or their indices""" 137 | 138 | , SnippetFile "TLCDatum_" 139 | 140 | , Blurb """Again, we're just showing syntax and shape of the DSL here: it's still extremely simple, and the Model, 141 | datum_ and so on might not be needed for such a simple example.""" 142 | 143 | , PreRendered $ 144 | Button.buttonVertical 145 | [ HE.onClick $ const ToggleExample ] 146 | [ HH.text "Parabola" ] 147 | ] 148 | -------------------------------------------------------------------------------- /src/DemoApp/Stories/Types.purs: -------------------------------------------------------------------------------- 1 | module D3Tagless.App.Routes.Types where 2 | 3 | import Prelude 4 | 5 | import D3.Simulation.Types (D3SimulationState_) 6 | import Data.Const (Const) 7 | import Effect.Aff (Aff) 8 | import Halogen as H 9 | 10 | data Group 11 | = Examples 12 | | AltInterpreters 13 | | Application 14 | 15 | derive instance eqGroup :: Eq Group 16 | derive instance ordGroup :: Ord Group 17 | instance showGroup :: Show Group where 18 | show Examples = "Examples" 19 | show Application = "Application" 20 | show AltInterpreters = "Alternative interpreters" 21 | 22 | data RouteConfig = 23 | SimpleRoute { anchor :: String 24 | , component :: H.Component (Const Void) Unit Void Aff 25 | , group :: Group 26 | } 27 | | SimulationRoute { anchor :: String 28 | , component :: H.Component (Const Void) D3SimulationState_ Void Aff 29 | , group :: Group 30 | } 31 | 32 | getGroup :: RouteConfig -> Group 33 | getGroup = case _ of 34 | (SimpleRoute r ) -> r.group 35 | (SimulationRoute r ) -> r.group 36 | 37 | getAnchor :: RouteConfig -> String 38 | getAnchor = case _ of 39 | (SimpleRoute r ) -> r.anchor 40 | (SimulationRoute r ) -> r.anchor 41 | 42 | 43 | -------------------------------------------------------------------------------- /src/DemoApp/Stories/Utilities.js: -------------------------------------------------------------------------------- 1 | export function highlightBlock_(selector) { 2 | return async => { 3 | var block = document.getElementById("prism") 4 | Prism.highlightElement(block); 5 | }; 6 | } 7 | 8 | export function highlightString_(codetext) { 9 | const highlightedCode = Prism.highlight(codetext, Prism.languages.purescript, 'purescript'); 10 | return highlightedCode 11 | } -------------------------------------------------------------------------------- /src/DemoApp/Stories/Utilities.purs: -------------------------------------------------------------------------------- 1 | module Stories.Utilities where 2 | 3 | import Prelude 4 | 5 | import Data.Array (singleton) 6 | import Halogen.HTML (HTML) 7 | import Halogen.HTML as HH 8 | import Halogen.HTML.Properties as HP 9 | import Html.Renderer.Halogen as RH 10 | 11 | classed :: forall r i. String -> HP.IProp (class :: String | r) i 12 | classed = HP.class_ <<< HH.ClassName 13 | 14 | tailwindClass :: forall r i. String -> HP.IProp (class :: String | r) i 15 | tailwindClass = classed 16 | 17 | blurbParagraphs :: forall t16 t19 t20. Functor t16 => t16 String -> t16 (HTML t19 t20) 18 | blurbParagraphs texts = 19 | (HH.p [ HP.classes [ HH.ClassName "m-2" ] ]) <$> ((singleton <<< HH.text) <$> texts) 20 | 21 | syntaxHighlightedCode :: forall t2 t3. String -> Array (HTML t2 t3) 22 | syntaxHighlightedCode codetext = 23 | [ HH.pre 24 | [ HP.class_ $ HH.ClassName "language-purescript" ] 25 | [ HH.code_ [ RH.render_ $ highlightString_ codetext ] ] 26 | ] 27 | 28 | highlightBlockSynchronous :: String -> Unit 29 | highlightBlockSynchronous selector = highlightBlock_ selector false 30 | 31 | foreign import highlightBlock_ :: String -> Boolean -> Unit 32 | foreign import highlightString_ :: String -> String 33 | -------------------------------------------------------------------------------- /src/DemoApp/Viz/GUP.purs: -------------------------------------------------------------------------------- 1 | module D3.Examples.GUP where 2 | 3 | import D3.Attributes.Sugar 4 | 5 | import D3.Data.Types (D3Selection_, Datum_, Element(..), Index_, Selector) 6 | import D3.Selection (SelectionAttribute) 7 | import D3Tagless.Capabilities (class SelectionM, appendTo, attach, openSelection, setAttributes, updateJoin) 8 | import Data.String.CodeUnits (singleton) 9 | import Effect.Aff (Milliseconds(..)) 10 | import Prelude (bind, discard, pure, ($), (*), (+), (<<<)) 11 | import Unsafe.Coerce (unsafeCoerce) 12 | 13 | -- | ==================================================================================== 14 | -- | Simple-as-can-be example of the more complex Join which allows for new data to be 15 | -- | entered, existing data to be updated and disappearing data to be removed 16 | -- | ==================================================================================== 17 | -- Snippet_Start 18 | -- Name: GUP 19 | type Model = Array Char 20 | 21 | -- in the interests of brevity these unsafe functions are defined here with the "script" 22 | -- however, in a larger program both Model and Unsafe would be their own modules 23 | datumIsChar :: Datum_ -> Char 24 | datumIsChar = unsafeCoerce 25 | 26 | indexIsNumber :: Index_ -> Number 27 | indexIsNumber = unsafeCoerce 28 | 29 | keyFunction :: Datum_ -> Index_ -- for this very simple example, the data (Char) can be used directly as the key 30 | keyFunction = unsafeCoerce 31 | 32 | exGeneralUpdatePattern :: forall m. SelectionM D3Selection_ m => Selector D3Selection_-> m ((Array Char) -> m D3Selection_) 33 | exGeneralUpdatePattern selector = do 34 | root <- attach selector 35 | svg <- appendTo root Svg [ viewBox 0.0 0.0 650.0 650.0, classed "d3svg gup" ] 36 | letterGroup <- appendTo svg Group [] 37 | 38 | pure $ \letters -> do 39 | enterSelection <- openSelection letterGroup "text" 40 | updateSelections <- updateJoin enterSelection Text letters keyFunction 41 | setAttributes updateSelections.exit exit 42 | setAttributes updateSelections.update update 43 | 44 | newlyEntered <- appendTo updateSelections.enter Text [] 45 | setAttributes newlyEntered enter 46 | 47 | pure newlyEntered 48 | 49 | where 50 | transition :: SelectionAttribute 51 | transition = transitionWithDuration $ Milliseconds 2000.0 52 | 53 | xFromIndex :: Datum_ -> Index_ -> Number 54 | xFromIndex _ i = 50.0 + ((indexIsNumber i) * 48.0) -- letters enter at this position, and then must transition to new position on each update 55 | 56 | enter = [ classed "enter" 57 | , fill "green" 58 | , x xFromIndex 59 | , y 0.0 60 | , text (singleton <<< datumIsChar) 61 | , fontSize 96.0 ] 62 | `andThen` (transition `to` [ y 200.0 ]) 63 | 64 | update = [ classed "update", fill "gray", y 200.0 ] 65 | `andThen` (transition `to` [ x xFromIndex ] ) 66 | 67 | exit = [ classed "exit", fill "brown"] 68 | `andThen` (transition `to` [ y 400.0, remove ]) 69 | -- Snippet_End 70 | -------------------------------------------------------------------------------- /src/DemoApp/Viz/LesMis/File.js: -------------------------------------------------------------------------------- 1 | "use strict" 2 | 3 | export function readJSONJS_(filecontents) { return decodeFile(filecontents) } 4 | 5 | const decodeFile = function (filecontents) { 6 | const json = JSON.parse(filecontents) 7 | const links = json.links.map(d => Object.create(d)) 8 | // const nodes = json.nodes.map(d => Object.create({data: d})) 9 | // return { links: links, nodes: nodes } 10 | return { links: links, nodes: json.nodes } 11 | } 12 | -------------------------------------------------------------------------------- /src/DemoApp/Viz/LesMis/File.purs: -------------------------------------------------------------------------------- 1 | module D3.Examples.LesMiserables.File where 2 | 3 | import Affjax (Error) 4 | import D3.Examples.LesMiserables.Model (LesMisRawModel) 5 | import Data.Either (Either(..)) 6 | 7 | -- TODO no error handling at all here RN (OTOH - performant!!) 8 | foreign import readJSONJS_ :: String -> LesMisRawModel 9 | 10 | readGraphFromFileContents :: forall r. Either Error { body ∷ String | r } -> LesMisRawModel 11 | readGraphFromFileContents (Right { body } ) = readJSONJS_ body 12 | -- TODO exceptions dodged using empty Model, fix with Maybe 13 | readGraphFromFileContents (Left err) = { links: [], nodes: [] } 14 | -------------------------------------------------------------------------------- /src/DemoApp/Viz/LesMis/LesMiserables.purs: -------------------------------------------------------------------------------- 1 | module D3.Examples.LesMiserables where 2 | 3 | import Control.Monad.State (class MonadState) 4 | import D3.Attributes.Sugar (classed, cx, cy, fill, radius, strokeColor, strokeOpacity, strokeWidth, viewBox, x1, x2, y1, y2) 5 | import D3.Data.Types (D3Selection_, Element(..), Selector) 6 | import D3.Examples.LesMis.Unsafe (unboxD3SimLink, unboxD3SimNode) 7 | import D3.Examples.LesMiserables.Model (LesMisRawModel) 8 | import D3.FFI (keyIsID_, simdrag) 9 | import D3.Scales (d3SchemeCategory10N_) 10 | import D3.Selection (Behavior(..), DragBehavior(..)) 11 | import D3.Simulation.Types (D3SimulationState_, SimVariable(..), Step(..)) 12 | import D3.Zoom (ScaleExtent(..), ZoomExtent(..)) 13 | import D3Tagless.Capabilities (class SimulationM, addTickFunction, appendTo, attach, on, setAttributes, setConfigVariable, setLinks, setNodes, simpleJoin) 14 | import Data.Int (toNumber) 15 | import Data.Number (sqrt) 16 | import Data.Tuple (Tuple(..)) 17 | import Effect.Class (class MonadEffect, liftEffect) 18 | import Prelude (class Bind, Unit, bind, discard, negate, pure, unit, ($), (/), (<<<)) 19 | import Utility (getWindowWidthHeight) 20 | 21 | -- type-safe(ish) accessors for the data that is given to D3 22 | -- we lose the type information in callbacks from the FFI, such as for attributes 23 | -- but since we know what we gave we can coerce it back to the initial type. 24 | -- Snippet_Start 25 | -- Name: LesMisAccessors 26 | link_ = { 27 | source: _.source <<< unboxD3SimLink 28 | , target: _.target <<< unboxD3SimLink 29 | , value: _.value <<< unboxD3SimLink 30 | , color: d3SchemeCategory10N_ <<< toNumber <<< _.target.group <<< unboxD3SimLink 31 | } 32 | 33 | datum_ = { 34 | -- direct accessors to fields of the datum (BOILERPLATE) 35 | id : _.id <<< unboxD3SimNode -- NB the id in this case is a String 36 | , x : _.x <<< unboxD3SimNode 37 | , y : _.y <<< unboxD3SimNode 38 | , group : _.group <<< unboxD3SimNode 39 | 40 | , colorByGroup: d3SchemeCategory10N_ <<< toNumber <<< _.group <<< unboxD3SimNode 41 | } 42 | -- Snippet_End 43 | 44 | -- Snippet_Start 45 | -- Name: LesMisScript 46 | -- | recipe for this force layout graph 47 | draw :: forall row m. 48 | Bind m => 49 | MonadEffect m => 50 | MonadState { simulation :: D3SimulationState_ | row } m => 51 | SimulationM D3Selection_ m => 52 | LesMisRawModel -> Selector D3Selection_ -> m Unit 53 | draw model selector = do 54 | (Tuple w h) <- liftEffect getWindowWidthHeight 55 | (root :: D3Selection_) <- attach selector 56 | svg <- appendTo root Svg [ viewBox (-w / 2.0) (-h / 2.0) w h, classed "lesmis" ] 57 | linksGroup <- appendTo svg Group [ classed "link", strokeColor "#999", strokeOpacity 0.6 ] 58 | nodesGroup <- appendTo svg Group [ classed "node", strokeColor "#fff", strokeOpacity 1.5 ] 59 | 60 | -- in contrast to a simple SelectionM function, we have additional typeclass capabilities for simulation 61 | -- which we use here to introduce the nodes and links to the simulation 62 | nodesInSim <- setNodes model.nodes -- no staging here, we just load the nodes straight into Sim 63 | linksInSim <- setLinks model.links model.nodes keyIsID_ 64 | 65 | -- joining the data from the model after it has been put into the simulation 66 | nodesSelection <- simpleJoin nodesGroup Circle nodesInSim keyIsID_ 67 | setAttributes nodesSelection [ radius 5.0, fill datum_.colorByGroup ] 68 | linksSelection <- simpleJoin linksGroup Line linksInSim keyIsID_ 69 | setAttributes linksSelection [ strokeWidth (sqrt <<< link_.value), strokeColor link_.color ] 70 | 71 | -- both links and nodes are updated on each step of the simulation, 72 | -- in this case it's a simple translation of underlying (x,y) data for the circle centers 73 | -- tick functions have names, in this case "nodes" and "links" 74 | addTickFunction "nodes" $ Step nodesSelection [ cx datum_.x, cy datum_.y ] 75 | addTickFunction "links" $ Step linksSelection [ x1 (_.x <<< link_.source) 76 | , y1 (_.y <<< link_.source) 77 | , x2 (_.x <<< link_.target) 78 | , y2 (_.y <<< link_.target) 79 | ] 80 | -- use default drag function (simply drags the element that's clicked on) 81 | _ <- nodesSelection `on` Drag (CustomDrag "lesmis" simdrag) 82 | -- TODO create inner and apply the zoom functionality to it 83 | _ <- svg `on` Zoom { extent : ZoomExtent { top: 0.0, left: 0.0 , bottom: h, right: w } 84 | , scale : ScaleExtent 1.0 4.0 -- wonder if ScaleExtent ctor could be range operator `..` 85 | , name : "LesMis" 86 | , target : svg 87 | } 88 | setConfigVariable $ Alpha 1.0 89 | pure unit 90 | -- Snippet_End -------------------------------------------------------------------------------- /src/DemoApp/Viz/LesMis/Model.purs: -------------------------------------------------------------------------------- 1 | module D3.Examples.LesMiserables.Model where 2 | 3 | import D3.Node (D3TreeRow, D3Link, D3_SimulationNode, D3_VxyFxy, D3_XY, EmbeddedData) 4 | import Type.Row (type (+)) 5 | 6 | -- | ========================================================================================== 7 | -- | Model data types specialized with inital data 8 | -- | ========================================================================================== 9 | 10 | -- the "extra / model-specific" data above and beyond what any D3 Tree Node is going to have: 11 | type LesMisNodeData row = ( id :: String, group :: Int | row ) 12 | -- this extra data inside a D3SimNode as used in PureScript: 13 | type LesMisSimNode = D3_SimulationNode ( LesMisNodeData + D3_XY + D3_VxyFxy + ()) 14 | 15 | -- first the "extra / model-specific" data in the links 16 | type LesMisLinkData = ( value :: Number ) 17 | type LesMisGraphLinkObj = { source :: LesMisSimRecord, target :: LesMisSimRecord | LesMisLinkData } 18 | 19 | 20 | -- we make the model like so, but D3 then swizzles it to the "cooked" model below 21 | -- the source and target in the links are given as "String" to match id in the node data 22 | type LesMisRawModel = { links :: Array (D3Link String LesMisLinkData), nodes :: Array LesMisSimNode } 23 | 24 | -- same as above but as a bare record, this is the "datum" that D3 sees and which it returns to you for attr setting: 25 | type LesMisSimRecord = Record (D3_XY + D3_VxyFxy + LesMisNodeData + ()) 26 | 27 | 28 | 29 | -- now a definition for that same row if it is embedded instead in a D3 Hierarchical structure, in which case 30 | -- our extra data is available in the "datum" as an embedded object at the field "data" 31 | type LesMisTreeNode = D3TreeRow (EmbeddedData { | LesMisNodeData () } + ()) 32 | -- type LesMisTreeRecord = Record (D3_ID + D3_TreeRow + D3_XY + D3_Leaf + EmbeddedData { | LesMisNodeData () } + ()) 33 | 34 | 35 | 36 | -------------------------------------------------------------------------------- /src/DemoApp/Viz/LesMis/Unsafe.purs: -------------------------------------------------------------------------------- 1 | module D3.Examples.LesMis.Unsafe where 2 | 3 | 4 | import D3.Data.Types (Datum_) 5 | import D3.Examples.LesMiserables.Model (LesMisGraphLinkObj, LesMisSimRecord) 6 | import D3.Node (D3LinkSwizzled(..), D3_SimulationNode(..)) 7 | import Unsafe.Coerce (unsafeCoerce) 8 | 9 | unboxD3SimNode :: Datum_ -> LesMisSimRecord 10 | unboxD3SimNode datum = do 11 | let (D3SimNode d) = unsafeCoerce datum 12 | d 13 | 14 | unboxD3SimLink :: Datum_ -> LesMisGraphLinkObj 15 | unboxD3SimLink datum = do 16 | let (D3LinkObj l) = unsafeCoerce datum 17 | l 18 | -------------------------------------------------------------------------------- /src/DemoApp/Viz/MetaTree/MetaTree.purs: -------------------------------------------------------------------------------- 1 | module D3.Examples.MetaTree where 2 | 3 | import D3.Attributes.Sugar 4 | import Prelude 5 | 6 | import D3.Data.Tree (TreeModel, TreeType(..)) 7 | import D3.Data.Types (D3Selection_, Datum_, Element(..)) 8 | import D3.Examples.MetaTree.Model (MetaTreeNode) 9 | import D3.Examples.MetaTree.Unsafe (coerceToTreeNode, unboxD3TreeNode) 10 | import D3.FFI (descendants_, getLayout, hNodeHeight_, hierarchyFromJSON_, keyIsID_, links_, runLayoutFn_, treeMinMax_, treeSetNodeSize_) 11 | import D3.Layouts.Hierarchical (verticalLink) 12 | import D3Tagless.Capabilities (class SelectionM, appendTo, attach, setAttributes, simpleJoin) 13 | import D3Tagless.Instance.Selection (runD3M) 14 | import Data.Number (abs) 15 | import Data.Tuple (Tuple(..)) 16 | import Effect.Aff (Aff) 17 | import Effect.Class (liftEffect) 18 | import Utility (getWindowWidthHeight) 19 | 20 | datum_ :: { 21 | param1 :: Datum_ -> String 22 | , positionXY :: Datum_ -> String 23 | , symbol :: Datum_ -> String 24 | , x :: Datum_ -> Number 25 | , y :: Datum_ -> Number 26 | } 27 | datum_ = { 28 | x : _.x <<< unboxD3TreeNode <<< coerceToTreeNode 29 | , y : _.y <<< unboxD3TreeNode <<< coerceToTreeNode 30 | -- now the fields which are in the original data object, embedded in this tree object 31 | , symbol: _.data.symbol <<< unboxD3TreeNode <<< coerceToTreeNode 32 | , param1: _.data.param1 <<< unboxD3TreeNode <<< coerceToTreeNode 33 | , positionXY: \d -> "translate(" <> show (datum_.x d) <> "," <> show (datum_.y d) <>")" 34 | } 35 | 36 | -- | Evaluate the tree drawing script in the "d3" monad which will render it in SVG 37 | -- | TODO specialize runD3M so that this function isn't necessary 38 | drawTree :: TreeModel -> Aff Unit 39 | drawTree treeModel = liftEffect $ do 40 | widthHeight <- getWindowWidthHeight 41 | let tree = hierarchyFromJSON_ treeModel.json 42 | (_ :: Tuple D3Selection_ Unit) <- runD3M (draw widthHeight tree) 43 | pure unit 44 | 45 | -- Snippet_Start 46 | -- Name: MetaTreeDraw 47 | -- | "script" to produce the documentation-ready rendering of another script's structure 48 | -- | (could also be the basis for graphical editor of scripts / trees) 49 | draw :: forall m selection. Bind m => SelectionM selection m => 50 | Tuple Number Number -> MetaTreeNode -> m selection 51 | draw (Tuple w h) tree = do 52 | let 53 | -- configure dimensions 54 | numberOfLevels = (hNodeHeight_ tree) + 1.0 55 | spacing = { interChild: (w/5.0), interLevel: h / numberOfLevels} 56 | layoutFn = (getLayout TidyTree) `treeSetNodeSize_` [ spacing.interChild, spacing.interLevel ] 57 | laidOutRoot_ = layoutFn `runLayoutFn_` tree 58 | { xMin, xMax, yMin, yMax } = treeMinMax_ laidOutRoot_ 59 | xExtent = abs $ xMax - xMin -- ie if tree spans from -50 to 200, it's extent is 250 60 | yExtent = abs $ yMax - yMin -- ie if tree spans from -50 to 200, it's extent is 250 61 | vtreeYOffset = (abs (h - yExtent)) / 2.0 62 | vtreeXOffset = pad xMin -- the left and right sides might be different so (xExtent / 2) would not necessarily be right 63 | pad n = n * 1.2 64 | 65 | 66 | -- "script" 67 | root <- attach ".svg-container" 68 | svg <- appendTo root Svg [ viewBox vtreeXOffset (-vtreeYOffset) (pad xExtent) (pad yExtent) 69 | , preserveAspectRatio $ AspectRatio XMin YMid Meet 70 | , width w 71 | , height h 72 | , classed "metatree" ] 73 | container <- appendTo svg Group [ fontFamily "sans-serif" 74 | , fontSize 18.0 75 | ] 76 | links <- appendTo container Group [ classed "links"] 77 | nodes <- appendTo container Group [ classed "nodes"] 78 | 79 | theLinks_ <- simpleJoin links Path (links_ tree) keyIsID_ 80 | setAttributes theLinks_ 81 | [ strokeWidth 1.5, strokeColor "black", strokeOpacity 0.4, fill "none", verticalLink] 82 | 83 | nodeJoin_ <- simpleJoin nodes Group (descendants_ tree) keyIsID_ 84 | setAttributes nodeJoin_ [ transform [ datum_.positionXY ] ] 85 | 86 | 87 | theNodes <- appendTo nodeJoin_ 88 | Circle [ fill "blue" 89 | , radius 20.0 90 | , strokeColor "white" 91 | , strokeWidth 3.0 92 | ] 93 | 94 | labelsWhite <- appendTo nodeJoin_ 95 | Text [ x 0.0 96 | , y 3.0 97 | , textAnchor "middle" 98 | , text datum_.symbol 99 | , fill "white" 100 | ] 101 | 102 | labelsGray <- appendTo nodeJoin_ 103 | Text [ x 22.0 104 | , y 3.0 105 | , textAnchor "start" 106 | , text datum_.param1 107 | , fill "gray" 108 | ] 109 | 110 | pure svg 111 | -- Snippet_End -------------------------------------------------------------------------------- /src/DemoApp/Viz/MetaTree/Model.purs: -------------------------------------------------------------------------------- 1 | module D3.Examples.MetaTree.Model where 2 | 3 | import D3.Node (D3TreeRow, D3Link, EmbeddedData, NodeID) 4 | 5 | import Type.Row (type (+)) 6 | 7 | -- Model data types specialized with inital data 8 | type MetaTreeNodeRow row = ( 9 | name :: String 10 | , symbol :: String 11 | , param1 :: String 12 | , param2 :: String 13 | | row ) 14 | type MetaTreeNodeData = { | MetaTreeNodeRow () } 15 | 16 | type MetaTreeNode = D3TreeRow (EmbeddedData MetaTreeNodeData + ()) 17 | 18 | type MetaTreeLinkData = ( example :: Number ) 19 | type MetaTreeSimRecord = Record (MetaTreeNodeRow + ()) 20 | type MetaTreeLinkObj = { source :: MetaTreeSimRecord, target :: MetaTreeSimRecord | MetaTreeLinkData } 21 | 22 | type MetaTreeRawModel = { 23 | links :: Array (D3Link NodeID MetaTreeLinkData) 24 | , nodes :: Array MetaTreeNodeData 25 | } 26 | 27 | type MetaTreeCookedModel = { 28 | links :: Array (D3Link NodeID MetaTreeLinkData) 29 | , nodes :: Array MetaTreeNodeData 30 | } 31 | -------------------------------------------------------------------------------- /src/DemoApp/Viz/MetaTree/Unsafe.purs: -------------------------------------------------------------------------------- 1 | module D3.Examples.MetaTree.Unsafe where 2 | 3 | import D3.Data.Types (Datum_) 4 | import D3.Examples.MetaTree.Model (MetaTreeNodeRow) 5 | import D3.Node (D3_ID, D3_TreeNode(..), D3_TreeRow, D3_XY, EmbeddedData) 6 | import Data.Nullable (Nullable) 7 | import Halogen.Svg.Attributes (r) 8 | import Type.Row (type (+)) 9 | import Unsafe.Coerce (unsafeCoerce) 10 | 11 | unboxD3TreeNode :: forall row. 12 | D3_TreeNode row 13 | -> { depth :: Int 14 | , height :: Int 15 | , id :: Int 16 | , value :: Nullable Number 17 | | row 18 | } 19 | unboxD3TreeNode (D3TreeNode t) = t 20 | 21 | coerceToTreeNode :: forall r. Datum_ -> D3_TreeNode r 22 | coerceToTreeNode = unsafeCoerce 23 | -------------------------------------------------------------------------------- /src/DemoApp/Viz/Spago/Attributes.purs: -------------------------------------------------------------------------------- 1 | module D3.Examples.Spago.Draw.Attributes where 2 | 3 | import D3.Attributes.Sugar (classed, cursor, fill, height, onMouseEvent, opacity, radius, rotate, strokeColor, strokeWidth, text, textAnchor, transform, transform', viewBox, width, x, y) 4 | import D3.Data.Tree (TreeLayout(..)) 5 | import D3.Data.Types (D3Simulation_, MouseEvent(..)) 6 | import D3.Examples.Spago.Model (datum_) 7 | import D3.Selection (SelectionAttribute) 8 | import Data.Maybe (Maybe) 9 | import Prelude (negate, (/), (<>)) 10 | 11 | -- TODO this is a problem once extracted from "script", leads to undefined in D3.js 12 | enterLinks :: forall t339. Array t339 13 | enterLinks = [] -- [ classed link_.linkClass ] -- default invisible in CSS unless marked "visible" 14 | 15 | -- explodePackageOnClick :: D3Simulation_ -> SelectionAttribute 16 | -- explodePackageOnClick simulation_ = onMouseEvent MouseClick (\e d _ -> explodePackages e simulation_ d) -- here we need to raise a Halogen Event 17 | 18 | -- toggleSpotlightOnClick :: D3Simulation_ -> SelectionAttribute 19 | -- toggleSpotlightOnClick simulation_ = onMouseEvent MouseClick (\e d _ -> toggleSpotlight e simulation_ d) 20 | 21 | -- unused right now but could be used to make, for example, click on Package or background cause unSpotlighting of node 22 | -- undoSpotlightOnClick :: D3Simulation_ -> SelectionAttribute 23 | -- undoSpotlightOnClick simulation_ = onMouseEvent MouseClick (\e d t -> cancelSpotlight_ simulation_) 24 | 25 | enterAttrs :: Array SelectionAttribute 26 | enterAttrs = 27 | [ classed datum_.nodeClass 28 | , transform' datum_.translateNode 29 | ] 30 | 31 | updateAttrs :: Array SelectionAttribute 32 | updateAttrs = 33 | [ classed datum_.nodeClass 34 | , transform' datum_.translateNode 35 | ] 36 | 37 | type SpagoSceneAttributes = { 38 | circles :: Array SelectionAttribute 39 | , labels :: Array SelectionAttribute 40 | } 41 | 42 | clusterSceneAttributes :: SpagoSceneAttributes 43 | clusterSceneAttributes = { 44 | circles: [ radius datum_.radius 45 | , fill datum_.fillByUsage 46 | , strokeColor datum_.strokeByUsage 47 | , strokeWidth 3.0 48 | , opacity datum_.opacityByType 49 | ] 50 | , labels: [ classed "label" 51 | , x 0.2 52 | , y datum_.positionLabel 53 | , textAnchor "middle" 54 | , text datum_.name 55 | -- , text datum_.nameAndID 56 | ] 57 | } 58 | 59 | graphSceneAttributes :: SpagoSceneAttributes 60 | graphSceneAttributes = { 61 | circles: [ radius datum_.radius 62 | , fill datum_.colorByGroup 63 | , opacity datum_.opacityByType 64 | -- , callback 65 | ] 66 | , labels: [ classed "label" 67 | , x 0.2 68 | , y datum_.positionLabel 69 | , textAnchor "middle" 70 | , text datum_.name 71 | -- , text datum_.indexAndID 72 | ] 73 | } 74 | 75 | treeSceneAttributes :: SpagoSceneAttributes 76 | treeSceneAttributes = { 77 | circles: [ radius datum_.radius 78 | , fill datum_.colorByDepth 79 | , strokeColor datum_.colorByGroup 80 | , strokeWidth 3.0 81 | ] 82 | , labels: [ classed "label" 83 | , x 4.0 84 | , y 2.0 85 | -- the following attribute is suspended until we can revisit the tree_datum_ concept, see if it's really needed etc 86 | -- , textAnchor (tree_datum_.textAnchor Horizontal) 87 | , text datum_.name 88 | ] 89 | } 90 | 91 | svgAttrs :: Number -> Number -> Array SelectionAttribute 92 | svgAttrs w h = [ viewBox (-w / 2.1) (-h / 2.05) w h 93 | -- , preserveAspectRatio $ AspectRatio XMid YMid Meet 94 | , classed "overlay" 95 | , width w, height h 96 | , cursor "grab" 97 | ] 98 | -------------------------------------------------------------------------------- /src/DemoApp/Viz/Spago/Files.js: -------------------------------------------------------------------------------- 1 | export function readSpago_Raw_JSON_(modulesBody) { 2 | return packagesBody => lsdepsBody => locBody => { 3 | const modules = decodeModulesFile(modulesBody); 4 | const packages = decodePackagesFile(packagesBody); 5 | const lsDeps = decodeLsDepsFile(lsdepsBody); 6 | const loc = decodeLOCFile(locBody); 7 | 8 | return { modules, packages, lsDeps, loc } 9 | }; 10 | } 11 | 12 | // module has key, path & depends 13 | const decodeModulesFile = function (filecontents) { 14 | const json = JSON.parse(filecontents) 15 | const modules = Object.keys(json).map(key => { return { key: key, depends: json[key].depends, path: json[key].path }; }) 16 | 17 | return modules; 18 | } 19 | 20 | // package has key and depends 21 | const decodePackagesFile = function (filecontents) { 22 | const json = JSON.parse(filecontents) 23 | const packages = Object.keys(json).map(key => { return { key: key, depends: json[key].depends }; }) 24 | 25 | return packages; 26 | } 27 | 28 | // package has key and depends 29 | const decodeLOCFile = function (filecontents) { 30 | const json = JSON.parse(filecontents) 31 | return json.loc; 32 | } 33 | 34 | // lsdep has key === packageName, version, repo { tag, contents } 35 | const decodeLsDepsFile = function (filecontents) { 36 | const jsonlines = splitIntoLines(filecontents) 37 | jsonlines.length = jsonlines.length - 1 38 | var objectArray = jsonlines.map(d => JSON.parse(d)) 39 | return objectArray; 40 | } 41 | 42 | function splitIntoLines(str) { 43 | // See http://www.unicode.org/reports/tr18/#RL1.6 44 | return str.split(/\r\n|[\n\v\f\r\u0085\u2028\u2029]/); 45 | } 46 | 47 | -------------------------------------------------------------------------------- /src/DemoApp/Viz/Spago/Model.js: -------------------------------------------------------------------------------- 1 | // ******************************************************************************** 2 | // functionality to "explode" a package by removing it and replacing with it's constituent modules 3 | // ******************************************************************************** 4 | export function explodePackages_(event) { 5 | return simulation => id => nodetype => { 6 | event.stopPropagation() 7 | if (nodetype === "package") { 8 | console.log('clicked on a package'); 9 | return 10 | } 11 | }; 12 | } 13 | // ******************************************************************************** 14 | // functionality to spotlight the immediate graph neighbours of a module 15 | // (and only modules at present) 16 | // ******************************************************************************** 17 | let spotlitSelection 18 | let spotlitNode 19 | let sourcesSelection 20 | let targetSelection 21 | let spotlitID 22 | let spotlit = false; 23 | 24 | export function cancelSpotlight_(simulation) { 25 | console.log("cancelling spotlight"); 26 | if (spotlit) { 27 | unSpotlightNeighbours_(simulation) 28 | } 29 | } 30 | 31 | export function toggleSpotlight_(event) { 32 | return simulation => id => nodetype => { 33 | event.stopPropagation() 34 | if (nodetype === "package") { 35 | return 36 | } 37 | if ((spotlit && id !== spotlitID)) { 38 | console.log(`changing spotlight from ${spotlitID} to ${id}`); 39 | unSpotlightNeighbours_(simulation) 40 | spotlightNeighbours_(simulation, id, nodetype) 41 | } else if (spotlit && id === spotlitID) { 42 | console.log(`cancelling spotlight on ${spotlitID}`); 43 | unSpotlightNeighbours_(simulation) 44 | } else { 45 | console.log(`setting a spotlight on ${id}`); 46 | spotlightNeighbours_(simulation, id, nodetype) 47 | } 48 | }; 49 | } 50 | 51 | // TODO implement this as purescript-function-called from FFI?? 52 | spotlightNeighbours_ = (simulation, id, nodetype) => { 53 | // else 54 | spotlit = true; 55 | spotlitID = id 56 | simulation.stop() 57 | svg = d3.select('div.svg-container svg') 58 | nodeSelection = svg.selectAll('g.nodes g') 59 | spotlitSelection = nodeSelection.filter((d, i) => d.id == id) 60 | 61 | spotlitNode = spotlitSelection.node() 62 | // check if fx already set, don't reset if so 63 | spotlitNode.__data__.fx = spotlitNode.__data__.fx || spotlitNode.__data__.x 64 | spotlitNode.__data__.fy = spotlitNode.__data__.fy || spotlitNode.__data__.y 65 | const targets = spotlitNode.__data__.links.targets 66 | const sources = spotlitNode.__data__.links.sources 67 | 68 | sourcesSelection = nodeSelection.filter((d, i) => sources.includes(d.id)) 69 | targetSelection = nodeSelection.filter((d, i) => targets.includes(d.id)) 70 | 71 | svg.classed('spotlight', true) 72 | sourcesSelection.classed('source', true) 73 | targetSelection.classed('target', true) 74 | spotlitSelection.classed('spotlight', true) 75 | spotlitSelection.classed('source target', false) 76 | 77 | simulation.force( 78 | 'collide', 79 | d3 80 | .forceCollide() 81 | .radius(d => 82 | sources.includes(d.id) || targets.includes(d.id) ? d.r * 4 : (d.id === d.containerID) ? 10.0 : d.r 83 | ) 84 | ) 85 | simulation.alpha(1).restart() 86 | } 87 | unSpotlightNeighbours_ = (simulation) => { 88 | simulation.stop() 89 | svg.classed('spotlight', false) 90 | spotlitNode.__data__.fx = null 91 | spotlitNode.__data__.fy = null 92 | spotlitSelection.classed('spotlight', false) 93 | sourcesSelection.classed('source', false) 94 | targetSelection.classed('target', false) 95 | // move the radii back to what they were before 96 | simulation.force( 97 | 'collide', 98 | d3.forceCollide().radius(d => (d.id === d.containerID) ? 10.0 : d.r) 99 | ) 100 | simulation.restart() 101 | spotlit = false 102 | } -------------------------------------------------------------------------------- /src/DemoApp/Viz/Spago/Unsafe.purs: -------------------------------------------------------------------------------- 1 | module D3.Examples.Spago.Unsafe where 2 | 3 | import Prelude 4 | 5 | import D3.Data.Types (Datum_, Index_) 6 | import D3.Examples.Spago.Files (NodeType, SpagoDataRecord, SpagoLinkData, SpagoNodeRow, SpagoTreeObj) 7 | import D3.Node (D3Link(..), D3LinkSwizzled, D3_FocusXY, D3_ID, D3_Radius, D3_TreeNode(..), D3_TreeRow, D3_VxyFxy, D3_XY, EmbeddedData, NodeID) 8 | import D3.Node (D3LinkDatum, D3LinkSwizzled(..), D3_SimulationNode(..), D3_TreeNode(..)) 9 | import Data.Nullable (Nullable) 10 | import Type.Row (type (+)) 11 | import Unsafe.Coerce (unsafeCoerce) 12 | 13 | -- | why a single unsafeCoerce and not, say, some kind of lens for each field ? PERFORMANCE 14 | unboxD3SimNode :: Datum_ -> SpagoDataRecord 15 | unboxD3SimNode datum = d 16 | where (D3SimNode d) = unsafeCoerce datum 17 | 18 | unboxD3SimLink :: Datum_ -> D3LinkDatum SpagoDataRecord SpagoLinkData 19 | unboxD3SimLink datum = l 20 | where 21 | (D3LinkObj l) = unsafeCoerce datum 22 | 23 | coerceToIndex_ :: forall a. (Ord a) => a -> Index_ 24 | coerceToIndex_ = unsafeCoerce 25 | 26 | spagoNodeKeyFunction :: Datum_ -> Index_ 27 | spagoNodeKeyFunction d = index 28 | where 29 | index = unsafeCoerce $ (unboxD3SimNode d).id 30 | 31 | -- ====================================================================== 32 | -- | Tree object contains SpagoNodeData embedded in it in a "data" field 33 | -- ====================================================================== 34 | unwrapD3TreeNode :: forall t3. 35 | D3_TreeNode t3 36 | -> { depth :: Int 37 | , height :: Int 38 | , id :: Int 39 | , value :: Nullable Number 40 | | t3 41 | } 42 | unwrapD3TreeNode (D3TreeNode t) = t 43 | 44 | recoverSpagoTreeObj :: Datum_ -> SpagoTreeObj 45 | recoverSpagoTreeObj datum = t' 46 | where 47 | (t' :: SpagoTreeObj ) = unsafeCoerce datum 48 | 49 | 50 | -- unboxTreeDatum :: Datum_ -> SpagoTreeObj 51 | unboxD3TreeNode :: Datum_ 52 | -> { data :: { connected :: Boolean 53 | , containerID :: Int 54 | , containerName :: String 55 | , containsMany :: Boolean 56 | , gridXY :: Nullable 57 | { x :: Number 58 | , y :: Number 59 | } 60 | , id :: Int 61 | , inSim :: Boolean 62 | , links :: { contains :: Array Int 63 | , inPackage :: Array Int 64 | , outPackage :: Array Int 65 | , sources :: Array Int 66 | , targets :: Array Int 67 | , treeChildren :: Array Int 68 | } 69 | , loc :: Number 70 | , name :: String 71 | , nodetype :: NodeType 72 | , showChildren :: Boolean 73 | , treeDepth :: Nullable Int 74 | , treeXY :: Nullable 75 | { x :: Number 76 | , y :: Number 77 | } 78 | } 79 | , depth :: Int 80 | , height :: Int 81 | , id :: Int 82 | , value :: Nullable Number 83 | , x :: Number 84 | , y :: Number 85 | } 86 | unboxD3TreeNode = unwrapD3TreeNode <<< recoverSpagoTreeObj 87 | -------------------------------------------------------------------------------- /src/DemoApp/Viz/ThreeLittleCircles.purs: -------------------------------------------------------------------------------- 1 | module D3.Examples.ThreeLittleCircles where 2 | 3 | import D3.Attributes.Sugar 4 | 5 | import D3.Data.Types (D3Selection_, Datum_, Element(..), Index_, Selector) 6 | import D3.FFI (keyIsID_) 7 | import D3.Scales (d3SchemeCategory10N_, d3SchemeDiverging10N_, d3SchemePairedN_, d3SchemeSequential10N_) 8 | import D3Tagless.Capabilities (class SelectionM, appendTo, attach, setAttributes, simpleJoin) 9 | import Data.Int (toNumber) 10 | import Prelude (bind, discard, negate, pure, ($), (*), (-), (/)) 11 | import Unsafe.Coerce (unsafeCoerce) 12 | 13 | -- Snippet_Start 14 | -- Name: 3LC-xFromIndex 15 | -- | simple utility function used in all three of these examples 16 | xFromIndex :: Datum_ -> Index_ -> Number 17 | xFromIndex _ i = ((indexIsNumber i) * 100.0) 18 | where 19 | indexIsNumber :: Index_ -> Number 20 | indexIsNumber = unsafeCoerce 21 | -- Snippet_End 22 | 23 | -- Snippet_Start 24 | -- Name: TLCSimple 25 | -- | Pretty much the most basic example imaginable, three ints represented by three circles 26 | drawThreeCircles :: forall m. SelectionM D3Selection_ m => Selector D3Selection_-> m D3Selection_ 27 | drawThreeCircles selector = do 28 | 29 | let circleAttributes = [ fill "green", cx xFromIndex, cy 50.0, radius 20.0 ] 30 | 31 | root <- attach selector 32 | svg <- appendTo root Svg [ viewBox (-100.0) (-100.0) 650.0 650.0, classed "d3svg gup" ] 33 | circleGroup <- appendTo svg Group [] 34 | circles <- simpleJoin circleGroup Circle [32, 57, 293] keyIsID_ 35 | setAttributes circles circleAttributes 36 | 37 | pure circles 38 | -- Snippet_End 39 | 40 | -- Snippet_Start 41 | -- Name: TLCDatum_ 42 | type Model = Array Int -- not strictly necessary in such a simple example, of course 43 | 44 | datum_ :: -- a record containing all the accessor functions needed for attributes 45 | { color :: Datum_ -> String 46 | , x :: Datum_ -> Index_ -> Number 47 | , y :: Datum_ -> Number 48 | } 49 | datum_ = 50 | let 51 | -- we bury the unsafe functions inside the datum_ record, unsafeCoerce yes, but very restricted how it can be used 52 | getDatum :: Datum_ -> Int 53 | getDatum = unsafeCoerce 54 | getIndex :: Index_ -> Int 55 | getIndex = unsafeCoerce 56 | in { 57 | x : \_ i -> (toNumber $ getIndex i) * 20.0 58 | , y : \d -> 100.0 - (toNumber $ getDatum d) / 5.0 59 | , color : \d -> d3SchemePairedN_ ((toNumber $ getDatum d) / 100.0) 60 | } 61 | -- Snippet_End 62 | 63 | -- Snippet_Start 64 | -- Name: TLCParabola 65 | drawWithData :: forall m. SelectionM D3Selection_ m => Model -> Selector D3Selection_-> m D3Selection_ 66 | drawWithData circleData selector = do 67 | 68 | let circleAttributes = [ 69 | strokeColor datum_.color 70 | , strokeWidth 3.0 71 | , fill "none" 72 | , cx datum_.x 73 | , cy datum_.y 74 | , radius 10.0 ] 75 | 76 | root <- attach selector 77 | svg <- appendTo root Svg [ viewBox (-100.0) (-100.0) 650.0 650.0, classed "d3svg gup" ] 78 | circleGroup <- appendTo svg Group [] 79 | 80 | circles <- simpleJoin circleGroup Circle circleData keyIsID_ 81 | setAttributes circles circleAttributes 82 | 83 | pure circles 84 | -- Snippet_End 85 | -------------------------------------------------------------------------------- /src/DemoApp/Viz/Tree/Draw.purs: -------------------------------------------------------------------------------- 1 | module D3.Examples.Tree.Draw where 2 | 3 | import Prelude 4 | 5 | import D3.Attributes.Sugar (classed, dy, fill, fontFamily, fontSize, height, radius, strokeColor, strokeOpacity, strokeWidth, text, textAnchor, width, x) 6 | import D3.Data.Tree (TreeLayout(..)) 7 | import D3.Data.Types (Datum_, Element(..), Selector) 8 | import D3.Examples.MetaTree.Unsafe (coerceToTreeNode, unboxD3TreeNode) 9 | import D3.Examples.Tree.Model (FlareTreeNode) 10 | import D3.FFI (descendants_, getHierarchyChildren_, getHierarchyValue_, hasChildren_, keyIsID_, links_) 11 | import D3.Node (D3_TreeNode(..)) 12 | import D3.Selection (SelectionAttribute) 13 | import D3Tagless.Capabilities (class SelectionM, appendTo, attach, setAttributes, simpleJoin) 14 | import D3Tagless.Capabilities as D3 15 | import Data.Array as A 16 | import Data.Nullable (Nullable) 17 | import Data.Number (pi) 18 | import Unsafe.Coerce (unsafeCoerce) 19 | 20 | treeDatum_ :: 21 | { hasChildren :: Datum_ -> Boolean 22 | , name :: Datum_ -> String 23 | , onRHS :: TreeLayout -> Datum_ -> Boolean 24 | , textAnchor :: TreeLayout -> Datum_ -> String 25 | , textX :: TreeLayout -> Datum_ -> Number 26 | , x :: Datum_ -> Number 27 | , y :: Datum_ -> Number 28 | , depth :: Datum_ -> Int 29 | , height :: Datum_ -> Int 30 | , value :: Datum_ -> Nullable Number 31 | } 32 | treeDatum_ = { 33 | -- simple accessors first 34 | depth : _.depth <<< unboxD3TreeNode <<< coerceToTreeNode 35 | , height: _.height <<< unboxD3TreeNode <<< coerceToTreeNode 36 | , x : _.x <<< unboxD3TreeNode <<< coerceToTreeNode 37 | , y : _.y <<< unboxD3TreeNode <<< coerceToTreeNode 38 | -- now accessors that use the embedded "data" object within the Tree node 39 | , name : _.data.name <<< unboxD3TreeNode <<< coerceToTreeNode 40 | -- now more semanticly complicated accessors 41 | -- value_ returns null rather than undefined if there is no value field 42 | , value : getHierarchyValue_ <<< coerceToTreeNode 43 | -- hasChildren_ returns empty array rather than undefined if there is no children field 44 | , hasChildren: hasChildren_ <<< coerceToTreeNode 45 | -- -- TODO these next two should be rewritten to use some sort of choice operator 46 | , textAnchor : (\l d -> case l of 47 | Radial -> 48 | if (treeDatum_.hasChildren d) == (treeDatum_.x d < pi) 49 | then "start" 50 | else "end" 51 | _ -> 52 | if (treeDatum_.hasChildren d) 53 | then "start" 54 | else "end" 55 | ) 56 | , textX : (\l d -> case l of 57 | Radial -> 58 | if (treeDatum_.hasChildren d) == (treeDatum_.x d < pi) -- d.x < pi => node is on the RHS of Radial tree 59 | then 6.0 60 | else (-6.0) 61 | _ -> 62 | if (treeDatum_.hasChildren d) 63 | then 6.0 64 | else (-6.0) 65 | ) 66 | , onRHS : \l d -> if l == Radial && (treeDatum_.x d >= pi) 67 | then true 68 | else false 69 | } 70 | 71 | 72 | -- a record that packages up all the customizations that are needed to render the 6 variations on Tree 73 | type ScriptConfig = { 74 | layout :: TreeLayout 75 | , selector :: Selector String 76 | , linkPath :: SelectionAttribute 77 | , spacing :: { interChild :: Number, interLevel :: Number } 78 | , viewbox :: Array SelectionAttribute 79 | , nodeTransform :: Array SelectionAttribute 80 | , color :: String 81 | , svg :: { width :: Number, height :: Number } 82 | } 83 | 84 | -- | The eDSL script that renders tree layouts 85 | -- | it has been parameterized rather heavily using the ScriptConfig record so that it can draw 86 | -- | all six variations of [Radial, Horizontal, Vertical] * [Dendrogram, TidyTree] 87 | -- | NB there would be nothing wrong, per se, with individual examples, this just shows 88 | -- | some more composability, at the price of some direct legibility 89 | 90 | -- Snippet_Start 91 | -- Name: TreeDraw 92 | draw :: forall m selection. Bind m => SelectionM selection m => 93 | ScriptConfig -> FlareTreeNode -> m selection 94 | draw config tree = do 95 | root <- attach config.selector 96 | svg <- appendTo root Svg (config.viewbox <> 97 | [ classed "tree", width config.svg.width, height config.svg.height ]) 98 | container <- appendTo svg Group [ fontFamily "sans-serif", fontSize 10.0 ] 99 | links <- appendTo container Group [ classed "links"] 100 | nodes <- appendTo container Group [ classed "nodes"] 101 | 102 | theLinks_ <- simpleJoin links Path (links_ tree) keyIsID_ 103 | setAttributes theLinks_ [ strokeWidth 1.5, strokeColor config.color, strokeOpacity 0.4, fill "none", config.linkPath ] 104 | 105 | -- we make a group to hold the node circle and the label text 106 | nodeJoin_ <- simpleJoin nodes Group (descendants_ tree) keyIsID_ 107 | setAttributes nodeJoin_ config.nodeTransform 108 | 109 | theNodes <- appendTo nodeJoin_ Circle 110 | [ fill (\(d :: Datum_) -> if treeDatum_.hasChildren d then "#999" else "#555") 111 | , radius 2.5 112 | , strokeColor "white" 113 | ] 114 | 115 | theLabels <- appendTo nodeJoin_ Text 116 | [ dy 0.31 117 | , x (treeDatum_.textX config.layout) 118 | , textAnchor (treeDatum_.textAnchor config.layout) 119 | , text treeDatum_.name 120 | , fill config.color 121 | ] 122 | pure svg 123 | -- Snippet_End -------------------------------------------------------------------------------- /src/DemoApp/Viz/Tree/Model.purs: -------------------------------------------------------------------------------- 1 | module D3.Examples.Tree.Model where 2 | 3 | 4 | import D3.Node (D3TreeRow, D3Link, D3_SimulationNode, D3_VxyFxy, D3_XY, EmbeddedData, NodeID) 5 | import Type.Row (type (+)) 6 | 7 | 8 | -- Model data types specialized with inital data 9 | type FlareNodeRow row = ( name :: String | row ) 10 | type FlareNodeData = { | FlareNodeRow () } 11 | 12 | type FlareTreeNode = D3TreeRow (EmbeddedData FlareNodeData + ()) 13 | -- type FlareSimNode = D3SimulationRow ( FlareNodeRow + ()) 14 | type FlareSimNode = D3_SimulationNode (FlareNodeRow + D3_XY + D3_VxyFxy + ()) 15 | 16 | type FlareLinkData = ( value :: Number ) 17 | type FlareSimRecord = Record (FlareNodeRow + ()) 18 | type FlareLinkObj = { source :: FlareSimRecord, target :: FlareSimRecord | FlareLinkData } 19 | 20 | type FlareRawModel = { 21 | links :: Array (D3Link NodeID FlareLinkData) 22 | , nodes :: Array FlareNodeData 23 | } 24 | 25 | type FlareCookedModel = { 26 | links :: Array (D3Link NodeID FlareLinkData) 27 | , nodes :: Array FlareNodeData 28 | } 29 | -------------------------------------------------------------------------------- /src/DemoApp/Viz/Tree/Unsafe.purs: -------------------------------------------------------------------------------- 1 | module D3.Examples.Tree.Unsafe where 2 | 3 | 4 | import D3.Data.Types (Datum_) 5 | import D3.Examples.Tree.Model (FlareLinkObj, FlareNodeRow) 6 | import D3.Node (D3_ID, D3LinkSwizzled(..), D3_TreeNode(..), D3_TreeRow, D3_XY, EmbeddedData) 7 | import Type.Row (type (+)) 8 | import Unsafe.Coerce (unsafeCoerce) 9 | 10 | 11 | unboxD3SimLink :: Datum_ -> FlareLinkObj 12 | unboxD3SimLink datum = l 13 | where (D3LinkObj l) = unsafeCoerce datum 14 | 15 | unboxD3TreeNode datum = do 16 | let (t' :: D3_TreeNode (D3_ID + D3_TreeRow + D3_XY + (EmbeddedData { | FlareNodeRow () }) + () ) ) = unsafeCoerce datum 17 | (D3TreeNode t) = t' 18 | t -------------------------------------------------------------------------------- /src/DemoApp/css/package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "tailwind-beginner-blog", 3 | "version": "1.0.0", 4 | "main": "index.js", 5 | "license": "MIT", 6 | "dependencies": { 7 | "autoprefixer": "^10.2.6", 8 | "postcss-cli": "^8.3.1", 9 | "postcss-import": "^14.0.2", 10 | "postcss-nesting": "^8.0.1", 11 | "tailwindcss": "^2.1.4" 12 | }, 13 | "scripts": { 14 | "build": "postcss src/index.css -o ../../dist/index.css" 15 | } 16 | } 17 | -------------------------------------------------------------------------------- /src/DemoApp/css/postcss.config.js: -------------------------------------------------------------------------------- 1 | module.exports = { 2 | plugins: [ 3 | require('postcss-import'), 4 | require('tailwindcss'), 5 | require('postcss-nesting'), 6 | require('autoprefixer'), 7 | ] 8 | } -------------------------------------------------------------------------------- /src/DemoApp/css/src/composite-rules.css: -------------------------------------------------------------------------------- 1 | @layer components { 2 | .app-container { 3 | @apply w-screen h-screen flex flex-row; 4 | } 5 | .story-sidebar { 6 | @apply hidden top-0 bottom-0 left-0 overflow-y-auto bg-blue-500 border-gray-50 flex-none border-r-2 md:overflow-visible md:max-w-xs md:flex flex-col; 7 | } 8 | .story-container { 9 | @apply flex flex-row gap-1 h-screen w-full bg-gray-100; 10 | } 11 | /* .story-panel { 12 | @apply flex flex-col; 13 | } */ 14 | .story-panel-controls { 15 | @apply flex flex-col overflow-hidden h-screen min-w-min p-2 bg-white shadow-md; 16 | } 17 | .story-panel-about { 18 | @apply flex flex-col overflow-y-scroll h-screen max-w-prose p-2 bg-white shadow-md; 19 | } 20 | .story-panel-code { 21 | @apply flex flex-col overflow-y-scroll h-screen max-w-prose min-w-min p-2 bg-white shadow-md; 22 | } 23 | .story-panel-code div { 24 | @apply mb-2; 25 | } 26 | .svg-container { 27 | @apply flex-grow bg-white overflow-hidden; 28 | } 29 | } 30 | 31 | div.svg-container.cluster, 32 | div.svg-container.graph, 33 | div.svg-container.tree, 34 | div.svg-container.grid { 35 | & svg g.nodes g.updated text { 36 | font: 14px; 37 | fill: red; 38 | } 39 | } -------------------------------------------------------------------------------- /src/DemoApp/css/src/examples/GUP.css: -------------------------------------------------------------------------------- 1 | div.svg-container svg.gup { 2 | & text { font-size: 48px; font-family: monospace; } 3 | } 4 | -------------------------------------------------------------------------------- /src/DemoApp/css/src/examples/common.css: -------------------------------------------------------------------------------- 1 | div.story-panel-code pre.language-purescript { 2 | font-size: 8pt; 3 | } 4 | div.story-panel-code { 5 | width: fit-content; 6 | } -------------------------------------------------------------------------------- /src/DemoApp/css/src/examples/spago-cluster.css: -------------------------------------------------------------------------------- 1 | 2 | /* the svg-container's class is set by Halogen, thus controlling look of the visualization */ 3 | div.svg-container.cluster { 4 | & svg { 5 | &.spotlight { 6 | & g.package text { 7 | opacity: 0.2; 8 | } 9 | & g.module { 10 | opacity: 0.2; 11 | &.source, 12 | &.target, 13 | &.spotlight { 14 | opacity: 1; 15 | & text { 16 | fill: gray; 17 | } 18 | } 19 | } 20 | } 21 | & g.links line { 22 | opacity: 0.5; 23 | &.source { 24 | opacity: 0.8; 25 | stroke: red; 26 | stroke-width: 2px; 27 | } 28 | &.target { 29 | opacity: 0.8; 30 | stroke: blue; 31 | stroke-width: 2px; 32 | } 33 | } 34 | 35 | & g.nodes { 36 | & text { 37 | font: 12px sans-serif; 38 | text-anchor: middle; 39 | } 40 | & g.module { 41 | & text { 42 | visibility: hidden; 43 | } 44 | & circle { 45 | opacity: 1; 46 | } 47 | &:hover { 48 | & text { 49 | visibility: visible; 50 | fill: black; 51 | opacity: 0.8; 52 | } 53 | } 54 | } 55 | & g.package { 56 | & circle { 57 | visibility: visible; 58 | opacity: 0.3; 59 | } 60 | & text { 61 | visibility: visible; 62 | fill: black; 63 | font-size: 24px; 64 | opacity: 0.5; 65 | text-anchor: middle; 66 | } 67 | } 68 | & g.spotlight { 69 | & text { 70 | visibility: visible; 71 | } 72 | & circle { 73 | opacity: 1; 74 | stroke-width: 5px; 75 | stroke-dasharray: 4 1; 76 | stroke: black; 77 | } 78 | } 79 | } 80 | } 81 | } 82 | -------------------------------------------------------------------------------- /src/DemoApp/css/src/examples/spago-graph.css: -------------------------------------------------------------------------------- 1 | /* the svg-container's class is set by Halogen, thus controlling look of the visualization */ 2 | div.svg-container.graph { 3 | & svg { 4 | background-color: white; 5 | & g.links { 6 | & line { 7 | visibility: visible; 8 | opacity: 0.2; 9 | stroke-width: 1px; 10 | } 11 | & line.M2M-Graph { 12 | visibility: hidden; 13 | } 14 | & line.P2P { 15 | visibility: visible; 16 | opacity: 0.2; 17 | stroke-width: 1px; 18 | } 19 | } 20 | 21 | & g.nodes { 22 | & text { 23 | font: 12px sans-serif; 24 | text-anchor: middle; 25 | } 26 | & g.module { 27 | & text { 28 | visibility: visible; 29 | opacity: 0.5; 30 | } 31 | & circle { 32 | visibility: hidden; 33 | fill-opacity: 0.2; 34 | } 35 | &:hover { 36 | & text { 37 | visibility: visible; 38 | fill: black; 39 | opacity: 0.8; 40 | } 41 | & circle { 42 | visibility: visible; 43 | opacity: 0.9; 44 | } 45 | } 46 | } 47 | & g.package { 48 | & circle { 49 | } 50 | & text { 51 | visibility: visible; 52 | fill: black; 53 | font-size: 24px; 54 | opacity: 0.5; 55 | text-anchor: middle; 56 | } 57 | &:hover { 58 | & text { 59 | visibility: visible; 60 | opacity: 1; 61 | } 62 | & circle { visibility: visible; } 63 | } 64 | } 65 | } 66 | } 67 | } 68 | -------------------------------------------------------------------------------- /src/DemoApp/css/src/examples/spago-initial.css: -------------------------------------------------------------------------------- 1 | /* the svg-container's class is set by Halogen, thus controlling look of the visualization */ 2 | div.svg-container.initial { 3 | & svg { 4 | & g.links { 5 | & line.M2M-Graph { 6 | stroke: red; 7 | visibility: hidden; 8 | } 9 | & line.P2P { 10 | stroke: green; 11 | visibility: visible; 12 | } 13 | & line.in-package.dependency { 14 | stroke: blue; 15 | visibility: hidden; 16 | } 17 | } 18 | 19 | & g.nodes { 20 | & text { 21 | font: 12px sans-serif; 22 | text-anchor: middle; 23 | } 24 | & g.module { 25 | & text { 26 | visibility: hidden; 27 | opacity: 0.5; 28 | } 29 | & circle { 30 | visibility: visible; 31 | fill-opacity: 0.2; 32 | } 33 | &:hover { 34 | & text { 35 | visibility: visible; 36 | fill: black; 37 | opacity: 0.8; 38 | } 39 | & circle { 40 | visibility: visible; 41 | } 42 | } 43 | } 44 | & g.package { 45 | & circle { 46 | visibility: visible; 47 | } 48 | & text { 49 | visibility: hidden; 50 | fill: black; 51 | font-size: 24px; 52 | opacity: 0.5; 53 | text-anchor: middle; 54 | } 55 | &:hover { 56 | & text { 57 | visibility: visible; 58 | } 59 | } 60 | } 61 | } 62 | } 63 | } 64 | -------------------------------------------------------------------------------- /src/DemoApp/css/src/examples/spago-tree.css: -------------------------------------------------------------------------------- 1 | /* the svg-container's class is set by Halogen, thus controlling look of the visualization */ 2 | div.svg-container.tree { 3 | & svg { 4 | & g.links { 5 | & line { 6 | opacity: 0.3; 7 | } 8 | & line.M2M-Graph { 9 | stroke: red; 10 | visibility: hidden; 11 | } 12 | & path.M2M-Tree { /* tree links are splines, not straight lines */ 13 | fill: none; 14 | visibility: visible; 15 | } 16 | & line.P2P { 17 | stroke: green; 18 | visibility: visible; 19 | } 20 | & line.in-package.dependency { 21 | stroke: blue; 22 | visibility: hidden; 23 | } 24 | } 25 | 26 | & g.nodes { 27 | & text { 28 | font: 10px monospace; 29 | } 30 | & g.module { 31 | & text { 32 | opacity: 0.5; 33 | } 34 | & circle { 35 | visibility: visible; 36 | fill-opacity: 0.2; 37 | } 38 | & circle.connected { 39 | visibility: visible; 40 | fill-opacity: 1; 41 | } 42 | &:hover { 43 | & text { 44 | visibility: visible; 45 | fill: black; 46 | opacity: 0.8; 47 | } 48 | & circle { 49 | visibility: visible; 50 | } 51 | } 52 | } 53 | & g.module.connected { /* not sure why this rule isn't visible in browser even it's overruled by attribute on node */ 54 | & circle { 55 | visibility: visible; 56 | fill-opacity: 1; 57 | } 58 | } 59 | & g.package { 60 | & circle { 61 | visibility: visible; 62 | } 63 | & text { 64 | visibility: hidden; 65 | fill: black; 66 | font-size: 24px; 67 | opacity: 0.5; 68 | text-anchor: middle; 69 | } 70 | &:hover { 71 | & text { 72 | visibility: visible; 73 | } 74 | } 75 | } 76 | } 77 | } 78 | } 79 | /* now some small overrides (more specificity) */ 80 | div.svg-container.tree.vertical svg g.nodes text { 81 | transform: rotate(45deg); 82 | } 83 | -------------------------------------------------------------------------------- /src/DemoApp/css/src/index.css: -------------------------------------------------------------------------------- 1 | @import "examples/common.css"; 2 | @import "examples/GUP.css"; 3 | @import "examples/spago-cluster.css"; 4 | @import "examples/spago-graph.css"; 5 | @import "examples/spago-tree.css"; 6 | @import "tailwindcss/base"; 7 | @import "ocelot-1.css"; 8 | @import "fonts.css"; 9 | @import "icons.css"; 10 | @import "tailwindcss/components"; 11 | @import "tailwindcss/utilities"; 12 | @import "ocelot-2.css"; 13 | @import "composite-rules.css"; 14 | -------------------------------------------------------------------------------- /src/DemoApp/css/src/ocelot-1.css: -------------------------------------------------------------------------------- 1 | html, body { @apply gotham; @apply leading-normal; font-size: 12px; @apply text-black-20; } 2 | button, input, optgroup, select, textarea { @apply leading-normal; } 3 | 4 | /* Temp overrides */ 5 | 6 | * { 7 | font-size: inherit; 8 | } 9 | h3 { 10 | text-transform: unset; 11 | } 12 | fieldset legend { 13 | position: unset; 14 | top: 0; 15 | } 16 | legend { 17 | font-size: inherit; 18 | font-weight: inherit; 19 | color: inherit; 20 | border: unset; 21 | text-transform: inherit; 22 | } 23 | label { 24 | display: inherit; 25 | margin-bottom: unset; 26 | } 27 | th { 28 | text-align: inherit; 29 | } 30 | dt { 31 | margin-bottom: 0; 32 | } -------------------------------------------------------------------------------- /src/DemoApp/css/tailwind.config.js: -------------------------------------------------------------------------------- 1 | module.exports = { 2 | purge: [], 3 | darkMode: false, // or 'media' or 'class' 4 | theme: { 5 | screens: { 6 | sm: '480px', 7 | md: '768px', 8 | lg: '976px', 9 | xl: '1440px', 10 | xxl: '2000px', 11 | }, 12 | extend: { 13 | colors: { 14 | 'black-10': '#00091A', 15 | 'black-20': '#242A33', 16 | 'black-modal-a90': 'rgba(0,9,26,0.9)', 17 | 'grey-50': '#5C6573', 18 | 'grey-50-a20': 'rgba(102,113,128,0.2)', 19 | 'grey-50-a30': 'rgba(102,113,128,0.3)', 20 | 'grey-50-a80': 'rgba(102,113,128,0.8)', 21 | 'grey-50-a90': 'rgba(102,113,128,0.9)', 22 | 'grey-70': 'rgb(143,158,179)', 23 | 'grey-70-a30': 'rgba(143,158,179,0.3)', 24 | 'grey-70-a40': 'rgba(143,158,179,0.4)', 25 | 'grey-80': '#C2C6CC', 26 | 'grey-90': '#E1E3E6', 27 | 'grey-95': '#F0F1F2', 28 | 'grey-97': '#F7F7F7', 29 | 'blue-65': '#008AA6', 30 | 'blue-75': '#009FBF', 31 | 'blue-82': '#00ABD1', 32 | 'blue-88': '#00BBE0', 33 | 'red': '#FF5471', 34 | 'yellow': '#FFC859', 35 | 'green': '#66C7AF', 36 | 'steel-75': '#A8B2BF', 37 | 'steel-85': '#BFCAD9', 38 | 'steel-100': '#E6F0FF' 39 | }, 40 | spacing: { 41 | '0': '0', 42 | '5': '1.25rem', 43 | '7': '1.75rem', 44 | '9': '2.25rem', 45 | '10': '2.5rem', 46 | '12': '3rem', 47 | '14': '3.5rem', 48 | '16': '4rem', 49 | '20': '5rem', 50 | '30': '7.5rem', 51 | '40': '10rem', 52 | '50': '12.5rem', 53 | '60': '15rem', 54 | '80': '20rem', 55 | '90': '22.5rem', 56 | '120': '30rem', 57 | '160': '40rem', 58 | }, 59 | zIndex: { 60 | '60': '60', 61 | '-10': '-10', 62 | }, 63 | }, 64 | }, 65 | variants: { 66 | extend: {}, 67 | }, 68 | plugins: [], 69 | } 70 | -------------------------------------------------------------------------------- /src/lib/D3/Attributes/Instances.purs: -------------------------------------------------------------------------------- 1 | module D3.Attributes.Instances where 2 | 3 | import Prelude 4 | 5 | import D3.Data.Types (D3This_, Datum_, Index_) 6 | import Data.Function.Uncurried (Fn2, Fn3, mkFn2) 7 | import Effect (Effect) 8 | import Effect.Uncurried (EffectFn3) 9 | import Unsafe.Coerce (unsafeCoerce) 10 | import Web.Event.Internal.Types (Event) 11 | 12 | -- | Some useful type aliases 13 | type IndexedLambda a = Fn2 Datum_ Index_ a 14 | type Listener = (Event -> Datum_ -> D3This_ -> Unit) 15 | type Listener_ = Fn3 Event Datum_ D3This_ Unit 16 | type EffectfulListener = (Event -> Datum_ -> D3This_ -> Effect Unit) 17 | type EffectfulListener_ = EffectFn3 Event Datum_ D3This_ Unit 18 | type Label = String 19 | 20 | -- | Central feature of this module, 21 | data AttributeSetter = AttributeSetter Label Attr 22 | 23 | attributeLabel :: AttributeSetter -> String 24 | attributeLabel (AttributeSetter label _) = label 25 | 26 | attributeAttr :: AttributeSetter -> Attr 27 | attributeAttr (AttributeSetter _ a) = a 28 | 29 | data AttrBuilder a = 30 | Static a 31 | | Fn (Datum_ -> a) 32 | | FnI (IndexedLambda a) 33 | 34 | data Attr = 35 | StringAttr (AttrBuilder String) 36 | | NumberAttr (AttrBuilder Number) 37 | | ArrayAttr (AttrBuilder (Array Number)) 38 | 39 | -- Kind annotation to avoid "fun" with polykinds. 40 | class ToAttr :: Type -> Type -> Constraint 41 | -- | typeclass to enable polymorphic forms of the attribute setter 42 | class ToAttr to from | from -> to where 43 | toAttr :: from -> Attr 44 | 45 | -- | we only unbox the attr at the point where we ship it over the FFI to JavaScript 46 | -- | the JavaScript API (D3) is polymorphic in this sense, can accept any of AttrBuilder forms 47 | unboxAttr :: ∀ a. Attr -> a 48 | unboxAttr = 49 | case _ of 50 | (StringAttr (Static a)) -> unsafeCoerce a 51 | (StringAttr (Fn a)) -> unsafeCoerce a 52 | (StringAttr (FnI a)) -> unsafeCoerce a 53 | 54 | (NumberAttr (Static a)) -> unsafeCoerce a 55 | (NumberAttr (Fn a)) -> unsafeCoerce a 56 | (NumberAttr (FnI a)) -> unsafeCoerce a 57 | 58 | (ArrayAttr (Static a)) -> unsafeCoerce a 59 | (ArrayAttr (Fn a)) -> unsafeCoerce a 60 | (ArrayAttr (FnI a)) -> unsafeCoerce a 61 | 62 | -- | because the text attribute can only be String, it has only Static|Fn|FnI forms 63 | unboxText :: ∀ a. AttrBuilder String -> a 64 | unboxText = 65 | case _ of 66 | (Static a) -> unsafeCoerce a 67 | (Fn a) -> unsafeCoerce a 68 | (FnI a) -> unsafeCoerce a 69 | 70 | -- | Instances for the 9 combinations of attributeSetters we need 71 | -- | ie (Static, Fn, FnI) * (String, Number, Array Number) 72 | instance toAttrString :: ToAttr String String where 73 | toAttr = StringAttr <<< Static 74 | instance toAttrStringFn :: ToAttr String (Datum_ -> String) where 75 | toAttr = StringAttr <<< Fn 76 | instance toAttrStringFnI :: ToAttr String (Datum_ -> Index_ -> String) where 77 | toAttr = StringAttr <<< FnI <<< mkFn2 78 | 79 | instance toAttrNumber :: ToAttr Number Number where 80 | toAttr = NumberAttr <<< Static 81 | instance toAttrNumberFn :: ToAttr Number (Datum_ -> Number) where 82 | toAttr = NumberAttr <<< Fn 83 | instance toAttrNumberFnI :: ToAttr Number (Datum_ -> Index_ -> Number) where 84 | toAttr = NumberAttr <<< FnI <<< mkFn2 85 | 86 | instance toAttrArray :: ToAttr (Array Number) (Array Number) where 87 | toAttr = ArrayAttr <<< Static 88 | instance toAttrArrayFn :: ToAttr (Array Number) (Datum_ -> Array Number) where 89 | toAttr = ArrayAttr <<< Fn 90 | instance toAttrArrayFnI :: ToAttr (Array Number) (Datum_ -> Index_ -> Array Number) where 91 | toAttr = ArrayAttr <<< FnI <<< mkFn2 92 | -------------------------------------------------------------------------------- /src/lib/D3/Data/Graph.purs: -------------------------------------------------------------------------------- 1 | module D3.Data.Graph where 2 | 3 | import Data.Array (elem, filter, head, null, partition, uncons, (:)) 4 | import Data.Graph (Graph) 5 | import Data.Graph as G 6 | import Data.Maybe (Maybe(..)) 7 | import Data.Tree (Tree) 8 | import Data.Tuple (Tuple(..)) 9 | import Prelude 10 | 11 | type DepPath id = Array id 12 | type GraphSearchRecord id = { 13 | nodes :: Array id -- potentially confusingly this is just a list of nodes, not a list of dependencies 14 | , openDepPaths :: Array (DepPath id) 15 | , closedDepPaths :: Array (DepPath id) 16 | , dependencyTree :: Maybe (Tree id) 17 | , redundantLinks :: Array (Tuple id id) 18 | } 19 | 20 | getReachableNodes :: forall id r1 r2. (Ord id) => id -> Graph id { links :: { targets :: Array id | r1 } | r2 } -> GraphSearchRecord id 21 | getReachableNodes id graph = go { nodes: [], openDepPaths: [[id]], closedDepPaths: [], redundantLinks: [], dependencyTree: Nothing } 22 | where 23 | go :: GraphSearchRecord id -> GraphSearchRecord id 24 | go searchRecord@{ openDepPaths: [] } = searchRecord -- bottom out when all open paths are consumed 25 | go searchRecord = do 26 | case processNextOpenDepPath searchRecord of 27 | Nothing -> searchRecord -- bottom out but....possibly some exceptions to be looked at here 28 | (Just searchRecord') -> go searchRecord' 29 | 30 | processNextOpenDepPath :: GraphSearchRecord id -> Maybe (GraphSearchRecord id) 31 | processNextOpenDepPath searchRecord = do 32 | x <- uncons searchRecord.openDepPaths 33 | firstID <- head x.head -- NB we're pushing onto the path, cause head is easier than tail 34 | firstNode <- G.lookup firstID graph 35 | 36 | let newDeps = partition (\d -> not $ elem d searchRecord.nodes) firstNode.links.targets 37 | newOpenDepPaths = newDeps.yes <#> \d -> d : x.head -- ie [ab] with deps [bc] -> [abc, abd] 38 | prunedLinks = newDeps.no <#> \d -> Tuple firstID d -- these are the links that we dropped to make tree 39 | 40 | if null newOpenDepPaths 41 | -- moving the open path we just processed to the list of closedDepPaths 42 | then Just $ searchRecord { openDepPaths = x.tail 43 | , closedDepPaths = x.head : searchRecord.closedDepPaths 44 | , redundantLinks = searchRecord.redundantLinks <> prunedLinks } 45 | -- replace this open path with it's extension(s) 46 | else Just $ searchRecord { openDepPaths = x.tail <> newOpenDepPaths 47 | , nodes = searchRecord.nodes <> newDeps.yes 48 | , redundantLinks = searchRecord.redundantLinks <> prunedLinks } 49 | 50 | -------------------------------------------------------------------------------- /src/lib/D3/Data/Node.purs: -------------------------------------------------------------------------------- 1 | module D3.Node where 2 | 3 | import Data.Nullable (Nullable) 4 | import Type.Row (type (+)) 5 | 6 | -- ============================================================================================================================ 7 | -- | Types for working with D3 Trees and Graphs, to try to smooth the moving between them. 8 | -- | D3 Simulation/graph data is EXTENDED ROW whereas Tree/Hierarchy data has the original object EMBEDDED as { data: } 9 | -- | Work-in-progress 10 | -- ============================================================================================================================ 11 | 12 | -- ============================================================================================================================ 13 | -- | Links 14 | -- ============================================================================================================================ 15 | type NodeID = Int -- REVIEW won't always be an Int, could be a String, but why complicate the types prematurely 16 | -- a link specialized to a particular type of object, it can be initialized using IDs for objects of that type 17 | type D3LinkDatum l row = Record ( source :: l, target :: l | row ) 18 | newtype D3Link l row = D3LinkID { source :: l, target :: l | row } 19 | newtype D3LinkSwizzled l row = D3LinkObj { source :: l, target :: l | row } 20 | 21 | -- ============================================================================================================================ 22 | -- | Standard Graph node rows 23 | -- ============================================================================================================================ 24 | -- often we want to create a unique `id` from some other field(s) of data object 25 | type D3_ID row = ( id :: NodeID | row ) 26 | -- nodes of many types have or are given an x,y position 27 | type D3_XY row = ( x :: Number, y :: Number | row ) 28 | -- the fields that are acted upon by forces in the simulation 29 | type D3_VxyFxy row = ( vx :: Number, vy :: Number, fx :: Nullable Number, fy :: Nullable Number | row ) 30 | -- focus points for custom forces (such as clustering) 31 | type D3_FocusXY row = ( cluster :: Int, focusX :: Number, focusY :: Number | row ) 32 | 33 | -- the crucial type for building simulation-ready records with mixture of the rows above 34 | newtype D3_SimulationNode row = D3SimNode { | row } 35 | 36 | -- ============================================================================================================================ 37 | -- | Standard Tree row 38 | -- ============================================================================================================================ 39 | -- depth, height and possible value are common to all tree layouts (tidy tree, dendrogram, treemap, circlepack etc) 40 | type D3_TreeRow row = ( depth :: Int, height :: Int, value:: Nullable Number | row ) 41 | -- Radius, Rect are fields that are used in circlepack and treemap layouts respectively 42 | type D3_Radius row = ( r :: Number | row ) 43 | type D3_Rect row = ( x0 :: Number, y0 :: Number, x1 :: Number, y1 :: Number | row ) 44 | -- field to track whether node has TREE children, ie Parent or Leaf 45 | -- NB the node may still have GRAPH "children" / depends which have been pruned to get a tree 46 | -- (in the spago example, the Model nodes contain explicit lists of graph deps in and out and tree children 47 | -- which is probably the way you'll want to go) 48 | -- type D3_Leaf row = ( isTreeLeaf :: Boolean | row ) 49 | 50 | -- REVIEW WARNING WARNING WARNING WARNING 51 | newtype D3_TreeNode row = D3TreeNode { | D3_ID + D3_TreeRow + row } -- parent and children also in some records but only accessible via FFI calls 52 | type D3TreeRow row = D3_TreeNode ( D3_XY + row ) 53 | 54 | -- | not tested in any way yet 55 | type D3CirclePackRow row = D3_TreeNode ( D3_XY + D3_Radius + row ) 56 | -- | not tested in any way yet 57 | type D3TreeMapRow row = D3_TreeNode ( D3_Rect + row ) 58 | 59 | -- when you give data to d3.hierarchy the original object contents are present under the `data` field of the new hierarchical objects 60 | type EmbeddedData :: forall k. k -> Row k -> Row k 61 | type EmbeddedData d row= ( "data" :: d | row ) 62 | 63 | 64 | -- | *************************************************************************************************** 65 | -- | ********************************* D3 hierarchy node 66 | -- | D3 methods on D3_Hierarchy_Node_ 67 | -- ancestors() 68 | -- descendants() 69 | -- leaves() 70 | -- find() 71 | -- path() 72 | -- links() 73 | -- sum() 74 | -- count() 75 | -- sort() 76 | -- iterators and maps - each, eachAfter, eachBefore, copy 77 | -- | *************************************************************************************************** 78 | 79 | -- | *************************************************************************************************** 80 | -- | ********************************* D3 simulation node 81 | -- | D3 methods on D3_Simulation_Node 82 | -- alpha() 83 | -- alphaMin() 84 | -- alphaDecay() 85 | -- alphaTarget() 86 | -- velocityDecay() 87 | -- force(forcetype) 88 | -- find(x,y, [r]) 89 | -- randomSource 90 | -- on "tick" 91 | -- on "end" 92 | -- | *************************************************************************************************** 93 | 94 | -- TODO add more of these fundamental node / link types for Sankey and Chord diagrams at least 95 | 96 | -- | *************************************************************************************************** 97 | -- | ********************************* D3 sankey node 98 | -- | *************************************************************************************************** 99 | 100 | 101 | -- | *************************************************************************************************** 102 | -- | ********************************* D3 chord node 103 | -- | *************************************************************************************************** 104 | -------------------------------------------------------------------------------- /src/lib/D3/Data/Tree.js: -------------------------------------------------------------------------------- 1 | export function idTreeLeaf_(obj) { 2 | const treeObj = Object.assign({}, obj) 3 | treeObj.isTreeLeaf = true 4 | return treeObj 5 | } 6 | export function idTreeParent_(obj) { 7 | return children => { 8 | const treeObj = Object.assign({}, obj) 9 | treeObj.isTreeLeaf = false 10 | treeObj.children = children 11 | return treeObj 12 | } 13 | } 14 | 15 | export const emptyTreeJson_ = {} 16 | -------------------------------------------------------------------------------- /src/lib/D3/Data/Tree.purs: -------------------------------------------------------------------------------- 1 | module D3.Data.Tree ( 2 | TreeJson_, TreeLayoutFn_, TreeType(..), TreeModel, TreeLayout(..) 3 | , makeD3TreeJSONFromTreeID -- notably this is only used by Spago example right now 4 | )where 5 | 6 | import D3.Node (NodeID) 7 | import Data.Array as A 8 | import Data.List (List(..)) 9 | import Data.Map as M 10 | import Data.Maybe (Maybe(..)) 11 | import Data.Tree (Tree(..)) 12 | import Prelude (class Eq, class Show, (<$>)) 13 | 14 | foreign import data TreeJson_ :: Type 15 | foreign import emptyTreeJson_ :: TreeJson_ 16 | 17 | data TreeType = TidyTree | Dendrogram 18 | derive instance eqTreeType :: Eq TreeType 19 | instance showTreeType :: Show TreeType where 20 | show TidyTree = "Tidy Tree" 21 | show Dendrogram = "Dendrogram" 22 | 23 | data TreeLayout = Radial | Horizontal | Vertical 24 | derive instance eqTreeLayout :: Eq TreeLayout 25 | instance showTreeLayout :: Show TreeLayout where 26 | show Radial = "Radial" 27 | show Horizontal = "Horizontal" 28 | show Vertical = "Vertical" 29 | 30 | type TreeModel = { 31 | json :: TreeJson_ -- data from file 32 | , treeType :: TreeType 33 | , treeLayout :: TreeLayout 34 | , treeLayoutFn :: TreeLayoutFn_ 35 | , svgConfig :: { width :: Number, height :: Number } 36 | } 37 | 38 | foreign import data TreeLayoutFn_ :: Type 39 | 40 | -- | this function is to be used when you have a Tree ID, ie the id is already present for D3 41 | -- | so you likely just want a tree that can be laid out 42 | -- | in order to get the (x,y), height, depth etc that are initialized by a D3 tree layout 43 | -- | it does copy the name over because actually that is going to be needed for sorting in order 44 | -- | to make a tidy tree (radial in our spago example) 45 | makeD3TreeJSONFromTreeID :: forall d. Tree NodeID -> M.Map NodeID d -> TreeJson_ 46 | makeD3TreeJSONFromTreeID root nodesMap = go root 47 | where 48 | go (Node id children) = 49 | case M.lookup id nodesMap of 50 | Nothing -> emptyTreeJson_ -- TODO think of a more principled way to handle this 51 | (Just obj) -> case children of 52 | Nil -> idTreeLeaf_ obj 53 | _ -> idTreeParent_ obj (go <$> (A.fromFoldable children)) 54 | 55 | foreign import idTreeLeaf_ :: forall d. d -> TreeJson_ 56 | foreign import idTreeParent_ :: forall d. d -> Array TreeJson_ -> TreeJson_ 57 | 58 | -------------------------------------------------------------------------------- /src/lib/D3/Data/Types.purs: -------------------------------------------------------------------------------- 1 | module D3.Data.Types where 2 | 3 | import Data.Time.Duration (Milliseconds) 4 | import Prelude (class Show) 5 | import Unsafe.Coerce (unsafeCoerce) 6 | 7 | foreign import data Datum_ :: Type 8 | foreign import data Index_ :: Type 9 | index_ToInt :: Index_ -> Int 10 | index_ToInt = unsafeCoerce 11 | intToIndex_ :: Int -> Index_ 12 | intToIndex_ = unsafeCoerce 13 | 14 | foreign import data D3Data_ :: Type 15 | foreign import data D3Selection_ :: Type 16 | foreign import data D3Simulation_ :: Type -- has to be declared here to avoid cycle with Simulation.purs 17 | foreign import data D3Transition_ :: Type -- not clear yet if we need to distinguish from Selection 18 | foreign import data D3This_ :: Type -- not yet used but may be needed, ex. in callbacks 19 | foreign import data D3DomNode_ :: Type 20 | 21 | type Selector :: forall k. k -> Type 22 | type Selector selection = String 23 | 24 | data Element = Div | Svg | Circle | Line | Group | Text | Path | Rect 25 | instance showElement :: Show Element where 26 | show Div = "div" 27 | show Svg = "svg" 28 | show Circle = "circle" 29 | show Line = "line" 30 | show Group = "g" 31 | show Text = "text" 32 | show Path = "path" 33 | show Rect = "rect" 34 | 35 | -- TODO find a way to get units back in without making DSL hideous 36 | data UnitType = Px | Pt | Em | Rem | Percent 37 | instance showUnitType :: Show UnitType where 38 | show Px = "px" 39 | show Pt = "pt" 40 | show Em = "em" 41 | show Rem = "rem" 42 | show Percent = "%" 43 | 44 | -- TODO we could / should also allow keyboard and other events, all this on long finger for now 45 | data MouseEvent = MouseEnter | MouseLeave | MouseClick | MouseDown | MouseUp 46 | instance showMouseEvent :: Show MouseEvent where 47 | show MouseEnter = "mouseenter" 48 | show MouseLeave = "mouseleave" 49 | show MouseClick = "click" 50 | show MouseDown = "mousedown" 51 | show MouseUp = "mouseup" 52 | 53 | type PointXY = { x :: Number, y :: Number } 54 | 55 | -- | Transition definitions 56 | -- TODO make this a Newtype and give it monoid instance 57 | type Transition = { name :: String 58 | , delay :: Milliseconds-- can also be a function, ie (\d -> f d) 59 | , duration :: Milliseconds -- can also be a function, ie (\d -> f d) 60 | , easing :: EasingFunction 61 | } 62 | type D3Group_ = Array D3DomNode_ 63 | 64 | 65 | type EasingTime = Number 66 | type D3EasingFn = EasingTime -> EasingTime -- easing function maps 0-1 to 0-1 in some way with 0 -> 0, 1 -> 1 67 | data EasingFunction = 68 | DefaultCubic 69 | | EasingFunction D3EasingFn 70 | | EasingFactory (Datum_ -> Int -> D3Group_ -> D3This_ -> D3EasingFn) 71 | 72 | -- Zoom types 73 | -- TODO some Attr polymorphism needed here too 74 | type ZoomConfig_ = { 75 | extent :: Array (Array Number) 76 | , scaleExtent :: Array Number 77 | , name :: String 78 | , target :: D3Selection_ 79 | } 80 | type ZoomConfigDefault_ = { 81 | scaleExtent :: Array Number 82 | , name :: String 83 | , target :: D3Selection_ 84 | } 85 | -------------------------------------------------------------------------------- /src/lib/D3/Data/Utility.purs: -------------------------------------------------------------------------------- 1 | module Utility where 2 | 3 | import Prelude 4 | 5 | import Data.Array.NonEmpty (NonEmptyArray) 6 | import Data.Array.NonEmpty as NA 7 | import Data.Int (toNumber) 8 | import Data.Tuple (Tuple(..), fst, snd) 9 | import Effect (Effect) 10 | import Web.HTML (window) 11 | import Web.HTML.Window (innerHeight, innerWidth) 12 | 13 | getWindowWidthHeight :: Effect (Tuple Number Number) 14 | getWindowWidthHeight = do 15 | win <- window 16 | w <- innerWidth win 17 | h <- innerHeight win 18 | pure $ Tuple (toNumber w) (toNumber h) 19 | 20 | 21 | -- | move to utility file 22 | compareFst :: forall a b x. Ord a => Tuple a b -> Tuple a x -> Ordering 23 | compareFst a b = compare (fst a) (fst b) 24 | compareSnd :: forall a b x. Ord b => Tuple a b -> Tuple x b -> Ordering 25 | compareSnd a b = compare (snd a) (snd b) 26 | equalFst :: forall a b x. Eq a => Tuple a b -> Tuple a x -> Boolean 27 | equalFst a b = eq (fst a) (fst b) 28 | equalSnd :: forall a b x. Eq b => Tuple a b -> Tuple x b -> Boolean 29 | equalSnd a b = eq (snd a) (snd b) 30 | 31 | -- | chunk is a utility function that's easier to show than tell: 32 | -- | example input [ [(m1,p1), (m4,p1)], [(m2,p2), (m3,p2)], [(m5,p3)] ] 33 | -- | example ouput [ (p1, [m1,m4]), (p2, [m2,m3]), (p3, [m5]) ] 34 | chunk :: forall a b. NonEmptyArray (Tuple a b) -> Tuple b (Array a) 35 | chunk tuples = do 36 | let 37 | package = snd $ NA.head tuples 38 | contains = NA.toArray $ fst <$> tuples 39 | Tuple package contains 40 | -------------------------------------------------------------------------------- /src/lib/D3/Layouts/Hierarchical/Hierarchical.js: -------------------------------------------------------------------------------- 1 | // foreign import readJSONJS :: String -> TreeJson -- TODO no error handling at all here RN 2 | export function readJSON_(filecontents) { return JSON.parse(filecontents); } 3 | -------------------------------------------------------------------------------- /src/lib/D3/Layouts/Hierarchical/Hierarchical.purs: -------------------------------------------------------------------------------- 1 | module D3.Layouts.Hierarchical where 2 | 3 | import D3.Node 4 | 5 | import Affjax.Web (Error, URL) 6 | import Affjax.Web as AJAX 7 | import Affjax.ResponseFormat as ResponseFormat 8 | import D3.Attributes.Instances (AttributeSetter(..), toAttr) 9 | import D3.Data.Tree (TreeJson_, TreeLayout, TreeModel, TreeType) 10 | import D3.Data.Types (Datum_) 11 | import D3.FFI (find_, getLayout, hNodeDepth_, linkClusterHorizontal_, linkClusterVertical_, linkHorizontal2_, linkHorizontal_, linkRadial_, linkVertical_, sharesParent_) 12 | import D3.Selection (SelectionAttribute(..)) 13 | import Data.Bifunctor (rmap) 14 | import Data.Either (Either) 15 | import Data.Function.Uncurried (Fn2, mkFn2) 16 | import Data.Maybe (Maybe) 17 | import Data.Nullable (toMaybe) 18 | import Effect.Aff (Aff) 19 | import Effect.Class (class MonadEffect) 20 | import Prelude (class Bind, bind, pure, ($), (/)) 21 | 22 | find :: forall d. D3_TreeNode d -> (Datum_ -> Boolean) -> Maybe (D3_TreeNode d) 23 | find tree filter = toMaybe $ find_ tree filter 24 | 25 | getTreeViaAJAX :: URL -> Aff (Either Error TreeJson_) 26 | getTreeViaAJAX url = do 27 | result <- AJAX.get ResponseFormat.string url 28 | pure $ rmap (\{body} -> readJSON_ body) result 29 | 30 | makeModel :: Bind Aff => 31 | MonadEffect Aff => 32 | TreeType -> 33 | TreeLayout -> 34 | TreeJson_ -> 35 | Aff TreeModel 36 | makeModel treeType treeLayout json = do 37 | let 38 | -- svgConfig = { width: fst widthHeight, height: snd widthHeight } 39 | treeLayoutFn = getLayout treeType -- REVIEW why not run this here and fill in root_ ? 40 | svgConfig = { width: 650.0, height: 650.0 } 41 | pure $ { json, treeType, treeLayout, treeLayoutFn, svgConfig } 42 | 43 | foreign import readJSON_ :: String -> TreeJson_ -- TODO no error handling at all here RN 44 | 45 | -- not clear if we really want to write all these in PureScript, there is no Eq instance for parents etc 46 | -- but it will at least serve as documentation 47 | -- OTOH if it can be nicely written here, so much the better as custom separation and all _is_ necessary 48 | defaultSeparation :: forall d. Fn2 (D3_TreeNode d) (D3_TreeNode d) Number 49 | defaultSeparation = mkFn2 (\a b -> if (sharesParent_ a b) 50 | then 1.0 51 | else 2.0) 52 | 53 | radialSeparation :: forall r. Fn2 (D3_TreeNode r) (D3_TreeNode r) Number 54 | radialSeparation = mkFn2 (\a b -> if (sharesParent_ a b) 55 | then 1.0 56 | else 2.0 / (hNodeDepth_ a)) 57 | 58 | horizontalLink :: SelectionAttribute 59 | horizontalLink = AttrT $ AttributeSetter "d" $ toAttr linkHorizontal_ 60 | 61 | -- version for when the x and y point are already swapped 62 | -- should be default someday 63 | horizontalLink' :: SelectionAttribute 64 | horizontalLink' = AttrT $ AttributeSetter "d" $ toAttr linkHorizontal2_ 65 | 66 | verticalLink :: SelectionAttribute 67 | verticalLink = AttrT $ AttributeSetter "d" $ toAttr linkVertical_ 68 | 69 | horizontalClusterLink :: Number -> SelectionAttribute 70 | horizontalClusterLink yOffset = AttrT $ AttributeSetter "d" $ toAttr (linkClusterHorizontal_ yOffset) 71 | 72 | verticalClusterLink :: Number -> SelectionAttribute 73 | verticalClusterLink xOffset = AttrT $ AttributeSetter "d" $ toAttr (linkClusterVertical_ xOffset) 74 | 75 | radialLink :: (Datum_ -> Number) -> (Datum_ -> Number) -> SelectionAttribute 76 | radialLink angleFn radius_Fn = do 77 | let radialFn = linkRadial_ angleFn radius_Fn 78 | AttrT $ AttributeSetter "d" $ toAttr radialFn 79 | 80 | 81 | 82 | -------------------------------------------------------------------------------- /src/lib/D3/Layouts/Simulation/Config.purs: -------------------------------------------------------------------------------- 1 | module D3.Simulation.Config where 2 | 3 | import D3.Attributes.Instances (class ToAttr, Attr(..), AttrBuilder(..), AttributeSetter(..), toAttr) 4 | import D3.Data.Types (Datum_, Index_) 5 | import D3.Simulation.Types (ChainableF(..)) 6 | import Data.Number (infinity) 7 | import Prelude (negate, (<<<)) 8 | 9 | 10 | defaultForceRadialConfig :: (Datum_ -> Index_ -> Number) -> Array ChainableF 11 | defaultForceRadialConfig r = 12 | [ radius r, strength 0.1, x 0.0, y 0.0 ] 13 | 14 | defaultForceManyConfig :: Array ChainableF 15 | defaultForceManyConfig = 16 | [ strength (-30.0), theta 0.9, distanceMin 1.0, distanceMax infinity ] 17 | 18 | defaultForceCenterConfig :: Array ChainableF 19 | defaultForceCenterConfig = 20 | [ x 0.0, y 0.0, strength 1.0 ] 21 | 22 | defaultForceCollideConfig :: (Datum_ -> Index_ -> Number) -> Array ChainableF 23 | defaultForceCollideConfig r = 24 | [ radius r, strength 1.0, iterations 1.0 ] 25 | 26 | defaultForceXConfig :: Array ChainableF 27 | defaultForceXConfig = 28 | [ strength 0.1, x 0.0 ] 29 | 30 | defaultForceYConfig :: Array ChainableF 31 | defaultForceYConfig = 32 | [ strength 0.1, y 0.0 ] 33 | 34 | -- | ================================================================================================== 35 | -- | ========================= sugar for the various attributes of forces ============================= 36 | -- | ================================================================================================== 37 | radius :: ∀ a. ToAttr Number a => a -> ChainableF 38 | radius = ForceT <<< AttributeSetter "radius" <<< toAttr 39 | 40 | strength :: ∀ a. ToAttr Number a => a -> ChainableF 41 | strength = ForceT <<< AttributeSetter "strength" <<< toAttr 42 | 43 | -- cx :: ∀ a. ToAttr Number a => a -> ChainableF 44 | -- cx = ForceT <<< AttributeSetter "cx" <<< toAttr 45 | 46 | -- cy :: ∀ a. ToAttr Number a => a -> ChainableF 47 | -- cy = ForceT <<< AttributeSetter "cy" <<< toAttr 48 | 49 | theta :: ∀ a. ToAttr Number a => a -> ChainableF 50 | theta = ForceT <<< AttributeSetter "theta" <<< toAttr 51 | 52 | distanceMin :: ∀ a. ToAttr Number a => a -> ChainableF 53 | distanceMin = ForceT <<< AttributeSetter "distanceMin" <<< toAttr 54 | 55 | distanceMax :: ∀ a. ToAttr Number a => a -> ChainableF 56 | distanceMax = ForceT <<< AttributeSetter "distanceMax" <<< toAttr 57 | 58 | iterations :: ∀ a. ToAttr Number a => a -> ChainableF 59 | iterations = ForceT <<< AttributeSetter "iterations" <<< toAttr 60 | 61 | x :: ∀ a. ToAttr Number a => a -> ChainableF 62 | x = ForceT <<< AttributeSetter "x" <<< toAttr 63 | 64 | y :: ∀ a. ToAttr Number a => a -> ChainableF 65 | y = ForceT <<< AttributeSetter "y" <<< toAttr 66 | 67 | fx :: ∀ a. ToAttr Number a => a -> ChainableF 68 | fx = ForceT <<< AttributeSetter "fx" <<< toAttr 69 | 70 | fy :: ∀ a. ToAttr Number a => a -> ChainableF 71 | fy = ForceT <<< AttributeSetter "fy" <<< toAttr 72 | 73 | distance :: ∀ a. ToAttr Number a => a -> ChainableF 74 | distance = ForceT <<< AttributeSetter "distance" <<< toAttr 75 | 76 | index :: ∀ a. ToAttr Number a => a -> ChainableF -- TODO in fact this would be an Int correctly 77 | index = ForceT <<< AttributeSetter "distance" <<< toAttr 78 | 79 | -- these next two are for specifying how a link should swizzle its "id" to an object reference 80 | numKey :: (Datum_ -> Number) -> ChainableF 81 | numKey = ForceT <<< AttributeSetter "keyFn" <<< NumberAttr <<< Fn 82 | 83 | stringKey :: (Datum_ -> String) -> ChainableF 84 | stringKey = ForceT <<< AttributeSetter "keyFn" <<< StringAttr <<< Fn 85 | 86 | -------------------------------------------------------------------------------- /src/lib/D3/Scales/Scales.js: -------------------------------------------------------------------------------- 1 | // REVIEW big TODO here is to expose the domain setting of the scales so that this is usable in multiple contexts 2 | 3 | const d3SchemeCategory10 = d3.scaleOrdinal(d3.schemeCategory10) 4 | export function d3SchemeCategory10N_(number) { return d3SchemeCategory10(number) } 5 | export function d3SchemeCategory10S_(string) { return d3SchemeCategory10(string) } 6 | 7 | const d3SchemePaired = d3.scaleOrdinal(d3.schemePaired) 8 | export function d3SchemePairedN_(number) { return d3SchemePaired(number) } 9 | export function d3SchemePairedS_(string) { return d3SchemePaired(string) } 10 | 11 | const d3SchemeDiverging10 = d3.scaleDiverging(d3.interpolateBrBG) 12 | .domain([0, 250, 500]); // TODO this should be determined by number of nodes in sim 13 | export function d3SchemeDiverging10N_(number) { return d3SchemeDiverging10(number) } 14 | 15 | const d3SchemeSequential10 = d3.scaleSequential() 16 | .interpolator(d3.interpolateYlOrRd) 17 | .domain([0, 5, 10]); // TODO this should be determined by number of nodes in sim 18 | export function d3SchemeSequential10N_(number) { return d3SchemeSequential10(number) } 19 | 20 | 21 | // diverging example for reference 22 | // colorScale = d3.scaleSequential() 23 | // .interpolator(d3.interpolateBrBG) 24 | // .domain([0,99]); 25 | 26 | // sequential example for reference 27 | // colorScale = d3.scaleSequential() 28 | // .interpolator(d3.interpolateRgb("purple", "orange")) 29 | // .domain([0,99]); 30 | -------------------------------------------------------------------------------- /src/lib/D3/Scales/Scales.purs: -------------------------------------------------------------------------------- 1 | module D3.Scales where 2 | 3 | -- TODO much more to be ported over / wrapped here 4 | 5 | -- COLOR & SCALE functions 6 | -- gross simplification here, scales can take ranges and allsorts 7 | -- we just want to be able to pass d3.schemeCategory10 back in from Purescript to prove the idea tho RN 8 | 9 | type ScaleNumeric_ = Number -> String 10 | type ScaleString_ = String -> String -- REVIEW this might need coercion? 11 | 12 | foreign import d3SchemeCategory10N_ :: ScaleNumeric_ -- not modelling the scale / domain distinction yet 13 | foreign import d3SchemeDiverging10N_ :: ScaleNumeric_ -- not modelling the scale / domain distinction yet 14 | foreign import d3SchemeSequential10N_ :: ScaleNumeric_ -- not modelling the scale / domain distinction yet 15 | foreign import d3SchemeCategory10S_ :: ScaleString_ -- not modelling the scale / domain distinction yet 16 | foreign import d3SchemePairedN_ :: ScaleNumeric_ -------------------------------------------------------------------------------- /src/lib/D3/Selection/Functions.purs: -------------------------------------------------------------------------------- 1 | module D3.Selection.Functions where 2 | 3 | import D3.Data.Types (D3Selection_, Datum_, Element, Index_, Selector) 4 | import D3.FFI (d3Append_, d3AttachZoomDefaultExtent_, d3AttachZoom_, d3DataWithKeyFunction_, d3EnterAndAppend_, d3FilterSelection_, d3GetEnterSelection_, d3GetExitSelection_, d3MergeSelectionWith_, d3SelectAllInDOM_, d3SelectionSelectAll_, d3SelectionSelect_) 5 | import D3.Selection (Behavior(..), SelectionAttribute, applySelectionAttributeD3) 6 | import D3.Zoom (ScaleExtent(..), ZoomExtent(..)) 7 | import D3Tagless.Capabilities (class SelectionM) 8 | import Data.Foldable (foldl) 9 | import Debug (spy) 10 | import Prelude (Unit, discard, pure, show, unit, ($)) 11 | 12 | 13 | selectionAttach :: forall m. (SelectionM D3Selection_ m) => Selector D3Selection_ -> m D3Selection_ 14 | selectionAttach selector = pure $ d3SelectAllInDOM_ selector 15 | 16 | selectionSelectUnder :: forall m. (SelectionM D3Selection_ m) => D3Selection_ -> Selector D3Selection_ -> m D3Selection_ 17 | selectionSelectUnder selection selector = pure $ d3SelectionSelectAll_ selector selection 18 | 19 | selectionAppendElement :: forall m. (SelectionM D3Selection_ m) => D3Selection_ -> Element -> Array SelectionAttribute -> m D3Selection_ 20 | selectionAppendElement selection_ element attributes = do 21 | let appended_ = d3Append_ (show element) selection_ 22 | selectionModifySelection appended_ attributes 23 | pure appended_ 24 | 25 | selectionFilterSelection :: forall m. (SelectionM D3Selection_ m) => D3Selection_ -> Selector D3Selection_ -> m D3Selection_ 26 | selectionFilterSelection selection_ selector = pure $ d3FilterSelection_ selection_ selector 27 | 28 | selectionModifySelection :: forall m. (SelectionM D3Selection_ m) => D3Selection_ -> Array (SelectionAttribute) -> m Unit 29 | selectionModifySelection selection_ attributes = do 30 | let _ = foldl applySelectionAttributeD3 selection_ attributes 31 | pure unit 32 | 33 | selectionJoin :: forall datum m. (SelectionM D3Selection_ m) => D3Selection_ -> Element -> (Array datum) -> (Datum_ -> Index_) -> m D3Selection_ 34 | selectionJoin selection e theData keyFn = do 35 | let 36 | element = spy "Join: " $ show e 37 | selectS = d3SelectionSelectAll_ element selection 38 | dataSelection = d3DataWithKeyFunction_ theData keyFn selectS 39 | enterSelection = d3EnterAndAppend_ element dataSelection 40 | pure enterSelection 41 | 42 | selectionUpdateJoin :: forall datum m. 43 | (SelectionM D3Selection_ m) => 44 | D3Selection_ -> 45 | Element -> (Array datum) -> 46 | (Datum_ -> Index_) -> 47 | m { enter :: D3Selection_, exit :: D3Selection_, update :: D3Selection_ } 48 | selectionUpdateJoin openSelection e theData keyFn = do 49 | let 50 | -- REVIEW use these FFI function to decompose the update Selection into it's component parts 51 | updateSelection = d3DataWithKeyFunction_ theData keyFn openSelection 52 | enterSelection = d3GetEnterSelection_ updateSelection 53 | exitSelection = d3GetExitSelection_ updateSelection 54 | 55 | pure { enter: enterSelection, exit: exitSelection, update: updateSelection } 56 | 57 | selectionOpenSelection :: forall m. (SelectionM D3Selection_ m) => D3Selection_ -> Selector D3Selection_ -> m D3Selection_ 58 | selectionOpenSelection selection selector = do 59 | let _ = spy "open selection: " $ selector 60 | pure $ d3SelectionSelectAll_ selector selection 61 | 62 | selectionMergeSelections :: forall m. (SelectionM D3Selection_ m) => D3Selection_ -> D3Selection_ -> m D3Selection_ 63 | selectionMergeSelections selectionA selectionB = pure $ d3MergeSelectionWith_ selectionA selectionB 64 | 65 | selectionOn :: forall m. (SelectionM D3Selection_ m) => D3Selection_ -> Behavior D3Selection_ -> m Unit 66 | selectionOn selection (Drag drag) = do 67 | -- TODO need to provide the simpler, non-simulation version here 68 | -- let _ = case drag of 69 | -- DefaultDrag -> defaultDrag_ selection 70 | -- NoDrag -> disableDrag_ selection 71 | -- (CustomDrag fn) -> defaultDrag_ selection simulation_ -- TODO no custom drag implemented yet 72 | pure unit 73 | 74 | selectionOn selection (Zoom config) = do 75 | let 76 | (ScaleExtent smallest largest) = config.scale 77 | target = selection 78 | -- TODO recover the ability to "direct" the zoom to element other than the one receiving the event 79 | -- ie for controllers, containers etc 80 | 81 | -- sticking to the rules of no ADT's on the JS side we case on the ZoomExtent here 82 | _ = case config.extent of 83 | DefaultZoomExtent -> 84 | d3AttachZoomDefaultExtent_ selection { 85 | scaleExtent: [ smallest, largest ] 86 | , name : config.name 87 | , target 88 | } 89 | 90 | (ZoomExtent ze) -> do 91 | d3AttachZoom_ selection { 92 | extent : [ [ ze.left, ze.top ], [ ze.right, ze.bottom ] ] 93 | , scaleExtent: [ smallest, largest ] 94 | , name : config.name 95 | , target 96 | } 97 | pure unit -------------------------------------------------------------------------------- /src/lib/D3/Selection/Selection.purs: -------------------------------------------------------------------------------- 1 | module D3.Selection where 2 | 3 | import D3.FFI 4 | 5 | import D3.Attributes.Instances (AttributeSetter(..), Label, Listener_, EffectfulListener_, attributeLabel, unboxAttr) 6 | import D3.Data.Types (D3Selection_, Datum_, Element, MouseEvent, Transition) 7 | import D3.Zoom (ZoomConfig) 8 | import Data.Array (foldl) 9 | import Prelude (class Eq, class Ord, class Show, Unit, show, (<>)) 10 | 11 | -- type D3Selection = Last D3Selection_ 12 | 13 | data DragBehavior = 14 | DefaultDrag 15 | | NoDrag 16 | | CustomDrag Label D3DragFunction_ 17 | 18 | data Behavior selection = Drag DragBehavior 19 | | Zoom (ZoomConfig selection) 20 | 21 | newtype SelectionName = SelectionName String 22 | derive instance eqSelectionName :: Eq SelectionName 23 | derive instance ordSelectionName :: Ord SelectionName 24 | 25 | -- data D3_Node = D3_Node Element (Array SelectionAttribute) 26 | 27 | -- instance showD3_Node :: Show D3_Node where 28 | -- show (D3_Node e _) = "D3Node: " <> show e 29 | 30 | -- -- sugar for appending WITH attributes 31 | -- node :: Element -> (Array SelectionAttribute) -> D3_Node 32 | -- node e a = D3_Node e a 33 | 34 | -- -- sugar for appending with NO attributes 35 | -- node_ :: Element -> D3_Node 36 | -- node_ e = D3_Node e [] 37 | 38 | data OrderingAttribute = Order | Sort (Datum_ -> Datum_ -> Int) | Raise | Lower 39 | 40 | data SelectionAttribute = 41 | AttrT AttributeSetter 42 | | TextT AttributeSetter -- we can't narrow it to String here but helper function will do that 43 | | HTMLT AttributeSetter -- we can't narrow it to String here but helper function will do that 44 | | PropertyT AttributeSetter -- this might motivate adding a Boolean flavor of Attribute, eg for checkbox "checked" 45 | 46 | | OrderingT OrderingAttribute 47 | 48 | | TransitionT (Array SelectionAttribute) Transition -- the array is set situationally 49 | 50 | | RemoveT 51 | 52 | | OnT MouseEvent Listener_ 53 | | OnT' MouseEvent EffectfulListener_ 54 | 55 | instance showSelectionAttribute :: Show SelectionAttribute where 56 | show (AttrT attr) = "chainable: attr " <> attributeLabel attr 57 | show (TextT _) = "chainable: text" 58 | show (HTMLT attr) = "chainable: html" <> attributeLabel attr 59 | show (PropertyT attr) = "chainable: property" <> attributeLabel attr 60 | 61 | show (TransitionT _ _) = "chainable: transition" 62 | 63 | show RemoveT = "chainable: remove" 64 | -- show (ForceT _) = "chainable: force attr" 65 | show (OnT event _) = show event 66 | show (OnT' event _) = show event 67 | 68 | show (OrderingT attr) = "chainable: ordering" <> show attr 69 | 70 | 71 | instance showOrderingAttribute :: Show OrderingAttribute where 72 | show Order = "Order" 73 | show Raise = "Raise" 74 | show Lower = "Lower" 75 | show (Sort _) = "Sort" 76 | 77 | 78 | applySelectionAttributeD3 :: D3Selection_ -> SelectionAttribute -> D3Selection_ 79 | applySelectionAttributeD3 selection_ (AttrT (AttributeSetter label attr)) = 80 | d3SetAttr_ label (unboxAttr attr) selection_ 81 | 82 | -- NB only protection against non-text attribute for Text field is in the helper function 83 | -- and similarly for Property and HTML 84 | applySelectionAttributeD3 selection_ (TextT (AttributeSetter _ attr)) = d3SetText_ (unboxAttr attr) selection_ 85 | applySelectionAttributeD3 selection_ (PropertyT (AttributeSetter _ attr)) = d3SetProperty_ (unboxAttr attr) selection_ 86 | applySelectionAttributeD3 selection_ (HTMLT (AttributeSetter _ attr)) = d3SetHTML_ (unboxAttr attr) selection_ 87 | 88 | -- NB this remove call will have no effect on elements with active or pending transitions 89 | -- and this gives rise to very counter-intuitive misbehaviour as subsequent enters clash with 90 | -- elements that should have been removed 91 | -- also NB "selection" here will often be a "transition" but this distinction won't matter (i think) 92 | -- the remove function returns the removed selection which allows it to be cached amongst other things 93 | applySelectionAttributeD3 selection_ RemoveT = do 94 | let removed_ = d3RemoveSelection_ selection_ 95 | removed_ 96 | 97 | -- for transition in D3 we must use .call(selection, transition) so that chain continues 98 | -- in this interpreter it's enought to just return the selection instead of the transition 99 | applySelectionAttributeD3 selection_ (TransitionT chain transition) = do 100 | let tHandler = d3AddTransition_ selection_ transition 101 | _ = foldl applySelectionAttributeD3 tHandler chain 102 | selection_ -- NB we return selection, not transition 103 | 104 | applySelectionAttributeD3 selection_ (OnT event listener) = selectionOn_ selection_ (show event) listener 105 | applySelectionAttributeD3 selection_ (OnT' event listener) = selectionOn_ selection_ (show event) listener 106 | 107 | applySelectionAttributeD3 selection_ (OrderingT oAttr) = 108 | case oAttr of 109 | Order -> d3OrderSelection_ selection_ 110 | (Sort compare) -> d3SortSelection_ selection_ compare 111 | Raise -> d3RaiseSelection_ selection_ 112 | Lower -> d3LowerSelection_ selection_ 113 | -------------------------------------------------------------------------------- /src/lib/D3/Selection/Zoom.purs: -------------------------------------------------------------------------------- 1 | module D3.Zoom where 2 | 3 | import D3.FFI (ZoomBehavior_) 4 | import Web.Event.Internal.Types (Event) 5 | 6 | -- stuff related to zoom functionality 7 | type ZoomConfig selection = { 8 | extent :: ZoomExtent 9 | , scale :: ScaleExtent 10 | , name :: String -- zoom.foo 11 | , target :: selection 12 | -- this is the full list of values and their defaults 13 | -- filter = defaultFilter, 14 | -- extent = defaultExtent, 15 | -- constrain = defaultConstrain, 16 | -- wheelDelta = defaultWheelDelta, 17 | -- touchable = defaultTouchable, 18 | -- scaleExtent = [0, Infinity], 19 | -- translateExtent = [[-Infinity, -Infinity], [Infinity, Infinity]], 20 | -- duration = 250, 21 | -- interpolate = interpolateZoom, 22 | -- listeners = dispatch("start", "zoom", "end"), 23 | -- touchstarting, 24 | -- touchfirst, 25 | -- touchending, 26 | -- touchDelay = 500, 27 | -- wheelDelay = 150, 28 | -- clickDistance2 = 0, 29 | -- tapDistance = 10; 30 | } 31 | data ScaleExtent = ScaleExtent Number Number 32 | data ZoomExtent = DefaultZoomExtent 33 | | ZoomExtent { top :: Number, left :: Number, bottom :: Number, right :: Number } 34 | -- | ExtentFunction (Datum_ -> Array (Array Number)) 35 | data ZoomType = ZoomStart | ZoomEnd | ZoomZoom 36 | data ZoomTransform = ZoomTransform { k :: Number, tx :: Number, ty :: Number } 37 | type ZoomEvent = { 38 | target :: ZoomBehavior_ 39 | , type :: ZoomType 40 | , transform :: ZoomTransform 41 | , sourceEvent :: Event 42 | } 43 | 44 | zoomRange :: Number -> Number -> ScaleExtent 45 | zoomRange = ScaleExtent 46 | 47 | zoomExtent :: { bottom :: Number 48 | , left :: Number 49 | , right :: Number 50 | , top :: Number 51 | } -> ZoomExtent 52 | zoomExtent = ZoomExtent 53 | -------------------------------------------------------------------------------- /src/lib/Data/Tree.purs: -------------------------------------------------------------------------------- 1 | module Data.Tree where 2 | 3 | import Prelude 4 | 5 | import Data.Foldable (class Foldable) 6 | import Data.List (List(..), catMaybes, foldMap, foldl, foldr, fromFoldable, head) 7 | import Data.Maybe (Maybe(..)) 8 | import Data.Traversable (class Traversable, traverse) 9 | 10 | data Tree a = Node a (List (Tree a)) 11 | 12 | -- =========================================================================== 13 | -- || Maps and folds for Tree type 14 | -- =========================================================================== 15 | instance showTree :: (Show a) => Show (Tree a) where 16 | show (Node a cs) = show a <> " " <> show cs 17 | 18 | instance eqTree :: (Eq a) => Eq (Tree a) where 19 | eq (Node a cs) (Node a' cs') = a == a' && cs == cs' 20 | 21 | instance functorTree :: Functor Tree where 22 | map f (Node a cs) = Node (f a) (map f <$> cs) 23 | 24 | instance foldableTree :: Foldable Tree where 25 | foldr f b (Node a cs) = f a (foldr (flip $ foldr f) b cs) 26 | foldl f b (Node a cs) = f (foldl (foldl f) b cs) a 27 | foldMap f (Node a cs) = f a <> foldMap (foldMap f) cs 28 | 29 | instance traversableTree :: Traversable Tree where 30 | traverse f (Node a cs) = Node <$> f a <*> traverse (traverse f) cs 31 | sequence = traverse identity 32 | 33 | -- | map over the tree which updates tree's own data incorporating data from updated children 34 | treeMapDeep :: ∀ a b. (a -> List b -> b) -> Tree a -> Tree b 35 | treeMapDeep f (Node node' children) = Node (f node' newChildData) newChildren 36 | where newChildren = children <#> treeMapDeep f 37 | runData (Node d _) = d 38 | newChildData = runData <$> newChildren 39 | 40 | -- | map over the child arrays in the tree without touching tree data 41 | treeMapOverChildren :: ∀ a. (List (Tree a) -> List (Tree a)) -> Tree a -> Tree a 42 | treeMapOverChildren f (Node nd cs) = Node nd (f newCs) 43 | where 44 | newCs = cs <#> treeMapOverChildren f 45 | 46 | hasChildren :: ∀ a. Tree a -> Boolean 47 | hasChildren (Node _ Nil) = false 48 | hasChildren (Node _ _) = true 49 | 50 | subTree :: ∀ a. Tree a -> (a -> Boolean) -> Maybe (Tree a) 51 | subTree n@(Node d trees) pred = 52 | if pred d 53 | then Just n 54 | else head $ catMaybes $ trees <#> \tree -> subTree tree pred 55 | 56 | -- || you provide a predicate on the type in the tree and a transform on that data type 57 | -- || and you get back a list of the ones that matched transformed by the second function 58 | -- || eg filterTransformToList pred identity tree == List.fromFoldable 59 | filterTransformToList :: ∀ a b. (a -> Boolean) -> (a -> b) -> Tree a -> List b 60 | filterTransformToList nodePredicate dataTransform tree = foldl fn Nil tree 61 | where 62 | fn acc d = if nodePredicate d 63 | then Cons (dataTransform d) acc 64 | else acc 65 | 66 | -- || this is a potentially quite costly operation but it is very powerful as it takes a 67 | -- || predicate that works on entire (sub)trees 68 | filterTransformToListRecursive :: ∀ a b. (Tree a -> Boolean) -> (a -> b) -> Tree a -> List b 69 | filterTransformToListRecursive treePredicate dataTransform tree 70 | = catMaybes $ fromFoldable $ go tree 71 | where 72 | go :: Tree a -> Tree (Maybe b) 73 | go subtree@(Node a cs) 74 | = if treePredicate subtree 75 | then Node (Just (dataTransform a)) (go <$> cs) 76 | else Node Nothing (go <$> cs) 77 | 78 | -- || simple functions to enable us to write test cases more easily 79 | leaf :: forall a. a -> Tree a 80 | leaf a = Node a Nil 81 | 82 | node :: forall a. a -> Array (Tree a) -> Tree a 83 | node a childArray = Node a (fromFoldable childArray) -------------------------------------------------------------------------------- /src/lib/Interpreters/Capabilities.purs: -------------------------------------------------------------------------------- 1 | module D3Tagless.Capabilities where 2 | 3 | import D3.Attributes.Instances (Label) 4 | import D3.Data.Types (D3Simulation_, Datum_, Element, Index_, Selector) 5 | import D3.Node (D3Link, D3LinkSwizzled, D3_SimulationNode) 6 | import D3.Selection (Behavior, SelectionAttribute) 7 | import D3.Simulation.Types (Force, ForceStatus, SimVariable, Step) 8 | import Data.Map (Map) 9 | import Data.Maybe (Maybe) 10 | import Prelude (class Eq, class Monad, Unit) 11 | 12 | -- TODO see whether it can be useful to extend the interpreter here, for different visualization types 13 | -- in particular, it could be good to have Simulation do it's join function by putting nodes / links 14 | -- into both DOM and Simulation for example (and current implementation is gross and wrong) 15 | class (Monad m) <= SelectionM selection m where 16 | appendTo :: selection -> Element -> Array (SelectionAttribute) -> m selection 17 | selectUnder :: selection -> Selector selection -> m selection 18 | attach :: Selector selection -> m selection 19 | filterSelection :: selection -> Selector selection -> m selection 20 | mergeSelections :: selection -> selection -> m selection 21 | setAttributes :: selection -> Array (SelectionAttribute) -> m Unit 22 | on :: selection -> Behavior selection -> m Unit 23 | -- `openSelection` hopefully isn't needed and can be folded back into the UpdateJoin somehow (perhaps as a "first time only" thing or "when null") 24 | openSelection :: selection -> Selector selection -> m selection 25 | simpleJoin :: ∀ datum. selection -> Element -> (Array datum) -> (Datum_ -> Index_) -> m selection 26 | updateJoin :: ∀ datum. selection -> Element -> (Array datum) -> (Datum_ -> Index_) 27 | -> m { enter :: selection, exit :: selection, update :: selection } 28 | 29 | 30 | -- TODO things that are not handled by this (deliberately) ultra-simple grammar so far: 31 | -- 1) say you wanted to attach to "div#hook" and then select an _already existing_

in it and apply Attrs to that h1 32 | -- 2)... 33 | 34 | -- | These data types are to prevent "boolean blindness" when choosing forces to enable and disable 35 | type ForceConfigLists = { enable :: Array Label, disable :: Array Label } 36 | 37 | -- TODO 38 | -- parameterize out the D3_ part of SimulationNode - could we make all this opaque? 39 | -- note in the implementation we're putting the nodes and links into the SimulationState, but we 40 | -- return them for the Join to use using the same type...however, they may actually be changed 41 | -- from what was sent...it's not tidy yet 42 | class (Monad m, SelectionM selection m) <= SimulationM selection m | m -> selection where 43 | -- control 44 | start :: m Unit 45 | stop :: m Unit 46 | -- config 47 | setConfigVariable :: SimVariable -> m Unit 48 | -- management of forces 49 | -- | make the forces in the simulation match the forces in the simulation state 50 | actualizeForces:: Map Label ForceStatus -> m Unit 51 | -- setForcesByLabel :: { enable :: Array Label, disable :: Array Label } -> m Unit -- REVIEW not convinced this function is necessary 52 | -- management of data (nodes and links) 53 | setNodes :: forall d. Array (D3_SimulationNode d) -> m (Array (D3_SimulationNode d)) 54 | setLinks :: forall d r id. (Eq id) => Array (D3Link id r) -> Array (D3_SimulationNode d) -> (Datum_ -> Index_ ) -> m (Array (D3LinkSwizzled (D3_SimulationNode d) r)) 55 | -- the following versions are less type-safe but they are necessary for updating simulations 56 | -- it's up to the "script" writer to make sure the selection data matches the D3SimulationNode and/or D3LinkSwizzled 57 | setNodesFromSelection :: selection -> m Unit 58 | setLinksFromSelection :: selection -> (Datum_ -> Boolean) -> m Unit 59 | mergeNewDataWithSim :: forall d r id. (Eq id) => 60 | selection -> -- nodes selection 61 | (Datum_ -> Index_) -> -- nodes keyFn 62 | selection -> -- links selection 63 | (Datum_ -> Index_) -> -- links KeyFn 64 | RawData d r id -> -- links and nodes raw data 65 | m { links :: (Array (D3LinkSwizzled (D3_SimulationNode d) r)), nodes :: (Array (D3_SimulationNode d))} 66 | 67 | -- simulationHandle is needed for (at least) the following tick functions 68 | simulationHandle :: m D3Simulation_ 69 | -- adding functions that occur on every tick of the simulation clock 70 | -- this could potentially be extracted from here by doing each step of sim in PureScript 71 | addTickFunction :: Label -> Step selection -> m Unit 72 | removeTickFunction :: Label -> m Unit 73 | 74 | -- RawData type exists to clean up types of mergeNewDataWithSim 75 | type RawData d r id = { 76 | nodes :: Array (D3_SimulationNode d) 77 | , links :: Array (D3Link id r) 78 | } 79 | type Staging selection d r id = { 80 | selections :: { 81 | nodes :: Maybe selection 82 | , links :: Maybe selection 83 | } 84 | -- filter for links given to simulation engine, you don't necessarily want all links to be exerting force 85 | , linksWithForce :: Datum_ -> Boolean 86 | , rawdata :: RawData d r id 87 | } 88 | -------------------------------------------------------------------------------- /src/lib/Interpreters/D3/Selection.purs: -------------------------------------------------------------------------------- 1 | module D3Tagless.Instance.Selection where 2 | 3 | 4 | import Control.Monad.State (class MonadState, StateT, runStateT) 5 | import D3.Data.Types (D3Selection_) 6 | import D3.Selection.Functions (selectionAppendElement, selectionAttach, selectionFilterSelection, selectionJoin, selectionMergeSelections, selectionModifySelection, selectionOn, selectionOpenSelection, selectionSelectUnder, selectionUpdateJoin) 7 | import D3Tagless.Capabilities (class SelectionM) 8 | import Data.Tuple (Tuple, fst, snd) 9 | import Effect (Effect) 10 | import Effect.Class (class MonadEffect) 11 | import Prelude (class Applicative, class Apply, class Bind, class Functor, class Monad, Unit, liftA1, unit, ($)) 12 | 13 | -- not actually using Effect in foreign fns to keep sigs simple (for now) 14 | newtype D3M :: forall k. Type -> k -> Type -> Type 15 | newtype D3M state selection a = D3M (StateT state Effect a) 16 | 17 | derive newtype instance functorD3M :: Functor (D3M state selection) 18 | derive newtype instance applyD3M :: Apply (D3M state selection) 19 | derive newtype instance applicativeD3M :: Applicative (D3M state selection) 20 | derive newtype instance bindD3M :: Bind (D3M state selection) 21 | derive newtype instance monadD3M :: Monad (D3M state selection) 22 | derive newtype instance monadStateD3M :: MonadState state (D3M state selection) 23 | derive newtype instance monadEffD3M :: MonadEffect (D3M state selection) 24 | 25 | -- | ==================================================== 26 | -- | Selection instance (capability) for the D3 interpreter 27 | -- | ==================================================== 28 | instance d3TaglessD3M :: SelectionM D3Selection_ (D3M state D3Selection_) where 29 | attach selector = selectionAttach selector 30 | selectUnder s_ = selectionSelectUnder s_ 31 | appendTo s_ = selectionAppendElement s_ 32 | filterSelection s_ = selectionFilterSelection s_ 33 | openSelection s_ = selectionOpenSelection s_ 34 | mergeSelections s_ = selectionMergeSelections s_ 35 | setAttributes s_ = selectionModifySelection s_ 36 | simpleJoin s_ = selectionJoin s_ 37 | updateJoin s_ = selectionUpdateJoin s_ 38 | on s_ = selectionOn s_ 39 | 40 | runD3M :: forall a. D3M Unit D3Selection_ a -> Effect (Tuple a Unit) 41 | runD3M (D3M state_T) = runStateT state_T unit 42 | 43 | eval_D3M :: forall a. D3M Unit D3Selection_ a -> Effect a 44 | eval_D3M (D3M state_T) = liftA1 fst $ runStateT state_T unit 45 | 46 | exec_D3M :: forall a. D3M Unit D3Selection_ a -> Effect Unit 47 | exec_D3M (D3M state_T) = liftA1 snd $ runStateT state_T unit 48 | 49 | -------------------------------------------------------------------------------- /src/lib/Interpreters/D3/Utility.purs: -------------------------------------------------------------------------------- 1 | module D3Tagless.Utility where 2 | 3 | import D3.Data.Types (D3Selection_) 4 | import D3.FFI (d3RemoveSelection_, d3SelectFirstInDOM_, d3SelectionIsEmpty_, d3SelectionSelect_) 5 | import Prelude 6 | 7 | import D3Tagless.Capabilities (class SelectionM) 8 | import Debug (spy) 9 | 10 | -- TODO reuse existing SVG if it's the right one 11 | removeExistingSVG :: forall m. SelectionM D3Selection_ m => String -> m D3Selection_ 12 | removeExistingSVG rootSelector = do 13 | let 14 | root = d3SelectFirstInDOM_ rootSelector 15 | -- check for an svg element under the given root 16 | previous = d3SelectionSelect_ (rootSelector <> " svg") root 17 | pure $ 18 | case d3SelectionIsEmpty_ previous of -- 19 | true -> spy "no previous SVG to remove" previous 20 | false -> spy "removed previous SVG" $ d3RemoveSelection_ previous 21 | -------------------------------------------------------------------------------- /src/lib/Interpreters/MetaTree/Meta.js: -------------------------------------------------------------------------------- 1 | //pruneEmptyChildren :: Tree MetaTreeNode -> TreeJson_ 2 | export function pruneEmptyChildren(node) { 3 | prune(node); 4 | return node; 5 | } 6 | 7 | prune = function (node) { 8 | if (node.children.length == 0) { 9 | delete node.children; 10 | } else { 11 | node.children.forEach(child => prune(child) 12 | ) 13 | }; 14 | } -------------------------------------------------------------------------------- /src/lib/Interpreters/String/String.js: -------------------------------------------------------------------------------- 1 | // TODO all these show statements are getting pruned out in DCE and causing crash at runtime if you have debug enabled 2 | // so either have to backtrack on the extraction to functions or find a way to avoid them being pruned 3 | export function showSelectAllInDOM_(selector) { 4 | return `\td3SelectAllInDOM: ${selector}` 5 | } 6 | export function showSelectAll_(selector) { 7 | return selection => { 8 | return `\td3SelectionSelectAll: ${selection}.selectAll(${selector})` 9 | } 10 | } 11 | export function showEnterAndAppend_(element) { 12 | return selection => { 13 | return `\td3EnterAndAppend: ${selection}.enter().append(${element})` 14 | } 15 | } 16 | export function showExit_(selection) { 17 | return `\td3Exit: ${selection}.exit()` 18 | } 19 | export function showAddTransition_(selection) { 20 | return transition => { 21 | if (transition.name == '') { 22 | const statement1 = `\td3addTransition: ${selection}.transition(${transition})` 23 | var statement2 = '' 24 | var statement3 = '' 25 | if (transition.duration != 0) { 26 | statement2 = `transition.duration(${transition.duration})` 27 | } 28 | if (transition.delay != 0) { 29 | statement3 = `\t\ttransition.delay(${transition.delay})` 30 | } 31 | return statement1 + statement2 + statement3 32 | } else { 33 | return `\td3addNamedTransition: ${selection}.transition(${transition})` 34 | } 35 | } 36 | } 37 | export function showRemoveSelection_(selection) { 38 | return `\td3Remove: ${selection}.remove()` 39 | } 40 | export function showAppend_(element) { 41 | return selection => { 42 | return `\td3Append: ${selection}.append(${element})` 43 | } 44 | } 45 | export function showKeyFunction_(data) { 46 | return keyFunction => selection => { 47 | return `\td3Data: ${selection}.data(${data}, ${keyFunction})` 48 | } 49 | } 50 | export function showData_(data) { 51 | return selection => { 52 | return `\td3Data: ${selection}.data(${data})` 53 | } 54 | } 55 | export function showSetAttr_(name) { 56 | return value => selection => { 57 | return `\t${selection}.attr(${name}, ${value})` 58 | } 59 | } 60 | export function showSetText_(value) { 61 | return selection => { 62 | return `\t${selection}.text(${value})` 63 | } 64 | } 65 | export function showSetHTML_(value) { 66 | return selection => { 67 | return `\t${selection}.html(${value})` 68 | } 69 | } 70 | export function showSetProperty_(value) { 71 | return selection => { 72 | return `\t${selection}.property(${value})` 73 | } 74 | } 75 | export function showSetOrdering_(ordering) { 76 | return selection => { 77 | return `\t${selection}.${ordering}()` 78 | } 79 | } 80 | -------------------------------------------------------------------------------- /src/scripts/snippets3.pl: -------------------------------------------------------------------------------- 1 | use 5.010; 2 | use strict; 3 | use warnings; 4 | use Data::Dumper qw(Dumper); 5 | use File::Find::Rule; 6 | 7 | my %snippets; 8 | my $snipCount = 0; 9 | my $currentSnippetName = ""; 10 | my @snippetLines; 11 | my @tokens; 12 | 13 | my @files = File::Find::Rule->file() 14 | ->name( '*.purs' ) 15 | ->in( './src/' ); 16 | 17 | for my $file (@files) { 18 | print "file: $file\n"; 19 | } 20 | 21 | 22 | while (<@files>) { 23 | if (/Snippet_Start/../Snippet_End/) { # snippets are between these delimiters 24 | next if /Snippet_Start/; # we don't include the START delimiter 25 | if (/Snippet_End/ || eof) { # if end of file and in middle of snippet, finish current snippet 26 | $snippets{$currentSnippetName} = [ @snippetLines ]; 27 | @snippetLines = (); # reset the accumulator to empty array 28 | next; # we don't include the END delimiters 29 | } 30 | if (/Name: /) { # get name of snippet from line following /SNIPPET/ 31 | $snipCount++; # start a new snippet 32 | @tokens = split(' ', $_); # tokenize name line 33 | $currentSnippetName = $tokens[2]; # name is the third item 34 | } 35 | else { 36 | push (@snippetLines, $_); # we're in snippet, push this line onto accumulator; 37 | } 38 | } 39 | } 40 | 41 | # print Dumper \%snippets; 42 | 43 | my $name; 44 | my $i; 45 | foreach $name ( keys %snippets ) { 46 | print "snippet: $name\n"; 47 | open(FH, '>', $name.purs) or die $!; 48 | foreach $i ( 0 .. $snippets{$name}->$#* ) { 49 | print FH "$snippets{$name}[$i]"; 50 | } 51 | close(FH); 52 | } 53 | -------------------------------------------------------------------------------- /src/scripts/tiny.pl: -------------------------------------------------------------------------------- 1 | @ARGV = qw(.) unless @ARGV; 2 | use File::Find; 3 | 4 | find sub { print $File::Find::name, -d && '/', "\n" }, @ARGV; 5 | 6 | # use File::Find::Rule; 7 | 8 | # my @files = File::Find::Rule->file() 9 | # ->name( '*.purs' ) 10 | # ->in( './src/' ); 11 | -------------------------------------------------------------------------------- /test/Main.purs: -------------------------------------------------------------------------------- 1 | module Test.Main where 2 | 3 | import Prelude 4 | 5 | import Effect (Effect) 6 | import Effect.Class.Console (log) 7 | 8 | main :: Effect Unit 9 | main = do 10 | log "🍝" 11 | log "You should add some tests." 12 | --------------------------------------------------------------------------------