diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for jmonkey + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2018 peus + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,35 @@ +# jmonkey + +[![Build status](https://travis-ci.org/opyapeus/jmonkey.svg?branch=master)](https://travis-ci.org/opyapeus/jmonkey) + +Jmonkey is very restricted but handy EDSL for javascript. + +The DOM effect that jmonkey can do is just to change classes and ids of HTML elements. + +So it only supports some on-actions and condition checks. + +Instead of limited functions, it can be called internally unlike other rich javascript EDSLs that require external calls. + +If you manage some states for complex frontend actions, jmonkey won't be usable. + +Jmonkey may be useful when you implement some actions that css can not handle. + +## Example + +A practical implementation is shown in [example](example). + +Clone this repository first, and execute following. + +```sh +stack run +``` + +Then access to localhost:3000. + +## Documentation + +- [API documentation on Hackage](#TODO) + +## Contribution + +If you find a bug or want new features or else, making issues and PRs are very welcome. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/example/Data/Gender.hs b/example/Data/Gender.hs new file mode 100644 --- /dev/null +++ b/example/Data/Gender.hs @@ -0,0 +1,4 @@ +module Data.Gender where + +data Gender = Man | Woman | Trans + deriving (Show, Eq) diff --git a/example/Data/Person.hs b/example/Data/Person.hs new file mode 100644 --- /dev/null +++ b/example/Data/Person.hs @@ -0,0 +1,39 @@ +module Data.Person where + +import Data.Gender + +data Person = Person + { name :: String + , age :: Int + , gender :: Gender + } deriving (Show, Eq) + +people :: [Person] +people = + [ Person "A" 20 Man + , Person "B" 21 Woman + , Person "C" 22 Trans + , Person "D" 23 Man + , Person "E" 24 Woman + , Person "F" 25 Trans + , Person "G" 26 Man + , Person "H" 27 Woman + , Person "I" 28 Trans + , Person "J" 29 Man + , Person "K" 30 Woman + , Person "L" 31 Trans + , Person "M" 32 Man + , Person "N" 33 Woman + , Person "O" 34 Trans + , Person "P" 35 Man + , Person "Q" 36 Woman + , Person "R" 37 Trans + , Person "S" 38 Man + , Person "T" 39 Woman + , Person "U" 40 Trans + , Person "V" 41 Man + , Person "W" 42 Woman + , Person "X" 43 Trans + , Person "Y" 44 Man + , Person "Z" 45 Woman + ] diff --git a/example/Data/Selector.hs b/example/Data/Selector.hs new file mode 100644 --- /dev/null +++ b/example/Data/Selector.hs @@ -0,0 +1,26 @@ +module Data.Selector where + +import Data.Gender + +data Selector = Id IdName | Class ClassName + deriving (Show, Eq) + +data IdName + = Button Gender + | ButtonAll + deriving (Show, Eq) + +data ClassName + = First + | Second + | Third + | Hide + | Tab + | Current + | AboveHeader + | Head + | HeadFixed + | Content + | Box + | Group Gender + deriving (Show, Eq) diff --git a/example/Data/ToAttribute.hs b/example/Data/ToAttribute.hs new file mode 100644 --- /dev/null +++ b/example/Data/ToAttribute.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} + +module Data.ToAttribute where + +import Data.Text ( pack ) +import Text.Casing ( kebab ) +import Lucid ( Attribute + , id_ + , class_ + ) +import qualified Clay as C + ( Selector ) +import Clay.Selector ( selectorFromText ) +import qualified JMonkey as J + ( Selector(..) ) +import Data.Selector + +class ToAttribute a where + toAttr :: Selector -> a + +instance ToAttribute Attribute where + toAttr (Id v) = id_ . pack . kebab . show $ v + toAttr (Class v) = class_ . pack . kebab. show $ v + +instance ToAttribute C.Selector where + toAttr (Id v) = selectorFromText . mappend "#" . pack . kebab . show $ v + toAttr (Class v) = selectorFromText . mappend "." . pack . kebab . show $ v + +instance ToAttribute J.Selector where + toAttr (Id v) = J.Id . kebab . show $ v + toAttr (Class v) = J.Class . kebab . show $ v + +-- TODO: div [class_ "a", class_ "b"] "X" ->
X
+-- NOTE: https://github.com/chrisdone/lucid/issues/84 +toClasses :: [ClassName] -> Attribute +toClasses = class_ . pack . unwords . map (kebab . show) diff --git a/example/Frontend/Css.hs b/example/Frontend/Css.hs new file mode 100644 --- /dev/null +++ b/example/Frontend/Css.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Frontend.Css where + +import Clay +import Data.Gender +import Data.Selector +import Data.ToAttribute + +zero :: Size LengthUnit +zero = 0 + +p100 :: Size Percentage +p100 = 100 + +clayCss :: Css +clayCss = do + body ? do + sym margin zero + sym padding zero + backgroundColor "#ffffff" + + toAttr (Class AboveHeader) ? do + height (px 200) + backgroundColor "#add8e6" + + toAttr (Class Head) ? do + backgroundColor "#f8f8ff" + position absolute + width p100 + + toAttr (Class Tab) ? do + display inlineBlock + width (px 150) + + toAttr (Class Current) ? do + backgroundColor "#d3d3d3" + fontWeight bold + + toAttr (Class HeadFixed) ? do + position fixed + top zero + + toAttr (Class Content) ? do + display flex + flexWrap (FlexWrap "wrap") -- FIXME: flexWrap wrap + justifyContent spaceBetween + listStyleType none + sym margin zero + sym padding zero + + toAttr (Class Box) ? do + width (px 200) + sym padding (px 20) + marginBottom (px 30) + + toAttr (Class First) ? backgroundColor "#ff0000" + toAttr (Class Second) ? backgroundColor "#00ff00" + toAttr (Class Third) ? backgroundColor "#0000ff" + + toAttr (Class $ Group Man) ? backgroundColor "#00ced1" + toAttr (Class $ Group Woman) ? backgroundColor "#f08080" + toAttr (Class $ Group Trans) ? backgroundColor "#eee8aa" + + toAttr (Class Hide) ? display none diff --git a/example/Frontend/Html.hs b/example/Frontend/Html.hs new file mode 100644 --- /dev/null +++ b/example/Frontend/Html.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Frontend.Html where + +import Lucid +import JMonkey ( interpretString ) +import Clay ( render ) +import Frontend.Css +import Frontend.Js +import Data.Gender +import Data.Person +import Data.Selector +import Data.ToAttribute + +lucidHtml :: [Person] -> Html () +lucidHtml ps = do + doctype_ + html_ $ do + head_ $ do + meta_ [charset_ "UTF-8"] + meta_ + [ name_ "viewport" + , content_ "width=device-width, initial-scale=1.0" + ] + style_ [type_ "text/css"] $ render clayCss + title_ "Example" + body_ $ do + div_ [toAttr (Class AboveHeader)] $ do + div_ [toAttr (Class First)] "yay!" + h1_ "Various People" + header_ [toAttr (Class Head)] $ do + div_ [toAttr (Id ButtonAll), toClasses [Tab, Current]] "All" + div_ [toAttr (Id $ Button Man), toAttr (Class Tab)] + $ toHtml (show Man) + div_ [toAttr (Id $ Button Woman), toAttr (Class Tab)] + $ toHtml (show Woman) + div_ [toAttr (Id $ Button Trans), toAttr (Class Tab)] + $ toHtml (show Trans) + div_ . ul_ [toAttr (Class Content)] $ mapM_ box ps + script_ [type_ "text/javascript"] $ interpretString jMonkeyJs + +box :: Person -> Html () +box p = li_ [toClasses [Box, Group (gender p)]] . dl_ $ do + dt_ "Name" + dd_ $ toHtml (name p) + dt_ "Age" + dd_ $ toHtml (show $ age p) + dt_ "Gender" + dd_ $ toHtml (show $ gender p) diff --git a/example/Frontend/Js.hs b/example/Frontend/Js.hs new file mode 100644 --- /dev/null +++ b/example/Frontend/Js.hs @@ -0,0 +1,68 @@ +module Frontend.Js where + +import JMonkey hiding ( Id + , Class + ) +import Data.Gender +import Data.Selector hiding ( Selector ) +import Data.ToAttribute + +jMonkeyJs :: JMonkey +jMonkeyJs = do + -- Header to be fixed from the middle + header <- select $ toAttr (Class Head) + onScroll win $ ifel (YOffset Grater 200) + (add header $ toAttr (Class HeadFixed)) + (remove header $ toAttr (Class HeadFixed)) + + -- Loops automatically change classes + d <- select $ toAttr (Class First) + onTime Endless 3000 + $ ifel + (Possess d $ toAttr (Class First)) + (do + remove d $ toAttr (Class First) + add d $ toAttr (Class Second) + ) + $ ifel + (Possess d $ toAttr (Class Second)) + (do + remove d $ toAttr (Class Second) + add d $ toAttr (Class Third) + ) + $ ifThen + (Possess d $ toAttr (Class Third)) + (do + remove d $ toAttr (Class Third) + add d $ toAttr (Class First) + ) + + -- People filter + groupMan <- select $ toAttr (Class $ Group Man) + groupWoman <- select $ toAttr (Class $ Group Woman) + groupTrans <- select $ toAttr (Class $ Group Trans) + btnMan <- select $ toAttr (Id $ Button Man) + btnWoman <- select $ toAttr (Id $ Button Woman) + btnTrans <- select $ toAttr (Id $ Button Trans) + btnAll <- select $ toAttr (Id ButtonAll) + onClick btnMan $ do + removeAdds groupMan [groupWoman, groupTrans] $ toAttr (Class Hide) + addRemoves btnMan [btnWoman, btnTrans, btnAll] $ toAttr (Class Current) + onClick btnWoman $ do + removeAdds groupWoman [groupMan, groupTrans] $ toAttr (Class Hide) + addRemoves btnWoman [btnMan, btnTrans, btnAll] $ toAttr (Class Current) + onClick btnTrans $ do + removeAdds groupTrans [groupMan, groupWoman] $ toAttr (Class Hide) + addRemoves btnTrans [btnMan, btnWoman, btnAll] $ toAttr (Class Current) + onClick btnAll $ do + removes [groupMan, groupWoman, groupTrans] $ toAttr (Class Hide) + addRemoves btnAll [btnMan, btnWoman, btnTrans] $ toAttr (Class Current) + where + removeAdds :: Target -> [Target] -> Selector -> JMonkey + removeAdds t ts sel = do + remove t sel + adds ts sel + addRemoves :: Target -> [Target] -> Selector -> JMonkey + addRemoves t ts sel = do + add t sel + removes ts sel diff --git a/example/Main.hs b/example/Main.hs new file mode 100644 --- /dev/null +++ b/example/Main.hs @@ -0,0 +1,18 @@ +module Main where + +import Network.Wai.Handler.Warp ( run ) +import Network.Wai ( Application + , responseLBS + ) +import Network.HTTP.Types ( status200 ) +import Lucid ( renderBS ) +import Frontend.Html +import Data.Person + +main :: IO () +main = run 3000 app + +app :: Application +app _ respond = do + let bs = renderBS $ lucidHtml people + respond $ responseLBS status200 [] bs diff --git a/jmonkey.cabal b/jmonkey.cabal new file mode 100644 --- /dev/null +++ b/jmonkey.cabal @@ -0,0 +1,87 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 6fed5e823fdf4f4e59fa32ae04797bc55a4ed6fec67f5c2110f60fc2a17ea948 + +name: jmonkey +version: 0.1.0.0 +description: Please see the README on GitHub at +homepage: https://github.com/opyapeus/jmonkey#readme +bug-reports: https://github.com/opyapeus/jmonkey/issues +author: peus +maintainer: opyapeus@gmail.com +copyright: 2018 peus +license: MIT +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/opyapeus/jmonkey + +library + exposed-modules: + JMonkey + JMonkey.Action + JMonkey.Data + JMonkey.Interpreter + other-modules: + Paths_jmonkey + hs-source-dirs: + src + build-depends: + base >=4.7 && <5 + , casing + , free + , jmacro + default-language: Haskell2010 + +executable jmonkey-example-exe + main-is: Main.hs + other-modules: + Data.Gender + Data.Person + Data.Selector + Data.ToAttribute + Frontend.Css + Frontend.Html + Frontend.Js + Paths_jmonkey + hs-source-dirs: + example + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , casing + , clay + , free + , http-types + , jmacro + , jmonkey + , lucid + , text + , wai + , warp + default-language: Haskell2010 + +test-suite jmonkey-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_jmonkey + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , casing + , free + , jmacro + , jmonkey + default-language: Haskell2010 diff --git a/src/JMonkey.hs b/src/JMonkey.hs new file mode 100644 --- /dev/null +++ b/src/JMonkey.hs @@ -0,0 +1,33 @@ +-- | Jmonkey is very restricted but handy EDSL for javascript. +-- +-- It's backend uses for designing DSL and for interpreter. +-- +-- Here is some examples. +-- +-- Click btn element then add "clicked" class to target elements. +-- +-- @ +-- btn <- select (Id "btn") +-- target <- select (Class "target") +-- onClick btn $ add target (Class "clicked") +-- @ +-- +-- If target element(s) have "hide" class then remove, otherwise add "hide" class. +-- +-- @ +-- ifel (Having target (Class "hide")) +-- (remove target (Class "hide")) +-- (add target (Class "hide")) +-- @ +-- +-- Once you define some actions like aboves, you can get javascript string easily by `interpretString`. +module JMonkey + ( module JMonkey.Action + , module JMonkey.Data + , module JMonkey.Interpreter + ) +where + +import JMonkey.Action +import JMonkey.Data +import JMonkey.Interpreter diff --git a/src/JMonkey/Action.hs b/src/JMonkey/Action.hs new file mode 100644 --- /dev/null +++ b/src/JMonkey/Action.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE DeriveFunctor #-} + +-- | JMonkey actions. +module JMonkey.Action + ( + -- * Types + JMonkey + , JMonkeyM + , Action(..) + , Cond(..) + -- * Show + , putLog + , alert + -- * Selection + , select + -- * Selector Modification + , add + , adds + , remove + , removes + -- * On Event + , on + , onClick + , onScroll + , onChange + -- * Time Triggered Event + , onTime + -- * Conditional Action + , ifel + , ifThen + , elThen + ) +where + +import Control.Monad.Free +import JMonkey.Data + +-- | Empty JMonkey monad. +type JMonkey = JMonkeyM () + +-- | JMonkey monad designed with free monad. +type JMonkeyM = Free Action + +-- | JMonkey action AST. +data Action n + = Log String n + | Alert String n + | Select Selector (Target -> n) + | Add Target Selector n + | Remove Target Selector n + | On String Target JMonkey n + | OnTime Repeat Int JMonkey n + | If Cond JMonkey JMonkey n + deriving Functor + +-- | JMonkey conditions. +-- These mean boolean value. +data Cond + = Possess Target Selector -- ^ if all the target have the selector + | YOffset CompOp Double -- ^ if window.pageYOffset satisfies with given comparision operator and threshold value + +-- | Show console log. +putLog :: String -> JMonkey +putLog s = liftF $ Log s () + +-- | Show alert. +alert :: String -> JMonkey +alert s = liftF $ Alert s () + +-- | Select target by given selector. +select :: Selector -> JMonkeyM Target +select sel = liftF $ Select sel id + +-- | Add class or id to the target. +-- +-- For multiple selectors +-- +-- @ +-- f :: Target -> [Selector] -> JMonkey +-- f t = mapM_ (`add` t) +-- @ +add :: Target -> Selector -> JMonkey +add t sel = liftF $ Add t sel () + +-- | Add class or id to the targets. +-- +-- For multiple selectors +-- +-- @ +-- f :: [Target] -> [Selector] -> JMonkey +-- f ts = mapM_ (`adds` ts) +-- @ +adds :: [Target] -> Selector -> JMonkey +adds ts sel = mapM_ (\t -> add t sel) ts + +-- | Remove class or id from the target. +remove :: Target -> Selector -> JMonkey +remove t sel = liftF $ Remove t sel () + +-- | Remove class or id from the targets. +removes :: [Target] -> Selector -> JMonkey +removes ts sel = mapM_ (\t -> remove t sel) ts + +-- | Make event. +on + :: String -- ^ an event name like "click", "scroll", ...etc + -> Target -- ^ a target related to the event + -> JMonkey -- ^ an action triggered by the event + -> JMonkey +on s t act = liftF $ On s t act () + +-- | Same as `on` "click". +onClick :: Target -> JMonkey -> JMonkey +onClick t act = liftF $ On "click" t act () + +-- | Same as `on` "scroll". +onScroll :: Target -> JMonkey -> JMonkey +onScroll t act = liftF $ On "scroll" t act () + +-- | Same as `on` "change". +onChange :: Target -> JMonkey -> JMonkey +onChange t act = liftF $ On "change" t act () + +-- | Make time triggered event. +onTime + :: Repeat -- ^ repetition + -> Int -- ^ delay time (milliseconds) + -> JMonkey -- ^ an action on the time + -> JMonkey +onTime r t act = liftF $ OnTime r t act () + +-- | Make conditional action. +ifel + :: Cond -- ^ a condition + -> JMonkey -- ^ an action do when the condition is satisfied + -> JMonkey -- ^ an action do when the condition is not satisfied + -> JMonkey +ifel c tA fA = liftF $ If c tA fA () + +-- | Only true conditional action of `ifel` +ifThen :: Cond -> JMonkey -> JMonkey +ifThen c tA = ifel c tA noop + +-- | Only false conditional action of `ifel` +elThen :: Cond -> JMonkey -> JMonkey +elThen c = ifel c noop + +noop :: JMonkey +noop = Pure () diff --git a/src/JMonkey/Data.hs b/src/JMonkey/Data.hs new file mode 100644 --- /dev/null +++ b/src/JMonkey/Data.hs @@ -0,0 +1,37 @@ +-- | JMonkey data types. +module JMonkey.Data + ( + -- * Types + Selector(..) + , Target(..) + , CompOp(..) + , Repeat(..) + -- * Target + , doc + , win + ) +where + +-- | Represents id and class. +data Selector = Id String | Class String + deriving (Show, Eq) + +-- | Represents javascript element(s). +data Target = Elem String | Elems String + deriving (Show, Eq) + +-- | Comparision operator. +data CompOp = Equal | Grater | Less + deriving (Show, Eq) + +-- | Repetition. +data Repeat = Once | Endless + deriving (Show, Eq) + +-- | Document element. +doc :: Target +doc = Elem "document" + +-- | Window element. +win :: Target +win = Elem "window" diff --git a/src/JMonkey/Interpreter.hs b/src/JMonkey/Interpreter.hs new file mode 100644 --- /dev/null +++ b/src/JMonkey/Interpreter.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE QuasiQuotes #-} + +-- | JMonkey interpreter using jmacro backend. +module JMonkey.Interpreter + ( + -- * Interpreter + interpretString + , interpretJStat + ) where + +import Control.Monad.Free +import Language.Javascript.JMacro +import Text.Casing +import JMonkey.Action +import JMonkey.Data + +-- | Interpret to javascript string. +interpretString :: JMonkey -> String +interpretString = show . renderJs . interpretJStat + +toStr :: Selector -> String +toStr (Id s) = '#' : s +toStr (Class s) = '.' : s + +onEvent :: String -> String +onEvent = mappend "on" + +jvar :: String -> JStat +jvar s = DeclStat (StrI s) Nothing + +jref :: String -> JExpr +jref = ValExpr . JVar . StrI + +-- TODO: check when compiling? +forbidden :: JStat +forbidden = [jmacro| throw "forbidden action: id corresponds to multiple elements." |] + +-- | Interpret to jmacro statement. +interpretJStat :: JMonkey -> JStat +interpretJStat (Free (Log s n)) = [jmacro| console.log `s` |] <> interpretJStat n +interpretJStat (Free (Alert s n)) = [jmacro| alert `s` |] <> interpretJStat n +interpretJStat (Free (Select sel@(Id s) n)) = [jmacro| + `jvar tmp`; + `jref tmp` = document.querySelector(`toStr sel`); +|] <> interpretJStat (n $ Elem tmp) + where tmp = "i_" ++ snake s -- TODO: allocate by generator? +interpretJStat (Free (Select sel@(Class s) n)) = [jmacro| + `jvar tmps`; + `jref tmps` = document.querySelectorAll(`toStr sel`); +|] <> interpretJStat (n $ Elems tmps) + where tmps = "c_" ++ snake s -- TODO: allocate by generator? +interpretJStat (Free (Add (Elem t) (Class s) n)) = [jmacro| `jref t`.classList.add(`s`); |] <> interpretJStat n +interpretJStat (Free (Add (Elem t) sel@(Id _) n)) = [jmacro| `jref t`.id = `toStr sel`; |] <> interpretJStat n +interpretJStat (Free (Add (Elems t) (Class s) n)) = [jmacro| + `jref t`.forEach( function e { + e.classList.add(`s`); + }) +|] <> interpretJStat n +interpretJStat (Free (Add (Elems _) (Id _) n)) = forbidden <> interpretJStat n +interpretJStat (Free (Remove (Elem t) (Class s) n)) = [jmacro| `jref t`.classList.remove(`s`); |] <> interpretJStat n +interpretJStat (Free (Remove (Elem t) sel@(Id _) n)) = [jmacro| if (`jref t`.id == `toStr sel`) { `jref t`.id = ""; } |] <> interpretJStat n +interpretJStat (Free (Remove (Elems t) (Class s) n)) = [jmacro| + `jref t`.forEach( function e { + e.classList.remove(`s`); + }) +|] <> interpretJStat n +interpretJStat (Free (Remove (Elems _) (Id _) n)) = forbidden <> interpretJStat n +interpretJStat (Free (On s (Elem t) a n)) = [jmacro| + `jref t`[`event`] = function { + `interpretJStat a`; + } +|] <> interpretJStat n + where event = onEvent s +interpretJStat (Free (On s (Elems t) a n)) = [jmacro| + `jref t`.forEach( function e { + e[`event`] = function { `interpretJStat a`; } + }); +|] <> interpretJStat n + where event = onEvent s +interpretJStat (Free (OnTime Once i a n)) = [jmacro| + var f = function { `interpretJStat a`; }; + setTimeout(f, `i`); +|] <> interpretJStat n +interpretJStat (Free (OnTime Endless i a n)) = [jmacro| + var f = function { `interpretJStat a`; }; + setInterval(f, `i`); +|] <> interpretJStat n +interpretJStat (Free (If (Possess target sel) tA fA n)) = case (target, sel) of + (Elem t, Class s) -> ifElse [jmacroE| `jref t`.classList.contains(`s`) |] tA fA <> interpretJStat n + (Elems t, Class s) -> ifElse [jmacroE| Array.from(`jref t`).every(function e { return e.classList.contains(`s`); }) |] tA fA <> interpretJStat n + (Elem t, Id s) -> ifElse [jmacroE| `jref t`.id == `s` |] tA fA <> interpretJStat n + (Elems _, Id _) -> forbidden <> interpretJStat n +interpretJStat (Free (If (YOffset op v) tA fA n)) = + let cond = case op of + Equal -> [jmacroE| window.pageYOffset == `v` |] + Grater -> [jmacroE| window.pageYOffset > `v` |] + Less -> [jmacroE| window.pageYOffset < `v` |] + in ifElse cond tA fA <> interpretJStat n +interpretJStat (Pure _) = nullStat + +ifElse :: JExpr -> JMonkey -> JMonkey -> JStat +ifElse cond tA fA = [jmacro| + if (`cond`) { + `interpretJStat tA`; + } else { + `interpretJStat fA`; + } +|] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"