Shpadoinkle-examples 0.0.0.1 → 0.0.0.2
raw patch · 20 files changed
+795/−482 lines, 20 filesdep +Shpadoinkle-consoledep +easedep +generic-lensdep −Shpadoinkle-backend-snabbdomdep −servant-client-ghcjsdep ~basenew-component:exe:animationnew-component:exe:calculatornew-component:exe:calculator-ienew-component:exe:lensnew-component:exe:throttle-and-debounce
Dependencies added: Shpadoinkle-console, ease, generic-lens, ghcjs-dom, jsaddle, safe, servant-client-js, split
Dependencies removed: Shpadoinkle-backend-snabbdom, servant-client-ghcjs
Dependency ranges changed: base
Files
- Animation.hs +64/−0
- Calculator.hs +76/−0
- CalculatorIE.hs +205/−0
- Counter.hs +3/−3
- LICENSE +21/−20
- Lens.hs +84/−0
- README.md +6/−3
- Shpadoinkle-examples.cabal +96/−21
- TODOMVC.hs +118/−35
- TODOMVC/Types.hs +0/−40
- TODOMVC/Update.hs +0/−59
- TODOMVCAtomic.hs +0/−138
- TODOMVCAtomic/Types.hs +0/−61
- TODOMVCAtomic/Update.hs +0/−46
- ThrottleAndDebounce.hs +52/−0
- servant-crud/Client.hs +10/−6
- servant-crud/Server.hs +1/−0
- servant-crud/Types.hs +8/−5
- servant-crud/View.hs +29/−29
- widgets/Widgets.hs +22/−16
+ Animation.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+++module Main where+++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+++default (Text)+++left :: Double -> Text+left x = "transform:translate3d(150px, " <> pack (show $ x / 5) <> "px, 0)"+++easeRange :: Fractional b => b -> (b -> b) -> b -> b+easeRange r e = (* r) . e . (/ r)+++dur :: Double+dur = 3000+++view :: Double -> Html m a+view clock = H.div+ [ textProperty "style" $+ "position:absolute;background:red;padding:10px;" <> left+ (easeRange dur bounceOut clock) ]+ [ if | clock < 500 -> "Wat?"+ | clock < 1000 -> "AAAA!!"+ | clock < dur * 0.65 -> "Oh no!"+ | otherwise -> "I'm ok" ]+++animation :: Window -> TVar Double -> JSM ()+animation w t = void $ requestAnimationFrame w =<< go where+ go = newRequestAnimationFrameCallback $ \clock -> do+ liftIO . atomically $ writeTVar t clock+ r <- go+ if clock < dur then void $ requestAnimationFrame w r else return ()+++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
+ Calculator.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+++module Main where+++import Data.Maybe+import Data.Text+import Safe+import Shpadoinkle+import Shpadoinkle.Backend.ParDiff+import Shpadoinkle.Html+++data Model = Model+ { operation :: Operation+ , left :: Int+ , right :: Int+ } deriving (Eq, Show)+++data Operation+ = Addition+ | Subtraction+ | Multiplication+ | Division+ deriving (Eq, Show, Read, Enum, Bounded)+++opFunction :: Operation -> (Int -> Int -> Int)+opFunction = \case+ Addition -> (+)+ Subtraction -> (-)+ Multiplication -> (*)+ Division -> \x y ->+ if y == 0 then 0 else Prelude.div x y+++opText :: Operation -> Text+opText = \case+ Addition -> "+"+ Subtraction -> "-"+ Multiplication -> "×"+ Division -> "÷"+++opSelect :: Html m Operation+opSelect = select [ onOption $ read . unpack ]+ $ opOption <$> [minBound..maxBound]+ where opOption o = option [ value . pack $ show o ] [ text $ opText o ]+++num :: Int -> Html m Int+num x = input'+ [ value . pack $ show x+ , onInput $ 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)+ , text $ " = " <> pack (show $ opFunction+ (operation model) (left model) (right model))+ ]+++main :: IO ()+main = runJSorWarp 8080 $+ simple runParDiff (Model Addition 0 0) view getBody+
+ CalculatorIE.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}++module Main where++import Control.Lens+import Data.Aeson+import Data.FileEmbed+import Data.List as L+import Data.List.Split as L+import Data.Text+import Data.Text.Encoding+import GHC.Generics (Generic)+import Shpadoinkle+import Shpadoinkle.Backend.ParDiff+import Shpadoinkle.Console+import Shpadoinkle.Html as H++default (ClassList)++data Digit+ = Seven | Eight | Nine+ | Four | Five | Six+ | One | Two | Three+ | Zero deriving (Eq, Show, Ord, Enum, Bounded, Generic, ToJSON)++data Operator = Addition | Multiplication | Subtraction | Division+ deriving (Eq, Enum, Bounded, Generic, ToJSON)++instance Show Operator where+ show = \case+ Addition -> "+"+ Subtraction -> "−"+ Multiplication -> "×"+ Division -> "÷"++data Entry+ = Whole [Digit]+ | [Digit] :<.> [Digit]+ | Negate Entry+ deriving (Eq, Generic, ToJSON)++noEntry :: Entry+noEntry = Whole []++instance Show Entry where+ show = let asChar = traverse . re charDigit in \case+ Whole xs -> xs ^.. asChar+ xs :<.> ys -> xs ^.. asChar <> "." <> ys ^.. asChar+ Negate e -> '-' : show e++frac :: Iso' Entry Double+frac = iso toFrac fromFrac where+ toFrac =+ let f x = case L.reverse x of+ "" -> "0"+ '.':xs -> L.reverse xs+ _ -> x+ in read . f . show+ fromFrac d =+ let asChar = traverse . charDigit+ ab xs = case L.splitOn "." xs of+ [whole, []] -> Whole $ whole ^.. asChar+ [whole, dec] -> (whole ^.. asChar)+ :<.> (dec ^.. asChar)+ _ -> noEntry+ in case show d of+ '-':xs -> Negate $ ab xs+ xs -> ab xs++charDigit :: Prism' Char Digit+charDigit = prism'+ (\case Seven -> '7'; Eight -> '8'; Nine -> '9'+ Four -> '4'; Five -> '5'; Six -> '6'+ One -> '1'; Two -> '2'; Three -> '3'+ Zero -> '0')+ (\case '7' -> Just Seven; '8' -> Just Eight; '9' -> Just Nine+ '4' -> Just Four; '5' -> Just Five; '6' -> Just Six+ '1' -> Just One; '2' -> Just Two; '3' -> Just Three+ '0' -> Just Zero; _ -> Nothing)++data Operation = Operation+ { _operator :: Operator+ , _previous :: Entry+ } deriving (Eq, Show, Generic, ToJSON)++makeFieldsNoPrefix ''Operation++data Model = Model+ { _current :: Entry+ , _operation :: Maybe Operation+ } deriving (Eq, Show, Generic, ToJSON)++makeFieldsNoPrefix ''Model++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' ]+ 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) ]+ [ text . pack $ show o ]++applyDigit :: Digit -> Entry -> Entry+applyDigit d = \case+ Whole xs -> Whole $ xs <> [d]+ xs :<.> ys -> xs :<.> (ys <> [d])+ Negate e -> Negate $ applyDigit d e++addDecimal :: Entry -> Entry+addDecimal = \case+ Whole xs -> xs :<.> []+ ys -> ys++cleanEntry :: Entry -> Entry+cleanEntry = \case+ xs :<.> [] -> Whole xs+ xs :<.> [Zero] -> Whole xs+ x -> x++calcResult :: Model -> Model+calcResult x = x+ & operation .~ Nothing+ & current .~ case x ^. operation of+ Nothing -> x ^. current+ Just o -> let l = o ^. previous . frac; r = x ^. current . frac+ in cleanEntry . (^. from frac) $ case o ^. operator of+ Addition -> l + r+ Subtraction -> l - r+ Multiplication -> l * r+ Division -> if r == 0 then l else l / r++neg :: Entry -> Entry+neg = \case+ Negate e -> e+ e -> Negate e++readout :: Model -> Html m a+readout x = H.div "readout" $+ [ text . pack . show $ x ^. current+ ] <> case x ^? operation . traverse . operator of+ Nothing -> []+ Just o -> [ H.div "operator"+ [ text $ pack (show o) <> " " <>+ x ^. operation . traverse . previous . to (pack .show)+ ]+ ]++clear :: Html m Model+clear = button [ class' "clear", onClick initial ] [ "AC" ]++posNeg :: Model -> Html m Model+posNeg x = button [ class' "posNeg", onClick (x & current %~ neg) ] [ "-/+" ]++numberpad :: Model -> Html m Model+numberpad m = H.div "numberpad" . L.intercalate [ br'_ ] . L.chunksOf 3 $+ digit m <$> [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))+ & 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 ] [ "." ]++equals :: Model -> Html m Model+equals x = button [ class' "equals", onClick $ calcResult x ] [ "=" ]++view :: Monad m => Model -> Html m Model+view m = H.div "calculator"+ [ readout m+ , H.div "buttons"+ [ clear, posNeg m, operations m+ , numberpad m+ , H.div "zerodot"+ [ digit m Zero+ , dot m+ , equals m+ ]+ ]+ ]++main :: IO ()+main = runJSorWarp 8080 $ do+ setTitle "Calculator"+ ctx <- askJSM+ addInlineStyle $ decodeUtf8 $(embedFile "./CalculatorIE.css")+ Shpadoinkle.simple runParDiff initial (Main.view . trapper @ToJSON ctx) getBody
Counter.hs view
@@ -15,14 +15,14 @@ import Shpadoinkle.Html.Utils -view :: Applicative m => Int -> Html m Int+view :: Int -> Html m Int view count = div_ [ h2_ [ "Counter Example" ] , "The current count is: " , span [ id' "out" ] [ text (pack $ show count) ] , br'_, br'_- , button [ onClick (count - 1) ] [ "Decrement" ]- , button [ onClick (count + 1) ] [ "Increment" ]+ , button [ onClick $ count - 1 ] [ "Decrement" ]+ , button [ onClick $ count + 1 ] [ "Increment" ] ]
LICENSE view
@@ -1,26 +1,27 @@-Shpadoinkle Examples, I think I know exactly what it means-Copyright © 2019 Isaac Shpaira+Shpadoinkle Examples aka S11 Examples+Copyright © 2020 Isaac Shapira All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:-1. Redistributions of source code must retain the above copyright-notice, this list of conditions and the following disclaimer.-2. Redistributions in binary form must reproduce the above copyright-notice, this list of conditions and the following disclaimer in the-documentation and/or other materials provided with the distribution.-3. Neither the name of the <`3:organization`> nor the-names of its contributors may be used to endorse or promote products-derived from this software without specific prior written permission. -THIS SOFTWARE IS PROVIDED BY <|2|> ''AS IS'' AND ANY-EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED-WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE-DISCLAIMED. IN NO EVENT SHALL <|2|> BE LIABLE FOR ANY-DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES-(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;-LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND-ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS-SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+ * Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+ * Neither the name of Shpadoinkle nor the names of its contributors may be+ used to endorse or promote products derived from this software without+ specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Lens.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+++module Main where+++import Control.Lens ((^.))+import Data.Generics.Labels ()+import Data.Maybe (fromMaybe)+import Data.Text (Text, pack, unpack)+import GHC.Generics (Generic)+import Safe (readMay)+import Shpadoinkle (Html, JSM, runJSorWarp, simple,+ text)+import Shpadoinkle.Backend.ParDiff (runParDiff)+import Shpadoinkle.Html (button, div_, for', getBody, id',+ input', label, onClick, onInput,+ value)+import Shpadoinkle.Lens (onRecord, onSum)+++data Form = Form+ { name :: Text+ , age :: Int+ } deriving (Eq, Show, Generic)+++form :: Functor m => Form -> Html m Form+form f = div_+ [ label [ for' "name" ] [ "Name" ]+ , onRecord #name $ input'+ [ id' "name"+ , value $ f ^. #name+ , onInput id+ ]+ , label [ for' "age" ] [ "Age" ]+ , onRecord #age $ input'+ [ id' "age"+ , value . pack . show $ f ^. #age+ , onInput $ fromMaybe 0 . readMay . unpack+ ]+ ]+++newtype Counter = Counter Int+ deriving (Eq, Ord, Num, Show, Generic)+++counter :: Counter -> Html m Counter+counter c = div_+ [ label [ for' "counter" ] [ text . pack $ show c ]+ , button [ id' "counter", onClick $ c + 1 ] [ "Increment" ]+ ]+++data Model+ = MCounter Counter+ | MForm Form+ deriving (Eq, Show, Generic)+++view :: Applicative m => Model -> Html m Model+view = \case+ MCounter c -> div_+ [ onSum #_MCounter $ counter c+ , button [ onClick . MForm $ Form "" 18 ] [ "Go to Form" ]+ ]+ MForm f -> div_+ [ onSum #_MForm $ form f+ , button [ onClick $ MCounter 0 ] [ "Go to Counter" ]+ ]+++app :: JSM ()+app = simple runParDiff (MCounter 0) view getBody+++main :: IO ()+main = runJSorWarp 8080 app+
README.md view
@@ -8,12 +8,15 @@ [](https://matrix.hackage.haskell.org/#/package/Shpadoinkle-examples) Work in progress developing a compelling collection of example applications using Shpadoinkle.-This repo will be used with the Shpadoinkle tutorial when it's finished.+This repo will be used with the Shpadoinkle tutorial when it is finished. ## Complete examples -- Simple counter-- TODOMVC+- [Counter](https://fresheyeball.gitlab.io/Shpadoinkle/examples/counter.jsexe/)+- [TODOMVC](https://fresheyeball.gitlab.io/Shpadoinkle/examples/todomvc.jsexe/)+- [Widgets](https://fresheyeball.gitlab.io/Shpadoinkle/examples/widgets.jsexe/)+- [Calculator](https://fresheyeball.gitlab.io/Shpadoinkle/examples/calculator.jsexe/)+- [Immediate Execution](https://fresheyeball.gitlab.io/Shpadoinkle/examples/calculator-ie.jsexe/) - Servant CRUD using Widgets This package also houses experimental designs, and other explorations.
Shpadoinkle-examples.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 1659b859dd98837a87a964e0cf7684da9755b756eacede1a890dab6740e71d01+-- hash: 21985c60c92f72c182e14dfac317f3e717d0ca271e4b587fdf362594753f26ba name: Shpadoinkle-examples-version: 0.0.0.1+version: 0.0.0.2 synopsis: Example usages of Shpadoinkle description: A collection of illustrative applications to show various Shpadoinkle utilities. category: Web@@ -24,6 +24,62 @@ type: git location: https://gitlab.com/fresheyeball/Shpadoinkle.git +executable animation+ main-is: Animation.hs+ 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+ build-depends:+ Shpadoinkle+ , Shpadoinkle-backend-pardiff+ , Shpadoinkle-html+ , base >=4.12.0 && <4.16+ , ease+ , ghcjs-dom+ , stm+ , text+ default-language: Haskell2010++executable calculator+ main-is: Calculator.hs+ 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+ build-depends:+ Shpadoinkle+ , Shpadoinkle-backend-pardiff+ , Shpadoinkle-html+ , Shpadoinkle-lens+ , Shpadoinkle-widgets+ , base >=4.12.0 && <4.16+ , lens+ , safe+ , text+ default-language: Haskell2010++executable calculator-ie+ main-is: CalculatorIE.hs+ 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+ build-depends:+ Shpadoinkle+ , Shpadoinkle-backend-pardiff+ , Shpadoinkle-console+ , Shpadoinkle-html+ , Shpadoinkle-widgets+ , aeson+ , base >=4.12.0 && <4.16+ , file-embed+ , lens+ , safe+ , split+ , text+ default-language: Haskell2010+ executable counter main-is: Counter.hs hs-source-dirs:@@ -34,11 +90,29 @@ Shpadoinkle , Shpadoinkle-backend-pardiff , Shpadoinkle-html- , base >=4.12.0 && <4.15+ , base >=4.12.0 && <4.16 , stm , text default-language: Haskell2010 +executable lens+ main-is: Lens.hs+ 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+ build-depends:+ Shpadoinkle+ , Shpadoinkle-backend-pardiff+ , Shpadoinkle-html+ , Shpadoinkle-lens+ , base >=4.12.0 && <4.16+ , generic-lens+ , lens+ , safe+ , text+ default-language: Haskell2010+ executable servant-crud-client main-is: Client.hs other-modules:@@ -57,11 +131,12 @@ , Shpadoinkle-router , Shpadoinkle-widgets , aeson- , base >=4.12.0 && <4.15+ , base >=4.12.0 && <4.16 , beam-core , bytestring , containers , exceptions+ , jsaddle , lens , mtl , servant@@ -70,7 +145,7 @@ , unliftio if impl(ghcjs) build-depends:- servant-client-ghcjs+ servant-client-js else build-depends: beam-sqlite@@ -96,7 +171,7 @@ , Shpadoinkle-router , Shpadoinkle-widgets , aeson- , base >=4.12.0 && <4.15+ , base >=4.12.0 && <4.16 , beam-core , beam-sqlite , bytestring@@ -119,11 +194,8 @@ buildable: True default-language: Haskell2010 -executable todomvc- main-is: TODOMVC.hs- other-modules:- TODOMVC.Types- TODOMVC.Update+executable throttle-and-debounce+ main-is: ThrottleAndDebounce.hs hs-source-dirs: ./. ghc-options: -Wall -Wcompat -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities@@ -131,27 +203,28 @@ build-depends: Shpadoinkle , Shpadoinkle-backend-pardiff+ , Shpadoinkle-console , Shpadoinkle-html- , base >=4.12.0 && <4.15- , containers+ , base >=4.12.0 && <4.16+ , lens+ , safe , text default-language: Haskell2010 -executable todomvcatomic- main-is: TODOMVCAtomic.hs- other-modules:- TODOMVCAtomic.Types- TODOMVCAtomic.Update+executable todomvc+ main-is: TODOMVC.hs 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 build-depends: Shpadoinkle- , Shpadoinkle-backend-snabbdom+ , Shpadoinkle-backend-pardiff , Shpadoinkle-html- , base >=4.12.0 && <4.15+ , Shpadoinkle-lens+ , base >=4.12.0 && <4.16 , containers+ , generic-lens , lens , text default-language: Haskell2010@@ -168,8 +241,10 @@ Shpadoinkle , Shpadoinkle-backend-pardiff , Shpadoinkle-html+ , Shpadoinkle-lens , Shpadoinkle-widgets- , base >=4.12.0 && <4.15+ , base >=4.12.0 && <4.16+ , lens , stm , text default-language: Haskell2010
TODOMVC.hs view
@@ -1,30 +1,113 @@-{-# LANGUAGE ExtendedDefaultRules #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} module Main where +import Control.Lens hiding (view)+import Data.Generics.Labels ()+import Data.String import Data.Text hiding (count, filter, length)+import GHC.Generics import Prelude hiding (div, unwords) import Shpadoinkle import Shpadoinkle.Backend.ParDiff-import Shpadoinkle.Html hiding (main)+import Shpadoinkle.Html import Shpadoinkle.Html.LocalStorage import Shpadoinkle.Html.Memo-import Shpadoinkle.Html.Utils--import TODOMVC.Types-import TODOMVC.Update+import Shpadoinkle.Lens default (Text) -filterHtml :: Applicative m => Visibility -> Visibility -> Html m Visibility+newtype Description = Description { unDescription :: Text } deriving (Generic, Show, Read, Eq, IsString)+newtype TaskId = TaskId { unTaskId :: Int } deriving (Generic, Show, Read, Eq, Ord, Num)+++data Completed = Complete | Incomplete+ deriving (Generic, Show, Read, Eq)+++data Visibility = All | Active | Completed+ deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded)+++data Task = Task+ { description :: Description+ , completed :: Completed+ , taskId :: TaskId+ } deriving (Generic, Show, Read, Eq)+++data Model = Model+ { tasks :: [Task]+ , editing :: Maybe TaskId+ , visibility :: Visibility+ , current :: Description+ } deriving (Generic, Show, Read, Eq)+++emptyModel :: Model+emptyModel = Model [] Nothing All (Description "")+++appendItem :: Model -> Model+appendItem m = if current m /= "" then m+ & #tasks %~ (Task (current m) Incomplete newId :)+ & #current .~ "" else m+ where newId = Prelude.maximum (0 : (taskId <$> tasks m)) + 1+++toggleCompleted :: TaskId -> Model -> Model+toggleCompleted tid m = m & #tasks . mapped %~ \t ->+ if taskId t == tid then t & #completed %~ negC else t+ where negC Complete = Incomplete+ negC Incomplete = Complete+++toggleEditing :: Maybe TaskId -> Model -> Model+toggleEditing t = #editing .~ t+++updateTaskDescription :: TaskId -> Description -> Model -> Model+updateTaskDescription tid desc m = m & #tasks . mapped %~ \t ->+ if taskId t == tid then t & #description .~ desc else t+++removeTask :: TaskId -> Model -> Model+removeTask tid m = m & #tasks %~ filter ((/= tid) . taskId)+++toggleAll :: Model -> Model+toggleAll m = m & #tasks . traverse . #completed .~ c+ where c = if Prelude.all ((== Complete) . completed) $ tasks m then Incomplete else Complete+++count :: Completed -> [Task] -> Int+count c = length . filter ((== c) . completed)+++clearComplete :: Model -> Model+clearComplete = #tasks %~ filter ((== Incomplete) . completed)+++toVisible :: Visibility -> [Task] -> [Task]+toVisible v = case v of+ All -> id+ Active -> filter $ (== Incomplete) . completed+ Completed -> filter $ (== Complete) . completed+++filterHtml :: Visibility -> Visibility -> Html m Visibility filterHtml = memo2 $ \cur item -> li_- [ a (href "#" : onClick item : [className ("selected", cur == item)]) [ text . pack $ show item ]+ [ a (href "#" : onClick item+ : [class' ("selected", cur == item)]) [ text . pack $ show item ] ] @@ -32,42 +115,43 @@ htmlIfTasks m h' = if Prelude.null (tasks m) then [] else h' -taskView :: MonadJSM m => Model -> Task -> Html m Model+taskView :: Model -> Task -> Html m Model taskView m = memo $ \(Task (Description d) c tid) -> li [ id' . pack . show $ unTaskId tid- , className [ ("completed", c == Complete)- , ("editing", Just tid == editing m) ]+ , class' [ ("completed", c == Complete)+ , ("editing", Just tid == editing m)+ ] ] [ div "view" [ input' [ type' "checkbox"- , className "toggle"- , onChange $ toggleCompleted m tid+ , class' "toggle"+ , onChange $ toggleCompleted tid m , checked $ c == Complete ]- , label [ onDblclick (toggleEditing m (Just tid)) ] [ text d ]- , button' [ className "destroy", onClick (removeTask m tid) ]+ , label [ onDblclick $ toggleEditing (Just tid) m ] [ text d ]+ , button' [ class' "destroy", onClick $ removeTask tid m ] ]- , form [ onSubmit $ toggleEditing m Nothing ]- [ input' [ className "edit"+ , form [ onSubmit $ toggleEditing Nothing m ]+ [ input' [ class' "edit" , value d- , onInput $ updateTaskDescription m tid . Description+ , onInput $ ($ m) . updateTaskDescription tid . Description , autofocus True- , onBlur $ toggleEditing m Nothing+ , onBlur $ toggleEditing Nothing m ] ] ] -listFooter :: Applicative m => Model -> Html m Model+listFooter :: Functor m => Model -> Html m Model listFooter model = footer "footer" $ [ Shpadoinkle.Html.span "todo-count" $ let co = count Incomplete $ tasks model in [ strong_ [ text . pack $ show co ] , text $ " item" <> (if co == 1 then "" else "s") <> " left" ]- , ul "filters" $ fmap (\v -> model { visibility = v })- <$> (filterHtml (visibility model) <$> [minBound..maxBound])+ , ul "filters" $ generalize #visibility .+ filterHtml (visibility model) <$> [minBound..maxBound] ] ++ (if count Complete (tasks model) == 0 then [] else- [ button [ className "clear-completed", onClick $ clearComplete model ] [ "Clear completed" ]+ [ button [ class' "clear-completed", onClick $ clearComplete model ] [ "Clear completed" ] ]) @@ -80,33 +164,33 @@ ] -newTaskForm :: MonadJSM m => Model -> Html m Model-newTaskForm model = form [ className "todo-form", onSubmit (appendItem model) ]- [ input' [ className "new-todo"+newTaskForm :: Model -> Html m Model+newTaskForm model = form [ class' "todo-form", onSubmit (appendItem model) ]+ [ input' [ class' "new-todo" , value . unDescription $ current model- , onInput $ updateDescription model . Description+ , onInput $ ($ model) . (#current .~) . Description , placeholder "What needs to be done?" ] ] -todoList :: MonadJSM m => Model -> Html m Model-todoList model = ul "todo-list" $ taskView model <$> toVisible (visibility model) (tasks model)+todoList :: Model -> Html m Model+todoList model = ul "todo-list" $ taskView model <$> visibility model `toVisible` tasks model -toggleAllBtn :: Applicative m => Model -> [Html m Model]+toggleAllBtn :: Model -> [Html m Model] toggleAllBtn model =- [ input' [ id' "toggle-all", className "toggle-all", type' "checkbox", onChange (toggleAll model) ]+ [ input' [ id' "toggle-all", class' "toggle-all", type' "checkbox", onChange $ toggleAll model ] , label [ for' "toggle-all" ] [ "Mark all as complete" ] ] -view :: MonadJSM m => Model -> Html m Model+view :: Functor m => Model -> Html m Model view model = div_ [ section "todoapp" $ header "header" [ h1_ [ "todos" ], newTaskForm model ] : htmlIfTasks model- [ section "main" $ toggleAllBtn model ++ [ todoList model ]+ [ section "main" $ toggleAllBtn model <> [ todoList model ] , listFooter model ] , info@@ -126,4 +210,3 @@ main = do putStrLn "running app" runJSorWarp 8080 app-
− TODOMVC/Types.hs
@@ -1,40 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}---module TODOMVC.Types where---import Data.String-import Data.Text---newtype Description = Description { unDescription :: Text } deriving (Show, Read, Eq, IsString)-newtype TaskId = TaskId { unTaskId :: Int } deriving (Show, Read, Eq, Ord, Num)---data Completed = Complete | Incomplete- deriving (Show, Read, Eq)---data Visibility = All | Active | Completed- deriving (Show, Read, Eq, Ord, Enum, Bounded)---data Task = Task- { description :: Description- , completed :: Completed- , taskId :: TaskId- } deriving (Show, Read, Eq)---data Model = Model- { tasks :: [Task]- , editing :: Maybe TaskId- , visibility :: Visibility- , current :: Description- } deriving (Show, Read, Eq)---emptyModel :: Model-emptyModel = Model [] Nothing All (Description "")
− TODOMVC/Update.hs
@@ -1,59 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---module TODOMVC.Update where---import TODOMVC.Types---appendItem :: Model -> Model-appendItem m = if current m /= "" then m- { tasks = Task (current m) Incomplete ((+ 1)- $ Prelude.maximum $ 0 : (taskId <$> tasks m)) : tasks m- , current = "" }- else m---updateDescription :: Model -> Description -> Model-updateDescription m d = m { current = d }---toggleCompleted :: Model -> TaskId -> Model-toggleCompleted m tid = m { tasks =- (\t -> if taskId t == tid then t { completed = negC (completed t) } else t) <$> tasks m }- where negC Complete = Incomplete- negC Incomplete = Complete---toggleEditing :: Model -> Maybe TaskId -> Model-toggleEditing m t = m { editing = t }---updateTaskDescription :: Model -> TaskId -> Description -> Model-updateTaskDescription m tid desc = m { tasks = f <$> tasks m}- where f t = if taskId t == tid then t { description = desc } else t---removeTask :: Model -> TaskId -> Model-removeTask m tid = m { tasks = filter ((/= tid) . taskId) $ tasks m}---toggleAll :: Model -> Model-toggleAll m = m { tasks = (\t -> t { completed = c }) <$> tasks m}- where c = if Prelude.all ((== Complete) . completed) $ tasks m then Incomplete else Complete---count :: Completed -> [Task] -> Int-count c = length . filter ((== c) . completed)---clearComplete :: Model -> Model-clearComplete m = m { tasks = filter ((== Incomplete) . completed) (tasks m) }---toVisible :: Visibility -> [Task] -> [Task]-toVisible v = case v of- All -> id- Active -> filter $ (== Incomplete) . completed- Completed -> filter $ (== Complete) . completed
− TODOMVCAtomic.hs
@@ -1,138 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ExtendedDefaultRules #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS_GHC -fno-warn-type-defaults #-}---module Main where---import Control.Lens (set, to, (%~), (.~), (?~), (^.),- _Wrapped)-import Data.Text hiding (count, filter, length)-import Prelude hiding (div, unwords)-import Shpadoinkle-import Shpadoinkle.Backend.Snabbdom-import Shpadoinkle.Html hiding (main)-import Shpadoinkle.Html.LocalStorage-import Shpadoinkle.Html.Memo-import Shpadoinkle.Html.Utils--import TODOMVCAtomic.Types-import TODOMVCAtomic.Update---default (Text)---filterHtml :: Applicative m => Eq v => Show v => v -> v -> Html m v-filterHtml = memo $ \cur item -> li_- [ a [href "#" , onClick item , className [("selected", cur == item)]] [ text . pack $ show item ]- ]---htmlIfTasks :: [b] -> [Html m a] -> [Html m a]-htmlIfTasks m h' = if Prelude.null m then [] else h'---taskView :: MonadJSM m => Maybe TaskId -> Task -> Html m (Model -> Model)-taskView = memo $ \ed (Task (Description d) c tid) ->- li [ id' . pack . show $ tid ^. _Wrapped- , className [ ("completed", c == Complete)- , ("editing", Just tid == ed) ]- ]- [ div "view"- [ input' [ type' "checkbox"- , className "toggle"- , onChange $ toggleCompleted tid- , checked $ c == Complete- ]- , label [ onDblclick $ editing ?~ tid ] [ text d ]- , button' [ className "destroy", onClick $ tasks %~ filter ((/= tid) . _taskId) ]- ]- , form [ onSubmit $ editing .~ Nothing ]- [ input' [ className "edit"- , value d- , onInput $ updateTaskDescription tid . Description- , autofocus True- , onBlur $ editing .~ Nothing- ]- ]- ]---listFooter :: Applicative m => Int -> Int -> Visibility -> Html m (Model -> Model)-listFooter = memo $ \ic cc v -> footer "footer" $- [ Shpadoinkle.Html.span "todo-count"- [ strong_ [ text . pack $ show ic ]- , text $ " item" <> (if ic == 1 then "" else "s") <> " left"- ]- , ul "filters" $ fmap (set visibility) . filterHtml v <$> [minBound..maxBound]- ] ++ (if cc == 0 then [] else- [ button [ className "clear-completed", onClick clearComplete ] [ "Clear completed" ]- ])----info :: Html m a-info = footer "info"- [ p_ [ "Double-click to edit a todo" ]- , p_ [ "Credits ", a [ href "https://twitter.com/fresheyeball" ] [ "Isaac Shapira" ] ]- , p_ [ "Part of ", a [ href "http://todomvc.com" ] [ "TodoMVC" ] ]- ]---newTaskForm :: MonadJSM m => Description -> Html m (Model -> Model)-newTaskForm = memo $ \desc -> form [ className "todo-form", onSubmit appendItem' ]- [ input' [ className "new-todo"- , value $ desc ^. _Wrapped- , onInput . set $ current . _Wrapped- , placeholder "What needs to be done?" ]- ]---todoList :: MonadJSM m => Maybe TaskId -> Visibility -> [Task] -> Html m (Model -> Model)-todoList = memo $ \ed v ts -> ul "todo-list" $ taskView ed <$> toVisible v ts---toggleAllBtn :: Applicative m => [Html m (Model -> Model)]-toggleAllBtn =- [ input' [ id' "toggle-all", className "toggle-all", type' "checkbox", onChange toggleAll ]- , label [ for' "toggle-all" ] [ "Mark all as complete" ]- ]---apply :: Functor m => a -> Html m (a -> b) -> Html m b-apply m v = ($ m) <$> v----render :: MonadJSM m => Model -> Html m Model-render m = div_- [ section "todoapp" $- header "header"- [ h1_ [ "todos" ], apply m . newTaskForm $ m ^. current ]- : htmlIfTasks (m ^. tasks)- [ section "main" $ (apply m <$> toggleAllBtn) ++ [ apply m $ todoList (m ^. editing) (m ^. visibility) (m ^. tasks) ]- , apply m $ listFooter (m ^. tasks . to (count Incomplete))- (m ^. tasks . to (count Complete))- (m ^. visibility)- ]- , info- ]---app :: JSM ()-app = do- model <- manageLocalStorage "todo" emptyModel- 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"- initial <- readTVarIO model- shpadoinkle id runSnabbdom initial model render stage---main :: IO ()-main = runJSorWarp 8080 app-
− TODOMVCAtomic/Types.hs
@@ -1,61 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}---module TODOMVCAtomic.Types where---import Control.Lens.TH-import Data.String-import Data.Text---newtype Description = Description { _unDescription :: Text } deriving (Show, Read, Eq, IsString)-newtype TaskId = TaskId { _unTaskId :: Int } deriving (Show, Read, Eq, Ord, Num)---makeWrapped ''Description-makeWrapped ''TaskId---data Completed = Complete | Incomplete- deriving (Show, Read, Eq)---makePrisms ''Completed---data Visibility = All | Active | Completed- deriving (Show, Read, Eq, Ord, Enum, Bounded)---makePrisms ''Visibility---data Task = Task- { _description :: Description- , _completed :: Completed- , _taskId :: TaskId- } deriving (Show, Read, Eq)---makeLenses ''Task---data Model = Model- { _tasks :: [Task]- , _editing :: Maybe TaskId- , _visibility :: Visibility- , _current :: Description- } deriving (Show, Read, Eq)---makeLenses ''Model---emptyModel :: Model-emptyModel = Model [] Nothing All (Description "")
− TODOMVCAtomic/Update.hs
@@ -1,46 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---module TODOMVCAtomic.Update where---import TODOMVCAtomic.Types---appendItem' :: Model -> Model-appendItem' m = if _current m /= "" then m- { _tasks = Task (_current m) Incomplete ((+ 1)- $ Prelude.maximum $ 0 : (_taskId <$> _tasks m)) : _tasks m- , _current = "" }- else m--toggleCompleted :: TaskId -> Model -> Model-toggleCompleted tid m = m { _tasks =- (\t -> if _taskId t == tid then t { _completed = negC (_completed t) } else t) <$> _tasks m }- where negC Complete = Incomplete- negC Incomplete = Complete---updateTaskDescription :: TaskId -> Description -> Model -> Model-updateTaskDescription tid desc m = m { _tasks = f <$> _tasks m}- where f t = if _taskId t == tid then t { _description = desc } else t---toggleAll :: Model -> Model-toggleAll m = m { _tasks = (\t -> t { _completed = c }) <$> _tasks m}- where c = if Prelude.all ((== Complete) . _completed) $ _tasks m then Incomplete else Complete---count :: Completed -> [Task] -> Int-count c = length . filter ((== c) . _completed)---clearComplete :: Model -> Model-clearComplete m = m { _tasks = filter ((== Incomplete) . _completed) (_tasks m) }---toVisible :: Visibility -> [Task] -> [Task]-toVisible v = case v of- All -> id- Active -> filter $ (== Incomplete) . _completed- Completed -> filter $ (== Complete) . _completed
+ ThrottleAndDebounce.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+++module Main where+++import Control.Monad.IO.Class+import Data.Text (Text, pack)+import Shpadoinkle+import Shpadoinkle.Backend.ParDiff+import Shpadoinkle.Html+++type Model = (Int, Text)+++type App = ParDiffT Model JSM+++data Control m = Control+ (Debounce m Model Model)+ (Debounce m (Text -> Model) Model)+ (Throttle m Model Model)+ (Throttle m (Text -> 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_ [ text txt ]+ , div_ [ text "Throttled input", input [ runThrottle throttler2 onInput (count,) ] [ ] ]+ ]+++app :: Control App -> JSM ()+app control = do+ model <- liftIO $ newTVarIO initial+ shpadoinkle id runParDiff initial model (view control) getBody+ where initial = (0, "")+++main :: IO ()+main = do+ control <- Control <$> debounce 1 <*> debounce 2 <*> throttle 1 <*> throttle 2+ runJSorWarp 8080 (app control)
servant-crud/Client.hs view
@@ -12,11 +12,15 @@ import Control.Monad.Catch (MonadThrow) import Control.Monad.Reader (MonadIO) import Data.Proxy (Proxy (..))+import Language.Javascript.JSaddle (askJSM, runJSM) 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 (..)) @@ -37,11 +41,11 @@ instance CRUDSpaceCraft App where- listSpaceCraft = runXHR App listSpaceCraftM- getSpaceCraft = runXHR App . getSpaceCraftM- updateSpaceCraft x y = runXHR App $ updateSpaceCraftM x y- createSpaceCraft = runXHR App . createSpaceCraftM- deleteSpaceCraft = runXHR App . deleteSpaceCraftM+ listSpaceCraft = App $ runXHR listSpaceCraftM+ getSpaceCraft x = App . runXHR $ getSpaceCraftM x+ updateSpaceCraft x y = App . runXHR $ updateSpaceCraftM x y+ createSpaceCraft x = App . runXHR $ createSpaceCraftM x+ deleteSpaceCraft x = App . runXHR $ deleteSpaceCraftM x (listSpaceCraftM :<|> getSpaceCraftM :<|> updateSpaceCraftM :<|> createSpaceCraftM :<|> deleteSpaceCraftM)@@ -49,7 +53,7 @@ app :: JSM ()-app = fullPageSPA @ SPA runApp runParDiff (withHydration start) view getBody (const . start) routes+app = fullPageSPA @ SPA runApp runParDiff (withHydration start) view getBody start routes main :: IO ()
servant-crud/Server.hs view
@@ -27,6 +27,7 @@ import Servant.Server import Shpadoinkle+import Shpadoinkle.Router (MonadJSM) import Shpadoinkle.Router.Server import Types
servant-crud/Types.hs view
@@ -155,7 +155,7 @@ instance (FromJSON (Column [SpaceCraft])) => FromJSON Frontend -makeLenses ''Frontend+makePrisms ''Frontend data Route@@ -244,7 +244,7 @@ toRows = fmap SpaceCraftRow - toCell xs (SpaceCraftRow SpaceCraft {..}) = \case+ toCell _ (SpaceCraftRow SpaceCraft {..}) = \case SKUT -> present _sku DescriptionT -> present _description SerialNumberT -> present _serial@@ -252,9 +252,12 @@ OperableT -> present _operable ToolsT -> [ H.div "btn-group"- [ H.button [ H.class' "btn btn-sm btn-secondary", H.onClick' (xs <$ navigate @ SPA (RExisting _identity)) ] [ "Edit" ]- , H.button [ H.class' "btn btn-sm btn-secondary", H.onClick' (Prelude.filter (\x -> x ^. identity /= _identity) xs- <$ deleteSpaceCraft _identity) ] [ "Delete" ]+ [ H.button [ H.className "btn btn-sm btn-secondary",+ H.onClickM_ $ navigate @ SPA (RExisting _identity) ] [ "Edit" ]+ , H.button [ H.className "btn btn-sm btn-secondary",+ H.onClickM $ do+ deleteSpaceCraft _identity+ return . Prelude.filter $ \x -> x ^. identity /= _identity ] [ "Delete" ] ] ]
servant-crud/View.hs view
@@ -29,7 +29,7 @@ import Data.Text as T import Shpadoinkle (Html, MonadJSM, text) import qualified Shpadoinkle.Html as H-import Shpadoinkle.Lens ((<%), (<+))+import Shpadoinkle.Lens import Shpadoinkle.Router (navigate, toHydration) import Shpadoinkle.Widgets.Form.Dropdown as Dropdown (Dropdown (..), Theme (..),@@ -45,7 +45,7 @@ Selected, Status (..), Toggle (..), Validated (..), fullset, fuzzySearch,- getValid, humanize,+ getValid, humanize, present, validate, withOptions') import Types@@ -78,7 +78,7 @@ , H.div "col-sm-10" $ [ ef <% l . mapping (fromMaybe "" `iso` noEmpty) $ Input.text [ H.name' hName- , H.className ("form-control":controlClass (errs ^. l) (ef ^. l .hygiene))+ , H.class' ("form-control":controlClass (errs ^. l) (ef ^. l .hygiene)) ] ] <> invalid (errs ^. l) (ef ^. l . hygiene)@@ -95,9 +95,9 @@ intControl l msg errs ef = formGroup [ H.label [ H.for' hName, H.class' "col-sm-2 col-form-label" ] [ text msg ] , H.div "col-sm-10" $- [ ef <% l $ Input.integral @m+ [ ef <% l $ Input.integral $ [ H.name' hName, H.step "1", H.min "0"- , H.className ("form-control":controlClass (errs ^. l) (ef ^. l .hygiene))+ , H.class' ("form-control":controlClass (errs ^. l) (ef ^. l .hygiene)) ] ] <> invalid (errs ^. l) (ef ^. l . hygiene)@@ -108,7 +108,7 @@ :: forall p x m a . MonadJSM m => Control (Dropdown p) => Considered p ~ Maybe => Consideration ConsideredChoice p- => Present (Selected p x) => Present x => Ord x+ => Present (Selected p x) => Ord 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@@ -121,19 +121,19 @@ where bootstrap Dropdown {..} = Dropdown.Theme { _wrapper = H.div- [ H.className [ ("dropdown", True)- , ("show", _toggle == Open) ]+ [ H.class' [ ("dropdown", True)+ , ("show", _toggle == Open) ] ]- , _header = pure . H.button- [ H.className ([ "btn", "btn-secondary", "dropdown-toggle" ] :: [Text])+ , _header = \cs -> pure $ H.button+ [ H.class' ([ "btn", "btn-secondary", "dropdown-toggle" ] :: [Text]) , H.type' "button"- ]+ ] (present cs) , _list = H.div- [ H.className [ ("dropdown-menu", True)- , ("show", _toggle == Open) ]+ [ H.class' [ ("dropdown-menu", True)+ , ("show", _toggle == Open) ] ]- , _item = H.a [ H.className "dropdown-item"- , H.textProperty "style" "cursor:pointer" ]+ , _item = const $ H.a' [ H.className "dropdown-item"+ , H.textProperty "style" "cursor:pointer" ] } @@ -163,17 +163,17 @@ , H.div "d-flex flex-row justify-content-end" [ H.button- [ H.onClick' (ef <$ navigate @SPA (RList mempty))+ [ H.onClickM_ . navigate @SPA $ RList mempty , H.class' "btn btn-secondary" ] [ "Cancel" ] , H.button- [ H.onClick' $ case isValid of- Nothing -> return ef+ [ H.onClickM_ $ case isValid of+ Nothing -> return () Just up -> do case mid of Nothing -> () <$ createSpaceCraft up Just sid -> updateSpaceCraft sid up- ef <$ navigate @SPA (RList mempty)+ navigate @SPA (RList mempty) , H.class' "btn btn-primary" , H.disabled $ isNothing isValid ] [ "Save" ]@@ -197,8 +197,8 @@ tableCfg :: Table.Theme m [SpaceCraft] tableCfg = mempty- { tableProps = [ H.class' "table table-striped table-bordered" ]- , tdProps = \case+ { tableProps = const . const . pure $ H.class' "table table-striped table-bordered"+ , tdProps = const . const . const $ \case ToolsT -> [ H.width 1 ] _ -> "align-middle" }@@ -217,7 +217,7 @@ view :: (MonadJSM m, CRUDSpaceCraft m) => Frontend -> Html m Frontend view fe = case fe of - MList r -> MList <$> H.div "container-fluid"+ MList r -> onSum _MList $ H.div "container-fluid" [ H.div "row justify-content-between align-items-center" [ H.h2_ [ "Space Craft Roster" ] , H.div [ H.class' "input-group"@@ -225,16 +225,16 @@ ] [ r <% search $ Input.search [ H.class' "form-control", H.placeholder "Search" ] , H.div "input-group-append mr-3"- [ H.button [ H.onClick' (r <$ navigate @SPA RNew), H.class' "btn btn-primary" ] [ "Register" ]+ [ H.button [ H.onClickM_ $ navigate @SPA RNew, H.class' "btn btn-primary" ] [ "Register" ] ] ] ]- , r <+ lensProduct table sort $ Table.viewWith tableCfg- (r ^. table . to (fuzzySearch fuzzy $ r ^. search . value))- (r ^. sort)+ , onRecord (lensProduct table sort) $ Table.viewWith tableCfg+ (r ^. table . to (fuzzySearch fuzzy $ r ^. search . value))+ (r ^. sort) ] - MDetail sid form -> MDetail sid <$> H.div "row"+ MDetail sid form -> onSum (_MDetail . _2) $ H.div "row" [ H.div "col-sm-8 offset-sm-2" [ H.h2_ [ text $ maybe "Register New Space Craft" (const "Edit Space Craft") sid ]@@ -244,7 +244,7 @@ MEcho t -> H.div_ [ maybe (text "Erie silence") text t- , H.a [ H.onClick' (fe <$ navigate @SPA (RList $ Input Clean "")) ] [ "Go To Space Craft Roster" ]+ , H.a [ H.onClickM_ . navigate @SPA $ RList mempty ] [ "Go To Space Craft Roster" ] ] M404 -> text "404"@@ -255,7 +255,7 @@ [ H.head_ [ H.link' [ H.rel "stylesheet"- , H.href "https://cdn.usebootstrap.com/bootstrap/4.3.1/css/bootstrap.min.css"+ , H.href "https://cdnjs.cloudflare.com/ajax/libs/twitter-bootstrap/4.3.1/css/bootstrap.min.css" ] , H.meta [ H.charset "ISO-8859-1" ] [] , toHydration fe
widgets/Widgets.hs view
@@ -1,25 +1,30 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} module Main where +import Control.Lens hiding (view) import Control.Monad.IO.Class (liftIO) import Data.Text import Prelude hiding (div) import Shpadoinkle import Shpadoinkle.Backend.ParDiff-import Shpadoinkle.Html as H (a, button, className,- div, div_, href, id',- link', rel,- textProperty, type')+import Shpadoinkle.Html as H (a, button, class', div,+ div_, href, id', link',+ rel, textProperty,+ type') import Shpadoinkle.Html.Utils+import Shpadoinkle.Lens import Shpadoinkle.Widgets.Form.Dropdown as Dropdown import Shpadoinkle.Widgets.Types @@ -43,34 +48,35 @@ { _pickOne :: Dropdown 'One Cheese , _pickAtleastOne :: Dropdown 'AtleastOne Cheese } deriving (Eq, Show)+makeLenses ''Model -view :: MonadJSM m => Model -> Html m Model+view :: Monad m => Model -> Html m Model view m = div_ [ link' [ rel "stylesheet", href "https://stackpath.bootstrapcdn.com/bootstrap/4.3.1/css/bootstrap.min.css" ]- , (\x -> m {_pickOne = x}) <$>- dropdown bootstrap defConfig { _attrs = [ id' "One" ] } (_pickOne m)- , (\x -> m {_pickAtleastOne = x}) <$>- dropdown bootstrap defConfig { _attrs = [ id' "AtleastOne" ] } (_pickAtleastOne m)+ , generalize pickOne $ dropdown bootstrap defConfig { _attrs = [ id' "One" ] } (_pickOne m)+ , generalize pickAtleastOne $ dropdown bootstrap defConfig { _attrs = [ id' "AtleastOne" ] } (_pickAtleastOne m) ] where+ bootstrap :: Present b => Present (Selected p b) => Dropdown p b -> Theme m p b bootstrap Dropdown {..} = Dropdown.Theme { _wrapper = div- [ className [ ("dropdown", True)- , ("show", _toggle == Open) ]+ [ class' [ ("dropdown", True)+ , ("show", _toggle == Open) ] ] , _header = pure . button- [ className ([ "btn", "btn-secondary", "dropdown-toggle" ] :: [Text])+ [ class' ([ "btn", "btn-secondary", "dropdown-toggle" ] :: [Text]) , type' "button" ]+ . present , _list = div- [ className [ ("dropdown-menu", True)- , ("show", _toggle == Open) ]+ [ class' [ ("dropdown-menu", True)+ , ("show", _toggle == Open) ] ]- , _item = a [ className "dropdown-item"+ , _item = a [ class' "dropdown-item" , textProperty "style" "cursor:pointer" ]+ . present }- initial :: Model