Test for long query string stack overflow

module Test.QueryString (testSuite) where

import Data.Either
import Data.Foldable (for_)
import Data.Maybe
import Node.Express.Internal.QueryString
import Prelude
import Test.Unit
import Test.Unit.Assert

type TestCase a b = { input :: a, expected :: b }

queryParserTestCases =
    [ {input: "a=b",        expected: Right [Param "a" "b"]}
    , {input: "a=b&b=c",    expected: Right [Param "a" "b", Param "b" "c"]}
    , {input: "a[123]=&b=", expected: Right [Param "a[123]" "", Param "b" ""]}
    , {input: "",           expected: Right []}
    , {input: "a=b%20c",    expected: Right [Param "a" "b c"]}
    , {input: "a=b+c",      expected: Right [Param "a" "b c"]}
    , {input: "a=b=c",      expected: Right [Param "a" "b=c"]}
    , {input: "a%3Db=c",    expected: Right [Param "a=b" "c"]}
    ]

queryGetOneTestCases =
    [ {input: [Param "b" "c"],                  expected: Nothing}
    , {input: [],                               expected: Nothing}
    , {input: [Param "a" "b"],                  expected: Just "b"}
    , {input: [Param "a" "b", Param "a" "c"],   expected: Just "b"}
    ]

queryGetAllTestCases =
    [ {input: [Param "b" "c"],                  expected: []}
    , {input: [],                               expected: []}
    , {input: [Param "a" "b"],                  expected: ["b"]}
    , {input: [Param "a" "b", Param "a" "c"],   expected: ["b", "c"]}
    ]

doTest :: forall a b e. Show b => Eq b => (a -> b) -> TestCase a b -> Test e
doTest fun testCase = do
    let actual = fun testCase.input
        msg = show actual <> " should equal " <> show testCase.expected
    assert msg (actual == testCase.expected)

testSuite =
    suite "QueryString" do
        test "parse" do
            for_ queryParserTestCases $ doTest (\t -> parse t)
        test "getOne" do
            for_ queryGetOneTestCases $ doTest (\t -> getOne t "a")
        test "getAll" do
            for_ queryGetAllTestCases $ doTest (\t -> getAll t "a")


stylistic changes

stylistic changes

{-
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.Deck.Gripper
  ( gripperDefsForCard
  , renderGrippers
  , module SlamData.Workspace.Deck.Gripper.Def
  ) where

import SlamData.Prelude

import Data.Array as Array
import Data.Bifoldable (bifoldMap)

import Halogen.HTML as HH
import Halogen.HTML.Core (ClassName)
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.HTML.Properties.ARIA as ARIA

import SlamData.Render.ClassName as CN
import SlamData.Workspace.Deck.Common (DeckHTML)
import SlamData.Workspace.Deck.Component.Query (Query(StartSliding))
import SlamData.Workspace.Deck.Component.State (DisplayCard, eqDisplayCard)
import SlamData.Workspace.Deck.Gripper.Def (GripperDef(..))

gripperDefsForCard
  ∷ Array DisplayCard
  → DisplayCard
  → GripperDef × GripperDef
gripperDefsForCard cards card =
  Previous previousCardAvailable × Next nextCardAvailable
  where
  previousCardAvailable =
    fromMaybe true $
      not ∘ eqDisplayCard card <$> Array.head cards

  nextCardAvailable =
    isRight card

isAvailable ∷ GripperDef → Boolean
isAvailable = case _ of
  Previous available → available
  Next available → available

gripperLabel ∷ GripperDef → String
gripperLabel = case _ of
  Previous _ → "Access previous card"
  Next _ → "Access next card"

gripperClassName ∷ GripperDef → ClassName
gripperClassName = case _ of
  Previous _ → CN.cardGripper
  Next _ → CN.cardGripperLast

renderGrippers ∷ Boolean → Boolean → GripperDef × GripperDef → Array DeckHTML
renderGrippers isActiveCard isGrabbed =
  bifoldMap render render
  where
  render ∷ GripperDef → Array DeckHTML
  render gripperDef =
    if not (isAvailable gripperDef) || not isActiveCard then
      []
    else
      [ HH.button
          ([ HP.classes [ gripperClassName gripperDef ]
           , HE.onMouseDown $ HE.input $ StartSliding gripperDef
           , ARIA.grabbed $ show isGrabbed
           ]
           <> (guard isActiveCard $> ARIA.label (gripperLabel gripperDef))
          )
          []
      ]

{-
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.Deck.Gripper
  ( gripperDefsForCard
  , renderGrippers
  , module SlamData.Workspace.Deck.Gripper.Def
  ) where

import SlamData.Prelude

import Data.Array as Array
import Data.Bifoldable (bifoldMap)

import Halogen.HTML as HH
import Halogen.HTML.Core (ClassName)
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.HTML.Properties.ARIA as ARIA

import SlamData.Render.ClassName as CN
import SlamData.Workspace.Deck.Common (DeckHTML)
import SlamData.Workspace.Deck.Component.Query (Query(StartSliding))
import SlamData.Workspace.Deck.Component.State (DisplayCard, eqDisplayCard)
import SlamData.Workspace.Deck.Gripper.Def (GripperDef(..))

gripperDefsForCard
  ∷ Array DisplayCard
  → DisplayCard
  → GripperDef × GripperDef
gripperDefsForCard cards card =
  Previous previousCardAvailable × Next nextCardAvailable
  where
  previousCardAvailable =
    fromMaybe true $
      not ∘ eqDisplayCard card <$> Array.head cards

  nextCardAvailable =
    isRight card

isAvailable ∷ GripperDef → Boolean
isAvailable = case _ of
  Previous available → available
  Next available → available

gripperLabel ∷ GripperDef → String
gripperLabel = case _ of
  Previous _ → "Access previous card"
  Next _ → "Access next card"

gripperClassName ∷ GripperDef → ClassName
gripperClassName = case _ of
  Previous _ → CN.cardGripper
  Next _ → CN.cardGripperLast

renderGrippers ∷ Boolean → Boolean → GripperDef × GripperDef → Array DeckHTML
renderGrippers isActiveCard isGrabbed =
  bifoldMap render render
  where
  render ∷ GripperDef → Array DeckHTML
  render gripperDef =
    if (not $ isAvailable gripperDef) || (not $ isActiveCard) then
      []
    else
      [ HH.button
          ([ HP.classes [ gripperClassName gripperDef ]
           , HE.onMouseDown $ HE.input (StartSliding gripperDef)
           , ARIA.grabbed $ show $ isGrabbed
           ]
           ⊕ (guard (isActiveCard) $> ARIA.label (gripperLabel gripperDef))
          )
          []
      ]


Prevent Viz eval loop

Prevent Viz eval loop

{-
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.Viz.Component (vizComponent) where

import SlamData.Prelude

import Control.Monad.Eff.Exception (Error)

import Data.Argonaut (JArray, JCursor)
import Data.Array (length, null, cons, index)
import Data.Int as Int
import Data.Lens as Lens
import Data.Lens ((.~), (^?))
import Data.List as L
import Data.Map as M
import Data.Set as Set

import CSS.Geometry (marginBottom)
import CSS.Size (px)

import Halogen as H
import Halogen.CustomProps as Cp
import Halogen.HTML.CSS.Indexed as CSS
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP
import Halogen.HTML.Properties.Indexed.ARIA as ARIA
import Halogen.Themes.Bootstrap3 as B

import SlamData.Effects (Slam)
import SlamData.Form.Select (Select, autoSelect, newSelect, (⊝), ifSelected, trySelect', _value)
import SlamData.Quasar.Query as Quasar
import SlamData.Render.Common (row, glyph)
import SlamData.Render.CSS as Rc
import SlamData.Workspace.Card.CardType (CardType(Viz))
import SlamData.Workspace.Card.Chart.Aggregation (aggregationSelect)
import SlamData.Workspace.Card.Chart.Axis (analyzeJArray, Axis)
import SlamData.Workspace.Card.Chart.Axis as Ax
import SlamData.Workspace.Card.Chart.ChartConfiguration (ChartConfiguration, depends, dependsOnArr)
import SlamData.Workspace.Card.Chart.ChartType (ChartType(..), isPie)
import SlamData.Workspace.Card.Component as CC
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.Card.Port as P
import SlamData.Workspace.Card.Viz.Component.Query (QueryC, Query(..))
import SlamData.Workspace.Card.Viz.Component.State as VCS
import SlamData.Workspace.Card.Viz.Form.Component (formComponent)
import SlamData.Workspace.Card.Viz.Form.Component as Form
import SlamData.Workspace.LevelOfDetails (LevelOfDetails(..))

type VizHTML = H.ParentHTML Form.StateP QueryC Form.QueryP Slam ChartType
type VizDSL = H.ParentDSL VCS.State Form.StateP QueryC Form.QueryP Slam ChartType

-- | How does this module work?
-- | + Take a TaggedResource case of Port
-- | + Check that resource exists and if so analyze sample to extract Map from
-- |   JCursors to Axes otherwise leave it Map.empty and set available chart types
-- |   to Set.empty. Following steps don't do anything useful if sample is empty.
-- |   Localized in first part of EvalCard handler and updateForm function.
-- | + Load all resource and if it's not too big produce output port
-- |   Second part of EvalCard handler
-- |
-- | + Output port is response of currently active subcomponent which is `Form`
-- | + Form's state (ChartConfiguration) is record with `dimensions`,
-- |   `aggregations`, `series` and `measures` fields.
-- |   These fields are arrays of `Select JCursor`  where `Select α`
-- |   Is model of html combobox with maybe selected α and list of α choices.
-- | + Form can render any kind of `ChartConfiguration` and has weird logic
-- |   for doing this :)
-- |
-- | + Peeking form signals and running CardEval call `configure` func
-- |   (second through `updateForms`)
-- | + `configure` takes all subcomponent configuration and filters them
-- |   e.g. it removes already selected in first measure combobox value from
-- |   available to select choices of second measure combobox -->
-- |   nonsense output is forbidden (one shouldn't be able to make chart
-- |   from `foo` to `foo` groupped by `foo`)
-- | + After filtering (That's important!) previoiusly selected values must
-- |   be set with func `setPreviousValueFrom`.
-- | + Then we have updated config and set it back as subcomponent state.
-- |
-- | About `needToUpdate`
-- | This flag is set when we need to update `records` and `sample` fields.
-- | Basically it's true after parent in deck has changed its output.
-- | And it's false when we just re`configure`d subcomponents.
-- |
-- |   >>> TODO: update this note, or fix the code to restore the old needToUpdate
-- |       logic, if needed. -js
-- |
-- | cryogenian 04/29/2016

vizComponent ∷ H.Component CC.CardStateP CC.CardQueryP Slam
vizComponent = CC.makeCardComponent
  { cardType: Viz
  , component: H.parentComponent { render, eval, peek: Just peek }
  , initialState: H.parentState VCS.initialState
  , _State: CC._VizState
  , _Query: CC.makeQueryPrism' CC._VizQuery
  }

render ∷ VCS.State → VizHTML
render state =
  HH.div_
    [ renderHighLOD state
    , renderLowLOD state
    ]

renderHighLOD ∷ VCS.State → VizHTML
renderHighLOD state =
    HH.div
      [ HP.classes
          $ [ Rc.cardInput, HH.className "card-input-maximum-lod" ]
          ⊕ (guard (state.levelOfDetails ≠ High) $> B.hidden)
      ]
      [ renderEmpty $ not Set.isEmpty state.availableChartTypes
      , renderForm state
      ]

renderLowLOD ∷ VCS.State → VizHTML
renderLowLOD state =
  HH.div
    [ HP.classes
        $ [ HH.className "card-input-minimum-lod" ]
        ⊕ (guard (state.levelOfDetails ≠ Low) $> B.hidden)
    ]
    [ HH.button
      [ ARIA.label "Zoom or resize"
      , HP.title "Zoom or resize"
      , HE.onClick (HE.input_ (left ∘ CC.ZoomIn))
      ]
      [ glyph B.glyphiconPicture
      , HH.text "Zoom or resize"
      ]
    ]

renderEmpty ∷ Boolean → VizHTML
renderEmpty hidden =
  HH.div
    [ HP.classes
        $ [ B.alert, B.alertDanger ]
        ⊕ (guard hidden $> B.hide)
    , CSS.style $ marginBottom $ px 12.0
    ]
    [ HH.text "There is no available chart for this dataset" ]

renderForm ∷ VCS.State → VizHTML
renderForm state =
  HH.div
    [ HP.classes
        $ [ Rc.vizCardEditor ]
        ⊕ (guard hidden $> B.hide)
    ]
    [ renderChartTypeSelector state
    , renderChartConfiguration state
    ]
  where
  hidden ∷ Boolean
  hidden = Set.isEmpty state.availableChartTypes

renderChartTypeSelector ∷ VCS.State → VizHTML
renderChartTypeSelector state =
  HH.div
    [ HP.classes [ Rc.vizChartTypeSelector ] ]
    $ foldl (foldFn state.chartType) empty state.availableChartTypes
  where
  foldFn ∷ ChartType → Array VizHTML → ChartType → Array VizHTML
  foldFn selected accum current =
    flip cons accum $
      HH.img
        [ HP.src $ src current
        , HP.classes
            $ [ cls state.chartType ]
            ⊕ (guard (selected ≡ current) $> B.active)
        , HE.onClick (HE.input_ (right ∘ SetChartType current))
        ]

  src ∷ ChartType → String
  src Pie = "img/pie.svg"
  src Line = "img/line.svg"
  src Bar = "img/bar.svg"

  cls ∷ ChartType → HH.ClassName
  cls Pie = Rc.pieChartIcon
  cls Line = Rc.lineChartIcon
  cls Bar = Rc.barChartIcon

renderChartConfiguration ∷ VCS.State → VizHTML
renderChartConfiguration state =
  HH.div
    [ HP.classes [ Rc.vizChartConfiguration ] ]
    [ renderTab Pie
    , renderTab Line
    , renderTab Bar
    , renderDimensions state
    ]
  where
  renderTab ∷ ChartType → VizHTML
  renderTab ty =
    showIf (state.chartType ≡ ty)
    [ HH.slot ty \_ →
        { component: formComponent
        , initialState: H.parentState Form.initialState
        }
    ]

  showIf ∷ Boolean → Array VizHTML → VizHTML
  showIf ok content = HH.div [ HP.classes $ (guard (not ok) $> B.hide) ] content

renderDimensions ∷ VCS.State → VizHTML
renderDimensions state =
  row
  [ chartInput Rc.axisLabelParam "Axis label angle"
      (_.axisLabelAngle ⋙ show) RotateAxisLabel (isPie state.chartType)
  , chartInput Rc.axisLabelParam "Axis font size"
      (_.axisLabelFontSize ⋙ show) SetAxisFontSize (isPie state.chartType)
  ]
  where
  chartInput
    ∷ HH.ClassName
    → String
    → (VCS.State → String)
    → (Int → Unit → Query Unit)
    → Boolean → VizHTML
  chartInput cls labelText valueFromState queryCtor isHidden =
    HH.form
      [ HP.classes
          $ [ B.colXs6, cls ]
          ⊕ (guard isHidden $> B.hide)
      , Cp.nonSubmit
      ]
      [ label labelText
      , HH.input
          [ HP.classes [ B.formControl ]
          , HP.value $ valueFromState state
          , ARIA.label labelText
          , HE.onValueInput
              $ pure ∘ map (right ∘ flip queryCtor unit) ∘ stringToInt
          ]
      ]

  label ∷ String → VizHTML
  label str = HH.label [ HP.classes [ B.controlLabel ] ] [ HH.text str ]

  showIfNeqZero ∷ ∀ a. (Eq a, Show a, Semiring a) ⇒ a → String
  showIfNeqZero a = if zero ≡ a then "" else show a

  stringToInt ∷ String → Maybe Int
  stringToInt s = if s ≡ "" then Just 0 else Int.fromString s

-- Note: need to put running to state
eval ∷ QueryC ~> VizDSL
eval = coproduct cardEval vizEval

vizEval ∷ Query ~> VizDSL
vizEval q = do
  next <- case q of
    SetChartType ct n → H.modify (VCS._chartType .~ ct) $> n
    RotateAxisLabel angle n → H.modify (VCS._axisLabelAngle .~ angle) $> n
    SetAxisFontSize size n → H.modify (VCS._axisLabelFontSize .~ size) $> n
  configure
  CC.raiseUpdatedP' CC.EvalModelUpdate
  pure next

cardEval ∷ CC.CardEvalQuery ~> VizDSL
cardEval = case _ of
  CC.EvalCard info output next → do
    for (output ^? Lens._Just ∘ P._ChartOptions) \opts → do
      sample ← either (const []) id <$>
        H.fromAff (Quasar.sample opts.resource 0 20 :: Slam (Either Error JArray))
      if null sample
        then H.modify (VCS._availableChartTypes .~ Set.empty)
        else H.modify (VCS._sample .~ analyzeJArray sample) *> configure
    pure next
  CC.Save k → do
    st ← H.get
    config ← H.query st.chartType $ left $ H.request Form.GetConfiguration
    pure ∘ k $ Card.Viz
      { chartConfig: fromMaybe Form.initialState config
      , options:
          { chartType: st.chartType
          , axisLabelFontSize: st.axisLabelFontSize
          , axisLabelAngle: st.axisLabelAngle
          }
      }
  CC.Load card next → do
    case card of
      Card.Viz model → do
        let st = VCS.fromModel model
        H.set st
        H.query st.chartType
          $ left
          $ H.action $ Form.SetConfiguration model.chartConfig
        pure unit
      _ → pure unit
    pure next
  CC.SetDimensions dims next → do
    H.modify
      $ VCS._levelOfDetails
      .~ if dims.width < 576.0 ∨ dims.height < 416.0
           then Low
           else High
    pure next
  CC.ModelUpdated _ next →
    pure next
  CC.ZoomIn next →
    pure next

type AxisAccum =
  { category ∷ Array JCursor
  , value ∷ Array JCursor
  , time ∷ Array JCursor
  }

configure ∷ VizDSL Unit
configure = void do
  axises ← getAxises
  pieConf ← getOrInitial Pie
  setConfFor Pie $ pieBarConfiguration axises pieConf
  lineConf ← getOrInitial Line
  setConfFor Line $ lineConfiguration axises lineConf
  barConf ← getOrInitial Bar
  setConfFor Bar $ pieBarConfiguration axises barConf
  let chartTypes = available axises
  H.modify (VCS._availableChartTypes .~ available axises)
  case Set.toList chartTypes of
    L.Cons ct L.Nil → H.modify (VCS._chartType .~ ct)
    _ → pure unit
  where
  getOrInitial ∷ ChartType → VizDSL ChartConfiguration
  getOrInitial ty =
    map (fromMaybe Form.initialState)
      $ H.query ty
      $ left (H.request Form.GetConfiguration)

  setConfFor ∷ ChartType → ChartConfiguration → VizDSL Unit
  setConfFor ty conf =
    void $ H.query ty $ left $ H.action $ Form.SetConfiguration conf

  available ∷ AxisAccum → Set.Set ChartType
  available axises =
    foldMap Set.singleton
    $ if null axises.value
      then []
      else if not $ null axises.category
           then [Pie, Bar, Line]
           else if (null axises.time) && (length axises.value < 2)
                then []
                else [Line]

  getAxises ∷ VizDSL AxisAccum
  getAxises = do
    sample ← H.gets _.sample
    pure $ foldl axisFolder {category: [], value: [], time: [] } $ M.toList sample

  axisFolder ∷ AxisAccum → Tuple JCursor Axis → AxisAccum
  axisFolder accum (Tuple cursor axis)
    | Ax.isCatAxis axis = accum { category = cons cursor accum.category }
    | Ax.isValAxis axis = accum { value = cons cursor accum.value }
    | Ax.isTimeAxis axis = accum {time = cons cursor accum.time }
    | otherwise = accum

  setPreviousValueFrom
    ∷ ∀ a. (Eq a) ⇒ Maybe (Select a) → Select a → Select a
  setPreviousValueFrom mbSel target  =
    (maybe id trySelect' $ mbSel >>= Lens.view _value) $ target

  pieBarConfiguration ∷ AxisAccum → ChartConfiguration → ChartConfiguration
  pieBarConfiguration axises current =
    let allAxises = axises.category ⊕ axises.time ⊕ axises.value
        categories =
          setPreviousValueFrom (index current.series 0)
          $ autoSelect $ newSelect allAxises
        measures =
          setPreviousValueFrom (index current.measures 0)
          $ autoSelect $ newSelect $ depends categories axises.value
        firstSeries =
          setPreviousValueFrom (index current.series 1)
          $ newSelect $ ifSelected [categories] $ allAxises ⊝ categories
        secondSeries =
          setPreviousValueFrom (index current.series 2)
          $ newSelect $ ifSelected [categories, firstSeries]
          $ allAxises ⊝ categories ⊝ firstSeries
        aggregation =
          setPreviousValueFrom (index current.aggregations 0) aggregationSelect
    in { series: [categories, firstSeries, secondSeries]
       , dimensions: []
       , measures: [measures]
       , aggregations: [aggregation]
       }

  lineConfiguration ∷ AxisAccum → ChartConfiguration → ChartConfiguration
  lineConfiguration axises current =
    let allAxises = (axises.category ⊕ axises.time ⊕ axises.value)
        dimensions =
          setPreviousValueFrom (index current.dimensions 0)
          $ autoSelect $ newSelect $ dependsOnArr axises.value
          -- This is redundant, I've put it here to notify
          -- that this behaviour differs from pieBar and can be changed.
          $ allAxises
        firstMeasures =
          setPreviousValueFrom (index current.measures 0)
          $ autoSelect $ newSelect $ depends dimensions
          $ axises.value ⊝ dimensions
        secondMeasures =
          setPreviousValueFrom (index current.measures 1)
          $ newSelect $ ifSelected [firstMeasures]
          $ depends dimensions
          $ axises.value ⊝ firstMeasures ⊝ dimensions
        firstSeries =
          setPreviousValueFrom (index current.series 0)
          $ newSelect $ ifSelected [dimensions] $ allAxises ⊝ dimensions
        secondSeries =
          setPreviousValueFrom (index current.series 1)
          $ newSelect $ ifSelected [dimensions, firstSeries]
          $ allAxises ⊝ dimensions ⊝ firstSeries
        firstAggregation =
          setPreviousValueFrom (index current.aggregations 0) aggregationSelect
        secondAggregation =
          setPreviousValueFrom (index current.aggregations 1) aggregationSelect
    in { series: [firstSeries, secondSeries]
       , dimensions: [dimensions]
       , measures: [firstMeasures, secondMeasures]
       , aggregations: [firstAggregation, secondAggregation]
       }

peek ∷ ∀ a. H.ChildF ChartType Form.QueryP a → VizDSL Unit
peek _ = configure *> CC.raiseUpdatedP' CC.EvalModelUpdate

{-
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.Viz.Component (vizComponent) where

import SlamData.Prelude

import Control.Monad.Eff.Exception (Error)

import Data.Argonaut (JArray, JCursor)
import Data.Array (length, null, cons, index)
import Data.Int as Int
import Data.Lens as Lens
import Data.Lens ((.~), (^?))
import Data.List as L
import Data.Map as M
import Data.Set as Set

import CSS.Geometry (marginBottom)
import CSS.Size (px)

import Halogen as H
import Halogen.CustomProps as Cp
import Halogen.HTML.CSS.Indexed as CSS
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP
import Halogen.HTML.Properties.Indexed.ARIA as ARIA
import Halogen.Themes.Bootstrap3 as B

import SlamData.Effects (Slam)
import SlamData.Form.Select (Select, autoSelect, newSelect, (⊝), ifSelected, trySelect', _value)
import SlamData.Quasar.Query as Quasar
import SlamData.Render.Common (row, glyph)
import SlamData.Render.CSS as Rc
import SlamData.Workspace.Card.CardType (CardType(Viz))
import SlamData.Workspace.Card.Chart.Aggregation (aggregationSelect)
import SlamData.Workspace.Card.Chart.Axis (analyzeJArray, Axis)
import SlamData.Workspace.Card.Chart.Axis as Ax
import SlamData.Workspace.Card.Chart.ChartConfiguration (ChartConfiguration, depends, dependsOnArr)
import SlamData.Workspace.Card.Chart.ChartType (ChartType(..), isPie)
import SlamData.Workspace.Card.Component as CC
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.Card.Port as P
import SlamData.Workspace.Card.Viz.Component.Query (QueryC, Query(..))
import SlamData.Workspace.Card.Viz.Component.State as VCS
import SlamData.Workspace.Card.Viz.Form.Component (formComponent)
import SlamData.Workspace.Card.Viz.Form.Component as Form
import SlamData.Workspace.LevelOfDetails (LevelOfDetails(..))

type VizHTML = H.ParentHTML Form.StateP QueryC Form.QueryP Slam ChartType
type VizDSL = H.ParentDSL VCS.State Form.StateP QueryC Form.QueryP Slam ChartType

-- | How does this module work?
-- | + Take a TaggedResource case of Port
-- | + Check that resource exists and if so analyze sample to extract Map from
-- |   JCursors to Axes otherwise leave it Map.empty and set available chart types
-- |   to Set.empty. Following steps don't do anything useful if sample is empty.
-- |   Localized in first part of EvalCard handler and updateForm function.
-- | + Load all resource and if it's not too big produce output port
-- |   Second part of EvalCard handler
-- |
-- | + Output port is response of currently active subcomponent which is `Form`
-- | + Form's state (ChartConfiguration) is record with `dimensions`,
-- |   `aggregations`, `series` and `measures` fields.
-- |   These fields are arrays of `Select JCursor`  where `Select α`
-- |   Is model of html combobox with maybe selected α and list of α choices.
-- | + Form can render any kind of `ChartConfiguration` and has weird logic
-- |   for doing this :)
-- |
-- | + Peeking form signals and running CardEval call `configure` func
-- |   (second through `updateForms`)
-- | + `configure` takes all subcomponent configuration and filters them
-- |   e.g. it removes already selected in first measure combobox value from
-- |   available to select choices of second measure combobox -->
-- |   nonsense output is forbidden (one shouldn't be able to make chart
-- |   from `foo` to `foo` groupped by `foo`)
-- | + After filtering (That's important!) previoiusly selected values must
-- |   be set with func `setPreviousValueFrom`.
-- | + Then we have updated config and set it back as subcomponent state.
-- |
-- | About `needToUpdate`
-- | This flag is set when we need to update `records` and `sample` fields.
-- | Basically it's true after parent in deck has changed its output.
-- | And it's false when we just re`configure`d subcomponents.
-- |
-- |   >>> TODO: update this note, or fix the code to restore the old needToUpdate
-- |       logic, if needed. -js
-- |
-- | cryogenian 04/29/2016

vizComponent ∷ H.Component CC.CardStateP CC.CardQueryP Slam
vizComponent = CC.makeCardComponent
  { cardType: Viz
  , component: H.parentComponent { render, eval, peek: Just peek }
  , initialState: H.parentState VCS.initialState
  , _State: CC._VizState
  , _Query: CC.makeQueryPrism' CC._VizQuery
  }

render ∷ VCS.State → VizHTML
render state =
  HH.div_
    [ renderHighLOD state
    , renderLowLOD state
    ]

renderHighLOD ∷ VCS.State → VizHTML
renderHighLOD state =
    HH.div
      [ HP.classes
          $ [ Rc.cardInput, HH.className "card-input-maximum-lod" ]
          ⊕ (guard (state.levelOfDetails ≠ High) $> B.hidden)
      ]
      [ renderEmpty $ not Set.isEmpty state.availableChartTypes
      , renderForm state
      ]

renderLowLOD ∷ VCS.State → VizHTML
renderLowLOD state =
  HH.div
    [ HP.classes
        $ [ HH.className "card-input-minimum-lod" ]
        ⊕ (guard (state.levelOfDetails ≠ Low) $> B.hidden)
    ]
    [ HH.button
      [ ARIA.label "Zoom or resize"
      , HP.title "Zoom or resize"
      , HE.onClick (HE.input_ (left ∘ CC.ZoomIn))
      ]
      [ glyph B.glyphiconPicture
      , HH.text "Zoom or resize"
      ]
    ]

renderEmpty ∷ Boolean → VizHTML
renderEmpty hidden =
  HH.div
    [ HP.classes
        $ [ B.alert, B.alertDanger ]
        ⊕ (guard hidden $> B.hide)
    , CSS.style $ marginBottom $ px 12.0
    ]
    [ HH.text "There is no available chart for this dataset" ]

renderForm ∷ VCS.State → VizHTML
renderForm state =
  HH.div
    [ HP.classes
        $ [ Rc.vizCardEditor ]
        ⊕ (guard hidden $> B.hide)
    ]
    [ renderChartTypeSelector state
    , renderChartConfiguration state
    ]
  where
  hidden ∷ Boolean
  hidden = Set.isEmpty state.availableChartTypes

renderChartTypeSelector ∷ VCS.State → VizHTML
renderChartTypeSelector state =
  HH.div
    [ HP.classes [ Rc.vizChartTypeSelector ] ]
    $ foldl (foldFn state.chartType) empty state.availableChartTypes
  where
  foldFn ∷ ChartType → Array VizHTML → ChartType → Array VizHTML
  foldFn selected accum current =
    flip cons accum $
      HH.img
        [ HP.src $ src current
        , HP.classes
            $ [ cls state.chartType ]
            ⊕ (guard (selected ≡ current) $> B.active)
        , HE.onClick (HE.input_ (right ∘ SetChartType current))
        ]

  src ∷ ChartType → String
  src Pie = "img/pie.svg"
  src Line = "img/line.svg"
  src Bar = "img/bar.svg"

  cls ∷ ChartType → HH.ClassName
  cls Pie = Rc.pieChartIcon
  cls Line = Rc.lineChartIcon
  cls Bar = Rc.barChartIcon

renderChartConfiguration ∷ VCS.State → VizHTML
renderChartConfiguration state =
  HH.div
    [ HP.classes [ Rc.vizChartConfiguration ] ]
    [ renderTab Pie
    , renderTab Line
    , renderTab Bar
    , renderDimensions state
    ]
  where
  renderTab ∷ ChartType → VizHTML
  renderTab ty =
    showIf (state.chartType ≡ ty)
    [ HH.slot ty \_ →
        { component: formComponent
        , initialState: H.parentState Form.initialState
        }
    ]

  showIf ∷ Boolean → Array VizHTML → VizHTML
  showIf ok content = HH.div [ HP.classes $ (guard (not ok) $> B.hide) ] content

renderDimensions ∷ VCS.State → VizHTML
renderDimensions state =
  row
  [ chartInput Rc.axisLabelParam "Axis label angle"
      (_.axisLabelAngle ⋙ show) RotateAxisLabel (isPie state.chartType)
  , chartInput Rc.axisLabelParam "Axis font size"
      (_.axisLabelFontSize ⋙ show) SetAxisFontSize (isPie state.chartType)
  ]
  where
  chartInput
    ∷ HH.ClassName
    → String
    → (VCS.State → String)
    → (Int → Unit → Query Unit)
    → Boolean → VizHTML
  chartInput cls labelText valueFromState queryCtor isHidden =
    HH.form
      [ HP.classes
          $ [ B.colXs6, cls ]
          ⊕ (guard isHidden $> B.hide)
      , Cp.nonSubmit
      ]
      [ label labelText
      , HH.input
          [ HP.classes [ B.formControl ]
          , HP.value $ valueFromState state
          , ARIA.label labelText
          , HE.onValueInput
              $ pure ∘ map (right ∘ flip queryCtor unit) ∘ stringToInt
          ]
      ]

  label ∷ String → VizHTML
  label str = HH.label [ HP.classes [ B.controlLabel ] ] [ HH.text str ]

  showIfNeqZero ∷ ∀ a. (Eq a, Show a, Semiring a) ⇒ a → String
  showIfNeqZero a = if zero ≡ a then "" else show a

  stringToInt ∷ String → Maybe Int
  stringToInt s = if s ≡ "" then Just 0 else Int.fromString s

-- Note: need to put running to state
eval ∷ QueryC ~> VizDSL
eval = coproduct cardEval vizEval

vizEval ∷ Query ~> VizDSL
vizEval = case _ of
  SetChartType ct next →
    H.modify (VCS._chartType .~ ct) *> configure $> next
  RotateAxisLabel angle next →
    H.modify (VCS._axisLabelAngle .~ angle) *> configure $> next
  SetAxisFontSize size next →
    H.modify (VCS._axisLabelFontSize .~ size) *> configure $> next

cardEval ∷ CC.CardEvalQuery ~> VizDSL
cardEval = case _ of
  CC.EvalCard info output next → do
    for (output ^? Lens._Just ∘ P._ChartOptions) \opts → do
      sample ← either (const []) id <$>
        H.fromAff (Quasar.sample opts.resource 0 20 :: Slam (Either Error JArray))
      if null sample
        then H.modify (VCS._availableChartTypes .~ Set.empty)
        else H.modify (VCS._sample .~ analyzeJArray sample) *> configure
    pure next
  CC.Save k → do
    st ← H.get
    config ← H.query st.chartType $ left $ H.request Form.GetConfiguration
    pure ∘ k $ Card.Viz
      { chartConfig: fromMaybe Form.initialState config
      , options:
          { chartType: st.chartType
          , axisLabelFontSize: st.axisLabelFontSize
          , axisLabelAngle: st.axisLabelAngle
          }
      }
  CC.Load card next → do
    case card of
      Card.Viz model → do
        let st = VCS.fromModel model
        H.set st
        H.query st.chartType
          $ left
          $ H.action $ Form.SetConfiguration model.chartConfig
        pure unit
      _ → pure unit
    pure next
  CC.SetDimensions dims next → do
    H.modify
      $ VCS._levelOfDetails
      .~ if dims.width < 576.0 ∨ dims.height < 416.0
           then Low
           else High
    pure next
  CC.ModelUpdated _ next →
    pure next
  CC.ZoomIn next →
    pure next

type AxisAccum =
  { category ∷ Array JCursor
  , value ∷ Array JCursor
  , time ∷ Array JCursor
  }

configure ∷ VizDSL Unit
configure = void do
  axises ← getAxises
  pieConf ← getOrInitial Pie
  setConfFor Pie $ pieBarConfiguration axises pieConf
  lineConf ← getOrInitial Line
  setConfFor Line $ lineConfiguration axises lineConf
  barConf ← getOrInitial Bar
  setConfFor Bar $ pieBarConfiguration axises barConf
  let chartTypes = available axises
  H.modify (VCS._availableChartTypes .~ available axises)
  case Set.toList chartTypes of
    L.Cons ct L.Nil → H.modify (VCS._chartType .~ ct)
    _ → pure unit
  CC.raiseUpdatedP' CC.EvalModelUpdate
  where
  getOrInitial ∷ ChartType → VizDSL ChartConfiguration
  getOrInitial ty =
    map (fromMaybe Form.initialState)
      $ H.query ty
      $ left (H.request Form.GetConfiguration)

  setConfFor ∷ ChartType → ChartConfiguration → VizDSL Unit
  setConfFor ty conf =
    void $ H.query ty $ left $ H.action $ Form.SetConfiguration conf

  available ∷ AxisAccum → Set.Set ChartType
  available axises =
    foldMap Set.singleton
    $ if null axises.value
      then []
      else if not $ null axises.category
           then [Pie, Bar, Line]
           else if (null axises.time) && (length axises.value < 2)
                then []
                else [Line]

  getAxises ∷ VizDSL AxisAccum
  getAxises = do
    sample ← H.gets _.sample
    pure $ foldl axisFolder {category: [], value: [], time: [] } $ M.toList sample

  axisFolder ∷ AxisAccum → Tuple JCursor Axis → AxisAccum
  axisFolder accum (Tuple cursor axis)
    | Ax.isCatAxis axis = accum { category = cons cursor accum.category }
    | Ax.isValAxis axis = accum { value = cons cursor accum.value }
    | Ax.isTimeAxis axis = accum {time = cons cursor accum.time }
    | otherwise = accum

  setPreviousValueFrom
    ∷ ∀ a. (Eq a) ⇒ Maybe (Select a) → Select a → Select a
  setPreviousValueFrom mbSel target  =
    (maybe id trySelect' $ mbSel >>= Lens.view _value) $ target

  pieBarConfiguration ∷ AxisAccum → ChartConfiguration → ChartConfiguration
  pieBarConfiguration axises current =
    let allAxises = axises.category ⊕ axises.time ⊕ axises.value
        categories =
          setPreviousValueFrom (index current.series 0)
          $ autoSelect $ newSelect allAxises
        measures =
          setPreviousValueFrom (index current.measures 0)
          $ autoSelect $ newSelect $ depends categories axises.value
        firstSeries =
          setPreviousValueFrom (index current.series 1)
          $ newSelect $ ifSelected [categories] $ allAxises ⊝ categories
        secondSeries =
          setPreviousValueFrom (index current.series 2)
          $ newSelect $ ifSelected [categories, firstSeries]
          $ allAxises ⊝ categories ⊝ firstSeries
        aggregation =
          setPreviousValueFrom (index current.aggregations 0) aggregationSelect
    in { series: [categories, firstSeries, secondSeries]
       , dimensions: []
       , measures: [measures]
       , aggregations: [aggregation]
       }

  lineConfiguration ∷ AxisAccum → ChartConfiguration → ChartConfiguration
  lineConfiguration axises current =
    let allAxises = (axises.category ⊕ axises.time ⊕ axises.value)
        dimensions =
          setPreviousValueFrom (index current.dimensions 0)
          $ autoSelect $ newSelect $ dependsOnArr axises.value
          -- This is redundant, I've put it here to notify
          -- that this behaviour differs from pieBar and can be changed.
          $ allAxises
        firstMeasures =
          setPreviousValueFrom (index current.measures 0)
          $ autoSelect $ newSelect $ depends dimensions
          $ axises.value ⊝ dimensions
        secondMeasures =
          setPreviousValueFrom (index current.measures 1)
          $ newSelect $ ifSelected [firstMeasures]
          $ depends dimensions
          $ axises.value ⊝ firstMeasures ⊝ dimensions
        firstSeries =
          setPreviousValueFrom (index current.series 0)
          $ newSelect $ ifSelected [dimensions] $ allAxises ⊝ dimensions
        secondSeries =
          setPreviousValueFrom (index current.series 1)
          $ newSelect $ ifSelected [dimensions, firstSeries]
          $ allAxises ⊝ dimensions ⊝ firstSeries
        firstAggregation =
          setPreviousValueFrom (index current.aggregations 0) aggregationSelect
        secondAggregation =
          setPreviousValueFrom (index current.aggregations 1) aggregationSelect
    in { series: [firstSeries, secondSeries]
       , dimensions: [dimensions]
       , measures: [firstMeasures, secondMeasures]
       , aggregations: [firstAggregation, secondAggregation]
       }

peek ∷ ∀ a. H.ChildF ChartType Form.QueryP a → VizDSL Unit
peek _ = configure


Clean up unnecessary stuff

Clean up unnecessary stuff

module Halogen.Component
  ( Component()
  , ComponentHTML()
  , Render()
  , ComponentDSL()
  , Eval()
  , component
  , ParentHTML()
  , RenderParent()
  , SlotConstructor(..)
  , ParentDSL()
  , EvalParent()
  , Peek()
  , parentComponent
  , parentComponent'
  , InstalledState()
  , installedState
  , ChildF(..)
  , QueryF()
  , mkQuery
  , mkQuery'
  , liftQuery
  , query
  , query'
  , interpret
  , transformChild
  , renderComponent
  , queryComponent
  ) where

import Prelude

import Control.Apply ((<*))
import Control.Bind ((=<<), (<=<), (>=>))
import Control.Coroutine (await)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Class (MonadEff, liftEff)
import Control.Monad.Free (Free(), foldFree, liftF, mapF)
import Control.Monad.Rec.Class (forever)
import Control.Monad.State (State(), runState)
import Control.Monad.Trans (lift)
import Control.Plus (empty)
import qualified Control.Monad.State.Class as CMS
import qualified Control.Monad.State.Trans as CMS

import Data.Bifunctor (bimap, lmap, rmap)
import Data.Const (Const())
import Data.Either (Either(..), either)
import Data.Functor.Coproduct (Coproduct(..), coproduct, left, right)
import Data.Maybe (Maybe(..), maybe, fromMaybe')
import Data.NaturalTransformation (Natural())
import Data.Traversable (for)
import Data.Tuple (Tuple(..), snd)
import Data.Void (Void())
import qualified Data.Either.Unsafe as U
import qualified Data.Map as M
import qualified Data.Maybe.Unsafe as U

import Halogen.Component.ChildPath (ChildPath(), injState, injQuery, injSlot, prjState, prjQuery, prjSlot)
import Halogen.HTML.Core (HTML(..), fillSlot)
import Halogen.Query (HalogenF(..), get, modify, liftH, hoistHalogenF, transformHF)
import Halogen.Query.StateF (StateF(), mapState)
import Halogen.Query.SubscribeF (SubscribeF(), subscribeN, remapSubscribe, hoistSubscribe)

-- | Data type for Halogen components.
-- | - `s` - the component's state
-- | - `f` - the component's query algebra
-- | - `g` - a functor integrated into the component's query algebra that allows
-- |         embedding of external DSLs or handling of effects.
newtype Component s f g = Component
  { render :: State s (HTML Void (f Unit))
  , eval :: Eval f s f g
  }

-- | The type for `HTML` rendered by a self-contained component.
type ComponentHTML f = HTML Void (f Unit)

-- | A type alias for a component `render` function - takes the component's
-- | current state and returns a `HTML` value.
type Render s f = s -> ComponentHTML f

-- | The DSL used in the `eval` function for self-contained components.
type ComponentDSL s f g = Free (HalogenF s f g)

-- | A type alias for a component `eval` function - takes a functorial value `i`
-- | and returns a `Free` of the Halogen component algebra.
-- |
-- | Usually `i` will be the same type as `f`, but sometimes it is useful to be
-- | able to break up an `Eval` function into different parts, in which case
-- | `i`'s type may differ.
type Eval i s f g = Natural i (ComponentDSL s f g)

-- | Builds a self-contained component with no possible children.
component :: forall s f g. Render s f -> Eval f s f g -> Component s f g
component r e = Component { render: CMS.gets r, eval: e }

-- | The type for `HTML` rendered by a parent component.
type ParentHTML s' f f' g p = HTML (SlotConstructor s' f' g p) (f Unit)

-- | A variation on `Render` for parent components - the function follows the
-- | same form but the type representation is different.
type RenderParent s s' f f' g p = s -> ParentHTML s' f f' g p

-- | The type used for slots in the HTML rendered by parent components.
data SlotConstructor s' f' g p = SlotConstructor p (Unit -> { component :: Component s' f' g, initialState :: s' })

-- | The DSL used in the `eval` and `peek` functions for parent components.
type ParentDSL s s' f f' g p = ComponentDSL s f (QueryF s s' f f' g p)

-- | A variation on `Eval` for parent components - the function follows the
-- | same form but the type representation is different.
type EvalParent i s s' f f' g p = Natural i (ParentDSL s s' f f' g p)

-- | A type alias for a component `peek` function that observes inputs to child
-- | components.
type Peek i s s' f f' g p = forall a. i a -> ParentDSL s s' f f' g p Unit

-- | Builds a component that may contain child components.
parentComponent
  :: forall s s' f f' g p
   . (Functor g, Ord p)
  => RenderParent s s' f f' g p
  -> EvalParent f s s' f f' g p
  -> Component (InstalledState s s' f f' g p) (Coproduct f (ChildF p f')) g
parentComponent r e = Component { render: render r, eval: eval }
  where
  eval :: Eval (Coproduct f (ChildF p f')) (InstalledState s s' f f' g p) (Coproduct f (ChildF p f')) g
  eval = coproduct (queryParent e) queryChild

-- | Builds a component that may contain child components and additionally
-- | supports the `peek` operation to allow the parent to observe queries that
-- | descendant components have processed.
parentComponent'
  :: forall s s' f f' g p
   . (Functor g, Ord p)
  => RenderParent s s' f f' g p
  -> EvalParent f s s' f f' g p
  -> Peek (ChildF p f') s s' f f' g p
  -> Component (InstalledState s s' f f' g p) (Coproduct f (ChildF p f')) g
parentComponent' r e p = Component { render: render r, eval: eval }
  where
  eval :: Eval (Coproduct f (ChildF p f')) (InstalledState s s' f f' g p) (Coproduct f (ChildF p f')) g
  eval = coproduct (queryParent e) \q -> queryChild q <* peek q

  peek :: forall a. ChildF p f' a -> ComponentDSL (InstalledState s s' f f' g p) (Coproduct f (ChildF p f')) g Unit
  peek =
    p >>> foldFree \h ->
      case h of
        StateHF q -> mergeParentStateF q
        SubscribeHF q -> runSubscribeF (queryParent e) q
        QueryHF q -> liftChildF q
        HaltHF -> liftF empty

-- | The type used by component containers for their state where `s` is the
-- | state local to the container, `p` is the type of slot used by the
-- | container, and the remaining parameters are the type variables for the
-- | child components.
type InstalledState s s' f f' g p =
  { parent :: s
  , children :: M.Map p (Tuple (Component s' f' g) s')
  , memo :: M.Map p (HTML Void (Coproduct f (ChildF p f') Unit))
  }

-- | Lifts a state value into an `InstalledState` value. Useful when providing
-- | an initial state value for a parent component.
installedState :: forall s s' f f' g p. (Ord p) => s -> InstalledState s s' f f' g p
installedState = { parent: _, children: M.empty, memo: M.empty }

-- | An intermediate algebra that parent components "produce" from their `eval`
-- | and `peek` functions. This takes the place of `g` when compared to a leaf
-- | (non-parent) component.
type QueryF s s' f f' g p = Free (HalogenF (InstalledState s s' f f' g p) (ChildF p f') g)

-- | An intermediate algebra used to associate values from a child component's
-- | algebra with the slot the component was installed into.
data ChildF p f i = ChildF p (f i)

instance functorChildF :: (Functor f) => Functor (ChildF p f) where
  map f (ChildF p fi) = ChildF p (f <$> fi)

-- | Queries a child component, for use within a parent component's `eval` or
-- | `peek` function.
query
  :: forall s s' f f' g p i
   . (Functor g, Ord p)
  => p
  -> f' i
  -> Free (HalogenF s f (QueryF s s' f f' g p)) (Maybe i)
query p q = liftQuery (mkQuery p q)

-- | A version of [`query`](#query) for use when a parent component has multiple
-- | types of child component.
query'
  :: forall s s' s'' f f' f'' g p p' i
   . (Functor g, Ord p')
  => ChildPath s s' f f' p p'
  -> p
  -> f i
  -> Free (HalogenF s'' f'' (QueryF s'' s' f'' f' g p')) (Maybe i)
query' i p q = liftQuery (mkQuery' i p q)

-- | Creates a query for a child component where `p` is the slot the component
-- | was installed into and `f' i` in the input query.
-- |
-- | If a component is not found for the slot the result of the query
-- | will be `Nothing`.
mkQuery
  :: forall s s' f f' p g i
   . (Functor g, Ord p)
  => p
  -> f' i
  -> QueryF s s' f f' g p (Maybe i)
mkQuery p q = do
  st <- get
  for (M.lookup p st.children) \(Tuple c _) ->
    mapF (transformHF (mapStateFChild p) (ChildF p) id) (queryComponent c q)

-- | A version of [`mkQuery`](#mkQuery) for use when a parent component has
-- | multiple types of child component.
mkQuery'
  :: forall s s' s'' f f' f'' g p p' i
   . (Functor g, Ord p')
  => ChildPath s s' f f' p p'
  -> p
  -> f i
  -> QueryF s'' s' f'' f' g p' (Maybe i)
mkQuery' i p q = mkQuery (injSlot i p) (injQuery i q)

-- | Lifts a value in the `QueryF` algebra into the monad used by a component's
-- | `eval` function.
liftQuery
  :: forall s s' f f' g p
   . (Functor g)
  => EvalParent (QueryF s s' f f' g p) s s' f f' g p
liftQuery = liftH

mapStateFParent :: forall s s' f f' g p. Natural (StateF s) (StateF (InstalledState s s' f f' g p))
mapStateFParent = mapState (_.parent) (\f st -> st { parent = f st.parent })

mapStateFChild :: forall s s' f f' g p. (Ord p) => p -> Natural (StateF s') (StateF (InstalledState s s' f f' g p))
mapStateFChild p =
  mapState
    (\st -> U.fromJust $ snd <$> M.lookup p st.children)
    (\f st -> { parent: st.parent, children: M.update (Just <<< rmap f) p st.children, memo: st.memo })

render
  :: forall s s' f f' g p
   . (Ord p)
  => (s -> HTML (SlotConstructor s' f' g p) (f Unit))
  -> State (InstalledState s s' f f' g p) (HTML Void ((Coproduct f (ChildF p f')) Unit))
render rc = do
    st <- CMS.get
    let html = rc st.parent
    -- Empty the state so that we don't keep children that are no longer
    -- being rendered...
    CMS.put
      { parent: st.parent
      , children: M.empty :: M.Map p (Tuple (Component s' f' g) s')
      , memo: M.empty :: M.Map p (HTML Void (Coproduct f (ChildF p f') Unit))
      }
    -- ...but then pass through the old state so we can lookup child
    -- components that are being re-rendered
    fillSlot (renderChild st) left html

  where

  renderChild
    :: InstalledState s s' f f' g p
    -> SlotConstructor s' f' g p
    -> State (InstalledState s s' f f' g p) (HTML Void ((Coproduct f (ChildF p f')) Unit))
  renderChild st (SlotConstructor p def) =
    let childState = M.lookup p st.children
    in case M.lookup p st.memo of
      Just html -> do
        CMS.modify \st' ->
          { parent: st'.parent
          , children: M.alter (const childState) p st'.children
          , memo: M.insert p html st'.memo
          } :: InstalledState s s' f f' g p
        pure html
      Nothing -> case childState of
        Just (Tuple c s) -> renderChild' p c s
        Nothing ->
          let def' = def unit
          in renderChild' p def'.component def'.initialState

  renderChild'
    :: p
    -> Component s' f' g
    -> s'
    -> State (InstalledState s s' f f' g p) (HTML Void ((Coproduct f (ChildF p f')) Unit))
  renderChild' p c s = case renderComponent c s of
    Tuple html s' -> do
      CMS.modify (\st -> { parent: st.parent, children: M.insert p (Tuple c s') st.children, memo: st.memo } :: InstalledState s s' f f' g p)
      pure $ right <<< ChildF p <$> html

queryParent
  :: forall s s' f f' g p. (Functor g)
  => EvalParent f s s' f f' g p
  -> Eval f (InstalledState s s' f f' g p) (Coproduct f (ChildF p f')) g
queryParent f =
  f >>> foldFree \h ->
    case h of
      StateHF q -> mergeParentStateF q
      SubscribeHF q -> runSubscribeF (queryParent f) q
      QueryHF q -> liftChildF q
      HaltHF -> liftF empty

mergeParentStateF :: forall s s' f f' g p. Eval (StateF s) (InstalledState s s' f f' g p) (Coproduct f (ChildF p f')) g
mergeParentStateF = liftF <<< StateHF <<< mapStateFParent

runSubscribeF
  :: forall s s' f f' g p
   . (Functor g)
  => Eval f (InstalledState s s' f f' g p) (Coproduct f (ChildF p f')) g
  -> Eval (SubscribeF f (Free (HalogenF (InstalledState s s' f f' g p) (ChildF p f') g))) (InstalledState s s' f f' g p) (Coproduct f (ChildF p f')) g
runSubscribeF queryParent' = subscribeN (forever $ lift <<< queryParent' =<< await) <<< hoistSubscribe liftChildF

liftChildF
  :: forall s s' f f' g p
   . (Functor g)
  => Eval (Free (HalogenF (InstalledState s s' f f' g p) (ChildF p f') g)) (InstalledState s s' f f' g p) (Coproduct f (ChildF p f')) g
liftChildF = mapF (transformHF id right id)

queryChild
  :: forall s s' f f' g p
   . (Functor g, Ord p)
  => Eval (ChildF p f') (InstalledState s s' f f' g p) (Coproduct f (ChildF p f')) g
queryChild (ChildF p q) = do
  modify \st -> { parent: st.parent, children: st.children, memo: M.delete p st.memo }
  mapF (transformHF id right id) (mkQuery p q)
    >>= maybe (liftF empty) pure

adaptState :: forall s t m a. (Monad m) => (s -> t) -> (t -> s) -> CMS.StateT s m a -> CMS.StateT t m a
adaptState st ts (CMS.StateT f) = CMS.StateT \state -> f (ts state) >>= \(Tuple a s) -> pure $ Tuple a (st s)

transform'
  :: forall s s' f f' g
   . (Functor g)
  => (s -> s')
  -> (s' -> s)
  -> Natural f f'
  -> Natural f' f
  -> Component s f g
  -> Component s' f' g
transform' sTo sFrom fTo fFrom (Component c) =
  Component { render: map fTo <$> adaptState sTo sFrom c.render
            , eval: mapF natHF <<< c.eval <<< fFrom
            }
  where
  natHF :: Natural (HalogenF s f g) (HalogenF s' f' g)
  natHF = transformHF (mapState sFrom (\f s -> sTo (f (sFrom s)))) fTo id

-- | Transforms a `Component`'s types using a `ChildPath` definition.
transformChild
  :: forall s s' f f' g p p'
   . (Functor g)
  => ChildPath s s' f f' p p'
  -> Component s f g
  -> Component s' f' g
transformChild i =
  transform'
    (injState i)
    (U.fromJust <<< prjState i)
    (injQuery i)
    (U.fromJust <<< prjQuery i)

-- | Changes the component's `g` type. A use case for this would be to interpret
-- | some `Free` monad as `Aff` so the component can be used with `runUI`.
interpret
  :: forall s f g g'
   . (Functor g')
  => Natural g g'
  -> Component s f g
  -> Component s f g'
interpret nat (Component c) =
  Component { render: c.render
            , eval: mapF (hoistHalogenF nat) <<< c.eval
            }

-- | Runs a component's `render` function with the specified state, returning
-- | the generated `HTML` and new state.
renderComponent :: forall s f g p. Component s f g -> s -> Tuple (HTML Void (f Unit)) s
renderComponent (Component c) = runState c.render

-- | Runs a compnent's `query` function with the specified query input and
-- | returns the pending computation as a `Free` monad.
queryComponent :: forall s f g p. Component s f g -> Eval f s f g
queryComponent (Component c) = c.eval

module Halogen.Component
  ( ComponentP()
  , Component()
  , ComponentHTML()
  , Render()
  , ComponentDSL()
  , Eval()
  , component
  , ParentHTML()
  , RenderParent()
  , SlotConstructor(..)
  , ParentDSL()
  , EvalParent()
  , Peek()
  , parentComponent
  , parentComponent'
  , InstalledState()
  , installedState
  , ChildF(..)
  , QueryF()
  , mkQuery
  , mkQuery'
  , liftQuery
  , query
  , query'
  , interpret
  , transformChild
  , renderComponent
  , queryComponent
  ) where

import Prelude

import Control.Apply ((<*))
import Control.Bind ((=<<), (<=<), (>=>))
import Control.Coroutine (await)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Class (MonadEff, liftEff)
import Control.Monad.Free (Free(), foldFree, liftF, mapF)
import Control.Monad.Rec.Class (forever)
import Control.Monad.State (State(), runState)
import Control.Monad.Trans (lift)
import Control.Plus (empty)
import qualified Control.Monad.State.Class as CMS
import qualified Control.Monad.State.Trans as CMS

import Data.Bifunctor (bimap, lmap, rmap)
import Data.Const (Const())
import Data.Either (Either(..), either)
import Data.Functor.Coproduct (Coproduct(..), coproduct, left, right)
import Data.Maybe (Maybe(..), maybe, fromMaybe')
import Data.NaturalTransformation (Natural())
import Data.Traversable (for)
import Data.Tuple (Tuple(..), snd)
import Data.Void (Void())
import qualified Data.Either.Unsafe as U
import qualified Data.Map as M
import qualified Data.Maybe.Unsafe as U

import Halogen.Component.ChildPath (ChildPath(), injState, injQuery, injSlot, prjState, prjQuery, prjSlot)
import Halogen.HTML.Core (HTML(..), fillSlot)
import Halogen.Query (HalogenF(..), get, modify, liftH, hoistHalogenF, transformHF)
import Halogen.Query.StateF (StateF(), mapState)
import Halogen.Query.SubscribeF (SubscribeF(), subscribeN, remapSubscribe, hoistSubscribe)

-- | Data type for Halogen components.
-- | - `s` - the component's state
-- | - `f` - the component's query algebra
-- | - `g` - a functor integrated into the component's query algebra that allows
-- |         embedding of external DSLs or handling of effects.
-- | - `o` - the type of values observable via `peek`, used to allow parent
-- |         components to see queries their children have acted upon.
-- | - `p` - the type of slot addresses within the component - these values
-- |         allow queries to child components to be specifically addressed.
newtype ComponentP s f g o p = Component
  { render :: State s (HTML p (f Unit))
  , eval :: Eval f s f g
  , peek :: PeekP o s f g
  }

instance functorComponent :: Functor (ComponentP s f g o) where
  map f (Component c) = Component { render: lmap f <$> c.render, eval: c.eval, peek: c.peek }

-- | A low level constructor for building components.
component' :: forall s f g o p. RenderP s f p -> Eval f s f g -> PeekP o s f g -> ComponentP s f g o p
component' r e p = Component { render: CMS.gets r, eval: e, peek: p }

-- | A type alias for self-contained Halogen components.
type Component s f g = ComponentP s f g (Const Void) Void

-- | A low level form of the `Render` and `RenderParent` synonyms, used
-- | internally.
type RenderP s f p = s -> HTML p (f Unit)

-- | The type for `HTML` rendered by a self-contained component.
type ComponentHTML f = HTML Void (f Unit)

-- | A type alias for a component `render` function - takes the component's
-- | current state and returns a `HTML` value.
type Render s f = s -> ComponentHTML f

-- | The DSL used in the `eval` function for self-contained components.
type ComponentDSL s f g = Free (HalogenF s f g)

-- | A type alias for a component `eval` function - takes a functorial value `i`
-- | and returns a `Free` of the Halogen component algebra.
-- |
-- | Usually `i` will be the same type as `f`, but sometimes it is useful to be
-- | able to break up an `Eval` function into different parts, in which case
-- | `i`'s type may differ.
type Eval i s f g = Natural i (ComponentDSL s f g)

-- | Builds a self-contained component with no possible children.
component :: forall s f g. Render s f -> Eval f s f g -> Component s f g
component r e = component' r e (const (pure unit))

-- | The type for `HTML` rendered by a parent component.
type ParentHTML s' f f' g p = HTML (SlotConstructor s' f' g p) (f Unit)

-- | A variation on `Render` for parent components - the function follows the
-- | same form but the type representation is different.
type RenderParent s s' f f' g p = s -> ParentHTML s' f f' g p

-- | The type used for slots in the HTML rendered by parent components.
data SlotConstructor s' f' g p = SlotConstructor p (Unit -> { component :: Component s' f' g, initialState :: s' })

-- | The DSL used in the `eval` and `peek` functions for parent components.
type ParentDSL s s' f f' g p = ComponentDSL s f (QueryF s s' f f' g p)

-- | A variation on `Eval` for parent components - the function follows the
-- | same form but the type representation is different.
type EvalParent i s s' f f' g p = Natural i (ParentDSL s s' f f' g p)

-- | A low level form of the `Peek` type synonym, used internally.
type PeekP i s f g = forall a. i a -> Free (HalogenF s f g) Unit

-- | A type alias for a component `peek` function that observes inputs to child
-- | components.
type Peek i s s' f f' g p = forall a. i a -> ParentDSL s s' f f' g p Unit

-- | Builds a component that may contain child components.
parentComponent
  :: forall s s' f f' g p
   . (Functor g, Ord p)
  => RenderParent s s' f f' g p
  -> EvalParent f s s' f f' g p
  -> Component (InstalledState s s' f f' g p) (Coproduct f (ChildF p f')) g
parentComponent r e = Component { render: render r, eval: eval, peek: const (pure unit) }
  where
  eval :: Eval (Coproduct f (ChildF p f')) (InstalledState s s' f f' g p) (Coproduct f (ChildF p f')) g
  eval = coproduct (queryParent e) queryChild

-- | Builds a component that may contain child components and additionally
-- | supports the `peek` operation to allow the parent to observe queries that
-- | descendant components have processed.
parentComponent'
  :: forall s s' f f' g p
   . (Functor g, Ord p)
  => RenderParent s s' f f' g p
  -> EvalParent f s s' f f' g p
  -> Peek (ChildF p f') s s' f f' g p
  -> Component (InstalledState s s' f f' g p) (Coproduct f (ChildF p f')) g
parentComponent' r e p = Component { render: render r, eval: eval, peek: const (pure unit) }
  where
  eval :: Eval (Coproduct f (ChildF p f')) (InstalledState s s' f f' g p) (Coproduct f (ChildF p f')) g
  eval = coproduct (queryParent e) \q -> queryChild q <* peek q

  peek :: PeekP (ChildF p f') (InstalledState s s' f f' g p) (Coproduct f (ChildF p f')) g
  peek =
    p >>> foldFree \h ->
      case h of
        StateHF q -> mergeParentStateF q
        SubscribeHF q -> runSubscribeF (queryParent e) q
        QueryHF q -> liftChildF q
        HaltHF -> liftF empty

-- | The type used by component containers for their state where `s` is the
-- | state local to the container, `p` is the type of slot used by the
-- | container, and the remaining parameters are the type variables for the
-- | child components.
type InstalledState s s' f f' g p =
  { parent :: s
  , children :: M.Map p (Tuple (Component s' f' g) s')
  , memo :: M.Map p (HTML Void (Coproduct f (ChildF p f') Unit))
  }

-- | Lifts a state value into an `InstalledState` value. Useful when providing
-- | an initial state value for a parent component.
installedState :: forall s s' f f' g p. (Ord p) => s -> InstalledState s s' f f' g p
installedState = { parent: _, children: M.empty, memo: M.empty }

-- | An intermediate algebra that parent components "produce" from their `eval`
-- | and `peek` functions. This takes the place of `g` when compared to a leaf
-- | (non-parent) component.
type QueryF s s' f f' g p = Free (HalogenF (InstalledState s s' f f' g p) (ChildF p f') g)

-- | An intermediate algebra used to associate values from a child component's
-- | algebra with the slot the component was installed into.
data ChildF p f i = ChildF p (f i)

instance functorChildF :: (Functor f) => Functor (ChildF p f) where
  map f (ChildF p fi) = ChildF p (f <$> fi)

-- | Queries a child component, for use within a parent component's `eval` or
-- | `peek` function.
query
  :: forall s s' f f' g p i
   . (Functor g, Ord p)
  => p
  -> f' i
  -> Free (HalogenF s f (QueryF s s' f f' g p)) (Maybe i)
query p q = liftQuery (mkQuery p q)

-- | A version of [`query`](#query) for use when a parent component has multiple
-- | types of child component.
query'
  :: forall s s' s'' f f' f'' g p p' i
   . (Functor g, Ord p')
  => ChildPath s s' f f' p p'
  -> p
  -> f i
  -> Free (HalogenF s'' f'' (QueryF s'' s' f'' f' g p')) (Maybe i)
query' i p q = liftQuery (mkQuery' i p q)

-- | Creates a query for a child component where `p` is the slot the component
-- | was installed into and `f' i` in the input query.
-- |
-- | If a component is not found for the slot the result of the query
-- | will be `Nothing`.
mkQuery
  :: forall s s' f f' p g i
   . (Functor g, Ord p)
  => p
  -> f' i
  -> QueryF s s' f f' g p (Maybe i)
mkQuery p q = do
  st <- get
  for (M.lookup p st.children) \(Tuple c _) ->
    mapF (transformHF (mapStateFChild p) (ChildF p) id) (queryComponent c q)

-- | A version of [`mkQuery`](#mkQuery) for use when a parent component has
-- | multiple types of child component.
mkQuery'
  :: forall s s' s'' f f' f'' g p p' i
   . (Functor g, Ord p')
  => ChildPath s s' f f' p p'
  -> p
  -> f i
  -> QueryF s'' s' f'' f' g p' (Maybe i)
mkQuery' i p q = mkQuery (injSlot i p) (injQuery i q)

-- | Lifts a value in the `QueryF` algebra into the monad used by a component's
-- | `eval` function.
liftQuery
  :: forall s s' f f' g p
   . (Functor g)
  => EvalParent (QueryF s s' f f' g p) s s' f f' g p
liftQuery = liftH

mapStateFParent :: forall s s' f f' g p. Natural (StateF s) (StateF (InstalledState s s' f f' g p))
mapStateFParent = mapState (_.parent) (\f st -> st { parent = f st.parent })

mapStateFChild :: forall s s' f f' g p. (Ord p) => p -> Natural (StateF s') (StateF (InstalledState s s' f f' g p))
mapStateFChild p =
  mapState
    (\st -> U.fromJust $ snd <$> M.lookup p st.children)
    (\f st -> { parent: st.parent, children: M.update (Just <<< rmap f) p st.children, memo: st.memo })

render
  :: forall s s' f f' g p
   . (Ord p)
  => (s -> HTML (SlotConstructor s' f' g p) (f Unit))
  -> State (InstalledState s s' f f' g p) (HTML Void ((Coproduct f (ChildF p f')) Unit))
render rc = do
    st <- CMS.get
    let html = rc st.parent
    -- Empty the state so that we don't keep children that are no longer
    -- being rendered...
    CMS.put
      { parent: st.parent
      , children: M.empty :: M.Map p (Tuple (Component s' f' g) s')
      , memo: M.empty :: M.Map p (HTML Void (Coproduct f (ChildF p f') Unit))
      }
    -- ...but then pass through the old state so we can lookup child
    -- components that are being re-rendered
    fillSlot (renderChild st) left html

  where

  renderChild
    :: InstalledState s s' f f' g p
    -> SlotConstructor s' f' g p
    -> State (InstalledState s s' f f' g p) (HTML Void ((Coproduct f (ChildF p f')) Unit))
  renderChild st (SlotConstructor p def) =
    let childState = M.lookup p st.children
    in case M.lookup p st.memo of
      Just html -> do
        CMS.modify \st' ->
          { parent: st'.parent
          , children: M.alter (const childState) p st'.children
          , memo: M.insert p html st'.memo
          } :: InstalledState s s' f f' g p
        pure html
      Nothing -> case childState of
        Just (Tuple c s) -> renderChild' p c s
        Nothing ->
          let def' = def unit
          in renderChild' p def'.component def'.initialState

  renderChild'
    :: p
    -> Component s' f' g
    -> s'
    -> State (InstalledState s s' f f' g p) (HTML Void ((Coproduct f (ChildF p f')) Unit))
  renderChild' p c s = case renderComponent c s of
    Tuple html s' -> do
      CMS.modify (\st -> { parent: st.parent, children: M.insert p (Tuple c s') st.children, memo: st.memo } :: InstalledState s s' f f' g p)
      pure $ right <<< ChildF p <$> html

queryParent
  :: forall s s' f f' g p. (Functor g)
  => EvalParent f s s' f f' g p
  -> Eval f (InstalledState s s' f f' g p) (Coproduct f (ChildF p f')) g
queryParent f =
  f >>> foldFree \h ->
    case h of
      StateHF q -> mergeParentStateF q
      SubscribeHF q -> runSubscribeF (queryParent f) q
      QueryHF q -> liftChildF q
      HaltHF -> liftF empty

mergeParentStateF :: forall s s' f f' g p. Eval (StateF s) (InstalledState s s' f f' g p) (Coproduct f (ChildF p f')) g
mergeParentStateF = liftF <<< StateHF <<< mapStateFParent

runSubscribeF
  :: forall s s' f f' g p
   . (Functor g)
  => Eval f (InstalledState s s' f f' g p) (Coproduct f (ChildF p f')) g
  -> Eval (SubscribeF f (Free (HalogenF (InstalledState s s' f f' g p) (ChildF p f') g))) (InstalledState s s' f f' g p) (Coproduct f (ChildF p f')) g
runSubscribeF queryParent' = subscribeN (forever $ lift <<< queryParent' =<< await) <<< hoistSubscribe liftChildF

liftChildF
  :: forall s s' f f' g p
   . (Functor g)
  => Eval (Free (HalogenF (InstalledState s s' f f' g p) (ChildF p f') g)) (InstalledState s s' f f' g p) (Coproduct f (ChildF p f')) g
liftChildF = mapF (transformHF id right id)

queryChild
  :: forall s s' f f' g p
   . (Functor g, Ord p)
  => Eval (ChildF p f') (InstalledState s s' f f' g p) (Coproduct f (ChildF p f')) g
queryChild (ChildF p q) = do
  modify \st -> { parent: st.parent, children: st.children, memo: M.delete p st.memo }
  mapF (transformHF id right id) (mkQuery p q)
    >>= maybe (liftF empty) pure

adaptState :: forall s t m a. (Monad m) => (s -> t) -> (t -> s) -> CMS.StateT s m a -> CMS.StateT t m a
adaptState st ts (CMS.StateT f) = CMS.StateT \state -> f (ts state) >>= \(Tuple a s) -> pure $ Tuple a (st s)

transform'
  :: forall s s' f f' g
   . (Functor g)
  => (s -> s')
  -> (s' -> s)
  -> Natural f f'
  -> Natural f' f
  -> Component s f g
  -> Component s' f' g
transform' sTo sFrom fTo fFrom (Component c) =
  Component { render: map fTo <$> adaptState sTo sFrom c.render
            , eval: mapF natHF <<< c.eval <<< fFrom
            , peek: mapF natHF <<< c.peek
            }
  where
  natHF :: Natural (HalogenF s f g) (HalogenF s' f' g)
  natHF = transformHF (mapState sFrom (\f s -> sTo (f (sFrom s)))) fTo id

-- | Transforms a `Component`'s types using a `ChildPath` definition.
transformChild
  :: forall s s' f f' g p p'
   . (Functor g)
  => ChildPath s s' f f' p p'
  -> Component s f g
  -> Component s' f' g
transformChild i =
  transform'
    (injState i)
    (U.fromJust <<< prjState i)
    (injQuery i)
    (U.fromJust <<< prjQuery i)

-- | Changes the component's `g` type. A use case for this would be to interpret
-- | some `Free` monad as `Aff` so the component can be used with `runUI`.
interpret
  :: forall s f g g' o p
   . (Functor g')
  => Natural g g'
  -> ComponentP s f g o p
  -> ComponentP s f g' o p
interpret nat (Component c) =
  Component { render: c.render
            , eval: mapF (hoistHalogenF nat) <<< c.eval
            , peek: mapF (hoistHalogenF nat) <<< c.peek
            }

-- | Runs a component's `render` function with the specified state, returning
-- | the generated `HTML` and new state.
renderComponent :: forall s f g o p. ComponentP s f g o p -> s -> Tuple (HTML p (f Unit)) s
renderComponent (Component c) = runState c.render

-- | Runs a compnent's `query` function with the specified query input and
-- | returns the pending computation as a `Free` monad.
queryComponent :: forall s f g o p. ComponentP s f g o p -> Eval f s f g
queryComponent (Component c) = c.eval


A little further

A little further

module Main where

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Random (RANDOM)
import Data.Helpers (generateSequence)
import Data.List.Lazy (List, nil)
import Data.Maybe (Maybe(..))
import Prelude hiding (div)
import Pux (CoreEffects, EffModel, noEffects, start)
import Pux.DOM.Events (onClick)
import Pux.DOM.HTML (HTML)
import Pux.Renderer.React (renderToDOM)
import Text.Smolder.HTML (button, div)
import Text.Smolder.Markup (text, (#!))

data Event = Start | NewSequence (List Int)

type State = List Int

foldp :: ∀ fx. Event -> State -> EffModel State Event (random :: RANDOM)
foldp (NewSequence list) state =
  noEffects $ list
foldp Start state = { state: state, effects: [ do
  result <- liftEff generateSequence
  pure $ Just $ NewSequence result
]}

view :: State -> HTML Event
view count =
  div do
    button #! onClick (const Start) $ text "Start"

main :: ∀ fx. Eff (CoreEffects fx (random :: RANDOM)) Unit
main = do
  app <- start
    { initialState: nil
    , view
    , foldp
    , inputs: []
    }

  renderToDOM "#app" app.markup app.input

module Main where

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Random (RANDOM)
import Data.Helpers (generateSequence)
import Data.List.Lazy (List, nil)
import Data.Maybe (Maybe(..))
import Prelude hiding (div)
import Pux (CoreEffects, EffModel, noEffects, start)
import Pux.DOM.Events (onClick)
import Pux.DOM.HTML (HTML)
import Pux.Renderer.React (renderToDOM)
import Text.Smolder.HTML (button, div)
import Text.Smolder.Markup (text, (#!))

data Event = Start | NewSequence (List Int)

type State = List Int

foldp :: ∀ fx. Event -> State -> EffModel State Event fx
foldp (NewSequence list) state =
  noEffects $ list
foldp Start state = { state: state, effects: [ do
  result <- generateSequence
  pure $ Just $ NewSequence result
]}

view :: State -> HTML Event
view count =
  div do
    button #! onClick (const Start) $ text "Start"

main :: ∀ fx. Eff (CoreEffects fx (random :: RANDOM)) Unit
main = do
  app <- start
    { initialState: nil
    , view
    , foldp
    , inputs: []
    }

  renderToDOM "#app" app.markup app.input


Added straight up jumping with numpad 8

Added straight up jumping with numpad 8

module Main where

import Data.Char
import Data.String hiding (length, drop)
import Data.Maybe
import Data.Tuple
import Data.Array ((!!), (..), map, updateAt, modifyAt, range, length, head, filter, drop)
import Data.Foldable
import qualified Data.Map as M
import Control.Monad.Eff
import qualified Control.Monad.JQuery as J
import Debug.Trace

import Graphics.CanvasConsole
import GameData
import Utils
import Level

strlen = Data.String.length

data GameState = Game { level         :: Level
                      , player        :: Creature
                      , npcs          :: [Creature]
                      , items         :: [Item]
                      , playerName    :: String
                      , points        :: Number
                      , inventory     :: [Item]
                      , freeFallTimer :: Number
                      , messageBuf    :: [String]
                      }
               | MainMenu
               | NameCreation { playerName :: String }
               | CharCreation { playerName :: String }

initialState :: String -> GameState
initialState pname = Game
        { level: stringToLevel testLevel
        , player: pl
        , npcs: [testGuard]
        , items: [testItem1, testItem2]
        , playerName: pname
        , points: 0
        , inventory: []
        , freeFallTimer: 0
        , messageBuf: map ((++) "Line" <<< show) (1 .. 4)
        }
    where
        pl :: Creature
        pl = { pos: {x: 4, y: 3}, ctype: Player, stats: defaultStats, speed: 1000, time: 0, vel: zerop }

        testGuard = { pos: {x: 10, y: 4}, ctype: Guard, stats: defaultStats, speed: 500, time: 0, vel: zerop }
        testItem1 = { itemType: Weapon { dmg: 1, attackBonus: 1 }, pos: {x: 6, y: 4}, vel: {x: 0, y: 0}, weight: 4 }
        testItem2 = { itemType: Loot { value: 3 }, pos: {x: 20, y: 3}, vel: {x: 0, y: 0}, weight: 1 }

messageBufSize :: Number
messageBufSize = 4

addMsg :: String -> GameState -> GameState
addMsg msg (Game state) | length state.messageBuf >= messageBufSize =
    Game state { messageBuf = drop 1 state.messageBuf ++ [msg] }
addMsg msg (Game state) | otherwise =Game state { messageBuf = state.messageBuf ++ [msg] }

onUpdate :: Console -> Number -> GameState -> ConsoleEff GameState
onUpdate console dt g@(Game state) | playerCannotAct state.level state.player && state.freeFallTimer > 0.1 =
    drawGame console <<< updateWorld (calcSpeed g state.player) $ Game state { freeFallTimer = 0 }
onUpdate console dt g@(Game state) | otherwise =
    drawGame console $ Game state { freeFallTimer = state.freeFallTimer + dt }
onUpdate console _ g = drawGame console g

drawGame :: Console -> GameState -> ConsoleEff GameState
drawGame console g@(Game state) = do
    clear console
    mapM_ (\p -> drawTile p (getTile state.level p)) (levelPoints state.level)
    mapM_ drawCreature state.npcs
    mapM_ drawItem state.items
    drawCreature state.player
    drawString console (state.playerName) "FF0000" 2 23
    drawString console ("HP: " ++ (show (state.player.stats.hp))) "FF0000" 2 24
    drawString console ("Points: " ++ (show (state.points))) "FF0000" 10 24
    drawStrings {x: 1, y: 20} "FFFFFF" state.messageBuf
    return g
    where
        drawStrings :: Point -> String -> [String] -> ConsoleEff Unit
        drawStrings p col (x:xs) = drawString console x col p.x p.y
                                >> drawStrings {x: p.x, y: p.y + 1} col xs
        drawStrings _  _  []     = return unit

        drawCreature :: Creature -> ConsoleEff Unit
        drawCreature c = drawCreatureType c.pos c.ctype

        drawCreatureType :: Point -> CreatureType -> ConsoleEff Unit
        drawCreatureType p Player  = drawChar console "@" "FF0000" p.x p.y
        drawCreatureType p Guard   = drawChar console "G" "0000FF" p.x p.y
        drawCreatureType p Archer  = drawChar console "A" "00FF00" p.x p.y
        drawCreatureType p Peasant = drawChar console "P" "AAAAFF" p.x p.y
        drawCreatureType p _       = drawChar console "?" "FFFFFF" p.x p.y

        drawItem :: Item -> ConsoleEff Unit
        drawItem i = drawItemType i.pos i.itemType

        drawItemType :: Point -> ItemType -> ConsoleEff Unit
        drawItemType p (Loot _)   = drawChar console "$" "FFAA00" p.x p.y
        drawItemType p (Weapon _) = drawChar console "/" "AAAAAA" p.x p.y

        drawTile :: Point -> Maybe Tile -> ConsoleEff Unit
        drawTile p (Just Air)        = drawChar console " " "FFFFFF" p.x p.y
        drawTile p (Just Ground)     = drawChar console (singleton $ fromCharCode 176) "AAAAAA" p.x p.y
        drawTile p (Just Wall)       = drawChar console (singleton $ fromCharCode 219) "444422" p.x p.y
        drawTile p (Just DoorLocked) = drawChar console "+" "666633" p.x p.y
        drawTile p (Just DoorClosed) = drawChar console "+" "666633" p.x p.y
        drawTile p (Just DoorOpen)   = drawChar console "|" "666633" p.x p.y
        drawTile p _                 = drawChar console "?" "FFFFFF" p.x p.y
drawGame console MainMenu = do
    clear console
    drawString console "RobberyRL" "FFFFFF" 12 5
    drawString console "Press enter to start your adventure" "AAAAAA" 6 12
    return MainMenu
drawGame console (NameCreation {playerName = pname}) = do
    clear console
    drawString console "What is your name? (max 15 characters):" "FF0000" 4 4
    drawString console pname "FF0000" 6 6
    drawString console "Press enter to continue" "FF0000" 4 8
    return (NameCreation {playerName: pname})
drawGame console (CharCreation {playerName = pname}) = do
    clear console
    drawString console ("Character Creation:   " ++ pname) "FF0000" 2 2

    drawString console "Press a to enter game" "FF0000" 2 20

    drawString console "a) Archer      ( +2 dex | +1 str | +2 SP ) (SP = skill point)" "336600" 3 4
    drawString console "b) Knight      ( +4 str | -1 dex | +2 SP )" "B8B8B8" 3 5
    drawString console "c) Monk        ( +2 int | +1 dex | +2 SP )" "E6AC00" 3 6
    drawString console "d) Ninja       ( +4 dex | -1 str | +2 SP )" "5C5C5C" 3 7
    drawString console "e) Peasant     ( -1 all |        | +1 SP )" "00B36B" 3 8
    drawString console "f) Rogue       ( +1 dex | +1 int | +5 SP )" "5C5C5C" 3 9
    drawString console "g) Scholar     ( +3 int | -1 str | +5 SP )" "3D00CC" 3 10
    drawString console "h) Skillmaster ( +1 int |        | +8 SP )" "00B336" 3 11
    drawString console "i) Soldier     ( +2 str | +1 dex | +2 SP )" "9E9E9E" 3 12

    --drawString console "Prefix:" "FF0000" 46 13
    --drawString console "j) Strong (+1 str)" "336600" 47 15
    --drawString console "k) Weak   (-1 str)" "FF0000" 47 16
    --drawString console "l) Agile  (+1 dex)" "336600" 47 17
    --drawString console "m) Clumsy (-1 dex)" "FF0000" 47 18
    --drawString console "n) Wise   (+1 int)" "336600" 47 19
    --drawString console "q) Dumb   (-1 int)" "FF0000" 47 20
    return (CharCreation {playerName: pname})

-- Updates all npcs.
updateCreatures :: Number -> GameState -> GameState
updateCreatures advance g@(Game state') =
    foldl (\g' i -> updateCreature i (advTime i g')) g (0 .. (length state'.npcs - 1))
    where
        -- Updaters are not allowed to remove creatures.
        -- Dead creatures will be cleaned up later.

        -- Advances game time for creature at index i.
        advTime :: Number -> GameState -> GameState
        advTime i game = modifyCreatureAt i game $ \c -> c { time = c.time + advance }

        -- Gets creature information from creature at index i.
        get :: forall a. Number -> GameState -> a -> (Creature -> a) -> a
        get i (Game state) d getter = fromMaybe d $ getter <$> state.npcs !! i

        -- Modify creature at index i with a function.
        modifyCreatureAt :: Number -> GameState -> (Creature -> Creature) -> GameState
        modifyCreatureAt i (Game state) f = Game state { npcs = modifyAt i f state.npcs }

        -- Updates creature at index i until it runs out of time.
        updateCreature :: Number -> GameState -> GameState
        updateCreature i game | get i game 0 (\c -> c.time) >= get i game 0 (calcSpeed game) =
            updateCreature i (modifyCreatureAt i (updateCreatureOnce i game) (\c -> c { time = c.time - calcSpeed game c }))
        updateCreature i game | otherwise = game

        -- Creature at index i does a single action.
        updateCreatureOnce :: Number -> GameState -> GameState
        updateCreatureOnce i game = modifyCreatureAt i game $ updatePhysics game

updatePhysics :: forall r. GameState -> { pos :: Point, vel :: Point | r } -> { pos :: Point, vel :: Point | r }
updatePhysics g@(Game state) c | inFreeFall state.level c = move g fc (unitp fc.vel)
    where
        projectedMovement p = p.pos .+. unitp p.vel

        -- 1. update gravity
        gc = c { vel = { x: c.vel.x, y: c.vel.y + 1 } }

        -- 2. check collision
        newpos = projectedMovement gc
        blocked = not $ isValidMove state.level newpos
        finalVelX = if blocked then 0 else gc.vel.x

        -- 3. calculate final velocity
        fc = c { vel = { x: finalVelX, y: gc.vel.y } }
updatePhysics _ c = c { vel = zerop }

move :: forall r. GameState -> { pos :: Point | r } -> Point -> { pos :: Point | r }
move (Game state) c delta =
    if blocked then c else c { pos = newpos }
    where
        newpos  = clampPos $ c.pos .+. delta
        blocked = not $ isValidMove state.level newpos

        clampPos :: Point -> Point
        clampPos pos = { x: clamp pos.x 0 79, y: clamp pos.y 0 24 }

updateWorld :: Number -> GameState -> GameState
updateWorld advance = updateCreatures advance
    >>> (\(Game state) -> Game state { player = updatePhysics (Game state) state.player })
    >>> (\(Game state) -> Game state { items = map (updatePhysics (Game state)) state.items })

inFreeFall :: forall r. Level -> { pos :: Point, vel :: Point | r } -> Boolean
inFreeFall level c = isValidMove level (c.pos .+. {x:0, y: 1}) || c.vel.y < 0

canGrab :: forall r. Level -> { pos :: Point, vel :: Point | r } -> Boolean
canGrab level c = isFree {x:0, y: 1} && (ledge (-1) || ledge 1)
    where
        ledge dx = isFree {x: dx, y: -1} && blocked {x: dx, y: 0}
        isFree delta  = isValidMove level (c.pos .+. delta)
        blocked = not <<< isFree

playerCannotAct :: forall r. Level -> { pos :: Point, vel :: Point | r } -> Boolean
playerCannotAct level c = inFreeFall level c && not (canGrab level c)

isValidMove :: Level -> Point -> Boolean
isValidMove level = not <<< isTileSolid <<< fromMaybe Air <<< getTile level

-- todo: item weight should affect player
calcSpeed :: GameState -> Creature -> Number
calcSpeed (Game state) c | inFreeFall state.level c = 500
calcSpeed (Game state) c | otherwise                = c.speed

movePlayer :: Point -> GameState -> GameState
movePlayer delta g@(Game state) =
    if canMove then
        updateWorld (calcSpeed g state.player) $ Game state { player = move (Game state) state.player { vel = zerop } delta }
        else Game state
    where
        newpos  = state.player.pos .+. delta
        canMove = isValidMove state.level newpos

playerJump :: GameState -> Number -> GameState
playerJump g@(Game state) xdir | isValidMove state.level (state.player.pos .+. {x: xdir, y: -1}) && not (isValidMove state.level (state.player.pos .+. {x: xdir, y: 0})) =
    movePlayer {x: xdir, y: -1} g
playerJump g@(Game state) xdir | otherwise =
    Game state { player = state.player { vel = {x: xdir, y: -3} } }

movementkeys :: M.Map Number Point
movementkeys = M.fromList [numpad 8 // {x:  0, y: -1}
                          ,numpad 2 // {x:  0, y:  1}
                          ,numpad 4 // {x: -1, y:  0}
                          ,numpad 6 // {x:  1, y:  0}
                          ,numpad 5 // {x:  0, y:  0}]

pickUp :: Point -> GameState -> GameState
pickUp point (Game state) =
    case head (filter (\i -> i.pos .==. point) state.items) of
        Just item -> Game state { items = deleteItem state.items point, inventory = addItem state.inventory item }
        Nothing   -> Game state
    where
        deleteItem :: [Item] -> Point -> [Item]
        deleteItem (x:xs) delPos | x.pos .==. delPos = xs
        deleteItem (x:xs) delPos | otherwise = x : deleteItem xs delPos
        deleteItem [] _ = []

        addItem :: [Item] -> Item -> [Item]
        addItem xs { itemType = Loot { value = num } } = xs
        addItem xs x = x:xs

onKeyPress :: Console -> GameState -> Number -> ConsoleEff GameState
onKeyPress console g@(Game state) _ | playerCannotAct state.level state.player = return g
onKeyPress console g@(Game state) key                      | key == numpad 7 = return $ playerJump g (-1)
onKeyPress console g@(Game state) key                      | key == numpad 9 = return $ playerJump g 1
onKeyPress console g@(Game state) key                      | key == numpad 8 = return $ playerJump g 0
onKeyPress console g@(Game state) key                      | key == 80       = return $ pickUp (state.player.pos) g
onKeyPress console g@(Game state) key =
    case M.lookup key movementkeys of
        Just delta -> drawGame console $ movePlayer delta g
        Nothing    -> return g

onKeyPress console MainMenu key                            | key == 13       = return $ NameCreation { playerName: "" }
onKeyPress console (NameCreation {playerName = pname}) key | key == 13       = return $ CharCreation { playerName: pname }
onKeyPress console (NameCreation {playerName = xs}) key    | key == 8        = return $ NameCreation { playerName: (take (strlen xs - 1) xs) }
onKeyPress console (NameCreation {playerName = ""}) key                      = return $ NameCreation { playerName: (fromCharArray [fromCharCode key]) }
onKeyPress console (NameCreation {playerName = xs}) key    | strlen xs > 15  = return $ NameCreation { playerName: xs }
onKeyPress console (NameCreation {playerName = xs}) key                      = return $ NameCreation { playerName: (xs ++ (fromCharArray [fromCharCode key])) }
onKeyPress console (CharCreation {playerName = xs}) key    | key == 65       = return $ initialState xs
onKeyPress _ st _ = return st

main = J.ready $ withConsole 80 25 MainMenu {onKeyPress: onKeyPress, onUpdate: onUpdate}

module Main where

import Data.Char
import Data.String hiding (length, drop)
import Data.Maybe
import Data.Tuple
import Data.Array ((!!), (..), map, updateAt, modifyAt, range, length, head, filter, drop)
import Data.Foldable
import qualified Data.Map as M
import Control.Monad.Eff
import qualified Control.Monad.JQuery as J
import Debug.Trace

import Graphics.CanvasConsole
import GameData
import Utils
import Level

strlen = Data.String.length

data GameState = Game { level         :: Level
                      , player        :: Creature
                      , npcs          :: [Creature]
                      , items         :: [Item]
                      , playerName    :: String
                      , points        :: Number
                      , inventory     :: [Item]
                      , freeFallTimer :: Number
                      , messageBuf    :: [String]
                      }
               | MainMenu
               | NameCreation { playerName :: String }
               | CharCreation { playerName :: String }

initialState :: String -> GameState
initialState pname = Game
        { level: stringToLevel testLevel
        , player: pl
        , npcs: [testGuard]
        , items: [testItem1, testItem2]
        , playerName: pname
        , points: 0
        , inventory: []
        , freeFallTimer: 0
        , messageBuf: map ((++) "Line" <<< show) (1 .. 4)
        }
    where
        pl :: Creature
        pl = { pos: {x: 4, y: 3}, ctype: Player, stats: defaultStats, speed: 1000, time: 0, vel: zerop }

        testGuard = { pos: {x: 10, y: 4}, ctype: Guard, stats: defaultStats, speed: 500, time: 0, vel: zerop }
        testItem1 = { itemType: Weapon { dmg: 1, attackBonus: 1 }, pos: {x: 6, y: 4}, vel: {x: 0, y: 0}, weight: 4 }
        testItem2 = { itemType: Loot { value: 3 }, pos: {x: 20, y: 3}, vel: {x: 0, y: 0}, weight: 1 }

messageBufSize :: Number
messageBufSize = 4

addMsg :: String -> GameState -> GameState
addMsg msg (Game state) | length state.messageBuf >= messageBufSize =
    Game state { messageBuf = drop 1 state.messageBuf ++ [msg] }
addMsg msg (Game state) | otherwise =Game state { messageBuf = state.messageBuf ++ [msg] }

onUpdate :: Console -> Number -> GameState -> ConsoleEff GameState
onUpdate console dt g@(Game state) | playerCannotAct state.level state.player && state.freeFallTimer > 0.1 =
    drawGame console <<< updateWorld (calcSpeed g state.player) $ Game state { freeFallTimer = 0 }
onUpdate console dt g@(Game state) | otherwise =
    drawGame console $ Game state { freeFallTimer = state.freeFallTimer + dt }
onUpdate console _ g = drawGame console g

drawGame :: Console -> GameState -> ConsoleEff GameState
drawGame console g@(Game state) = do
    clear console
    mapM_ (\p -> drawTile p (getTile state.level p)) (levelPoints state.level)
    mapM_ drawCreature state.npcs
    mapM_ drawItem state.items
    drawCreature state.player
    drawString console (state.playerName) "FF0000" 2 23
    drawString console ("HP: " ++ (show (state.player.stats.hp))) "FF0000" 2 24
    drawString console ("Points: " ++ (show (state.points))) "FF0000" 10 24
    drawStrings {x: 1, y: 20} "FFFFFF" state.messageBuf
    return g
    where
        drawStrings :: Point -> String -> [String] -> ConsoleEff Unit
        drawStrings p col (x:xs) = drawString console x col p.x p.y
                                >> drawStrings {x: p.x, y: p.y + 1} col xs
        drawStrings _  _  []     = return unit

        drawCreature :: Creature -> ConsoleEff Unit
        drawCreature c = drawCreatureType c.pos c.ctype

        drawCreatureType :: Point -> CreatureType -> ConsoleEff Unit
        drawCreatureType p Player  = drawChar console "@" "FF0000" p.x p.y
        drawCreatureType p Guard   = drawChar console "G" "0000FF" p.x p.y
        drawCreatureType p Archer  = drawChar console "A" "00FF00" p.x p.y
        drawCreatureType p Peasant = drawChar console "P" "AAAAFF" p.x p.y
        drawCreatureType p _       = drawChar console "?" "FFFFFF" p.x p.y

        drawItem :: Item -> ConsoleEff Unit
        drawItem i = drawItemType i.pos i.itemType

        drawItemType :: Point -> ItemType -> ConsoleEff Unit
        drawItemType p (Loot _)   = drawChar console "$" "FFAA00" p.x p.y
        drawItemType p (Weapon _) = drawChar console "/" "AAAAAA" p.x p.y

        drawTile :: Point -> Maybe Tile -> ConsoleEff Unit
        drawTile p (Just Air)        = drawChar console " " "FFFFFF" p.x p.y
        drawTile p (Just Ground)     = drawChar console (singleton $ fromCharCode 176) "AAAAAA" p.x p.y
        drawTile p (Just Wall)       = drawChar console (singleton $ fromCharCode 219) "444422" p.x p.y
        drawTile p (Just DoorLocked) = drawChar console "+" "666633" p.x p.y
        drawTile p (Just DoorClosed) = drawChar console "+" "666633" p.x p.y
        drawTile p (Just DoorOpen)   = drawChar console "|" "666633" p.x p.y
        drawTile p _                 = drawChar console "?" "FFFFFF" p.x p.y
drawGame console MainMenu = do
    clear console
    drawString console "RobberyRL" "FFFFFF" 12 5
    drawString console "Press enter to start your adventure" "AAAAAA" 6 12
    return MainMenu
drawGame console (NameCreation {playerName = pname}) = do
    clear console
    drawString console "What is your name? (max 15 characters):" "FF0000" 4 4
    drawString console pname "FF0000" 6 6
    drawString console "Press enter to continue" "FF0000" 4 8
    return (NameCreation {playerName: pname})
drawGame console (CharCreation {playerName = pname}) = do
    clear console
    drawString console ("Character Creation:   " ++ pname) "FF0000" 2 2

    drawString console "Press a to enter game" "FF0000" 2 20

    drawString console "a) Archer      ( +2 dex | +1 str | +2 SP ) (SP = skill point)" "336600" 3 4
    drawString console "b) Knight      ( +4 str | -1 dex | +2 SP )" "B8B8B8" 3 5
    drawString console "c) Monk        ( +2 int | +1 dex | +2 SP )" "E6AC00" 3 6
    drawString console "d) Ninja       ( +4 dex | -1 str | +2 SP )" "5C5C5C" 3 7
    drawString console "e) Peasant     ( -1 all |        | +1 SP )" "00B36B" 3 8
    drawString console "f) Rogue       ( +1 dex | +1 int | +5 SP )" "5C5C5C" 3 9
    drawString console "g) Scholar     ( +3 int | -1 str | +5 SP )" "3D00CC" 3 10
    drawString console "h) Skillmaster ( +1 int |        | +8 SP )" "00B336" 3 11
    drawString console "i) Soldier     ( +2 str | +1 dex | +2 SP )" "9E9E9E" 3 12

    --drawString console "Prefix:" "FF0000" 46 13
    --drawString console "j) Strong (+1 str)" "336600" 47 15
    --drawString console "k) Weak   (-1 str)" "FF0000" 47 16
    --drawString console "l) Agile  (+1 dex)" "336600" 47 17
    --drawString console "m) Clumsy (-1 dex)" "FF0000" 47 18
    --drawString console "n) Wise   (+1 int)" "336600" 47 19
    --drawString console "q) Dumb   (-1 int)" "FF0000" 47 20
    return (CharCreation {playerName: pname})

-- Updates all npcs.
updateCreatures :: Number -> GameState -> GameState
updateCreatures advance g@(Game state') =
    foldl (\g' i -> updateCreature i (advTime i g')) g (0 .. (length state'.npcs - 1))
    where
        -- Updaters are not allowed to remove creatures.
        -- Dead creatures will be cleaned up later.

        -- Advances game time for creature at index i.
        advTime :: Number -> GameState -> GameState
        advTime i game = modifyCreatureAt i game $ \c -> c { time = c.time + advance }

        -- Gets creature information from creature at index i.
        get :: forall a. Number -> GameState -> a -> (Creature -> a) -> a
        get i (Game state) d getter = fromMaybe d $ getter <$> state.npcs !! i

        -- Modify creature at index i with a function.
        modifyCreatureAt :: Number -> GameState -> (Creature -> Creature) -> GameState
        modifyCreatureAt i (Game state) f = Game state { npcs = modifyAt i f state.npcs }

        -- Updates creature at index i until it runs out of time.
        updateCreature :: Number -> GameState -> GameState
        updateCreature i game | get i game 0 (\c -> c.time) >= get i game 0 (calcSpeed game) =
            updateCreature i (modifyCreatureAt i (updateCreatureOnce i game) (\c -> c { time = c.time - calcSpeed game c }))
        updateCreature i game | otherwise = game

        -- Creature at index i does a single action.
        updateCreatureOnce :: Number -> GameState -> GameState
        updateCreatureOnce i game = modifyCreatureAt i game $ updatePhysics game

updatePhysics :: forall r. GameState -> { pos :: Point, vel :: Point | r } -> { pos :: Point, vel :: Point | r }
updatePhysics g@(Game state) c | inFreeFall state.level c = move g fc (unitp fc.vel)
    where
        projectedMovement p = p.pos .+. unitp p.vel

        -- 1. update gravity
        gc = c { vel = { x: c.vel.x, y: c.vel.y + 1 } }

        -- 2. check collision
        newpos = projectedMovement gc
        blocked = not $ isValidMove state.level newpos
        finalVelX = if blocked then 0 else gc.vel.x

        -- 3. calculate final velocity
        fc = c { vel = { x: finalVelX, y: gc.vel.y } }
updatePhysics _ c = c { vel = zerop }

move :: forall r. GameState -> { pos :: Point | r } -> Point -> { pos :: Point | r }
move (Game state) c delta =
    if blocked then c else c { pos = newpos }
    where
        newpos  = clampPos $ c.pos .+. delta
        blocked = not $ isValidMove state.level newpos

        clampPos :: Point -> Point
        clampPos pos = { x: clamp pos.x 0 79, y: clamp pos.y 0 24 }

updateWorld :: Number -> GameState -> GameState
updateWorld advance = updateCreatures advance
    >>> (\(Game state) -> Game state { player = updatePhysics (Game state) state.player })
    >>> (\(Game state) -> Game state { items = map (updatePhysics (Game state)) state.items })

inFreeFall :: forall r. Level -> { pos :: Point, vel :: Point | r } -> Boolean
inFreeFall level c = isValidMove level (c.pos .+. {x:0, y: 1}) || c.vel.y < 0

canGrab :: forall r. Level -> { pos :: Point, vel :: Point | r } -> Boolean
canGrab level c = isFree {x:0, y: 1} && (ledge (-1) || ledge 1)
    where
        ledge dx = isFree {x: dx, y: -1} && blocked {x: dx, y: 0}
        isFree delta  = isValidMove level (c.pos .+. delta)
        blocked = not <<< isFree

playerCannotAct :: forall r. Level -> { pos :: Point, vel :: Point | r } -> Boolean
playerCannotAct level c = inFreeFall level c && not (canGrab level c)

isValidMove :: Level -> Point -> Boolean
isValidMove level = not <<< isTileSolid <<< fromMaybe Air <<< getTile level

-- todo: item weight should affect player
calcSpeed :: GameState -> Creature -> Number
calcSpeed (Game state) c | inFreeFall state.level c = 500
calcSpeed (Game state) c | otherwise                = c.speed

movePlayer :: Point -> GameState -> GameState
movePlayer delta g@(Game state) =
    if canMove then
        updateWorld (calcSpeed g state.player) $ Game state { player = move (Game state) state.player { vel = zerop } delta }
        else Game state
    where
        newpos  = state.player.pos .+. delta
        canMove = isValidMove state.level newpos

playerJump :: GameState -> Number -> GameState
playerJump g@(Game state) xdir | isValidMove state.level (state.player.pos .+. {x: xdir, y: -1}) && not (isValidMove state.level (state.player.pos .+. {x: xdir, y: 0})) =
    movePlayer {x: xdir, y: -1} g
playerJump g@(Game state) xdir | otherwise =
    Game state { player = state.player { vel = {x: xdir, y: -3} } }

movementkeys :: M.Map Number Point
movementkeys = M.fromList [numpad 8 // {x:  0, y: -1}
                          ,numpad 2 // {x:  0, y:  1}
                          ,numpad 4 // {x: -1, y:  0}
                          ,numpad 6 // {x:  1, y:  0}
                          ,numpad 5 // {x:  0, y:  0}]

pickUp :: Point -> GameState -> GameState
pickUp point (Game state) =
    case head (filter (\i -> i.pos .==. point) state.items) of
        Just item -> Game state { items = deleteItem state.items point, inventory = addItem state.inventory item }
        Nothing   -> Game state
    where
        deleteItem :: [Item] -> Point -> [Item]
        deleteItem (x:xs) delPos | x.pos .==. delPos = xs
        deleteItem (x:xs) delPos | otherwise = x : deleteItem xs delPos
        deleteItem [] _ = []

        addItem :: [Item] -> Item -> [Item]
        addItem xs { itemType = Loot { value = num } } = xs
        addItem xs x = x:xs

onKeyPress :: Console -> GameState -> Number -> ConsoleEff GameState
onKeyPress console g@(Game state) _ | playerCannotAct state.level state.player = return g
onKeyPress console g@(Game state) key                      | key == numpad 7 = return $ playerJump g (-1)
onKeyPress console g@(Game state) key                      | key == numpad 9 = return $ playerJump g 1
onKeyPress console g@(Game state) key                      | key == 80       = return $ pickUp (state.player.pos) g
onKeyPress console g@(Game state) key =
    case M.lookup key movementkeys of
        Just delta -> drawGame console $ movePlayer delta g
        Nothing    -> return g

onKeyPress console MainMenu key                            | key == 13       = return $ NameCreation { playerName: "" }
onKeyPress console (NameCreation {playerName = pname}) key | key == 13       = return $ CharCreation { playerName: pname }
onKeyPress console (NameCreation {playerName = xs}) key    | key == 8        = return $ NameCreation { playerName: (take (strlen xs - 1) xs) }
onKeyPress console (NameCreation {playerName = ""}) key                      = return $ NameCreation { playerName: (fromCharArray [fromCharCode key]) }
onKeyPress console (NameCreation {playerName = xs}) key    | strlen xs > 15  = return $ NameCreation { playerName: xs }
onKeyPress console (NameCreation {playerName = xs}) key                      = return $ NameCreation { playerName: (xs ++ (fromCharArray [fromCharCode key])) }
onKeyPress console (CharCreation {playerName = xs}) key    | key == 65       = return $ initialState xs
onKeyPress _ st _ = return st

main = J.ready $ withConsole 80 25 MainMenu {onKeyPress: onKeyPress, onUpdate: onUpdate}