Todos.hs

{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE OverloadedStrings #-}
module Main where

import           Control.Monad        (forever, void)
import           Control.Monad.State  (StateT, execStateT, get, lift, put)

import qualified Data.JSString        as JSS
import           Data.List            (intersperse)
import           Data.String          (fromString)
import           Data.Void

import qualified GHCJS.VDOM.Attribute as A
import qualified GHCJS.VDOM.Element   as E
import qualified GHCJS.VDOM.Event     as Ev

import           Concur.Core          (Widget, orr, never)
import           Concur.VDOM          (HTML, classList, clickEl, el,
                                       elEvent, el_, initConcur,
                                       inputEnter, runWidgetInBody,
                                       text)

main :: IO ()
main = do
  -- This needs to be called once at the very beginning
  initConcur
  -- Run widget
  runWidgetInBody $ void $ flip execStateT startEntries widgetTodos


-----------------------------------------------------
-- Data Structures, and associated pure operations --
-----------------------------------------------------

data Entry = Entry
    { entryDescription :: String
    , entryCompleted   :: Bool
    }

data EntriesVisibility = All | Active | Completed
  deriving (Show, Eq)

data EntriesList = EntriesList
  { entriesVisibility :: EntriesVisibility
  , entriesList       :: [Entry]
  }

startEntries :: EntriesList
startEntries = EntriesList All []

entriesCompleted :: EntriesList -> Int
entriesCompleted = length . filter entryCompleted . entriesList

entriesLeft :: EntriesList -> Int
entriesLeft elist = length (entriesList elist) - entriesCompleted elist


-------------
-- Widgets --
-------------

type EntriesWidget a = StateT EntriesList (Widget HTML) a

widgetTodos :: EntriesWidget a
widgetTodos = forever $ el E.div [ A.class_ "todomvc-wrapper" ]
  [ el E.section [A.class_ "todoapp"] [widgetInput, widgetEntries, widgetControls]
  , lift $ el E.footer [ A.class_ "info" ]
        [ el E.p [] [text "Double-click to edit a todo"]
        , el E.p []
            [ text "Written by "
            , el E.a [ A.href "https://github.com/ajnsit" ] [ text "Anupam Jain" ]
            ]
        , el E.p []
            [ text "Part of "
            , el E.a [ A.href "https://todomvc.com" ] [ text "TodoMVC" ]
            ]
        ]
  ]

widgetInput :: EntriesWidget ()
widgetInput = el E.header
  [ A.class_ "header" ]
  [ el E.h1 [] [lift $ text "todos"]
  , do
      elist <- get
      s <- lift $ inputEnter [A.class_ "new-todo", A.placeholder "What needs to be done?", A.autofocus "autofocus", A.name "newTodo", A.value ""]
      put $ elist { entriesList = Entry s False : entriesList elist }
  ]

widgetEntries :: EntriesWidget ()
widgetEntries = do
  elist <- get
  el E.section [ classList [("main", True), ("hidden", null $ entriesList elist)] ]
    [ lift (allCompletedToggle (allCompleted elist)) >>= put . flip markAllComplete elist
    , el_ E.ul [ A.class_ "todo-list" ] $ elistToEntriesListWidget elist
    ]
  where
    addChecked v l = if v then (A.checked "checked" : l) else l
    allCompletedToggle v = clickEl E.input (addChecked v [A.type_ "checkbox", A.class_ "toggle-all", A.name "toggle"]) (const $ not v) []
    elistToEntriesListWidget elist = orr $ map (numberedEntryToWidget elist) $ filter (isEntryVisible (entriesVisibility elist) . snd) $ zip [0..] $ entriesList elist
    numberedEntryToWidget elist (i,e) = do
      let l = entriesList elist
      me <- lift $ widgetEntry e
      put $ elist { entriesList = case me of
                      Nothing -> take i l ++ drop (i+1) l
                      Just e' -> take i l ++ [e'] ++ drop (i+1) l
                  }
    isEntryVisible Completed = entryCompleted
    isEntryVisible Active    = not . entryCompleted
    isEntryVisible All       = const True
    allCompleted elist = entriesLeft elist <= 0
    markAllComplete v elist = elist { entriesList = map (\e -> e {entryCompleted = v}) (entriesList elist) }


widgetEntry :: Entry -> Widget HTML (Maybe Entry)
widgetEntry todo = go False
  where
    go editing = ego editing >>= either go return
    ego editing = do
      el E.li [ classList [ ("completed", completed), ("editing", editing) ] ] $
        [ el E.div [ A.class_ "view" ] $
            [ clickEl E.input (addChecked completed [A.type_ "checkbox", A.class_ "toggle"])
                (\_e -> Right $ Just $ todo { entryCompleted = not completed }) []
            , either (const $ Left $ not editing) absurd <$> elEvent Ev.dblclick E.label [] (text desc)
            , clickEl E.button [A.class_ "destroy"] (const $ Right Nothing) []
            ]
        , if editing
            then fmap (\desc' -> Right $ Just $ todo { entryDescription = desc' }) $
                   inputEnter [A.autofocus "autofocus", A.class_ "edit", A.name "title", A.value $ JSS.pack desc]
            else never
        ]
    completed = entryCompleted todo
    desc = entryDescription todo
    addChecked v l = if v then (A.checked "checked" : l) else l

widgetControls :: EntriesWidget ()
widgetControls = do
  elist <- get
  el E.footer
      [ classList [("footer", True), ("hidden", null $ entriesList elist)] ]
      [ widgetControlsCount , widgetControlsFilters , widgetControlsClear ]

widgetControlsCount :: EntriesWidget a
widgetControlsCount = do
  elist <- get
  el E.span
      [ A.class_ "todo-count" ]
      [ el E.strong [] [ lift $ text (fromString $ show $ entriesLeft elist) ]
      , lift $ text $ (if entriesLeft elist == 1 then " item" else " items") ++ " left"
      ]

widgetControlsFilters :: EntriesWidget ()
widgetControlsFilters = el_ E.ul [ A.class_ "filters" ] $ do
  elist <- get
  newVisibility <- lift $ visibilityWidget $ entriesVisibility elist
  put $ elist { entriesVisibility = newVisibility }
  where
    visibilityWidget :: EntriesVisibility -> Widget HTML EntriesVisibility
    visibilityWidget visibility = orr $ intersperse (text " ") $
      [ visibilitySwap "#/" "All" All visibility
      , visibilitySwap "#/active" "Active" Active visibility
      , visibilitySwap "#/completed" "Completed" Completed visibility
      ]
    visibilitySwap :: String -> String -> EntriesVisibility -> EntriesVisibility -> Widget HTML EntriesVisibility
    visibilitySwap uri label visibility actualVisibility = do
      clickEl E.li [] (const visibility)
        [ el_ E.a
            [ A.href $ fromString uri, classList [("selected", visibility == actualVisibility)] ] $
              text label
        ]

widgetControlsClear :: EntriesWidget ()
widgetControlsClear = do
  elist <- get
  _ <- lift $ clickEl E.button
      [ classList [("clear-completed", True), ("hidden", entriesCompleted elist == 0)] ]
      (const ())
      [ text ("Clear completed (" ++ fromString (show $ entriesCompleted elist) ++ ")") ]
  put $ elist { entriesList = filter (not . entryCompleted) (entriesList elist) }