Shpadoinkle-examples 0.0.0.2 → 0.0.0.3
raw patch · 17 files changed
+443/−253 lines, 17 filesdep +Shpadoinkle-backend-snabbdomdep +generic-monoiddep +pretty-shownew-component:exe:servant-crud-dev
Dependencies added: Shpadoinkle-backend-snabbdom, generic-monoid, pretty-show
Files
- Animation.hs +28/−19
- Calculator.hs +22/−15
- CalculatorIE.hs +35/−32
- Counter.hs +7/−9
- Lens.hs +7/−7
- Shpadoinkle-examples.cabal +72/−17
- TODOMVC.hs +35/−26
- ThrottleAndDebounce.hs +18/−14
- servant-crud/Client.hs +12/−16
- servant-crud/Run/Client.hs +9/−0
- servant-crud/Run/Dev.hs +10/−0
- servant-crud/Run/Server.hs +8/−0
- servant-crud/Server.hs +41/−22
- servant-crud/Types.hs +64/−31
- servant-crud/Types/Prim.hs +19/−14
- servant-crud/View.hs +21/−19
- widgets/Widgets.hs +35/−12
Animation.hs view
@@ -8,16 +8,22 @@ import Control.Concurrent.STM (atomically, writeTVar)-import Control.Monad (void)-import Control.Monad.IO.Class-import Data.Text-import Ease-import GHCJS.DOM-import GHCJS.DOM.RequestAnimationFrameCallback-import GHCJS.DOM.Window-import Shpadoinkle-import Shpadoinkle.Backend.ParDiff-import Shpadoinkle.Html as H+import Control.Monad (void, when)+import Control.Monad.IO.Class (MonadIO (liftIO))+import Data.Text (Text, pack)+import Ease (bounceOut)+import GHCJS.DOM (currentWindowUnchecked)+import GHCJS.DOM.RequestAnimationFrameCallback (newRequestAnimationFrameCallback)+import GHCJS.DOM.Window (Window,+ requestAnimationFrame)+import Shpadoinkle (Html, JSM, TVar,+ newTVarIO,+ shpadoinkle)+import Shpadoinkle.Backend.Snabbdom (runSnabbdom, stage)+import Shpadoinkle.Html as H (div,+ textProperty)+import Shpadoinkle.Run (runJSorWarp)+import UnliftIO.Concurrent (forkIO, threadDelay) default (Text)@@ -46,19 +52,22 @@ | otherwise -> "I'm ok" ] +wait :: Num n => n+wait = 3000000++ animation :: Window -> TVar Double -> JSM () animation w t = void $ requestAnimationFrame w =<< go where- go = newRequestAnimationFrameCallback $ \clock -> do+ go = newRequestAnimationFrameCallback $ \clock' -> do+ let clock = clock' - (wait / 1000) liftIO . atomically $ writeTVar t clock r <- go- if clock < dur then void $ requestAnimationFrame w r else return ()+ when (clock < dur) . void $ requestAnimationFrame w r main :: IO ()-main = do- putStrLn "\nHappy point of view on https://localhost:8080\n"- runJSorWarp 8080 $ do- t <- newTVarIO 0- w <- currentWindowUnchecked- animation w t- shpadoinkle id runParDiff 0 t view getBody+main = runJSorWarp 8080 $ do+ t <- newTVarIO 0+ w <- currentWindowUnchecked+ _ <- forkIO $ threadDelay wait >> animation w t+ shpadoinkle id runSnabbdom 0 t view stage
Calculator.hs view
@@ -1,18 +1,25 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} module Main where -import Data.Maybe-import Data.Text-import Safe-import Shpadoinkle-import Shpadoinkle.Backend.ParDiff-import Shpadoinkle.Html+import Data.Maybe (fromMaybe)+import Data.Text (Text, pack, unpack)+import Safe (readMay)+import Shpadoinkle (Html, liftC, text)+import Shpadoinkle.Backend.ParDiff (runParDiff)+import Shpadoinkle.Html (div_, getBody, input', onInput,+ onOption, option, select, value)+import Shpadoinkle.Run (runJSorWarp, simple) data Model = Model@@ -48,7 +55,7 @@ opSelect :: Html m Operation-opSelect = select [ onOption $ read . unpack ]+opSelect = select [ onOption $ const . read . unpack ] $ opOption <$> [minBound..maxBound] where opOption o = option [ value . pack $ show o ] [ text $ opText o ] @@ -56,15 +63,15 @@ num :: Int -> Html m Int num x = input' [ value . pack $ show x- , onInput $ fromMaybe 0 . readMay . unpack+ , onInput $ const . fromMaybe 0 . readMay . unpack ] view :: Functor m => Model -> Html m Model view model = div_- [ liftC (\l m -> m { left = l }) left $ num (left model)- , liftC (\o m -> m { operation = o }) operation $ opSelect- , liftC (\r m -> m { right = r }) right $ num (right model)+ [ liftC (\l m -> m { left = l }) left $ num (left model)+ , liftC (\o m -> m { operation = o }) operation opSelect+ , liftC (\r m -> m { right = r }) right $ num (right model) , text $ " = " <> pack (show $ opFunction (operation model) (left model) (right model)) ]
CalculatorIE.hs view
@@ -6,7 +6,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-}@@ -14,18 +13,22 @@ module Main where -import Control.Lens-import Data.Aeson-import Data.FileEmbed+import Control.Lens (Iso', Prism', from, iso,+ makeFieldsNoPrefix, prism', re,+ to, (%~), (&), (.~), (?~), (^.),+ (^..), (^?))+import Data.Aeson (ToJSON)+import Data.FileEmbed (embedFile) import Data.List as L import Data.List.Split as L-import Data.Text-import Data.Text.Encoding+import Data.Text (Text, pack)+import Data.Text.Encoding (decodeUtf8) import GHC.Generics (Generic)-import Shpadoinkle-import Shpadoinkle.Backend.ParDiff-import Shpadoinkle.Console+import Shpadoinkle (Html, liftC)+import Shpadoinkle.Backend.ParDiff (runParDiff)+import Shpadoinkle.Console (askJSM, trapper) import Shpadoinkle.Html as H+import Shpadoinkle.Run (runJSorWarp, simple) default (ClassList) @@ -56,9 +59,9 @@ instance Show Entry where show = let asChar = traverse . re charDigit in \case- Whole xs -> xs ^.. asChar+ Whole xs -> xs ^.. asChar xs :<.> ys -> xs ^.. asChar <> "." <> ys ^.. asChar- Negate e -> '-' : show e+ Negate e -> '-' : show e frac :: Iso' Entry Double frac = iso toFrac fromFrac where@@ -107,13 +110,13 @@ initial :: Model initial = Model noEntry Nothing -digit :: Model -> Digit -> Html m Model-digit m d = button [ onClick $ m & current %~ applyDigit d, class' $ "d" <> d' ] [ text d' ]+digit :: Digit -> Html m Model+digit d = button [ onClick $ current %~ applyDigit d, class' $ "d" <> d' ] [ text d' ] where d' = d ^. re charDigit . to (pack . pure) operate :: Maybe Operator -> Operator -> Html m Operator operate active o = button- [ onClick o, class' ("active" :: Text, Just o == active) ]+ [ onClick $ const o, class' ("active" :: Text, Just o == active) ] [ text . pack $ show o ] applyDigit :: Digit -> Entry -> Entry@@ -148,7 +151,7 @@ neg :: Entry -> Entry neg = \case Negate e -> e- e -> Negate e+ e -> Negate e readout :: Model -> Html m a readout x = H.div "readout" $@@ -162,37 +165,37 @@ ] clear :: Html m Model-clear = button [ class' "clear", onClick initial ] [ "AC" ]+clear = button [ class' "clear", onClick $ const initial ] [ "AC" ] -posNeg :: Model -> Html m Model-posNeg x = button [ class' "posNeg", onClick (x & current %~ neg) ] [ "-/+" ]+posNeg :: Html m Model+posNeg = button [ class' "posNeg", onClick $ current %~ neg ] [ "-/+" ] -numberpad :: Model -> Html m Model-numberpad m = H.div "numberpad" . L.intercalate [ br'_ ] . L.chunksOf 3 $- digit m <$> [minBound .. pred maxBound]+numberpad :: Html m Model+numberpad = H.div "numberpad" . L.intercalate [ br'_ ] . L.chunksOf 3 $+ digit <$> [minBound .. pred maxBound] operations :: Functor m => Model -> Html m Model operations x = H.div "operate" $ (\o' -> liftC (\o _ -> x- & operation .~ Just (Operation o (x ^. current))+ & operation ?~ Operation o (x ^. current) & current .~ noEntry) (const o') $ operate (x ^? operation . traverse . operator) o') <$> ([minBound .. maxBound] :: [Operator]) -dot :: Model -> Html m Model-dot x = button [ onClick $ x & current %~ addDecimal ] [ "." ]+dot :: Html m Model+dot = button [ onClick $ current %~ addDecimal ] [ "." ] -equals :: Model -> Html m Model-equals x = button [ class' "equals", onClick $ calcResult x ] [ "=" ]+equals :: Html m Model+equals = button [ class' "equals", onClick calcResult ] [ "=" ] view :: Monad m => Model -> Html m Model view m = H.div "calculator" [ readout m , H.div "buttons"- [ clear, posNeg m, operations m- , numberpad m+ [ clear, posNeg, operations m+ , numberpad , H.div "zerodot"- [ digit m Zero- , dot m- , equals m+ [ digit Zero+ , dot+ , equals ] ] ]@@ -202,4 +205,4 @@ setTitle "Calculator" ctx <- askJSM addInlineStyle $ decodeUtf8 $(embedFile "./CalculatorIE.css")- Shpadoinkle.simple runParDiff initial (Main.view . trapper @ToJSON ctx) getBody+ simple runParDiff initial (Main.view . trapper @ToJSON ctx) getBody
Counter.hs view
@@ -4,32 +4,30 @@ module Main where -import Control.Monad.IO.Class (liftIO) import Data.Text (pack) import Prelude hiding (span) -import Shpadoinkle-import Shpadoinkle.Backend.ParDiff+import Shpadoinkle (Html, JSM, text)+import Shpadoinkle.Backend.ParDiff (runParDiff) import Shpadoinkle.Html (br'_, button, div_, h2_, id', onClick, span) import Shpadoinkle.Html.Utils+import Shpadoinkle.Run (runJSorWarp, simple) view :: Int -> Html m Int view count = div_ [ h2_ [ "Counter Example" ] , "The current count is: "- , span [ id' "out" ] [ text (pack $ show count) ]+ , span [ id' "out" ] [ text . pack $ show count ] , br'_, br'_- , button [ onClick $ count - 1 ] [ "Decrement" ]- , button [ onClick $ count + 1 ] [ "Increment" ]+ , button [ onClick $ subtract 1 ] [ "Decrement" ]+ , button [ onClick (+ 1) ] [ "Increment" ] ] app :: JSM ()-app = do- model <- liftIO $ newTVarIO 0- shpadoinkle id runParDiff 0 model view getBody+app = simple runParDiff 0 view getBody main :: IO ()
Lens.hs view
@@ -14,13 +14,13 @@ import Data.Text (Text, pack, unpack) import GHC.Generics (Generic) import Safe (readMay)-import Shpadoinkle (Html, JSM, runJSorWarp, simple,- text)+import Shpadoinkle (Html, JSM, text) import Shpadoinkle.Backend.ParDiff (runParDiff) import Shpadoinkle.Html (button, div_, for', getBody, id', input', label, onClick, onInput, value) import Shpadoinkle.Lens (onRecord, onSum)+import Shpadoinkle.Run (runJSorWarp, simple) data Form = Form@@ -35,13 +35,13 @@ , onRecord #name $ input' [ id' "name" , value $ f ^. #name- , onInput id+ , onInput const ] , label [ for' "age" ] [ "Age" ] , onRecord #age $ input' [ id' "age" , value . pack . show $ f ^. #age- , onInput $ fromMaybe 0 . readMay . unpack+ , onInput $ const . fromMaybe 0 . readMay . unpack ] ] @@ -53,7 +53,7 @@ counter :: Counter -> Html m Counter counter c = div_ [ label [ for' "counter" ] [ text . pack $ show c ]- , button [ id' "counter", onClick $ c + 1 ] [ "Increment" ]+ , button [ id' "counter", onClick (+ 1) ] [ "Increment" ] ] @@ -67,11 +67,11 @@ view = \case MCounter c -> div_ [ onSum #_MCounter $ counter c- , button [ onClick . MForm $ Form "" 18 ] [ "Go to Form" ]+ , button [ onClick . const. MForm $ Form "" 18 ] [ "Go to Form" ] ] MForm f -> div_ [ onSum #_MForm $ form f- , button [ onClick $ MCounter 0 ] [ "Go to Counter" ]+ , button [ onClick . const $ MCounter 0 ] [ "Go to Counter" ] ]
Shpadoinkle-examples.cabal view
@@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.32.0.+-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack ----- hash: 21985c60c92f72c182e14dfac317f3e717d0ca271e4b587fdf362594753f26ba+-- hash: 88d13fd460ee408ee1c0ec246c6bc8d33bf71d4eedd027989073ab30c91fe2e4 name: Shpadoinkle-examples-version: 0.0.0.2+version: 0.0.0.3 synopsis: Example usages of Shpadoinkle description: A collection of illustrative applications to show various Shpadoinkle utilities. category: Web@@ -29,16 +29,17 @@ hs-source-dirs: ./. ghc-options: -Wall -Wcompat -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities- ghcjs-options: -Wall -Wcompat -fno-warn-missing-home-modules -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities -dedupe+ ghcjs-options: -Wall -Wcompat -fno-warn-missing-home-modules -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities -dedupe -O2 build-depends: Shpadoinkle- , Shpadoinkle-backend-pardiff+ , Shpadoinkle-backend-snabbdom , Shpadoinkle-html , base >=4.12.0 && <4.16 , ease , ghcjs-dom , stm , text+ , unliftio default-language: Haskell2010 executable calculator@@ -46,7 +47,7 @@ hs-source-dirs: ./. ghc-options: -Wall -Wcompat -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities- ghcjs-options: -Wall -Wcompat -fno-warn-missing-home-modules -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities -dedupe+ ghcjs-options: -Wall -Wcompat -fno-warn-missing-home-modules -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities -dedupe -O2 build-depends: Shpadoinkle , Shpadoinkle-backend-pardiff@@ -64,7 +65,7 @@ hs-source-dirs: ./. ghc-options: -Wall -Wcompat -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities- ghcjs-options: -Wall -Wcompat -fno-warn-missing-home-modules -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities -dedupe+ ghcjs-options: -Wall -Wcompat -fno-warn-missing-home-modules -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities -dedupe -O2 build-depends: Shpadoinkle , Shpadoinkle-backend-pardiff@@ -85,7 +86,7 @@ hs-source-dirs: ./. ghc-options: -Wall -Wcompat -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities- ghcjs-options: -Wall -Wcompat -fno-warn-missing-home-modules -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities -dedupe+ ghcjs-options: -Wall -Wcompat -fno-warn-missing-home-modules -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities -dedupe -O2 build-depends: Shpadoinkle , Shpadoinkle-backend-pardiff@@ -100,7 +101,7 @@ hs-source-dirs: ./. ghc-options: -Wall -Wcompat -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities- ghcjs-options: -Wall -Wcompat -fno-warn-missing-home-modules -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities -dedupe+ ghcjs-options: -Wall -Wcompat -fno-warn-missing-home-modules -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities -dedupe -O2 build-depends: Shpadoinkle , Shpadoinkle-backend-pardiff@@ -114,18 +115,20 @@ default-language: Haskell2010 executable servant-crud-client- main-is: Client.hs+ main-is: Run/Client.hs other-modules: Types Types.Prim View+ Client hs-source-dirs: ./servant-crud ghc-options: -Wall -Wcompat -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities- ghcjs-options: -Wall -Wcompat -fno-warn-missing-home-modules -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities -dedupe+ ghcjs-options: -Wall -Wcompat -fno-warn-missing-home-modules -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities -dedupe -O2 build-depends: Shpadoinkle , Shpadoinkle-backend-pardiff+ , Shpadoinkle-backend-snabbdom , Shpadoinkle-html , Shpadoinkle-lens , Shpadoinkle-router@@ -153,16 +156,66 @@ , sqlite-simple default-language: Haskell2010 +executable servant-crud-dev+ main-is: Run/Dev.hs+ other-modules:+ Types.Prim+ Types+ View+ Client+ Server+ hs-source-dirs:+ ./servant-crud+ ghc-options: -Wall -Wcompat -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities+ ghcjs-options: -Wall -Wcompat -fno-warn-missing-home-modules -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities -dedupe -O2+ build-depends:+ Shpadoinkle+ , Shpadoinkle-backend-pardiff+ , Shpadoinkle-backend-snabbdom+ , Shpadoinkle-backend-static+ , Shpadoinkle-html+ , Shpadoinkle-lens+ , Shpadoinkle-router+ , Shpadoinkle-widgets+ , aeson+ , base >=4.12.0 && <4.16+ , beam-core+ , beam-sqlite+ , bytestring+ , containers+ , exceptions+ , file-embed+ , generic-monoid+ , jsaddle+ , lens+ , mtl+ , optparse-applicative+ , servant+ , servant-server+ , sqlite-simple+ , stm+ , text+ , unliftio+ , wai+ , wai-app-static+ , warp+ if impl(ghcjs)+ buildable: False+ else+ buildable: True+ default-language: Haskell2010+ executable servant-crud-server- main-is: Server.hs+ main-is: Run/Server.hs other-modules: Types.Prim Types View+ Server hs-source-dirs: ./servant-crud ghc-options: -Wall -Wcompat -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities- ghcjs-options: -Wall -Wcompat -fno-warn-missing-home-modules -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities -dedupe+ ghcjs-options: -Wall -Wcompat -fno-warn-missing-home-modules -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities -dedupe -O2 build-depends: Shpadoinkle , Shpadoinkle-backend-static@@ -199,7 +252,7 @@ hs-source-dirs: ./. ghc-options: -Wall -Wcompat -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities- ghcjs-options: -Wall -Wcompat -fno-warn-missing-home-modules -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities -dedupe+ ghcjs-options: -Wall -Wcompat -fno-warn-missing-home-modules -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities -dedupe -O2 build-depends: Shpadoinkle , Shpadoinkle-backend-pardiff@@ -216,16 +269,17 @@ hs-source-dirs: ./. ghc-options: -Wall -Wcompat -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities- ghcjs-options: -Wall -Wcompat -fno-warn-missing-home-modules -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities -dedupe+ ghcjs-options: -Wall -Wcompat -fno-warn-missing-home-modules -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities -dedupe -O2 build-depends: Shpadoinkle- , Shpadoinkle-backend-pardiff+ , Shpadoinkle-backend-snabbdom , Shpadoinkle-html , Shpadoinkle-lens , base >=4.12.0 && <4.16 , containers , generic-lens , lens+ , pretty-show , text default-language: Haskell2010 @@ -236,10 +290,11 @@ hs-source-dirs: ./widgets ghc-options: -Wall -Wcompat -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities- ghcjs-options: -Wall -Wcompat -fno-warn-missing-home-modules -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities -dedupe+ ghcjs-options: -Wall -Wcompat -fno-warn-missing-home-modules -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities -dedupe -O2 build-depends: Shpadoinkle , Shpadoinkle-backend-pardiff+ , Shpadoinkle-backend-snabbdom , Shpadoinkle-html , Shpadoinkle-lens , Shpadoinkle-widgets
TODOMVC.hs view
@@ -11,16 +11,26 @@ import Control.Lens hiding (view) import Data.Generics.Labels ()-import Data.String+import Data.String (IsString) import Data.Text hiding (count, filter, length)-import GHC.Generics+import GHC.Generics (Generic) import Prelude hiding (div, unwords)-import Shpadoinkle-import Shpadoinkle.Backend.ParDiff-import Shpadoinkle.Html-import Shpadoinkle.Html.LocalStorage-import Shpadoinkle.Html.Memo-import Shpadoinkle.Lens+import Shpadoinkle (Html, JSM, readTVarIO,+ shpadoinkle, text)+import Shpadoinkle.Backend.Snabbdom (runSnabbdom, stage)+import Shpadoinkle.Html (a, addStyle, autofocus, button,+ button', checked, class', div,+ div_, footer, for', form, h1_,+ header, href, id', input',+ label, li, li_, onBlur,+ onChange, onClick, onDblclick,+ onInput, onSubmit, p_,+ placeholder, section, span,+ strong_, type', ul, value)+import Shpadoinkle.Html.LocalStorage (manageLocalStorage)+import Shpadoinkle.Html.Memo (memo)+import Shpadoinkle.Lens (generalize)+import Shpadoinkle.Run (runJSorWarp) default (Text)@@ -105,8 +115,8 @@ filterHtml :: Visibility -> Visibility -> Html m Visibility-filterHtml = memo2 $ \cur item -> li_- [ a (href "#" : onClick item+filterHtml = memo $ \cur item -> li_+ [ a (href "#" : onClick (const item) : [class' ("selected", cur == item)]) [ text . pack $ show item ] ] @@ -125,18 +135,18 @@ [ div "view" [ input' [ type' "checkbox" , class' "toggle"- , onChange $ toggleCompleted tid m+ , onChange $ toggleCompleted tid , checked $ c == Complete ]- , label [ onDblclick $ toggleEditing (Just tid) m ] [ text d ]- , button' [ class' "destroy", onClick $ removeTask tid m ]+ , label [ onDblclick $ toggleEditing (Just tid) ] [ text d ]+ , button' [ class' "destroy", onClick $ removeTask tid ] ]- , form [ onSubmit $ toggleEditing Nothing m ]+ , form [ onSubmit $ toggleEditing Nothing ] [ input' [ class' "edit" , value d- , onInput $ ($ m) . updateTaskDescription tid . Description+ , onInput $ updateTaskDescription tid . Description , autofocus True- , onBlur $ toggleEditing Nothing m+ , onBlur $ toggleEditing Nothing ] ] ]@@ -150,9 +160,8 @@ ] , ul "filters" $ generalize #visibility . filterHtml (visibility model) <$> [minBound..maxBound]- ] ++ (if count Complete (tasks model) == 0 then [] else- [ button [ class' "clear-completed", onClick $ clearComplete model ] [ "Clear completed" ]- ])+ ] ++ [ button [class' "clear-completed", onClick clearComplete ] ["Clear completed"]+ | count Complete (tasks model) /= 0 ] @@ -165,10 +174,10 @@ newTaskForm :: Model -> Html m Model-newTaskForm model = form [ class' "todo-form", onSubmit (appendItem model) ]+newTaskForm model = form [ class' "todo-form", onSubmit appendItem ] [ input' [ class' "new-todo" , value . unDescription $ current model- , onInput $ ($ model) . (#current .~) . Description+ , onInput $ (#current .~) . Description , placeholder "What needs to be done?" ] ] @@ -177,9 +186,9 @@ todoList model = ul "todo-list" $ taskView model <$> visibility model `toVisible` tasks model -toggleAllBtn :: Model -> [Html m Model]-toggleAllBtn model =- [ input' [ id' "toggle-all", class' "toggle-all", type' "checkbox", onChange $ toggleAll model ]+toggleAllBtn :: [Html m Model]+toggleAllBtn =+ [ input' [ id' "toggle-all", class' "toggle-all", type' "checkbox", onChange toggleAll ] , label [ for' "toggle-all" ] [ "Mark all as complete" ] ] @@ -190,7 +199,7 @@ header "header" [ h1_ [ "todos" ], newTaskForm model ] : htmlIfTasks model- [ section "main" $ toggleAllBtn model <> [ todoList model ]+ [ section "main" $ toggleAllBtn <> [ todoList model ] , listFooter model ] , info@@ -203,7 +212,7 @@ initial <- readTVarIO model addStyle "https://cdn.jsdelivr.net/npm/todomvc-common@1.0.5/base.css" addStyle "https://cdn.jsdelivr.net/npm/todomvc-app-css@2.2.0/index.css"- shpadoinkle id runParDiff initial model view getBody+ shpadoinkle id runSnabbdom initial model view stage main :: IO ()
ThrottleAndDebounce.hs view
@@ -1,17 +1,21 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-} module Main where -import Control.Monad.IO.Class+import Control.Arrow (first, second)+import Control.Monad.IO.Class (liftIO) import Data.Text (Text, pack)-import Shpadoinkle-import Shpadoinkle.Backend.ParDiff-import Shpadoinkle.Html+import Shpadoinkle (Html, JSM, newTVarIO, shpadoinkle,+ text)+import Shpadoinkle.Backend.ParDiff (ParDiffT, runParDiff)+import Shpadoinkle.Html (Debounce (..), Throttle (..),+ button, debounce, div_, getBody,+ input, onClick, onInput, throttle)+import Shpadoinkle.Run (runJSorWarp) type Model = (Int, Text)@@ -21,21 +25,21 @@ data Control m = Control- (Debounce m Model Model)- (Debounce m (Text -> Model) Model)- (Throttle m Model Model)- (Throttle m (Text -> Model) Model)+ (Debounce m (Model -> Model) Model)+ (Debounce m (Text -> Model -> Model) Model)+ (Throttle m (Model -> Model) Model)+ (Throttle m (Text -> Model -> Model) Model) view :: Control m -> Model -> Html m Model view (Control debouncer1 debouncer2 throttler1 throttler2) (count, txt) = div_ [ text ("Count: " <> pack (show count))- , div_ [ button [ onClick (count+1, txt) ] [ text "Increment" ] ]- , div_ [ button [ runThrottle throttler1 onClick (count+1, txt) ] [ text "Increment (throttle)" ] ]- , div_ [ button [ runDebounce debouncer1 onClick (count+1, txt) ] [ text "Increment (debounce)" ] ]- , div_ [ text "Debounced input", input [ runDebounce debouncer2 onInput (count,) ] [ ] ]+ , div_ [ button [ onClick $ first (+ 1) ] [ text "Increment" ] ]+ , div_ [ button [ runThrottle throttler1 onClick $ first (+ 1) ] [ text "Increment (throttle)" ] ]+ , div_ [ button [ runDebounce debouncer1 onClick $ first (+ 1) ] [ text "Increment (debounce)" ] ]+ , div_ [ text "Debounced input", input [ runDebounce debouncer2 onInput $ second . const ] [ ] ] , div_ [ text txt ]- , div_ [ text "Throttled input", input [ runThrottle throttler2 onInput (count,) ] [ ] ]+ , div_ [ text "Throttled input", input [ runThrottle throttler2 onInput $ second . const ] [ ] ] ]
servant-crud/Client.hs view
@@ -6,26 +6,28 @@ {-# OPTIONS_GHC -fno-warn-missing-signatures #-} -module Main where+module Client where import Control.Monad.Catch (MonadThrow) import Control.Monad.Reader (MonadIO) import Data.Proxy (Proxy (..))-import Language.Javascript.JSaddle (askJSM, runJSM)+#ifndef ghcjs_HOST_OS+import Shpadoinkle (JSM, MonadJSM, MonadUnliftIO (..),+ UnliftIO (..), askJSM, runJSM)+#else+import Shpadoinkle (JSM, MonadUnliftIO (..),+ UnliftIO (..), askJSM, runJSM)+#endif import Servant.API ((:<|>) (..))-import Shpadoinkle import Shpadoinkle.Backend.ParDiff (runParDiff) import Shpadoinkle.Html.Utils (getBody) import Shpadoinkle.Router (fullPageSPA, withHydration)-#ifndef ghcjs_HOST_OS-import Shpadoinkle.Router (MonadJSM)-#endif import Shpadoinkle.Router.Client (client, runXHR)-import UnliftIO (MonadUnliftIO (..), UnliftIO (..)) -import Types-import View+import Types (API, CRUDSpaceCraft (..), SPA,+ routes)+import View (start, view) newtype App a = App { runApp :: JSM a }@@ -53,10 +55,4 @@ app :: JSM ()-app = fullPageSPA @ SPA runApp runParDiff (withHydration start) view getBody start routes---main :: IO ()-main = do- putStrLn "running app"- runJSorWarp 8080 app+app = fullPageSPA @ (SPA JSM) runApp runParDiff (withHydration start) view getBody start routes
+ servant-crud/Run/Client.hs view
@@ -0,0 +1,9 @@+module Main where+++import qualified Client+import Shpadoinkle.Run (runJSorWarp)+++main :: IO ()+main = runJSorWarp 8080 Client.app
+ servant-crud/Run/Dev.hs view
@@ -0,0 +1,10 @@+module Main where+++import qualified Client+import qualified Server+import Shpadoinkle.Run (Env (Dev), liveWithBackend)+++main :: IO ()+main = liveWithBackend 8080 Client.app $ Server.application Dev "./static"
+ servant-crud/Run/Server.hs view
@@ -0,0 +1,8 @@+module Main where+++import qualified Server+++main :: IO ()+main = Server.main
servant-crud/Server.hs view
@@ -10,25 +10,38 @@ {-# OPTIONS_GHC -fno-warn-missing-methods #-} -module Main where+module Server where -import Control.Monad.Reader-import Data.FileEmbed-import Data.Proxy-import Data.Text.Encoding-import Database.Beam-import Database.Beam.Sqlite-import Database.SQLite.Simple-import Network.Wai-import Network.Wai.Handler.Warp-import Options.Applicative+import Control.Monad.Reader (MonadIO, MonadReader (..),+ ReaderT (..), liftIO)+import Data.FileEmbed (embedFile)+import Data.Proxy (Proxy (..))+import Data.Text.Encoding (decodeUtf8)+import Database.Beam (all_, default_, delete, filter_,+ insert, insertExpressions,+ primaryKey, runDelete,+ runSelectReturningList,+ runSelectReturningOne, runUpdate,+ save, select, val_, (==.))+import Database.Beam.Sqlite (SqliteM, runBeamSqlite,+ runInsertReturningList)+import Database.SQLite.Simple (Connection, Query (..), execute_,+ open)+import Network.Wai (Application)+import Network.Wai.Handler.Warp (run)+import Options.Applicative (Parser, ParserInfo, auto,+ execParser, fullDesc, header,+ helper, info, long, metavar, option,+ progDesc, short, showDefault,+ strOption, value, (<**>)) import Servant.API-import Servant.Server+import Servant.Server (Server, hoistServer, serve) -import Shpadoinkle+import Shpadoinkle (JSM, type (~>)) import Shpadoinkle.Router (MonadJSM)-import Shpadoinkle.Router.Server+import Shpadoinkle.Router.Server (serveUI)+import Shpadoinkle.Run (Env (Prod)) import Types import View@@ -90,8 +103,8 @@ [ SpaceCraft default_ (val_ _sku) (val_ _description) (val_ _serial) (val_ _squadron) (val_ _operable) ] -app :: Connection -> FilePath -> Application-app conn root = serve (Proxy @ (API :<|> SPA)) $ serveApi :<|> serveSpa+app :: Env -> Connection -> FilePath -> Application+app ev conn root = serve (Proxy @ (API :<|> SPA App)) $ serveApi :<|> serveSpa where serveApi :: Server API@@ -102,15 +115,21 @@ :<|> createSpaceCraft :<|> deleteSpaceCraft - serveSpa :: Server SPA- serveSpa = serveUI @ SPA root+ serveSpa :: Server (SPA App)+ serveSpa = serveUI @ (SPA App) root (\r -> toHandler conn $ do- i <- start r; return . template i $ view @ Noop i) routes+ i <- start r; return . template ev i $ view @ Noop i) routes +application :: Env -> FilePath -> IO Application+application ev assets = do+ conn <- open "roster.db"+ execute_ conn . Query $ decodeUtf8 $(embedFile "./servant-crud/migrate.sql")+ return $ app ev conn assets++ main :: IO () main = do Options {..} <- execParser options- conn <- open "roster.db"- execute_ conn . Query $ decodeUtf8 $(embedFile "./servant-crud/migrate.sql")- run port $ app conn assets+ run port =<< application Prod assets+
servant-crud/Types.hs view
@@ -7,10 +7,12 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-}@@ -18,31 +20,63 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} module Types (module Types, module Types.Prim) where -import Control.Lens as Lens hiding (Context)+import Control.Lens as Lens (Identity,+ makeFieldsNoPrefix,+ makeLenses,+ makePrisms, view,+ (^.)) import Control.Lens.TH ()-import Control.Monad.Except-import Data.Aeson-import Data.Function-import Data.Maybe-import Data.Proxy-import Data.Text-import Database.Beam+import Control.Monad.Except (MonadError (throwError),+ MonadTrans (..))+import Data.Aeson (FromJSON, ToJSON)+import Data.Function (on)+import Data.Maybe (fromMaybe)+import Data.Proxy (Proxy (Proxy))+import Data.Text (Text)+import Database.Beam (Beamable, Columnar,+ Database, DatabaseSettings,+ Generic, Nullable,+ Table (..), TableEntity,+ defaultDbSettings) -import Servant.API hiding (Description)-import Shpadoinkle+import Servant.API (Capture, Delete,+ FromHttpApiData, Get, JSON,+ Post, Put, QueryParam, Raw,+ ReqBody, ToHttpApiData,+ type (:<|>) (..), type (:>))+import Shpadoinkle (Html, MonadJSM) import qualified Shpadoinkle.Html as H-import Shpadoinkle.Router-import Shpadoinkle.Widgets.Form.Dropdown as Dropdown-import Shpadoinkle.Widgets.Table as Table-import Shpadoinkle.Widgets.Types-import Shpadoinkle.Widgets.Validation+import Shpadoinkle.Router (HasRouter (type (:>>)),+ Redirect (Redirect),+ Routed (..), View, navigate)+import Shpadoinkle.Widgets.Form.Dropdown as Dropdown (Dropdown)+import Shpadoinkle.Widgets.Table as Table (Column, Row,+ Sort (ASC, DESC),+ SortCol (..),+ Tabular (Effect, sortTable, toCell, toRows))+import Shpadoinkle.Widgets.Types (Field, Humanize (..),+ Hygiene (Clean),+ Input (Input, _value),+ Pick (AtleastOne, One),+ Present (present),+ Search (Search),+ Status (Edit, Errors, Valid),+ Validate (rules),+ fullOptions, fullOptionsMin)+import Shpadoinkle.Widgets.Validation (between, nonMEmpty, nonZero,+ positive) -import Types.Prim+import Types.Prim (Description (..),+ Operable (..), SKU (..),+ SerialNumber (..),+ SpaceCraftId (..),+ Squadron (..)) data SpaceCraftT f = SpaceCraft@@ -176,14 +210,14 @@ :<|> "api" :> "space-craft" :> ReqBody '[JSON] SpaceCraftId :> Delete '[JSON] () -type SPA = "app" :> "echo" :> QueryParam "echo" Text :> Raw- :<|> "app" :> "new" :> Raw- :<|> "app" :> "edit" :> Capture "id" SpaceCraftId :> Raw- :<|> "app" :> QueryParam "search" Search :> Raw- :<|> Raw+type SPA m = "app" :> "echo" :> QueryParam "echo" Text :> View m Text+ :<|> "app" :> "new" :> View m Frontend+ :<|> "app" :> "edit" :> Capture "id" SpaceCraftId :> View m Frontend+ :<|> "app" :> QueryParam "search" Search :> View m Frontend+ :<|> Raw -routes :: SPA :>> Route+routes :: SPA m :>> Route routes = REcho :<|> RNew :<|> RExisting@@ -195,12 +229,12 @@ deriving newtype instance FromHttpApiData Search -instance Routed SPA Route where+instance Routed (SPA m) Route where redirect = \case- REcho t -> Redirect (Proxy @("app" :> "echo" :> QueryParam "echo" Text :> Raw)) ($ t)- RNew -> Redirect (Proxy @("app" :> "new" :> Raw)) id- RExisting i -> Redirect (Proxy @("app" :> "edit" :> Capture "id" SpaceCraftId :> Raw)) ($ i)- RList s -> Redirect (Proxy @("app" :> QueryParam "search" Search :> Raw)) ($ Just (_value s))+ REcho t -> Redirect (Proxy @("app" :> "echo" :> QueryParam "echo" Text :> View m Text)) ($ t)+ RNew -> Redirect (Proxy @("app" :> "new" :> View m Frontend)) id+ RExisting i -> Redirect (Proxy @("app" :> "edit" :> Capture "id" SpaceCraftId :> View m Frontend)) ($ i)+ RList s -> Redirect (Proxy @("app" :> QueryParam "search" Search :> View m Frontend)) ($ Just (_value s)) class CRUDSpaceCraft m where@@ -244,6 +278,7 @@ toRows = fmap SpaceCraftRow + toCell :: forall m. Effect [SpaceCraft] m => [SpaceCraft] -> Row [SpaceCraft] -> Column [SpaceCraft] -> [Html m [SpaceCraft]] toCell _ (SpaceCraftRow SpaceCraft {..}) = \case SKUT -> present _sku DescriptionT -> present _description@@ -253,7 +288,7 @@ ToolsT -> [ H.div "btn-group" [ H.button [ H.className "btn btn-sm btn-secondary",- H.onClickM_ $ navigate @ SPA (RExisting _identity) ] [ "Edit" ]+ H.onClickM_ $ navigate @ (SPA m) (RExisting _identity) ] [ "Edit" ] , H.button [ H.className "btn btn-sm btn-secondary", H.onClickM $ do deleteSpaceCraft _identity@@ -270,5 +305,3 @@ ToolsT -> \_ _ -> EQ where f = case d of ASC -> id; DESC -> flip g l = compare `on` Lens.view l . unRow--
servant-crud/Types/Prim.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -9,28 +8,31 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} module Types.Prim where -import Data.Aeson-import Data.String-import Data.Text-import Database.Beam+import Data.Aeson (FromJSON, ToJSON)+import Data.String (IsString)+import Data.Text (Text)+import GHC.Generics (Generic) #ifndef ghcjs_HOST_OS-import Database.Beam.Backend.SQL.SQL92-import Database.Beam.Sqlite-import Database.Beam.Sqlite.Syntax-import Database.SQLite.Simple.FromField+import Database.Beam (FromBackendRow,+ HasSqlEqualityCheck)+import Database.Beam.Backend.SQL.SQL92 (HasSqlValueSyntax (..),+ autoSqlValueSyntax)+import Database.Beam.Sqlite (Sqlite)+import Database.Beam.Sqlite.Syntax (SqliteValueSyntax)+import Database.SQLite.Simple.FromField (FromField (..)) #endif -import Servant.API hiding (Description)-import Shpadoinkle.Widgets.Types+import Servant.API (FromHttpApiData,+ ToHttpApiData)+import Shpadoinkle (text)+import Shpadoinkle.Widgets.Types (Humanize (..), Present (..)) newtype SKU = SKU { unSKU :: Int }@@ -86,7 +88,7 @@ data Squadron = AwayTeam | StrikeForce | Scout- deriving (Eq, Ord, Enum, Bounded, Read, Show, Present, Generic, ToJSON, FromJSON)+ deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, ToJSON, FromJSON) #ifndef ghcjs_HOST_OS deriving (FromBackendRow Sqlite) instance HasSqlValueSyntax be String => HasSqlValueSyntax be Squadron where sqlValueSyntax = autoSqlValueSyntax@@ -105,6 +107,9 @@ AwayTeam -> "Away Team" StrikeForce -> "Strike Force" Scout -> "Scouting"++instance Present Squadron where+ present = pure . text . humanize instance Humanize (Maybe Squadron) where
servant-crud/View.hs view
@@ -6,7 +6,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ImpredicativeTypes #-}-{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}@@ -31,6 +30,7 @@ import qualified Shpadoinkle.Html as H import Shpadoinkle.Lens import Shpadoinkle.Router (navigate, toHydration)+import Shpadoinkle.Run (Env, entrypoint) import Shpadoinkle.Widgets.Form.Dropdown as Dropdown (Dropdown (..), Theme (..), defConfig,@@ -96,9 +96,9 @@ [ H.label [ H.for' hName, H.class' "col-sm-2 col-form-label" ] [ text msg ] , H.div "col-sm-10" $ [ ef <% l $ Input.integral- $ [ H.name' hName, H.step "1", H.min "0"- , H.class' ("form-control":controlClass (errs ^. l) (ef ^. l .hygiene))- ]+ [ H.name' hName, H.step "1", H.min "0"+ , H.class' ("form-control":controlClass (errs ^. l) (ef ^. l .hygiene))+ ] ] <> invalid (errs ^. l) (ef ^. l . hygiene) ] where hName = toHtmlName msg@@ -108,7 +108,7 @@ :: forall p x m a . MonadJSM m => Control (Dropdown p) => Considered p ~ Maybe => Consideration ConsideredChoice p- => Present (Selected p x) => Ord x+ => Present (Selected p x) => Ord x => Present x => (forall v. Lens' (a v) (Field v Text (Dropdown p) x)) -> Text -> a 'Errors -> a 'Edit -> Html m (a 'Edit) selectControl l msg errs ef = formGroup@@ -124,16 +124,16 @@ [ H.class' [ ("dropdown", True) , ("show", _toggle == Open) ] ]- , _header = \cs -> pure $ H.button+ , _header = pure . H.button [ H.class' ([ "btn", "btn-secondary", "dropdown-toggle" ] :: [Text]) , H.type' "button"- ] (present cs)+ ] . present , _list = H.div [ H.class' [ ("dropdown-menu", True) , ("show", _toggle == Open) ] ]- , _item = const $ H.a' [ H.className "dropdown-item"- , H.textProperty "style" "cursor:pointer" ]+ , _item = H.a [ H.className "dropdown-item"+ , H.textProperty "style" "cursor:pointer" ] . present } @@ -152,7 +152,7 @@ toHtmlName = toLower . replace " " "-" -editForm :: (CRUDSpaceCraft m, MonadJSM m) => Maybe SpaceCraftId -> SpaceCraftUpdate 'Edit -> Html m (SpaceCraftUpdate 'Edit)+editForm :: forall m. (CRUDSpaceCraft m, MonadJSM m) => Maybe SpaceCraftId -> SpaceCraftUpdate 'Edit -> Html m (SpaceCraftUpdate 'Edit) editForm mid ef = H.div_ [ intControl @SKU sku "SKU" errs ef@@ -163,7 +163,7 @@ , H.div "d-flex flex-row justify-content-end" [ H.button- [ H.onClickM_ . navigate @SPA $ RList mempty+ [ H.onClickM_ . navigate @(SPA m) $ RList mempty , H.class' "btn btn-secondary" ] [ "Cancel" ] @@ -173,7 +173,7 @@ Just up -> do case mid of Nothing -> () <$ createSpaceCraft up Just sid -> updateSpaceCraft sid up- navigate @SPA (RList mempty)+ navigate @(SPA m) (RList mempty) , H.class' "btn btn-primary" , H.disabled $ isNothing isValid ] [ "Save" ]@@ -200,7 +200,7 @@ { tableProps = const . const . pure $ H.class' "table table-striped table-bordered" , tdProps = const . const . const $ \case ToolsT -> [ H.width 1 ]- _ -> "align-middle"+ _ -> "align-middle" } @@ -214,7 +214,7 @@ ] -view :: (MonadJSM m, CRUDSpaceCraft m) => Frontend -> Html m Frontend+view :: forall m. (MonadJSM m, CRUDSpaceCraft m) => Frontend -> Html m Frontend view fe = case fe of MList r -> onSum _MList $ H.div "container-fluid"@@ -225,7 +225,7 @@ ] [ r <% search $ Input.search [ H.class' "form-control", H.placeholder "Search" ] , H.div "input-group-append mr-3"- [ H.button [ H.onClickM_ $ navigate @SPA RNew, H.class' "btn btn-primary" ] [ "Register" ]+ [ H.button [ H.onClickM_ $ navigate @(SPA m) RNew, H.class' "btn btn-primary" ] [ "Register" ] ] ] ]@@ -244,14 +244,14 @@ MEcho t -> H.div_ [ maybe (text "Erie silence") text t- , H.a [ H.onClickM_ . navigate @SPA $ RList mempty ] [ "Go To Space Craft Roster" ]+ , H.a [ H.onClickM_ . navigate @(SPA m) $ RList mempty ] [ "Go To Space Craft Roster" ] ] M404 -> text "404" -template :: Frontend -> Html m a -> Html m a-template fe stage = H.html_+template :: Env -> Frontend -> Html m a -> Html m a+template ev fe stage = H.html_ [ H.head_ [ H.link' [ H.rel "stylesheet"@@ -259,9 +259,11 @@ ] , H.meta [ H.charset "ISO-8859-1" ] [] , toHydration fe- , H.script [ H.src "/all.js" ] []+ , H.script [ H.src $ entrypoint ev ] [] ] , H.body_ [ stage ] ]++
widgets/Widgets.hs view
@@ -12,21 +12,30 @@ module Main where +import Control.Concurrent (threadDelay) import Control.Lens hiding (view) import Control.Monad.IO.Class (liftIO)-import Data.Text+import Data.Text (Text, pack) import Prelude hiding (div) -import Shpadoinkle-import Shpadoinkle.Backend.ParDiff+import Shpadoinkle (Html, JSM, MonadJSM,+ liftJSM, newTVarIO,+ shpadoinkle)+-- import Shpadoinkle.Backend.ParDiff (runParDiff)+import Shpadoinkle.Backend.Snabbdom (runSnabbdom) import Shpadoinkle.Html as H (a, button, class', div, div_, href, id', link',- rel, textProperty,+ onClick, onClickM, rel,+ text, textProperty, type')-import Shpadoinkle.Html.Utils-import Shpadoinkle.Lens+import Shpadoinkle.Html.Utils (getBody)+import Shpadoinkle.Lens (onRecord)+import Shpadoinkle.Run (runJSorWarp) import Shpadoinkle.Widgets.Form.Dropdown as Dropdown-import Shpadoinkle.Widgets.Types+import Shpadoinkle.Widgets.Types (Humanize (..), Pick (..),+ Present (..), Selected,+ Toggle (..), fullOptions,+ fullset, withOptions') default (Text)@@ -47,15 +56,29 @@ data Model = Model { _pickOne :: Dropdown 'One Cheese , _pickAtleastOne :: Dropdown 'AtleastOne Cheese+ , _concTest :: Int } deriving (Eq, Show) makeLenses ''Model -view :: Monad m => Model -> Html m Model+conc :: MonadJSM m => Int -> Html m Int+conc x = div_+ [ text . pack $ show x+ , button+ [ onClick (+ 1)+ , onClickM . liftJSM $ do+ liftIO $ threadDelay 3000000+ return (* 3)+ ] [ text "TEST" ]+ ]+++view :: MonadJSM m => Model -> Html m Model view m = div_ [ link' [ rel "stylesheet", href "https://stackpath.bootstrapcdn.com/bootstrap/4.3.1/css/bootstrap.min.css" ]- , generalize pickOne $ dropdown bootstrap defConfig { _attrs = [ id' "One" ] } (_pickOne m)- , generalize pickAtleastOne $ dropdown bootstrap defConfig { _attrs = [ id' "AtleastOne" ] } (_pickAtleastOne m)+ , onRecord pickOne $ dropdown bootstrap defConfig { _attrs = [ id' "One" ] } (_pickOne m)+ , onRecord pickAtleastOne $ dropdown bootstrap defConfig { _attrs = [ id' "AtleastOne" ] } (_pickAtleastOne m)+ , onRecord concTest $ conc $ _concTest m ] where bootstrap :: Present b => Present (Selected p b) => Dropdown p b -> Theme m p b@@ -80,13 +103,13 @@ initial :: Model-initial = Model fullOptions $ minBound `withOptions'` fullset+initial = Model fullOptions (minBound `withOptions'` fullset) 4 app :: JSM () app = do model <- liftIO $ newTVarIO initial- shpadoinkle id runParDiff initial model view getBody+ shpadoinkle id runSnabbdom initial model view getBody main :: IO ()