Shpadoinkle-examples (empty) → 0.0.0.1
raw patch · 17 files changed
+1640/−0 lines, 17 filesdep +Shpadoinkledep +Shpadoinkle-backend-pardiffdep +Shpadoinkle-backend-snabbdom
Dependencies added: Shpadoinkle, Shpadoinkle-backend-pardiff, Shpadoinkle-backend-snabbdom, Shpadoinkle-backend-static, Shpadoinkle-html, Shpadoinkle-lens, Shpadoinkle-router, Shpadoinkle-widgets, aeson, base, beam-core, beam-sqlite, bytestring, containers, exceptions, file-embed, lens, mtl, optparse-applicative, servant, servant-client, servant-client-ghcjs, servant-server, sqlite-simple, stm, text, unliftio, wai, wai-app-static, warp
Files
- CHANGELOG.md +0/−0
- Counter.hs +37/−0
- LICENSE +26/−0
- README.md +19/−0
- Shpadoinkle-examples.cabal +175/−0
- TODOMVC.hs +129/−0
- TODOMVC/Types.hs +40/−0
- TODOMVC/Update.hs +59/−0
- TODOMVCAtomic.hs +138/−0
- TODOMVCAtomic/Types.hs +61/−0
- TODOMVCAtomic/Update.hs +46/−0
- servant-crud/Client.hs +58/−0
- servant-crud/Server.hs +115/−0
- servant-crud/Types.hs +271/−0
- servant-crud/Types/Prim.hs +112/−0
- servant-crud/View.hs +267/−0
- widgets/Widgets.hs +87/−0
+ CHANGELOG.md view
+ Counter.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE OverloadedStrings #-}+++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 (br'_, button, div_, h2_, id',+ onClick, span)+import Shpadoinkle.Html.Utils+++view :: Applicative m => 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" ]+ ]+++app :: JSM ()+app = do+ model <- liftIO $ newTVarIO 0+ shpadoinkle id runParDiff 0 model view getBody+++main :: IO ()+main = runJSorWarp 8080 app+
+ LICENSE view
@@ -0,0 +1,26 @@+Shpadoinkle Examples, I think I know exactly what it means+Copyright © 2019 Isaac Shpaira+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.+
+ README.md view
@@ -0,0 +1,19 @@+# Shpadoinkle Examples++[](https://gitlab.com/fresheyeball/Shpadoinkle)+[](https://opensource.org/licenses/BSD-3-Clause)+[](https://builtwithnix.org)+[](https://hackage.haskell.org/package/Shpadoinkle-examples)+[](http://packdeps.haskellers.com/reverse/Shpadoinkle-examples)+[](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.++## Complete examples++- Simple counter+- TODOMVC+- Servant CRUD using Widgets++This package also houses experimental designs, and other explorations.
+ Shpadoinkle-examples.cabal view
@@ -0,0 +1,175 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.32.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 1659b859dd98837a87a964e0cf7684da9755b756eacede1a890dab6740e71d01++name: Shpadoinkle-examples+version: 0.0.0.1+synopsis: Example usages of Shpadoinkle+description: A collection of illustrative applications to show various Shpadoinkle utilities.+category: Web+author: Isaac Shapira+maintainer: fresheyeball@protonmail.com+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ CHANGELOG.md++source-repository head+ type: git+ location: https://gitlab.com/fresheyeball/Shpadoinkle.git++executable counter+ main-is: Counter.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.15+ , stm+ , text+ default-language: Haskell2010++executable servant-crud-client+ main-is: Client.hs+ other-modules:+ Types+ Types.Prim+ View+ 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+ build-depends:+ Shpadoinkle+ , Shpadoinkle-backend-pardiff+ , Shpadoinkle-html+ , Shpadoinkle-lens+ , Shpadoinkle-router+ , Shpadoinkle-widgets+ , aeson+ , base >=4.12.0 && <4.15+ , beam-core+ , bytestring+ , containers+ , exceptions+ , lens+ , mtl+ , servant+ , stm+ , text+ , unliftio+ if impl(ghcjs)+ build-depends:+ servant-client-ghcjs+ else+ build-depends:+ beam-sqlite+ , servant-client+ , sqlite-simple+ default-language: Haskell2010++executable servant-crud-server+ main-is: Server.hs+ other-modules:+ Types.Prim+ Types+ View+ 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+ build-depends:+ Shpadoinkle+ , Shpadoinkle-backend-static+ , Shpadoinkle-html+ , Shpadoinkle-lens+ , Shpadoinkle-router+ , Shpadoinkle-widgets+ , aeson+ , base >=4.12.0 && <4.15+ , beam-core+ , beam-sqlite+ , bytestring+ , containers+ , file-embed+ , lens+ , mtl+ , optparse-applicative+ , servant+ , servant-server+ , sqlite-simple+ , stm+ , text+ , wai+ , wai-app-static+ , warp+ if impl(ghcjs)+ buildable: False+ else+ buildable: True+ default-language: Haskell2010++executable todomvc+ main-is: TODOMVC.hs+ other-modules:+ TODOMVC.Types+ TODOMVC.Update+ 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.15+ , containers+ , text+ default-language: Haskell2010++executable todomvcatomic+ main-is: TODOMVCAtomic.hs+ other-modules:+ TODOMVCAtomic.Types+ TODOMVCAtomic.Update+ 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-html+ , base >=4.12.0 && <4.15+ , containers+ , lens+ , text+ default-language: Haskell2010++executable widgets+ main-is: Widgets.hs+ other-modules:+ Paths_Shpadoinkle_examples+ 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+ build-depends:+ Shpadoinkle+ , Shpadoinkle-backend-pardiff+ , Shpadoinkle-html+ , Shpadoinkle-widgets+ , base >=4.12.0 && <4.15+ , stm+ , text+ default-language: Haskell2010
+ TODOMVC.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+++module Main where+++import Data.Text hiding (count, filter, length)+import Prelude hiding (div, unwords)+import Shpadoinkle+import Shpadoinkle.Backend.ParDiff+import Shpadoinkle.Html hiding (main)+import Shpadoinkle.Html.LocalStorage+import Shpadoinkle.Html.Memo+import Shpadoinkle.Html.Utils++import TODOMVC.Types+import TODOMVC.Update+++default (Text)+++filterHtml :: Applicative m => Visibility -> Visibility -> Html m Visibility+filterHtml = memo2 $ \cur item -> li_+ [ a (href "#" : onClick item : [className ("selected", cur == item)]) [ text . pack $ show item ]+ ]+++htmlIfTasks :: Model -> [Html m a] -> [Html m a]+htmlIfTasks m h' = if Prelude.null (tasks m) then [] else h'+++taskView :: MonadJSM m => 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) ]+ ]+ [ div "view"+ [ input' [ type' "checkbox"+ , className "toggle"+ , onChange $ toggleCompleted m tid+ , checked $ c == Complete+ ]+ , label [ onDblclick (toggleEditing m (Just tid)) ] [ text d ]+ , button' [ className "destroy", onClick (removeTask m tid) ]+ ]+ , form [ onSubmit $ toggleEditing m Nothing ]+ [ input' [ className "edit"+ , value d+ , onInput $ updateTaskDescription m tid . Description+ , autofocus True+ , onBlur $ toggleEditing m Nothing+ ]+ ]+ ]+++listFooter :: Applicative 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])+ ] ++ (if count Complete (tasks model) == 0 then [] else+ [ button [ className "clear-completed", onClick $ clearComplete model ] [ "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 => Model -> Html m Model+newTaskForm model = form [ className "todo-form", onSubmit (appendItem model) ]+ [ input' [ className "new-todo"+ , value . unDescription $ current model+ , onInput $ updateDescription model . 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)+++toggleAllBtn :: Applicative m => Model -> [Html m Model]+toggleAllBtn model =+ [ input' [ id' "toggle-all", className "toggle-all", type' "checkbox", onChange (toggleAll model) ]+ , label [ for' "toggle-all" ] [ "Mark all as complete" ]+ ]+++view :: MonadJSM m => Model -> Html m Model+view model = div_+ [ section "todoapp" $+ header "header"+ [ h1_ [ "todos" ], newTaskForm model ]+ : htmlIfTasks model+ [ section "main" $ toggleAllBtn model ++ [ todoList model ]+ , listFooter model+ ]+ , info+ ]+++app :: JSM ()+app = do+ model <- manageLocalStorage "todo" emptyModel+ 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+++main :: IO ()+main = do+ putStrLn "running app"+ runJSorWarp 8080 app+
+ TODOMVC/Types.hs view
@@ -0,0 +1,40 @@+{-# 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 view
@@ -0,0 +1,59 @@+{-# 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 view
@@ -0,0 +1,138 @@+{-# 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 view
@@ -0,0 +1,61 @@+{-# 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 view
@@ -0,0 +1,46 @@+{-# 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
+ servant-crud/Client.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+++module Main where+++import Control.Monad.Catch (MonadThrow)+import Control.Monad.Reader (MonadIO)+import Data.Proxy (Proxy (..))+import Servant.API ((:<|>) (..))+import Shpadoinkle+import Shpadoinkle.Backend.ParDiff (runParDiff)+import Shpadoinkle.Html.Utils (getBody)+import Shpadoinkle.Router (fullPageSPA, withHydration)+import Shpadoinkle.Router.Client (client, runXHR)+import UnliftIO (MonadUnliftIO (..), UnliftIO (..))++import Types+import View+++newtype App a = App { runApp :: JSM a }+ deriving (Functor, Applicative, Monad, MonadIO, MonadThrow)+#ifndef ghcjs_HOST_OS+ deriving (MonadJSM)+#endif+++instance MonadUnliftIO App where+ {-# INLINE askUnliftIO #-}+ askUnliftIO = do ctx <- askJSM; return $ UnliftIO $ \(App m) -> runJSM m ctx+++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+++(listSpaceCraftM :<|> getSpaceCraftM :<|> updateSpaceCraftM :<|> createSpaceCraftM :<|> deleteSpaceCraftM)+ = client (Proxy @ API)+++app :: JSM ()+app = fullPageSPA @ SPA runApp runParDiff (withHydration start) view getBody (const . start) routes+++main :: IO ()+main = do+ putStrLn "running app"+ runJSorWarp 8080 app
+ servant-crud/Server.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -fno-warn-missing-methods #-}+++module Main 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 Servant.API+import Servant.Server++import Shpadoinkle+import Shpadoinkle.Router.Server++import Types+import View+++data Options = Options+ { assets :: FilePath+ , port :: Int+ }+++newtype App a = App { runApp :: ReaderT Connection IO a }+ deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader Connection)+++toHandler :: MonadIO m => Connection -> App ~> m+toHandler c a = liftIO $ runReaderT (runApp a) c+++parser :: Parser Options+parser = Options+ <$> strOption (long "assets" <> short 'a' <> metavar "FILEPATH")+ <*> option auto (long "port" <> short 'p' <> metavar "PORT" <> showDefault <> value 8080)+++options :: ParserInfo Options+options = info (parser <**> helper) $+ fullDesc <> progDesc "Servant CRUD Example"+ <> header "Space craft manager as an example of Shpadoinkle"+++runSql :: (MonadIO m, MonadReader Connection m) => SqliteM ~> m+runSql x = do conn <- ask; liftIO $ runBeamSqlite conn x+++newtype Noop a = Noop (JSM a)+ deriving newtype (Functor, Applicative, Monad, MonadIO, MonadJSM)+ deriving anyclass CRUDSpaceCraft+++instance CRUDSpaceCraft App where++ listSpaceCraft =+ runSql . runSelectReturningList . select . all_ $ _roster db++ getSpaceCraft i =+ runSql . runSelectReturningOne . select+ . filter_ (\s -> val_ (SpaceCraftKey i) ==. primaryKey s) . all_ $ _roster db++ updateSpaceCraft i SpaceCraftUpdate {..} =+ runSql . runUpdate $ save (_roster db) $+ SpaceCraft i _sku _description _serial _squadron _operable++ deleteSpaceCraft i =+ runSql . runDelete $ delete (_roster db) $ \sc -> val_ (SpaceCraftKey i) ==. primaryKey sc++ createSpaceCraft SpaceCraftUpdate {..} =+ runSql . fmap (_identity . head) . runInsertReturningList . insert (_roster db) $ insertExpressions+ [ 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+ where++ serveApi :: Server API+ serveApi = hoistServer (Proxy @ API) (toHandler conn)+ $ listSpaceCraft+ :<|> getSpaceCraft+ :<|> updateSpaceCraft+ :<|> createSpaceCraft+ :<|> deleteSpaceCraft++ serveSpa :: Server SPA+ serveSpa = serveUI @ SPA root+ (\r -> toHandler conn $ do+ i <- start r; return . template i $ view @ Noop i) routes+++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
+ servant-crud/Types.hs view
@@ -0,0 +1,271 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+++module Types (module Types, module Types.Prim) where+++import Control.Lens as Lens hiding (Context)+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 Servant.API hiding (Description)+import Shpadoinkle+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 Types.Prim+++data SpaceCraftT f = SpaceCraft+ { _identity :: Columnar f SpaceCraftId+ , _sku :: Columnar f SKU+ , _description :: Columnar (Nullable f) Description+ , _serial :: Columnar f SerialNumber+ , _squadron :: Columnar f Squadron+ , _operable :: Columnar f Operable+ } deriving (Generic, Beamable)+++instance Table SpaceCraftT where+ newtype PrimaryKey SpaceCraftT f = SpaceCraftKey (Columnar f SpaceCraftId) deriving (Generic) deriving anyclass (Beamable)+ primaryKey = SpaceCraftKey . _identity+++type SpaceCraft = SpaceCraftT Identity+deriving instance Eq SpaceCraft+deriving instance Ord SpaceCraft+deriving instance Show SpaceCraft+deriving instance ToJSON SpaceCraft+deriving instance FromJSON SpaceCraft+++makeFieldsNoPrefix ''SpaceCraftT+++newtype DB f = DB { _roster :: f (TableEntity SpaceCraftT) } deriving (Generic) deriving anyclass (Database be)+++db :: DatabaseSettings be DB+db = defaultDbSettings+++data SpaceCraftUpdate s = SpaceCraftUpdate+ { _sku :: Field s Text Input SKU+ , _description :: Field s Text Input (Maybe Description)+ , _serial :: Field s Text Input SerialNumber+ , _squadron :: Field s Text (Dropdown 'One) Squadron+ , _operable :: Field s Text (Dropdown 'AtleastOne) Operable+ } deriving Generic+++deriving instance Eq (SpaceCraftUpdate 'Valid)+deriving instance Ord (SpaceCraftUpdate 'Valid)+deriving instance Show (SpaceCraftUpdate 'Valid)+deriving instance ToJSON (SpaceCraftUpdate 'Valid)+deriving instance FromJSON (SpaceCraftUpdate 'Valid)++deriving instance Eq (SpaceCraftUpdate 'Edit)+deriving instance Ord (SpaceCraftUpdate 'Edit)+deriving instance Show (SpaceCraftUpdate 'Edit)+deriving instance ToJSON (SpaceCraftUpdate 'Edit)+deriving instance FromJSON (SpaceCraftUpdate 'Edit)++deriving instance Show (SpaceCraftUpdate 'Errors)+++instance Validate SpaceCraftUpdate where+ rules = SpaceCraftUpdate+ { _sku = positive <> nonZero+ , _description = nonMEmpty+ , _serial = between (30, maxBound)+ , _squadron = maybe (throwError "Cannot be empty") pure+ , _operable = pure+ }+++makeFieldsNoPrefix ''SpaceCraftUpdate+++data Roster = Roster+ { _sort :: SortCol [SpaceCraft]+ , _search :: Input Search+ , _table :: [SpaceCraft]+ }+++deriving instance Eq Roster+deriving instance Ord Roster+deriving instance Show Roster+deriving instance Generic Roster+instance (ToJSON (Table.Column [SpaceCraft])) => ToJSON Roster+instance (FromJSON (Table.Column [SpaceCraft])) => FromJSON Roster+++makeFieldsNoPrefix ''Roster+++emptyEditForm :: SpaceCraftUpdate 'Edit+emptyEditForm = SpaceCraftUpdate+ { _sku = Input Clean 0+ , _description = Input Clean Nothing+ , _serial = Input Clean 0+ , _squadron = fullOptions+ , _operable = fullOptionsMin+ }+++data Frontend+ = MEcho (Maybe Text)+ | MList Roster+ | MDetail (Maybe SpaceCraftId) (SpaceCraftUpdate 'Edit)+ | M404+ deriving (Eq, Ord, Show, Generic)+++instance (ToJSON (Column [SpaceCraft])) => ToJSON Frontend+instance (FromJSON (Column [SpaceCraft])) => FromJSON Frontend+++makeLenses ''Frontend+++data Route+ = REcho (Maybe Text)+ | RList (Input Search)+ | RNew+ | RExisting SpaceCraftId+ deriving (Eq, Ord, Show, Generic)+++makeLenses ''Route+++type API = "api" :> "space-craft" :> Get '[JSON] [SpaceCraft]+ :<|> "api" :> "space-craft" :> Capture "id" SpaceCraftId :> Get '[JSON] (Maybe SpaceCraft)+ :<|> "api" :> "space-craft" :> Capture "id" SpaceCraftId :> ReqBody '[JSON] (SpaceCraftUpdate 'Valid) :> Post '[JSON] ()+ :<|> "api" :> "space-craft" :> ReqBody '[JSON] (SpaceCraftUpdate 'Valid) :> Put '[JSON] SpaceCraftId+ :<|> "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+++routes :: SPA :>> Route+routes = REcho+ :<|> RNew+ :<|> RExisting+ :<|> RList . Input Clean . fromMaybe ""+ :<|> RList (Input Clean "")+++deriving newtype instance ToHttpApiData Search+deriving newtype instance FromHttpApiData Search+++instance Routed SPA 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))+++class CRUDSpaceCraft m where+ listSpaceCraft :: m [SpaceCraft]+ getSpaceCraft :: SpaceCraftId -> m (Maybe SpaceCraft)+ updateSpaceCraft :: SpaceCraftId -> SpaceCraftUpdate 'Valid -> m ()+ createSpaceCraft :: SpaceCraftUpdate 'Valid -> m SpaceCraftId+ deleteSpaceCraft :: SpaceCraftId -> m ()+++instance (MonadTrans t, Monad m, CRUDSpaceCraft m) => CRUDSpaceCraft (t m) where+ listSpaceCraft = lift listSpaceCraft+ getSpaceCraft = lift . getSpaceCraft+ updateSpaceCraft x = lift . updateSpaceCraft x+ createSpaceCraft = lift . createSpaceCraft+ deleteSpaceCraft = lift . deleteSpaceCraft+++instance Humanize (Column [SpaceCraft]) where+ humanize = \case+ SKUT -> "SKU"+ DescriptionT -> "Desc"+ SerialNumberT -> "Serial #"+ SquadronT -> "Squadron"+ OperableT -> "Status"+ ToolsT -> ""+++data instance Column [SpaceCraft] =+ SKUT | DescriptionT | SerialNumberT | SquadronT | OperableT | ToolsT+ deriving (Eq, Ord, Show, Enum, Bounded, Generic, ToJSON, FromJSON)+++newtype instance Row [SpaceCraft] = SpaceCraftRow { unRow :: SpaceCraft }+ deriving (Eq, Ord, Show)+++instance Tabular [SpaceCraft] where++ type Effect [SpaceCraft] m = (MonadJSM m, CRUDSpaceCraft m)++ toRows = fmap SpaceCraftRow++ toCell xs (SpaceCraftRow SpaceCraft {..}) = \case+ SKUT -> present _sku+ DescriptionT -> present _description+ SerialNumberT -> present _serial+ SquadronT -> present _squadron+ 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" ]+ ]+ ]++ sortTable (SortCol c d) = f $ case c of+ SKUT -> g sku+ DescriptionT -> g description+ SerialNumberT -> g serial+ SquadronT -> g squadron+ OperableT -> g operable+ 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
@@ -0,0 +1,112 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# 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++#ifndef ghcjs_HOST_OS+import Database.Beam.Backend.SQL.SQL92+import Database.Beam.Sqlite+import Database.Beam.Sqlite.Syntax+import Database.SQLite.Simple.FromField+#endif++import Servant.API hiding (Description)+import Shpadoinkle.Widgets.Types+++newtype SKU = SKU { unSKU :: Int }+ deriving stock Generic+ deriving newtype (Real, Enum, Integral, Eq, Ord, Show, Read, Num, ToJSON, FromJSON)+ deriving anyclass (Humanize, Present)+#ifndef ghcjs_HOST_OS+ deriving newtype (FromBackendRow Sqlite, HasSqlValueSyntax SqliteValueSyntax, HasSqlEqualityCheck Sqlite)+#endif+instance Semigroup SKU where SKU x <> SKU y = SKU $ x + y+instance Monoid SKU where mempty = SKU 0+++newtype Description = Description { unDescription :: Text }+ deriving stock (Generic)+ deriving newtype (Eq, Ord, Show, Read, IsString, ToJSON, FromJSON, Humanize, Semigroup, Monoid)+ deriving anyclass (Present)+#ifndef ghcjs_HOST_OS+ deriving newtype (FromBackendRow Sqlite, HasSqlValueSyntax SqliteValueSyntax, HasSqlEqualityCheck Sqlite)+#endif++instance Humanize (Maybe Description) where+ humanize = maybe "N/A" humanize+++newtype SerialNumber = SerialNumber { unSerialNumber :: Int }+ deriving stock Generic+ deriving newtype (Enum, Bounded, Real, Integral, Eq, Ord, Show, Num, ToJSON, FromJSON)+ deriving anyclass (Humanize, Present)+#ifndef ghcjs_HOST_OS+ deriving newtype (FromBackendRow Sqlite, HasSqlValueSyntax SqliteValueSyntax, HasSqlEqualityCheck Sqlite)+#endif+instance Semigroup SerialNumber where SerialNumber x <> SerialNumber y = SerialNumber $ x + y+instance Monoid SerialNumber where mempty = SerialNumber 0+++newtype SpaceCraftId = SpaceCraftId { unSpaceCraftId :: Int }+ deriving newtype ( Eq, Ord, Show, Num, ToJSON, FromJSON, FromHttpApiData, ToHttpApiData)+ deriving anyclass (Humanize, Present)+#ifndef ghcjs_HOST_OS+ deriving newtype (FromBackendRow Sqlite, HasSqlValueSyntax SqliteValueSyntax, HasSqlEqualityCheck Sqlite)+#endif+++data Operable = Operational | Inoperable+ deriving (Eq, Ord, Enum, Bounded, Read, Show, Humanize, Present, Generic, ToJSON, FromJSON)+#ifndef ghcjs_HOST_OS+ deriving (FromBackendRow Sqlite, HasSqlEqualityCheck Sqlite)+instance HasSqlValueSyntax be String => HasSqlValueSyntax be Operable where sqlValueSyntax = autoSqlValueSyntax+#endif+instance Semigroup Operable where (<>) = min+instance Monoid Operable where mempty = maxBound+++data Squadron = AwayTeam | StrikeForce | Scout+ deriving (Eq, Ord, Enum, Bounded, Read, Show, Present, Generic, ToJSON, FromJSON)+#ifndef ghcjs_HOST_OS+ deriving (FromBackendRow Sqlite)+instance HasSqlValueSyntax be String => HasSqlValueSyntax be Squadron where sqlValueSyntax = autoSqlValueSyntax+#endif+instance Semigroup Squadron where x <> _ = x+++#ifndef ghcjs_HOST_OS+instance FromField Operable where fromField = fmap read <$> fromField+instance FromField Squadron where fromField = fmap read <$> fromField+#endif+++instance Humanize Squadron where+ humanize = \case+ AwayTeam -> "Away Team"+ StrikeForce -> "Strike Force"+ Scout -> "Scouting"+++instance Humanize (Maybe Squadron) where+ humanize = maybe "N/A" humanize+
+ servant-crud/View.hs view
@@ -0,0 +1,267 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+++module View where+++import Control.Lens hiding (view)+import Control.Lens.Unsound (lensProduct)+import Data.Coerce (Coercible)+import Data.Maybe (fromMaybe, isNothing)+import Data.String (IsString)+import Data.Text as T+import Shpadoinkle (Html, MonadJSM, text)+import qualified Shpadoinkle.Html as H+import Shpadoinkle.Lens ((<%), (<+))+import Shpadoinkle.Router (navigate, toHydration)+import Shpadoinkle.Widgets.Form.Dropdown as Dropdown (Dropdown (..),+ Theme (..),+ defConfig,+ dropdown)+import qualified Shpadoinkle.Widgets.Form.Input as Input+import Shpadoinkle.Widgets.Table as Table+import Shpadoinkle.Widgets.Types (Consideration, Considered,+ ConsideredChoice,+ Control (..), Field,+ Hygiene (..), Input (..),+ Pick (..), Present,+ Selected, Status (..),+ Toggle (..), Validated (..),+ fullset, fuzzySearch,+ getValid, humanize,+ validate, withOptions')++import Types+++default (Text, [])+++toEditForm :: SpaceCraft -> SpaceCraftUpdate 'Edit+toEditForm sc = SpaceCraftUpdate+ { _sku = pure $ sc ^. sku+ , _description = pure $ sc ^. description+ , _serial = pure $ sc ^. serial+ , _squadron = (sc ^. squadron) `withOptions'` fullset+ , _operable = (sc ^. operable) `withOptions'` fullset+ }+++formGroup :: [Html m a] -> Html m a+formGroup = H.div "form-group row"+++textControl+ :: forall t m a+ . Eq t => IsString t => Coercible Text t => MonadJSM m+ => (forall v. Lens' (a v) (Field v Text Input (Maybe t)))+ -> Text -> a 'Errors -> a 'Edit -> Html m (a 'Edit)+textControl 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 . mapping (fromMaybe "" `iso` noEmpty) $ Input.text+ [ H.name' hName+ , H.className ("form-control":controlClass (errs ^. l) (ef ^. l .hygiene))+ ]+ ]+ <> invalid (errs ^. l) (ef ^. l . hygiene)+ ] where hName = toHtmlName msg+ noEmpty "" = Nothing+ noEmpty x = Just x+++intControl+ :: forall n m a+ . MonadJSM m => Integral n => Show n+ => (forall v. Lens' (a v) (Field v Text Input n))+ -> Text -> a 'Errors -> a 'Edit -> Html m (a 'Edit)+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+ $ [ H.name' hName, H.step "1", H.min "0"+ , H.className ("form-control":controlClass (errs ^. l) (ef ^. l .hygiene))+ ]+ ]+ <> invalid (errs ^. l) (ef ^. l . hygiene)+ ] where hName = toHtmlName msg+++selectControl+ :: forall p x m a+ . MonadJSM m => Control (Dropdown p)+ => Considered p ~ Maybe => Consideration ConsideredChoice p+ => Present (Selected p x) => Present 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+ [ H.label [ H.for' (toHtmlName msg)+ , H.class' "col-sm-2 col-form-label" ] [ text msg ]+ , H.div "col-sm-10" $+ [ ef <% l $ dropdown bootstrap defConfig ]+ <> invalid (errs ^. l) (ef ^. l . hygiene)+ ]+ where+ bootstrap Dropdown {..} = Dropdown.Theme+ { _wrapper = H.div+ [ H.className [ ("dropdown", True)+ , ("show", _toggle == Open) ]+ ]+ , _header = pure . H.button+ [ H.className ([ "btn", "btn-secondary", "dropdown-toggle" ] :: [Text])+ , H.type' "button"+ ]+ , _list = H.div+ [ H.className [ ("dropdown-menu", True)+ , ("show", _toggle == Open) ]+ ]+ , _item = H.a [ H.className "dropdown-item"+ , H.textProperty "style" "cursor:pointer" ]+ }+++controlClass :: Validated e a -> Hygiene -> [Text]+controlClass (Invalid _ _) Dirty = ["is-invalid"]+controlClass (Validated _) Dirty = ["is-valid"]+controlClass _ Clean = []+++invalid :: Validated Text a -> Hygiene -> [ Html m b ]+invalid (Invalid err errs) Dirty = (\e -> H.div "invalid-feedback" [ text e ]) <$> err:errs+invalid _ _ = []+++toHtmlName :: Text -> Text+toHtmlName = toLower . replace " " "-"+++editForm :: (CRUDSpaceCraft m, MonadJSM m) => Maybe SpaceCraftId -> SpaceCraftUpdate 'Edit -> Html m (SpaceCraftUpdate 'Edit)+editForm mid ef = H.div_++ [ intControl @SKU sku "SKU" errs ef+ , textControl @Description description "Description" errs ef+ , intControl @SerialNumber serial "Serial Number" errs ef+ , selectControl @'One @Squadron squadron "Squadron" errs ef+ , selectControl @'AtleastOne @Operable operable "Operable" errs ef+ , H.div "d-flex flex-row justify-content-end"++ [ H.button+ [ H.onClick' (ef <$ navigate @SPA (RList mempty))+ , H.class' "btn btn-secondary"+ ] [ "Cancel" ]++ , H.button+ [ H.onClick' $ case isValid of+ Nothing -> return ef+ Just up -> do+ case mid of Nothing -> () <$ createSpaceCraft up+ Just sid -> updateSpaceCraft sid up+ ef <$ navigate @SPA (RList mempty)+ , H.class' "btn btn-primary"+ , H.disabled $ isNothing isValid+ ] [ "Save" ]++ ]+ ] where errs = validate ef+ isValid = getValid errs+++start :: (Monad m, CRUDSpaceCraft m) => Route -> m Frontend+start = \case+ RList s -> MList . Roster (SortCol SKUT ASC) s <$> listSpaceCraft+ REcho t -> return $ MEcho t+ RNew -> return $ MDetail Nothing emptyEditForm+ RExisting i -> do+ mcraft <- getSpaceCraft i+ return $ case mcraft of+ Just craft -> MDetail (Just i) $ toEditForm craft+ _ -> M404+++tableCfg :: Table.Theme m [SpaceCraft]+tableCfg = mempty+ { tableProps = [ H.class' "table table-striped table-bordered" ]+ , tdProps = \case+ ToolsT -> [ H.width 1 ]+ _ -> "align-middle"+ }+++fuzzy :: [SpaceCraft -> Text]+fuzzy = flip (^.) <$>+ [ sku . to humanize+ , description . to humanize+ , serial . to humanize+ , squadron . to humanize+ , operable . to humanize+ ]+++view :: (MonadJSM m, CRUDSpaceCraft m) => Frontend -> Html m Frontend+view fe = case fe of++ MList r -> 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"+ , H.textProperty "style" ("width:300px" :: Text)+ ]+ [ 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" ]+ ]+ ]+ ]+ , r <+ lensProduct table sort $ Table.viewWith tableCfg+ (r ^. table . to (fuzzySearch fuzzy $ r ^. search . value))+ (r ^. sort)+ ]++ MDetail sid form -> MDetail sid <$> H.div "row"+ [ H.div "col-sm-8 offset-sm-2"+ [ H.h2_ [ text $ maybe "Register New Space Craft" (const "Edit Space Craft") sid+ ]+ , editForm sid form+ ]+ ]++ 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" ]+ ]++ M404 -> text "404"+++template :: Frontend -> Html m a -> Html m a+template fe stage = H.html_+ [ H.head_+ [ H.link'+ [ H.rel "stylesheet"+ , H.href "https://cdn.usebootstrap.com/bootstrap/4.3.1/css/bootstrap.min.css"+ ]+ , H.meta [ H.charset "ISO-8859-1" ] []+ , toHydration fe+ , H.script [ H.src "/all.js" ] []+ ]+ , H.body_+ [ stage+ ]+ ]
+ widgets/Widgets.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+++module Main where+++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.Utils+import Shpadoinkle.Widgets.Form.Dropdown as Dropdown+import Shpadoinkle.Widgets.Types+++default (Text)+++data Cheese = Cheddar | Munster | Mozzeralla+ deriving (Show, Eq, Ord, Bounded, Enum)+++instance Humanize Cheese where+ humanize = pack . show+++instance Humanize (Maybe Cheese) where+ humanize = maybe "Please Select" humanize+++data Model = Model+ { _pickOne :: Dropdown 'One Cheese+ , _pickAtleastOne :: Dropdown 'AtleastOne Cheese+ } deriving (Eq, Show)+++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" ]+ , (\x -> m {_pickOne = x}) <$>+ dropdown bootstrap defConfig { _attrs = [ id' "One" ] } (_pickOne m)+ , (\x -> m {_pickAtleastOne = x}) <$>+ dropdown bootstrap defConfig { _attrs = [ id' "AtleastOne" ] } (_pickAtleastOne m)+ ]+ where+ bootstrap Dropdown {..} = Dropdown.Theme+ { _wrapper = div+ [ className [ ("dropdown", True)+ , ("show", _toggle == Open) ]+ ]+ , _header = pure . button+ [ className ([ "btn", "btn-secondary", "dropdown-toggle" ] :: [Text])+ , type' "button"+ ]+ , _list = div+ [ className [ ("dropdown-menu", True)+ , ("show", _toggle == Open) ]+ ]+ , _item = a [ className "dropdown-item"+ , textProperty "style" "cursor:pointer" ]+ }++++initial :: Model+initial = Model fullOptions $ minBound `withOptions'` fullset+++app :: JSM ()+app = do+ model <- liftIO $ newTVarIO initial+ shpadoinkle id runParDiff initial model view getBody+++main :: IO ()+main = runJSorWarp 8080 app