Shpadoinkle-examples-0.0.0.1: TODOMVCAtomic.hs

{-# 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