Added whole effects synonym

Added whole effects synonym

module Main where

import Prelude
import Control.Alt ((<|>))
import Control.Monad.Aff (liftEff', launchAff, later')
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (EXCEPTION)
import Data.Foldable (fold)
import Data.Maybe (fromMaybe)
import Data.Tuple.Nested ((/\))
import Rout (match, lit, int, end)
import VOM (VNode, h, t, (:=), (:|), (~>), stringTo, noneTo)
import Cherry (Config(..), AppEffects, Subscription, router, navigateTo, goBack, reduce, app)
import Style (whole, link)

type ExampleEffects e = AppEffects (err :: EXCEPTION | e)

data Route
  = Home
  | Item Int
  | NotFound

detectRoute :: String -> Route
detectRoute url = fromMaybe NotFound $ match url $
  Home <$ end
  <|>
  Item <$> (lit "items" *> int) <* end

route :: forall e. Subscription (ExampleEffects e)
route = router (\url -> reduce (\s -> s { route = detectRoute url }))

-- State

type State =
  { route :: Route
  , count :: Int
  , message :: String
  }

initialState :: State
initialState =
  { route: Home
  , count: 0
  , message: ""
  }

-- Reducer

incr :: State -> State
incr s = s { count = s.count + 1 }

updateMsg :: String -> State -> State
updateMsg content s = s { message = content }

-- Action

increment :: forall e. Eff (ExampleEffects e) Unit
increment = do
  launchAff $ later' 1500 $ liftEff' $ reduce incr
  pure unit

changeMessage :: forall e. String -> Eff (ExampleEffects e) Unit
changeMessage content = do
  reduce $ updateMsg content
  log "bar"

-- View

view :: forall e. State -> VNode (ExampleEffects e)
view state =
  h "div" []
    [ scene
    , style
    ]
  where
    scene =
      case state.route of
        Home -> home state.message
        Item id -> item id state.count
        NotFound -> notFound

style :: forall e. VNode (ExampleEffects e)
style = h "style" [] [ t styleStr ]
  where
    styleStr = fold [ whole, link.output ]

home :: forall e. String -> VNode (ExampleEffects e)
home message =
  h "div" []
    [ h "h1" [] [ t "Home" ]
    , h "div" [] [ t message ]
    , h "input"
        [ "type" := "text"
        , "value" := message
        , "onInput" ~> stringTo changeMessage
        ]
        []
    , h "a" [ "class" := link.name, "onClick" ~> (noneTo $ navigateTo "/items/1") ] [ t "Item 1 " ]
    , h "a" [ "class" := link.name, "onClick" ~> (noneTo $ navigateTo "/items/2") ] [ t "Item 2 " ]
    , h "a" [ "class" := link.name, "onClick" ~> (noneTo $ navigateTo "/not_found") ] [ t "404 Not Found" ]
    ]

item :: forall e. Int -> Int -> VNode (ExampleEffects e)
item id count =
  h "div" []
    [ h "h1" [] [ t $ "Item " <> show id ]
    , h "div" [ "onClick" ~> noneTo increment ] [ t $ show (count :: Int) ]
    , h "a" [ "onClick" ~> noneTo goBack ] [ t "Back" ]
    ]

notFound :: forall e. VNode (ExampleEffects e)
notFound =
  h "div" []
    [ h "h1" [ "style" :| [ "color" /\ "red" ] ] [ t "404" ]
    , h "a" [ "href" := "https://github.com/oreshinya/purescript-cherry" ] [ t "Github" ]
    ]

-- Subscription

subscriptions :: forall e. Array (Subscription (ExampleEffects e))
subscriptions = [ route ]

-- Init

config :: forall e. Config (ExampleEffects e) State
config = Config
  { selector: "#app"
  , state: initialState
  , view: view
  , subscriptions
  }

main :: forall e. Eff (ExampleEffects e) Unit
main = app config

module Main where

import Prelude
import Control.Alt ((<|>))
import Control.Monad.Aff (liftEff', launchAff, later')
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (EXCEPTION)
import Data.Foldable (fold)
import Data.Maybe (fromMaybe)
import Data.Tuple.Nested ((/\))
import Rout (match, lit, int, end)
import VOM (VNode, h, t, (:=), (:|), (~>), stringTo, noneTo)
import Cherry (Config(..), AppEffects, Subscription, router, navigateTo, goBack, reduce, app)
import Style (whole, link)

data Route
  = Home
  | Item Int
  | NotFound

detectRoute :: String -> Route
detectRoute url = fromMaybe NotFound $ match url $
  Home <$ end
  <|>
  Item <$> (lit "items" *> int) <* end

route :: forall e. Subscription (AppEffects e)
route = router (\url -> reduce (\s -> s { route = detectRoute url }))

-- State

type State =
  { route :: Route
  , count :: Int
  , message :: String
  }

initialState :: State
initialState =
  { route: Home
  , count: 0
  , message: ""
  }

-- Reducer

incr :: State -> State
incr s = s { count = s.count + 1 }

updateMsg :: String -> State -> State
updateMsg content s = s { message = content }

-- Action

increment :: forall e. Eff (AppEffects (err :: EXCEPTION | e)) Unit
increment = do
  launchAff $ later' 1500 $ liftEff' $ reduce incr
  pure unit

changeMessage :: forall e. String -> Eff (AppEffects e) Unit
changeMessage content = do
  reduce $ updateMsg content
  log "bar"

-- View

view :: forall e. State -> VNode (AppEffects (err :: EXCEPTION | e))
view state =
  h "div" []
    [ scene
    , style
    ]
  where
    scene =
      case state.route of
        Home -> home state.message
        Item id -> item id state.count
        NotFound -> notFound

style :: forall e. VNode (AppEffects e)
style = h "style" [] [ t styleStr ]
  where
    styleStr = fold [ whole, link.output ]

home :: forall e. String -> VNode (AppEffects e)
home message =
  h "div" []
    [ h "h1" [] [ t "Home" ]
    , h "div" [] [ t message ]
    , h "input"
        [ "type" := "text"
        , "value" := message
        , "onInput" ~> stringTo changeMessage
        ]
        []
    , h "a" [ "class" := link.name, "onClick" ~> (noneTo $ navigateTo "/items/1") ] [ t "Item 1 " ]
    , h "a" [ "class" := link.name, "onClick" ~> (noneTo $ navigateTo "/items/2") ] [ t "Item 2 " ]
    , h "a" [ "class" := link.name, "onClick" ~> (noneTo $ navigateTo "/not_found") ] [ t "404 Not Found" ]
    ]

item :: forall e. Int -> Int -> VNode (AppEffects (err :: EXCEPTION | e))
item id count =
  h "div" []
    [ h "h1" [] [ t $ "Item " <> show id ]
    , h "div" [ "onClick" ~> noneTo increment ] [ t $ show (count :: Int) ]
    , h "a" [ "onClick" ~> noneTo goBack ] [ t "Back" ]
    ]

notFound :: forall e. VNode (AppEffects e)
notFound =
  h "div" []
    [ h "h1" [ "style" :| [ "color" /\ "red" ] ] [ t "404" ]
    , h "a" [ "href" := "https://github.com/oreshinya/purescript-cherry" ] [ t "Github" ]
    ]

-- Subscription

subscriptions :: forall e. Array (Subscription (AppEffects e))
subscriptions = [ route ]

-- Init

config :: forall e. Config (AppEffects (err :: EXCEPTION | e)) State
config = Config
  { selector: "#app"
  , state: initialState
  , view: view
  , subscriptions
  }

main :: forall e. Eff (AppEffects (err :: EXCEPTION | e)) Unit
main = app config


Add pivot table headers for dimensions (#1446)

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Card.Chart.PivotTableRenderer.Component where

import SlamData.Prelude

import Data.Argonaut as J
import Data.Array as Array
import Data.Foldable as F
import Data.Formatter.Number as FN
import Data.Int as Int
import Data.Lens ((^.))
import Data.List (List, (:))
import Data.List as List
import Data.String as String

import DOM.Event.Event (preventDefault)
import DOM.Event.Types (Event)

import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.Themes.Bootstrap3 as B

import SlamData.Monad (Slam)
import SlamData.Quasar.Query as QQ
import SlamData.Render.CSS.New as CSS
import SlamData.Render.Common (glyph)
import SlamData.Workspace.Card.Chart.PivotTableRenderer.Model as PTRM
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.Setups.Chart.Aggregation as Ag
import SlamData.Workspace.Card.Setups.Chart.PivotTable.Model (Column(..))

import Global (readFloat)
import Utils (hush)

type Input =
  { port ∷ Port.PivotTablePort
  , resource ∷ Port.Resource
  }

type State =
  { input ∷ Maybe Input
  , count ∷ Int
  , pageCount ∷ Int
  , pageIndex ∷ Int
  , pageSize ∷ Int
  , rawRecords ∷ Maybe (Array J.Json)
  , records ∷ Maybe (PTree J.Json J.Json)
  , customPage ∷ Maybe String
  , loading ∷ Boolean
  }

initialState ∷ State
initialState =
  { input: Nothing
  , count: 0
  , pageCount: 0
  , pageIndex: 0
  , pageSize: PTRM.initialModel.pageSize
  , rawRecords: Nothing
  , records: Nothing
  , customPage: Nothing
  , loading: false
  }

data Query a
  = Update Port.PivotTablePort Port.Resource a
  | Load PTRM.Model a
  | Save (PTRM.Model → a)
  | StepPage PageStep a
  | SetCustomPage String a
  | UpdatePage Event a
  | ChangePageSize String a

data Message
  = ModelUpdated

data PageStep
  = First
  | Prev
  | Next
  | Last

type DSL = H.ComponentDSL State Query Message Slam
type HTML = H.ComponentHTML Query

component ∷ H.Component HH.HTML Query Unit Message Slam
component =
  H.component
    { initialState: const initialState
    , render
    , eval
    , receiver: const Nothing
    }

render ∷ State → HTML
render st =
  case st.input of
    Just { port } →
      HH.div
        [ HP.classes [ HH.ClassName "sd-pivot-table" ] ]
        [ HH.div
            [ HP.classes [ HH.ClassName "sd-pivot-table-content" ] ]
            [ maybe (HH.text "") (renderTable port.dimensions port.columns) st.records ]
        , HH.div
            [ HP.classes
                [ HH.ClassName "sd-pagination"
                , HH.ClassName "sd-form"
                ]
            ]
            [ prevButtons (st.pageIndex > 0)
            , pageField st.pageIndex st.customPage st.pageCount
            , nextButtons (st.pageIndex < st.pageCount - 1)
            , pageSizeControls st.pageSize
            ]
            , if st.loading
                then HH.div [ HP.classes [ HH.ClassName "loading" ] ] []
                else HH.text ""
        ]
    _ →
      HH.text ""
  where
  renderTable dims cols tree =
    if st.count ≡ 0
      then
        HH.div
          [ HP.classes [ HH.ClassName "no-results" ] ]
          [ HH.text "No results" ]
      else
        HH.table_
            $ [ HH.tr_
                $ (dims <#> \d → HH.th_ [ HH.text (fst d) ])
                ⊕ (cols <#> case _ of
                      n × Column { value } →
                        HH.th_ [ HH.text n ]
                      _ × Count →
                        HH.th_ [ HH.text "COUNT" ])
            ]
            ⊕ renderRows cols tree

  renderRows cols =
    map HH.tr_ ∘ foldTree (renderLeaves cols) renderHeadings

  renderLeaves cols =
    foldMap (renderLeaf cols)

  renderLeaf cols row =
    let
      rowLen = sizeOfRow cols row
    in
      Array.range 0 (rowLen - 1) <#> \rowIx →
        flip foldMap cols \(c × col) →
          let
            text = J.cursorGet (topField c) row <#> case rowIx, col of
              0, Column { valueAggregation: Just ag } →
                foldJsonArray'
                  renderJson
                  (show ∘ Ag.runAggregation ag ∘ jsonNumbers)
              _, Column { valueAggregation: Just ag } →
                foldJsonArray'
                  (const "")
                  (maybe "" renderJson ∘ flip Array.index rowIx)
              _, Column _ →
                foldJsonArray'
                  renderJson
                  (maybe "" renderJson ∘ flip Array.index rowIx)
              0, Count →
                J.foldJsonNumber "" (FN.format numFormatter)
              _, Count →
                const ""
            in
              [ HH.td_ [ HH.text (fromMaybe "" text) ] ]

  jsonNumbers =
    Array.mapMaybe (J.foldJsonNumber Nothing Just)

  renderHeadings =
    foldMap renderHeading

  renderHeading (k × rs) =
    case Array.uncons rs of
      Just { head, tail } →
        Array.cons
          (Array.cons
            (HH.th [ HP.rowSpan (Array.length rs) ] [ HH.text (renderJson k) ])
            head)
          tail
      Nothing →
        []

  renderJson =
    J.foldJson show show showPrettyNum id show show

  showJCursor (J.JField i c) = i <> show c
  showJCursor c = show c

  showPrettyNum n =
    let s = show n
    in fromMaybe s (String.stripSuffix (String.Pattern ".0") s)

  numFormatter =
    { comma: true
    , before: 0
    , after: 0
    , abbreviations: false
    , sign: false
    }

  prevButtons enabled =
    HH.div
      [ HP.class_ CSS.formButtonGroup ]
      [ HH.button
          [ HP.class_ CSS.formButton
          , HP.disabled (not enabled)
          , HE.onClick $ HE.input_ (StepPage First)
          ]
          [ glyph B.glyphiconFastBackward ]
      , HH.button
          [ HP.class_ CSS.formButton
          , HP.disabled (not enabled)
          , HE.onClick $ HE.input_ (StepPage Prev)
          ]
          [ glyph B.glyphiconStepBackward ]
      ]

  pageField currentPage customPage totalPages =
    HH.div_
      [ HH.form
          [ HE.onSubmit (HE.input UpdatePage) ]
          [ HH.text "Page"
          , HH.input
              [ HP.type_ HP.InputNumber
              , HP.value (fromMaybe (show (currentPage + 1)) customPage)
              , HE.onValueInput (HE.input SetCustomPage)
              ]
          , HH.text $ "of " <> show totalPages
          ]
      ]

  nextButtons enabled =
    HH.div
      [ HP.class_ CSS.formButtonGroup ]
      [ HH.button
          [ HP.disabled (not enabled)
          , HE.onClick $ HE.input_ (StepPage Next)
          ]
          [ glyph B.glyphiconStepForward ]
      , HH.button
          [ HP.disabled (not enabled)
          , HE.onClick $ HE.input_ (StepPage Last)
          ]
          [ glyph B.glyphiconFastForward ]
      ]

  pageSizeControls pageSize =
    let
      sizeValues = [10, 25, 50, 100]
      options = sizeValues <#> \value →
        HH.option
          [ HP.selected (value ≡ pageSize) ]
          [ HH.text (show value) ]
    in
      HH.div_
        [ HH.select
            [ HE.onValueChange (HE.input ChangePageSize) ]
            options
        ]

eval ∷ Query ~> DSL
eval = case _ of
  Update port resource next → do
    st ← H.get
    let input = { port, resource }
    if fromMaybe false (eq resource ∘ _.resource <$> st.input)
      then
        H.modify _ { input = Just input }
      else do
        H.modify _ { input = Just input, pageIndex = 0, count = 0, pageCount = 0 }
        ifSimpleQuery pageQuery loadTree input
    pure next
  StepPage step next → do
    st ← H.get
    let
      pageIndex = clamp 0 (st.pageCount - 1) case step of
        First → 0
        Prev  → st.pageIndex - 1
        Next  → st.pageIndex + 1
        Last  → st.pageCount - 1
    H.modify _ { pageIndex = pageIndex }
    for st.input (ifSimpleQuery pageQuery pageTree)
    pure next
  SetCustomPage page next → do
    H.modify _ { customPage = Just page }
    pure next
  UpdatePage ev next → do
    H.liftEff $ preventDefault ev
    st ← H.get
    for_ st.customPage \page → do
      let
        pageIndex = clamp 0 (st.pageCount - 1) (Int.floor (readFloat page) - 1)
      H.modify _
        { pageIndex = pageIndex
        , customPage = Nothing
        }
      for st.input (ifSimpleQuery pageQuery pageTree)
    pure next
  ChangePageSize size next → do
    st ← H.get
    let
      pageSize  = Int.floor (readFloat size)
    H.modify _ { pageSize = pageSize }
    for st.input (ifSimpleQuery pageQuery pageTree)
    H.raise ModelUpdated
    pure next
  Load model next → do
    H.modify _ { pageSize = model.pageSize }
    pure next
  Save k → do
    { pageSize } ← H.get
    pure $ k { pageSize }

ifSimpleQuery
  ∷ (Input → DSL Unit)
  → (Input → DSL Unit)
  → Input
  → DSL Unit
ifSimpleQuery f g p =
  if p.port.isSimpleQuery then f p else g p

pageQuery ∷ Input → DSL Unit
pageQuery input = do
  st ← H.get
  let
    filePath = input.resource ^. Port._filePath
    offset = st.pageIndex * st.pageSize
    limit = st.pageSize
  H.modify _ { loading = true }
  if st.count ≡ 0
    then do
      count ← either (const 0) id <$> QQ.count filePath
      H.modify _
        { count = count
        , pageCount = calcPageCount count st.pageSize
        }
    else do
      H.modify _
        { pageCount = calcPageCount st.count st.pageSize
        }
  records ← QQ.sample filePath offset limit
  H.modify _ { loading = false }
  for_ records \recs →
    H.modify _ { records = Just (buildTree mempty Bucket Grouped recs) }

pageTree ∷ Input → DSL Unit
pageTree input = do
  st ← H.get
  for_ st.rawRecords \records → do
    let
      dims = List.fromFoldable $ J.cursorGet ∘ topField ∘ fst <$> input.port.dimensions
      tree = buildTree dims Bucket Grouped records
      pages = pagedTree st.pageSize (sizeOfRow input.port.columns) tree
      pageCount = Array.length (snd pages)
      pageIndex = clamp 0 (pageCount - 1) st.pageIndex
    H.modify _
      { records = Array.index (snd pages) pageIndex
      , count = fst pages
      , pageCount = pageCount
      , pageIndex = pageIndex
      }

loadTree ∷ Input → DSL Unit
loadTree input = do
  let filePath = input.resource ^. Port._filePath
  H.modify _ { loading = true }
  records ← QQ.all filePath
  H.modify _
    { loading = false
    , rawRecords = hush records
    }
  pageTree input

calcPageCount ∷ Int → Int → Int
calcPageCount count size =
  Int.ceil (Int.toNumber count / Int.toNumber size)

sizeOfRow ∷ Array (String × Column) → J.Json → Int
sizeOfRow columns row =
  fromMaybe 1
    (F.maximum
      (Array.mapMaybe
        case _ of
          c × Column { valueAggregation: Just _ } → Just 1
          c × _ → J.foldJsonArray 1 Array.length <$> J.cursorGet (topField c) row
        columns))

topField ∷ String → J.JCursor
topField c = J.JField c J.JCursorTop

data PTree k a
  = Bucket (Array a)
  | Grouped (Array (k × PTree k a))

foldTree
  ∷ ∀ k a r
  . (Array a → r)
  → (Array (k × r) → r)
  → PTree k a
  → r
foldTree f g (Bucket a) = f a
foldTree f g (Grouped as) = g (map (foldTree f g) <$> as)

buildTree
  ∷ ∀ k a r
  . Eq k
  ⇒ List (a → Maybe k)
  → (Array a → r)
  → (Array (k × r) → r)
  → Array a
  → r
buildTree List.Nil f g as = f as
buildTree (k : ks) f g as =
  g (fin (foldl go { key: Nothing, group: [], acc: [] } as))
  where
  go res@{ key: mbKey, group, acc } a =
    case mbKey, k a of
      Just key, Just key' | key == key' →
        { key: mbKey, group: Array.snoc group a, acc }
      _, Just key' →
        { key: Just key', group: [a], acc: fin res }
      _, Nothing →
        res
  fin { key, group, acc } =
    case key of
      Just key' →
        Array.snoc acc (key' × (buildTree ks f g group))
      Nothing →
        acc

pagedTree
  ∷ ∀ k a
  . Int
  → (a → Int)
  → PTree k a
  → Int × Array (PTree k a)
pagedTree page sizeOf tree =
  case tree of
    Bucket as → map Bucket <$> chunked page sizeOf as
    Grouped gs → map Grouped <$> chunked page (sizeOf' ∘ snd) gs
  where
  sizeOf' (Bucket as) = F.sum (sizeOf <$> as)
  sizeOf' (Grouped gs) = F.sum (sizeOf' ∘ snd <$> gs)

chunked
  ∷ ∀ b
  . Int
  → (b → Int)
  → Array b
  → Int × Array (Array b)
chunked page sizeOf arr = res.total × Array.snoc res.chunks res.chunk
  where
  res =
    foldl go { total: 0, size: 0, chunk: [], chunks: []} arr

  go { total, size, chunk, chunks } a =
    let
      s2 = sizeOf a
      t2 = total + s2
    in
      case size + s2, chunk of
        size', [] | size' > page →
          { total: t2, size: 0, chunk, chunks: Array.snoc chunks [a] }
        size', _  | size' > page →
          { total: t2, size: s2, chunk: [a], chunks: Array.snoc chunks chunk }
        size', _ →
          { total: t2, size: size', chunk: Array.snoc chunk a, chunks }

foldJsonArray'
  ∷ ∀ a
  . (J.Json → a)
  → (J.JArray → a)
  → J.Json
  → a
foldJsonArray' f g j = J.foldJson f' f' f' f' g f' j
  where
  f' ∷ ∀ b. b → a
  f' _ = f j

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Card.Chart.PivotTableRenderer.Component where

import SlamData.Prelude

import Data.Argonaut as J
import Data.Array as Array
import Data.Foldable as F
import Data.Formatter.Number as FN
import Data.Int as Int
import Data.Lens ((^.))
import Data.List (List, (:))
import Data.List as List
import Data.String as String

import DOM.Event.Event (preventDefault)
import DOM.Event.Types (Event)

import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.Themes.Bootstrap3 as B

import SlamData.Monad (Slam)
import SlamData.Quasar.Query as QQ
import SlamData.Render.CSS.New as CSS
import SlamData.Render.Common (glyph)
import SlamData.Workspace.Card.Chart.PivotTableRenderer.Model as PTRM
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.Setups.Chart.Aggregation as Ag
import SlamData.Workspace.Card.Setups.Chart.PivotTable.Model (Column(..))

import Global (readFloat)
import Utils (hush)

type Input =
  { port ∷ Port.PivotTablePort
  , resource ∷ Port.Resource
  }

type State =
  { input ∷ Maybe Input
  , count ∷ Int
  , pageCount ∷ Int
  , pageIndex ∷ Int
  , pageSize ∷ Int
  , rawRecords ∷ Maybe (Array J.Json)
  , records ∷ Maybe (PTree J.Json J.Json)
  , customPage ∷ Maybe String
  , loading ∷ Boolean
  }

initialState ∷ State
initialState =
  { input: Nothing
  , count: 0
  , pageCount: 0
  , pageIndex: 0
  , pageSize: PTRM.initialModel.pageSize
  , rawRecords: Nothing
  , records: Nothing
  , customPage: Nothing
  , loading: false
  }

data Query a
  = Update Port.PivotTablePort Port.Resource a
  | Load PTRM.Model a
  | Save (PTRM.Model → a)
  | StepPage PageStep a
  | SetCustomPage String a
  | UpdatePage Event a
  | ChangePageSize String a

data Message
  = ModelUpdated

data PageStep
  = First
  | Prev
  | Next
  | Last

type DSL = H.ComponentDSL State Query Message Slam
type HTML = H.ComponentHTML Query

component ∷ H.Component HH.HTML Query Unit Message Slam
component =
  H.component
    { initialState: const initialState
    , render
    , eval
    , receiver: const Nothing
    }

render ∷ State → HTML
render st =
  case st.input of
    Just { port } →
      HH.div
        [ HP.classes [ HH.ClassName "sd-pivot-table" ] ]
        [ HH.div
            [ HP.classes [ HH.ClassName "sd-pivot-table-content" ] ]
            [ maybe (HH.text "") (renderTable port.dimensions port.columns) st.records ]
        , HH.div
            [ HP.classes
                [ HH.ClassName "sd-pagination"
                , HH.ClassName "sd-form"
                ]
            ]
            [ prevButtons (st.pageIndex > 0)
            , pageField st.pageIndex st.customPage st.pageCount
            , nextButtons (st.pageIndex < st.pageCount - 1)
            , pageSizeControls st.pageSize
            ]
            , if st.loading
                then HH.div [ HP.classes [ HH.ClassName "loading" ] ] []
                else HH.text ""
        ]
    _ →
      HH.text ""
  where
  renderTable dims cols tree =
    if st.count ≡ 0
      then
        HH.div
          [ HP.classes [ HH.ClassName "no-results" ] ]
          [ HH.text "No results" ]
      else
        HH.table_
            $ [ HH.tr_
                $ (if Array.null dims
                    then []
                    else [ HH.td [ HP.colSpan (Array.length dims) ] [] ])
                ⊕ (cols <#> case _ of
                      n × Column { value } →
                        HH.th_ [ HH.text n ]
                      _ × Count →
                        HH.th_ [ HH.text "COUNT" ])
            ]
            ⊕ renderRows cols tree

  renderRows cols =
    map HH.tr_ ∘ foldTree (renderLeaves cols) renderHeadings

  renderLeaves cols =
    foldMap (renderLeaf cols)

  renderLeaf cols row =
    let
      rowLen = sizeOfRow cols row
    in
      Array.range 0 (rowLen - 1) <#> \rowIx →
        flip foldMap cols \(c × col) →
          let
            text = J.cursorGet (topField c) row <#> case rowIx, col of
              0, Column { valueAggregation: Just ag } →
                foldJsonArray'
                  renderJson
                  (show ∘ Ag.runAggregation ag ∘ jsonNumbers)
              _, Column { valueAggregation: Just ag } →
                foldJsonArray'
                  (const "")
                  (maybe "" renderJson ∘ flip Array.index rowIx)
              _, Column _ →
                foldJsonArray'
                  renderJson
                  (maybe "" renderJson ∘ flip Array.index rowIx)
              0, Count →
                J.foldJsonNumber "" (FN.format numFormatter)
              _, Count →
                const ""
            in
              [ HH.td_ [ HH.text (fromMaybe "" text) ] ]

  jsonNumbers =
    Array.mapMaybe (J.foldJsonNumber Nothing Just)

  renderHeadings =
    foldMap renderHeading

  renderHeading (k × rs) =
    case Array.uncons rs of
      Just { head, tail } →
        Array.cons
          (Array.cons
            (HH.th [ HP.rowSpan (Array.length rs) ] [ HH.text (renderJson k) ])
            head)
          tail
      Nothing →
        []

  renderJson =
    J.foldJson show show showPrettyNum id show show

  showJCursor (J.JField i c) = i <> show c
  showJCursor c = show c

  showPrettyNum n =
    let s = show n
    in fromMaybe s (String.stripSuffix (String.Pattern ".0") s)

  numFormatter =
    { comma: true
    , before: 0
    , after: 0
    , abbreviations: false
    , sign: false
    }

  prevButtons enabled =
    HH.div
      [ HP.class_ CSS.formButtonGroup ]
      [ HH.button
          [ HP.class_ CSS.formButton
          , HP.disabled (not enabled)
          , HE.onClick $ HE.input_ (StepPage First)
          ]
          [ glyph B.glyphiconFastBackward ]
      , HH.button
          [ HP.class_ CSS.formButton
          , HP.disabled (not enabled)
          , HE.onClick $ HE.input_ (StepPage Prev)
          ]
          [ glyph B.glyphiconStepBackward ]
      ]

  pageField currentPage customPage totalPages =
    HH.div_
      [ HH.form
          [ HE.onSubmit (HE.input UpdatePage) ]
          [ HH.text "Page"
          , HH.input
              [ HP.type_ HP.InputNumber
              , HP.value (fromMaybe (show (currentPage + 1)) customPage)
              , HE.onValueInput (HE.input SetCustomPage)
              ]
          , HH.text $ "of " <> show totalPages
          ]
      ]

  nextButtons enabled =
    HH.div
      [ HP.class_ CSS.formButtonGroup ]
      [ HH.button
          [ HP.disabled (not enabled)
          , HE.onClick $ HE.input_ (StepPage Next)
          ]
          [ glyph B.glyphiconStepForward ]
      , HH.button
          [ HP.disabled (not enabled)
          , HE.onClick $ HE.input_ (StepPage Last)
          ]
          [ glyph B.glyphiconFastForward ]
      ]

  pageSizeControls pageSize =
    let
      sizeValues = [10, 25, 50, 100]
      options = sizeValues <#> \value →
        HH.option
          [ HP.selected (value ≡ pageSize) ]
          [ HH.text (show value) ]
    in
      HH.div_
        [ HH.select
            [ HE.onValueChange (HE.input ChangePageSize) ]
            options
        ]

eval ∷ Query ~> DSL
eval = case _ of
  Update port resource next → do
    st ← H.get
    let input = { port, resource }
    if fromMaybe false (eq resource ∘ _.resource <$> st.input)
      then
        H.modify _ { input = Just input }
      else do
        H.modify _ { input = Just input, pageIndex = 0, count = 0, pageCount = 0 }
        ifSimpleQuery pageQuery loadTree input
    pure next
  StepPage step next → do
    st ← H.get
    let
      pageIndex = clamp 0 (st.pageCount - 1) case step of
        First → 0
        Prev  → st.pageIndex - 1
        Next  → st.pageIndex + 1
        Last  → st.pageCount - 1
    H.modify _ { pageIndex = pageIndex }
    for st.input (ifSimpleQuery pageQuery pageTree)
    pure next
  SetCustomPage page next → do
    H.modify _ { customPage = Just page }
    pure next
  UpdatePage ev next → do
    H.liftEff $ preventDefault ev
    st ← H.get
    for_ st.customPage \page → do
      let
        pageIndex = clamp 0 (st.pageCount - 1) (Int.floor (readFloat page) - 1)
      H.modify _
        { pageIndex = pageIndex
        , customPage = Nothing
        }
      for st.input (ifSimpleQuery pageQuery pageTree)
    pure next
  ChangePageSize size next → do
    st ← H.get
    let
      pageSize  = Int.floor (readFloat size)
    H.modify _ { pageSize = pageSize }
    for st.input (ifSimpleQuery pageQuery pageTree)
    H.raise ModelUpdated
    pure next
  Load model next → do
    H.modify _ { pageSize = model.pageSize }
    pure next
  Save k → do
    { pageSize } ← H.get
    pure $ k { pageSize }

ifSimpleQuery
  ∷ (Input → DSL Unit)
  → (Input → DSL Unit)
  → Input
  → DSL Unit
ifSimpleQuery f g p =
  if p.port.isSimpleQuery then f p else g p

pageQuery ∷ Input → DSL Unit
pageQuery input = do
  st ← H.get
  let
    filePath = input.resource ^. Port._filePath
    offset = st.pageIndex * st.pageSize
    limit = st.pageSize
  H.modify _ { loading = true }
  if st.count ≡ 0
    then do
      count ← either (const 0) id <$> QQ.count filePath
      H.modify _
        { count = count
        , pageCount = calcPageCount count st.pageSize
        }
    else do
      H.modify _
        { pageCount = calcPageCount st.count st.pageSize
        }
  records ← QQ.sample filePath offset limit
  H.modify _ { loading = false }
  for_ records \recs →
    H.modify _ { records = Just (buildTree mempty Bucket Grouped recs) }

pageTree ∷ Input → DSL Unit
pageTree input = do
  st ← H.get
  for_ st.rawRecords \records → do
    let
      dims = List.fromFoldable $ J.cursorGet ∘ topField ∘ fst <$> input.port.dimensions
      tree = buildTree dims Bucket Grouped records
      pages = pagedTree st.pageSize (sizeOfRow input.port.columns) tree
      pageCount = Array.length (snd pages)
      pageIndex = clamp 0 (pageCount - 1) st.pageIndex
    H.modify _
      { records = Array.index (snd pages) pageIndex
      , count = fst pages
      , pageCount = pageCount
      , pageIndex = pageIndex
      }

loadTree ∷ Input → DSL Unit
loadTree input = do
  let filePath = input.resource ^. Port._filePath
  H.modify _ { loading = true }
  records ← QQ.all filePath
  H.modify _
    { loading = false
    , rawRecords = hush records
    }
  pageTree input

calcPageCount ∷ Int → Int → Int
calcPageCount count size =
  Int.ceil (Int.toNumber count / Int.toNumber size)

sizeOfRow ∷ Array (String × Column) → J.Json → Int
sizeOfRow columns row =
  fromMaybe 1
    (F.maximum
      (Array.mapMaybe
        case _ of
          c × Column { valueAggregation: Just _ } → Just 1
          c × _ → J.foldJsonArray 1 Array.length <$> J.cursorGet (topField c) row
        columns))

topField ∷ String → J.JCursor
topField c = J.JField c J.JCursorTop

data PTree k a
  = Bucket (Array a)
  | Grouped (Array (k × PTree k a))

foldTree
  ∷ ∀ k a r
  . (Array a → r)
  → (Array (k × r) → r)
  → PTree k a
  → r
foldTree f g (Bucket a) = f a
foldTree f g (Grouped as) = g (map (foldTree f g) <$> as)

buildTree
  ∷ ∀ k a r
  . Eq k
  ⇒ List (a → Maybe k)
  → (Array a → r)
  → (Array (k × r) → r)
  → Array a
  → r
buildTree List.Nil f g as = f as
buildTree (k : ks) f g as =
  g (fin (foldl go { key: Nothing, group: [], acc: [] } as))
  where
  go res@{ key: mbKey, group, acc } a =
    case mbKey, k a of
      Just key, Just key' | key == key' →
        { key: mbKey, group: Array.snoc group a, acc }
      _, Just key' →
        { key: Just key', group: [a], acc: fin res }
      _, Nothing →
        res
  fin { key, group, acc } =
    case key of
      Just key' →
        Array.snoc acc (key' × (buildTree ks f g group))
      Nothing →
        acc

pagedTree
  ∷ ∀ k a
  . Int
  → (a → Int)
  → PTree k a
  → Int × Array (PTree k a)
pagedTree page sizeOf tree =
  case tree of
    Bucket as → map Bucket <$> chunked page sizeOf as
    Grouped gs → map Grouped <$> chunked page (sizeOf' ∘ snd) gs
  where
  sizeOf' (Bucket as) = F.sum (sizeOf <$> as)
  sizeOf' (Grouped gs) = F.sum (sizeOf' ∘ snd <$> gs)

chunked
  ∷ ∀ b
  . Int
  → (b → Int)
  → Array b
  → Int × Array (Array b)
chunked page sizeOf arr = res.total × Array.snoc res.chunks res.chunk
  where
  res =
    foldl go { total: 0, size: 0, chunk: [], chunks: []} arr

  go { total, size, chunk, chunks } a =
    let
      s2 = sizeOf a
      t2 = total + s2
    in
      case size + s2, chunk of
        size', [] | size' > page →
          { total: t2, size: 0, chunk, chunks: Array.snoc chunks [a] }
        size', _  | size' > page →
          { total: t2, size: s2, chunk: [a], chunks: Array.snoc chunks chunk }
        size', _ →
          { total: t2, size: size', chunk: Array.snoc chunk a, chunks }

foldJsonArray'
  ∷ ∀ a
  . (J.Json → a)
  → (J.JArray → a)
  → J.Json
  → a
foldJsonArray' f g j = J.foldJson f' f' f' f' g f' j
  where
  f' ∷ ∀ b. b → a
  f' _ = f j


submenu

submenu

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Card.Next.NextAction where

import SlamData.Prelude

import Data.Array as A

import Halogen.HTML as H
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP
import Halogen.Themes.Bootstrap3 as B

import SlamData.Workspace.Card.InsertableCardType (InsertableCardType)
import SlamData.Workspace.Card.InsertableCardType as ICT
import SlamData.Workspace.Card.CardType (CardType, cardName, lightCardGlyph)
import SlamData.Render.Common (glyph)
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.CardType.ChartType (allChartTypes)
import SlamData.Workspace.Card.CardType.FormInputType (allFormInputTypes)
import SlamData.Workspace.Card.Port (Port)

data NextAction
  = Insert CardType
  | FindOutHowToInsert CardType
  | Drill String String (Array NextAction)
  | GoBack

formInputSubmenu ∷ NextAction
formInputSubmenu =
  Drill
    "Setup Form"
    "img/cardsLight/setupFormInput.svg"
    ([ GoBack ] ⊕ map (Insert ∘ CT.SetupFormInput) allFormInputTypes)

chartSubmenu ∷ NextAction
chartSubmenu =
  Drill
    "Setup Chart"
    "img/cardsLight/setupChart.svg"
    ([ GoBack ] ⊕ map (Insert ∘ CT.ChartOptions) allChartTypes)

findOutHowToFormInputSubmenu ∷ NextAction
findOutHowToFormInputSubmenu =
  Drill
    "Setup Form"
    "img/cardsLight/setupFormInput.svg"
    ([ GoBack ] ⊕ map (FindOutHowToInsert ∘ CT.SetupFormInput) allFormInputTypes)

findOutHowToChartSubmenu ∷ NextAction
findOutHowToChartSubmenu =
  Drill
    "Setup Chart"
    "img/cardsLight/setupChart.svg"
    ([ GoBack ] ⊕ map (FindOutHowToInsert ∘ CT.ChartOptions) allChartTypes)

instance eqNextAction ∷ Eq NextAction where
  eq GoBack GoBack = true
  eq (Insert cty1) (Insert cty2) = cty1 ≡ cty2
  eq (FindOutHowToInsert cty1) (FindOutHowToInsert cty2) = cty1 ≡ cty2
  eq (Drill n1 i1 ctys1) (Drill n2 i2 ctys2) =
    n1 ≡ n2
    ∧ i1 ≡ i2
    ∧ ctys1 ≡ ctys2
  eq _ _ = false

foldToArray ∷ NextAction → Array CardType
foldToArray (Insert cty) = [ cty ]
foldToArray (FindOutHowToInsert cty) = [ cty ]
foldToArray (Drill _ _ as) = A.concat $ map foldToArray as
foldToArray (GoBack) = [ ]

searchFilters ∷ NextAction → Array String
searchFilters (Insert cty) = [ cardName cty ]
searchFilters (FindOutHowToInsert cty) = [ cardName cty ]
searchFilters (Drill name _ as) = [ name ] ⊕ A.concat (map searchFilters as)
searchFilters (GoBack) = [ ]

actionLabel ∷ NextAction → String
actionLabel (Insert cty) = cardName cty
actionLabel (FindOutHowToInsert cty) = cardName cty
actionLabel (Drill name _ _) = name
actionLabel (GoBack) = "Back"

actionGlyph ∷ ∀ s f. NextAction → H.HTML s f
actionGlyph (Insert cty) = lightCardGlyph cty
actionGlyph (FindOutHowToInsert cty) = lightCardGlyph cty
actionGlyph (Drill _ src _) = HH.img [ HP.src src ]
actionGlyph (GoBack) = glyph B.glyphiconChevronLeft

insert ∷ InsertableCardType → NextAction
insert =
  case _ of
    ICT.SetupChartCard → chartSubmenu
    ICT.SetupFormInputCard → formInputSubmenu
    iCardType → Insert $ ICT.toCardType iCardType

findOutHowToInsert ∷ InsertableCardType → NextAction
findOutHowToInsert =
  case _ of
    ICT.SetupChartCard → findOutHowToChartSubmenu
    ICT.SetupFormInputCard → findOutHowToFormInputSubmenu
    iCardType → FindOutHowToInsert $ ICT.toCardType iCardType

fromInsertableCard ∷ InsertableCardType → Array InsertableCardType → NextAction
fromInsertableCard x =
  maybe (findOutHowToInsert x) (const $ insert x) ∘ A.findIndex (eq x)

fromPort ∷ Port → Array NextAction
fromPort port =
  flip fromInsertableCard (ICT.cardsThatTakeInput $ ICT.fromPort port) <$> ICT.all

fromMaybePort ∷ Maybe Port → Array NextAction
fromMaybePort = maybe (flip fromInsertableCard (ICT.cardsThatTakeInput ICT.None) <$> ICT.all) fromPort

isInsert ∷ NextAction → Boolean
isInsert (Insert _) = true
isInsert _ = false

isDrill ∷ NextAction → Boolean
isDrill (Drill _ _ _) = true
isDrill _ = false

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Card.Next.NextAction where

import SlamData.Prelude

import Data.Array as A

import Halogen.HTML as H
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP
import Halogen.Themes.Bootstrap3 as B

import SlamData.Workspace.Card.InsertableCardType (InsertableCardType)
import SlamData.Workspace.Card.InsertableCardType as ICT
import SlamData.Workspace.Card.CardType (CardType, cardName, lightCardGlyph)
import SlamData.Render.Common (glyph)
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.CardType.ChartType (allChartTypes)
import SlamData.Workspace.Card.CardType.FormInputType (allFormInputTypes)
import SlamData.Workspace.Card.Port (Port)

data NextAction
  = Insert CardType
  | FindOutHowToInsert CardType
  | Drill String String (Array NextAction)
  | GoBack

formInputSubmenu ∷ NextAction
formInputSubmenu =
  Drill
    "Setup Form"
    "img/cardsLight/setupFormInput.svg"
    ([ GoBack ] ⊕ map (Insert ∘ CT.SetupFormInput) allFormInputTypes)

chartSubmenu ∷ NextAction
chartSubmenu =
  Drill
    "Setup Chart"
    "img/cardsLight/setupChart.svg"
    ([ GoBack ] ⊕ map (Insert ∘ CT.ChartOptions) allChartTypes)

findOutHowToChartSubmenu ∷ NextAction
findOutHowToChartSubmenu =
  Drill
    "Setup Chart"
    "img/cardsLight/setupChart.svg"
    ([ GoBack ] ⊕ map (FindOutHowToInsert ∘ CT.ChartOptions) allChartTypes)

instance eqNextAction ∷ Eq NextAction where
  eq GoBack GoBack = true
  eq (Insert cty1) (Insert cty2) = cty1 ≡ cty2
  eq (FindOutHowToInsert cty1) (FindOutHowToInsert cty2) = cty1 ≡ cty2
  eq (Drill n1 i1 ctys1) (Drill n2 i2 ctys2) =
    n1 ≡ n2
    ∧ i1 ≡ i2
    ∧ ctys1 ≡ ctys2
  eq _ _ = false

foldToArray ∷ NextAction → Array CardType
foldToArray (Insert cty) = [ cty ]
foldToArray (FindOutHowToInsert cty) = [ cty ]
foldToArray (Drill _ _ as) = A.concat $ map foldToArray as
foldToArray (GoBack) = [ ]

searchFilters ∷ NextAction → Array String
searchFilters (Insert cty) = [ cardName cty ]
searchFilters (FindOutHowToInsert cty) = [ cardName cty ]
searchFilters (Drill name _ as) = [ name ] ⊕ A.concat (map searchFilters as)
searchFilters (GoBack) = [ ]

actionLabel ∷ NextAction → String
actionLabel (Insert cty) = cardName cty
actionLabel (FindOutHowToInsert cty) = cardName cty
actionLabel (Drill name _ _) = name
actionLabel (GoBack) = "Back"

actionGlyph ∷ ∀ s f. NextAction → H.HTML s f
actionGlyph (Insert cty) = lightCardGlyph cty
actionGlyph (FindOutHowToInsert cty) = lightCardGlyph cty
actionGlyph (Drill _ src _) = HH.img [ HP.src src ]
actionGlyph (GoBack) = glyph B.glyphiconChevronLeft

insert ∷ InsertableCardType → NextAction
insert =
  case _ of
    ICT.SetupChartCard → chartSubmenu
    iCardType → Insert $ ICT.toCardType iCardType

findOutHowToInsert ∷ InsertableCardType → NextAction
findOutHowToInsert =
  case _ of
    ICT.SetupChartCard → findOutHowToChartSubmenu
    iCardType → FindOutHowToInsert $ ICT.toCardType iCardType

fromInsertableCard ∷ InsertableCardType → Array InsertableCardType → NextAction
fromInsertableCard x =
  maybe (findOutHowToInsert x) (const $ insert x) ∘ A.findIndex (eq x)

fromPort ∷ Port → Array NextAction
fromPort port =
  flip fromInsertableCard (ICT.cardsThatTakeInput $ ICT.fromPort port) <$> ICT.all

fromMaybePort ∷ Maybe Port → Array NextAction
fromMaybePort = maybe (flip fromInsertableCard (ICT.cardsThatTakeInput ICT.None) <$> ICT.all) fromPort

isInsert ∷ NextAction → Boolean
isInsert (Insert _) = true
isInsert _ = false

isDrill ∷ NextAction → Boolean
isDrill (Drill _ _ _) = true
isDrill _ = false


make it work via https

make it work via https

module Client where

import Debug.Trace (trace)
import Data.Maybe
import Data.Maybe.Unsafe (fromJust)
import qualified Data.Either as E
import Data.JSON (eitherDecode, encode)
import Data.Tuple
import qualified Data.String as S
import qualified Data.Map as M
import Data.DOM.Simple.Events hiding (view)
import Data.DOM.Simple.Types (DOM(), DOMEvent(), DOMLocation(), HTMLElement())
import Data.DOM.Simple.Window (globalWindow, location, document)
import Data.DOM.Simple.Element
  (setInnerHTML, querySelector, setAttribute, value, setValue, focus)
import Data.DOM.Simple.Events
  (keyCode, addKeyboardEventListener, KeyboardEventType(..))
import Data.DOM.Simple.Document ()
import Control.Monad
import Control.Monad.Eff
import Control.Monad.Eff.Ref
import Control.Monad.RWS.Class
import Control.Monad.State.Class
import Control.Lens (lens, (.~), (..), (^.), (~))
import Control.Reactive.Timer

import qualified BrowserWebSocket as WS
import qualified Rendering as R
import qualified HtmlViews as V
import BaseClient
import Game
import Types
import Utils
import LocalStorage

foreign import host
  """
  function host(location) {
    return location.host;
  }
  """ :: DOMLocation -> String

foreign import protocol
  """
  function protocol(location) {
    return location.protocol
  }
  """ :: DOMLocation -> String

foreign import selectElement """
  function selectElement(el) {
    return function() {
      el.select()
    }
  }
""" :: forall e. HTMLElement -> Eff (dom :: DOM | e) Unit

initialState =
  CWaitingForPlayers
    { prevGame: Nothing
    , backgroundCleared: false
    , readyStates: M.empty
    , cachedHtml: ""
    }

main = do
  hideSimpleScoresDiv
  startRef <- newRef false
  loop startRef
  where
  loop startRef =
    promptScreenName "Enter a screen name:" $ \name ->
      if S.null (S.trim name)
         then loop startRef
         else start startRef name

promptScreenName :: forall e.
  String -> (String -> Eff (storage :: Storage, dom :: DOM | e) Unit)
  -> Eff (storage :: Storage, dom :: DOM | e) Unit
promptScreenName msg cont = do
  let key = "screenName"
  mVal <- getStorage key
  let val = fromMaybe "" mVal
  popupPromptInput msg val $ \name -> do
    setStorage "screenName" name
    cont name

popupPromptInput msg val cont = do
  containerEl <- q' "#prompt"
  showElement (containerEl :: HTMLElement)

  messageEl <- q' "#prompt-message"
  setInnerHTML msg (messageEl :: HTMLElement)

  inputEl <- q' "#prompt-input"
  setValue val (inputEl :: HTMLElement)

  focus inputEl
  selectElement inputEl

  addKeyboardEventListener
    KeydownEvent
    (handleKeydown containerEl inputEl)
    inputEl
  where
  handleKeydown cEl iEl event = do
    code <- keyCode (event :: DOMEvent)
    when (code == keyCodeEnter) $ do
      hideElement cEl
      value iEl >>= cont

start startedRef name = do
  started <- readRef startedRef
  when (not started) $ do
    writeRef startedRef true

    callbacks <- mkCallbacks
    h <- host <$> location globalWindow
    p <- protocol <$> location globalWindow

    let wsProtocol = if p == "https:" then "wss:" else "ws:"
    let socketUrl = wsProtocol <> "//" <> h <> "/"
    startClient initialState callbacks socketUrl name

-- CALLBACKS
mkCallbacks =
  R.setupRendering <#> \ctx ->
    { render: render ctx
    , onMessage: onMessage
    , onKeyDown: onKeyDown
    , onError: onError
    , onClose: onClose
    }

render :: forall e. RenderingContext -> CM e Unit
render ctx = do
  state <- get
  pId <- askPlayerId
  case state of
    CInProgress g -> do
      liftEff $ R.render ctx g.game pId g.redrawMap
      put $ CInProgress (g # redrawMap .~ false)

      players <- askPlayers
      let html = V.simpleScores players g.game
      when (g.cachedHtml /= html) $ do
        liftEff $ q' "#scores-container" >>= setInnerHTML html
        put $ CInProgress (g # cachedHtml .~ html)

    CWaitingForPlayers sw -> do
      when (not (sw ^. backgroundCleared)) $ do
        liftEff $ R.clearBoth ctx
        put $ CWaitingForPlayers (sw # backgroundCleared .~ true)

      players <- askPlayers
      let html = V.waitingMessage sw pId players
      when (sw.cachedHtml /= html) $ do
        liftEff $ do
          el <- q "#waiting-message"
          whenJust el $ setInnerHTML html
        put $ CWaitingForPlayers (sw # cachedHtml .~ html)

onKeyDown :: forall e. DOMEvent -> CM e Unit
onKeyDown event = do
  state <- get
  code <- liftEff $ keyCode event

  case state of
    CInProgress _ -> do
      whenJust (directionFromKeyCode code) $ \direction ->
        sendUpdate (SIInProgress direction)

    CWaitingForPlayers sw -> do
      when (code == keyCodeSpace) do
        sendUpdate SIToggleReadyState

type CM e a = ClientM ClientState ServerIncomingMessage e a

matchInProgress :: forall e.
  ServerOutgoingMessage -> ([GameUpdate] -> CM e Unit) -> CM e Unit
matchInProgress = matchMessage asInProgressMessageO

matchWaiting :: forall e.
  ServerOutgoingMessage -> (WaitingUpdate -> CM e Unit) -> CM e Unit
matchWaiting = matchMessage asWaitingMessageO

onMessage msg = do
  state <- get
  case state of
    CInProgress g ->
      matchInProgress msg $ \updates ->
        let game' = applyGameUpdates updates g.game
        in if isEnded game'
            then do
              liftEff $ do
                showWaitingMessageDiv
                hideSimpleScoresDiv
              putWaitingState $ Just game'
            else do
              put $ CInProgress (g { game = game'
                                            , prevGame = g.game })

    CWaitingForPlayers g -> do
      matchWaiting msg $ \update -> do
        case update of
          GameStarting game -> do
            liftEff $ do
              hideWaitingMessageDiv
              showSimpleScoresDiv
            put $ CInProgress $ startNewGame game
          NewReadyStates m -> do
            put $ CWaitingForPlayers (g # readyStates .~ m)

startNewGame game =
  { game: game
  , prevGame: game
  , redrawMap: true
  , cachedHtml: ""
  }

onError = liftEff $ do
  withEl showElement "#error"
  withEl showElement "#error-overlay"

onClose = onError

putWaitingState :: forall e. Maybe Game -> CM e Unit
putWaitingState prevGame =
  put $ CWaitingForPlayers
          { prevGame: prevGame
          , backgroundCleared: false
          , readyStates: getStates prevGame
          , cachedHtml: ""
          }
  where
  getStates mg =
    case mg of
      Just g -> M.fromList $
        (\(Tuple pId _) -> pId ~ false) <$> (M.toList (g ^. players))
      Nothing -> M.empty

directionFromKeyCode :: Number -> Maybe Direction
directionFromKeyCode code =
  case code of
    38 -> Just Up
    40 -> Just Down
    37 -> Just Left
    39 -> Just Right
    _  -> Nothing

keyCodeSpace = 32
keyCodeEnter = 13

q sel = document globalWindow >>= querySelector sel

q' sel = fromJust <$> q sel

withEl f sel = do
  el <- q sel
  whenJust el $ f

showElement el = setAttribute "style" "display: block;" (el :: HTMLElement)
hideElement el = setAttribute "style" "display: none;" (el :: HTMLElement)

showWaitingMessageDiv = withEl showElement "#waiting-message"
hideWaitingMessageDiv = withEl hideElement "#waiting-message"

showSimpleScoresDiv = withEl showElement "#scores-container"
hideSimpleScoresDiv = withEl hideElement "#scores-container"

module Client where

import Debug.Trace (trace)
import Data.Maybe
import Data.Maybe.Unsafe (fromJust)
import qualified Data.Either as E
import Data.JSON (eitherDecode, encode)
import Data.Tuple
import qualified Data.String as S
import qualified Data.Map as M
import Data.DOM.Simple.Events hiding (view)
import Data.DOM.Simple.Types (DOM(), DOMEvent(), DOMLocation(), HTMLElement())
import Data.DOM.Simple.Window (globalWindow, location, document)
import Data.DOM.Simple.Element
  (setInnerHTML, querySelector, setAttribute, value, setValue, focus)
import Data.DOM.Simple.Events
  (keyCode, addKeyboardEventListener, KeyboardEventType(..))
import Data.DOM.Simple.Document ()
import Control.Monad
import Control.Monad.Eff
import Control.Monad.Eff.Ref
import Control.Monad.RWS.Class
import Control.Monad.State.Class
import Control.Lens (lens, (.~), (..), (^.), (~))
import Control.Reactive.Timer

import qualified BrowserWebSocket as WS
import qualified Rendering as R
import qualified HtmlViews as V
import BaseClient
import Game
import Types
import Utils
import LocalStorage

foreign import host
  """
  function host(location) {
    return location.host;
  }
  """ :: DOMLocation -> String

foreign import selectElement """
  function selectElement(el) {
    return function() {
      el.select()
    }
  }
""" :: forall e. HTMLElement -> Eff (dom :: DOM | e) Unit

initialState =
  CWaitingForPlayers
    { prevGame: Nothing
    , backgroundCleared: false
    , readyStates: M.empty
    , cachedHtml: ""
    }

main = do
  hideSimpleScoresDiv
  startRef <- newRef false
  loop startRef
  where
  loop startRef =
    promptScreenName "Enter a screen name:" $ \name ->
      if S.null (S.trim name)
         then loop startRef
         else start startRef name

promptScreenName :: forall e.
  String -> (String -> Eff (storage :: Storage, dom :: DOM | e) Unit)
  -> Eff (storage :: Storage, dom :: DOM | e) Unit
promptScreenName msg cont = do
  let key = "screenName"
  mVal <- getStorage key
  let val = fromMaybe "" mVal
  popupPromptInput msg val $ \name -> do
    setStorage "screenName" name
    cont name

popupPromptInput msg val cont = do
  containerEl <- q' "#prompt"
  showElement (containerEl :: HTMLElement)

  messageEl <- q' "#prompt-message"
  setInnerHTML msg (messageEl :: HTMLElement)

  inputEl <- q' "#prompt-input"
  setValue val (inputEl :: HTMLElement)

  focus inputEl
  selectElement inputEl

  addKeyboardEventListener
    KeydownEvent
    (handleKeydown containerEl inputEl)
    inputEl
  where
  handleKeydown cEl iEl event = do
    code <- keyCode (event :: DOMEvent)
    when (code == keyCodeEnter) $ do
      hideElement cEl
      value iEl >>= cont

start startedRef name = do
  started <- readRef startedRef
  when (not started) $ do
    writeRef startedRef true

    callbacks <- mkCallbacks
    h <- host <$> location globalWindow

    let socketUrl = "ws://" <> h <> "/"
    startClient initialState callbacks socketUrl name

-- CALLBACKS
mkCallbacks =
  R.setupRendering <#> \ctx ->
    { render: render ctx
    , onMessage: onMessage
    , onKeyDown: onKeyDown
    , onError: onError
    , onClose: onClose
    }

render :: forall e. RenderingContext -> CM e Unit
render ctx = do
  state <- get
  pId <- askPlayerId
  case state of
    CInProgress g -> do
      liftEff $ R.render ctx g.game pId g.redrawMap
      put $ CInProgress (g # redrawMap .~ false)

      players <- askPlayers
      let html = V.simpleScores players g.game
      when (g.cachedHtml /= html) $ do
        liftEff $ q' "#scores-container" >>= setInnerHTML html
        put $ CInProgress (g # cachedHtml .~ html)

    CWaitingForPlayers sw -> do
      when (not (sw ^. backgroundCleared)) $ do
        liftEff $ R.clearBoth ctx
        put $ CWaitingForPlayers (sw # backgroundCleared .~ true)

      players <- askPlayers
      let html = V.waitingMessage sw pId players
      when (sw.cachedHtml /= html) $ do
        liftEff $ do
          el <- q "#waiting-message"
          whenJust el $ setInnerHTML html
        put $ CWaitingForPlayers (sw # cachedHtml .~ html)

onKeyDown :: forall e. DOMEvent -> CM e Unit
onKeyDown event = do
  state <- get
  code <- liftEff $ keyCode event

  case state of
    CInProgress _ -> do
      whenJust (directionFromKeyCode code) $ \direction ->
        sendUpdate (SIInProgress direction)

    CWaitingForPlayers sw -> do
      when (code == keyCodeSpace) do
        sendUpdate SIToggleReadyState

type CM e a = ClientM ClientState ServerIncomingMessage e a

matchInProgress :: forall e.
  ServerOutgoingMessage -> ([GameUpdate] -> CM e Unit) -> CM e Unit
matchInProgress = matchMessage asInProgressMessageO

matchWaiting :: forall e.
  ServerOutgoingMessage -> (WaitingUpdate -> CM e Unit) -> CM e Unit
matchWaiting = matchMessage asWaitingMessageO

onMessage msg = do
  state <- get
  case state of
    CInProgress g ->
      matchInProgress msg $ \updates ->
        let game' = applyGameUpdates updates g.game
        in if isEnded game'
            then do
              liftEff $ do
                showWaitingMessageDiv
                hideSimpleScoresDiv
              putWaitingState $ Just game'
            else do
              put $ CInProgress (g { game = game'
                                            , prevGame = g.game })

    CWaitingForPlayers g -> do
      matchWaiting msg $ \update -> do
        case update of
          GameStarting game -> do
            liftEff $ do
              hideWaitingMessageDiv
              showSimpleScoresDiv
            put $ CInProgress $ startNewGame game
          NewReadyStates m -> do
            put $ CWaitingForPlayers (g # readyStates .~ m)

startNewGame game =
  { game: game
  , prevGame: game
  , redrawMap: true
  , cachedHtml: ""
  }

onError = liftEff $ do
  withEl showElement "#error"
  withEl showElement "#error-overlay"

onClose = onError

putWaitingState :: forall e. Maybe Game -> CM e Unit
putWaitingState prevGame =
  put $ CWaitingForPlayers
          { prevGame: prevGame
          , backgroundCleared: false
          , readyStates: getStates prevGame
          , cachedHtml: ""
          }
  where
  getStates mg =
    case mg of
      Just g -> M.fromList $
        (\(Tuple pId _) -> pId ~ false) <$> (M.toList (g ^. players))
      Nothing -> M.empty

directionFromKeyCode :: Number -> Maybe Direction
directionFromKeyCode code =
  case code of
    38 -> Just Up
    40 -> Just Down
    37 -> Just Left
    39 -> Just Right
    _  -> Nothing

keyCodeSpace = 32
keyCodeEnter = 13

q sel = document globalWindow >>= querySelector sel

q' sel = fromJust <$> q sel

withEl f sel = do
  el <- q sel
  whenJust el $ f

showElement el = setAttribute "style" "display: block;" (el :: HTMLElement)
hideElement el = setAttribute "style" "display: none;" (el :: HTMLElement)

showWaitingMessageDiv = withEl showElement "#waiting-message"
hideWaitingMessageDiv = withEl hideElement "#waiting-message"

showSimpleScoresDiv = withEl showElement "#scores-container"
hideSimpleScoresDiv = withEl hideElement "#scores-container"


Path fix take 2

Path fix take 2

module Config where

baseUrl :: String
baseUrl = ""

serviceBaseUrl :: String
serviceBaseUrl = "/"

uploadUrl :: String
uploadUrl = serviceBaseUrl <> "upload"

metadataUrl :: String
metadataUrl = serviceBaseUrl <> "metadata/fs/"

dataUrl :: String
dataUrl = serviceBaseUrl <> "data/fs/"

queryUrl :: String
queryUrl = serviceBaseUrl <> "query/fs/"

notebookUrl :: String
notebookUrl = baseUrl <> "notebook.html"

searchTimeout :: Number
searchTimeout = 500

slamDataHome :: String
slamDataHome = baseUrl <> "index.html"

userEnabled :: Boolean
userEnabled = false

newFolderName :: String
newFolderName = "Untitled Folder"

notebookExtension :: String
notebookExtension = "slam"

newNotebookName :: String
newNotebookName = "Untitled Notebook." <> notebookExtension

newFileName :: String
newFileName = "Untitled File"

newDatabaseName :: String
newDatabaseName = "Untitled Database"

homeHash :: String
homeHash = "index.html#?sort=asc&q=path%3A%2F&salt="

notebookNameEditorId :: String
notebookNameEditorId = "name-editor"

module Config where

baseUrl :: String
baseUrl = ""

uploadUrl :: String
uploadUrl = baseUrl <> "upload"

metadataUrl :: String
metadataUrl = baseUrl <> "metadata/fs/"

dataUrl :: String
dataUrl = baseUrl <> "data/fs/"

queryUrl :: String
queryUrl = baseUrl <> "query/fs/"

notebookUrl :: String
notebookUrl = baseUrl <> "notebook.html"

searchTimeout :: Number
searchTimeout = 500

slamDataHome :: String
slamDataHome = baseUrl <> "index.html"

userEnabled :: Boolean
userEnabled = false

newFolderName :: String
newFolderName = "Untitled Folder"

notebookExtension :: String
notebookExtension = "slam"

newNotebookName :: String
newNotebookName = "Untitled Notebook." <> notebookExtension

newFileName :: String
newFileName = "Untitled File"

newDatabaseName :: String
newDatabaseName = "Untitled Database"

homeHash :: String
homeHash = "index.html#?sort=asc&q=path%3A%2F&salt="

notebookNameEditorId :: String
notebookNameEditorId = "name-editor"