purview 0.1.0.0 → 0.2.0.0
raw patch · 35 files changed
+2524/−1545 lines, 35 filesdep +blaze-builderdep +http-typesdep +template-haskelldep −scottydep −wai-extradep ~aesondep ~bytestringdep ~hspec
Dependencies added: blaze-builder, http-types, template-haskell
Dependencies removed: scotty, wai-extra
Dependency ranges changed: aeson, bytestring, hspec, text, wai, warp, websockets
Files
- README.md +31/−118
- purview.cabal +56/−40
- src/CleanTree.hs +52/−0
- src/CollectInitials.hs +66/−0
- src/Component.hs +96/−242
- src/ComponentHelpers.hs +409/−0
- src/ComponentSpec.hs +0/−17
- src/Configuration.hs +26/−0
- src/Diffing.hs +16/−21
- src/DiffingSpec.hs +0/−103
- src/EventHandling.hs +98/−58
- src/EventHandlingSpec.hs +0/−289
- src/EventLoop.hs +85/−38
- src/Events.hs +66/−26
- src/PrepareTree.hs +42/−39
- src/PrepareTreeSpec.hs +0/−136
- src/Purview.hs +151/−149
- src/Purview/Server.hs +142/−0
- src/PurviewSpec.hs +0/−44
- src/Rendering.hs +52/−16
- src/RenderingSpec.hs +0/−98
- src/Spec.hs +0/−1
- src/Style.hs +156/−0
- src/TreeGenerator.hs +0/−40
- src/Wrapper.hs +168/−70
- test/ComponentSpec.hs +17/−0
- test/DiffingSpec.hs +87/−0
- test/EventHandlingSpec.hs +169/−0
- test/EventsSpec.hs +32/−0
- test/PrepareTreeSpec.hs +173/−0
- test/PurviewSpec.hs +44/−0
- test/RenderingSpec.hs +136/−0
- test/Spec.hs +1/−0
- test/StyleSpec.hs +115/−0
- test/TreeGenerator.hs +38/−0
README.md view
@@ -1,155 +1,69 @@ # Purview -A framework to build interactive UIs with Haskell. It's inspired by Phoenix LiveView, React, and Redux + Sagas.+A simple, fun way to build websites with Haskell. It's inspired by Phoenix LiveView, React, and Redux + Sagas. The main points: * It's server side rendered and uses websockets to communicate HTML updates and to receive events. * State can be broken up into small components.-* The approach is to provide useful atoms, with the user building up a kind of AST. * Attributes flow down to concrete HTML, events bubble up to state handlers.+* Handlers can send further events to a parent handler or themselves It's still in early development so expect things to break or be missing! ## What it looks like -Here's what a component looks like (see `experiments/Counter.hs`):- ```haskell- module Main where import Prelude hiding (div)-import Data.Aeson-import Data.Aeson.TH -import Purview+import Purview +import Purview.Server -data Direction = Up | Down -$(deriveJSON defaultOptions ''Direction)--upButton = onClick Up $ div [ text "up" ]-downButton = onClick Down $ div [ text "down" ]--handler = messageHandler (0 :: Int) reducer- where- reducer Up state = (const $ state + 1, [])- reducer Down state = (const $ state - 1, [])+data CountEvent = Increment | Decrement+ deriving (Show, Eq) -counter state = div- [ upButton- , text $ "count: " <> show state- , downButton+view :: Int -> Purview CountEvent m+view count = div+ [ h1 [ text (show count) ]+ , div [ onClick Increment $ button [ text "increment" ]+ , onClick Decrement $ button [ text "decrement" ]+ ] ] -view = handler counter--main = Purview.run defaultConfiguration { component=view }-```--## Overview--### Adding attributes to HTML elements--Attributes flow down to concrete HTML.--For example, if you wanted to add a `style="color: blue;"` to a `div`:--``` haskell-blue = style "color: blue;"--blueDiv = blue (div [])-```--Calling `render blueDiv` will produce `<div style="color: blue;"></div>"`--If you wanted to have a blue div that's 50% of the width,--``` haskell-blue = style "color: blue;"-halfWidth = style "width: 50%;"--view = blue (halfWidth (div [])-```--Now `render view` will produce `<div style="color: blue; width: 50%;></div>`--As purview is non-prescriptive in what attributes you can give a `div`, or any other HTML element, you can create your own.--If you need `name` attribute put on `div`s or other HTML, you can do:--``` haskell-nameAttr = Attribute . Generic "name"--namedDiv = nameAttr "wumbo" (div [])-```--And `render namedDiv` will produce `<div name="wumbo"></div>`. Eventually there will be more attributes-by-default like `style`, but for now expect to build up what you need!--### Creating new HTML elements--Just like you can add new attributes, you can also add new html elements. For example, if you need a button--``` haskell-button = Html "button"--view = button [ text "click" ]-```--Now `render view` will produce `<button>click</button>`. Like all the built in ones, attributes will flow down and be added to the button.--### Events--At the core of Purview are three event handlers, in order of increasing power:-1. `simpleHandler`: Used for just returning a new state. No messages or effects.-2. `messageHandler`: Used when you need to send messages to the component itself or to its parent.-3. `effectHandler`: Used when you need the above and access to IO / your monad stack / algebraic effects.--The first two are just some sugar around `effectHandler`.--Handlers take an initial state and a reducer. The reducer receives actions from anywhere below them in the tree, and returns the new state with a list of actions to send either to itself or up the tree to the parent. The handler passes down the state to its child. This is the core idea to make it all interactive.--For example, if we wanted to build something that fetched the server time on each click:--``` haskell-reducer action state = case action of- "getTime" -> do- time <- getCurrentTime- pure (const $ Just time, [])+-- passes state down to the child and maintains type safety of actions+countHandler :: (Int -> Purview CountEvent m) -> Purview () m+-- arguments are initial actions, initial state, and then the reducer+countHandler = handler' [] (0 :: Int) reducer+ where+ reducer Increment state = (state + 1, []) -- new events can be added in the []+ reducer Decrement state = (state - 1, []) -handler = effectHandler Nothing reducer+-- url is passed in to the top level component by `serve`+component url = countHandler view -view time = div - [ onClick "getTime" $ button [ text "check time" ]- , p [ text (show time) ]- ]- -component = handler view+main = serve defaultConfiguration component ``` -Some things to note:-* The state is passed down to children.-* Events bubble up to the nearest handler where they are captured.-* `onClick` can wrap anything -- like other attributes it flows down to concrete HTML.-* The reducer is run in its own thread when an event is received, so you don't have to worry about slow operations locking the page.+More detailed docs on the use and particulars of Purview are mainly on [Hackage](https://hackage.haskell.org/package/purview). ### Overview of how it works -Using the above example of getting the time, here's how events flow when the user clicks "check time"+Using an imagined example of getting the time, here's how events flow when the user clicks "check time" -1. The event is sent from the browser in a form like `+1. The event is sent from the browser in a form like - ```{ event: click, message: "checkTime", location: [0] }```+ ```{ event: click, value: undefined, location: [0], childLocation: [0,0] }``` 2. The event is put onto the channel for the event loop to process-3. By going down the tree it applies the event to the matched handler-- a. Any HTML changes are sent to the browser, completing the loop+3. It goes down the tree to find the event in Haskell by childLocation+4. It takes that event and applies it to the handler found by location 5. The handler does its work in a green thread, creating a new event that looks like ```{ event: stateChange, fn: state -> state, location: [0] }```-7. The state change event is put onto the channel for the event loop to process-8. By going down the tree it applies the state change fn to the latest state in the tree, returning a new tree-9. Any HTML changes are sent to the browser, completing the loop+6. The state change event is put onto the channel for the event loop to process+7. By going down the tree it applies the state change fn to the latest state in the tree, returning a new tree+8. Any HTML changes are sent to the browser, completing the loop ### Contributing @@ -163,7 +77,6 @@ 1. Install [stack](https://docs.haskellstack.org/en/stable/README/) 2. `stack build`-3. `stack exec purview-exe` for just running the example above ### Running Tests
purview.cabal view
@@ -5,9 +5,9 @@ -- see: https://github.com/sol/hpack name: purview-version: 0.1.0.0-synopsis: Build server rendered, interactive websites-description: A framework for building server rendered, interactive websites.+version: 0.2.0.0+synopsis: A simple, fun way to build websites+description: A simple, fun way to build websites with Haskell. . The main points: .@@ -15,19 +15,17 @@ . * State can be broken up into small components. .- * The approach is to provide useful atoms, with the user building up a kind of AST.+ * Attributes flow down to concrete HTML, events bubble up to handlers. .- * Attributes flow down to concrete HTML, events bubble up to state handlers.+ * Handlers can send further events to a parent handler or themselves . It's inspired by Phoenix LiveView, React, Redux, and Redux-Sagas.- .- For the full readme, please see https://github.com/purview-framework/purview/blob/main/README.md category: Library, Web homepage: https://github.com/purview-framework/purview#readme bug-reports: https://github.com/purview-framework/purview/issues author: Ian Davidson maintainer: bontaq@gmail.com-copyright: 2022 Ian Davidson+copyright: 2023 Ian Davidson license: BSD3 license-file: LICENSE build-type: Simple@@ -42,77 +40,94 @@ library exposed-modules: Purview+ Purview.Server other-modules:+ CleanTree+ CollectInitials Component+ ComponentHelpers+ Configuration Diffing EventHandling EventLoop Events PrepareTree Rendering+ Style Wrapper Paths_purview hs-source-dirs: src ghc-options: -Wincomplete-patterns build-depends:- aeson >=2.0.3 && <2.1+ aeson >=1.5.6 && <2.3 , base >=4.7 && <5- , bytestring >=0.10.12.1 && <0.12+ , blaze-builder >=0.4.2 && <0.5+ , bytestring >=0.10.12.0 && <0.12+ , http-types >=0.12.3 && <0.13 , raw-strings-qq ==1.1.*- , scotty ==0.12.* , stm >=2.5.0 && <2.6- , text >=1.2.5 && <1.3- , wai >=3.2.3 && <3.3- , wai-extra >=3.1.8 && <3.2+ , template-haskell >=2.15.0 && <2.21+ , text >=1.2.4.1 && <2.1+ , wai >=3.2.0 && <3.3 , wai-websockets >=3.0.1 && <3.1- , warp >=3.3.20 && <3.4- , websockets >=0.12.7 && <0.13+ , warp >=3.3.0 && <3.4+ , websockets ==0.12.* default-language: Haskell2010 test-suite purview-test type: exitcode-stdio-1.0 main-is: Spec.hs other-modules:- Component ComponentSpec- Diffing DiffingSpec- EventHandling EventHandlingSpec+ EventsSpec+ PrepareTreeSpec+ PurviewSpec+ RenderingSpec+ StyleSpec+ TreeGenerator+ CleanTree+ CollectInitials+ Component+ ComponentHelpers+ Configuration+ Diffing+ EventHandling EventLoop Events PrepareTree- PrepareTreeSpec Purview- PurviewSpec+ Purview.Server Rendering- RenderingSpec- TreeGenerator+ Style Wrapper Paths_purview hs-source-dirs:+ test src ghc-options: -threaded -rtsopts -with-rtsopts=-N -main-is Spec build-tool-depends: hspec-discover:hspec-discover ==2.* build-depends: QuickCheck >=2.14.2 && <2.15- , aeson >=2.0.3 && <2.1+ , aeson >=1.5.6 && <2.3 , base >=4.7 && <5- , bytestring >=0.10.12.1 && <0.12- , hspec >=2.8.5 && <2.10+ , blaze-builder >=0.4.2 && <0.5+ , bytestring >=0.10.12.0 && <0.12+ , hspec >=2.7.10 && <2.10+ , http-types >=0.12.3 && <0.13 , purview , raw-strings-qq ==1.1.*- , scotty ==0.12.* , stm >=2.5.0 && <2.6- , text >=1.2.5 && <1.3+ , template-haskell >=2.15.0 && <2.21+ , text >=1.2.4.1 && <2.1 , time >=1.9.3 && <1.12- , wai >=3.2.3 && <3.3- , wai-extra >=3.1.8 && <3.2+ , wai >=3.2.0 && <3.3 , wai-websockets >=3.0.1 && <3.1- , warp >=3.3.20 && <3.4- , websockets >=0.12.7 && <0.13+ , warp >=3.3.0 && <3.4+ , websockets ==0.12.* default-language: Haskell2010 benchmark purview-perf-test@@ -124,19 +139,20 @@ performance ghc-options: -main-is Criterion build-depends:- aeson >=2.0.3 && <2.1+ aeson >=1.5.6 && <2.3 , base >=4.7 && <5- , bytestring >=0.10.12.1 && <0.12+ , blaze-builder >=0.4.2 && <0.5+ , bytestring >=0.10.12.0 && <0.12 , criterion >=1.5.13 && <1.6+ , http-types >=0.12.3 && <0.13 , purview , raw-strings-qq ==1.1.*- , scotty ==0.12.* , stm >=2.5.0 && <2.6- , text >=1.2.5 && <1.3- , wai >=3.2.3 && <3.3- , wai-extra >=3.1.8 && <3.2+ , template-haskell >=2.15.0 && <2.21+ , text >=1.2.4.1 && <2.1+ , wai >=3.2.0 && <3.3 , wai-websockets >=3.0.1 && <3.1- , warp >=3.3.20 && <3.4- , websockets >=0.12.7 && <0.13+ , warp >=3.3.0 && <3.4+ , websockets ==0.12.* buildable: False default-language: Haskell2010
+ src/CleanTree.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE BangPatterns #-}+-- |++module CleanTree where++import Data.Typeable+import Data.List++import Component++++removeClassCSS :: [(Hash, String)] -> Attributes e -> Attributes e+removeClassCSS foundCSS attr = case attr of+ Style (hash, css) ->+ if hash /= "-1"+ then case find (== (hash, css)) foundCSS of+ Just _ -> Style (hash, "")+ Nothing -> Style (hash, css)+ else attr+ _ -> attr++cleanTree :: Typeable event => [(Hash, String)] -> Purview event m -> Purview event m+cleanTree css component = case component of+ Attribute attr cont ->+ let+ tree = cleanTree css cont+ cleanedAttr = removeClassCSS css attr+ in+ Attribute cleanedAttr tree++ Html kind children ->+ let+ cleanChildren = fmap (cleanTree css) children+ in+ Html kind cleanChildren++ EffectHandler ploc loc initEvents state handler cont ->+ let+ cleanCont = fmap (cleanTree css) cont+ in+ EffectHandler ploc loc [] state handler cleanCont++ Handler ploc loc initEvents state handler cont ->+ let+ cleanCont = fmap (cleanTree css) cont+ in+ Handler ploc loc [] state handler cleanCont++ r@Receiver {} -> r+ t@(Text val) -> t+ v@(Value val) -> v
+ src/CollectInitials.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE DuplicateRecordFields #-}+-- |++module CollectInitials where++import Data.Typeable++import Component+import Events++type Location = [Int]++getStyleFromAttr :: Attributes e -> Maybe (Hash, String)+getStyleFromAttr attr = case attr of+ Style (hash, css) ->+ if hash /= "-1" && css /= ""+ then Just (hash, css) -- set the css to empty since it's been caught+ else Nothing+ _ -> Nothing++directedEventToInternalEvent :: (Typeable a, Typeable b) => Location -> Location -> DirectedEvent a b -> Event+directedEventToInternalEvent parentLocation location directedEvent = case directedEvent of+ Parent event -> InternalEvent { event=event, childId=Nothing, handlerId=Just parentLocation }+ Self event -> InternalEvent { event=event, childId=Nothing, handlerId=Just location }+ Browser {} -> error "tried to turn a browser event into an internal event"++collectInitials :: Typeable event => Purview event m -> ([Event], [(Hash, String)])+collectInitials component = case component of+ Attribute attr cont ->+ let+ (events, css) = collectInitials cont+ possibleCss = getStyleFromAttr attr+ in+ case possibleCss of+ Just newCss -> (events, newCss : css)+ Nothing -> (events, css)++ Html kind children ->+ let+ eventsAndCss = fmap collectInitials children+ events = concatMap fst eventsAndCss+ css = concatMap snd eventsAndCss+ in+ (events, css)++ EffectHandler ploc loc initEvents state _handler cont ->+ let+ (events, css) = collectInitials (cont state)+ internalizedEvents = case (ploc, loc) of+ (Just ploc, Just loc) -> fmap (directedEventToInternalEvent ploc loc) initEvents+ _ -> error "EffectHandler missing locations"+ in+ (internalizedEvents <> events, css)++ Handler ploc loc initEvents state _handler cont ->+ let+ (events, css) = collectInitials (cont state)+ internalizedEvents = case (ploc, loc) of+ (Just ploc, Just loc) -> fmap (directedEventToInternalEvent ploc loc) initEvents+ _ -> error "Handler missing locations"+ in+ (internalizedEvents <> events, css)++ Receiver {} -> ([], [])+ Text val -> ([], [])+ Value val -> ([], [])
src/Component.hs view
@@ -4,37 +4,47 @@ {-# LANGUAGE GADTs #-} module Component where -import Data.Aeson import Data.Typeable- import Events +type Hash = String+ {-| Attributes are collected until an 'HTML' constructor is hit, where they are applied during rendering. -}-data Attributes action where- On :: ToJSON action => String -> action -> Attributes action- -- ^ part of creating handlers for different events, e.g. On "click"- Style :: String -> Attributes action- -- ^ inline css- Generic :: String -> String -> Attributes action- -- ^ for creating new Attributes to put on HTML, e.g. Generic "type" "radio" for type="radio".+data Attributes event where+ On :: ( Show event+ , Eq event+ , Typeable event+ )+ => String+ -> Identifier+ -> (Maybe String -> event) -- the string here is information from the browser+ -> Attributes event+ -- ^ part of creating handlers for different events, e.g. On "click"+ Style :: (Hash, String) -> Attributes event+ -- ^ hash of the css, the css+ Generic :: String -> String -> Attributes event+ -- ^ for creating new Attributes to put on HTML, e.g. Generic "type" "radio" for type="radio". -instance Eq (Attributes action) where+instance Eq (Attributes event) where (Style a) == (Style b) = a == b (Style _) == _ = False - (On kind action) == (On kind' action') = kind == kind' && encode action == encode action'- (On _ _) == _ = False+ (On kind ident _event) == (On kind' ident' _event') =+ kind == kind' && ident == ident'+ (On {}) == _ = False (Generic name value) == (Generic name' value') = name == name' && value == value' (Generic _ _) == _ = False -type Identifier = Maybe [Int]-type ParentIdentifier = Identifier+instance Show (Attributes event) where+ show (On kind ident evt) = "On " <> show kind <> " " <> show ident+ show (Style str) = "Style " <> show str+ show (Generic attrKey attrValue) = "Generic " <> show attrKey <> show attrValue {-| @@ -43,244 +53,88 @@ what's happening behind the scenes. -}-data Purview parentAction action m where- Attribute :: Attributes action -> Purview parentAction action m -> Purview parentAction action m- Text :: String -> Purview parentAction action m- Html :: String -> [Purview parentAction action m] -> Purview parentAction action m- Value :: Show a => a -> Purview parentAction action m+data Purview event m where+ Attribute :: Attributes event -> Purview event m -> Purview event m+ Text :: String -> Purview event m+ Html :: String -> [Purview event m] -> Purview event m+ Value :: Show a => a -> Purview event m - -- | All the handlers boil down to this one.+ Receiver+ :: ( Show event+ , Eq event+ , Typeable event+ )+ => { parentIdentifier :: ParentIdentifier+ , identifier :: Identifier+ , name :: String -- the name to be used to send an event+ , eventHandler :: Maybe String -> event -- what to do with an event from the fn+ , child :: state -> Purview event m+ , state :: state+ }+ -> Purview event m+ EffectHandler- :: ( FromJSON newAction- , ToJSON newAction- , ToJSON parentAction- , FromJSON state- , ToJSON state- , Typeable state+ :: ( Show state , Eq state+ , Typeable state+ , Typeable newEvent )- => ParentIdentifier- -- ^ The location of the parent effect handler (provided by prepareTree)- -> Identifier- -- ^ The location of this effect handler (provided by prepareTree)- -> state- -- ^ The initial state- -> (newAction-> state -> m (state -> state, [DirectedEvent parentAction newAction]))- -- ^ Receive an action, change the state, and send messages- -> (state -> Purview newAction any m)- -- ^ Continuation- -> Purview parentAction newAction m-- Once- :: (ToJSON action)- => ((action -> Event) -> Event)- -> Bool -- has run- -> Purview parentAction action m- -> Purview parentAction action m+ => { parentIdentifier :: ParentIdentifier+ -- ^ The location of the parent effect handler (provided by prepareTree)+ , identifier :: Identifier+ -- ^ The location of this effect handler (provided by prepareTree)+ , initialEvents :: [DirectedEvent event newEvent]+ , state :: state+ -- ^ The initial state+ , effectReducer :: newEvent+ -> state+ -> m (state -> state, [DirectedEvent event newEvent])+ -- ^ Receive an event, change the state, and send messages+ , continuation :: state -> Purview newEvent m+ }+ -> Purview event m - Hide :: Purview parentAction newAction m -> Purview parentAction any m+ Handler+ :: ( Show state+ , Eq state+ , Typeable state+ , Typeable newEvent+ )+ => { parentIdentifier :: ParentIdentifier+ , identifier :: Identifier+ , initialEvents :: [DirectedEvent event newEvent]+ , state :: state+ , reducer :: newEvent+ -> state+ -> (state -> state, [DirectedEvent event newEvent])+ , continuation :: state -> Purview newEvent m+ }+ -> Purview event m -instance Show (Purview parentAction action m) where- show (EffectHandler parentLocation location state _action cont) =+instance Show (Purview event m) where+ show (EffectHandler parentLocation location initialEvents state _event cont) = "EffectHandler "- <> show parentLocation <> " "- <> show location <> " "- <> show (encode state) <> " "- <> show (cont state)- show (Once _ hasRun cont) = "Once " <> show hasRun <> " " <> show cont- show (Attribute _attrs cont) = "Attr " <> show cont+ <> show parentLocation <> " "+ <> show location <> " "+ <> show state <> " "+ <> show (cont state)+ show (Handler parentLocation location initialEvents state _event cont) =+ "Handler "+ <> show parentLocation <> " "+ <> show location <> " "+ <> show state <> " "+ <> show (cont state)+ show (Receiver parentLocation location name handler child state) =+ "Receiver "+ <> show parentLocation <> " "+ <> show location <> " "+ <> show name <> " "+ <> show (child state)+ show (Attribute attrs cont) = "Attr " <> show attrs <> " " <> show cont show (Text str) = show str show (Html kind children) = kind <> " [ " <> concatMap ((<>) " " . show) children <> " ] " show (Value value) = show value- show (Hide a) = "Hide " <> show a -instance Eq (Purview parentAction action m) where+instance Eq (Purview event m) where a == b = show a == show b--{-|--This is most straightforward effect handler. It can't send messages to itself-or to its parent.--For example, let's say you want to make a button that switches between saying-"up" or "down":--> view direction = onClick "toggle" $ button [ text direction ]->-> handler = simpleHandler "up" reduce-> where reduce "toggle" state = if state == "up" then "down" else "up"->-> component = handler view---}-simpleHandler- :: ( FromJSON action- , FromJSON state- , ToJSON action- , ToJSON parentAction- , ToJSON state- , Typeable state- , Eq state- , Applicative m- )- => state- -- ^ The initial state- -> (action -> state -> state)- -- ^ The reducer, or how the state should change for an action- -> (state -> Purview action any1 m)- -- ^ The continuation / component to connect to- -> Purview parentAction any2 m-simpleHandler state handler =- effectHandler state (\action state -> pure (const $ handler action state, []))--{-|--More powerful than the 'simpleHandler', it can send messages to itself or its-parent. You will also note that instead of just returning the new state, it-returns a function to transform the state. This is because handlers run in-their own threads.---}-messageHandler- :: ( FromJSON action- , FromJSON state- , ToJSON action- , ToJSON parentAction- , ToJSON state- , Typeable state- , Eq state- , Applicative m- )- => state- -- ^ initial state- -> (action -> state -> (state -> state, [DirectedEvent parentAction action]))- -- ^ reducer- -> (state -> Purview action any1 m)- -- ^ continuation- -> Purview parentAction any2 m-messageHandler state handler =- effectHandler state (\action state -> pure (handler action state))--{-|--This handler gives you access to whichever monad you're running Purview with.--If you wanted to print something on the server every time someone clicked-a button:--> view direction = onClick "sayHello" $ button [ text "Say hello on the server" ]->-> handler = effectHandler Nothing reduce-> where reduce "sayHello" state = do-> print "someone on the browser says hello!"-> pure (const Nothing, [])->-> component = handler view---}-effectHandler- :: ( FromJSON action- , FromJSON state- , ToJSON action- , ToJSON parentAction- , ToJSON state- , Typeable state- , Eq state- )- => state- -- ^ initial state- -> (action -> state -> m (state -> state, [DirectedEvent parentAction action]))- -- ^ reducer (note the m!)- -> (state -> Purview action any1 m)- -- ^ continuation- -> Purview parentAction any2 m-effectHandler state handler =- Hide . EffectHandler Nothing Nothing state handler--{-|--This is for kicking off loading events. Put it beneath one of your handlers-to send an event up to it, and it will only be sent once.---}-once- :: ToJSON action- => ((action -> Event) -> Event)- -> Purview parentAction action m- -> Purview parentAction action m-once sendAction = Once sendAction False--{---Helpers---}--div :: [Purview parentAction action m] -> Purview parentAction action m-div = Html "div"--span :: [Purview parentAction action m] -> Purview parentAction action m-span = Html "span"--h1 :: [Purview parentAction action m] -> Purview parentAction action m-h1 = Html "h1"--h2 :: [Purview parentAction action m] -> Purview parentAction action m-h2 = Html "h2"--h3 :: [Purview parentAction action m] -> Purview parentAction action m-h3 = Html "h3"--h4 :: [Purview parentAction action m] -> Purview parentAction action m-h4 = Html "h4"--p :: [Purview parentAction action m] -> Purview parentAction action m-p = Html "p"--button :: [Purview parentAction action m] -> Purview parentAction action m-button = Html "button"--form :: [Purview parentAction action m] -> Purview parentAction action m-form = Html "form"--input :: [Purview parentAction action m] -> Purview parentAction action m-input = Html "input"--text :: String -> Purview parentAction action m-text = Text--{-|--For adding styles--> blue = style "color: \"blue\";"-> blueButton = blue $ button [ text "I'm blue" ]---}-style :: String -> Purview parentAction action m -> Purview parentAction action m-style = Attribute . Style--{-|--This will send the action to the handler above it whenever "click" is triggered-on the frontend. It will be bound to whichever 'HTML' is beneath it.---}-onClick :: ToJSON action => action -> Purview parentAction action m -> Purview parentAction action m-onClick = Attribute . On "click"--{-|--This will send the action to the handler above it whenever "submit" is triggered-on the frontend.---}-onSubmit :: ToJSON action => action -> Purview parentAction action m -> Purview parentAction action m-onSubmit = Attribute . On "submit"--identifier :: String -> Purview parentAction action m -> Purview parentAction action m-identifier = Attribute . Generic "id"--classes :: [String] -> Purview parentAction action m -> Purview parentAction action m-classes xs = Attribute . Generic "class" $ unwords xs
+ src/ComponentHelpers.hs view
@@ -0,0 +1,409 @@+module ComponentHelpers where++import Data.Typeable+import Data.Bifunctor++import Events+import Component (Purview (..), Attributes (..))++{-|++This is the pure handler, for when you don't need access to IO. Events+are still handled within a green thread so it's possible to overwrite+state, just something to be aware of.++__Example__:++Let's say you want to make a button that switches between saying+"up" or "down":++@+view direction = onClick "toggle" $ button [ text direction ]++toggleHandler = handler [] "up" reducer+ where reducer "toggle" state =+ let newState = if state == "up" then "down" else "up"+ in (const newState, [])++component = toggleHandler view+@++Or typed out in longer form:++@+type State = String+type Event = String++reducer :: Event -> State -> (State -> State, [DirectedEvent parentEvent Event])+reducer event state = case event of+ "up" -> (const "down", [])+ "down" -> (const "up", [])++toggleHandler :: (State -> Purview Event m) -> Purview parentEvent m+toggleHandler = handler [] "up" reducer++component :: Purview parentEvent m+component = toggleHandler view+@++Note that parentEvent is left unspecified as this handler doesn't send+any events to a parent, so it can be plugged in anywhere. If you did+want to send events, the reducer looks like this:++@+reducer :: String -> String -> (String -> String, [DirectedEvent String String])+reducer event state = case event of+ "up" -> (const "down", [Self "down"])+ "down" -> (const "up", [Parent "clickedDown"])+@++Which is about all there is to sending more events.+-}+handler+ :: ( Typeable event+ , Show state+ , Eq state+ , Typeable state+ )+ => [DirectedEvent parentEvent event]+ -- ^ Initial events to fire+ -> state+ -- ^ The initial state+ -> (event -> state -> (state -> state, [DirectedEvent parentEvent event]))+ -- ^ The reducer, or how the state should change for an event+ -> (state -> Purview event m)+ -- ^ The continuation / component to connect to+ -> Purview parentEvent m+handler initEvents state reducer cont =+ Handler Nothing Nothing initEvents state reducer cont++{-|++This provides a shorthand for when you know you want to overwrite+the state on each event.++__Example__:++@+view direction = onClick "toggle" $ button [ text direction ]++toggleHandler = handler' [] "up" reducer+ where reducer "toggle" state =+ let newState = if state == "up" then "down" else "up"+ -- note it's just newState, not const newState+ in (newState, [])++component = toggleHandler view+-}+handler'+ :: ( Typeable event+ , Show state+ , Eq state+ , Typeable state+ )+ => [DirectedEvent parentEvent event]+ -- ^ Initial events to fire+ -> state+ -- ^ The initial state+ -> (event -> state -> (state, [DirectedEvent parentEvent event]))+ -- ^ The reducer, or how the state should change for an event+ -> (state -> Purview event m)+ -- ^ The continuation / component to connect to+ -> Purview parentEvent m+handler' initEvents state reducer cont =+ Handler Nothing Nothing initEvents state (constReducer reducer) cont+ where constReducer reducer event state =+ let (newState, events) = reducer event state+ in (const newState, events)+++{-|++This handler gives you access to whichever monad you're running Purview with.++__Example:__++If you wanted to print something on the server every time someone clicked+a button:++@+view _ = onClick "sayHello" $ button [ text "Say hello on the server" ]++handler = effectHandler [] () reduce+ where reduce "sayHello" state = do+ print "Someone on the browser says hello!"+ pure (const (), [])++component = handler view+@+-}+effectHandler+ :: ( Typeable event+ , Show state+ , Eq state+ , Typeable state+ )+ => [DirectedEvent parentEvent event]+ -- ^ Initial events to fire+ -> state+ -- ^ initial state+ -> (event -> state -> m (state -> state, [DirectedEvent parentEvent event]))+ -- ^ reducer (note the m!)+ -> (state -> Purview event m)+ -- ^ continuation+ -> Purview parentEvent m+effectHandler initEvents state reducer cont =+ EffectHandler Nothing Nothing initEvents state reducer cont++{-|+To mirror handler', a shorthand for when you know you want to overwrite state.+-}+effectHandler'+ :: ( Typeable event+ , Show state+ , Eq state+ , Typeable state+ , Functor m+ )+ => [DirectedEvent parentEvent event]+ -- ^ Initial events to fire+ -> state+ -- ^ initial state+ -> (event -> state -> m (state, [DirectedEvent parentEvent event]))+ -- ^ reducer (note the m!)+ -> (state -> Purview event m)+ -- ^ continuation+ -> Purview parentEvent m+effectHandler' initEvents state reducer cont =+ EffectHandler Nothing Nothing initEvents state (constReducer reducer) cont+ where constReducer reducer event state = fmap (Data.Bifunctor.first const) (reducer event state)++{-|+For receiving events from Javascript. In addition to the name and an event+producer, the receiver takes in a state and child and passes it through for+(hopefully) more natural composition with handlers.++__Example:__++This receives an event from javascript every 1 second and increments+the count.++@+component count = div [ text (show count) ]++countHandler = handler' [] (0 :: Int) reducer+ where+ reducer "increment" state = (state + 1, [])+ reducer "decrement" state = (state - 1, [])++countReceiver = receiver "incrementReceiver" (const "increment")++render = countHandler . countReceiver $ component++jsCounter = [r|+ const startCount = () => {+ window.setInterval(() => {+ -- sendEvent is added to the window by Purview and all that's+ -- needed. Purview finds the receiver by name.+ sendEvent("incrementReceiver", "increment")+ }, 1000)+ }+ startCount()+|]++main = serve defaultConfiguration { javascript=jsCounter } render+@+-}+receiver+ :: ( Show event+ , Eq event+ , Typeable event+ )+ => String -> (Maybe String -> event) -> (state -> Purview event m) -> state -> Purview event m+receiver name eventParser child state = Receiver Nothing Nothing name eventParser child state++{-++Helpers++-}++div :: [Purview event m] -> Purview event m+div = Html "div"++span :: [Purview event m] -> Purview event m+span = Html "span"++h1 :: [Purview event m] -> Purview event m+h1 = Html "h1"++h2 :: [Purview event m] -> Purview event m+h2 = Html "h2"++h3 :: [Purview event m] -> Purview event m+h3 = Html "h3"++h4 :: [Purview event m] -> Purview event m+h4 = Html "h4"++p :: [Purview event m] -> Purview event m+p = Html "p"++a :: [Purview event m] -> Purview event m+a = Html "a"++ul :: [Purview event m] -> Purview event m+ul = Html "ul"++li :: [Purview event m] -> Purview event m+li = Html "li"++button :: [Purview event m] -> Purview event m+button = Html "button"++form :: [Purview event m] -> Purview event m+form = Html "form"++input :: [Purview event m] -> Purview event m+input = Html "input"++text :: String -> Purview event m+text = Text++{-|+For adding an "id" to HTML+-}+id' :: String -> Purview event m -> Purview event m+id' = Attribute . Generic "id"++{-|+For adding a "class" to HTML+-}+class' :: String -> Purview event m -> Purview event m+class' = Attribute . Generic "class"++classes :: [String] -> Purview event m -> Purview event m+classes xs = Attribute . Generic "class" $ unwords xs++href :: String -> Purview event m -> Purview event m+href = Attribute . Generic "href"++{-|++For adding inline styles. Good for dynamic parts of styling, as+the style QuasiQuoter does not support variables.++__Example:__++Varying a color based on input:++@+submitButton valid =+ let+ borderColor = if valid then "green" else "red"+ borderStyle = "border-color: " <> borderColor <> ";"+ in+ istyle borderStyle $ button [ text "Submit" ]+@+-}+istyle :: String -> Purview event m -> Purview event m+istyle str = Attribute $ Style ("-1", str)++{-|++This will send the event to the handler above it whenever "click" is triggered+on the frontend. It will be bound to whichever concrete HTML is beneath it.+++__Example:__++To send a string based event:++@+toggleButton :: Purview String m+toggleButton = onClick "toggle" $ button []+@++To send a better typed event:++@+data Toggle = Toggle+ deriving (Show, Eq)++toggleButton :: Purview Toggle m+toggleButton = onClick Toggle $ button []+@++Note how the type changed to show which kind of event is produced.++-}+onClick :: (Typeable event, Eq event, Show event) => event -> Purview event m -> Purview event m+onClick = Attribute . On "click" Nothing . const++{-|++This will send the event to the handler above it whenever "submit" is triggered+on the frontend. It takes a function to transform the value received into+an event for handlers, this can be a good spot to debug trace and see what+is being received from the browser.++The form produces JSON so the handling function can also be used to parse+the form, or you can throw it up as a string for the handler to parse.++__Example:__++@+nameAttr = Attribute . Generic "name"++data FormEvent = Submitted String+ deriving (Show, Eq)++handleSubmit (Just val) = Submitted val+handleSubmit Nothing = Submitted ""++component :: Purview FormEvent m+component = onSubmit handleSubmit $+ form+ [ nameAttr "text" $ input []+ ]+@+-}+onSubmit :: (Typeable event, Eq event, Show event) => (Maybe String -> event) -> Purview event m -> Purview event m+onSubmit = Attribute . On "submit" Nothing++{-|+This is triggered on focusout instead of blur to work with mobile+sites as well. Like onSubmit it takes a value.++__Example:__++@+data AddressEvent = LineOneUpdated String+ deriving (Show, Eq)++handleBlur (Just val) = LineOneUpdated val+handleBlur Nothing = LineOneUpdated ""++addressLineOne = onBlur handleBlur $ input []+@+-}+onBlur :: (Typeable event, Eq event, Show event) => (Maybe String -> event) -> Purview event m -> Purview event m+onBlur = Attribute . On "focusout" Nothing++{-|+Triggered on change++__Example:__++@+data AddressEvent = LineOneUpdated String+ deriving (Show, Eq)++handleChange (Just val) = LineOneUpdated val+handleChange Nothing = LineOneUpdated ""++addressLineOne = onChange handleChange $ input []+@+-}+onChange :: (Typeable event, Eq event, Show event) => (Maybe String -> event) -> Purview event m -> Purview event m+onChange = Attribute . On "change" Nothing
− src/ComponentSpec.hs
@@ -1,17 +0,0 @@-module ComponentSpec where--import Test.Hspec--import Component--spec :: SpecWith ()-spec = parallel $ do-- describe "placeholder" $ do-- it "holds a place" $ do- 1 `shouldBe` 1---main :: IO ()-main = hspec spec
+ src/Configuration.hs view
@@ -0,0 +1,26 @@+module Configuration where++import Events++data Configuration m = Configuration+ { interpreter :: m [Event] -> IO [Event]+ -- ^ How to run your algebraic effects or other. This will apply to all `effectHandler`s.+ , logger :: String -> IO ()+ -- ^ Specify what to do with logs+ , eventsToListenTo :: [String]+ -- ^ For extending the handled events. By default it covers the usual click, change, focus(in/out)+ , htmlHead :: String+ -- ^ This is placed directly into the \<head\>, so that you can link to external+ -- CSS etc+ , devMode :: Bool+ -- ^ When enabled, Purview will send the whole tree on websocket reconnection.+ -- This enables you to use+ -- "ghcid --command 'stack ghci examples/Main.hs' --test :main`"+ -- to restart the server on file change, and get a kind of live reloading+ , javascript :: String+ , port :: Int+ -- ^ the port to run on+ , secure :: Bool+ -- ^ whether the websocket tries to connect using ws:// or wss://+ -- locally you probably want this false, in prod secure of course+ }
src/Diffing.hs view
@@ -2,7 +2,6 @@ module Diffing where import GHC.Generics-import Data.Typeable import Data.Aeson import Component@@ -10,7 +9,7 @@ {- -Since actions target specific locations, we can't stop going the tree early+Since events target specific locations, we can't stop going the tree early because changes may have happened beneath the top level. kind of the downside not having a single, passed down, state. @@ -36,9 +35,9 @@ diff :: Maybe Location -> Location- -> Purview parentAction action m- -> Purview parentAction action m- -> [Change (Purview parentAction action m)]+ -> Purview event m+ -> Purview event m+ -> [Change (Purview event m)] diff target location oldGraph newGraph = case (oldGraph, newGraph) of (Html kind children, Html kind' children') ->@@ -55,29 +54,25 @@ (unknown, Html kind children) -> [Update location newGraph] - (Hide (EffectHandler _ loc state _ cont), Hide (EffectHandler _ loc' newState _ newCont)) ->- case cast state of- Just state' ->- [Update location newGraph | state' /= newState && loc == loc']- -- TODO: this is weak, instead of walking the whole tree it should be targetted- -- to specific effect handlers+ -- TODO: add Handler+ (EffectHandler _ loc initEvents state _ cont, EffectHandler _ loc' initEvents' newState _ newCont) ->+ [Update location newGraph | unsafeCoerce state /= newState && loc == loc']+ -- TODO: this is weak, instead of walking the whole tree it should be targetted+ -- to specific effect handlers - -- if we hit the target, we're already saying update the whole tree- <> if Just location == target- then []- else diff target (0:location) (unsafeCoerce cont state) (unsafeCoerce newCont newState)+ -- if we hit the target, we're already saying update the whole tree+ <> if Just location == target+ then []+ else diff target (0:location) (unsafeCoerce cont state) (unsafeCoerce newCont newState) - -- different kinds of state- Nothing ->- [Update location newGraph] - ((Attribute attr a), (Attribute attr' b)) ->+ (Attribute attr a, Attribute attr' b) -> [Update location newGraph | attr /= attr'] - ((Value _), _) ->+ (Value _, _) -> [Update location newGraph] - ((EffectHandler _ _ _ _ _), _) ->+ (EffectHandler _ _ _ _ _ _, _) -> [Update location newGraph] (_, _) -> [Update location newGraph]
− src/DiffingSpec.hs
@@ -1,103 +0,0 @@-module DiffingSpec where--import Prelude hiding (div)-import Test.Hspec--import PrepareTree-import Purview-import Diffing--type DefaultAction = DirectedEvent String String--spec :: SpecWith ()-spec = parallel $ do-- describe "diff" $ do-- it "creates an update for differing text" $ do- let- oldTree = div [ text "night" ]- newTree = div [ text "morning" ]-- diff Nothing [] oldTree newTree `shouldBe` [Update [0] (text "morning")]-- it "can do a nested update" $ do- let- oldTree = div [ div [ text "night" ] ]- newTree = div [ div [ text "morning" ] ]-- diff Nothing [] oldTree newTree `shouldBe` [Update [0, 0] (text "morning")]-- it "says to update the whole underlying tree on added div" $ do- let- oldTree = div [ text "night" ]- newTree = div [ div [ text "morning" ] ]-- diff Nothing [] oldTree newTree `shouldBe` [Update [0] (div [ text "morning" ])]-- describe "message handlers" $ do--- it "doesn't diff handler children if the state is the same" $ do--- let--- mkHandler :: (String -> Purview String action IO) -> Purview String action IO--- mkHandler = messageHandler "initial state" (\action state -> (state <> action, [] :: [DefaultAction]))--- oldTree = div [ mkHandler (const (text "the original")) ]--- newTree = div [ mkHandler (const (text "this is different")) ]------ diff [] oldTree newTree `shouldBe` []-- it "diffs handler children if the state is different" $ do- let- handler1 :: (String -> Purview String action IO) -> Purview String action IO- handler1 = messageHandler "initial state" (\action state -> (const $ state <> action, [] :: [DefaultAction]))- handler2 = messageHandler "different state" (\action state -> (const $ state <> action, [] :: [DefaultAction]))- oldTree = div [ handler1 (const (text "the original")) ]- newTree = div [ handler2 (const (text "this is different")) ]-- diff Nothing [] oldTree newTree `shouldBe`- [ Update [0] (handler2 (const (text "this is different")))- , Update [0, 0] (text "this is different")- ]-- describe "effect handlers" $ do--- it "doesn't diff handler children if the state is the same" $ do--- let--- mkHandler :: (String -> Purview String action IO) -> Purview String action IO--- mkHandler = effectHandler "initial state" (\action state -> pure $ (state <> action, ([] :: [DirectedEvent String String])))--- oldTree = div [ mkHandler (const (text "the original")) ]--- newTree = div [ mkHandler (const (text "this is different")) ]------ diff [] oldTree newTree `shouldBe` []-- it "diffs handler children if the state is different" $ do- let- handler1 :: (String -> Purview String action IO) -> Purview String action IO- handler1 = effectHandler "initial state" (\action state -> pure $ (const $ state <> action, ([] :: [DirectedEvent String String])))- handler2 = effectHandler "different state" (\action state -> pure $ (const $ state <> action, ([] :: [DirectedEvent String String])))- oldTree = div [ handler1 (const (text "the original")) ]- newTree = div [ handler2 (const (text "this is different")) ]-- diff Nothing [] oldTree newTree `shouldBe`- [ Update [0] (handler2 (const (text "this is different")))- , Update [0, 0] (text "this is different")- ]-- it "continues going down the tree even if the state is the same at the top" $ do- let- handler1 :: (String -> Purview String action IO) -> Purview String action IO- handler1 = effectHandler "initial state" (\action state -> pure $ (const $ state <> action, ([] :: [DirectedEvent String String])))- handler2 = effectHandler "different state" (\action state -> pure $ (const $ state <> action, ([] :: [DirectedEvent String String])))- oldTree = fst . prepareTree $ div [ handler1 . const $ handler1 (const (text "the original")) ]- newTree = fst . prepareTree $ div [ handler1 . const $ handler2 (const (text "this is different")) ]-- diff (Just [0, 0]) [] oldTree newTree `shouldBe`- [ Update [0, 0] (Hide $ EffectHandler- (Just [0])- (Just [0, 0])- "different state"- (\action state -> pure $ (const $ state <> action, ([] :: [DirectedEvent String String])))- (const (text "this is different")))- ]---main :: IO ()-main = hspec spec
src/EventHandling.hs view
@@ -1,16 +1,26 @@+{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE DuplicateRecordFields #-} module EventHandling where -import Control.Concurrent.STM.TChan-import Data.Aeson++ import Data.Typeable+import Data.Maybe import Events import Component +type Location = [Int]++directedEventToInternalEvent :: (Typeable a, Typeable b) => Location -> Location -> DirectedEvent a b -> Event+directedEventToInternalEvent parentLocation location directedEvent = case directedEvent of+ Parent event -> InternalEvent { event=event, childId=Nothing, handlerId=Just parentLocation }+ Self event -> InternalEvent { event=event, childId=Nothing, handlerId=Just location }+ Browser name value -> JavascriptCallEvent name value+ {-| This is a special case event to assign new state to handlers@@ -18,20 +28,30 @@ -} applyNewState :: Event- -> Purview parentAction action m- -> Purview parentAction action m+ -> Purview event m+ -> Purview event m applyNewState fromEvent@(StateChangeEvent newStateFn location) component = case component of- EffectHandler ploc loc state handler cont -> case cast newStateFn of- Just newStateFn' -> EffectHandler ploc loc (newStateFn' state) handler cont- Nothing ->+ EffectHandler ploc loc initEvents state handler cont ->+ if loc == location then+ case cast newStateFn of+ Just newStateFn' -> EffectHandler ploc loc initEvents (newStateFn' state) handler cont+ Nothing ->+ let children = fmap (applyNewState fromEvent) cont+ in EffectHandler ploc loc initEvents state handler children+ else let children = fmap (applyNewState fromEvent) cont- in EffectHandler ploc loc state handler children+ in EffectHandler ploc loc initEvents state handler children - Hide x ->- let- children = applyNewState fromEvent x- in- Hide children+ Handler ploc loc initEvents state handler cont ->+ if loc == location then+ case cast newStateFn of+ Just newStateFn' -> Handler ploc loc initEvents (newStateFn' state) handler cont+ Nothing ->+ let children = fmap (applyNewState fromEvent) cont+ in Handler ploc loc initEvents state handler children+ else+ let children = fmap (applyNewState fromEvent) cont+ in Handler ploc loc initEvents state handler children Html kind children -> Html kind $ fmap (applyNewState fromEvent) children@@ -39,68 +59,88 @@ Attribute n cont -> Attribute n (applyNewState fromEvent cont) - Once fn run cont ->- Once fn run $ applyNewState fromEvent cont+ receiver@Receiver {} -> receiver Text x -> Text x Value x -> Value x-applyNewState (Event {}) component = component+applyNewState (FromFrontendEvent {}) component = component+applyNewState (InternalEvent {}) component = component+applyNewState (JavascriptCallEvent {}) component = component -runEvent :: Monad m => Event -> Purview parentAction action m -> m [Event]-runEvent (StateChangeEvent _ _) _ = pure []-runEvent fromEvent@(Event { message, location }) component = case component of- EffectHandler parentLocation loc state handler cont -> case fromJSON message of- Success parsedAction -> do- -- if locations match, we actually run what is in the handler- (newStateFn, events) <-- if loc == location- then handler parsedAction state- else pure (const state, [])+findEvent :: Event -> Purview event m -> Maybe Event+findEvent (StateChangeEvent {}) _ = Nothing+findEvent (InternalEvent {}) _ = Nothing+findEvent (JavascriptCallEvent {}) _ = Nothing+findEvent event@FromFrontendEvent { childLocation=childLocation, location=handlerLocation, value=value } tree = case tree of+ Attribute attr cont -> case attr of+ On _ ident evt ->+ if ident == childLocation+ then Just $ InternalEvent (evt value) childLocation handlerLocation+ else Nothing+ _ -> findEvent event cont - -- although it doesn't break anything, only send this when the- -- locations match (cuts down on noise)- let newStateEvent = [StateChangeEvent newStateFn loc | loc == location]+ Html _ children ->+ case mapMaybe (findEvent event) children of+ [found] -> Just found+ [] -> Nothing+ _ -> Nothing - let createMessage directedEvent = case directedEvent of- (Parent event) -> Event- -- TODO: this should probably be a new kind of event- { event = "internal"- , message = toJSON event- , location = parentLocation- }- (Self event) -> Event- { event = "internal"- , message = toJSON event- , location = loc- }+ EffectHandler _ ident initEvents state _ cont ->+ findEvent event (cont state) - -- here we handle sending events returned to either this- -- same handler or passing it up the chain- -- mapM_ (atomically . writeTChan eventBus . createMessage) events- let handlerEvents = fmap createMessage events+ Handler _ ident initEvents state _ cont ->+ findEvent event (cont state) - -- ok, right, no where in this function does the tree actually change- -- that's handled by the setting state event- childEvents <- runEvent fromEvent (cont state)+ -- TODO: dunno how I feel about findEvent running anything+ Receiver parentLocation location name eventHandler child state ->+ if location == childLocation+ then Just $ InternalEvent (eventHandler value) location parentLocation+ else findEvent event (child state) - -- so we can ignore the results from applyEvent and continue- -- pure $ EffectHandler parentLocation loc state handler cont- pure $ newStateEvent <> handlerEvents <> childEvents+ Text _ -> Nothing - Error _err -> runEvent fromEvent (cont state)+ Value _ -> Nothing - Html kind children -> do- childEvents' <- mapM (runEvent fromEvent) children- pure $ concat childEvents'+runEvent :: (Typeable event, Monad m) => Event -> Purview event m -> m [Event]+runEvent (FromFrontendEvent {}) _ = pure []+runEvent (StateChangeEvent {}) _ = pure []+runEvent (JavascriptCallEvent {}) _ = pure []+runEvent internalEvent@InternalEvent { event, handlerId } tree = case tree of+ Attribute attr cont ->+ runEvent internalEvent cont - Attribute n cont -> runEvent fromEvent cont+ Html _ children -> concat <$> mapM (runEvent internalEvent) children - Hide x -> runEvent fromEvent x+ EffectHandler (Just parentIdent) (Just ident) initEvents state handler cont ->+ if Just ident == handlerId then+ case cast event of+ Just event' -> do+ (newStateFn, events) <- handler event' state+ pure $ [StateChangeEvent newStateFn handlerId] <> fmap (directedEventToInternalEvent parentIdent ident) events+ Nothing -> pure []+ else+ runEvent internalEvent (cont state) - Once _ _ cont -> runEvent fromEvent cont+ Handler (Just parentIdent) (Just ident) initEvents state handler cont ->+ if Just ident == handlerId then+ case cast event of+ Just event' ->+ let (newStateFn, events) = handler event' state+ in pure $ [StateChangeEvent newStateFn handlerId] <> fmap (directedEventToInternalEvent parentIdent ident) events+ Nothing -> pure []+ else+ runEvent internalEvent (cont state) + Receiver {} -> pure []+ Text _ -> pure [] Value _ -> pure []++ -- TODO: this should never happen, should refactor so it's clear+ EffectHandler { identifier = Nothing } -> undefined+ EffectHandler { parentIdentifier = Nothing } -> undefined+ Handler { identifier = Nothing } -> undefined+ Handler { parentIdentifier = Nothing } -> undefined
− src/EventHandlingSpec.hs
@@ -1,289 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE LambdaCase #-}-module EventHandlingSpec where--import Prelude hiding (div)-import Control.Concurrent.STM.TChan-import Control.Monad.STM (atomically)-import Control.Monad.IO.Class-import Test.Hspec.QuickCheck-import Test.Hspec-import Test.QuickCheck-import Data.Aeson-import Data.Aeson.TH--import TreeGenerator-import Component-import EventHandling-import Events-import PrepareTree-import Rendering--type Id a = a -> a--data TestAction = Up | Down--$(deriveJSON defaultOptions ''TestAction)--data SingleConstructor = SingleConstructor--$(deriveJSON (defaultOptions{tagSingleConstructors=True}) ''SingleConstructor)--{---Just to clean up tests a bit. I dunno if this approach would work to clean-up the main event loop as well, since it calls "runEvent" (re: applying the event)-in a non-forked fashioned. If you try void . forkIO you end up back in m a -> IO a-hell.---}-apply :: MonadIO m => TChan Event -> Event -> Purview parentAction action m -> m (Purview parentAction action m)-apply eventBus newStateEvent@StateChangeEvent {} component =- pure $ applyNewState newStateEvent component-apply eventBus fromEvent@Event {event=eventKind} component =- case eventKind of- "newState" -> pure $ applyNewState fromEvent component- _ -> do- events <- runEvent fromEvent component- liftIO $ mapM_ (atomically . writeTChan eventBus) events- pure component--spec :: SpecWith ()-spec = parallel $ do- describe "apply" $ do-- it "changes state" $ do- let- actionHandler :: String -> Int -> Int- actionHandler "up" _ = 1- actionHandler _ _ = 0-- handler :: Purview () a IO- handler =- simpleHandler (0 :: Int)- actionHandler- (Text . show)-- render handler- `shouldBe`- "<div handler=\"null\">0</div>"-- chan <- newTChanIO-- let event' = Event { event="click", message="up", location=Nothing }-- appliedHandler <- apply chan event' handler-- stateEvent <- atomically $ readTChan chan-- show stateEvent `shouldBe` show (StateChangeEvent (id :: Int -> Int) Nothing)-- afterState <- apply chan stateEvent appliedHandler-- render afterState- `shouldBe`- "<div handler=\"null\">1</div>"-- it "works for clicks across many different trees" $- property $ \x -> do- let event = Event { event="click", message="up", location=Nothing }- chan <- newTChanIO-- component <- apply chan event (x :: Purview String String IO)- render component `shouldContain` "always present"-- it "works for setting state across many different trees" $- property $ \x -> do- let event = Event { event="newState", message="up", location=Just [] }- chan <- newTChanIO-- component <- apply chan event (x :: Purview String String IO)- -- this tests 2 things- -- 1. that it fully goes down the tree- -- 2. the component remains the same, since the event doesn't- -- have a location that matches anything- component `shouldBe` x-- it "works with typed messages" $ do- let- actionHandler :: TestAction -> Int -> (Id Int, [DirectedEvent String TestAction])- actionHandler Up _ = (const 1, [])- actionHandler Down _ = (const 0, [])-- handler =- messageHandler (0 :: Int)- actionHandler- (Text . show)-- render handler- `shouldBe`- "<div handler=\"null\">0</div>"-- chan <- newTChanIO-- let event' = Event { event="click", message=toJSON Up, location=Nothing }-- appliedHandler <- apply chan event' handler-- stateEvent <- atomically $ readTChan chan-- afterState <- apply chan stateEvent appliedHandler-- render afterState- `shouldBe`- "<div handler=\"null\">1</div>"-- it "works after sending an event that did not match anything" $ do- let- actionHandler :: TestAction -> Int -> (Id Int, [DirectedEvent String TestAction])- actionHandler Up _ = (const 1, [])- actionHandler Down _ = (const 0, [])-- handler =- messageHandler (0 :: Int)- actionHandler- (Text . show)-- chan <- newTChanIO-- let event0 = Event { event="init", message="init", location=Nothing }-- appliedHandler0 <- apply chan event0 handler- render appliedHandler0- `shouldBe`- "<div handler=\"null\">0</div>"-- let event1 = Event { event="init", message=toJSON Up, location=Nothing }-- appliedHandler1 <- apply chan event1 appliedHandler0-- stateEvent <- atomically $ readTChan chan- appliedHandler2 <- apply chan stateEvent appliedHandler1-- render appliedHandler2- `shouldBe`- "<div handler=\"null\">1</div>"-- it "works with a nested attribute" $ do- let- childHandler :: TestAction -> Int -> (Id Int, [DirectedEvent String TestAction])- childHandler Up _ = (const 1, [Parent "hello"])- childHandler Down _ = (const 0, [])-- parentHandler :: String -> String -> (Id String, [DirectedEvent String String])- parentHandler "hello" _ = (const "bye", [])- parentHandler "bye" _ = (const "hello", [])- parentHandler str _ = (const str, [])-- styledContainer = style "font-size: 10px;" . div-- handler =- messageHandler ("" :: String) parentHandler- $ \message ->- styledContainer- [ text message- , messageHandler (0 :: Int)- childHandler- (text . show)- ]-- component = handler-- chan <- newTChanIO-- let- locatedGraph = fst $ prepareTree component- event1 = Event { event="click", message=toJSON Up, location=Just [1, 0] }-- afterEvent1 <- apply chan event1 locatedGraph-- receivedEvent1 <- atomically $ readTChan chan- show receivedEvent1 `shouldBe` show (StateChangeEvent (id :: Int -> Int) (Just [1, 0]))-- receivedEvent2 <- atomically $ readTChan chan- receivedEvent2 `shouldBe` Event {event = "internal", message = String "hello", location = Just []}-- describe "sending events" $ do-- it "can send an event to a parent" $ do- let- childHandler :: TestAction -> Int -> (Id Int, [DirectedEvent String TestAction])- childHandler Up _ = (const 1, [Parent "hello"])- childHandler Down _ = (const 0, [])-- parentHandler :: String -> String -> (Id String, [DirectedEvent String String])- parentHandler "hello" _ = (const "bye", [])- parentHandler "bye" _ = (const "hello", [])- parentHandler str _ = (const str, [])-- handler =- messageHandler ("" :: String) parentHandler- $ \message ->- div- [ text message- , messageHandler (0 :: Int)- childHandler- (text . show)- ]-- chan <- newTChanIO-- let locatedGraph = fst $ prepareTree handler-- render locatedGraph `shouldBe` "<div handler=\"[]\"><div><div handler=\"[1,0]\">0</div></div></div>"-- let event1 = Event { event="click", message=toJSON Up, location=Just [1, 0] }-- afterEvent1 <- apply chan event1 locatedGraph-- receivedEvent1 <- atomically $ readTChan chan- show receivedEvent1 `shouldBe` show (StateChangeEvent (id :: Int -> Int) (Just [1, 0]))-- receivedEvent2 <- atomically $ readTChan chan- -- correctly targeted to the parent- receivedEvent2 `shouldBe` Event {event = "internal", message = String "hello", location = Just []}--- it "can send an event to self" $ do- let- childHandler :: TestAction -> Int -> (Int -> Int, [DirectedEvent String TestAction])- childHandler Up _ = (const 1, [Self Down])- childHandler Down _ = (const 0, [])-- parentHandler :: String -> String -> (String -> String, [DirectedEvent String String])- parentHandler "hello" _ = (const "bye", [])- parentHandler "bye" _ = (const "hello", [])- parentHandler str _ = (const str, [])-- handler =- messageHandler ("" :: String) parentHandler- $ \message ->- div- [ text message- , messageHandler (0 :: Int)- childHandler- (text . show)- ]-- chan <- newTChanIO-- let locatedGraph = fst $ prepareTree handler-- render locatedGraph `shouldBe` "<div handler=\"[]\"><div><div handler=\"[1,0]\">0</div></div></div>"-- let event1 = Event { event="click", message=toJSON Up, location=Just [1, 0] }-- afterEvent1 <- apply chan event1 locatedGraph-- receivedEvent1 <- atomically $ readTChan chan- show receivedEvent1 `shouldBe` show (StateChangeEvent (id :: Int -> Int) (Just [1, 0]))-- receivedEvent2 <- atomically $ readTChan chan- -- correctly targeted to self- receivedEvent2 `shouldBe` Event {event = "internal", message = String "Down", location = Just [1,0]}---main :: IO ()-main = hspec spec
src/EventLoop.hs view
@@ -10,6 +10,7 @@ import Control.Monad.STM import Control.Monad import Control.Concurrent+import Data.Typeable import Data.Aeson (encode) import qualified Network.WebSockets as WebSockets @@ -19,54 +20,59 @@ import Events import PrepareTree import Rendering+import CleanTree (cleanTree)+import CollectInitials (collectInitials) type Log m = String -> m () ------ This is the main event loop of handling messages from the websocket------ pretty much just get a message, then run the message via the component--- handler, and then send the "setHtml" back downstream to tell it to replace--- the html with the new.----eventLoop- :: Monad m- => Bool+eventLoop'+ :: (Monad m, Typeable event)+ => Event+ -> Bool -> (m [Event] -> IO [Event]) -> Log IO -> TChan Event -> WebSockets.Connection- -> Purview parentAction action m- -> IO ()-eventLoop devMode runner log eventBus connection component = do- message <- atomically $ readTChan eventBus-- when devMode $ log $ "received> " <> show message+ -> Purview event m+ -> IO (Maybe (Purview event m))+eventLoop' message devMode runner log eventBus connection component = do+ -- if it's special newState event, the state is replaced in the tree+ let newTree = case message of+ FromFrontendEvent {} -> component+ InternalEvent {} -> component+ JavascriptCallEvent {} -> component+ stateChangeEvent@StateChangeEvent {} -> applyNewState stateChangeEvent component let- -- this collects any actions that should run once and sets them- -- to "run" in the tree, while assigning locations / identifiers- -- to the event handlers- (newTree, actions) = prepareTree component+ -- 1. adds locations+ locatedTree = prepareTree newTree+ -- 2. collects css and initial events+ (initialEvents, css) = collectInitials locatedTree+ -- 3. removes captured css and initial events+ newTree' = cleanTree css locatedTree+ -- why pass in the found css? otherwise haskell will optimize by+ -- putting the function that removes css into the tree, which results+ -- in the css being removed before it's been found by collectInitials.+ -- or at least, that's what seemed to be happening. very funny. - -- if it's special newState event, the state is replaced in the tree- let newTree' = case message of- Event {} -> newTree- stateChangeEvent -> applyNewState stateChangeEvent newTree+ event = findEvent message newTree' -- this is where handlers are actually called, and their events are sent back into -- this loop void . forkIO $ do- newEvents <- runner $ runEvent message newTree'+ newEvents <- case (event, message) of+ (_, event'@InternalEvent {}) -> runner $ runEvent event' newTree'+ (Just event', _) -> runner $ runEvent event' newTree'+ (Nothing, _) -> pure [] mapM_ (atomically . writeTChan eventBus) newEvents - mapM_ (atomically . writeTChan eventBus) actions- let -- collect diffs location = case message of- (Event { location }) -> location- (StateChangeEvent _ location) -> location+ (FromFrontendEvent { location }) -> location+ (StateChangeEvent _ location) -> location+ (InternalEvent { handlerId }) -> handlerId+ (JavascriptCallEvent {}) -> error "tried to get location off javascript call" diffs = diff location [0] component newTree' -- for now it's just "Update", which the javascript handles as replacing@@ -74,18 +80,59 @@ -- Delete / Create events. renderedDiffs = fmap (\(Update location graph) -> Update location (render graph)) diffs - when devMode $ log $ "sending> " <> show renderedDiffs+ unless (null css) $ WebSockets.sendTextData+ connection+ (encode $ ForFrontEndEvent { event = "setCSS", message = css }) WebSockets.sendTextData connection (encode $ ForFrontEndEvent { event = "setHtml", message = renderedDiffs }) - case message of- (Event { event }) ->- when (devMode && event == "init") $- WebSockets.sendTextData- connection- (encode $ ForFrontEndEvent { event = "setHtml", message = [ Update [] (render newTree') ] })- _ -> pure ()+ pure (Just newTree') - eventLoop devMode runner log eventBus connection newTree'+handleJavascriptCall :: String -> String -> WebSockets.Connection -> IO (Maybe (Purview event m))+handleJavascriptCall name value connection = do+ WebSockets.sendTextData+ connection+ (encode $ ForFrontEndEvent { event = "callJS", message = [name, value] })++ pure Nothing++--+-- This is the main event loop of handling messages from the websocket+--+-- pretty much just get a message, then run the message via the component+-- handler, and then send the "setHtml" back downstream to tell it to replace+-- the html with the new.+--+eventLoop+ :: (Monad m, Typeable event)+ => Bool+ -> (m [Event] -> IO [Event])+ -> Log IO+ -> TChan Event+ -> WebSockets.Connection+ -> Purview event m+ -> IO ()+eventLoop devMode runner log eventBus connection component = do+ message <- atomically $ readTChan eventBus++ when devMode $ log $ show message++ newTree <- case message of+ JavascriptCallEvent name value -> handleJavascriptCall name value connection+ _ -> eventLoop' message devMode runner log eventBus connection component++ case newTree of+ Just tree ->+ case message of+ (FromFrontendEvent { kind }) -> do+ when (devMode && kind == "init") $+ WebSockets.sendTextData+ connection+ (encode $ ForFrontEndEvent { event = "setHtml", message = [ Update [] (render tree) ] })++ eventLoop devMode runner log eventBus connection tree+ _ ->+ eventLoop devMode runner log eventBus connection tree+ Nothing -> eventLoop devMode runner log eventBus connection component
src/Events.hs view
@@ -1,17 +1,21 @@-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} module Events where +import Prelude hiding (print) import Data.Text (Text) import Data.Typeable import Data.Aeson import GHC.Generics ++type Identifier = Maybe [Int]+type ParentIdentifier = Identifier+ {-| This for events intended for the front end@@ -33,40 +37,77 @@ -} data Event where- Event ::- { event :: Text- , message :: Value- , location :: Maybe [Int]- } -> Event+ FromFrontendEvent+ :: { kind :: Text+ -- ^ for example, "click" or "blur"+ , childLocation :: Identifier+ , location :: Identifier+ , value :: Maybe String+ }+ -> Event + InternalEvent+ :: ( Show event+ , Eq event+ , Typeable event+ )+ => { event :: event+ , childId :: Identifier+ , handlerId :: Identifier+ }+ -> Event+ StateChangeEvent- :: ( Eq state- , Typeable state- , ToJSON state- , FromJSON state)- => (state -> state) -> Maybe [Int] -> Event+ :: ( Eq state, Show state, Typeable state )+ => (state -> state) -> Identifier -> Event + JavascriptCallEvent+ :: String -> String -> Event++ instance Show Event where- show (Event event message location) =- show $ "{ event: "+ show (FromFrontendEvent event message location value) =+ "{ event: " <> show event- <> ", message: "+ <> ", childLocation: " <> show message <> ", location: "- <> show location <> " }"+ <> show location+ <> ", value: "+ <> show value <> " }"+ show (StateChangeEvent _ location) = "{ event: \"newState\", location: " <> show location <> " }" + show (InternalEvent event childId handlerId)+ = "{ event: " <> show event+ <> ", childId: " <> show childId+ <> ", handlerId: " <> show handlerId+ <> " }"++ show (JavascriptCallEvent name value) =+ "{ event: \"callJS\" }"+ instance Eq Event where- (Event { message=messageA, event=eventA, location=locationA })- == (Event { message=messageB, event=eventB, location=locationB }) =- eventA == eventB && messageA == messageB && locationA == locationB- (Event {}) == _ = False+ (FromFrontendEvent { childLocation=messageA, kind=eventA, location=locationA, value=valueA })+ == (FromFrontendEvent { childLocation=messageB, kind=eventB, location=locationB, value=valueB }) =+ eventA == eventB && messageA == messageB && locationA == locationB && valueA == valueB+ (FromFrontendEvent {}) == _ = False+ (StateChangeEvent _ _) == _ = False + (InternalEvent event childId handlerId) == (InternalEvent event' childId' handlerId') =+ case cast event of+ Just castEvent -> childId == childId' && handlerId == handlerId' && castEvent == event'+ Nothing -> False+ (InternalEvent {}) == _ = False++ (JavascriptCallEvent {}) == _ = False++ instance FromJSON Event where parseJSON (Object o) =- Event <$> o .: "event" <*> (o .: "message") <*> o .: "location"+ FromFrontendEvent <$> o .: "event" <*> (o .: "childLocation") <*> o .: "location" <*> o .:? "value" parseJSON _ = error "fail" {-|@@ -75,8 +116,7 @@ or sent back in to the same handler. -}-data DirectedEvent a b = Parent a | Self b- deriving (Generic, Show, Eq)--instance (ToJSON a, ToJSON b) => ToJSON (DirectedEvent a b) where- toEncoding = genericToEncoding defaultOptions+data DirectedEvent a b where+ Parent :: (Show a, Eq a) => a -> DirectedEvent a b+ Self :: (Show b, Eq b) => b -> DirectedEvent a b+ Browser :: String -> String -> DirectedEvent a b
src/PrepareTree.hs view
@@ -1,12 +1,15 @@+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DuplicateRecordFields #-} module PrepareTree where -import Data.Aeson+import Data.Typeable import Component-import Events +++ {-| This walks through the tree and collects actions that should be run@@ -16,56 +19,56 @@ It also assigns a location to message and effect handlers. -}--prepareTree :: Purview parentAction action m -> (Purview parentAction action m, [Event])+prepareTree :: Typeable event => Purview event m -> Purview event m prepareTree = prepareTree' [] [] type Location = [Int] +addLocationToAttr :: Location -> Attributes e -> Attributes e+addLocationToAttr loc attr = case attr of+ On str _ event' -> On str (Just loc) event'+ _ -> attr+ prepareTree'- :: Location+ :: Typeable event+ => Location -> Location- -> Purview parentAction action m- -> (Purview parentAction action m, [Event])+ -> Purview event m+ -> Purview event m prepareTree' parentLocation location component = case component of- Attribute attrs cont ->- let result = prepareTree' parentLocation location cont- in (Attribute attrs (fst result), snd result)+ Attribute attr cont ->+ let+ child = prepareTree' parentLocation (location <> [0]) cont+ newAttr = addLocationToAttr location attr+ in+ Attribute newAttr child Html kind children ->- let result = fmap (\(index, child) -> prepareTree' parentLocation (index:location) child) (zip [0..] children)- in (Html kind (fmap fst result), concatMap snd result)+ let+ indexedChildren = zip [0..] children+ children' =+ fmap (\(location', child) -> prepareTree' parentLocation (location <> [location']) child) indexedChildren+ in+ Html kind children' - EffectHandler _ploc _loc state handler cont ->+ EffectHandler _ploc _loc initEvents state handler cont -> let- rest = fmap (prepareTree' location (0:location)) cont+ cont' = fmap (prepareTree' location (location <> [0])) cont in- ( EffectHandler (Just parentLocation) (Just location) state handler (\state' -> fst (rest state'))- , snd (rest state)- )+ EffectHandler (Just parentLocation) (Just location) initEvents state handler cont' - Once effect hasRun cont ->- let send message =- Event- { event = "once"- , message = toJSON message- , location = Just location- }- in if not hasRun then- let- rest = prepareTree' parentLocation location cont- in- (Once effect True (fst rest), [effect send] <> (snd rest))- else- let- rest = prepareTree' parentLocation location cont- in- (Once effect True (fst rest), snd rest)+ Handler _ploc _loc initEvents state handler cont ->+ let+ cont' = fmap (prepareTree' location (location <> [0])) cont+ in+ Handler (Just parentLocation) (Just location) initEvents state handler cont' - Hide x ->- let (child, actions) = prepareTree' parentLocation location x- in (Hide child, actions)+ Receiver { name, eventHandler, child, state } ->+ let+ child' = fmap (prepareTree' location (location <> [0])) child+ in+ Receiver (Just parentLocation) (Just location) name eventHandler child' state - Value x -> (Value x, [])+ Text val -> Text val - Text x -> (Text x, [])+ Value val -> Value val
− src/PrepareTreeSpec.hs
@@ -1,136 +0,0 @@-module PrepareTreeSpec where--import Prelude hiding (div)-import Test.Hspec-import Test.QuickCheck-import Data.Time--import TreeGenerator-import Events-import Component-import PrepareTree--spec :: SpecWith ()-spec = parallel $ do-- describe "prepareTree" $ do-- it "works across a variety of trees" $ do- property $ \x -> show (fst (prepareTree (x :: Purview String String IO))) `shouldContain` "always present"-- it "sets hasRun to True" $ do- let- display time = div- [ text (show time)- , onClick ("setTime" :: String) $ div [ text "check time" ]- ]-- startClock cont state = Once (\send -> send ("setTime" :: String)) False (cont state)-- timeHandler = EffectHandler Nothing Nothing Nothing handle-- handle :: String -> Maybe UTCTime -> IO (Maybe UTCTime -> Maybe UTCTime, [DirectedEvent String String])- handle "setTime" _ = do- time <- getCurrentTime- pure (const $ Just time, [])- handle _ state = pure (const state, [])-- component = timeHandler (startClock display)-- show (fst (prepareTree component))- `shouldBe`- "EffectHandler Just [] Just [] \"null\" Once True div [ \"Nothing\" Attr div [ \"check time\" ] ] "-- length (snd (prepareTree component))- `shouldBe`- 1-- it "stops collecting the action if it has already run" $ do- let- display time = div- [ text (show time)- , onClick ("setTime" :: String) $ div [ text "check time" ]- ]-- startClock cont state = Once (\send -> send ("setTime" :: String)) False (cont state)-- timeHandler = EffectHandler Nothing Nothing Nothing handle-- handle :: String -> Maybe UTCTime -> IO (Maybe UTCTime -> Maybe UTCTime, [DirectedEvent String String])- handle "setTime" _ = do- time <- getCurrentTime- pure (const $ Just time, [])- handle _ state = pure (const state, [])-- component = timeHandler (startClock display)-- let- run1 = prepareTree component- run2 = prepareTree (fst run1)- run3 = prepareTree (fst run2)-- length (snd run1) `shouldBe` 1- length (snd run2) `shouldBe` 0- length (snd run3) `shouldBe` 0 -- for a bug where it was resetting run-- it "assigns a location to handlers" $ do- let- timeHandler = effectHandler Nothing handle-- handle :: String -> Maybe UTCTime -> IO (Maybe UTCTime -> Maybe UTCTime, [DirectedEvent String String])- handle "setTime" _ = do- time <- getCurrentTime- pure (const $ Just time, [])- handle _ state = pure (const state, [])-- component = timeHandler (const (Text ""))-- component `shouldBe` Hide (EffectHandler Nothing Nothing Nothing handle (const (Text "")))-- let- graphWithLocation = fst (prepareTree component)-- graphWithLocation `shouldBe` Hide (EffectHandler (Just []) (Just []) Nothing handle (const (Text "")))-- it "assigns a different location to child handlers" $ do- let- timeHandler = effectHandler Nothing handle-- handle :: String -> Maybe UTCTime -> IO (Maybe UTCTime -> Maybe UTCTime, [DirectedEvent String String])- handle "setTime" _ = do- time <- getCurrentTime- pure (const $ Just time, [])- handle _ state = pure (const state, [])-- component = div- [ timeHandler (const (Text ""))- , timeHandler (const (Text ""))- ]-- graphWithLocation = fst (prepareTree component)-- show graphWithLocation- `shouldBe`- "div [ Hide EffectHandler Just [] Just [0] \"null\" \"\" Hide EffectHandler Just [] Just [1] \"null\" \"\" ] "-- it "assigns a different location to nested handlers" $ do- let- timeHandler = effectHandler Nothing handle-- handle :: String -> Maybe UTCTime -> IO (Maybe UTCTime -> Maybe UTCTime, [DirectedEvent String String])- handle "setTime" _ = do- time <- getCurrentTime- pure (const $ Just time, [])- handle _ state = pure (const state, [])-- component =- timeHandler (const (timeHandler (const (Text ""))))--- graphWithLocation = fst (prepareTree component)-- show graphWithLocation `shouldBe` "Hide EffectHandler Just [] Just [] \"null\" Hide EffectHandler Just [] Just [0] \"null\" \"\""---main :: IO ()-main = hspec spec
src/Purview.hs view
@@ -1,15 +1,18 @@-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DuplicateRecordFields #-} {-| -Purview aims to be pretty straightforward to work with. As an example,-here's a counter that we'll then go through.+Purview follows the usual pattern of action -> state -> state, with+events flowing up from event producers to handlers where they are+captured. State is passed from handler to the continuation. +Here's a quick example with a counter:+ > module Main where > > import Purview+> import Purview.Server (serve, defaultConfiguration) > > incrementButton = onClick "increment" $ button [ text "+" ] > decrementButton = onClick "decrement" $ button [ text "-" ]@@ -20,32 +23,20 @@ > , decrementButton > ] >-> handler :: (Integer -> Purview String any IO) -> Purview () any IO-> handler = simpleHandler (0 :: Integer) reducer+> handler :: (Integer -> Purview event m) -> Purview event m+> handler = handler' [] (0 :: Integer) reducer >-> reducer action state = case action of-> "increment" -> state + 1-> "decrement" -> state - 1+> reducer event state = case event of+> "increment" -> (state + 1, [])+> "decrement" -> (state - 1, []) >-> top = handler view+> component' = handler view >-> main = run defaultConfiguration { component=top, devMode=True }--First we define two buttons, each which have action producers ('onClick').--When rendered, this tells Purview that when either is clicked it'd like to receive-a message ('increment' or 'decrement').--Then we define a handler, which takes an initial state ("0"), and a reducer.--The reducer defines how we're supposed to handle the events received, and it passes-down the new state to components.--Then we put it together ("handler view"), and run it.+> main = serve defaultConfiguration { component=component', devMode=True } Note the "devMode=True": this tells Purview to send the whole-tree over again when the websocket reconnects. This is really handy-if you're re-running the server in ghci, although I really recommend+tree over again when the websocket reconnects. This is handy+if you're re-running the server in ghci, although I recommend using ghcid so you can do: > ghcid --command 'stack ghci yourProject/Main.hs' --test :main@@ -58,21 +49,60 @@ -} module Purview- (- -- ** Server- run- , Configuration (..)- , defaultConfiguration- -- ** Handlers- -- | These are how you can catch events sent from things like 'onClick' and- -- change state, or in the case of 'effectHandler', make API requests or call- -- functions from your project.- , simpleHandler- , messageHandler+ {-|+These are how you can catch events sent from things like 'onClick' and+change state, or in the case of 'effectHandler', make API requests or call+functions from your project.++In addition they can send events to themself, to a parent, call a+function in the browser, or all three.++Note because of the typeable constraints Haskell will yell at you until+it knows the types of the event and state.+ -}+ ( handler , effectHandler+ , handler'+ , effectHandler' - -- ** HTML helpers+ -- ** Styling+ , style+ , istyle++ -- ** HTML+ {-|+These are some of the more common HTML nodes and some attributes to get you+started, but you'll want to create your own as well. Here's how:++__Examples:__++If you wanted to create a <code> node:++@+import Purview ( Purview( Html ), text )++code :: [Purview event m] -> Purview event m+code = Html "code"++helloCode :: Purview event m+helloCode = code [ text "it's some code" ]+-- renders as <code>it's some code</code>+@++If you wanted to create a new attribute for adding test-ids to nodes:++@+import Purview ( Purview( Attribute ), Attributes( Generic ), button, text )++testId :: String -> Purview event m -> Purview event m+testId = Attribute . Generic "test-id"++testableButton :: Purview event m+testableButton = testId "cool-button" $ button [ text "testable!" ]+-- renders as <button test-id="cool-button">testable!</button>+@+ -} , div , span , p@@ -82,140 +112,112 @@ , h4 , text , button+ , a+ , ul+ , li , form , input- , style+ , href+ , id'+ , class' - -- ** Action producers- , onClick- , onSubmit+ -- ** Events+ {-|+Event creators work similar to attributes in that they are bound to+the eventual concrete HTML. When triggered they create an event+that flows up to a handler. They can have a value, in which case+you'll need to provide a function to transform that value into+an event your handler can handle. - -- ** For Testing- , render+To create your own: - -- ** AST- , Attributes (..)- , DirectedEvent (..)- , Purview (..)- )-where+__Examples:__ -import Prelude hiding (div, log, span)-import qualified Web.Scotty as Sc-import Data.Text (pack, Text, all)-import qualified Data.Text.Lazy as LazyText-import qualified Network.Wai.Middleware.Gzip as Sc-import qualified Network.Wai.Handler.WebSockets as WaiWebSocket-import qualified Network.WebSockets as WebSocket-import qualified Network.Wai as Wai-import qualified Network.Wai.Handler.Warp as Warp-import Data.Aeson+To add an event creator for keydown: -import Control.Monad (when)-import Control.Concurrent.STM.TChan-import Control.Monad.STM-import Control.Concurrent+@+import Purview ( Purview( Attribute ), Attributes( On ) )+import Data.Typeable -import Component-import EventLoop-import Events-import PrepareTree-import Rendering-import Wrapper-import Network.Wai.Middleware.RequestLogger (mkRequestLogger)+onKeyDown+ :: ( Typeable event+ , Eq event+ , Show event+ )+ => (Maybe String -> event) -> Purview event m -> Purview event m+onKeyDown = Attribute . On "keydown" Nothing+@ -type Log m = String -> m ()+In addition to this, you'll need to add "keydown" to the list of events+listened for in the configuration at the top like so: -data Configuration parentAction action m = Configuration- { component :: Purview parentAction action m- -- ^ The top level component to put on the page.- , interpreter :: m [Event] -> IO [Event]- -- ^ How to run your algebraic effects or other. This will apply to all `effectHandler`s.- , logger :: String -> IO ()- -- ^ Specify what to do with logs- , htmlEventHandlers :: [HtmlEventHandler]- -- ^ For extending the handled events. Have a look at 'defaultConfiguration' to see- -- how to make your own.- , htmlHead :: Text- -- ^ This is placed directly into the \<head\>, so that you can link to external- -- CSS etc- , devMode :: Bool- -- ^ When enabled, Purview will send the whole tree on websocket reconnection.- -- This enables you to use- -- "ghcid --command 'stack ghci examples/Main.hs' --test :main`"- -- to restart the server on file change, and get a kind of live reloading- }+@+import Purview.Server (defaultConfiguration, serve, Configuration( eventsToListenTo )) -defaultConfiguration :: Configuration parentAction action IO-defaultConfiguration = Configuration- { component = div []- , interpreter = id- , logger = print- , htmlEventHandlers = [clickEventHandler, submitEventHandler]- , htmlHead = ""- , devMode = False- }+newConfig =+ let events = eventsToListenTo defaultConfiguration+ in defaultConfiguration { eventsToListenTo="keydown":events } -{-|+main = serve newConfig $ const $ div []+@ -This starts up the Scotty server. As a tiny example, to display some text saying "hello":+This is hopefully short-lived and going away in a coming version.+ -}+ , onClick+ , onSubmit+ , onBlur+ , onChange -> import Purview->-> view = p [ text "hello" ]->-> main = run defaultConfiguration { component=view }+ -- ** Interop+ {-|+While the receiver covers receiving events, here's how you can call javascript+functions: --}-run :: Monad m => Configuration () any m -> IO ()-run Configuration { devMode, component, logger, interpreter, htmlEventHandlers, htmlHead } = do- let port = 8001- let settings = Warp.setPort port Warp.defaultSettings- requestHandler' <- requestHandler component htmlHead htmlEventHandlers- Warp.runSettings settings- $ WaiWebSocket.websocketsOr- WebSocket.defaultConnectionOptions- (webSocketHandler devMode interpreter logger component)- requestHandler'+__Example:__ -requestHandler :: Purview parentAction action m -> Text -> [HtmlEventHandler] -> IO Wai.Application-requestHandler routes htmlHead htmlEventHandlers =- Sc.scottyApp $ do- Sc.middleware $ Sc.gzip $ Sc.def { Sc.gzipFiles = Sc.GzipCompress }+Here whenever "increment" is received by the handler, it produces a new+Browser event. This calls window.addMessage in the browser, with an+argument of the "show newState" -- so, a String. - Sc.get "/"- $ Sc.html- $ LazyText.fromStrict- $ wrapHtml htmlHead htmlEventHandlers- $ Data.Text.pack- $ render . fst- $ prepareTree routes+@+countHandler = handler' [] (0 :: Int) reducer+ where+ reducer "increment" state =+ let newState = state + 1+ -- this being the important bit, you can call any function in javascript+ -- with the Brower fnName value event.+ in (newState, [Browser "addMessage" (show newState)]) -webSocketMessageHandler :: TChan Event -> WebSocket.Connection -> IO ()-webSocketMessageHandler eventBus websocketConnection = do- message' <- WebSocket.receiveData websocketConnection+jsMessageAdder = [r|+ const addMessage = (value) => {+ const messagesBlock = document.querySelector("#messages");+ messagesBlock.innerHTML = value;+ }+ -- important, otherwise it won't be able to find the function+ window.addMessage = addMessage;+|] - case decode message' of- Just fromEvent -> atomically $ writeTChan eventBus fromEvent- Nothing -> pure ()+main = serve (defaultConfiguration { javascript=jsMessageAdder }+@ - webSocketMessageHandler eventBus websocketConnection+ -}+ , receiver -webSocketHandler- :: Monad m- => Bool- -> (m [Event] -> IO [Event])- -> Log IO- -> Purview parentAction action m- -> WebSocket.ServerApp-webSocketHandler devMode runner log component pending = do- when devMode $ putStrLn "ws connected"- conn <- WebSocket.acceptRequest pending+ -- ** Testing+ , render - eventBus <- newTChanIO+ -- ** AST+ , Attributes (..)+ , DirectedEvent (..)+ , Purview (..)+ )+where - atomically $ writeTChan eventBus $ Event { event = "init", message = "init", location = Nothing }+import Prelude hiding (div, log, span) - WebSocket.withPingThread conn 30 (pure ()) $ do- _ <- forkIO $ webSocketMessageHandler eventBus conn- eventLoop devMode runner log eventBus conn component+import Style (style)+import Component (Purview (Attribute, Html), Attributes(..))+import ComponentHelpers+import Events+import Rendering+import Configuration
+ src/Purview/Server.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Purview.Server+ ( serve+ , Configuration (..)+ , defaultConfiguration+ , renderFullPage+ , startWebSocketLoop+ )+where++import qualified Network.Wai.Handler.Warp as Warp+import qualified Network.Wai as Wai+import qualified Network.WebSockets as WebSocket+import qualified Network.Wai.Handler.WebSockets as WaiWebSocket+import Network.HTTP.Types ( status200 )+import qualified Data.ByteString.Char8 as ByteString+import Data.ByteString.Builder.Internal+import qualified Data.Text as Text+import Data.Typeable+import Control.Concurrent.STM.TChan+import Control.Monad.STM+import Control.Concurrent+import Data.Aeson+import Blaze.ByteString.Builder.Char.Utf8++import Component+import EventLoop+import Events+import PrepareTree+import Rendering+import Wrapper+import CollectInitials+import CleanTree+import Configuration++defaultConfiguration :: Configuration IO+defaultConfiguration = Configuration+ { interpreter = id+ , logger = putStrLn+ , eventsToListenTo = [ "click", "focusout", "focusin", "change", "submit" ]+ , htmlHead = ""+ , devMode = False+ , javascript = ""+ , port = 8001+ , secure = False+ }++{-|++This starts up the Warp server.++__Example:__++@+import Purview.Server++view url = p [ text "hello world" ]++main = serve defaultConfiguration view+@++-}+serve :: Monad m => Configuration m -> (String -> Purview () m) -> IO ()+serve config@Configuration{ port, logger } component =+ let+ settings = Warp.setPort port Warp.defaultSettings+ in do+ logger $ "Starting on port " <> show port++ Warp.runSettings settings+ $ WaiWebSocket.websocketsOr+ WebSocket.defaultConnectionOptions+ (webSocketHandler config component)+ (httpHandler config component)++webSocketHandler+ :: Monad m+ => Configuration m+ -> (String -> Purview () m)+ -> WebSocket.PendingConnection -> IO ()+webSocketHandler config component pendingConnection = do+ let+ path = ByteString.unpack+ $ WebSocket.requestPath (WebSocket.pendingRequest pendingConnection)+ render = component path++ connection <- WebSocket.acceptRequest pendingConnection+ startWebSocketLoop config { devMode=True } render connection++httpHandler :: Configuration m -> (String -> Purview () m) -> Wai.Application+httpHandler config component request respond =+ let+ path = Text.unpack . Text.concat $ Wai.pathInfo request+ render = component $ "/" <> path+ in+ respond+ $ Wai.responseBuilder+ status200+ [("Content-Type", "text/html")]+ (renderFullPage config render)++renderFullPage :: Typeable action => Configuration m -> Purview action m -> Builder+renderFullPage Configuration { htmlHead, eventsToListenTo, javascript, secure } component =+ let+ locatedComponent = prepareTree component+ (initialEvents, css) = collectInitials locatedComponent+ rendered = render (cleanTree css locatedComponent)+ wrap = wrapHtml css htmlHead eventsToListenTo javascript secure+ in+ fromString $ wrap rendered++startWebSocketLoop+ :: (Monad m, Typeable action)+ => Configuration m+ -> Purview action m+ -> WebSocket.Connection+ -> IO ()+startWebSocketLoop Configuration { devMode, interpreter, logger } component connection = do+ eventBus <- newTChanIO++ atomically+ $ writeTChan eventBus+ $ FromFrontendEvent { kind = "init", childLocation = Nothing, location = Nothing, value = Nothing }++ WebSocket.withPingThread connection 30 (pure ()) $ do+ _ <- forkIO $ webSocketMessageHandler eventBus connection+ eventLoop devMode interpreter logger eventBus connection component++webSocketMessageHandler :: TChan Event -> WebSocket.Connection -> IO ()+webSocketMessageHandler eventBus websocketConnection = do+ message' <- WebSocket.receiveData websocketConnection++ case decode message' of+ Just fromEvent -> atomically $ writeTChan eventBus fromEvent+ Nothing -> do+ print $ "error: failed to decode event: " <> message'+ print "this may be an error in Purview so feel free to open an issue"+ pure ()++ webSocketMessageHandler eventBus websocketConnection
− src/PurviewSpec.hs
@@ -1,44 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module PurviewSpec where--import Prelude hiding (div)-import Test.Hspec-import Purview--upButton :: Purview parentAction String m-upButton = onClick ("up" :: String) $ div [ text "up" ]--downButton :: Purview parentAction String m-downButton = onClick ("down" :: String) $ div [ text "down" ]--handler :: Applicative m => (Int -> Purview String action m) -> Purview String action m-handler = simpleHandler 0 action- where- action :: String -> Int -> Int- action "up" _ = 1- action _ _ = 0---- counter :: Show a => a -> Purview parentAction action m-counter state = div- [ upButton- , text $ "count: " <> show state- , downButton- ]--component :: Applicative m => Purview String String m-component = handler counter--event' :: String-event' = "{\"event\":\"click\",\"message\":\"up\"}"--spec :: SpecWith ()-spec = parallel $ do- describe "applying events" $ do- it "works with the event directly" $ do--- let applied = handleEvent event' component------ render [] applied `shouldNotBe` render [] component- (1 :: Integer) `shouldBe` 1--main :: IO ()-main = hspec spec
src/Rendering.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE NamedFieldPuns #-} module Rendering where import Data.Aeson@@ -7,21 +8,35 @@ import Component isOn :: Attributes a -> Bool-isOn (On _ _) = True-isOn _ = False+isOn (On _ _ _) = True+isOn _ = False isGeneric :: Attributes a -> Bool isGeneric (Generic _ _) = True-isGeneric _ = False+isGeneric _ = False +isClass :: Attributes a -> Bool+isClass (Generic "class" _) = True+isClass _ = False+ getStyle :: Attributes a -> String-getStyle (Style style') = style'-getStyle _ = ""+getStyle (Style (hash, style')) =+ -- inline styles are just given a hash of -1+ if hash == "-1" then style' else ""+getStyle _ = "" +getClassBasedStyle :: Attributes a -> String+getClassBasedStyle (Style (hash, style')) =+ -- earlier we set the style' to "" to say it's been captured+ -- also filter out things like "p123 li", which are created+ -- by nested rules in [style||] templates+ if style' == "" && not (' ' `elem` hash) then hash else ""+getClassBasedStyle _ = ""+ renderGeneric :: Attributes a -> String renderGeneric attr = case attr of (Generic name value) -> " " <> name <> "=" <> unpack (encode value)- _ -> ""+ _ -> "" renderAttributes :: [Attributes a] -> String renderAttributes attrs =@@ -29,15 +44,26 @@ styles = concatMap getStyle attrs renderedStyle = if not (null styles) then " style=" <> show styles else "" + -- TODO: this is uggo+ classStyles = filter (not . null) $ fmap getClassBasedStyle attrs+ existingClasses = (\(Generic _ name) -> name) <$> filter isClass attrs+ combinedClasses = classStyles <> existingClasses++ renderedClasses =+ if not (null combinedClasses)+ then " class=\"" <> unwords combinedClasses <> "\""+ else ""+ listeners = filter isOn attrs renderedListeners = concatMap- (\(On name action) -> " action=" <> (unpack $ encode action))+ (\(On name ident action) -> " " <> name <> "-location=" <> unpack (encode ident)) listeners+ noticeToBind = if null listeners then "" else " bubbling-bound" - generics = filter isGeneric attrs+ generics = filter (not . isClass) $ filter isGeneric attrs renderedGenerics = concatMap renderGeneric generics in- renderedStyle <> renderedListeners <> renderedGenerics+ renderedStyle <> noticeToBind <> renderedListeners <> renderedGenerics <> renderedClasses {-| @@ -46,10 +72,10 @@ -} -render :: Purview parentAction action m -> String+render :: Purview action m -> String render = render' [] -render' :: [Attributes action] -> Purview parentAction action m -> String+render' :: [Attributes action] -> Purview action m -> String render' attrs tree = case tree of Html kind rest -> "<" <> kind <> renderAttributes attrs <> ">"@@ -59,16 +85,26 @@ Text val -> val Attribute attr rest ->+ -- collecting all the attributes till we hit html render' (attr:attrs) rest - EffectHandler parentLocation location state _ cont ->+ EffectHandler parentLocation location initEvents state _ cont -> "<div handler=" <> (show . encode) location <> ">" <> render' attrs (unsafeCoerce cont state) <> "</div>" - Once _ _hasRun cont ->- render' attrs cont+ Handler { identifier, state, continuation } ->+ "<div handler=" <> (show . encode) identifier <> ">" <>+ render' attrs (unsafeCoerce continuation state) <>+ "</div>" - Value a -> show a+ Receiver { parentIdentifier, identifier, name, child, state } ->+ "<div" <>+ " handler=" <> (show . encode) identifier <>+ " parent-handler=" <> (show . encode) parentIdentifier <>+ " receiver-name=\"" <> name <> "\"" <>+ ">" <>+ render' attrs (child state) <>+ "</div>" - Hide a -> render' attrs (unsafeCoerce a)+ Value a -> show a
− src/RenderingSpec.hs
@@ -1,98 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module RenderingSpec where--import Prelude hiding (div)-import Data.Aeson.TH-import Test.Hspec-import Test.Hspec.QuickCheck-import Test.QuickCheck hiding (classes, once)--import TreeGenerator-import Component-import Events-import Rendering--data SingleConstructor = SingleConstructor--$(deriveJSON (defaultOptions{tagSingleConstructors=True}) ''SingleConstructor)---spec :: SpecWith ()-spec = parallel $ do-- describe "render" $ do-- it "can render an assortment of different trees" $- property $ \x -> render (x :: Purview String String IO) `shouldContain` "always present"-- it "can create a div" $ do- let element = Html "div" [Text "hello world"]-- render element `shouldBe` "<div>hello world</div>"-- it "can add an onclick" $ do- let element =- Attribute (On "click" (1 :: Integer))- $ Html "div" [Text "hello world"]-- render element `shouldBe`- "<div action=1>hello world</div>"-- it "can add an id" $ do- let element = identifier "hello" $ div [text "it's a hello div"]- render element `shouldBe` "<div id=\"hello\">it's a hello div</div>"-- it "can add one class" $ do- let element =- classes ["class1"] $ div [text "it's a hello div"]- render element `shouldBe` "<div class=\"class1\">it's a hello div</div>"-- it "can add classes" $ do- let element =- classes ["class1", "class2", "class3"] $ div [text "it's a hello div"]- render element `shouldBe` "<div class=\"class1 class2 class3\">it's a hello div</div>"-- it "can render classes and ids at the same time" $ do- let element =- classes ["class1", "class2", "class3"]- $ identifier "hello"- $ div [text "it's a hello div"]- render element `shouldBe` "<div id=\"hello\" class=\"class1 class2 class3\">it's a hello div</div>"-- it "can render a form" $ do- let- named = Attribute . Generic "name"- input = Html "input"- form = Html "form"- component = onSubmit ("initialValue" :: String) $ form [ named "name" $ input [] ]-- render component- `shouldBe`- "<form action=\"initialValue\"><input name=\"name\"></input></form>"-- it "can render a typed action" $ do- let element = onClick SingleConstructor $ div [ text "click" ]-- render element- `shouldBe`- "<div action=\"SingleConstructor\">click</div>"-- it "can render a style" $ do- let element = style "color: blue;" $ div [ text "blue" ]-- render element- `shouldBe`- "<div style=\"color: blue;\">blue</div>"-- it "can render composed styles" $ do- let blue = style "color: blue;"- halfSize = style "width: 50%; height: 50%;"-- render (blue . halfSize $ div [ text "box" ])- `shouldBe`- "<div style=\"width: 50%; height: 50%;color: blue;\">box</div>"----main :: IO ()-main = hspec spec
− src/Spec.hs
@@ -1,1 +0,0 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}
+ src/Style.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++-- |+module Style+ ( style+ , handleCSS+ , parseLine+ , parseCSS+ , Brace (..)+ )+where++import Language.Haskell.TH+import Language.Haskell.TH.Quote++import Data.Text (pack, unpack, replace)+import Data.Bits+import Data.List++import Component (Attributes ( Style ), Purview ( Attribute ))++-- thanks https://stackoverflow.com/questions/59399050/haskell-making-quasi-quoted-values-strict-evaluated-at-compile-time++{-|+Components styled with this QuasiQuoter will have a class added+to them and the CSS added to the stylesheet. Basic support is+provided for easily styling nested components and for pseudo+selectors.++__Examples:__++Styling a button:++@+blue = [style|+ background-color: blue;+|]++blueButton = blue $ button []+@++Styling a list with a pseudo selector to get the right cursor on hover:++@+listStyle = [style|+ width: 250px;+ li {+ padding: 25px;+ &:hover {+ cursor: pointer;+ }+ }+|]++list = listStyle $ ul [ li [ text "an item" ] ]+@+-}+style :: QuasiQuoter+style = QuasiQuoter+ { quoteDec = error "quoteDec not implemented"+ , quoteType = error "quoteType not implemented"+ , quotePat = error "quotePat not implemented"+ , quoteExp = style'+ }++{-++This is all kind of a mess and could definitely use some love. I don't think+it's quite doing what is wanted, looking at the dumped splices, as ideally+that would be a list of Attributes instead of a call to a function. I ran+into implementing Lift for Purview -> Purview, for the attributes, and this+at least works.++If it catches anyone's eye by all means rewrite it++-}+clean :: String -> String+clean [] = ""+clean ('\n':rest) = clean rest+clean (';':rest) = ';':clean (dropWhile (flip elem [' ', '\n']) rest)+clean (c:rest) = c:clean rest++data Brace = Open | Close | None+ deriving (Show, Eq)++-- Takes a chunk of CSS and returns a line, the remainder to parse, and if+-- it contains an opening brace+parseLine' :: (String, String) -> (Brace, String, String)+parseLine' (line, '\n':rest) = parseLine' (line, rest)+parseLine' (line, ';':rest) = (None, line <> [';'], rest)+parseLine' (line, '{':rest) = (Open, line <> ['{'], rest)+parseLine' (line, '}':rest) = (Close, line <> ['{'], rest)+parseLine' (line, c:rest) = parseLine' (line <> [c], rest)+parseLine' (line, "") = (None, line, "")++preParseLine :: String -> String+preParseLine = dropWhile (flip elem [' ', '\n'])++parseLine css =+ let cleaned = preParseLine css+ in parseLine' ("", cleaned)++parseNewLevel = takeWhile (/= '{')++parseCSS :: [String] -> String -> [(String, String)]+parseCSS _ "" = []+parseCSS path css =+ let (brace, line, remaining) = parseLine css+ in case brace of+ Open -> parseCSS (path <> [parseNewLevel line]) remaining+ Close -> parseCSS (take (length path - 1) path) remaining+ None ->+ if null line+ then []+ else (concat path, line) : parseCSS path remaining++joinOnClass :: [(String, String)] -> (String, String)+joinOnClass cs@((name, _):_) = (name, concatMap snd cs)+joinOnClass [] = ("", "")++handleCSS :: String -> [(String, String)]+handleCSS css =+ fmap joinOnClass $ groupBy (\a b -> fst a == fst b) $ sortOn fst $ parseCSS [] css++-- for handling top level pseudos+handlePseudo hash ('&':newClass) =+ hash <> newClass+-- for the nested pseudos+handlePseudo hash newClass =+ hash <> " " <> (unpack $ replace " &:" ":" (pack newClass))++combineClasses hash newClass =+ if '&' `elem` newClass+ then handlePseudo hash newClass+ else hash <> " " <> newClass++toAttributes :: String -> String -> (Purview event m -> Purview event m)+toAttributes hashed css =+ let ((_, baseCss):rest) = handleCSS css+ in foldr+ (\(newClass, newCss) acc ->+ acc . Attribute (Style (combineClasses hashed newClass, newCss))+ )+ (Attribute (Style (hashed, baseCss))) rest++style' :: String -> Q Exp+style' css =+ -- pretty funny, css needs a leading character (not number)+ let+ hashed = 'p' : show (hash css)+ in [| toAttributes hashed css |]++-- snagged from https://stackoverflow.com/a/9263004/1361890+hash :: String -> Int+hash = foldl' (\h c -> 33 * h `xor` fromEnum c) 5381
− src/TreeGenerator.hs
@@ -1,40 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-module TreeGenerator where--import Prelude hiding (div)-import Test.Hspec-import Test.QuickCheck hiding (once)-import Control.Monad.IO.Class--import Component-import Events--{---This is a helper to generate semi random purview trees-for tests, and to make sure everything can be combined-nicely.---}--testHandler :: (String -> Purview String action IO) -> Purview String action IO-testHandler = effectHandler ("" :: String) reducer- where- reducer :: String -> String -> IO (String -> String, [DirectedEvent String String])- reducer action state = pure (const "", [])--testOnce = once (\send -> send "")--sizedArbExpr :: Int -> Gen (Purview String String IO)-sizedArbExpr 0 = do pure $ text "always present"-sizedArbExpr n = do- es <- vectorOf 2 (sizedArbExpr (n-1))- elements- [ div es- , style "" $ div es- , testHandler (const $ div es)- , testOnce (div es)- ]--instance Arbitrary (Purview String String IO) where- arbitrary = resize 3 $ sized sizedArbExpr
src/Wrapper.hs view
@@ -3,104 +3,147 @@ module Wrapper where import Text.RawString.QQ (r)-import Data.Text (Text) -data HtmlEventHandler = HtmlEventHandler- { eventType :: Text -- eg submit or click- , functionName :: Text -- called whenever the event happens- , handlingFunction :: Text -- receives the event and sends the event over the websocket- }+{- -clickEventHandlingFunction :: Text-clickEventHandlingFunction = [r|- function handleClickEvents(event) {- event.stopPropagation();+Loosely, for each type of event, check if it has a "clickLocation" "blurLocation" etc+Each event would have its own location and if it doesn't, send nothing - var clickValue;- try {- clickValue = JSON.parse(event.target.getAttribute("action"));- } catch (error) {- // if the action is just a string, parsing it as JSON would fail- clickValue = event.target.getAttribute("action");- }- var location = JSON.parse(event.currentTarget.getAttribute("handler"))+I think that actually does it? - if (clickValue) {- window.ws.send(JSON.stringify({ "event": "click", "message": clickValue, "location": location }));- }- }-|]+Might also want to move to using "clickId" etc, if you want to. -clickEventHandler :: HtmlEventHandler-clickEventHandler = HtmlEventHandler "click" "handleClickEvents" clickEventHandlingFunction+-} -submitEventHandlingFunction :: Text-submitEventHandlingFunction = [r|- function handleFormEvents(event) {- event.preventDefault();+eventHandlerFn :: String+eventHandlerFn = [r|+ function eventHandler(event) { event.stopPropagation(); - var form = new FormData(event.target);- var entries = Object.fromEntries(form.entries());- var location = JSON.parse(event.currentTarget.getAttribute("handler"))+ const type = event.type;+ // ie "click-location" or "blur-location"+ const locationCheck = `${type}-location`; - if (entries) {- window.ws.send(JSON.stringify({ "event": "submit", "message": entries, "location": location }));+ const possibleLocation = event.target.getAttribute(locationCheck);++ if (possibleLocation) {+ const childLocation = JSON.parse(possibleLocation)++ if (type === "submit") {+ event.preventDefault();++ var form = new FormData(event.target);+ var entries = JSON.stringify(Object.fromEntries(form.entries()));+ var location = JSON.parse(event.currentTarget.getAttribute("handler"));++ window.ws.send(JSON.stringify({+ "event": "submit",+ "value": entries,+ "childLocation": childLocation,+ "location": location+ }));+ } else {+ var value = event.target.value;+ var location = JSON.parse(event.currentTarget.getAttribute("handler"))++ var wrappedValue = typeof value === 'string' ? value : `${value}`;++ window.ws.send(JSON.stringify({+ "event": type,+ "value": wrappedValue,+ "childLocation": childLocation,+ "location": location+ }));+ } } } |] -submitEventHandler :: HtmlEventHandler-submitEventHandler = HtmlEventHandler "submit" "handleFormEvents" submitEventHandlingFunction+bindEventsFn :: String+bindEventsFn = [r|+ function bindEvents() {+ document.querySelectorAll("[handler]").forEach(item => {+ if (!item.getAttribute("bound")) {+ events.map(event => {+ item.addEventListener(event, eventHandler)+ })+ item.setAttribute("bound", "true")+ }+ })+ }+|] -defaultHtmlEventHandlers :: [HtmlEventHandler]-defaultHtmlEventHandlers =- [ clickEventHandler- , submitEventHandler- ]+eventHandling :: [String] -> String+eventHandling eventsList =+ let eventsToWatch = "const events = " <> show eventsList+ in eventsToWatch <> "\n" <> eventHandlerFn <> "\n" <> bindEventsFn -mkBinding :: HtmlEventHandler -> Text-mkBinding (HtmlEventHandler kind functionName _) =- "item.removeEventListener(\"" <> kind <> "\", " <> functionName <> ");"- <> "item.addEventListener(\"" <> kind <> "\", " <> functionName <> ");"+{- -mkFunction :: HtmlEventHandler -> Text-mkFunction (HtmlEventHandler _ _ function) = function+This is so that event locations are added as events bubble past,+reflecting how you'd expect them to work. -bindEvents :: [HtmlEventHandler] -> Text-bindEvents htmlEventHandlers =- let bindings = foldr (<>) "" $ fmap mkBinding htmlEventHandlers- functions = foldr (<>) "" $ fmap mkFunction htmlEventHandlers- in- functions- <> "function bindEvents() {"- <> "document.querySelectorAll(\"[handler]\").forEach(item => {"- <> bindings- <> "});"- <> "};"+Without this, for example, click events on a div beneath the one+with the click-location would be ignored. -websocketScript :: Text-websocketScript = [r|+-}+eventBubblingHandling :: String+eventBubblingHandling = [r|+ function bindLocationEnrichment() {+ document.querySelectorAll("[bubbling-bound]").forEach(item => {+ const alreadyBound = item.getAttribute('bubbling-bound')++ if (!alreadyBound) {+ events.map(event => {+ const eventLocation = item.getAttribute(`${event}-location`)++ if (eventLocation) {+ item.addEventListener(event, eventFromDOM => {+ eventFromDOM.target.setAttribute(`${event}-location`, eventLocation)+ })+ }+ })+ item.setAttribute('bubbling-bound', true)+ }+ })+ }+|]++websocketScript :: Bool -> String+websocketScript secure =+ let connectionPath = if secure+ then "var ws = new WebSocket('wss://' + window.location.host + window.location.pathname);"+ else "var ws = new WebSocket('ws://' + window.location.host + window.location.pathname);"+ in+ connectionPath <> [r| var timeoutTime = -50; function connect() { timeoutTime += 50;- var ws = new WebSocket("ws://localhost:8001");+ // TODO: adding the current path is kind of a hack ws.onopen = () => {- ws.send("initial from js"); timeoutTime = 0; }; ws.onmessage = evt => { var m = evt.data;- console.log( m );- console.log(JSON.parse( m )); var event = JSON.parse(evt.data);+ if (event.event === "setHtml") { // cool enough for now event.message.map(command => setHtml(command)); bindEvents();+ bindLocationEnrichment();+ } else if (event.event === "callJS") {+ const [fnToCall, withValue] = event.message;+ window[fnToCall](withValue);+ } else if (event.event === "setCSS") {+ var sheet = window.document.styleSheets[0];+ event.message.map(cssRule => {+ const [name, css] = cssRule;+ sheet.insertRule('.' + name + '{ ' + css + ' }', sheet.cssRules.length);+ }) } }; @@ -132,16 +175,71 @@ const command = message.message; const [location, newHtml] = message.contents; const targetNode = getNode(location);- targetNode.outerHTML = newHtml;+ // hacky fix for https://github.com/purview-framework/purview/issues/123+ if (targetNode.tagName === "BODY") {+ targetNode.innerHTML = newHtml;+ } else {+ targetNode.outerHTML = newHtml;+ } } |] -wrapHtml :: Text -> [HtmlEventHandler] -> Text -> Text-wrapHtml htmlHead htmlEventHandlers body =- "<html>"+sendEventHelper :: String+sendEventHelper = [r|+ const sendEvent = (receiverName, value) => {+ const targets = document.querySelectorAll("[receiver-name=" + receiverName + "]")+ if (targets.length > 1) {+ console.error("too many")+ } else if (targets.length == 0) {+ console.error("none found")+ } else {+ var target = targets[0]+ var location = JSON.parse(target.getAttribute("parent-handler"))+ var childLocation = JSON.parse(target.getAttribute("handler"))++ window.ws.send(JSON.stringify({+ "event": "submit",+ "value": value,+ "childLocation": childLocation,+ "location": location+ }));+ }+ }+|]++prepareCss :: [(String, String)] -> String+prepareCss = concatMap (\(hash, css) -> "." <> hash <> " {" <> css <> "}\n")++wrapHtml+ :: [(String, String)]+ -> String+ -> [String]+ -> String+ -> Bool+ -> String+ -> String+wrapHtml css htmlHead eventsToListenTo javascript secure body =+ "<!DOCTYPE html>"+ <> "<html>" <> "<head>"- <> "<script>" <> websocketScript <> bindEvents htmlEventHandlers <> "bindEvents();" <> "</script>" <> htmlHead+ <> "<script>"+ <> websocketScript secure+ <> eventHandling eventsToListenTo+ <> eventBubblingHandling+ <> "</script>"+ <> "<script>"+ <> sendEventHelper+ <> "</script>"+ <> "<script>"+ <> javascript+ <> "</script>"+ <> "<style>"+ <> prepareCss css+ <> "</style>" <> "</head>"- <> "<body>"<> body <> "</body>"+ <> "<body>"+ <> body+ <> "<script>bindEvents(); bindLocationEnrichment();</script>"+ <> "</body>" <> "</html>"
+ test/ComponentSpec.hs view
@@ -0,0 +1,17 @@+module ComponentSpec where++import Test.Hspec++import Component++spec :: SpecWith ()+spec = parallel $ do++ describe "placeholder" $ do++ it "holds a place" $ do+ 1 `shouldBe` 1+++main :: IO ()+main = hspec spec
+ test/DiffingSpec.hs view
@@ -0,0 +1,87 @@+module DiffingSpec where++import Prelude hiding (div)+import Test.Hspec++import PrepareTree+import Purview+import Component+import Diffing++type DefaultAction = DirectedEvent String String++spec :: SpecWith ()+spec = parallel $ do++ describe "diff" $ do++ it "creates an update for differing text" $ do+ let+ oldTree = div [ text "night" ]+ newTree = div [ text "morning" ]++ diff Nothing [] oldTree newTree `shouldBe` [Update [0] (text "morning")]++ it "can do a nested update" $ do+ let+ oldTree = div [ div [ text "night" ] ]+ newTree = div [ div [ text "morning" ] ]++ diff Nothing [] oldTree newTree `shouldBe` [Update [0, 0] (text "morning")]++ it "says to update the whole underlying tree on added div" $ do+ let+ oldTree = div [ text "night" ]+ newTree = div [ div [ text "morning" ] ]++ diff Nothing [] oldTree newTree `shouldBe` [Update [0] (div [ text "morning" ])]++ describe "message handlers" $ do++ it "diffs handler children if the state is different" $ do+ let+ handler1 :: (String -> Purview String IO) -> Purview String IO+ handler1 = handler [] "initial state" (\action state -> (const $ state <> action, [] :: [DefaultAction]))+ handler2 = handler [] "different state" (\action state -> (const $ state <> action, [] :: [DefaultAction]))+ oldTree = div [ handler1 (const (text "the original")) ]+ newTree = div [ handler2 (const (text "this is different")) ]++ diff Nothing [] oldTree newTree `shouldBe`+ [ Update [0] (handler2 (const (text "this is different"))) ]++ describe "effect handlers" $ do++ it "diffs handler children if the state is different" $ do+ let+ handler1 :: (String -> Purview String IO) -> Purview String IO+ handler1 = effectHandler [] "initial state" (\action state -> pure $ (const $ state <> action, ([] :: [DirectedEvent String String])))+ handler2 = effectHandler [] "different state" (\action state -> pure $ (const $ state <> action, ([] :: [DirectedEvent String String])))+ oldTree = div [ handler1 (const (text "the original")) ]+ newTree = div [ handler2 (const (text "this is different")) ]++ diff Nothing [] oldTree newTree `shouldBe`+ [ Update [0] (handler2 (const (text "this is different")))+ , Update [0, 0] (text "this is different")+ ]++ it "continues going down the tree even if the state is the same at the top" $ do+ let+ handler1 :: (String -> Purview String IO) -> Purview String IO+ handler1 = effectHandler [] "initial state" (\action state -> pure $ (const $ state <> action, ([] :: [DirectedEvent String String])))+ handler2 = effectHandler [] "different state" (\action state -> pure $ (const $ state <> action, ([] :: [DirectedEvent String String])))+ oldTree = prepareTree $ div [ handler1 . const $ handler1 (const (text "the original")) ]+ newTree = prepareTree $ div [ handler1 . const $ handler2 (const (text "this is different")) ]++ diff (Just [0, 0]) [] oldTree newTree `shouldBe`+ [ Update [0, 0] (EffectHandler+ (Just [0])+ (Just [0, 0])+ []+ "different state"+ (\action state -> pure $ (const $ state <> action, ([] :: [DirectedEvent String String])))+ (const (text "this is different")))+ ]+++main :: IO ()+main = hspec spec
+ test/EventHandlingSpec.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LambdaCase #-}+module EventHandlingSpec where++import Prelude hiding (div)+import Control.Concurrent.STM.TChan+import Control.Monad.STM (atomically)+import Control.Monad.IO.Class+import Test.Hspec.QuickCheck+import Test.Hspec+import Test.QuickCheck+import Data.Aeson+import Data.Aeson.TH++import TreeGenerator+import Component+import ComponentHelpers+import EventHandling+import Events+import PrepareTree+import Rendering++import Data.Typeable++type Id a = a -> a++data TestAction = Up | Down++$(deriveJSON defaultOptions ''TestAction)++data SingleConstructor = SingleConstructor++$(deriveJSON (defaultOptions{tagSingleConstructors=True}) ''SingleConstructor)++{-++Just to clean up tests a bit. I dunno if this approach would work to clean+up the main event loop as well, since it calls "runEvent" (re: applying the event)+in a non-forked fashioned. If you try void . forkIO you end up back in m a -> IO a+hell.++-}+-- apply :: MonadIO m => TChan Event -> Event -> Purview event m -> m (Purview event m)+-- apply eventBus newStateEvent@StateChangeEvent {} component =+-- pure $ applyNewState newStateEvent component+-- apply eventBus fromEvent@Event {event=eventKind} component =+-- case eventKind of+-- "newState" -> pure $ applyNewState fromEvent component+-- _ -> do+-- events <- runEvent fromEvent component+-- liftIO $ mapM_ (atomically . writeTChan eventBus) events+-- pure component++spec :: SpecWith ()+spec = parallel $ do++ describe "applyNewState" $ do+ it "applies new state at the top level" $ do+ let+ reducer "test" st = (1, [])+ reducer _ st = (0, [])++ clickHandler :: (Int -> Purview String IO) -> Purview () IO+ clickHandler = handler' [] 0 reducer++ component = prepareTree $ clickHandler $ \state -> div [ text (show state) ]++ event = StateChangeEvent (\state -> state + 1 :: Int) (Just [])++ appliedClickHandler :: (Int -> Purview String IO) -> Purview () IO+ appliedClickHandler = handler' [] 1 reducer++ applied = prepareTree $ appliedClickHandler $ \state -> div [ text (show state) ]++ -- state should now be 1+ applyNewState event component `shouldBe` applied++ it "applies new state at a lower level" $ do+ let+ reducer "test" st = (1, [])+ reducer _ st = (0, [])++ clickHandler :: (Int -> Purview String IO) -> Purview String IO+ clickHandler = handler' [] 0 reducer++ component = prepareTree $ clickHandler $ \_ -> clickHandler $ \_ -> div []++ event = StateChangeEvent (\state -> state + 1 :: Int) (Just [0])++ appliedClickHandler :: (Int -> Purview String IO) -> Purview String IO+ appliedClickHandler = handler' [] 1 reducer++ applied = prepareTree $ clickHandler $ \_ -> appliedClickHandler $ \_ -> div []++ -- state should now be 1+ applyNewState event component `shouldBe` applied+++ describe "runEvent" $ do+ it "applies an event at the top level" $ do+ let+ reducer "test" st = (1, [])+ reducer _ st = (0, [])++ clickHandler :: (Int -> Purview String IO) -> Purview () IO+ clickHandler = handler' [] (0 :: Int) reducer++ component = prepareTree $ clickHandler $ \state -> div [ text (show state) ]++ event = InternalEvent { event = "test" :: String, childId = Nothing, handlerId = Just [] }++ [stateChangeEvent] <- runEvent event component++ case stateChangeEvent of+ StateChangeEvent fn id -> case cast fn of+ Just fn' -> fn' (0 :: Int) `shouldBe` (1 :: Int)+ _ -> fail "state change fn wrong type"+ _ -> fail "didn't return a state change fn"++ it "applies an event to the lower level" $ do+ let+ reducerA "test" st = (1, [])+ reducerA _ st = (0, [])++ clickHandlerA :: (Int -> Purview String IO) -> Purview () IO+ clickHandlerA = handler' [] (0 :: Int) reducerA++ reducerB "test" st = (5, [])+ reducerB _ st = (6, [])++ clickHandlerB :: (Int -> Purview String IO) -> Purview String IO+ clickHandlerB = handler' [] (0 :: Int) reducerB++ component = prepareTree $ clickHandlerA $ \_ -> clickHandlerB $ \_ -> div []++ event = InternalEvent { event = "test" :: String, childId = Nothing, handlerId = Just [0] }++ [stateChangeEvent] <- runEvent event component++ case stateChangeEvent of+ StateChangeEvent fn id -> case cast fn of+ Just fn' -> fn' (0 :: Int) `shouldBe` (5 :: Int)+ _ -> fail "state change fn wrong type"+ _ -> fail "didn't return a state change fn"+++ describe "findEvent" $ do+ it "works" $ do+ let+ reducer "test" st = (const 1, [])+ reducer _ st = (const 0, [])++ clickHandler :: (Int -> Purview String IO) -> Purview () IO+ clickHandler = handler [] (0 :: Int) reducer++ tree = clickHandler $ const $ div [ onClick "test" $ div [ text "up" ] ]+ treeWithLocations = prepareTree tree++ -- EffectHandler Just [] Just [] "0" div [ Attr On "click" Just [0,0] div [ "up" ] ]+ event' = FromFrontendEvent { kind="click", childLocation=Just [0, 0], location=Just [], value=Nothing }++ findEvent event' treeWithLocations+ `shouldBe`+ Just (InternalEvent ("test" :: String) (Just [0, 0]) (Just []))++main :: IO ()+main = hspec spec
+ test/EventsSpec.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE OverloadedStrings #-}+module EventsSpec where++import Test.Hspec+import Data.Aeson++import Events+import Data.Maybe (isNothing)+++spec :: SpecWith ()+spec = parallel $ do++ describe "parsing events" $ do+ it "parses a FrontEndEvent with a value of nothing" $ do+ decode "{ \"event\": \"click\", \"childLocation\": null, \"location\": null }"+ `shouldBe`+ Just (FromFrontendEvent { kind="click", childLocation=Nothing, location=Nothing, value=Nothing })++ it "parses a FrontEndEvent with a string value" $ do+ decode "{ \"event\": \"submit\", \"childLocation\": null, \"location\": null, \"value\": \"hello\" }"+ `shouldBe`+ Just (FromFrontendEvent { kind="submit", childLocation=Nothing, location=Nothing, value=Just "hello" })++ it "parses a FrontEndEvent with a dictionary value" $ do+ decode "{ \"event\": \"submit\", \"childLocation\": null, \"location\": null, \"value\": \"{}\" }"+ `shouldBe`+ Just (FromFrontendEvent { kind="submit", childLocation=Nothing, location=Nothing, value=Just "{}" })+++main :: IO ()+main = hspec spec
+ test/PrepareTreeSpec.hs view
@@ -0,0 +1,173 @@+module PrepareTreeSpec where++import Prelude hiding (div)+import Test.Hspec+import Test.QuickCheck++import TreeGenerator ()+import Events+import Component+import ComponentHelpers+import PrepareTree+import CollectInitials (collectInitials)+import CleanTree (cleanTree)++type UTCTime = Integer++getCurrentTime :: IO Integer+getCurrentTime = pure 10++spec :: SpecWith ()+spec = parallel $ do++ describe "prepareTree" $ do++ it "works across a variety of trees" $ do+ property $ \x -> show (prepareTree (x :: Purview String IO))+ `shouldContain` "always present"++ it "assigns an identifier to On actions" $ do+ let target = div+ [ onClick "setTime" $ div []+ , onClick "clearTime" $ div []+ ]+ fixedTree = prepareTree target++ fixedTree+ `shouldBe`+ Html "div"+ [ Attribute (On "click" (Just [0]) (const "setTime") ) $ Html "div" []+ , Attribute (On "click" (Just [1]) (const "clearTime") ) $ Html "div" []+ ]++ -- TODO: Nested On actions++ describe "collecting initial events" $ do++ it "works for handlers" $ do+ let+ handler' :: (String -> Purview String IO) -> Purview () IO+ handler' = handler [Self "up"] "" handle++ handle "up" state = (id, [])++ preparedTree = prepareTree (handler' (const $ div []))+ (initialActions, _) = collectInitials preparedTree++ initialActions `shouldBe` [InternalEvent "up" Nothing (Just [])]++ -- the next round there should be no initial actions+ let+ (initialActions', _) = collectInitials $ cleanTree [] (prepareTree $ handler' (const $ div []))++ initialActions' `shouldBe` []++ it "works for effectHandler" $ do+ let+ handler' = effectHandler' [Self "up"] "" handle++ handle "up" state = pure (state, []) :: IO (String, [DirectedEvent () String])++ preparedTree = prepareTree (handler' (const $ div []))+ (initialActions, _) = collectInitials preparedTree++ initialActions `shouldBe` [InternalEvent "up" Nothing (Just [])]++ -- the next round there should be no initial actions+ let+ (initialActions', _) = collectInitials $ cleanTree [] (prepareTree $ handler' (const $ div []))++ initialActions' `shouldBe` []++ it "works for nested handlers" $ do+ let+ parentHandler = handler' [] "" handle+ childHandler = handler' [Self "to child", Parent "to parent"] "" handle++ handle "" state = (state, [])++ component :: Purview () IO+ component = parentHandler $ \_ -> childHandler $ \_ -> div []++ preparedTree = prepareTree component+ (initialActions, _) = collectInitials preparedTree++ initialActions+ `shouldBe` [ InternalEvent "to child" Nothing (Just [0])+ , InternalEvent "to parent" Nothing (Just [])+ ]++ it "assigns a location to handlers" $ do+ let+ timeHandler = effectHandler [] Nothing handle++ handle :: String -> Maybe UTCTime -> IO (Maybe UTCTime -> Maybe UTCTime, [DirectedEvent String String])+ handle "setTime" _ = do+ time <- getCurrentTime+ pure (const $ Just time, [])+ handle _ state =+ pure (const state, [])++ component = timeHandler (const (Text ""))++ component `shouldBe` (EffectHandler Nothing Nothing [] Nothing handle (const (Text "")))++ let+ graphWithLocation = prepareTree component++ graphWithLocation `shouldBe` (EffectHandler (Just []) (Just []) [] Nothing handle (const (Text "")))++ it "assigns a different location to child handlers" $ do+ let+ timeHandler = effectHandler' [] Nothing handle++ handle :: String -> Maybe UTCTime -> IO (Maybe UTCTime, [DirectedEvent String String])+ handle "setTime" _ = do+ time <- getCurrentTime+ pure (Just time, [])+ handle _ state =+ pure (state, [])++ component = div+ [ timeHandler (const (Text ""))+ , timeHandler (const (Text ""))+ ]++ graphWithLocation = prepareTree component++ show graphWithLocation+ `shouldBe`+ "div [ EffectHandler Just [] Just [0] Nothing \"\" EffectHandler Just [] Just [1] Nothing \"\" ] "++ it "assigns a different location to nested handlers" $ do+ let+ timeHandler = effectHandler' [] Nothing handle++ handle :: String -> Maybe UTCTime -> IO (Maybe UTCTime, [DirectedEvent String String])+ handle "setTime" _ = do+ time <- getCurrentTime+ pure (Just time, [])+ handle _ state =+ pure (state, [])++ component =+ timeHandler (const (timeHandler (const (Text ""))))+++ graphWithLocation = prepareTree component++ show graphWithLocation `shouldBe` "EffectHandler Just [] Just [] Nothing EffectHandler Just [] Just [0] Nothing \"\""++ it "picks up css" $ do+ let+ component :: Purview () m+ component = (Attribute $ Style ("123", "color: blue;")) $ div []++ (_, css) = collectInitials component :: ([Event], [(Hash, String)])++ css `shouldBe` [("123", "color: blue;")]++++main :: IO ()+main = hspec spec
+ test/PurviewSpec.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE OverloadedStrings #-}+module PurviewSpec where++import Prelude hiding (div)+import Test.Hspec+import Purview++upButton :: Purview String m+upButton = onClick ("up" :: String) $ div [ text "up" ]++downButton :: Purview String m+downButton = onClick ("down" :: String) $ div [ text "down" ]++reducer :: Applicative m => (Int -> Purview String m) -> Purview String m+reducer = handler' [] 0 action+ where+ action :: String -> Int -> (Int, [DirectedEvent String String])+ action "up" _ = (1, [])+ action _ _ = (0, [])++-- counter :: Show a => a -> Purview parentAction action m+counter state = div+ [ upButton+ , text $ "count: " <> show state+ , downButton+ ]++component :: Applicative m => Purview String m+component = PurviewSpec.reducer counter++event' :: String+event' = "{\"event\":\"click\",\"message\":\"up\"}"++spec :: SpecWith ()+spec = parallel $ do+ describe "applying events" $ do+ it "works with the event directly" $ do+-- let applied = handleEvent event' component+--+-- render [] applied `shouldNotBe` render [] component+ (1 :: Integer) `shouldBe` 1++main :: IO ()+main = hspec spec
+ test/RenderingSpec.hs view
@@ -0,0 +1,136 @@+module RenderingSpec where++import Prelude hiding (div)+import Data.Aeson.TH+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck hiding (classes, once)++import TreeGenerator+import Component+import ComponentHelpers+import Events+import Rendering++data SingleConstructor = SingleConstructor+ deriving (Show, Eq)+++spec :: SpecWith ()+spec = parallel $ do++ describe "render" $ do++ it "can render an assortment of different trees" $+ property $ \x -> render (x :: Purview String IO) `shouldContain` "always present"++ it "can create a div" $ do+ let element = Html "div" [Text "hello world"]++ render element `shouldBe` "<div>hello world</div>"++ it "can add an onclick" $ do+ let element =+ Attribute (On "click" Nothing (\_ -> 1 :: Integer))+ $ Html "div" [Text "hello world"]++ render element `shouldBe`+ "<div bubbling-bound click-location=null>hello world</div>"++ it "can add an id" $ do+ let element = id' "hello" $ div [text "it's a hello div"]+ render element `shouldBe` "<div id=\"hello\">it's a hello div</div>"++ it "can add one class" $ do+ let element =+ classes ["class1"] $ div [text "it's a hello div"]+ render element `shouldBe` "<div class=\"class1\">it's a hello div</div>"++ it "can add classes" $ do+ let element =+ classes ["class1", "class2", "class3"] $ div [text "it's a hello div"]+ render element `shouldBe` "<div class=\"class1 class2 class3\">it's a hello div</div>"++ it "can render classes and ids at the same time" $ do+ let element =+ classes ["class1", "class2", "class3"]+ $ id' "hello"+ $ div [text "it's a hello div"]+ render element `shouldBe` "<div id=\"hello\" class=\"class1 class2 class3\">it's a hello div</div>"++ it "can render a form" $ do+ let+ named = Attribute . Generic "name"+ input = Html "input"+ form = Html "form"+ component = onSubmit (\_ -> "initialValue" :: String) $ form [ named "name" $ input [] ]++ render component+ `shouldBe`+ "<form bubbling-bound submit-location=null><input name=\"name\"></input></form>"++ it "can render a typed action" $ do+ let element = onClick SingleConstructor $ div [ text "click" ]++ render element+ `shouldBe`+ "<div bubbling-bound click-location=null>click</div>"++ it "can render two typed actions of different form" $ do+ let element+ = onSubmit (const SingleConstructor)+ $ onClick SingleConstructor+ $ div [ text "click" ]++ render element+ `shouldBe`+ "<div bubbling-bound click-location=null submit-location=null>click</div>"+++ it "can render a style" $ do+ let element = istyle "color: blue;" $ div [ text "blue" ]++ render element+ `shouldBe`+ "<div style=\"color: blue;\">blue</div>"++ it "can render composed styles" $ do+ let blue = istyle "color: blue;"+ halfSize = istyle "width: 50%; height: 50%;"++ render (blue . halfSize $ div [ text "box" ])+ `shouldBe`+ "<div style=\"width: 50%; height: 50%;color: blue;\">box</div>"++ it "can render a receiver" $ do+ let receiver = Receiver (Just []) (Just [0, 1]) "test" (const "") (const (div []))++ render (receiver ())+ `shouldBe`+ "<div handler=\"[0,1]\" parent-handler=\"[]\" receiver-name=\"test\"><div></div></div>"++ it "can render a class based style" $ do+ let component = (Attribute $ Style ("123", "")) $ div []++ render component+ `shouldBe`+ "<div class=\"123\"></div>"++ it "can render multile class based style" $ do+ let style = Attribute $ Style ("123", "")+ component = style $ style (div [])++ render component+ `shouldBe`+ "<div class=\"123 123\"></div>"++ it "can combine an existing class and class based style" $ do+ let style = Attribute $ Style ("123", "")+ component = class' "abc" $ style (div [])++ render component+ `shouldBe`+ "<div class=\"123 abc\"></div>"++main :: IO ()+main = hspec spec
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}
+ test/StyleSpec.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE QuasiQuotes #-}++-- |++module StyleSpec where++import Prelude hiding (div)+import Test.Hspec++import Component+import ComponentHelpers+import Style (style, handleCSS, parseLine, parseCSS, Brace (..))++spec :: SpecWith ()+spec = parallel $ do+ describe "the style quasiquoter" $ do+ let component = div []++ it "produces a non-empty style" $ do+ let styled = [style|blue;|] component++ show styled `shouldBe` "Attr Style (\"p210629223392\",\"blue;\") div [ ] "++ it "produces the same hash for the same style" $ do+ let+ styleA = [style|blue;|] component+ styleB = [style|blue;|] component++ styleA `shouldBe` styleB++ it "produces different hashes for different styles" $ do+ let+ styleA = [style|blue;|] component+ styleB = [style|red;|] component++ styleA `shouldNotBe` styleB++ describe "handleCSS" $ do+ it "turns nested CSS into pairs of class and rules" $ do+ let+ css = handleCSS "color: red; div { color: blue; width: 15%; } width: 15%;"++ css `shouldBe` [("","color: red;width: 15%;"),("div ","color: blue;width: 15%;")]++ describe "parseLine" $ do+ it "takes a line (simple)" $ do+ let result = parseLine "\n color: blue; color: red;"+ result `shouldBe` (None, "color: blue;", " color: red;")++ it "says when the line is a new level" $ do+ let result = parseLine "div {}"+ result `shouldBe` (Open, "div {", "}")++ describe "parseCSS" $ do+ it "works for an empty CSS" $ do+ let result = parseCSS [] ""+ result `shouldBe` []++ it "works with some newlines" $ do+ let result = parseCSS [] "\n\n"+ result `shouldBe` []++ it "works with a single rule" $ do+ let result = parseCSS [] "color: blue;"+ result `shouldBe` [("", "color: blue;")]++ it "works with multiple rules on a single level" $ do+ let result = parseCSS [] "color: blue; width: 15px;"+ result `shouldBe` [("", "color: blue;"), ("", "width: 15px;")]++ it "works with multiple rules with returns" $ do+ let result = parseCSS [] "color: blue;\n width: 15px;"+ result `shouldBe` [("", "color: blue;"), ("", "width: 15px;")]++ it "works with a nested rule" $ do+ let result = parseCSS [] "div { color: red; }"+ result `shouldBe` [("div ", "color: red;")]++ it "works with a nested tag and multiple rules" $ do+ let result = parseCSS [] "div { color: red;\n width: 15px; }"+ result `shouldBe` [("div ", "color: red;"), ("div ", "width: 15px;")]++ it "works with a top level rule, then a nested rule, then a top level rule" $ do+ let result = parseCSS [] "color: red;\n div { color: blue; }width: 15px;"+ result `shouldBe` [("", "color: red;"), ("div ", "color: blue;"), ("", "width: 15px;")]++ it "works with a doubly nested rule" $ do+ let result = parseCSS [] "ul { width: 150px;\nli { padding: 15px; } }"+ result `shouldBe` [("ul ","width: 150px;"),("ul li ","padding: 15px;")]++ it "works with two nested rules" $ do+ let result = parseCSS [] "width: 500px;\n\n div {\nwidth: 666px;\n}\n li {\n padding: 0 20px;\n}\n"+ result `shouldBe`[("","width: 500px;"),("div ","width: 666px;"),("li ","padding: 0 20px;")]++ let joined = handleCSS "width: 500px;\n\n div {\nwidth: 666px;\n}\n li {\n padding: 0 20px;\n}\n"+ joined `shouldBe` [("","width: 500px;"),("div ","width: 666px;"),("li ","padding: 0 20px;")]++ it "works with nested pseudo selectors" $ do+ let result = parseCSS [] "width: 500px;\nli {\n&:hover { pointer: cursor; }}"+ result `shouldBe` [("","width: 500px;"),("li &:hover ","pointer: cursor;")]++ let joined = handleCSS "width: 500px;\nli {\n&:hover { pointer: cursor; }}"+ joined `shouldBe` [("", "width: 500px;"), ("li &:hover ", "pointer: cursor;")]++ it "works with a psuedo selector" $ do+ let result = parseCSS [] "&:hover { color: green; }"+ result `shouldBe` [("&:hover ","color: green;")]++ let result = handleCSS "&:hover { color: green; }"+ result `shouldBe` [("&:hover ","color: green;")]++++main :: IO ()+main = hspec spec
+ test/TreeGenerator.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE FlexibleInstances #-}+module TreeGenerator where++import Prelude hiding (div)+import Test.Hspec+import Test.QuickCheck hiding (once)+import Control.Monad.IO.Class++import Component+import ComponentHelpers+import Events++{-++This is a helper to generate semi random purview trees+for tests, and to make sure everything can be combined+nicely.++-}++testHandler :: (String -> Purview String IO) -> Purview String IO+testHandler = effectHandler' [] ("" :: String) reducer+ where+ reducer :: String -> String -> IO (String, [DirectedEvent String String])+ reducer action state = pure ("", [])++sizedArbExpr :: Int -> Gen (Purview String IO)+sizedArbExpr 0 = do pure $ text "always present"+sizedArbExpr n = do+ es <- vectorOf 2 (sizedArbExpr (n-1))+ elements+ [ div es+ , istyle "" $ div es+ , testHandler (const $ div es)+ ]++instance Arbitrary (Purview String IO) where+ arbitrary = resize 3 $ sized sizedArbExpr