Shpadoinkle Navigation

{-# LANGUAGE DeriveAnyClass             #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE ExtendedDefaultRules       #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedLabels           #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}

module Main where

import           Shpadoinkle                 (Html, JSM, NFData, shpadoinkle)
import           GHC.Generics                (Generic)
import           Shpadoinkle.Backend.ParDiff (runParDiff)
import           Shpadoinkle.Html
import           Shpadoinkle.Run             (live, runJSorWarp, simple)
import           Shpadoinkle.Backend.Snabbdom  (runSnabbdom, stage)
import           Shpadoinkle.Html.LocalStorage (manageLocalStorage)
import           Data.Text
import           Control.Lens                  hiding (view)
import           Data.Generics.Labels          ()

data Model = Model
    { mdlPages :: Int
    , mdlHeader :: Text
    , mdlContent :: Text
    } deriving (Generic, Show, Read, Eq, NFData)

initialModel :: Model
initialModel = Model {
    mdlHeader = "Hello!"
  , mdlContent = "Click on a button!"
  , mdlPages = 2
}

setPage :: Text -> Text -> Model -> Model
setPage newHeader newContent m = m
    & #mdlHeader .~ newHeader
    & #mdlContent .~ newContent

viewControls :: Model -> Html m Model
viewControls m = do
    let nPg = m & mdlPages
    let predIfPositive n = if n > 0 then pred n else 0
    div_ [
        button [onClick $ \m -> m & #mdlPages %~ succ]
               ["Add page"]
      , button [onClick $ \m -> m & #mdlPages %~ predIfPositive]
               ["Remove page"]
      ]

viewNavigation :: Model -> Html m Model
viewNavigation m = div_ $ fmap mkBtn [0..(m & mdlPages)-1]
    where mkBtn i =
            button [onClick $ setPage (pageHdr i) (pageCont i)] [(pageName i)]
          pageHdr i = pack $ "Page " <> (show i) <> " header"
          pageCont i = pack $ "Page " <> (show i) <> " content"
          pageName i = text . pack $ "Page " <> (show i)

view :: Model -> Html m Model
view m = do
        div_ [
            viewControls m
         ,  viewNavigation m
         ,  h1_ [text $ m & mdlHeader]
         ,  p_ [text $ m & mdlContent]
         ]


app :: JSM ()
app = do
    model <- manageLocalStorage "pages" initialModel
    shpadoinkle id runSnabbdom model view stage

dev :: IO ()
dev = live 8082 app

main :: IO ()
main = runJSorWarp 8082 app