diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml new file mode 100644 index 0000000..101b7e6 --- /dev/null +++ b/.github/workflows/ci.yml @@ -0,0 +1,35 @@ +name: CI + +on: + push: + branches: [main] + pull_request: + +jobs: + build: + runs-on: ubuntu-latest + + steps: + - uses: actions/checkout@v2 + + - name: Set up PureScript toolchain + uses: purescript-contrib/setup-purescript@main + + - name: Cache PureScript dependencies + uses: actions/cache@v2 + with: + key: ${{ runner.os }}-spago-${{ hashFiles('**/*.dhall') }} + path: | + .spago + output + + - name: Set up Node toolchain + uses: actions/setup-node@v1 + with: + node-version: "12.x" + + - name: Install Spago dependencies + run: spago install + + - name: Build the project + run: spago build diff --git a/.gitignore b/.gitignore index 5f1dfa2..714a793 100644 --- a/.gitignore +++ b/.gitignore @@ -5,3 +5,7 @@ /.psci* package-lock.json .psc-package +/.spago/ +/generated-docs/ +.psc* +.purs* diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index d80bba0..0000000 --- a/.travis.yml +++ /dev/null @@ -1,10 +0,0 @@ -language: node_js -dist: trusty -sudo: required -node_js: 8 -install: - - npm install -g psc-package pulp purescript@">=0.12 <0.13" - - npm install -script: - - pulp --version - - npm test diff --git a/LICENSE b/LICENSE index bdb6c1d..883fcfa 100644 --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,8 @@ BSD 3-Clause License -Copyright (c) 2017, Kai Wohlfahrt +Copyright (c) 2017-2018, Kai Wohlfahrt +Copyright (c) 2019, Statebox and their contributors +Copyright (c) 2020, Jordan Martinez All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/bower.json b/bower.json index 6eff996..c2fb349 100644 --- a/bower.json +++ b/bower.json @@ -1,5 +1,5 @@ { - "name": "purescript-halogen-svg", + "name": "purescript-halogen-svg-elems", "authors": [ "Kai Wohlfahrt " ], @@ -11,15 +11,13 @@ "output" ], "dependencies": { - "purescript-strings": "^3.3.1", - "purescript-halogen": "^5.0.0", - "purescript-dom-indexed": "^5.0.0" + "purescript-halogen": "^6.0.0" }, "devDependencies": { - "purescript-psci-support": "^3.0.0" + "purescript-psci-support": "^5.0.0" }, "repository": { "type": "git", - "url": "https://github.com/kwohlfahrt/purescript-halogen-svg.git" + "url": "https://github.com/JordanMartinez/purescript-halogen-svg-elems.git" } } diff --git a/examples/circle/.gitignore b/examples/circle/.gitignore deleted file mode 100644 index 9fd72ce..0000000 --- a/examples/circle/.gitignore +++ /dev/null @@ -1,8 +0,0 @@ -/bower_components/ -/node_modules/ -/.pulp-cache/ -/output/ -/.psci* -/src/.webpack.js -/dist/app.js -/*.log diff --git a/examples/circle/README.md b/examples/circle/README.md deleted file mode 100644 index 2f91f2a..0000000 --- a/examples/circle/README.md +++ /dev/null @@ -1,13 +0,0 @@ -# Circle Example - -This is a minimal example to show (and test) SVG usage. - -## Building - -From the current directory: - - > npm install - > npm run build - -The code will be build as `./dist/app.js`, runnable by opening -`./dist/index.html`. diff --git a/examples/circle/bower.json b/examples/circle/bower.json deleted file mode 100644 index 13f8b71..0000000 --- a/examples/circle/bower.json +++ /dev/null @@ -1,7 +0,0 @@ -{ - "name": "circle", - "private": true, - "dependencies": { - "purescript-halogen-svg": "git://github.com/kwohlfahrt/purescript-halogen-svg.git" - } -} diff --git a/examples/circle/dist/index.html b/examples/circle/dist/index.html deleted file mode 100644 index aa9c02d..0000000 --- a/examples/circle/dist/index.html +++ /dev/null @@ -1,24 +0,0 @@ - - - - - My Halogen App - - - - - - diff --git a/examples/circle/package.json b/examples/circle/package.json deleted file mode 120000 index 138a42c..0000000 --- a/examples/circle/package.json +++ /dev/null @@ -1 +0,0 @@ -../../package.json \ No newline at end of file diff --git a/examples/circle/psc-package.json b/examples/circle/psc-package.json deleted file mode 100644 index 12fcd0d..0000000 --- a/examples/circle/psc-package.json +++ /dev/null @@ -1,8 +0,0 @@ -{ - "name": "svg-example", - "set": "master", - "source": "https://github.com/kwohlfahrt/package-sets.git", - "depends": [ - "prelude", "halogen", "halogen-svg", "web-uievents", "effect" - ] -} diff --git a/examples/circle/src/Main.purs b/examples/circle/src/Main.purs deleted file mode 100644 index f60b065..0000000 --- a/examples/circle/src/Main.purs +++ /dev/null @@ -1,51 +0,0 @@ -module Main where - -import Prelude -import Data.Maybe (Maybe(..)) - -import Effect (Effect) - -import Halogen as H -import Halogen.HTML (HTML) -import Halogen.HTML.Events as HE -import Halogen.Aff (awaitBody, runHalogenAff) -import Halogen.VDom.Driver (runUI) - -import Svg.Elements as SE -import Svg.Attributes as SA - -data Query a = ToggleState a - -type State = { on :: Boolean } - -initialState :: forall t . t -> State -initialState = const { on: false } - -ui :: forall g. H.Component HTML Query Unit Void g -ui = H.component { initialState, render, eval, receiver: const Nothing } - where - render :: State -> H.ComponentHTML Query - render state = - SE.svg [SA.viewBox x y w h] - [ SE.circle - [ SA.r (if state.on then w/6.0 else w/3.0) - , SA.fill $ Just (SA.RGB 0 0 100) - , HE.onClick (HE.input_ ToggleState) - ] - ] - - where - h = 150.0 - w = 150.0 - x = -(w / 2.0) - y = -(h / 2.0) - - eval :: Query ~> H.ComponentDSL State Query Void g - eval (ToggleState next) = do - _ <- H.modify (\state -> state { on = not state.on }) - pure next - -main :: Effect Unit -main = runHalogenAff do - body <- awaitBody - runUI ui unit body diff --git a/package.json b/package.json deleted file mode 100644 index 6a7cae5..0000000 --- a/package.json +++ /dev/null @@ -1,17 +0,0 @@ -{ - "private": true, - "scripts": { - "postinstall": "psc-package install", - "build": "pulp --psc-package browserify --optimise --to dist/app.js", - "watch": "pulp --psc-package -w browserify --to dist/app.js", - "test": "pulp --psc-package test" - }, - "dependencies": { - "virtual-dom": "^2.1.1" - }, - "devDependencies": { - "pulp": "^13.0.0", - "psc-package": "^3.0.1", - "purescript": "^0.13.0" - } -} diff --git a/packages.dhall b/packages.dhall new file mode 100644 index 0000000..ad93573 --- /dev/null +++ b/packages.dhall @@ -0,0 +1,4 @@ +let upstream = + https://github.com/purescript/package-sets/releases/download/psc-0.14.0-20210317/packages.dhall sha256:e2e744972f9b60188dcf07f41418661b505c9ee2e9f91e57e67daefad3a5ae09 + +in upstream diff --git a/psc-package.json b/psc-package.json deleted file mode 100644 index e315358..0000000 --- a/psc-package.json +++ /dev/null @@ -1,8 +0,0 @@ -{ - "name": "halogen-svg", - "set": "psc-0.13.3-20190818", - "source": "https://github.com/purescript/package-sets.git", - "depends": [ - "prelude", "halogen", "strings", "web-uievents", "effect" - ] -} diff --git a/spago.dhall b/spago.dhall new file mode 100644 index 0000000..b2111f7 --- /dev/null +++ b/spago.dhall @@ -0,0 +1,12 @@ +{- +Welcome to a Spago project! +You can edit this file as you like. +-} +{ name = "halogen-svg" +, dependencies = + [ "halogen" + , "psci-support" + ] +, packages = ./packages.dhall +, sources = [ "src/**/*.purs", "test/**/*.purs" ] +} diff --git a/src/Halogen/Svg/Attributes.purs b/src/Halogen/Svg/Attributes.purs new file mode 100644 index 0000000..650a5d4 --- /dev/null +++ b/src/Halogen/Svg/Attributes.purs @@ -0,0 +1,524 @@ +module Halogen.Svg.Attributes + ( Color(..) + , printColor + , Transform(..) + , TextAnchor(..) + , CSSLength(..) + , FontSize(..) + , Orient(..) + , printOrient + , MarkerUnit(..) + , printMarkerUnit + , printTextAnchor + , Baseline(..) + , printBaseline + , printTransform + , PathCommand -- constructor not exported + , printPathCommand + , CommandPositionReference(..) + , CommandArcChoice(..) + , printCommandArcChoice + , CommandSweepChoice(..) + , printCommandSweepChoice + , m, l, h, v, c, s, q, t, a, z + , Align(..) + , printAlign + , MeetOrSlice(..) + , printMeetOrSlice + , attr + , cx, cy + , r + , viewBox + , preserveAspectRatio + , rx, ry + , width, height + , x, y + , x1, y1 + , x2, y2 + , stroke + , fill + , transform + , d + , text_anchor + , font_size + , dominant_baseline + , class_ + , classes + , id + , markerWidth, markerHeight + , refX, refY + , orient + , markerUnits + , strokeWidth + , markerEnd + , DurationF(..) + , printDurationF + , Duration + , printDuration + , seconds + , FillState(..) + , printFillState + , dur + , attributeName + , from, to + , begin + , repeatCount + , fillAnim + , xlinkHref + , path + ) + where +-- Like Halogen.HTML.Properties + +import Prelude +import Data.Maybe (Maybe(..), maybe) +import Data.Newtype (un) +import Data.String (joinWith, toUpper) + +import Halogen.Svg.Core as Core + +import Halogen.HTML.Core (Prop, AttrName(AttrName), Namespace(Namespace), ClassName(..)) +import Halogen.HTML.Properties (IProp, attrNS) +import Unsafe.Coerce (unsafeCoerce) + +data Color = RGB Int Int Int + | RGBA Int Int Int Number + +printColor :: Maybe Color -> String +printColor = case _ of + Just (RGB r_ g_ b_) -> "rgb(" <> (joinWith "," $ map show [r_, g_, b_]) <> ")" + Just (RGBA r_ g_ b_ o) -> "rgba(" <> (joinWith "," $ map show [r_, g_, b_]) <> "," <> show o <> ")" + Nothing -> "None" + +data Transform + = Matrix Number Number Number Number Number Number + | Translate Number Number + | Scale Number Number + | Rotate Number Number Number + | SkewX Number + | SkewY Number + +data TextAnchor = Start | AnchorMiddle | End + +data CSSLength + = Cm Number + | Mm Number + | Inches Number + | Px Number + | Pt Number + | Pc Number + | Em Number + | Ex Number + | Rem Number + | Vw Number + | Vh Number + | Vmin Number + | Vmax Number + | Pct Number + | Nil + +instance showCSSLength :: Show CSSLength where + show = case _ of + Cm i -> (show i) <> "cm" + Mm i -> (show i) <> "mm" + Inches i -> (show i) <> "in" + Px i -> (show i) <> "px" + Pt i -> (show i) <> "pt" + Pc i -> (show i) <> "pc" + Em i -> (show i) <> "em" + Ex i -> (show i) <> "ex" + Rem i -> (show i) <> "rem" + Vw i -> (show i) <> "vw" + Vh i -> (show i) <> "vh" + Vmin i -> (show i) <> "vmin" + Vmax i -> (show i) <> "vmax" + Pct i -> (show i) <> "%" + Nil -> "0" + +data FontSize + = XXSmall + | XSmall + | Small + | Medium + | Large + | XLarge + | XXLarge + | Smaller + | Larger + | FontSizeLength CSSLength + +data Orient + = AutoOrient + | AutoStartReverse + +instance showOrient :: Show Orient where + show AutoOrient = "auto" + show AutoStartReverse = "auto-start-reverse" + +printOrient :: Orient -> String +printOrient AutoOrient = "auto" +printOrient AutoStartReverse = "auto-start-reverse" + +data MarkerUnit + = UserSpaceOnUse + | StrokeWidth + +instance showMarkerUnit :: Show MarkerUnit where + show UserSpaceOnUse = "userSpaceOnUse" + show StrokeWidth = "strokeWidth" + +printMarkerUnit :: MarkerUnit -> String +printMarkerUnit = case _ of + UserSpaceOnUse -> "userSpaceOnUse" + StrokeWidth -> "strokeWidth" + +instance showFontSize :: Show FontSize where + show = case _ of + XXSmall -> "xx-small" + XSmall -> "x-small" + Small -> "small" + Medium -> "medium" + Large -> "large" + XLarge -> "x-large" + XXLarge -> "xx-large" + Smaller -> "smaller" + Larger -> "larger" + FontSizeLength l_ -> show l_ + +printTextAnchor :: TextAnchor -> String +printTextAnchor = case _ of + Start -> "start" + AnchorMiddle -> "middle" + End -> "end" + +data Baseline + = Auto | UseScript | NoChange | ResetSize | Ideographic | Alphabetic | Hanging + | Mathematical | Central | BaselineMiddle | TextAfterEdge | TextBeforeEdge + +printBaseline :: Baseline -> String +printBaseline = case _ of + Auto -> "auto" + UseScript -> "use-script" + NoChange -> "no-change" + ResetSize -> "reset-size" + Ideographic -> "ideographic" + Alphabetic -> "alphabetic" + Hanging -> "hanging" + Mathematical -> "mathematical" + Central -> "central" + BaselineMiddle -> "middle" + TextAfterEdge -> "text-after-edge" + TextBeforeEdge -> "text-before-edge" + +printTransform :: Transform -> String +printTransform = case _ of + Matrix a_ b_ c_ d_ e_ f_ -> + "matrix(" <> (joinWith "," $ map show [a_, b_, c_, d_, e_, f_]) <> ")" + Translate x_ y_ -> + "translate(" <> (joinWith "," $ map show [x_, y_]) <> ")" + Scale x_ y_ -> + "scale(" <> (joinWith "," $ map show [x_, y_]) <> ")" + Rotate a_ x_ y_ -> + "rotate(" <> (joinWith "," $ map show [a_, x_, y_]) <> ")" + SkewX a_ -> + "skewX(" <> show a_ <> ")" + SkewY a_ -> + "skewY(" <> show a_ <> ")" + +newtype PathCommand = PathCommand String +derive instance eqPathCommand :: Eq PathCommand +instance showPathCommand :: Show PathCommand where + show val = printPathCommand val + +printPathCommand :: PathCommand -> String +printPathCommand (PathCommand s_) = s_ + +data CommandPositionReference = Rel | Abs +derive instance eqCommandPositionReference :: Eq CommandPositionReference +instance showCommandPositionReference :: Show CommandPositionReference where + show = case _ of + Abs -> "Abs" + Rel -> "Rel" + +-- | Arc0 = Small arc +-- | Arc1 = Large arc +data CommandArcChoice = Arc0 | Arc1 +derive instance eqCommandArcChoice :: Eq CommandArcChoice +instance showCommandArcChoice :: Show CommandArcChoice where + show = case _ of + Arc0 -> "Arc0" + Arc1 -> "Arc1" + +printCommandArcChoice :: CommandArcChoice -> String +printCommandArcChoice = case _ of + Arc0 -> "0" + Arc1 -> "1" + +-- | Sweep0 = Counter-Clockwise / Negative +-- | Sweep1 = Clockwise / Positive +data CommandSweepChoice = Sweep0 | Sweep1 +derive instance eqCommandSweepChoice :: Eq CommandSweepChoice +instance showCommandSweepChoice :: Show CommandSweepChoice where + show = case _ of + Sweep0 -> "Sweep0" + Sweep1 -> "Sweep1" + +printCommandSweepChoice :: CommandSweepChoice -> String +printCommandSweepChoice = case _ of + Sweep0 -> "0" + Sweep1 -> "1" + +-- For internal use. Do not export. +renderCommand :: CommandPositionReference -> String -> String +renderCommand cmd s_ = case cmd of + Rel -> s_ + Abs -> toUpper s_ + +-- For internal use. Do not export. +renderCommand1Arg :: String -> CommandPositionReference -> Number -> PathCommand +renderCommand1Arg s_ ref a_ = PathCommand $ (renderCommand ref s_) <> show a_ + +-- For internal use. Do not export. +renderCommand2Args :: String -> CommandPositionReference -> Number -> Number -> PathCommand +renderCommand2Args s_ ref a_ b = + PathCommand $ (renderCommand ref s_) <> show a_ <> ", " <> show b + +-- For internal use. Do not export. +renderCommand4Args :: String -> CommandPositionReference -> Number -> Number -> Number -> Number -> PathCommand +renderCommand4Args s_ ref a_ b c_ d_ = + PathCommand $ (renderCommand ref s_) <> + show a_ <> ", " <> show b <> ", " <> show c_ <> ", " <> show d_ + +m :: CommandPositionReference -> Number -> Number -> PathCommand +m = renderCommand2Args "m" + +l :: CommandPositionReference -> Number -> Number -> PathCommand +l = renderCommand2Args "l" + +h :: CommandPositionReference -> Number -> PathCommand +h = renderCommand1Arg "h" + +v :: CommandPositionReference -> Number -> PathCommand +v = renderCommand1Arg "v" + +c :: CommandPositionReference -> Number -> Number -> Number -> Number -> Number -> Number -> PathCommand +c ref x1_ y1_ x2_ y2_ x_ y_ = PathCommand $ (renderCommand ref "c") <> + show x1_ <> ", " <> show y1_ <> ", " <> show x2_ <> ", " <> show y2_ <> ", " <> + show x_ <> ", " <> show y_ + +s :: CommandPositionReference -> Number -> Number -> Number -> Number -> PathCommand +s = renderCommand4Args "s" + +q :: CommandPositionReference -> Number -> Number -> Number -> Number -> PathCommand +q = renderCommand4Args "q" + +t :: CommandPositionReference -> Number -> Number -> PathCommand +t = renderCommand2Args "t" + +a :: CommandPositionReference -> Number -> Number -> Number -> CommandArcChoice -> CommandSweepChoice -> Number -> Number -> PathCommand +a ref rx_ ry_ rot arc sweep x_ y_ = PathCommand $ (renderCommand ref "a") <> + show rx_ <> ", " <> show ry_ <> ", " <> show rot <> " " <> + (printCommandArcChoice arc) <> " " <> (printCommandSweepChoice sweep) <> " " <> + show x_ <> " " <> show y_ + +z :: PathCommand +z = PathCommand "z" + +data Align = Min | Mid | Max + +printAlign :: Align -> String +printAlign = case _ of + Min -> "Min" + Mid -> "Mid" + Max -> "Max" + +data MeetOrSlice = Meet | Slice + +printMeetOrSlice :: MeetOrSlice -> String +printMeetOrSlice = case _ of + Meet -> "meet" + Slice -> "slice" + +attr :: forall r i. AttrName -> String -> IProp r i +attr = coe Core.attr + where + coe :: (AttrName -> String -> Prop i) -> AttrName -> String -> IProp r i + coe = unsafeCoerce + +cx :: forall r i. Number -> IProp (cx :: Number | r) i +cx = attr (AttrName "cx") <<< show + +cy :: forall r i. Number -> IProp (cy :: Number | r) i +cy = attr (AttrName "cy") <<< show + +r :: forall s i. Number -> IProp (r :: Number | s) i +r = attr (AttrName "r") <<< show + +viewBox :: forall r i. Number -> Number -> Number -> Number -> IProp (viewBox :: String | r) i +viewBox x_ y_ w h_ = attr (AttrName "viewBox") (joinWith " " $ map show [x_, y_, w, h_]) + +preserveAspectRatio :: forall r i. Maybe {x_ :: Align, y_ :: Align} -> MeetOrSlice -> IProp (preserveAspectRatio :: String | r) i +preserveAspectRatio align slice = + attr (AttrName "preserveAspectRatio") (joinWith " " $ [align_str, printMeetOrSlice slice]) + where + align_str = case align of + Nothing -> "none" + Just {x_, y_} -> joinWith "" $ ["x", printAlign x_, "Y", printAlign y_] + +rx :: forall r i. Number -> IProp (rx :: Number | r) i +rx = attr (AttrName "rx") <<< show + +ry :: forall r i. Number -> IProp (ry :: Number | r) i +ry = attr (AttrName "ry") <<< show + +width :: forall r i. Number -> IProp (width :: Number | r) i +width = attr (AttrName "width") <<< show + +height :: forall r i. Number -> IProp (height :: Number | r) i +height = attr (AttrName "height") <<< show + +x :: forall r i. Number -> IProp (x :: Number | r) i +x = attr (AttrName "x") <<< show + +y :: forall r i. Number -> IProp (y :: Number | r) i +y = attr (AttrName "y") <<< show + +x1 :: forall r i. Number -> IProp (x1 :: Number | r) i +x1 = attr (AttrName "x1") <<< show + +y1 :: forall r i. Number -> IProp (y1 :: Number | r) i +y1 = attr (AttrName "y1") <<< show + +x2 :: forall r i. Number -> IProp (x2 :: Number | r) i +x2 = attr (AttrName "x2") <<< show + +y2 :: forall r i. Number -> IProp (y2 :: Number | r) i +y2 = attr (AttrName "y2") <<< show + +stroke :: forall r i. Maybe Color -> IProp (stroke :: String | r) i +stroke = attr (AttrName "stroke") <<< printColor + +fill :: forall r i. Maybe Color -> IProp (fill :: String | r) i +fill = attr (AttrName "fill") <<< printColor + +transform :: forall r i . Array Transform -> IProp (transform :: String | r) i +transform = attr (AttrName "transform") <<< joinWith " " <<< map printTransform + +d :: forall r i . Array PathCommand -> IProp (d :: String | r) i +d = attr (AttrName "d") <<< joinWith " " <<< unwrapNewtype + where + unwrapNewtype :: Array PathCommand -> Array String + unwrapNewtype = unsafeCoerce + +text_anchor :: forall r i . TextAnchor -> IProp (text_anchor :: String | r) i +text_anchor = attr (AttrName "text-anchor") <<< printTextAnchor + +font_size :: forall r i. FontSize -> IProp (font_size :: String | r) i +font_size = attr (AttrName "font-size") <<< show + +dominant_baseline :: forall r i . Baseline -> IProp (transform :: String | r) i +dominant_baseline = attr (AttrName "dominant-baseline") <<< printBaseline + +class_ :: forall r i . ClassName -> IProp (class :: String | r) i +class_ = attr (AttrName "class") <<< un ClassName + +classes :: forall r i . Array ClassName -> IProp (class :: String | r) i +classes = attr (AttrName "class") <<< joinWith " " <<< unwrapNewtype + where + unwrapNewtype :: Array ClassName -> Array String + unwrapNewtype = unsafeCoerce + +id :: forall r i . String -> IProp (id :: String | r) i +id = attr (AttrName "id") + +markerWidth :: forall r i. Number -> IProp (markerWidth :: Number | r) i +markerWidth = attr (AttrName "markerWidth") <<< show + +markerHeight :: forall r i. Number -> IProp (markerHeight :: Number | r) i +markerHeight = attr (AttrName "markerHeight") <<< show + +refX :: forall r i. Number -> IProp (refX :: Number | r) i +refX = attr (AttrName "refX") <<< show + +refY :: forall r i. Number -> IProp (refY :: Number | r) i +refY = attr (AttrName "refY") <<< show + +orient :: forall r i. Orient -> IProp (orient :: String | r) i +orient = attr (AttrName "orient") <<< printOrient + +markerUnits :: forall r i. MarkerUnit -> IProp (markerUnits :: String | r) i +markerUnits = attr (AttrName "markerUnits") <<< printMarkerUnit + +strokeWidth :: forall r i. Number -> IProp (strokeWidth :: Number | r) i +strokeWidth = attr (AttrName "stroke-width") <<< show + +markerEnd :: forall r i. String -> IProp (markerEnd :: String | r) i +markerEnd = attr (AttrName "marker-end") + +-------------------------------------------------------------------------------- + +-- | https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/dur +data DurationF a = Duration (Maybe a) (Maybe a) (Maybe a) (Maybe a) -- ^ TODO hours minutes seconds millis + +derive instance functorDurationF :: Functor DurationF + +printDurationF :: forall a. Show a => DurationF a -> String +printDurationF (Duration h_ m_ s_ i) = f "h" h_ <> f "m" m_ <> f "s" s_ <> f "i" i + where f u = maybe "" (\val -> show val <> u) + +type Duration = DurationF Number + +-- TODO derive Show instance for DurationF + +printDuration :: Duration -> String +printDuration = printDurationF + +-- TODO add other constructors +seconds :: Number -> Duration +seconds s_ = Duration Nothing Nothing (Just s_) Nothing + +data FillState = Freeze | Remove + +printFillState :: FillState -> String +printFillState = case _ of + Freeze -> "freeze" + Remove -> "remove" + +dur :: forall r i. Duration -> IProp (dur :: String | r) i +dur = attr (AttrName "dur") <<< printDuration + +-- TODO ADT or free string? +attributeName :: forall r i. String -> IProp (attributeName :: String | r) i +attributeName = attr (AttrName "attributeName") + +-- https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/from +from :: forall r i. String -> IProp (from :: String | r) i +from = attr (AttrName "from") + +-- https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/to +to :: forall r i. String -> IProp (to :: String | r) i +to = attr (AttrName "to") + +-- https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/begin +begin :: forall r i. String -> IProp (begin :: String | r) i +begin = attr (AttrName "begin") + +repeatCount :: forall r i. Int -> IProp (repeatCount :: Int | r) i +repeatCount = attr (AttrName "repeatCount") <<< show + +-- TODO this is just 'fill', but that function is already specialised to Color in this module +fillAnim :: forall r i. FillState -> IProp (fill :: String | r) i +fillAnim = attr (AttrName "fill") <<< printFillState + +-- TODO xlink:href seems to have some issues, among others around its namespace +xlinkHref :: forall r i. String -> IProp (xlinkHref :: String | r) i +-- xlinkHref = attr (AttrName "xlink:href") +-- xlinkHref = attrNS (Namespace "xlink") (AttrName "href") +xlinkHref = attrNS (Namespace "xlink") (AttrName "xlink:href") + +-- TODO copied from `d`; adapt where needed +path :: forall r i . Array PathCommand -> IProp (path :: String | r) i +path = attr (AttrName "path") <<< joinWith " " <<< unwrapNewtype + where + unwrapNewtype :: Array PathCommand -> Array String + unwrapNewtype = unsafeCoerce diff --git a/src/Svg/Core.purs b/src/Halogen/Svg/Core.purs similarity index 96% rename from src/Svg/Core.purs rename to src/Halogen/Svg/Core.purs index e624595..91397c1 100644 --- a/src/Svg/Core.purs +++ b/src/Halogen/Svg/Core.purs @@ -1,4 +1,4 @@ -module Core where +module Halogen.Svg.Core where -- Like Halogen.HTML.Core import Prelude diff --git a/src/Svg/Elements.purs b/src/Halogen/Svg/Elements.purs similarity index 95% rename from src/Svg/Elements.purs rename to src/Halogen/Svg/Elements.purs index cca01bf..9d9d810 100644 --- a/src/Svg/Elements.purs +++ b/src/Halogen/Svg/Elements.purs @@ -1,15 +1,15 @@ -module Svg.Elements where +module Halogen.Svg.Elements where -- Like Halogen.HTML.Elements import Prelude -import Core as Core +import Halogen.Svg.Core as Core import Halogen.HTML.Core (HTML, Prop, ElemName(ElemName)) import Halogen.HTML.Elements (Node, Leaf) import Halogen.HTML.Properties (IProp) import Unsafe.Coerce (unsafeCoerce) -import Svg.Indexed as I +import Halogen.Svg.Indexed as I element :: forall r p i. ElemName -> Array (IProp r i) -> Array (HTML p i) -> HTML p i element = coe Core.element diff --git a/src/Svg/Indexed.purs b/src/Halogen/Svg/Indexed.purs similarity index 98% rename from src/Svg/Indexed.purs rename to src/Halogen/Svg/Indexed.purs index 077d229..685f0db 100644 --- a/src/Svg/Indexed.purs +++ b/src/Halogen/Svg/Indexed.purs @@ -1,4 +1,4 @@ -module Svg.Indexed where +module Halogen.Svg.Indexed where import Web.UIEvent.MouseEvent (MouseEvent) import Web.UIEvent.WheelEvent (WheelEvent) diff --git a/src/Svg/Util.js b/src/Halogen/Svg/Util.js similarity index 98% rename from src/Svg/Util.js rename to src/Halogen/Svg/Util.js index 823687d..d073d1f 100644 --- a/src/Svg/Util.js +++ b/src/Halogen/Svg/Util.js @@ -1,3 +1,4 @@ +"use strict"; // module Svg.Util exports._beginElements = function (cssSelectorStr) { diff --git a/src/Svg/Util.purs b/src/Halogen/Svg/Util.purs similarity index 93% rename from src/Svg/Util.purs rename to src/Halogen/Svg/Util.purs index 66ae698..37ed89a 100644 --- a/src/Svg/Util.purs +++ b/src/Halogen/Svg/Util.purs @@ -1,4 +1,4 @@ -module Svg.Util where +module Halogen.Svg.Util where import Prelude ((<<<)) import Effect.Aff (Aff) diff --git a/src/Svg/Attributes.purs b/src/Svg/Attributes.purs deleted file mode 100644 index 10227d7..0000000 --- a/src/Svg/Attributes.purs +++ /dev/null @@ -1,366 +0,0 @@ -module Svg.Attributes where --- Like Halogen.HTML.Properties - -import Prelude -import Data.Maybe (Maybe(..), maybe) -import Data.String (joinWith, toUpper) - -import Core as Core - -import Halogen.HTML.Core (Prop, AttrName(AttrName), Namespace(Namespace)) -import Halogen.HTML.Properties (IProp, attrNS) -import Unsafe.Coerce (unsafeCoerce) - -data Color = RGB Int Int Int - | RGBA Int Int Int Number - -printColor :: Maybe Color -> String -printColor (Just (RGB r g b)) = "rgb(" <> (joinWith "," $ map show [r, g, b]) <> ")" -printColor (Just (RGBA r g b o)) = "rgba(" <> (joinWith "," $ map show [r, g, b]) <> "," <> show o <> ")" -printColor Nothing = "None" - -data Transform - = Matrix Number Number Number Number Number Number - | Translate Number Number - | Scale Number Number - | Rotate Number Number Number - | SkewX Number - | SkewY Number - -data TextAnchor = Start | AnchorMiddle | End - -data CSSLength - = Cm Number - | Mm Number - | Inches Number - | Px Number - | Pt Number - | Pc Number - | Em Number - | Ex Number - | Rem Number - | Vw Number - | Vh Number - | Vmin Number - | Vmax Number - | Pct Number - | Nil - -instance showCSSLength :: Show CSSLength where - show (Cm i) = (show i) <> "cm" - show (Mm i) = (show i) <> "mm" - show (Inches i) = (show i) <> "in" - show (Px i) = (show i) <> "px" - show (Pt i) = (show i) <> "pt" - show (Pc i) = (show i) <> "pc" - show (Em i) = (show i) <> "em" - show (Ex i) = (show i) <> "ex" - show (Rem i) = (show i) <> "rem" - show (Vw i) = (show i) <> "vw" - show (Vh i) = (show i) <> "vh" - show (Vmin i) = (show i) <> "vmin" - show (Vmax i) = (show i) <> "vmax" - show (Pct i) = (show i) <> "%" - show Nil = "0" - -data FontSize - = XXSmall - | XSmall - | Small - | Medium - | Large - | XLarge - | XXLarge - | Smaller - | Larger - | FontSizeLength CSSLength - -data Orient - = AutoOrient - | AutoStartReverse - -instance showOrient :: Show Orient where - show AutoOrient = "auto" - show AutoStartReverse = "auto-start-reverse" - -printOrient :: Orient -> String -printOrient AutoOrient = "auto" -printOrient AutoStartReverse = "auto-start-reverse" - -data MarkerUnit - = UserSpaceOnUse - | StrokeWidth - -instance showMarkerUnit :: Show MarkerUnit where - show UserSpaceOnUse = "userSpaceOnUse" - show StrokeWidth = "strokeWidth" - -printMarkerUnit :: MarkerUnit -> String -printMarkerUnit UserSpaceOnUse = "userSpaceOnUse" -printMarkerUnit StrokeWidth = "strokeWidth" - -instance showFontSize :: Show FontSize where - show XXSmall = "xx-small" - show XSmall = "x-small" - show Small = "small" - show Medium = "medium" - show Large = "large" - show XLarge = "x-large" - show XXLarge = "xx-large" - show Smaller = "smaller" - show Larger = "larger" - show (FontSizeLength l) = show l - -printTextAnchor :: TextAnchor -> String -printTextAnchor Start = "start" -printTextAnchor AnchorMiddle = "middle" -printTextAnchor End = "end" - -data Baseline - = Auto | UseScript | NoChange | ResetSize | Ideographic | Alphabetic | Hanging - | Mathematical | Central | BaselineMiddle | TextAfterEdge | TextBeforeEdge - -printBaseline :: Baseline -> String -printBaseline Auto = "auto" -printBaseline UseScript = "use-script" -printBaseline NoChange = "no-change" -printBaseline ResetSize = "reset-size" -printBaseline Ideographic = "ideographic" -printBaseline Alphabetic = "alphabetic" -printBaseline Hanging = "hanging" -printBaseline Mathematical = "mathematical" -printBaseline Central = "central" -printBaseline BaselineMiddle = "middle" -printBaseline TextAfterEdge = "text-after-edge" -printBaseline TextBeforeEdge = "text-before-edge" - -printTransform :: Transform -> String -printTransform (Matrix a b c d e f) = - "matrix(" <> (joinWith "," $ map show [a, b, c, d, e, f]) <> ")" -printTransform (Translate x y) = "translate(" <> (joinWith "," $ map show [x, y]) <> ")" -printTransform (Scale x y) = "scale(" <> (joinWith "," $ map show [x, y]) <> ")" -printTransform (Rotate a x y) = "rotate(" <> (joinWith "," $ map show [a, x, y]) <> ")" -printTransform (SkewX a) = "skewX(" <> show a <> ")" -printTransform (SkewY a) = "skewY(" <> show a <> ")" - -data D = Rel Command | Abs Command -printD :: D -> String -printD (Abs cmd) = (toUpper p.command) <> p.params - where p = printCommand cmd -printD (Rel cmd) = p.command <> p.params - where p = printCommand cmd - -data Command - = M Number Number - | L Number Number - | C Number Number Number Number Number Number - | S Number Number Number Number - | Q Number Number Number Number - | T Number Number - | A Number Number Number Boolean Boolean Number Number - | Z - -printCommand :: Command -> {command :: String, params :: String} -printCommand (M x y) = {command: "m", params: joinWith "," $ map show [x, y]} -printCommand (L x y) = {command: "l", params: joinWith "," $ map show [x, y]} -printCommand (C x1 y1 x2 y2 x y) = - {command: "c" , params: joinWith "," $ map show [x1, y1, x2, y2, x, y]} -printCommand (S x2 y2 x y) = - {command: "s" , params: joinWith "," $ map show [x2, y2, x, y]} -printCommand (Q x1 y1 x y) = - {command: "q" , params: joinWith "," $ map show [x1, y1, x, y]} -printCommand (T x y) = {command: "t", params: joinWith "," $ map show [x, y]} -printCommand (A rx ry rot large sweep x y) = - {command: "a", params: joinWith "," - $ map show [ rx, ry, rot ] - <> [ large_flag, sweep_flag ] - <> map show [ x, y ]} - where - large_flag = if large then "0" else "1" - sweep_flag = if sweep then "0" else "1" -printCommand Z = {command: "z", params: ""} - -data Align = Min | Mid | Max - -printAlign :: Align -> String -printAlign Min = "Min" -printAlign Mid = "Mid" -printAlign Max = "Max" - -data MeetOrSlice = Meet | Slice -printMeetOrSlice :: MeetOrSlice -> String -printMeetOrSlice Meet = "meet" -printMeetOrSlice Slice = "slice" - -attr :: forall r i. AttrName -> String -> IProp r i -attr = coe Core.attr - where - coe :: (AttrName -> String -> Prop i) -> AttrName -> String -> IProp r i - coe = unsafeCoerce - -cx :: forall r i. Number -> IProp (cx :: Number | r) i -cx = attr (AttrName "cx") <<< show - -cy :: forall r i. Number -> IProp (cy :: Number | r) i -cy = attr (AttrName "cy") <<< show - -r :: forall s i. Number -> IProp (r :: Number | s) i -r = attr (AttrName "r") <<< show - -viewBox :: forall r i. Number -> Number -> Number -> Number -> IProp (viewBox :: String | r) i -viewBox x y w h = attr (AttrName "viewBox") (joinWith " " $ map show [x, y, w, h]) - -preserveAspectRatio :: forall r i. Maybe {x :: Align, y :: Align} -> MeetOrSlice -> IProp (preserveAspectRatio :: String | r) i -preserveAspectRatio align slice = - attr (AttrName "preserveAspectRatio") (joinWith " " $ [align_str, printMeetOrSlice slice]) - where - align_str = case align of - Nothing -> "none" - Just {x, y} -> joinWith "" $ ["x", printAlign x, "Y", printAlign y] - -rx :: forall r i. Number -> IProp (rx :: Number | r) i -rx = attr (AttrName "rx") <<< show - -ry :: forall r i. Number -> IProp (ry :: Number | r) i -ry = attr (AttrName "ry") <<< show - -width :: forall r i. Number -> IProp (width :: Number | r) i -width = attr (AttrName "width") <<< show - -height :: forall r i. Number -> IProp (height :: Number | r) i -height = attr (AttrName "height") <<< show - -x :: forall r i. Number -> IProp (x :: Number | r) i -x = attr (AttrName "x") <<< show - -y :: forall r i. Number -> IProp (y :: Number | r) i -y = attr (AttrName "y") <<< show - -x1 :: forall r i. Number -> IProp (x1 :: Number | r) i -x1 = attr (AttrName "x1") <<< show - -y1 :: forall r i. Number -> IProp (y1 :: Number | r) i -y1 = attr (AttrName "y1") <<< show - -x2 :: forall r i. Number -> IProp (x2 :: Number | r) i -x2 = attr (AttrName "x2") <<< show - -y2 :: forall r i. Number -> IProp (y2 :: Number | r) i -y2 = attr (AttrName "y2") <<< show - -stroke :: forall r i. Maybe Color -> IProp (stroke :: String | r) i -stroke = attr (AttrName "stroke") <<< printColor - -fill :: forall r i. Maybe Color -> IProp (fill :: String | r) i -fill = attr (AttrName "fill") <<< printColor - -transform :: forall r i . Array Transform -> IProp (transform :: String | r) i -transform = attr (AttrName "transform") <<< joinWith " " <<< map printTransform - -d :: forall r i . Array D -> IProp (d :: String | r) i -d = attr (AttrName "d") <<< joinWith " " <<< map printD - -text_anchor :: forall r i . TextAnchor -> IProp (text_anchor :: String | r) i -text_anchor = attr (AttrName "text-anchor") <<< printTextAnchor - -font_size :: forall r i. FontSize -> IProp (font_size :: String | r) i -font_size = attr (AttrName "font-size") <<< show - -dominant_baseline :: forall r i . Baseline -> IProp (transform :: String | r) i -dominant_baseline = attr (AttrName "dominant-baseline") <<< printBaseline - --- TODO shouldn't this be 'classes' taking an (Array Classname), like the rest of Halogen? -class_ :: forall r i . String -> IProp (class :: String | r) i -class_ = attr (AttrName "class") - -id :: forall r i . String -> IProp (id :: String | r) i -id = attr (AttrName "id") - -markerWidth :: forall r i. Number -> IProp (markerWidth :: Number | r) i -markerWidth = attr (AttrName "markerWidth") <<< show - -markerHeight :: forall r i. Number -> IProp (markerHeight :: Number | r) i -markerHeight = attr (AttrName "markerHeight") <<< show - -refX :: forall r i. Number -> IProp (refX :: Number | r) i -refX = attr (AttrName "refX") <<< show - -refY :: forall r i. Number -> IProp (refY :: Number | r) i -refY = attr (AttrName "refY") <<< show - -orient :: forall r i. Orient -> IProp (orient :: String | r) i -orient = attr (AttrName "orient") <<< printOrient - -markerUnits :: forall r i. MarkerUnit -> IProp (markerUnits :: String | r) i -markerUnits = attr (AttrName "markerUnits") <<< printMarkerUnit - -strokeWidth :: forall r i. Number -> IProp (strokeWidth :: Number | r) i -strokeWidth = attr (AttrName "stroke-width") <<< show - -markerEnd :: forall r i. String -> IProp (markerEnd :: String | r) i -markerEnd = attr (AttrName "marker-end") - --------------------------------------------------------------------------------- - --- | https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/dur -data DurationF a = Duration (Maybe a) (Maybe a) (Maybe a) (Maybe a) -- ^ TODO hours minutes seconds millis - -derive instance functorDurationF :: Functor DurationF - -printDurationF :: forall a. Show a => DurationF a -> String -printDurationF (Duration h m s i) = f "h" h <> f "m" m <> f "s" s <> f "i" i - where f u = maybe "" (\v -> show v <> u) - -type Duration = DurationF Number - --- TODO derive Show instance for DurationF - -printDuration :: Duration -> String -printDuration = printDurationF - --- TODO add other constructors -seconds :: Number -> Duration -seconds s = Duration Nothing Nothing (Just s) Nothing - -data FillState = Freeze | Remove - -printFillState :: FillState -> String -printFillState = case _ of - Freeze -> "freeze" - Remove -> "remove" - -dur :: forall r i. Duration -> IProp (dur :: String | r) i -dur = attr (AttrName "dur") <<< printDuration - --- TODO ADT or free string? -attributeName :: forall r i. String -> IProp (attributeName :: String | r) i -attributeName = attr (AttrName "attributeName") - --- https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/from -from :: forall r i. String -> IProp (from :: String | r) i -from = attr (AttrName "from") - --- https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/to -to :: forall r i. String -> IProp (to :: String | r) i -to = attr (AttrName "to") - --- https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/begin -begin :: forall r i. String -> IProp (begin :: String | r) i -begin = attr (AttrName "begin") - -repeatCount :: forall r i. Int -> IProp (repeatCount :: Int | r) i -repeatCount = attr (AttrName "repeatCount") <<< show - --- TODO this is just 'fill', but that functino is already specialised to Color in this module -fillAnim :: forall r i. FillState -> IProp (fill :: String | r) i -fillAnim = attr (AttrName "fill") <<< printFillState - --- TODO xlink:href seems to have some issues, among others around its namespace -xlinkHref :: forall r i. String -> IProp (xlinkHref :: String | r) i --- xlinkHref = attr (AttrName "xlink:href") --- xlinkHref = attrNS (Namespace "xlink") (AttrName "href") -xlinkHref = attrNS (Namespace "xlink") (AttrName "xlink:href") - --- TODO copied from `d`; adapt where needed -path :: forall r i . Array D -> IProp (path :: String | r) i -path = attr (AttrName "path") <<< joinWith " " <<< map printD diff --git a/test/Main.purs b/test/Main.purs index ff0c82a..43bb33b 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -1,15 +1,15 @@ module Test.Main where import Prelude -import Halogen as H -import Svg.Attributes as SA -import Svg.Elements as SE +import Halogen.HTML as HH +import Halogen.Svg.Attributes as SA +import Halogen.Svg.Elements as SE import Effect (Effect) import Effect.Console (log) -- smoke test -render :: forall t1 t2 t3 . t1 -> H.HTML t2 t3 +render :: forall t1 t2 t3 . t1 -> HH.HTML t2 t3 render state = SE.svg [ SA.viewBox 0.0 0.0 100.0 100.0 ] [ SE.circle [ SA.r 10.0 ] ]