show 'Loading' only when input has been changed

{-
Copyright 2015 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 Notebook.Cell.Viz.Component where

import Prelude

import Control.Apply ((*>))
import Control.Monad (when)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Trans (lift)
import Control.MonadPlus (guard)
import Control.Plus (empty)

import Data.Argonaut (JCursor())
import Data.Array (length, null, cons, index)
import Data.Either (Either(..))
import Data.Foldable (foldl)
import Data.Functor (($>))
import Data.Functor.Aff (liftAff)
import Data.Functor.Coproduct (coproduct, right, left)
import Data.Int as Int
import Data.Lens ((.~), view, preview)
import Data.Map as M
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.Set as Set
import Data.Tuple (Tuple(..))

import Halogen
import Halogen.CustomProps.Indexed as Cp
import Halogen.HTML.CSS.Indexed as CSS
import Halogen.HTML.Events.Indexed as E
import Halogen.HTML.Indexed as H
import Halogen.HTML.Properties.Indexed as P
import Halogen.HTML.Properties.Indexed.ARIA as ARIA
import Halogen.Themes.Bootstrap3 as B

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

import Render.Common (row)
import Render.CssClasses as Rc

import Notebook.Cell.Chart.Aggregation (aggregationSelect)
import Notebook.Cell.Port as P
import Model.Resource as R
import Model.Select (Select(), autoSelect, newSelect, (<->), ifSelected, trySelect', _value)

import Notebook.Cell.CellType (CellType(Viz), cellName, cellGlyph)
import Notebook.Cell.Chart.Axis (analyzeJArray, Axis())
import Notebook.Cell.Chart.Axis as Ax
import Notebook.Cell.Chart.ChartConfiguration (ChartConfiguration(), depends, dependsOnArr)
import Notebook.Cell.Chart.ChartOptions (buildOptions)
import Notebook.Cell.Chart.ChartType (ChartType(..), isPie)
import Notebook.Cell.Common.EvalQuery (CellEvalQuery(..), CellEvalT(), runCellEvalT)
import Notebook.Cell.Component (CellStateP(), CellQueryP(), makeEditorCellComponent, makeQueryPrism', _VizState, _VizQuery)
import Notebook.Cell.Viz.Component.Query
import Notebook.Cell.Viz.Component.State
import Notebook.Cell.Viz.Form.Component (formComponent)
import Notebook.Cell.Viz.Form.Component as Form
import Notebook.Cell.Viz.Model as Model
import Notebook.Common (Slam())

import Quasar.Aff as Api

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

import Data.Foldable (foldMap)

vizComponent :: Component CellStateP CellQueryP Slam
vizComponent = makeEditorCellComponent
  { name: cellName Viz
  , glyph: cellGlyph Viz
  , component: parentComponent' render eval peek
  , initialState: installedState initialState
  , _State: _VizState
  , _Query: makeQueryPrism' _VizQuery
  }

render :: State -> VizHTML
render state =
  H.div_ $
  [ renderLoading $ not state.loading
  , renderEmpty $ state.loading || (not $ Set.isEmpty state.availableChartTypes)
  , renderForm state
  ]

renderLoading :: Boolean -> VizHTML
renderLoading hidden =
  H.div [ P.classes $ [ B.alert
                      , B.alertInfo
                      , Rc.loadingMessage
                      ]
                     <> (guard hidden $> B.hide)
        ]
  [ H.text "Loading"
  , H.img [ P.src "/img/blue-spin.gif" ]
  ]

renderEmpty :: Boolean -> VizHTML
renderEmpty hidden =
  H.div [ P.classes $ [ B.alert
                      , B.alertDanger
                      ]
                     <> (guard hidden $> B.hide)
        , CSS.style $ marginBottom $ px 12.0
        ]
  [ H.text "There is no available chart for this dataset" ]

renderForm :: State -> VizHTML
renderForm state =
  H.div [ P.classes $ [ Rc.vizCellEditor ]
                    <> (guard hidden $> B.hide)
        ]
  [ renderChartTypeSelector state
  , renderChartConfiguration state
  ]
  where
  hidden :: Boolean
  hidden =
       Set.isEmpty state.availableChartTypes
    || state.loading

renderChartTypeSelector :: State -> VizHTML
renderChartTypeSelector state =
  H.div [ P.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 $   H.img [ P.src $ src current
                              , P.classes $ [ cls state.chartType ]
                                <> (guard (selected == current) $> B.active)
                              , E.onClick (E.input_ (right <<< SetChartType current))
                              ]

  src :: ChartType -> String
  src Pie = "img/pie.svg"
  src Line = "img/line.svg"
  src Bar = "img/bar.svg"

  cls :: ChartType -> H.ClassName
  cls Pie = Rc.pieChartIcon
  cls Line = Rc.lineChartIcon
  cls Bar = Rc.barChartIcon

renderChartConfiguration :: State -> VizHTML
renderChartConfiguration state =
  H.div [ P.classes [ Rc.vizChartConfiguration ] ]
  [ renderTab Pie
  , renderTab Line
  , renderTab Bar
  , renderDimensions state
  ]
  where
  renderTab :: ChartType -> VizHTML
  renderTab ty =
    showIf (state.chartType == ty)
    [ H.slot ty \_ -> { component: formComponent
                      , initialState: installedState Form.initialState
                      }
    ]

  showIf :: Boolean -> Array VizHTML -> VizHTML
  showIf ok content = H.div [ P.classes $ (guard (not ok) $> B.hide) ] content

renderDimensions :: State -> VizHTML
renderDimensions state =
  row
  [ chartInput Rc.chartSizeParam "Height"
      (_.height >>> showIfNeqZero) SetHeight false
  , chartInput Rc.chartSizeParam "Width"
      (_.width >>> showIfNeqZero) SetWidth false
  , 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
    :: H.ClassName
    -> String
    -> (State -> String)
    -> (Int -> Unit -> Query Unit)
    -> Boolean -> VizHTML
  chartInput cls labelText valueFromState queryCtor isHidden =
    H.form [ P.classes $ [ B.colXs3, cls ]
                      <> (guard isHidden $> B.hide)
           , Cp.nonSubmit
           ]
    [ label labelText
    , H.input [ P.classes [ B.formControl ]
              , P.value $ valueFromState state
              , ARIA.label labelText
              , Cp.mbValueInput (pure
                                 <<< map (right <<< flip queryCtor unit)
                                 <<< stringToInt
                                )
              ]
    ]

  label :: String -> VizHTML
  label str = H.label [ P.classes [ B.controlLabel ] ] [ H.text str ]

  showIfNeqZero :: forall 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 :: Natural QueryC VizDSL
eval = coproduct cellEval vizEval

vizEval :: Natural Query VizDSL
vizEval q = do
  modify $ _needToUpdate .~ false
  case q of
    SetHeight h next ->
      modify (_height .~ h) *> configure $> next
    SetWidth w next ->
      modify (_width .~ w) *> configure $> next
    SetChartType ct next ->
      modify (_chartType .~ ct) *> configure $> next
    SetAvailableChartTypes ts next ->
      modify (_availableChartTypes .~ ts) *> configure $> next
    RotateAxisLabel angle next ->
      modify (_axisLabelAngle .~ angle) *> configure $> next
    SetAxisFontSize size next ->
      modify (_axisLabelFontSize .~ size) *> configure $> next

cellEval :: Natural CellEvalQuery VizDSL
cellEval (EvalCell info continue) = do
  needToUpdate <- gets _.needToUpdate
  map continue $ runCellEvalT do
    when needToUpdate $ withLoading do
      r <- maybe (throwError "Incorrect port in visual builder cell") pure
           $ info.inputPort >>= preview P._Resource
      lift $ updateForms r
      records <- lift $ liftAff $ Api.all r
      when (length records > 10000)
        $ throwError
        $  "Maximum record count available for visualization -- 10000, "
        <> "please consider using 'limit' or 'group by' in your request"
      lift $ modify $ _records .~ records
    lift $ modify $ _needToUpdate .~ true
    responsePort
  where
  withLoading action = do
    lift $ modify $ _loading .~ true
    a <- action
    lift $ modify $ _loading .~ false
    pure a
cellEval (SetupCell _ next) = pure next
cellEval (NotifyRunCell next) = pure next
cellEval (Save k) = do
  st <- get
  config <- query st.chartType $ left $ request Form.GetConfiguration
  pure $ k $ Model.encode
    { width: st.width
    , height: st.height
    , chartType: st.chartType
    , chartConfig: fromMaybe Form.initialState config
    , axisLabelFontSize: st.axisLabelFontSize
    , axisLabelAngle: st.axisLabelAngle
    }
cellEval (Load json next) =
  case Model.decode json of
    Left err -> pure next
    Right model -> do
      let st = fromModel model
      set st
      query st.chartType $ left $ action $ Form.SetConfiguration model.chartConfig
      pure next

responsePort :: CellEvalT VizDSL P.Port
responsePort = do
  state <- lift $ get
  mbConf <- lift $ query state.chartType $ left $ request Form.GetConfiguration
  conf <- maybe (throwError "Form state has not been set in responsePort")
          pure mbConf
  pure
    $ P.ChartOptions
    { options: buildOptions state conf
    , width: state.width
    , height: state.height
    }

updateForms :: R.Resource -> VizDSL Unit
updateForms file = do
  jarr <- liftAff $ Api.sample file 0 20
  if null jarr
    then
    modify $ _availableChartTypes .~ Set.empty
    else do
    modify (_sample .~ analyzeJArray jarr)
    configure

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
  modify (_availableChartTypes .~ available axises)
  where
  getOrInitial :: ChartType -> VizDSL ChartConfiguration
  getOrInitial ty =
    map (fromMaybe Form.initialState)
    $ query ty $ left (request Form.GetConfiguration)

  setConfFor :: ChartType -> ChartConfiguration -> VizDSL Unit
  setConfFor ty conf =
    void $ query ty $ left $ 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 <- 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
    :: forall a. (Eq a) => Maybe (Select a) -> Select a -> Select a
  setPreviousValueFrom mbSel target  =
    (maybe id trySelect' $ mbSel >>= 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
    in { series: [firstSeries, secondSeries]
       , dimensions: [dimensions]
       , measures: [firstMeasures, secondMeasures]
       , aggregations: [aggregationSelect, aggregationSelect]
       }

peek :: forall a. ChildF ChartType Form.QueryP a -> VizDSL Unit
peek (ChildF chartType q) = do
  modify $ _needToUpdate .~ false
  configure

{-
Copyright 2015 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 Notebook.Cell.Viz.Component where

import Prelude

import Control.Apply ((*>))
import Control.Monad (when)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Trans (lift)
import Control.MonadPlus (guard)
import Control.Plus (empty)

import Data.Argonaut (JCursor())
import Data.Array (length, null, cons, index)
import Data.Either (Either(..))
import Data.Foldable (foldl)
import Data.Functor (($>))
import Data.Functor.Aff (liftAff)
import Data.Functor.Coproduct (coproduct, right, left)
import Data.Int as Int
import Data.Lens ((.~), view, preview)
import Data.Map as M
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.Set as Set
import Data.Tuple (Tuple(..))

import Halogen
import Halogen.CustomProps.Indexed as Cp
import Halogen.HTML.CSS.Indexed as CSS
import Halogen.HTML.Events.Indexed as E
import Halogen.HTML.Indexed as H
import Halogen.HTML.Properties.Indexed as P
import Halogen.HTML.Properties.Indexed.ARIA as ARIA
import Halogen.Themes.Bootstrap3 as B

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

import Render.Common (row)
import Render.CssClasses as Rc

import Notebook.Cell.Chart.Aggregation (aggregationSelect)
import Notebook.Cell.Port as P
import Model.Resource as R
import Model.Select (Select(), autoSelect, newSelect, (<->), ifSelected, trySelect', _value)

import Notebook.Cell.CellType (CellType(Viz), cellName, cellGlyph)
import Notebook.Cell.Chart.Axis (analyzeJArray, Axis())
import Notebook.Cell.Chart.Axis as Ax
import Notebook.Cell.Chart.ChartConfiguration (ChartConfiguration(), depends, dependsOnArr)
import Notebook.Cell.Chart.ChartOptions (buildOptions)
import Notebook.Cell.Chart.ChartType (ChartType(..), isPie)
import Notebook.Cell.Common.EvalQuery (CellEvalQuery(..), CellEvalT(), runCellEvalT)
import Notebook.Cell.Component (CellStateP(), CellQueryP(), makeEditorCellComponent, makeQueryPrism', _VizState, _VizQuery)
import Notebook.Cell.Viz.Component.Query
import Notebook.Cell.Viz.Component.State
import Notebook.Cell.Viz.Form.Component (formComponent)
import Notebook.Cell.Viz.Form.Component as Form
import Notebook.Cell.Viz.Model as Model
import Notebook.Common (Slam())

import Quasar.Aff as Api

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

import Data.Foldable (foldMap)

vizComponent :: Component CellStateP CellQueryP Slam
vizComponent = makeEditorCellComponent
  { name: cellName Viz
  , glyph: cellGlyph Viz
  , component: parentComponent' render eval peek
  , initialState: installedState initialState
  , _State: _VizState
  , _Query: makeQueryPrism' _VizQuery
  }

render :: State -> VizHTML
render state =
  H.div_ $
  [ renderLoading $ not state.loading
  , renderEmpty $ state.loading || (not $ Set.isEmpty state.availableChartTypes)
  , renderForm state
  ]

renderLoading :: Boolean -> VizHTML
renderLoading hidden =
  H.div [ P.classes $ [ B.alert
                      , B.alertInfo
                      , Rc.loadingMessage
                      ]
                     <> (guard hidden $> B.hide)
        ]
  [ H.text "Loading"
  , H.img [ P.src "/img/blue-spin.gif" ]
  ]

renderEmpty :: Boolean -> VizHTML
renderEmpty hidden =
  H.div [ P.classes $ [ B.alert
                      , B.alertDanger
                      ]
                     <> (guard hidden $> B.hide)
        , CSS.style $ marginBottom $ px 12.0
        ]
  [ H.text "There is no available chart for this dataset" ]

renderForm :: State -> VizHTML
renderForm state =
  H.div [ P.classes $ [ Rc.vizCellEditor ]
                    <> (guard hidden $> B.hide)
        ]
  [ renderChartTypeSelector state
  , renderChartConfiguration state
  ]
  where
  hidden :: Boolean
  hidden =
       Set.isEmpty state.availableChartTypes
    || state.loading

renderChartTypeSelector :: State -> VizHTML
renderChartTypeSelector state =
  H.div [ P.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 $   H.img [ P.src $ src current
                              , P.classes $ [ cls state.chartType ]
                                <> (guard (selected == current) $> B.active)
                              , E.onClick (E.input_ (right <<< SetChartType current))
                              ]

  src :: ChartType -> String
  src Pie = "img/pie.svg"
  src Line = "img/line.svg"
  src Bar = "img/bar.svg"

  cls :: ChartType -> H.ClassName
  cls Pie = Rc.pieChartIcon
  cls Line = Rc.lineChartIcon
  cls Bar = Rc.barChartIcon

renderChartConfiguration :: State -> VizHTML
renderChartConfiguration state =
  H.div [ P.classes [ Rc.vizChartConfiguration ] ]
  [ renderTab Pie
  , renderTab Line
  , renderTab Bar
  , renderDimensions state
  ]
  where
  renderTab :: ChartType -> VizHTML
  renderTab ty =
    showIf (state.chartType == ty)
    [ H.slot ty \_ -> { component: formComponent
                      , initialState: installedState Form.initialState
                      }
    ]

  showIf :: Boolean -> Array VizHTML -> VizHTML
  showIf ok content = H.div [ P.classes $ (guard (not ok) $> B.hide) ] content

renderDimensions :: State -> VizHTML
renderDimensions state =
  row
  [ chartInput Rc.chartSizeParam "Height"
      (_.height >>> showIfNeqZero) SetHeight false
  , chartInput Rc.chartSizeParam "Width"
      (_.width >>> showIfNeqZero) SetWidth false
  , 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
    :: H.ClassName
    -> String
    -> (State -> String)
    -> (Int -> Unit -> Query Unit)
    -> Boolean -> VizHTML
  chartInput cls labelText valueFromState queryCtor isHidden =
    H.form [ P.classes $ [ B.colXs3, cls ]
                      <> (guard isHidden $> B.hide)
           , Cp.nonSubmit
           ]
    [ label labelText
    , H.input [ P.classes [ B.formControl ]
              , P.value $ valueFromState state
              , ARIA.label labelText
              , Cp.mbValueInput (pure
                                 <<< map (right <<< flip queryCtor unit)
                                 <<< stringToInt
                                )
              ]
    ]

  label :: String -> VizHTML
  label str = H.label [ P.classes [ B.controlLabel ] ] [ H.text str ]

  showIfNeqZero :: forall 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 :: Natural QueryC VizDSL
eval = coproduct cellEval vizEval

vizEval :: Natural Query VizDSL
vizEval q = do
  modify $ _needToUpdate .~ false
  case q of
    SetHeight h next ->
      modify (_height .~ h) *> configure $> next
    SetWidth w next ->
      modify (_width .~ w) *> configure $> next
    SetChartType ct next ->
      modify (_chartType .~ ct) *> configure $> next
    SetAvailableChartTypes ts next ->
      modify (_availableChartTypes .~ ts) *> configure $> next
    RotateAxisLabel angle next ->
      modify (_axisLabelAngle .~ angle) *> configure $> next
    SetAxisFontSize size next ->
      modify (_axisLabelFontSize .~ size) *> configure $> next

cellEval :: Natural CellEvalQuery VizDSL
cellEval (EvalCell info continue) = do
  needToUpdate <- gets _.needToUpdate
  map continue $ withLoading $ runCellEvalT do
    when needToUpdate do
      r <- maybe (throwError "Incorrect port in visual builder cell") pure
           $ info.inputPort >>= preview P._Resource
      lift $ updateForms r
      records <- lift $ liftAff $ Api.all r
      when (length records > 10000)
        $ throwError
        $  "Maximum record count available for visualization -- 10000, "
        <> "please consider using 'limit' or 'group by' in your request"
      lift $ modify $ _records .~ records
    responsePort
  where
  withLoading action = do
    modify $ _loading .~ true
    a <- action
    modify $ _loading .~ false
    modify $ _needToUpdate .~ true
    pure a
cellEval (SetupCell _ next) = pure next
cellEval (NotifyRunCell next) = pure next
cellEval (Save k) = do
  st <- get
  config <- query st.chartType $ left $ request Form.GetConfiguration
  pure $ k $ Model.encode
    { width: st.width
    , height: st.height
    , chartType: st.chartType
    , chartConfig: fromMaybe Form.initialState config
    , axisLabelFontSize: st.axisLabelFontSize
    , axisLabelAngle: st.axisLabelAngle
    }
cellEval (Load json next) =
  case Model.decode json of
    Left err -> pure next
    Right model -> do
      let st = fromModel model
      set st
      query st.chartType $ left $ action $ Form.SetConfiguration model.chartConfig
      pure next

responsePort :: CellEvalT VizDSL P.Port
responsePort = do
  state <- lift $ get
  mbConf <- lift $ query state.chartType $ left $ request Form.GetConfiguration
  conf <- maybe (throwError "Form state has not been set in responsePort")
          pure mbConf
  pure
    $ P.ChartOptions
    { options: buildOptions state conf
    , width: state.width
    , height: state.height
    }

updateForms :: R.Resource -> VizDSL Unit
updateForms file = do
  jarr <- liftAff $ Api.sample file 0 20
  if null jarr
    then
    modify $ _availableChartTypes .~ Set.empty
    else do
    modify (_sample .~ analyzeJArray jarr)
    configure

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
  modify (_availableChartTypes .~ available axises)
  where
  getOrInitial :: ChartType -> VizDSL ChartConfiguration
  getOrInitial ty =
    map (fromMaybe Form.initialState)
    $ query ty $ left (request Form.GetConfiguration)

  setConfFor :: ChartType -> ChartConfiguration -> VizDSL Unit
  setConfFor ty conf =
    void $ query ty $ left $ 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 <- 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
    :: forall a. (Eq a) => Maybe (Select a) -> Select a -> Select a
  setPreviousValueFrom mbSel target  =
    (maybe id trySelect' $ mbSel >>= 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
    in { series: [firstSeries, secondSeries]
       , dimensions: [dimensions]
       , measures: [firstMeasures, secondMeasures]
       , aggregations: [aggregationSelect, aggregationSelect]
       }

peek :: forall a. ChildF ChartType Form.QueryP a -> VizDSL Unit
peek (ChildF chartType q) = do
  modify $ _needToUpdate .~ false
  configure


Quickcheck property

Quickcheck property

module Test.Main where

import Prelude

import Effect (Effect)
import Data.UInt (UInt, and, fromInt, fromNumber)
import Data.UInt.Gen (genUInt)
import Test.QuickCheck (quickCheck, (===))
import Test.QuickCheck.Arbitrary (class Arbitrary)
import Test.QuickCheck.Laws.Data as Data
import Type.Proxy (Proxy(..))

newtype TestUInt = TestUInt UInt

instance arbitraryTestUInt :: Arbitrary TestUInt where
  arbitrary = TestUInt <$> genUInt (fromNumber 0.0) (fromNumber 20000.0)
derive newtype instance boundedTestUInt :: Bounded TestUInt
derive newtype instance eqTestUInt :: Eq TestUInt
derive newtype instance ordTestUInt :: Ord TestUInt
derive newtype instance showTestUInt :: Show TestUInt
derive newtype instance semiringTestUInt :: Semiring TestUInt
derive newtype instance ringTestUInt :: Ring TestUInt
derive newtype instance commutativeRingTestUInt :: CommutativeRing TestUInt
derive newtype instance euclideanRingTestUInt :: EuclideanRing TestUInt

main :: Effect Unit
main = do
  let prxUInt = Proxy ∷ Proxy TestUInt
  Data.checkEq prxUInt
  Data.checkOrd prxUInt
  Data.checkSemiring prxUInt
  Data.checkRing prxUInt
  Data.checkEuclideanRing prxUInt
  Data.checkBounded prxUInt
  Data.checkCommutativeRing prxUInt
  checkMulIsPrecise
  mulRegression1

checkMulIsPrecise :: Effect Unit
checkMulIsPrecise = do
  let onlyLowBits = and (fromInt 0x1)
  quickCheck \lhs rhs ->
    onlyLowBits (lhs * rhs) === onlyLowBits lhs * onlyLowBits rhs

mulRegression1 :: Effect Unit
mulRegression1 = do
  let lhs = fromInt (-2047875787)
      rhs = fromInt (-1028477387)
      expected = fromInt 1364097529
  quickCheck $ lhs * rhs === expected

module Test.Main where

import Prelude

import Effect (Effect)
import Data.UInt (UInt, fromInt, fromNumber)
import Data.UInt.Gen (genUInt)
import Test.QuickCheck (quickCheck, (===))
import Test.QuickCheck.Arbitrary (class Arbitrary)
import Test.QuickCheck.Laws.Data as Data
import Type.Proxy (Proxy(..))

newtype TestUInt = TestUInt UInt

instance arbitraryTestUInt :: Arbitrary TestUInt where
  arbitrary = TestUInt <$> genUInt (fromNumber 0.0) (fromNumber 20000.0)
derive newtype instance boundedTestUInt :: Bounded TestUInt
derive newtype instance eqTestUInt :: Eq TestUInt
derive newtype instance ordTestUInt :: Ord TestUInt
derive newtype instance showTestUInt :: Show TestUInt
derive newtype instance semiringTestUInt :: Semiring TestUInt
derive newtype instance ringTestUInt :: Ring TestUInt
derive newtype instance commutativeRingTestUInt :: CommutativeRing TestUInt
derive newtype instance euclideanRingTestUInt :: EuclideanRing TestUInt

main :: Effect Unit
main = do
  let prxUInt = Proxy ∷ Proxy TestUInt
  Data.checkEq prxUInt
  Data.checkOrd prxUInt
  Data.checkSemiring prxUInt
  Data.checkRing prxUInt
  Data.checkEuclideanRing prxUInt
  Data.checkBounded prxUInt
  Data.checkCommutativeRing prxUInt
  mulRegression1

mulRegression1 :: Effect Unit
mulRegression1 = do
  let lhs = fromInt (-2047875787)
      rhs = fromInt (-1028477387)
      expected = fromInt 1364097529
  quickCheck $ lhs * rhs === expected


WIP adding tests for Bifoldable and Bitraversable [Amended]

superfluous arguments to `testBitraversableIOr`

module Test.Main where

import Prelude

import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Console
import Data.Maybe
import Data.Monoid.Additive
import Data.Foldable
import Data.Traversable
import Data.Bifoldable
import Data.Bifunctor
import Data.Bitraversable
import Test.Assert

foreign import arrayFrom1UpTo :: Int -> Array Int

main = do
  log "Test foldableArray instance"
  testFoldableArrayWith 20

  log "Test foldableArray instance is stack safe"
  testFoldableArrayWith 20000

  log "Test foldMapDefaultL"
  testFoldableFoldMapDefaultL 20

  log "Test foldMapDefaultR"
  testFoldableFoldMapDefaultR 20

  log "Test foldlDefault"
  testFoldableFoldlDefault 20

  log "Test foldrDefault"
  testFoldableFoldlDefault 20

  log "Test traversableArray instance"
  testTraversableArrayWith 20

  log "Test traversableArray instance is stack safe"
  testTraversableArrayWith 20000

  log "Test traverseDefault"
  testTraverseDefault 20

  log "Test sequenceDefault"
  testSequenceDefault 20

  log "Test Bifoldable on `inclusive or`"
  testBifoldableIOrWith 10 100 42

  log "Test Bitraversable on `inclusive or`"
  testBitraversableIOr

  log "All done!"

testFoldableFWith :: forall f e. (Foldable f, Eq (f Int)) =>
                     (Int -> f Int) -> Int -> Eff (assert :: ASSERT | e) Unit
testFoldableFWith f n = do
  let dat = f n
  let expectedSum = (n / 2) * (n + 1)

  assert $ foldr (+) 0 dat == expectedSum
  assert $ foldl (+) 0 dat == expectedSum
  assert $ foldMap Additive dat == Additive expectedSum

testFoldableArrayWith = testFoldableFWith arrayFrom1UpTo

testTraversableFWith :: forall f e. (Traversable f, Eq (f Int)) =>
                        (Int -> f Int) -> Int -> Eff (assert :: ASSERT | e) Unit
testTraversableFWith f n = do
  let dat = f n

  assert $ traverse Just dat == Just dat
  assert $ traverse return dat == [dat]
  assert $ traverse (\x -> if x < 10 then Just x else Nothing) dat == Nothing
  assert $ sequence (map Just dat) == traverse Just dat

testTraversableArrayWith = testTraversableFWith arrayFrom1UpTo

-- structures for testing default `Foldable` implementations

newtype FoldMapDefaultL a = FML (Array a)
newtype FoldMapDefaultR a = FMR (Array a)
newtype FoldlDefault    a = FLD (Array a)
newtype FoldrDefault    a = FRD (Array a)

instance eqFML :: (Eq a) => Eq (FoldMapDefaultL a) where eq (FML l) (FML r) = l == r
instance eqFMR :: (Eq a) => Eq (FoldMapDefaultR a) where eq (FMR l) (FMR r) = l == r
instance eqFLD :: (Eq a) => Eq (FoldlDefault a)    where eq (FLD l) (FLD r) = l == r
instance eqFRD :: (Eq a) => Eq (FoldrDefault a)    where eq (FRD l) (FRD r) = l == r

-- implemented `foldl` and `foldr`, but default `foldMap` using `foldl`
instance foldableFML :: Foldable FoldMapDefaultL where
  foldMap f         = foldMapDefaultL f
  foldl f u (FML a) = foldl f u a
  foldr f u (FML a) = foldr f u a

-- implemented `foldl` and `foldr`, but default `foldMap`, using `foldr`
instance foldableFMR :: Foldable FoldMapDefaultR where
  foldMap f         = foldMapDefaultR f
  foldl f u (FMR a) = foldl f u a
  foldr f u (FMR a) = foldr f u a

-- implemented `foldMap` and `foldr`, but default `foldMap`
instance foldableDFL :: Foldable FoldlDefault where
  foldMap f (FLD a) = foldMap f a
  foldl f u         = foldlDefault f u
  foldr f u (FLD a) = foldr f u a

-- implemented `foldMap` and `foldl`, but default `foldr`
instance foldableDFR :: Foldable FoldrDefault where
  foldMap f (FRD a) = foldMap f a
  foldl f u (FRD a) = foldl f u a
  foldr f u         = foldrDefault f u

testFoldableFoldMapDefaultL = testFoldableFWith (FML <<< arrayFrom1UpTo)
testFoldableFoldMapDefaultR = testFoldableFWith (FMR <<< arrayFrom1UpTo)
testFoldableFoldlDefault    = testFoldableFWith (FLD <<< arrayFrom1UpTo)
testFoldableFoldrDefault    = testFoldableFWith (FRD <<< arrayFrom1UpTo)

-- structures for testing default `Traversable` implementations

newtype TraverseDefault a = TD (Array a)
newtype SequenceDefault a = SD (Array a)

instance eqTD :: (Eq a) => Eq (TraverseDefault a) where eq (TD l) (TD r) = l == r
instance eqSD :: (Eq a) => Eq (SequenceDefault a) where eq (SD l) (SD r) = l == r

instance functorTD :: Functor TraverseDefault where map f (TD a) = TD (map f a)
instance functorSD :: Functor SequenceDefault where map f (SD a) = SD (map f a)

instance foldableTD :: Foldable TraverseDefault where
  foldMap f (TD a) = foldMap f a
  foldr f u (TD a) = foldr f u a
  foldl f u (TD a) = foldl f u a

instance foldableSD :: Foldable SequenceDefault where
  foldMap f (SD a) = foldMap f a
  foldr f u (SD a) = foldr f u a
  foldl f u (SD a) = foldl f u a

instance traversableTD :: Traversable TraverseDefault where
  traverse f      = traverseDefault f
  sequence (TD a) = map TD (sequence a)

instance traversableSD :: Traversable SequenceDefault where
  traverse f (SD a) = map SD (traverse f a)
  sequence m        = sequenceDefault m

testTraverseDefault = testTraversableFWith (TD <<< arrayFrom1UpTo)
testSequenceDefault = testTraversableFWith (SD <<< arrayFrom1UpTo)

-- structure for testing bifoldable, picked `inclusive or` as it has both products and sums

data IOr l r = Both l r | Fst l | Snd r

instance eqIOr :: (Eq l, Eq r) => Eq (IOr l r) where
  eq (Both lFst lSnd) (Both rFst rSnd) = (lFst == rFst) && (lSnd == rSnd)
  eq (Fst l)          (Fst r)          = l == r
  eq (Snd l)          (Snd r)          = l == r
  eq _                _                = false

instance bifoldableIOr :: Bifoldable IOr where
  bifoldr l r u (Both fst snd) = l fst (r snd u)
  bifoldr l r u (Fst fst)      = l fst u
  bifoldr l r u (Snd snd)      = r snd u

  bifoldl l r u (Both fst snd) = r (l u fst) snd
  bifoldl l r u (Fst fst)      = l u fst
  bifoldl l r u (Snd snd)      = r u snd

  bifoldMap l r (Both fst snd) = l fst <> r snd
  bifoldMap l r (Fst fst)      = l fst
  bifoldMap l r (Snd snd)      = r snd

instance bifunctorIOr :: Bifunctor IOr where
  bimap f g (Both fst snd) = Both (f fst) (g snd)
  bimap f g (Fst fst)      = Fst (f fst)
  bimap f g (Snd snd)      = Snd (g snd)

instance bitraversableIOr :: Bitraversable IOr where
  bitraverse f g (Both fst snd) = Both <$> f fst <*> g snd
  bitraverse f g (Fst fst)      = Fst <$> f fst
  bitraverse f g (Snd snd)      = Snd <$> g snd

  bisequence (Both fst snd) = Both <$> fst <*> snd
  bisequence (Fst fst)      = Fst <$> fst
  bisequence (Snd snd)      = Snd <$> snd

testBifoldableIOrWith :: forall e. Int -> Int -> Int -> Eff (assert :: ASSERT | e) Unit
testBifoldableIOrWith fst snd u = do
  assert $ bifoldr (+) (*) u (Both fst snd) == fst + (snd * u)
  assert $ bifoldr (+) (*) u (Fst fst)      == fst + u
  assert $ bifoldr (+) (*) u (Snd snd)      == snd * u

  assert $ bifoldl (+) (*) u (Both fst snd) == (u + fst) * snd
  assert $ bifoldl (+) (*) u (Fst fst)      == u + fst
  assert $ bifoldl (+) (*) u (Snd snd)      == u * snd

  assert $ bifoldMap Additive Additive (Both fst snd) == Additive (fst + snd)
  assert $ bifoldMap Additive Additive (Fst fst)      == Additive fst
  assert $ bifoldMap Additive Additive (Snd snd)      == Additive snd

testBitraversableIOr :: forall e. Eff (assert :: ASSERT | e) Unit
testBitraversableIOr = do
  assert $ bisequence (Both (Just true) (Just false)) == Just (Both true false)
  assert $ bisequence (Fst (Just true))               == Just (Fst true  :: IOr Boolean Boolean)
  assert $ bisequence (Snd (Just false))              == Just (Snd false :: IOr Boolean Boolean)
  assert $ bitraverse Just Just (Both true false)     == Just (Both true false)
  assert $ bitraverse Just Just (Fst true)            == Just (Fst true  :: IOr Boolean Boolean)
  assert $ bitraverse Just Just (Snd false)           == Just (Snd false :: IOr Boolean Boolean)

module Test.Main where

import Prelude

import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Console
import Data.Foldable
import Data.Maybe
import Data.Monoid.Additive
import Data.Traversable
import Test.Assert

foreign import arrayFrom1UpTo :: Int -> Array Int

main = do
  log "Test foldableArray instance"
  testFoldableArrayWith 20

  log "Test traversableArray instance"
  testTraversableArrayWith 20

  log "Test foldableArray instance is stack safe"
  testFoldableArrayWith 20000

  log "Test traversableArray instance is stack safe"
  testTraversableArrayWith 20000

  log "Test foldMapDefaultL"
  testFoldableFoldMapDefaultL 20

  log "Test foldMapDefaultR"
  testFoldableFoldMapDefaultR 20

  log "Test foldlDefault"
  testFoldableFoldlDefault 20

  log "Test foldrDefault"
  testFoldableFoldlDefault 20

  log "Test traverseDefault"
  testTraverseDefault 20

  log "Test sequenceDefault"
  testSequenceDefault 20

  log "All done!"

testFoldableFWith :: forall f e. (Foldable f, Eq (f Int)) =>
                     (Int -> f Int) -> Int -> Eff (assert :: ASSERT | e) Unit
testFoldableFWith f n = do
  let arr = f n
  let expectedSum = (n / 2) * (n + 1)

  assert $ foldr (+) 0 arr == expectedSum
  assert $ foldl (+) 0 arr == expectedSum
  assert $ foldMap Additive arr == Additive expectedSum

testFoldableArrayWith = testFoldableFWith arrayFrom1UpTo

testTraversableFWith :: forall f e. (Traversable f, Eq (f Int)) =>
                        (Int -> f Int) -> Int -> Eff (assert :: ASSERT | e) Unit
testTraversableFWith f n = do
  let arr = f n

  assert $ traverse Just arr == Just arr
  assert $ traverse return arr == [arr]
  assert $ traverse (\x -> if x < 10 then Just x else Nothing) arr == Nothing
  assert $ sequence (map Just arr) == traverse Just arr

testTraversableArrayWith = testTraversableFWith arrayFrom1UpTo

-- structures for testing default `Foldable` implementations

newtype FoldMapDefaultL a = FML (Array a)
newtype FoldMapDefaultR a = FMR (Array a)
newtype FoldlDefault    a = FLD (Array a)
newtype FoldrDefault    a = FRD (Array a)

instance eqFML :: (Eq a) => Eq (FoldMapDefaultL a) where eq (FML l) (FML r) = l == r
instance eqFMR :: (Eq a) => Eq (FoldMapDefaultR a) where eq (FMR l) (FMR r) = l == r
instance eqFLD :: (Eq a) => Eq (FoldlDefault a)    where eq (FLD l) (FLD r) = l == r
instance eqFRD :: (Eq a) => Eq (FoldrDefault a)    where eq (FRD l) (FRD r) = l == r

-- implemented `foldl` and `foldr`, but default `foldMap` using `foldl`
instance foldableFML :: Foldable FoldMapDefaultL where
  foldMap f         = foldMapDefaultL f
  foldl f u (FML a) = foldl f u a
  foldr f u (FML a) = foldr f u a

-- implemented `foldl` and `foldr`, but default `foldMap`, using `foldr`
instance foldableFMR :: Foldable FoldMapDefaultR where
  foldMap f         = foldMapDefaultR f
  foldl f u (FMR a) = foldl f u a
  foldr f u (FMR a) = foldr f u a

-- implemented `foldMap` and `foldr`, but default `foldMap`
instance foldableDFL :: Foldable FoldlDefault where
  foldMap f (FLD a) = foldMap f a
  foldl f u         = foldlDefault f u
  foldr f u (FLD a) = foldr f u a

-- implemented `foldMap` and `foldl`, but default `foldr`
instance foldableDFR :: Foldable FoldrDefault where
  foldMap f (FRD a) = foldMap f a
  foldl f u (FRD a) = foldl f u a
  foldr f u         = foldrDefault f u

testFoldableFoldMapDefaultL = testFoldableFWith (FML <<< arrayFrom1UpTo)
testFoldableFoldMapDefaultR = testFoldableFWith (FMR <<< arrayFrom1UpTo)
testFoldableFoldlDefault    = testFoldableFWith (FLD <<< arrayFrom1UpTo)
testFoldableFoldrDefault    = testFoldableFWith (FRD <<< arrayFrom1UpTo)

-- structures for testing default `Traversable` implementations

newtype TraverseDefault a = TD (Array a)
newtype SequenceDefault a = SD (Array a)

instance eqTD :: (Eq a) => Eq (TraverseDefault a) where eq (TD l) (TD r) = l == r
instance eqSD :: (Eq a) => Eq (SequenceDefault a) where eq (SD l) (SD r) = l == r

instance functorTD :: Functor TraverseDefault where map f (TD a) = TD (map f a)
instance functorSD :: Functor SequenceDefault where map f (SD a) = SD (map f a)

instance foldableTD :: Foldable TraverseDefault where
  foldMap f (TD a) = foldMap f a
  foldr f u (TD a) = foldr f u a
  foldl f u (TD a) = foldl f u a

instance foldableSD :: Foldable SequenceDefault where
  foldMap f (SD a) = foldMap f a
  foldr f u (SD a) = foldr f u a
  foldl f u (SD a) = foldl f u a

instance traversableTD :: Traversable TraverseDefault where
  traverse f      = traverseDefault f
  sequence (TD a) = map TD (sequence a)

instance traversableSD :: Traversable SequenceDefault where
  traverse f (SD a) = map SD (traverse f a)
  sequence m        = sequenceDefault m

testTraverseDefault = testTraversableFWith (TD <<< arrayFrom1UpTo)
testSequenceDefault = testTraversableFWith (SD <<< arrayFrom1UpTo)


Formatting

Formatting

module JQuery where

  import Eff

  -- An effect type which indicates DOM manipulation
  foreign import data DOM :: !

  -- The jQuery wrapper type
  foreign import data JQuery :: *

  -- Wrapper function for jQuery selection $('..')
  foreign import select
    "function select(selector) { \
    \  return function () { \
    \    return jQuery(selector); \
    \  }; \
    \}" :: forall eff. String -> Eff (dom :: DOM | eff) JQuery

  -- Wrapper function for jQuery creation e.g. $('<div>')
  foreign import create
    "function create(html) { \
    \  return function () { \
    \    return jQuery(html); \
    \  }; \
    \}" :: forall eff. String -> Eff (dom :: DOM | eff) JQuery

  -- .attr({ ... })
  foreign import attr
    "function attr(attrs) { \
    \  return function(ob) { \
    \    return function () { \
    \      return ob.attr(attrs);\
    \    }; \
    \  }; \
    \}" :: forall eff attr. { | attr } -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- .css({ ... })
  foreign import css
    "function css(props) { \
    \  return function(ob) { \
    \    return function () { \
    \      return ob.css(props); \
    \    }; \
    \  }; \
    \}" :: forall eff css. { | css } -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- .append(...)
  foreign import append
    "function append(ob1) { \
    \  return function(ob) { \
    \    return function () { \
    \      return ob.append(ob1); \
    \    }; \
    \  }; \
    \}" :: forall eff. JQuery -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- .append(...)
  foreign import appendText
    "function appendText(s) { \
    \  return function(ob) { \
    \    return function () { \
    \      return ob.append(s); \
    \    }; \
    \  }; \
    \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- Get the document body
  foreign import body
    "function body() { \
    \  return jQuery(document.body); \
    \}" :: forall eff. Eff (dom :: DOM | eff) JQuery

  -- Get the text content of an element
  foreign import getText
    "function getText(ob) { \
    \  return function() { \
    \    return ob.text(); \
    \  }; \
    \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) String

  -- Set the text content of an element
  foreign import setText
    "function setText(text) { \
    \  return function(ob) { \
    \    return function() { \
    \      ob.text(text); \
    \    };\
    \  };\
    \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- Get the value of a text field
  foreign import getValue
    "function getValue(ob) { \
    \  return function() { \
    \    return ob.val(); \
    \  }; \
    \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) String

  -- Set the value of a text field
  foreign import setValue
    "function setValue(val) { \
    \  return function(ob) { \
    \    return function() { \
    \      return ob.val(val); \
    \    }; \
    \  }; \
    \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- Register an event handler
  foreign import on
    "function on(evt) { \
    \  return function(act) { \
    \    return function(ob) { \
    \      return function() { \
    \        return ob.on(evt, function() { \
    \          act(); \
    \        }); \
    \      }; \
    \    }; \
    \  }; \
    \}" :: forall eff a. String -> Eff eff a -> JQuery -> Eff (dom :: DOM | eff) JQuery

module JQuery where

  import Eff

  -- An effect type which indicates DOM manipulation
  foreign import data DOM :: !

  -- The jQuery wrapper type
  foreign import data JQuery :: *

  -- Wrapper function for jQuery selection $('..')
  foreign import select "function select(selector) { return function () { return jQuery(selector); }; }" :: forall eff. String -> Eff (dom :: DOM | eff) JQuery

  -- Wrapper function for jQuery creation e.g. $('<div>')
  foreign import create "function create(html) { return function () { return jQuery(html); }; }" :: forall eff. String -> Eff (dom :: DOM | eff) JQuery

  -- .attr({ ... })
  foreign import attr "function attr(attrs) { return function(ob) { return function () { return ob.attr(attrs); }; }; }" :: forall eff attr. { | attr } -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- .css({ ... })
  foreign import css "function css(props) { return function(ob) { return function () { return ob.css(props); }; }; }" :: forall eff css. { | css } -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- .append(...)
  foreign import append "function append(ob1) { return function(ob) { return function () { return ob.append(ob1); }; }; }" :: forall eff. JQuery -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- .append(...)
  foreign import appendText "function appendText(s) { return function(ob) { return function () { return ob.append(s); }; }; }" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- Get the document body
  foreign import body "function body() { return jQuery(document.body); }" :: forall eff. Eff (dom :: DOM | eff) JQuery

  -- Get the text content of an element
  foreign import getText "function getText(ob) { return function() { return ob.text(); }; }" :: forall eff. JQuery -> Eff (dom :: DOM | eff) String

  -- Set the text content of an element
  foreign import setText "function setText(text) { return function(ob) { return function() { ob.text(text); }; }; }" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- Get the value of a text field
  foreign import getValue "function getValue(ob) { return function() { return ob.val(); }; }" :: forall eff. JQuery -> Eff (dom :: DOM | eff) String

  -- Set the value of a text field
  foreign import setValue "function setValue(val) { return function(ob) { return function() { return ob.val(val); }; }; }" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- Register an event handler
  foreign import on "function on(evt) { return function(act) { return function(ob) { return function() { return ob.on(evt, function() { act(); } ); }; }; }; }" :: forall eff a. String -> Eff eff a -> JQuery -> Eff (dom :: DOM | eff) JQuery


Prune imports, rename operators

Prune imports, rename operators

Operators match what would be corresponding bits of HTML.

module Table where

import Prelude
import Data.Typelevel.Num
import DOM.Event.Event as Event
import DOM.HTML.HTMLInputElement as HInput
import Data.Array as Array
import Data.Maybe as Maybe
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import MDL as MDL
import MDL.Button as Button
import MDL.Layout as Layout
import MDL.Textfield as Textfield
import CSS.TextAlign (leftTextAlign, textAlign)
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import DOM (DOM)
import DOM.Event.Types (Event, MouseEvent)
import DOM.HTML.Indexed.InputType (InputType(..))
import DOM.HTML.Types (HTMLInputElement)
import Data.Maybe (Maybe(..))
import Data.Vector (Vec, empty, toArray, (+>))
import Halogen.HTML.CSS (style)
import Unsafe.Coerce (unsafeCoerce)

single :: forall a b. (Array (HH.HTML a b) -> HH.HTML a b) -> HH.HTML a b -> HH.HTML a b
single node child = node [ child ]
infixr 9 single as ><

oftext :: forall a b. (Array (HH.HTML a b) -> HH.HTML a b) -> String -> HH.HTML a b
oftext node = single node <<< HH.text
infixr 8 oftext as />

data Query a
    = ToggleState a
    | UserInput Event a

type Inflection nRows nCols cell =
    { rowLabels :: Vec nRows String
    , colLabels :: Vec nCols String
    , cells :: Vec nRows (Vec nCols cell)
    }

type Declension cell = Inflection D5 D2 cell
type Noun = Declension String

nomen :: Noun
nomen =
    { rowLabels: "nom" +> "gen" +> "dat" +> "acc" +> "abl" +> empty
    , colLabels: "sg" +> "pl" +> empty
    , cells:
        ( "nomen" +> "nomina" +> empty ) +>
        ( "nominis" +> "nominum" +> empty) +>
        ( "nomini" +> "nominibus" +> empty) +>
        ( "nomen" +> "nomina" +> empty) +>
        ( "nomine" +> "nominibus" +> empty) +>
        empty
    }

type State =
    { on :: Boolean
    , text :: String
    }

initialState :: State
initialState =
    { on: false
    , text: "Hello"
    }

button :: forall a b. (MouseEvent -> Maybe b) -> Array HH.ClassName -> String -> HH.HTML a b
button cmd classes label =
  HH.button
    [ HE.onClick cmd
    , HP.classes $
        append classes
          [ MDL.button
          , MDL.jsButton
          , MDL.jsRippleEffect
          , Button._raised
          ]
    ]
    [ HH.text label ]

input :: forall a b. (Event -> Maybe b) -> Array HH.ClassName -> String -> String -> HH.HTML a b
input cmd classes label value =
    mdiv [ MDL.textfield, MDL.jsTextfield ]
        [ HH.input
            [ HP.classes [ Textfield.input ]
            , HP.type_ InputText
            , HP.id_ "sample1"
            , HE.onInput cmd
            , HP.value value
            ]
        , HH.label
            [ HP.classes [ Textfield.label ]
            , HP.for "sample1"
            ]
            [ HH.text label ]
        ]

mdiv :: forall a b. Array HH.ClassName -> Array (HH.HTML a b) -> HH.HTML a b
mdiv classes children =
    HH.div [ HP.classes classes ] children
mdiv1 :: forall a b. HH.ClassName -> Array (HH.HTML a b) -> HH.HTML a b
mdiv1 = mdiv <<< Array.singleton

table :: forall cell nRows nCols a b. (Nat nRows, Nat nCols) => Inflection nRows nCols cell -> (cell -> HH.HTML a b) -> HH.HTML a b
table datable mapper = HH.table_><HH.tbody_ (map HH.tr_ (Array.cons header rows))
    where
      header = Array.cons (HH.th_/> "") $ map (HH.th[style (textAlign leftTextAlign)]/> _) $ toArray datable.colLabels
      labels = toArray datable.rowLabels
      label i = Maybe.fromMaybe "" $ Array.index labels i
      rows =
        Array.mapWithIndex rowOf $ toArray datable.cells
      rowOf i cells =
        Array.cons (HH.th_/> label i) (map mapper $ toArray cells)

ui :: forall eff. H.Component HH.HTML Query Unit Void (Aff (dom :: DOM | eff))
ui = H.component { render, eval, initialState: const initialState, receiver: const Nothing }
  where

  render :: State -> H.ComponentHTML Query
  render state =
    mdiv1 Layout.container
    ><mdiv [ MDL.layout ]
      ><mdiv1 Layout.content
        ><table nomen (input (HE.input UserInput) [] "Form of nomen" >>> (HH.td_><_))

  eval :: Query ~> H.ComponentDSL State Query Void (Aff (dom :: DOM | eff))
  eval (ToggleState next) = do
    H.modify (\state -> { on: not state.on, text: "Bye" })
    pure next
  eval (UserInput e next) = do
    let node = unsafeCoerce Event.target e :: HTMLInputElement
    s <- H.liftEff (HInput.value node :: Eff (dom :: DOM | eff) String)
    H.modify (\state -> { on: state.on, text: s })
    pure next

module Table where

import Prelude
import Data.Typelevel.Num
import DOM.Event.Event as Event
import DOM.HTML.HTMLInputElement as HInput
import Data.Array as Array
import Data.Maybe as Maybe
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import MDL as MDL
import MDL.Button as Button
import MDL.Card as Card
import MDL.Layout as Layout
import MDL.Shadow as Shadow
import MDL.Textfield as Textfield
import CSS (marginLeft, marginRight, rad, vGradient)
import CSS.Common (auto)
import Control.Bind ((=<<))
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import DOM (DOM)
import DOM.Event.Types (Event, MouseEvent)
import DOM.HTML.Indexed.InputType (InputType(..))
import DOM.HTML.Types (HTMLInputElement)
import Data.Maybe (Maybe(..))
import Data.Vector (Vec(..), (!!), (+>), empty, toArray, mapWithIndex)
import Halogen.HTML.CSS (style)
import Unsafe.Coerce (unsafeCoerce)

single :: forall a b. (Array (HH.HTML a b) -> HH.HTML a b) -> HH.HTML a b -> HH.HTML a b
single node child = node [ child ]
infixr 9 single as <\>

data Query a
    = ToggleState a
    | UserInput Event a

type Inflection nRows nCols cell =
    { rowLabels :: Vec nRows String
    , colLabels :: Vec nCols String
    , cells :: Vec nRows (Vec nCols cell)
    }

type Declension cell = Inflection D5 D2 cell
type Noun = Declension String

nomen :: Noun
nomen =
    { rowLabels: "nom" +> "gen" +> "dat" +> "acc" +> "abl" +> empty
    , colLabels: "sg" +> "pl" +> empty
    , cells:
        ( "nomen" +> "nomina" +> empty ) +>
        ( "nominis" +> "nominum" +> empty) +>
        ( "nomini" +> "nominibus" +> empty) +>
        ( "nomen" +> "nomina" +> empty) +>
        ( "nomine" +> "nominibus" +> empty) +>
        empty
    }

type State =
    { on :: Boolean
    , text :: String
    }

initialState :: State
initialState =
    { on: false
    , text: "Hello"
    }

button :: forall a b. (MouseEvent -> Maybe b) -> Array HH.ClassName -> String -> HH.HTML a b
button cmd classes label =
  HH.button
    [ HE.onClick cmd
    , HP.classes $
        append classes
          [ MDL.button
          , MDL.jsButton
          , MDL.jsRippleEffect
          , Button._raised
          ]
    ]
    [ HH.text label ]

input :: forall a b. (Event -> Maybe b) -> Array HH.ClassName -> String -> String -> HH.HTML a b
input cmd classes label value =
    mdiv [ MDL.textfield, MDL.jsTextfield ]
        [ HH.input
            [ HP.classes [ Textfield.input ]
            , HP.type_ InputText
            , HP.id_ "sample1"
            , HE.onInput cmd
            , HP.value value
            ]
        , HH.label
            [ HP.classes [ Textfield.label ]
            , HP.for "sample1"
            ]
            [ HH.text label ]
        ]

mdiv :: forall a b. Array HH.ClassName -> Array (HH.HTML a b) -> HH.HTML a b
mdiv classes children =
    HH.div [ HP.classes classes ] children
mdiv1 :: forall a b. HH.ClassName -> Array (HH.HTML a b) -> HH.HTML a b
mdiv1 = mdiv <<< Array.singleton

card :: forall a b. Array (HH.HTML a b) -> HH.HTML a b
card =
    HH.div
        [ HP.classes [ MDL.card, Shadow._2Dp ]
        , style do
            marginLeft auto
            marginRight auto
        ]

thtext :: forall a b. String -> HH.HTML a b
thtext = HH.th_ <<< Array.singleton <<< HH.text

tdtext :: forall a b. String -> HH.HTML a b
tdtext = HH.td_ <<< Array.singleton <<< HH.text

table :: forall cell nRows nCols a b. (Nat nRows, Nat nCols) => Inflection nRows nCols cell -> (cell -> HH.HTML a b) -> HH.HTML a b
table datable mapper = HH.table_ <\> HH.tbody_ (map HH.tr_ (Array.cons header rows))
    where
      header = Array.cons (thtext "") $ map thtext $ toArray datable.colLabels
      labels = toArray datable.rowLabels
      label i = Maybe.fromMaybe "" $ Array.index labels i
      rows =
        Array.mapWithIndex rowOf $ toArray datable.cells
      rowOf i cells =
        Array.cons (thtext $ label i) (map mapper $ toArray cells)

ui :: forall eff. H.Component HH.HTML Query Unit Void (Aff (dom :: DOM | eff))
ui = H.component { render, eval, initialState: const initialState, receiver: const Nothing }
  where

  render :: State -> H.ComponentHTML Query
  render state =
    mdiv1 Layout.container <\>
      mdiv [ MDL.layout ] <\>
        mdiv1 Layout.content <\>
            table nomen tdtext

  eval :: Query ~> H.ComponentDSL State Query Void (Aff (dom :: DOM | eff))
  eval (ToggleState next) = do
    H.modify (\state -> { on: not state.on, text: "Bye" })
    pure next
  eval (UserInput e next) = do
    let node = unsafeCoerce Event.target e :: HTMLInputElement
    s <- H.liftEff (HInput.value node :: Eff (dom :: DOM | eff) String)
    H.modify (\state -> { on: state.on, text: s })
    pure next