Fix scatter sql/group by

Fix scatter sql/group by

{-
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.Setups.Chart.Scatter.Eval
  ( eval
  , module SlamData.Workspace.Card.Setups.Chart.Scatter.Model
  ) where

import SlamData.Prelude

import Color as C

import Data.Argonaut (Json, decodeJson, (.?))
import Data.Array as A
import Data.Foldable as F
import Data.Lens ((^?), _Just)
import Data.List as L
import Data.Map as M
import Data.Set as Set

import Global (infinity)

import ECharts.Monad (DSL)
import ECharts.Commands as E
import ECharts.Types as ET
import ECharts.Types.Phantom (OptionI)
import ECharts.Types.Phantom as ETP

import SlamData.Workspace.Card.CardType.ChartType (ChartType(Scatter))
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.Setups.Axis (Axes)
import SlamData.Workspace.Card.Setups.Chart.ColorScheme (colors, getTransparentColor)
import SlamData.Workspace.Card.Setups.Chart.Common as SCC
import SlamData.Workspace.Card.Setups.Chart.Common.Positioning as BCP
import SlamData.Workspace.Card.Setups.Chart.Common.Tooltip as CCT
import SlamData.Workspace.Card.Setups.Chart.Scatter.Model (Model, ModelR)
import SlamData.Workspace.Card.Setups.Common.Eval (type (>>))
import SlamData.Workspace.Card.Setups.Common.Eval as BCE
import SlamData.Workspace.Card.Setups.Dimension as D
import SlamData.Workspace.Card.Setups.Semantics as Sem
import SlamData.Workspace.Card.Setups.Transform as T
import SlamData.Workspace.Card.Setups.Transform.Aggregation as Ag

import SqlSquare as Sql

import Utils.Foldable (enumeratedFor_)

eval ∷ ∀ m. BCE.ChartSetupEval ModelR m
eval = BCE.chartSetupEval (SCC.buildBasicSql buildProjections buildGroupBy) buildScatter

type ScatterSeries =
  { name ∷ Maybe String
  , w ∷ Maybe Number
  , h ∷ Maybe Number
  , x ∷ Maybe Number
  , y ∷ Maybe Number
  , fontSize ∷ Maybe Int
  , series ∷ Array OnOneGrid
  }

type OnOneGrid =
  { name ∷ Maybe String
  , items ∷ Array {x ∷ Number, y ∷ Number, r ∷ Number}
  }

type Item =
  { abscissa ∷ Number
  , ordinate ∷ Number
  , size ∷ Number
  , parallel ∷ Maybe String
  , series ∷ Maybe String
  }

decodeItem ∷ Json → Either String Item
decodeItem = decodeJson >=> \obj → do
  abscissa ← Sem.requiredNumber zero <$> obj .? "abscissa"
  ordinate ← Sem.requiredNumber zero <$> obj .? "ordinate"
  size ← Sem.requiredNumber zero <$> obj .? "size"
  parallel ← Sem.maybeString <$> obj .? "parallel"
  series ← Sem.maybeString <$> obj .? "series"
  pure { abscissa, ordinate, size, parallel, series }

buildProjections ∷ ModelR → L.List (Sql.Projection Sql.Sql)
buildProjections r = L.fromFoldable
  [ r.abscissa # SCC.jcursorPrj # Sql.as "abscissa"
  , r.ordinate # SCC.jcursorPrj # Sql.as "ordinate" # SCC.applyTransform r.ordinate
  , sizeF
  , r.parallel # maybe SCC.nullPrj SCC.jcursorPrj # Sql.as "parallel"
  , r.series # maybe SCC.nullPrj SCC.jcursorPrj # Sql.as "series"
  ]
  where
  sizeF = case r.size of
    Just sv → sv # SCC.jcursorPrj # Sql.as "size" # SCC.applyTransform sv
    Nothing → SCC.nullPrj # Sql.as "size"

buildGroupBy ∷ ModelR → Maybe (Sql.GroupBy Sql.Sql)
buildGroupBy r =
  SCC.groupBy $ L.fromFoldable $ A.catMaybes
    [ r.parallel <#> SCC.jcursorSql
    , r.series <#> SCC.jcursorSql
    ]

buildScatter ∷ ModelR → Axes → Array Json → Port.Port
buildScatter m _ jarr =
  Port.ChartInstructions
    { options: scatterOptions m $ buildScatterData m jarr
    , chartType: Scatter
    }

buildScatterData ∷ ModelR → Array Json → Array ScatterSeries
buildScatterData r records = series
  where
  items ∷ Array Item
  items = foldMap (foldMap A.singleton ∘ decodeItem) records

  dataMap ∷ Maybe String >> Maybe String >> (Array Number × Array Number × Array Number)
  dataMap = foldl dataMapFoldFn M.empty items

  dataMapFoldFn
    ∷ Maybe String >> Maybe String >> (Array Number × Array Number × Array Number)
    → Item
    → Maybe String >> Maybe String >> (Array Number × Array Number × Array Number)
  dataMapFoldFn acc item = M.alter alterParallelFn item.parallel acc
    where
    xs = pure item.abscissa
    ys = pure item.ordinate
    rs = pure item.size

    alterParallelFn
      ∷ Maybe (Maybe String >> (Array Number × Array Number × Array Number))
      → Maybe (Maybe String >> (Array Number × Array Number × Array Number))
    alterParallelFn = case _ of
      Nothing → Just $ M.singleton item.series $ xs × ys × rs
      Just parallel → Just $ M.alter alterSeriesFn item.series parallel

    alterSeriesFn
      ∷ Maybe (Array Number × Array Number × Array Number)
      → Maybe (Array Number × Array Number × Array Number)
    alterSeriesFn = case _ of
      Nothing → Just $ xs × ys × rs
      Just (xxs × yys × rrs) → Just $ (xxs ⊕ xs) × (yys ⊕ ys) × (rrs ⊕ rs)

  rawSeries ∷ Array ScatterSeries
  rawSeries = foldMap (pure ∘ mkScatterSeries) $ M.toList dataMap

  series ∷ Array ScatterSeries
  series = BCP.adjustRectangularPositions rawSeries

  mkScatterSeries
    ∷ Maybe String × (Maybe String >> (Array Number × Array Number × Array Number))
    → ScatterSeries
  mkScatterSeries (name × mp) =
    { name
    , x: Nothing
    , y: Nothing
    , w: Nothing
    , h: Nothing
    , fontSize: Nothing
    , series: foldMap (pure ∘ mkOneGrid) $ M.toList mp
    }

  mkOneGrid
    ∷ Maybe String × (Array Number × Array Number × Array Number)
    → OnOneGrid
  mkOneGrid (name × is) =
    { name
    , items: adjustSymbolSizes $ mkScatterItem is
    }

  mkScatterItem
    ∷ Array Number × Array Number × Array Number
    → Array { x ∷ Number, y ∷ Number, r ∷ Number }
  mkScatterItem (xs × ys × rs)
    | A.null xs = []
    | A.null ys = []
    | otherwise =
      let
        len =
          max (A.length xs) $ max (A.length ys) (A.length rs)

        abscissas =
          case r.abscissa ^? D._value ∘ D._transform ∘ _Just ∘ T._Aggregation of
            Nothing → xs
            Just ag →
              let
                v = Ag.runAggregation ag xs
              in
                map (const v) $ A.range 0 $ len - 1
        ordinates =
          case r.ordinate ^? D._value ∘ D._transform ∘ _Just ∘ T._Aggregation of
            Nothing → ys
            Just ag →
              let
                v = Ag.runAggregation ag ys
              in
                map (const v) $ A.range 0 $ len - 1

        sizes =
          case r.size ^? _Just ∘ D._value ∘ D._transform ∘ _Just ∘ T._Aggregation of
            Just ag →
              let
                v = Ag.runAggregation ag rs
              in
                map (const v) $ A.range 0 $ len - 1
            Nothing
              | A.null rs →
                map (\_ → r.minSize) rs
            Nothing →
              rs
        zipped = A.zip abscissas $ A.zip ordinates sizes
      in
        zipped <#> \(x × y × r) → {x, y, r}

  adjustSymbolSizes
    ∷ Array {x ∷ Number, y ∷ Number, r ∷ Number}
    → Array {x ∷ Number, y ∷ Number, r ∷ Number}
  adjustSymbolSizes is =
    let
      minValue =
        fromMaybe (-1.0 * infinity) $ map _.r $ F.maximumBy (\a b → compare a.r b.r) is
      maxValue =
        fromMaybe infinity $ map _.r $ F.maximumBy (\a b → compare a.r b.r) is
      distance =
        maxValue - minValue
      sizeDistance =
        r.maxSize - r.minSize

      relativeSize ∷ Number → Number
      relativeSize val
        | distance ≡ zero = val
        | otherwise =
            r.maxSize - sizeDistance / distance * (maxValue - val)
    in
      map (\x → x{r = relativeSize x.r}) is

scatterOptions ∷ ModelR → Array ScatterSeries → DSL OptionI
scatterOptions r scatterData = do
  let
    cols =
      [ { label: D.jcursorLabel r.abscissa, value: CCT.formatValueIx 0 }
      , { label: D.jcursorLabel r.ordinate, value: CCT.formatValueIx 1 }
      ]
    opts = A.catMaybes
      [ r.size <#> \dim → { label: D.jcursorLabel dim, value: CCT.formatValueIx 2 }
      , r.series <#> \dim → { label: D.jcursorLabel dim, value: _.seriesName }
      ]
  E.tooltip do
    E.formatterItem (CCT.tableFormatter (pure ∘ _.color) (cols <> opts) ∘ pure)
    E.triggerAxis
    E.textStyle do
      E.fontFamily "Ubuntu, sans"
      E.fontSize 12
    E.axisPointer do
      E.crossAxisPointer
      E.crossStyle do
        E.color $ C.rgba 170 170 170 0.6
        E.widthNum 0.2
        E.solidLine
  E.colors colors

  BCP.rectangularGrids scatterData
  BCP.rectangularTitles scatterData

  E.grid BCP.cartesian
  E.xAxes $ valueAxes E.addXAxis
  E.yAxes $ valueAxes E.addYAxis

  E.legend do
    E.topBottom
    E.textStyle $ E.fontFamily "Ubuntu, sans"
    E.items $ map ET.strItem seriesNames

  E.series series

  where
  valueAxes ∷ ∀ i a. (DSL (ETP.AxisI (gridIndex ∷ ETP.I|i)) → DSL a) → DSL a
  valueAxes addAxis = enumeratedFor_ scatterData \(ix × _) → addAxis do
    E.gridIndex ix
    E.axisType ET.Value
    E.axisLabel $ E.textStyle $ E.fontFamily "Ubuntu, sans"
    E.axisLine $ E.lineStyle do
      E.color $ C.rgba 184 184 184 1.0
      E.width 1
    E.splitLine $ E.lineStyle do
      E.color $ C.rgba 204 204 204 0.2
      E.width 1

  seriesNames ∷ Array String
  seriesNames =
    A.fromFoldable
    $ foldMap (_.series ⋙ foldMap (_.name ⋙ Set.fromFoldable)) scatterData

  series ∷ ∀ i. DSL (scatter ∷ ETP.I|i)
  series = enumeratedFor_ scatterData \(gridIx × onOneGrid) →
    enumeratedFor_ onOneGrid.series \(ix × serie) → E.scatter do
      E.xAxisIndex gridIx
      E.yAxisIndex gridIx
      for_ serie.name E.name
      for_ (A.index colors $ mod ix $ A.length colors) \color → do
        E.itemStyle $ E.normal $ E.color $ getTransparentColor color 0.5
      E.symbol ET.Circle
      E.buildItems $ for_ serie.items \item → E.addItem $ E.buildValues do
        E.addValue item.x
        E.addValue item.y
        E.addValue item.r

{-
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.Setups.Chart.Scatter.Eval
  ( eval
  , module SlamData.Workspace.Card.Setups.Chart.Scatter.Model
  ) where

import SlamData.Prelude

import Color as C

import Data.Argonaut (Json, decodeJson, (.?))
import Data.Array as A
import Data.Foldable as F
import Data.Lens ((^?), _Just)
import Data.List as L
import Data.Map as M
import Data.Set as Set

import Global (infinity)

import ECharts.Monad (DSL)
import ECharts.Commands as E
import ECharts.Types as ET
import ECharts.Types.Phantom (OptionI)
import ECharts.Types.Phantom as ETP

import SlamData.Workspace.Card.CardType.ChartType (ChartType(Scatter))
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.Setups.Axis (Axes)
import SlamData.Workspace.Card.Setups.Chart.ColorScheme (colors, getTransparentColor)
import SlamData.Workspace.Card.Setups.Chart.Common as SCC
import SlamData.Workspace.Card.Setups.Chart.Common.Positioning as BCP
import SlamData.Workspace.Card.Setups.Chart.Common.Tooltip as CCT
import SlamData.Workspace.Card.Setups.Chart.Scatter.Model (Model, ModelR)
import SlamData.Workspace.Card.Setups.Common.Eval (type (>>))
import SlamData.Workspace.Card.Setups.Common.Eval as BCE
import SlamData.Workspace.Card.Setups.Dimension as D
import SlamData.Workspace.Card.Setups.Semantics as Sem
import SlamData.Workspace.Card.Setups.Transform as T
import SlamData.Workspace.Card.Setups.Transform.Aggregation as Ag

import SqlSquare as Sql

import Utils.Foldable (enumeratedFor_)

eval ∷ ∀ m. BCE.ChartSetupEval ModelR m
eval = BCE.chartSetupEval (SCC.buildBasicSql buildProjections buildGroupBy) buildScatter

type ScatterSeries =
  { name ∷ Maybe String
  , w ∷ Maybe Number
  , h ∷ Maybe Number
  , x ∷ Maybe Number
  , y ∷ Maybe Number
  , fontSize ∷ Maybe Int
  , series ∷ Array OnOneGrid
  }

type OnOneGrid =
  { name ∷ Maybe String
  , items ∷ Array {x ∷ Number, y ∷ Number, r ∷ Number}
  }

type Item =
  { abscissa ∷ Number
  , ordinate ∷ Number
  , size ∷ Number
  , parallel ∷ Maybe String
  , series ∷ Maybe String
  }

decodeItem ∷ Json → Either String Item
decodeItem = decodeJson >=> \obj → do
  abscissa ← Sem.requiredNumber zero <$> obj .? "abscissa"
  ordinate ← Sem.requiredNumber zero <$> obj .? "ordinate"
  size ← Sem.requiredNumber zero <$> obj .? "size"
  parallel ← Sem.maybeString <$> obj .? "parallel"
  series ← Sem.maybeString <$> obj .? "series"
  pure { abscissa, ordinate, size, parallel, series }

buildProjections ∷ ModelR → L.List (Sql.Projection Sql.Sql)
buildProjections r = L.fromFoldable
  [ r.abscissa # SCC.jcursorPrj # Sql.as "abscissa"
  , r.ordinate # SCC.jcursorPrj # Sql.as "ordinate"
  , sizeF
  , r.parallel # maybe SCC.nullPrj SCC.jcursorPrj # Sql.as "parallel"
  , r.series # maybe SCC.nullPrj SCC.jcursorPrj # Sql.as "series"
  ]
  where
  sizeF = case r.size of
    Just sv → sv # SCC.jcursorPrj # Sql.as "size" # SCC.applyTransform sv
    Nothing → SCC.nullPrj # Sql.as "size"

buildGroupBy ∷ ModelR → Maybe (Sql.GroupBy Sql.Sql)
buildGroupBy r =
  SCC.groupBy $ L.fromFoldable $ A.catMaybes
    [ r.parallel <#> SCC.jcursorSql
    , r.series <#> SCC.jcursorSql
    , r.size <#> SCC.jcursorSql
    ]

buildScatter ∷ ModelR → Axes → Array Json → Port.Port
buildScatter m _ jarr =
  Port.ChartInstructions
    { options: scatterOptions m $ buildScatterData m jarr
    , chartType: Scatter
    }

buildScatterData ∷ ModelR → Array Json → Array ScatterSeries
buildScatterData r records = series
  where
  items ∷ Array Item
  items = foldMap (foldMap A.singleton ∘ decodeItem) records

  dataMap ∷ Maybe String >> Maybe String >> (Array Number × Array Number × Array Number)
  dataMap = foldl dataMapFoldFn M.empty items

  dataMapFoldFn
    ∷ Maybe String >> Maybe String >> (Array Number × Array Number × Array Number)
    → Item
    → Maybe String >> Maybe String >> (Array Number × Array Number × Array Number)
  dataMapFoldFn acc item = M.alter alterParallelFn item.parallel acc
    where
    xs = pure item.abscissa
    ys = pure item.ordinate
    rs = pure item.size

    alterParallelFn
      ∷ Maybe (Maybe String >> (Array Number × Array Number × Array Number))
      → Maybe (Maybe String >> (Array Number × Array Number × Array Number))
    alterParallelFn = case _ of
      Nothing → Just $ M.singleton item.series $ xs × ys × rs
      Just parallel → Just $ M.alter alterSeriesFn item.series parallel

    alterSeriesFn
      ∷ Maybe (Array Number × Array Number × Array Number)
      → Maybe (Array Number × Array Number × Array Number)
    alterSeriesFn = case _ of
      Nothing → Just $ xs × ys × rs
      Just (xxs × yys × rrs) → Just $ (xxs ⊕ xs) × (yys ⊕ ys) × (rrs ⊕ rs)

  rawSeries ∷ Array ScatterSeries
  rawSeries = foldMap (pure ∘ mkScatterSeries) $ M.toList dataMap

  series ∷ Array ScatterSeries
  series = BCP.adjustRectangularPositions rawSeries

  mkScatterSeries
    ∷ Maybe String × (Maybe String >> (Array Number × Array Number × Array Number))
    → ScatterSeries
  mkScatterSeries (name × mp) =
    { name
    , x: Nothing
    , y: Nothing
    , w: Nothing
    , h: Nothing
    , fontSize: Nothing
    , series: foldMap (pure ∘ mkOneGrid) $ M.toList mp
    }

  mkOneGrid
    ∷ Maybe String × (Array Number × Array Number × Array Number)
    → OnOneGrid
  mkOneGrid (name × is) =
    { name
    , items: adjustSymbolSizes $ mkScatterItem is
    }

  mkScatterItem
    ∷ Array Number × Array Number × Array Number
    → Array { x ∷ Number, y ∷ Number, r ∷ Number }
  mkScatterItem (xs × ys × rs)
    | A.null xs = []
    | A.null ys = []
    | otherwise =
      let
        len =
          max (A.length xs) $ max (A.length ys) (A.length rs)

        abscissas =
          case r.abscissa ^? D._value ∘ D._transform ∘ _Just ∘ T._Aggregation of
            Nothing → xs
            Just ag →
              let
                v = Ag.runAggregation ag xs
              in
                map (const v) $ A.range 0 $ len - 1
        ordinates =
          case r.ordinate ^? D._value ∘ D._transform ∘ _Just ∘ T._Aggregation of
            Nothing → ys
            Just ag →
              let
                v = Ag.runAggregation ag ys
              in
                map (const v) $ A.range 0 $ len - 1

        sizes =
          case r.size ^? _Just ∘ D._value ∘ D._transform ∘ _Just ∘ T._Aggregation of
            Just ag →
              let
                v = Ag.runAggregation ag rs
              in
                map (const v) $ A.range 0 $ len - 1
            Nothing
              | A.null rs →
                map (\_ → r.minSize) rs
            Nothing →
              rs
        zipped = A.zip abscissas $ A.zip ordinates sizes
      in
        zipped <#> \(x × y × r) → {x, y, r}

  adjustSymbolSizes
    ∷ Array {x ∷ Number, y ∷ Number, r ∷ Number}
    → Array {x ∷ Number, y ∷ Number, r ∷ Number}
  adjustSymbolSizes is =
    let
      minValue =
        fromMaybe (-1.0 * infinity) $ map _.r $ F.maximumBy (\a b → compare a.r b.r) is
      maxValue =
        fromMaybe infinity $ map _.r $ F.maximumBy (\a b → compare a.r b.r) is
      distance =
        maxValue - minValue
      sizeDistance =
        r.maxSize - r.minSize

      relativeSize ∷ Number → Number
      relativeSize val
        | distance ≡ zero = val
        | otherwise =
            r.maxSize - sizeDistance / distance * (maxValue - val)
    in
      map (\x → x{r = relativeSize x.r}) is

scatterOptions ∷ ModelR → Array ScatterSeries → DSL OptionI
scatterOptions r scatterData = do
  let
    cols =
      [ { label: D.jcursorLabel r.abscissa, value: CCT.formatValueIx 0 }
      , { label: D.jcursorLabel r.ordinate, value: CCT.formatValueIx 1 }
      ]
    opts = A.catMaybes
      [ r.size <#> \dim → { label: D.jcursorLabel dim, value: CCT.formatValueIx 2 }
      , r.series <#> \dim → { label: D.jcursorLabel dim, value: _.seriesName }
      ]
  E.tooltip do
    E.formatterItem (CCT.tableFormatter (pure ∘ _.color) (cols <> opts) ∘ pure)
    E.triggerAxis
    E.textStyle do
      E.fontFamily "Ubuntu, sans"
      E.fontSize 12
    E.axisPointer do
      E.crossAxisPointer
      E.crossStyle do
        E.color $ C.rgba 170 170 170 0.6
        E.widthNum 0.2
        E.solidLine
  E.colors colors

  BCP.rectangularGrids scatterData
  BCP.rectangularTitles scatterData

  E.grid BCP.cartesian
  E.xAxes $ valueAxes E.addXAxis
  E.yAxes $ valueAxes E.addYAxis

  E.legend do
    E.topBottom
    E.textStyle $ E.fontFamily "Ubuntu, sans"
    E.items $ map ET.strItem seriesNames

  E.series series

  where
  valueAxes ∷ ∀ i a. (DSL (ETP.AxisI (gridIndex ∷ ETP.I|i)) → DSL a) → DSL a
  valueAxes addAxis = enumeratedFor_ scatterData \(ix × _) → addAxis do
    E.gridIndex ix
    E.axisType ET.Value
    E.axisLabel $ E.textStyle $ E.fontFamily "Ubuntu, sans"
    E.axisLine $ E.lineStyle do
      E.color $ C.rgba 184 184 184 1.0
      E.width 1
    E.splitLine $ E.lineStyle do
      E.color $ C.rgba 204 204 204 0.2
      E.width 1

  seriesNames ∷ Array String
  seriesNames =
    A.fromFoldable
    $ foldMap (_.series ⋙ foldMap (_.name ⋙ Set.fromFoldable)) scatterData

  series ∷ ∀ i. DSL (scatter ∷ ETP.I|i)
  series = enumeratedFor_ scatterData \(gridIx × onOneGrid) →
    enumeratedFor_ onOneGrid.series \(ix × serie) → E.scatter do
      E.xAxisIndex gridIx
      E.yAxisIndex gridIx
      for_ serie.name E.name
      for_ (A.index colors $ mod ix $ A.length colors) \color → do
        E.itemStyle $ E.normal $ E.color $ getTransparentColor color 0.5
      E.symbol ET.Circle
      E.buildItems $ for_ serie.items \item → E.addItem $ E.buildValues do
        E.addValue item.x
        E.addValue item.y
        E.addValue item.r


Bigger test, just in case

Bigger test, just in case

module Test.Main where

import Prelude
import Control.Bind
import Data.Array (head)
import Data.Maybe.Unsafe (fromJust)
import Data.Foldable
import Test.QuickCheck.Gen
import Test.QuickCheck.Arbitrary
import Control.Monad.Eff.Console

main = do
  log "Try with some little Gens first"
  print =<< go 10
  print =<< go 100
  print =<< go 1000
  print =<< go 10000

  log "Testing stack safety of Gen"
  print =<< go 20000
  print =<< go 100000

  where
  go n = map (sum <<< unsafeHead) $ randomSample' 1 (vectorOf n (arbitrary :: Gen Int))
  unsafeHead = fromJust <<< head

module Test.Main where

import Prelude
import Control.Bind
import Data.Array (head)
import Data.Maybe.Unsafe (fromJust)
import Data.Foldable
import Test.QuickCheck.Gen
import Test.QuickCheck.Arbitrary
import Control.Monad.Eff.Console

main = do
  log "Try with some little Gens first"
  print =<< go 10
  print =<< go 100
  print =<< go 1000
  print =<< go 10000

  log "Testing stack safety of Gen"
  print =<< go 20000

  where
  go n = map (sum <<< unsafeHead) $ randomSample' 1 (vectorOf n (arbitrary :: Gen Int))
  unsafeHead = fromJust <<< head


Cleanup tests

Cleanup tests

module Test.Main where

import Prelude

import Control.Apply              ((*>))
import Control.Monad.Aff          (Aff()) -- MonadEff Aff
import Control.Monad.Eff.Console  (CONSOLE(), log)
import Control.Monad.Eff          (Eff())
import Control.Monad.Eff.Class    (liftEff)
import Control.Monad.Eff.Random   (RANDOM(), random, randomBool)
import Foreign.Context            (Context(), getContext)
import Test.Spec                  (describe, it)
import Test.Spec.Assertions       (shouldEqual)
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Spec.Runner           (Process(), run)
import Test.Spec.QuickCheck       (quickCheck)

import Data.Foreign.OOFFI

foreign import data TestObj :: *
foreign import data OOTEST :: !

foreign import obj :: TestObj
foreign import assignContext :: forall eff. Context -> Eff eff Unit

type Effit ret = Eff (ooTest :: OOTEST, random :: RANDOM, console :: CONSOLE, process :: Process) ret
type Affit ret = Aff (ooTest :: OOTEST, random :: RANDOM, console :: CONSOLE, process :: Process) ret

lift' :: forall a. Effit a -> Affit a
lift' = liftEff

main = (getContext >>= assignContext) *> run [consoleReporter] do
  describe "OOFFI" do
    describe "the method functions" do
      it "method0" do
        method0 "method0" obj `shouldEqual` true
      it "method0Eff" do
        x <- lift' (method0Eff "method0Eff" obj) :: Affit Boolean
        x `shouldEqual` true
      it "method1" do
        quickCheck \x -> x == method1 "method1" obj x :: Number
      it "method1Eff" do
        n <- lift' random :: Affit Number
        x <- lift' (method1Eff "method1Eff" obj n)
        x `shouldEqual` n
      it "method2" do
        quickCheck \x y -> x + y == method2 "method2" obj x y :: Number
      it "method2Eff" do
        n <- lift' random :: Affit Number
        m <- lift' random
        x <- lift' (method2Eff "method2Eff" obj n m)
        x `shouldEqual` (n + m)
      it "method3" do
        quickCheck \x y z -> x * y / z == method3 "method3" obj x y z :: Number
      it "method3Eff" do
        n  <- lift' random :: Affit Number
        n1 <- lift' random
        n2 <- lift' random
        x  <- lift' (method3Eff "method3Eff" obj n n1 n2)
        x `shouldEqual` (n * n1 / n2)
      it "method4" do
        quickCheck \w x y z -> w * x / y + z == method4 "method4" obj w x y z :: Number
      it "method4Eff" do
        n  <- lift' random :: Affit Number
        n1 <- lift' random
        n2 <- lift' random
        n3 <- lift' random
        x  <- lift' (method4Eff "method4Eff" obj n n1 n2 n3)
        x `shouldEqual` (n * n1 / n2 + n3)
      it "method5" do
        quickCheck \v w x y z -> v - w * x / y + z == method5 "method5" obj v w x y z :: Number
      it "method5Eff" do
        n  <- lift' random :: Affit Number
        n1 <- lift' random
        n2 <- lift' random
        n3 <- lift' random
        n4 <- lift' random
        x  <- lift' (method5Eff "method5Eff" obj n n1 n2 n3 n4)
        x `shouldEqual` (n - n1 * n2 / n3 + n4)

    describe "the property access functions" do
      it "getter" do
        g <- lift' (getter "getter" obj) :: Affit Boolean
        g `shouldEqual` false
      it "modifier" do
        foo <- lift' (modifier "modifier" obj (const true)) :: Affit Boolean
        foo `shouldEqual` true
      it "setter" do
        foo <- lift' (setter "setter" obj true) :: Affit Boolean
        foo `shouldEqual` true
      it "get set" do
        x  <- lift' randomBool :: Affit Boolean
        x' <- lift' randomBool
        _  <- lift' (setter "foo" obj x)
        g  <- lift' (getter "foo" obj)
        x `shouldEqual` g
        _  <- lift' (modifier "foo" obj \_ -> x')
        g' <- lift' (getter   "foo" obj)
        x' `shouldEqual` g'

    describe "the instantiator functions" do
      it "instantiate0" do
        x <- lift' (instantiate0 "i0") :: forall r. Affit {x :: Boolean | r}
        x.x `shouldEqual` true
      it "instantiate1" do
        r <- lift' random :: Affit Number
        x <- lift' (instantiate1 "i1" r)
        x.x `shouldEqual` r
      it "instantiate2" do
        r  <- lift' random :: Affit Number
        r' <- lift' random
        x  <- lift' (instantiate2 "i2" r r')
        x.x `shouldEqual` (r + r')
      it "instantiate3" do
        r  <- lift' random :: Affit Number
        r1 <- lift' random
        r2 <- lift' random
        x  <- lift' (instantiate3 "i3" r r1 r2)
        x.x `shouldEqual` (r + r1 / r2)
      it "instantiate4" do
        r  <- lift' random :: Affit Number
        r1 <- lift' random
        r2 <- lift' random
        r3 <- lift' random
        x  <- lift' (instantiate4 "i4" r r1 r2 r3)
        x.x `shouldEqual` (r * r1 + r2 / r3)
      it "instantiate5" do
        r  <- lift' random :: Affit Number
        r1 <- lift' random
        r2 <- lift' random
        r3 <- lift' random
        r4 <- lift' random
        x  <- lift' (instantiate5 "i5" r r1 r2 r3 r4)
        x.x `shouldEqual` (r * r1 + r2 / r3 - r4)

module Test.Main where

import Prelude

import Control.Apply              ((*>))
import Control.Monad.Aff          (Aff()) -- MonadEff Aff
import Control.Monad.Eff.Console  (CONSOLE(), log)
import Control.Monad.Eff          (Eff())
import Control.Monad.Eff.Class    (liftEff)
import Control.Monad.Eff.Random   (RANDOM(), random, randomBool)
import Foreign.Context            (Context(), getContext)
import Test.Spec                  (describe, it)
import Test.Spec.Assertions       (shouldEqual)
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Spec.Runner           (Process(), run)
import Test.Spec.QuickCheck       (quickCheck)

import Data.Foreign.OOFFI

foreign import data TestObj :: *
foreign import data OOTEST :: !

foreign import obj :: TestObj
foreign import assignContext :: forall eff. Context -> Eff eff Unit

type Effit ret = Eff (ooTest :: OOTEST, random :: RANDOM, console :: CONSOLE, process :: Process) ret
type Affit ret = Aff (ooTest :: OOTEST, random :: RANDOM, console :: CONSOLE, process :: Process) ret

lift' :: forall a. Effit a -> Affit a
lift' = liftEff

main = (getContext >>= assignContext) *> run [consoleReporter] do
  describe "OOFFI" do
    describe "the method functions" do
      it "method0" do
        method0 "method0" obj `shouldEqual` true
      it "method0Eff" do
        x <- lift' (method0Eff "method0Eff" obj) :: Affit Boolean
        x `shouldEqual` true
      it "method1" do
        quickCheck \x -> x == method1 "method1" obj x :: Number
      it "method1Eff" do
        n <- lift' random :: Affit Number
        x <- lift' (method1Eff "method1Eff" obj n)
        x `shouldEqual` n
      it "method2" do
        quickCheck \x y -> x + y == method2 "method2" obj x y :: Number
      it "method2Eff" do
        n <- lift' random :: Affit Number
        m <- lift' random
        x <- lift' (method2Eff "method2Eff" obj n m)
        x `shouldEqual` (n + m)
      it "method3" do
        quickCheck \x y z -> x * y / z == method3 "method3" obj x y z :: Number
      it "method3Eff" do
        n  <- lift' random :: Affit Number
        n1 <- lift' random
        n2 <- lift' random
        x  <- lift' (method3Eff "method3Eff" obj n n1 n2)
        x `shouldEqual` (n * n1 / n2)
      it "method4" do
        quickCheck \w x y z -> w * x / y + z == method4 "method4" obj w x y z :: Number
      it "method4Eff" do
        n  <- lift' random :: Affit Number
        n1 <- lift' random
        n2 <- lift' random
        n3 <- lift' random
        x  <- lift' (method4Eff "method4Eff" obj n n1 n2 n3)
        x `shouldEqual` (n * n1 / n2 + n3)
      it "method5" do
        quickCheck \v w x y z -> v - w * x / y + z == method5 "method5" obj v w x y z :: Number
      it "method5Eff" do
        n  <- lift' random :: Affit Number
        n1 <- lift' random
        n2 <- lift' random
        n3 <- lift' random
        n4 <- lift' random
        x  <- lift' (method5Eff "method5Eff" obj n n1 n2 n3 n4)
        x `shouldEqual` (n - n1 * n2 / n3 + n4)

    describe "the property access functions" do
      it "getter" do
        g <- lift' (getter "getter" obj) :: Affit Boolean
        g `shouldEqual` false
      it "modifier" do
        foo <- lift' (modifier "modifier" obj (const true)) :: Affit Boolean
        foo `shouldEqual` true
      it "setter" do
        foo <- lift' (setter "setter" obj true) :: Affit Boolean
        foo `shouldEqual` true
      it "get set" do
        x  <- lift' randomBool :: Affit Boolean
        x' <- lift' randomBool
        _  <- lift' (setter "foo" obj x)
        g  <- lift' (getter "foo" obj)
        x `shouldEqual` g
        _  <- lift' (modifier "foo" obj \_ -> x')
        g' <- lift' (getter   "foo" obj)
        x' `shouldEqual` g'

    describe "the instantiator functions" do
      it "instantiate0" do
        x <- lift' (instantiate0 "i0") :: forall r. Affit {x :: Boolean | r}
        x.x `shouldEqual` true
      it "instantiate1" do
        r <- lift' random :: Affit Number
        x <- lift' (instantiate1 "i1" r)
        lift' $ log "Hello!"
        lift' $ log $ "val: " <> show x.x
        x.x `shouldEqual` r
      it "instantiate2" do
        r  <- lift' random :: Affit Number
        r' <- lift' random
        x  <- lift' (instantiate2 "i2" r r')
        x.x `shouldEqual` (r + r')
      it "instantiate3" do
        r  <- lift' random :: Affit Number
        r1 <- lift' random
        r2 <- lift' random
        x  <- lift' (instantiate3 "i3" r r1 r2)
        x.x `shouldEqual` (r + r1 / r2)
      it "instantiate4" do
        r  <- lift' random :: Affit Number
        r1 <- lift' random
        r2 <- lift' random
        r3 <- lift' random
        x  <- lift' (instantiate4 "i4" r r1 r2 r3)
        x.x `shouldEqual` (r * r1 + r2 / r3)
      it "instantiate5" do
        r  <- lift' random :: Affit Number
        r1 <- lift' random
        r2 <- lift' random
        r3 <- lift' random
        r4 <- lift' random
        x  <- lift' (instantiate5 "i5" r r1 r2 r3 r4)
        x.x `shouldEqual` (r * r1 + r2 / r3 - r4)


re-export Data.String

re-export Data.String

module CodePoints
  ( CodePoint()
  , codePointAt
  , codePointFromInt
  , codePointToInt
  , count
  , drop
  --, dropWhile
  , fromCodePointArray
  --, indexOf
  --, indexOf'
  --, lastIndexOf
  --, lastIndexOf'
  , length
  , singleton
  , splitAt
  , take
  --, takeWhile
  --, uncons
  , toCodePointArray

  , module StringReExports
  ) where

import Data.Array as Array
import Data.Char (toCharCode)
import Data.List (List(Cons, Nil), fromFoldable)
import Data.Maybe (Maybe(Just, Nothing))
import Data.String (toCharArray)
import Data.String hiding (count, drop, dropWhile, indexOf, indexOf', lastIndexOf, lastIndexOf', length, singleton, splitAt, take, takeWhile, uncons) as StringReExports
import Data.Tuple (Tuple(Tuple))
import Data.Unfoldable (unfoldr)
import Prelude ((&&), (||), (*), (+), (-), (<$>), (<), (<=), (<<<))

newtype CodePoint = CodePoint Int

codePointFromInt :: Int -> Maybe CodePoint
codePointFromInt n | 0 <= n && n <= 0x10FFFF = Just (CodePoint n)
codePointFromInt n = Nothing

codePointToInt :: CodePoint -> Int
codePointToInt (CodePoint n) = n

codePointFromSurrogatePair :: Int -> Int -> Maybe CodePoint
codePointFromSurrogatePair lead trail | isLead lead && isTrail trail
  = Just (CodePoint (unsurrogate lead trail))
codePointFromSurrogatePair _ _ = Nothing

unsurrogate :: Int -> Int -> Int
unsurrogate h l = (h - 0xD800) * 0x400 + (l - 0xDC00) + 0x10000

isLead :: Int -> Boolean
isLead cu = 0xD800 <= cu && cu <= 0xDBFF

isTrail :: Int -> Boolean
isTrail cu = 0xDC00 <= cu && cu <= 0xDFFF

codePointAt :: Int -> String -> Maybe CodePoint
codePointAt = _codePointAt codePointAtFallback Just Nothing

foreign import _codePointAt
  :: (Int -> String -> Maybe CodePoint)
  -> (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Int
  -> String
  -> Maybe CodePoint

codePointAtFallback :: Int -> String -> Maybe CodePoint
codePointAtFallback n s = Array.index (toCodePointArray s) n

count :: (CodePoint -> Boolean) -> String -> Int
count pred = Array.length <<< Array.filter pred <<< toCodePointArray

drop :: Int -> String -> String
drop n s = fromCodePointArray (Array.drop n (toCodePointArray s))

length :: String -> Int
length = Array.length <<< toCodePointArray

foreign import singleton :: CodePoint -> String

splitAt :: Int -> String -> Maybe { before :: String, after :: String }
splitAt i s =
  let cps = toCodePointArray s in
  if i < 0 || Array.length cps <= i
    then Nothing
    else Just {
        before: fromCodePointArray (Array.take i cps),
        after: fromCodePointArray (Array.drop i cps)
      }

take :: Int -> String -> String
take = _take takeFallback

foreign import _take :: (Int -> String -> String) -> Int -> String -> String

takeFallback :: Int -> String -> String
takeFallback n s = fromCodePointArray (Array.take n (toCodePointArray s))

toCodePointArray :: String -> Array CodePoint
toCodePointArray = _toCodePointArray toCodePointArrayFallback

foreign import _toCodePointArray
  :: (String -> Array CodePoint)
  -> String
  -> Array CodePoint

toCodePointArrayFallback :: String -> Array CodePoint
toCodePointArrayFallback s = unfoldr decode (fromFoldable (toCharCode <$> toCharArray s))
  where
  decode :: List Int -> Maybe (Tuple CodePoint (List Int))
  decode (Cons h (Cons l rest)) | isLead h && isTrail l
    = Just (Tuple (CodePoint (unsurrogate h l)) rest)
  decode (Cons c rest) = Just (Tuple (CodePoint c) rest)
  decode Nil = Nothing

foreign import fromCodePointArray :: Array CodePoint -> String

module CodePoints
  ( CodePoint()
  --, Pattern()
  , codePointAt
  , codePointFromInt
  , codePointToInt
  --, contains
  , count
  , drop
  --, dropWhile
  --, indexOf
  --, indexOf'
  --, lastIndexOf
  --, lastIndexOf'
  , length
  --, replace
  --, replaceAll
  , singleton
  --, split
  , splitAt
  --, stripPrefix
  --, stripSuffix
  , take
  --, takeWhile
  --, uncons
  , toCodePointArray
  --, fromCodePointArray
  ) where

import Prelude ((&&), (||), (*), (+), (-), (<$>), (<), (<=), (<<<))
import Data.Maybe (Maybe(Just, Nothing))
import Data.String (toCharArray)
import Data.Unfoldable (unfoldr)
import Data.List (List(Cons, Nil), fromFoldable)
import Data.Tuple (Tuple(Tuple))
import Data.Array as Array
import Data.Char (toCharCode)

newtype CodePoint = CodePoint Int

codePointFromInt :: Int -> Maybe CodePoint
codePointFromInt n | 0 <= n && n <= 0x10FFFF = Just (CodePoint n)
codePointFromInt n = Nothing

codePointToInt :: CodePoint -> Int
codePointToInt (CodePoint n) = n

codePointFromSurrogatePair :: Int -> Int -> Maybe CodePoint
codePointFromSurrogatePair lead trail | isLead lead && isTrail trail
  = Just (CodePoint (unsurrogate lead trail))
codePointFromSurrogatePair _ _ = Nothing

unsurrogate :: Int -> Int -> Int
unsurrogate h l = (h - 0xD800) * 0x400 + (l - 0xDC00) + 0x10000

isLead :: Int -> Boolean
isLead cu = 0xD800 <= cu && cu <= 0xDBFF

isTrail :: Int -> Boolean
isTrail cu = 0xDC00 <= cu && cu <= 0xDFFF

codePointAt :: Int -> String -> Maybe CodePoint
codePointAt = _codePointAt codePointAtFallback Just Nothing

foreign import _codePointAt
  :: (Int -> String -> Maybe CodePoint)
  -> (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Int
  -> String
  -> Maybe CodePoint

codePointAtFallback :: Int -> String -> Maybe CodePoint
codePointAtFallback n s = Array.index (toCodePointArray s) n

count :: (CodePoint -> Boolean) -> String -> Int
count pred = Array.length <<< Array.filter pred <<< toCodePointArray

drop :: Int -> String -> String
drop n s = fromCodePointArray (Array.drop n (toCodePointArray s))

length :: String -> Int
length = Array.length <<< toCodePointArray

foreign import singleton :: CodePoint -> String

splitAt :: Int -> String -> Maybe { before :: String, after :: String }
splitAt i s =
  let cps = toCodePointArray s in
  if i < 0 || Array.length cps <= i
    then Nothing
    else Just {
        before: fromCodePointArray (Array.take i cps),
        after: fromCodePointArray (Array.drop i cps)
      }

take :: Int -> String -> String
take = _take takeFallback

foreign import _take :: (Int -> String -> String) -> Int -> String -> String

takeFallback :: Int -> String -> String
takeFallback n s = fromCodePointArray (Array.take n (toCodePointArray s))

toCodePointArray :: String -> Array CodePoint
toCodePointArray = _toCodePointArray toCodePointArrayFallback

foreign import _toCodePointArray
  :: (String -> Array CodePoint)
  -> String
  -> Array CodePoint

toCodePointArrayFallback :: String -> Array CodePoint
toCodePointArrayFallback s = unfoldr decode (fromFoldable (toCharCode <$> toCharArray s))
  where
  decode :: List Int -> Maybe (Tuple CodePoint (List Int))
  decode (Cons h (Cons l rest)) | isLead h && isTrail l
    = Just (Tuple (CodePoint (unsurrogate h l)) rest)
  decode (Cons c rest) = Just (Tuple (CodePoint c) rest)
  decode Nil = Nothing

foreign import fromCodePointArray :: Array CodePoint -> String


Add class for checking if a RowList has conflicting duplicate labels

module Genetics.Browser.Track
       ( class TrackRecord
       , buildTrack
       , makeTrack
       , TrackConfigRecord
       , class TrackConfig
       , makeContainersImpl
       , makeContainers
       , class TrackData
       , fetchDataImpl
       , fetchData
       , class CombineFuns
       , combineFunsImpl
       , combineFuns
       ) where

import Prelude

import Data.Foldable (foldMap)
import Data.Maybe (Maybe)
import Data.Pair (Pair)
import Effect (Effect)
import Effect.Aff (Aff)
import Genetics.Browser.Canvas (TrackContainer, trackContainer, withLoadingIndicator)
import Genetics.Browser.Coordinates (CoordSysView)
import Genetics.Browser.Layer (TrackPadding)
import Genetics.Browser.Types (Point)
import Prim.Boolean (False, True, kind Boolean)
import Prim.Row as Row
import Prim.RowList (class RowToList, Cons, Nil, kind RowList)
import Record (delete, get, insert)
import Type.Data.Boolean as Boolean
import Type.Data.Symbol as Symbol
import Type.Prelude (class IsSymbol, class TypeEquals, Proxy(..), RLProxy(..), RProxy(..), SProxy(..), from)
import Unsafe.Coerce (unsafeCoerce)

type TrackInterface a =
  { render   :: Pair Number -> CoordSysView -> Aff Unit
  , hotspots :: Aff (Number -> Point -> Array a) }

class TrackRecord
      (trackList :: RowList)
      (trackRow :: # Type)
      a
      | trackList -> trackRow
      , trackList -> a where
  buildTrack :: RLProxy trackList
             -> Record trackRow
             -> TrackContainer
             -> Aff { render   :: Pair Number -> CoordSysView -> Aff Unit
                    , hotspots :: Aff (Number -> Point -> Array a) }

instance trackRecordRender ::
  ( IsSymbol  name
  , Row.Lacks name trackRow'
  , Row.Cons  name (Pair Number -> CoordSysView -> Aff Unit) trackRow' trackRow
  , TrackRecord trackTail trackRow' a
  ) => TrackRecord (Cons name (Pair Number -> CoordSysView -> Aff Unit) trackTail) trackRow a where
  buildTrack _ r tcont = do

    let name = SProxy :: SProxy name

    rest <- buildTrack (RLProxy :: RLProxy trackTail)
                       (delete name r) tcont

    let rLayer p c = (get name r) p c

    pure { render:   rLayer <> rest.render
         , hotspots: rest.hotspots }

instance trackRecordUI ::
  ( IsSymbol  name
  , Row.Lacks name trackRow'
  , Row.Cons  name (Aff Unit) trackRow' trackRow
  , TrackRecord trackTail trackRow' a
  ) => TrackRecord (Cons name (Aff Unit) trackTail) trackRow a where
  buildTrack _ r tcont = do

    let name = SProxy :: SProxy name

    rest <- buildTrack (RLProxy :: RLProxy trackTail)
                       (delete name r) tcont

    let rLayer _ _ = (get name r)

    pure { render:   rLayer <> rest.render
         , hotspots: rest.hotspots }

instance trackRecordHotspots ::
  ( IsSymbol  name
  , Row.Lacks name trackRow'
  , Row.Cons  name (Aff (Number -> pt -> Array a)) trackRow' trackRow
  , TypeEquals pt Point
  , TrackRecord trackTail trackRow' a
  ) => TrackRecord (Cons name (Aff (Number -> pt -> Array a)) trackTail) trackRow a where
  buildTrack _ r tcont = do

    let name = SProxy :: SProxy name

    rest <- buildTrack (RLProxy :: RLProxy trackTail)
                       (delete name r) tcont

    let hotspots = ado
          h  <- get name r
          h' <- rest.hotspots
          in \rad p -> h rad (from p) <> h' rad p

    pure { render: rest.render, hotspots }

instance trackRecordNil ::
  ( TypeEquals (Record trackRow) {}
  ) => TrackRecord Nil trackRow a where
  buildTrack _ _ _ = mempty

makeTrack :: ∀ row list a.
             RowToList row list
          => TrackRecord list row a
          => Record row
          -> TrackContainer
          -> Aff (TrackInterface a)
makeTrack r c = buildTrack (RLProxy :: RLProxy list) r c

type TrackConfigRecord r =
  { trackHeight :: Number
  , padding :: TrackPadding | r }

class TrackConfig
  (confList :: RowList)
  (confRow  :: # Type)
  (trackRow :: # Type)
  | confList -> confRow trackRow
  where
  makeContainersImpl :: RLProxy confList
                     -> Number
                     -> Record confRow
                     -> Effect (Record trackRow)

instance trackConfigNil ::
  ( TypeEquals (Record tr) {}
  ) => TrackConfig Nil cr tr where
  makeContainersImpl _ _ _ = pure $ from {}

instance trackConfigCons ::
  ( IsSymbol name
  , TrackConfig tail confRow' trackRow'
  , Row.Cons name c confRow' confRow
  , Row.Lacks name confRow'
  , Row.Cons name TrackContainer trackRow' trackRow
  , Row.Lacks name trackRow'
  , TypeEquals (TrackConfigRecord we) c
  ) => TrackConfig (Cons name c tail) confRow trackRow where
  makeContainersImpl _ width r = do
    let n = SProxy :: SProxy name

        c :: TrackConfigRecord we
        c = from $ get n r

    cont <- trackContainer
              {width, height: c.trackHeight}
              c.padding
              (Symbol.reflectSymbol n)

    rest <- makeContainersImpl
              (RLProxy :: RLProxy tail)
              width
              (delete n $ from r)

    pure $ insert n cont rest

makeContainers :: ∀ cl cr tr.
                  RowToList cr cl
               => TrackConfig cl cr tr
               => Number
               -> Record cr
               -> Effect (Record tr)
makeContainers = makeContainersImpl (RLProxy :: RLProxy cl)

class TrackData
      (fetcherList :: RowList)
      (fetcherRow :: # Type)
      (urlRow :: # Type)
      (dataRow :: # Type)
      | fetcherList -> fetcherRow
      , fetcherList -> urlRow
      , fetcherList -> dataRow where
  fetchDataImpl :: RLProxy fetcherList
            -> Record fetcherRow
            -> Record urlRow
            -> Aff (Record dataRow)

instance trackDataCons ::
  ( IsSymbol  name
  , Row.Lacks name fetcherRow'
  , Row.Cons  name (String -> Aff x) fetcherRow' fetcherRow
  , Monoid x
  , Row.Cons  name (Maybe String) urlRow' urlRow
  , Row.Lacks name dataRow'
  , Row.Cons  name x dataRow' dataRow
  , TrackData fetcherTail fetcherRow' urlRow dataRow'
  ) => TrackData (Cons name (String -> Aff x) fetcherTail)
                 fetcherRow
                 urlRow
                 dataRow where
  fetchDataImpl _ fetchers urls = do
    let name = SProxy :: _ name

    rest <- fetchDataImpl (RLProxy :: _ fetcherTail)
                          (delete name fetchers)
                          urls

    dataset <- foldMap (get name fetchers) (get name urls)

    pure $ insert name dataset rest

instance trackDataNil ::
  ( TypeEquals (Record dataRow) {}
  ) => TrackData Nil () urlRow dataRow where
  fetchDataImpl _ _ _ = pure $ from {}

-- | `fetchData` puts a loading indicator in the provided TrackContainer,
-- | fetches the data in the provided `urlRow` record, and parses it
-- | using the parsers in the provided `parserRow` record.
fetchData :: ∀ fetcherRow fetcherList urlRow urlList dataRow.
             RowToList fetcherRow fetcherList
          => RowToList urlRow urlList
          => TrackData fetcherList fetcherRow urlRow dataRow
          => TrackContainer
          -> Record fetcherRow
          -> Record urlRow
          -> Aff (Record dataRow)
fetchData tc fs urls = withLoadingIndicator tc
                       $ fetchDataImpl (RLProxy :: _ fetcherList)
                                       fs
                                       urls

-- | Combine a record of functions from records,
-- | into a function from a record of their union,
-- | to a record of their outputs.
-- | E.g. `{f :: Record r1 -> a, g :: Record r2 -> b}`
-- | into `Record (r1 + r2) -> { f :: a, g :: b }`
class CombineFuns
  (funsList :: RowList)
  (funsRow :: # Type)
  (argRow :: # Type)
  (outRow :: # Type)
  | funsList -> funsRow
  , funsList -> argRow
  , funsList -> outRow where
  combineFunsImpl :: RLProxy funsList
              -> Record funsRow
              -> Record argRow
              -> Record outRow

instance combineFunCons ::
  ( IsSymbol  name
  , Row.Lacks name funsRow'
  , Row.Cons  name (Record r -> a) funsRow' funsRow
  , Row.Union argRow' r argRowUnion
  , Row.Nub   argRowUnion argRowNubbed
  , Row.Lacks name outRow'
  , Row.Cons  name a outRow' outRow
  , CombineFuns funsTail funsRow' argRow' outRow'
  ) => CombineFuns (Cons name (Record r -> a) funsTail)
                  funsRow
                  argRowNubbed
                  outRow where
  combineFunsImpl _ funs args =
    let name = SProxy :: _ name

        thoseArgs :: Record argRow'
        thoseArgs = unsafeCoerce args

        theseArgs :: Record r
        theseArgs = unsafeCoerce args

        rest = combineFunsImpl (RLProxy :: _ funsTail)
                               (delete name funs)
                               thoseArgs
        fn = (get name funs)

    in (insert name (fn theseArgs) rest)

instance combineFunNil ::
  ( TypeEquals (Record outRow) {}
  ) => CombineFuns Nil () () outRow where
  combineFunsImpl _ _ _ = from {}

-- | Note! this isn't actually type safe yet.
-- | If two functions use arguments with the same label
-- | but different types, things break...
combineFuns :: ∀ funsList funsRow argRow outRow.
               RowToList funsRow funsList
            => CombineFuns funsList funsRow argRow outRow
            => Record funsRow
            -> Record argRow
            -> Record outRow
combineFuns funs args = combineFunsImpl (RLProxy :: _ funsList) funs args

class BuildLayers
  (layers :: # Type)
  (output :: # Type)
  | layers -> output

class GetBrowserConfig
  (totalConfig :: # Type)
  (browser :: # Type)
  | totalConfig -> browser where
    getBrowserConfigImpl :: Record totalConfig
                         -> Record browser

instance getBrowserConfig ::
  ( IsSymbol sBrowser
  , TypeEquals (SProxy sBrowser) (SProxy "browser")
  , IsSymbol sLayers
  , TypeEquals (SProxy sLayers) (SProxy "layers")

  , Row.Cons sBrowser (Record browser') totalConfig' totalConfig
  , Row.Lacks sBrowser totalConfig'

  , Row.Cons sLayers layers browser browser'
  , Row.Lacks sLayers browser
  ) => GetBrowserConfig totalConfig browser where
  getBrowserConfigImpl total =
    let browser' :: Record browser'
        browser' = get (from (SProxy :: _ "browser")) total
    in delete (from (SProxy :: _ "layers")) browser'

class GetTrackConfig
  (totalConfig :: # Type)
  (track :: # Type)
  (trackName :: Symbol)
  | totalConfig trackName -> track where
    getTrackConfigImpl :: Record totalConfig
                       -> SProxy trackName
                       -> Record track

instance getTrackConfig ::
  ( IsSymbol sTracks
  , TypeEquals (SProxy sTracks) (SProxy "tracks")
  , IsSymbol sLayers
  , TypeEquals (SProxy sLayers) (SProxy "layers")
  , IsSymbol trackName

  , Row.Cons sTracks (Record tracks) totalConfig' totalConfig
  , Row.Lacks sTracks totalConfig'

  , Row.Cons trackName (Record thisTrack') tracks' tracks
  , Row.Lacks trackName tracks'

  , Row.Cons sLayers layers thisTrack thisTrack'
  , Row.Lacks sLayers thisTrack

  ) => GetTrackConfig totalConfig thisTrack trackName where
    getTrackConfigImpl total _ =
      let tracks' :: Record tracks
          tracks' = get (from (SProxy :: _ "tracks")) total

          thisTrack :: Record thisTrack'
          thisTrack = get (from (SProxy :: _ trackName)) tracks'

      in delete (from (SProxy :: _ "layers")) thisTrack

class GetLayerConfig
  (totalConfig :: # Type)
  (layer :: # Type)
  (trackName :: Symbol)
  (layerName :: Symbol)
  | totalConfig trackName layerName -> layer where
    getLayerConfigImpl :: Record totalConfig
                       -> SProxy trackName
                       -> SProxy layerName
                       -> Record layer

instance getLayerConfig ::
  ( IsSymbol sTracks
  , TypeEquals (SProxy sTracks) (SProxy "tracks")
  , IsSymbol sLayers
  , TypeEquals (SProxy sLayers) (SProxy "layers")
  , IsSymbol trackName
  , IsSymbol layerName

  , Row.Cons sTracks (Record tracks) totalConfig' totalConfig
  , Row.Lacks sTracks totalConfig'

  , Row.Cons trackName (Record thisTrack) tracks' tracks
  , Row.Lacks trackName tracks'

  , Row.Cons sLayers (Record layers) thisTrack' thisTrack
  , Row.Lacks sLayers thisTrack

  , Row.Cons layerName (Record thisLayer) layers' layers
  , Row.Lacks layerName layers'
  ) => GetLayerConfig totalConfig thisLayer trackName layerName where
    getLayerConfigImpl total _ _ =
      let tracks' :: Record tracks
          tracks' = get (from (SProxy :: _ "tracks")) total

          thisTrack :: Record thisTrack
          thisTrack = get (from (SProxy :: _ trackName)) tracks'

          layers :: Record layers
          layers = get (from (SProxy :: _ "layers")) thisTrack

      in get (from (SProxy :: _ layerName)) layers

newtype LayerDef browser track layer a
  = LayerDef ({ browserConfig :: Record browser
              , trackConfig :: Record track
              , layerConfig :: Record layer }
              -> a)

class ApplyLayerDef
  (browser :: # Type)
  (track :: # Type)
  (layer :: # Type)
  (totalConfig :: # Type)
  (trackName :: Symbol)
  (layerName :: Symbol)
  a
  | trackName layerName totalConfig -> track layer where
    applyLayerDefImpl :: LayerDef browser track layer a
                      -> SProxy trackName
                      -> SProxy layerName
                      -> Record totalConfig
                      -> a

instance applyLayerDefInst ::
  ( IsSymbol trackName
  , IsSymbol layerName
  , GetBrowserConfig totalConfig browser
  , GetTrackConfig totalConfig track trackName
  , GetLayerConfig totalConfig layer trackName layerName
  ) => ApplyLayerDef browser track layer totalConfig trackName layerName a where
    applyLayerDefImpl (LayerDef f) trackName layerName total =
      let browserConfig = getBrowserConfigImpl total
          trackConfig = getTrackConfigImpl total trackName
          layerConfig = getLayerConfigImpl total trackName layerName
      in f { browserConfig, trackConfig, layerConfig }

applyLayerDef :: ∀ browser track layer trackName layerName config a.
                 IsSymbol trackName
              => IsSymbol layerName
              => ApplyLayerDef browser track layer config trackName layerName a
              => LayerDef browser track layer a
              -> SProxy trackName
              -> SProxy layerName
              -> Record config
              -> a
applyLayerDef = applyLayerDefImpl

-- | Class for checking if a RowList has a "conflict" with a
-- | given label and type. If the list lacks the label, or
-- | has the label with the same type, return False; if it
-- | has the label, but with a different type, return True.
class ConflictsWith
  (list :: RowList)
  (label :: Symbol)
  (t :: Type)
  (result :: Boolean)
  | list label t -> result

-- no conflict base case
instance conflictsWithNil ::
  ConflictsWith Nil label t False

-- same label and type, no conflict, recurse
instance conflictsWithCons1 ::
  ( ConflictsWith tail label t tailResult
  ) => ConflictsWith (Cons label  t  tail) label t tailResult

-- found conflict base case
else instance conflictsWithCons3 ::
  ConflictsWith (Cons label  t' tail) label t True

-- different label, same or different type, recurse
else instance conflictsWithCons2 ::
  ( ConflictsWith tail label t tailResult
  ) =>  ConflictsWith (Cons label' t' tail) label t tailResult

hasConflict :: ∀ row list l a .
                 RowToList row list
              => IsSymbol l
              => ConflictsWith list l a True
              => RProxy row
              -> SProxy l
              -> Proxy a
              -> Unit
hasConflict _ _ _ = unit

noConflict :: ∀ row list l a .
                 RowToList row list
              => IsSymbol l
              => ConflictsWith list l a False
              => RProxy row
              -> SProxy l
              -> Proxy a
              -> Unit
noConflict _ _ _ = unit

-- | Returns True if there are duplicates of any label with different types
class ConflictingList
  (list :: RowList)
  (result :: Boolean)
  | list -> result

instance conflictingListNil :: ConflictingList Nil False

instance conflictingListCons ::
  ( ConflictsWith tail label t conflicts
  , ConflictingList tail tailResult
  , Boolean.Or conflicts tailResult result
  ) => ConflictingList (Cons label t tail) result

doesConflict :: ∀ row list.
                RowToList row list
             => ConflictingList list True
             => RProxy row
             -> Unit
doesConflict _ = unit

module Genetics.Browser.Track
       ( class TrackRecord
       , buildTrack
       , makeTrack
       , TrackConfigRecord
       , class TrackConfig
       , makeContainersImpl
       , makeContainers
       , class TrackData
       , fetchDataImpl
       , fetchData
       , class CombineFuns
       , combineFunsImpl
       , combineFuns
       ) where

import Prelude

import Data.Foldable (foldMap)
import Data.Maybe (Maybe)
import Data.Pair (Pair)
import Effect (Effect)
import Effect.Aff (Aff)
import Genetics.Browser.Canvas (TrackContainer, trackContainer, withLoadingIndicator)
import Genetics.Browser.Coordinates (CoordSysView)
import Genetics.Browser.Layer (TrackPadding)
import Genetics.Browser.Types (Point)
import Prim.Boolean (False, True, kind Boolean)
import Prim.Row as Row
import Prim.RowList (class RowToList, Cons, Nil, kind RowList)
import Record (delete, get, insert)
import Type.Data.Boolean as Boolean
import Type.Data.Symbol as Symbol
import Type.Prelude (class IsSymbol, class TypeEquals, Proxy(..), RLProxy(..), RProxy(..), SProxy(..), from)
import Unsafe.Coerce (unsafeCoerce)

type TrackInterface a =
  { render   :: Pair Number -> CoordSysView -> Aff Unit
  , hotspots :: Aff (Number -> Point -> Array a) }

class TrackRecord
      (trackList :: RowList)
      (trackRow :: # Type)
      a
      | trackList -> trackRow
      , trackList -> a where
  buildTrack :: RLProxy trackList
             -> Record trackRow
             -> TrackContainer
             -> Aff { render   :: Pair Number -> CoordSysView -> Aff Unit
                    , hotspots :: Aff (Number -> Point -> Array a) }

instance trackRecordRender ::
  ( IsSymbol  name
  , Row.Lacks name trackRow'
  , Row.Cons  name (Pair Number -> CoordSysView -> Aff Unit) trackRow' trackRow
  , TrackRecord trackTail trackRow' a
  ) => TrackRecord (Cons name (Pair Number -> CoordSysView -> Aff Unit) trackTail) trackRow a where
  buildTrack _ r tcont = do

    let name = SProxy :: SProxy name

    rest <- buildTrack (RLProxy :: RLProxy trackTail)
                       (delete name r) tcont

    let rLayer p c = (get name r) p c

    pure { render:   rLayer <> rest.render
         , hotspots: rest.hotspots }

instance trackRecordUI ::
  ( IsSymbol  name
  , Row.Lacks name trackRow'
  , Row.Cons  name (Aff Unit) trackRow' trackRow
  , TrackRecord trackTail trackRow' a
  ) => TrackRecord (Cons name (Aff Unit) trackTail) trackRow a where
  buildTrack _ r tcont = do

    let name = SProxy :: SProxy name

    rest <- buildTrack (RLProxy :: RLProxy trackTail)
                       (delete name r) tcont

    let rLayer _ _ = (get name r)

    pure { render:   rLayer <> rest.render
         , hotspots: rest.hotspots }

instance trackRecordHotspots ::
  ( IsSymbol  name
  , Row.Lacks name trackRow'
  , Row.Cons  name (Aff (Number -> pt -> Array a)) trackRow' trackRow
  , TypeEquals pt Point
  , TrackRecord trackTail trackRow' a
  ) => TrackRecord (Cons name (Aff (Number -> pt -> Array a)) trackTail) trackRow a where
  buildTrack _ r tcont = do

    let name = SProxy :: SProxy name

    rest <- buildTrack (RLProxy :: RLProxy trackTail)
                       (delete name r) tcont

    let hotspots = ado
          h  <- get name r
          h' <- rest.hotspots
          in \rad p -> h rad (from p) <> h' rad p

    pure { render: rest.render, hotspots }

instance trackRecordNil ::
  ( TypeEquals (Record trackRow) {}
  ) => TrackRecord Nil trackRow a where
  buildTrack _ _ _ = mempty

makeTrack :: ∀ row list a.
             RowToList row list
          => TrackRecord list row a
          => Record row
          -> TrackContainer
          -> Aff (TrackInterface a)
makeTrack r c = buildTrack (RLProxy :: RLProxy list) r c

type TrackConfigRecord r =
  { trackHeight :: Number
  , padding :: TrackPadding | r }

class TrackConfig
  (confList :: RowList)
  (confRow  :: # Type)
  (trackRow :: # Type)
  | confList -> confRow trackRow
  where
  makeContainersImpl :: RLProxy confList
                     -> Number
                     -> Record confRow
                     -> Effect (Record trackRow)

instance trackConfigNil ::
  ( TypeEquals (Record tr) {}
  ) => TrackConfig Nil cr tr where
  makeContainersImpl _ _ _ = pure $ from {}

instance trackConfigCons ::
  ( IsSymbol name
  , TrackConfig tail confRow' trackRow'
  , Row.Cons name c confRow' confRow
  , Row.Lacks name confRow'
  , Row.Cons name TrackContainer trackRow' trackRow
  , Row.Lacks name trackRow'
  , TypeEquals (TrackConfigRecord we) c
  ) => TrackConfig (Cons name c tail) confRow trackRow where
  makeContainersImpl _ width r = do
    let n = SProxy :: SProxy name

        c :: TrackConfigRecord we
        c = from $ get n r

    cont <- trackContainer
              {width, height: c.trackHeight}
              c.padding
              (Symbol.reflectSymbol n)

    rest <- makeContainersImpl
              (RLProxy :: RLProxy tail)
              width
              (delete n $ from r)

    pure $ insert n cont rest

makeContainers :: ∀ cl cr tr.
                  RowToList cr cl
               => TrackConfig cl cr tr
               => Number
               -> Record cr
               -> Effect (Record tr)
makeContainers = makeContainersImpl (RLProxy :: RLProxy cl)

class TrackData
      (fetcherList :: RowList)
      (fetcherRow :: # Type)
      (urlRow :: # Type)
      (dataRow :: # Type)
      | fetcherList -> fetcherRow
      , fetcherList -> urlRow
      , fetcherList -> dataRow where
  fetchDataImpl :: RLProxy fetcherList
            -> Record fetcherRow
            -> Record urlRow
            -> Aff (Record dataRow)

instance trackDataCons ::
  ( IsSymbol  name
  , Row.Lacks name fetcherRow'
  , Row.Cons  name (String -> Aff x) fetcherRow' fetcherRow
  , Monoid x
  , Row.Cons  name (Maybe String) urlRow' urlRow
  , Row.Lacks name dataRow'
  , Row.Cons  name x dataRow' dataRow
  , TrackData fetcherTail fetcherRow' urlRow dataRow'
  ) => TrackData (Cons name (String -> Aff x) fetcherTail)
                 fetcherRow
                 urlRow
                 dataRow where
  fetchDataImpl _ fetchers urls = do
    let name = SProxy :: _ name

    rest <- fetchDataImpl (RLProxy :: _ fetcherTail)
                          (delete name fetchers)
                          urls

    dataset <- foldMap (get name fetchers) (get name urls)

    pure $ insert name dataset rest

instance trackDataNil ::
  ( TypeEquals (Record dataRow) {}
  ) => TrackData Nil () urlRow dataRow where
  fetchDataImpl _ _ _ = pure $ from {}

-- | `fetchData` puts a loading indicator in the provided TrackContainer,
-- | fetches the data in the provided `urlRow` record, and parses it
-- | using the parsers in the provided `parserRow` record.
fetchData :: ∀ fetcherRow fetcherList urlRow urlList dataRow.
             RowToList fetcherRow fetcherList
          => RowToList urlRow urlList
          => TrackData fetcherList fetcherRow urlRow dataRow
          => TrackContainer
          -> Record fetcherRow
          -> Record urlRow
          -> Aff (Record dataRow)
fetchData tc fs urls = withLoadingIndicator tc
                       $ fetchDataImpl (RLProxy :: _ fetcherList)
                                       fs
                                       urls

-- | Combine a record of functions from records,
-- | into a function from a record of their union,
-- | to a record of their outputs.
-- | E.g. `{f :: Record r1 -> a, g :: Record r2 -> b}`
-- | into `Record (r1 + r2) -> { f :: a, g :: b }`
class CombineFuns
  (funsList :: RowList)
  (funsRow :: # Type)
  (argRow :: # Type)
  (outRow :: # Type)
  | funsList -> funsRow
  , funsList -> argRow
  , funsList -> outRow where
  combineFunsImpl :: RLProxy funsList
              -> Record funsRow
              -> Record argRow
              -> Record outRow

instance combineFunCons ::
  ( IsSymbol  name
  , Row.Lacks name funsRow'
  , Row.Cons  name (Record r -> a) funsRow' funsRow
  , Row.Union argRow' r argRowUnion
  , Row.Nub   argRowUnion argRowNubbed
  , Row.Lacks name outRow'
  , Row.Cons  name a outRow' outRow
  , CombineFuns funsTail funsRow' argRow' outRow'
  ) => CombineFuns (Cons name (Record r -> a) funsTail)
                  funsRow
                  argRowNubbed
                  outRow where
  combineFunsImpl _ funs args =
    let name = SProxy :: _ name

        thoseArgs :: Record argRow'
        thoseArgs = unsafeCoerce args

        theseArgs :: Record r
        theseArgs = unsafeCoerce args

        rest = combineFunsImpl (RLProxy :: _ funsTail)
                               (delete name funs)
                               thoseArgs
        fn = (get name funs)

    in (insert name (fn theseArgs) rest)

instance combineFunNil ::
  ( TypeEquals (Record outRow) {}
  ) => CombineFuns Nil () () outRow where
  combineFunsImpl _ _ _ = from {}

-- | Note! this isn't actually type safe yet.
-- | If two functions use arguments with the same label
-- | but different types, things break...
combineFuns :: ∀ funsList funsRow argRow outRow.
               RowToList funsRow funsList
            => CombineFuns funsList funsRow argRow outRow
            => Record funsRow
            -> Record argRow
            -> Record outRow
combineFuns funs args = combineFunsImpl (RLProxy :: _ funsList) funs args

class BuildLayers
  (layers :: # Type)
  (output :: # Type)
  | layers -> output

class GetBrowserConfig
  (totalConfig :: # Type)
  (browser :: # Type)
  | totalConfig -> browser where
    getBrowserConfigImpl :: Record totalConfig
                         -> Record browser

instance getBrowserConfig ::
  ( IsSymbol sBrowser
  , TypeEquals (SProxy sBrowser) (SProxy "browser")
  , IsSymbol sLayers
  , TypeEquals (SProxy sLayers) (SProxy "layers")

  , Row.Cons sBrowser (Record browser') totalConfig' totalConfig
  , Row.Lacks sBrowser totalConfig'

  , Row.Cons sLayers layers browser browser'
  , Row.Lacks sLayers browser
  ) => GetBrowserConfig totalConfig browser where
  getBrowserConfigImpl total =
    let browser' :: Record browser'
        browser' = get (from (SProxy :: _ "browser")) total
    in delete (from (SProxy :: _ "layers")) browser'

class GetTrackConfig
  (totalConfig :: # Type)
  (track :: # Type)
  (trackName :: Symbol)
  | totalConfig trackName -> track where
    getTrackConfigImpl :: Record totalConfig
                       -> SProxy trackName
                       -> Record track

instance getTrackConfig ::
  ( IsSymbol sTracks
  , TypeEquals (SProxy sTracks) (SProxy "tracks")
  , IsSymbol sLayers
  , TypeEquals (SProxy sLayers) (SProxy "layers")
  , IsSymbol trackName

  , Row.Cons sTracks (Record tracks) totalConfig' totalConfig
  , Row.Lacks sTracks totalConfig'

  , Row.Cons trackName (Record thisTrack') tracks' tracks
  , Row.Lacks trackName tracks'

  , Row.Cons sLayers layers thisTrack thisTrack'
  , Row.Lacks sLayers thisTrack

  ) => GetTrackConfig totalConfig thisTrack trackName where
    getTrackConfigImpl total _ =
      let tracks' :: Record tracks
          tracks' = get (from (SProxy :: _ "tracks")) total

          thisTrack :: Record thisTrack'
          thisTrack = get (from (SProxy :: _ trackName)) tracks'

      in delete (from (SProxy :: _ "layers")) thisTrack

class GetLayerConfig
  (totalConfig :: # Type)
  (layer :: # Type)
  (trackName :: Symbol)
  (layerName :: Symbol)
  | totalConfig trackName layerName -> layer where
    getLayerConfigImpl :: Record totalConfig
                       -> SProxy trackName
                       -> SProxy layerName
                       -> Record layer

instance getLayerConfig ::
  ( IsSymbol sTracks
  , TypeEquals (SProxy sTracks) (SProxy "tracks")
  , IsSymbol sLayers
  , TypeEquals (SProxy sLayers) (SProxy "layers")
  , IsSymbol trackName
  , IsSymbol layerName

  , Row.Cons sTracks (Record tracks) totalConfig' totalConfig
  , Row.Lacks sTracks totalConfig'

  , Row.Cons trackName (Record thisTrack) tracks' tracks
  , Row.Lacks trackName tracks'

  , Row.Cons sLayers (Record layers) thisTrack' thisTrack
  , Row.Lacks sLayers thisTrack

  , Row.Cons layerName (Record thisLayer) layers' layers
  , Row.Lacks layerName layers'
  ) => GetLayerConfig totalConfig thisLayer trackName layerName where
    getLayerConfigImpl total _ _ =
      let tracks' :: Record tracks
          tracks' = get (from (SProxy :: _ "tracks")) total

          thisTrack :: Record thisTrack
          thisTrack = get (from (SProxy :: _ trackName)) tracks'

          layers :: Record layers
          layers = get (from (SProxy :: _ "layers")) thisTrack

      in get (from (SProxy :: _ layerName)) layers

newtype LayerDef browser track layer a
  = LayerDef ({ browserConfig :: Record browser
              , trackConfig :: Record track
              , layerConfig :: Record layer }
              -> a)

class ApplyLayerDef
  (browser :: # Type)
  (track :: # Type)
  (layer :: # Type)
  (totalConfig :: # Type)
  (trackName :: Symbol)
  (layerName :: Symbol)
  a
  | trackName layerName totalConfig -> track layer where
    applyLayerDefImpl :: LayerDef browser track layer a
                      -> SProxy trackName
                      -> SProxy layerName
                      -> Record totalConfig
                      -> a

instance applyLayerDefInst ::
  ( IsSymbol trackName
  , IsSymbol layerName
  , GetBrowserConfig totalConfig browser
  , GetTrackConfig totalConfig track trackName
  , GetLayerConfig totalConfig layer trackName layerName
  ) => ApplyLayerDef browser track layer totalConfig trackName layerName a where
    applyLayerDefImpl (LayerDef f) trackName layerName total =
      let browserConfig = getBrowserConfigImpl total
          trackConfig = getTrackConfigImpl total trackName
          layerConfig = getLayerConfigImpl total trackName layerName
      in f { browserConfig, trackConfig, layerConfig }

applyLayerDef :: ∀ browser track layer trackName layerName config a.
                 IsSymbol trackName
              => IsSymbol layerName
              => ApplyLayerDef browser track layer config trackName layerName a
              => LayerDef browser track layer a
              -> SProxy trackName
              -> SProxy layerName
              -> Record config
              -> a
applyLayerDef = applyLayerDefImpl

-- | Class for checking if a RowList has a "conflict" with a
-- | given label and type. If the list lacks the label, or
-- | has the label with the same type, return False; if it
-- | has the label, but with a different type, return True.
class ConflictsWith
  (list :: RowList)
  (label :: Symbol)
  (t :: Type)
  (result :: Boolean)
  | list label t -> result

-- no conflict base case
instance conflictsWithNil ::
  ConflictsWith Nil label t False

-- same label and type, no conflict, recurse
instance conflictsWithCons1 ::
  ( ConflictsWith tail label t tailResult
  ) => ConflictsWith (Cons label  t  tail) label t tailResult

-- found conflict base case
else instance conflictsWithCons3 ::
  ConflictsWith (Cons label  t' tail) label t True

-- different label, same or different type, recurse
else instance conflictsWithCons2 ::
  ( ConflictsWith tail label t tailResult
  ) =>  ConflictsWith (Cons label' t' tail) label t tailResult

hasConflict :: ∀ row list l a .
                 RowToList row list
              => IsSymbol l
              => ConflictsWith list l a True
              => RProxy row
              -> SProxy l
              -> Proxy a
              -> Unit
hasConflict _ _ _ = unit

noConflict :: ∀ row list l a .
                 RowToList row list
              => IsSymbol l
              => ConflictsWith list l a False
              => RProxy row
              -> SProxy l
              -> Proxy a
              -> Unit
noConflict _ _ _ = unit

conflict1 = hasConflict  (RProxy :: _ (a :: Int, b :: String, c :: Boolean))
                         (SProxy :: _ "c") (Proxy :: _ Int)

conflict2 = hasConflict  (RProxy :: _ (a :: Int, b :: String, c :: Boolean))
                         (SProxy :: _ "b") (Proxy :: _ Int)

noconflict1 = noConflict (RProxy :: _ (a :: Int, b :: String, c :: Boolean))
                         (SProxy :: _ "d") (Proxy :: _ Int)

noconflict2 = noConflict (RProxy :: _ (a :: Int, b :: String, c :: Boolean))
                         (SProxy :: _ "b") (Proxy :: _ String)


WIP #1703 - no menu

WIP #1703 - no menu

{-
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.GlobalMenu.Component
  ( component
  , Query(..)
  , MenuOpen(..)
  , Message(..)
  , AuthenticateOrPresentHelp(..)
  , State
  , module SlamData.GlobalMenu.Bus
  ) where

import SlamData.Prelude

import Control.UI.Browser as Browser
import Control.Monad.Aff.AVar as AVar
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Eff as Eff
import Control.Monad.Eff.Ref as Ref
import Control.Monad.Eff.Exception as Exception

import Halogen as H
import Halogen.Component.Utils (busEventSource)
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.Query.EventSource as ES
import Halogen.HTML.Events as HE

import OIDC.Crypt as Crypt

import Quasar.Advanced.Types (ProviderR)

import SlamData.AuthenticationMode as AuthenticationMode
import SlamData.Workspace.Eval.Card as EvalCard
import SlamData.GlobalError (GlobalError)
import SlamData.GlobalError as GlobalError
import SlamData.GlobalMenu.Bus (SignInMessage(..))
import SlamData.Monad (Slam)
import SlamData.Quasar as Api
import SlamData.Quasar.Auth as Auth
import SlamData.Quasar.Auth.Authentication (AuthenticationError, toNotificationOptions)
import SlamData.Quasar.Auth.Store as AuthStore
import SlamData.Render.Icon as I
import SlamData.Wiring as Wiring
import SlamData.Workspace.Eval.Persistence as Persistence

data AuthenticateOrPresentHelp

data Query a
  = Authenticate (Maybe ProviderR) a
  | DismissSubmenu a
  | HandleGlobalError GlobalError a
  | Init a
  | PresentAttribution a
  | ToggleMenu MenuOpen a

data MenuOpen
 = SignInMenu
 | HelpMenu

derive instance eqMenuOpen ∷ Eq MenuOpen

type State =
  { email ∷ Maybe String
  , loggedIn ∷ Boolean
  , menuOpen ∷ Maybe MenuOpen
  , providers ∷ Maybe (Array ProviderR)
  }

data Message =
  PresentAttributionsDialog

type HTML = H.ParentHTML Query (Menu.Query AuthenticateOrPresentHelp) Unit Slam
type DSL = H.ParentDSL State Query (Menu.Query AuthenticateOrPresentHelp) Unit Message Slam

component ∷ H.Component HH.HTML Query Unit Message Slam
component =
  H.lifecycleParentComponent
    { initialState: \_ →
      { email: Nothing
      , loggedIn: false
      , menuOpen: Nothing
      , providers: Nothing
      }
    , render
    , eval
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    , receiver: const Nothing
    }

render ∷ State → HTML
render state =
  HH.div
    [ HP.classes $ [ HH.ClassName "sd-global-menu" ] ]
    $ menu state

eval ∷ Query ~> DSL
eval = case _ of
  Init next → do
    { bus } ← H.lift Wiring.expose
    H.subscribe $ busEventSource (flip HandleGlobalError ES.Listening) bus.globalError
    update
    pure next

  DismissSubmenu next → do
    H.modify _{ menuOpen = Nothing }
    pure next

  HandleGlobalError error next →
    case error of
      GlobalError.Unauthorized _ → update $> next
      _ → pure next

  Authenticate providerR next → do
    authenticate providerR
    pure next

  PresentAttribution next → do
    H.raise PresentAttributionsDialog
    pure next

  ToggleMenu which next → do
    menuOpen ← H.gets _.menuOpen
    let
      m = case menuOpen, which of
        Just HelpMenu, HelpMenu → Nothing
        Just SignInMenu, SignInMenu → Nothing
        _, _ → Just which
    H.modify _{ menuOpen = m }
    pure next

update ∷ DSL Unit
update = do
  maybeIdToken ← H.lift Auth.getIdToken
  case maybeIdToken of
    Just idToken → do
      either
        (const retrieveProvidersAndUpdateMenu)
        putEmailToMenu
        (Eff.runPure $ Exception.try $ Crypt.readPayload idToken)
    Nothing →
      retrieveProvidersAndUpdateMenu
  where
  putEmailToMenu ∷ Crypt.Payload → DSL Unit
  putEmailToMenu payload =
    H.modify _{ loggedIn = true, email = map unwrap $ Crypt.pluckEmail payload }

  retrieveProvidersAndUpdateMenu ∷ DSL Unit
  retrieveProvidersAndUpdateMenu = void do
    eProviders ← Api.retrieveAuthProviders
    case eProviders of
      Right p → H.modify _{ providers = p }
      _ → pure unit

    {- H.query unit
      $ H.action
      $ Menu.Set
          { chosen: Nothing
          , submenus: case eProviders of
              _ ->
              -- Right (Just providers) →
                let
                  makeSubmenuItem provider =
                    { label: "Sign in with " ⊕ provider.displayName
                    , shortcutLabel: Nothing
                    , value: Authenticate $ Just provider
                    }
                in
                  [ { label: "🔓 Sign in"
                    , submenu: makeSubmenuItem <$> mempty -- providers
                    }
                  ]
                ⊕
              -- _ → helpMenu
          }
                -}

menu :: forall a. State → Array (H.HTML a Query)
menu state =
  let
    container ∷ HH.ClassName
    container = HH.ClassName "menu-container"

    submenuItem = HP.classes $ HH.ClassName <$> [ "menu-item", "submenu-item" ]

    submenu ∷ Array (H.HTML a Query) → H.HTML a Query
    submenu = HH.ul [ HP.class_ $ HH.ClassName "submenu" ]

    -- wraps stiff in `li > button`
    sitem ∷ ProviderR → H.HTML a Query
    sitem provider =
      HH.li [ submenuItem ]
        [ HH.button
          [ HP.classes $ HH.ClassName <$> [ "menu-item-button", "submenu-item-button" ]
          , HE.onClick $ HE.input_ $ Authenticate $ pure provider
          ]
          [ HH.text $ "Sign in with " <> provider.displayName ]
        ]

    -- wraps stuff in `li > a`
    hitem attrs children =
      HH.li [ submenuItem ]
        [ HH.a
          ([ HP.classes $ HH.ClassName <$> [ "menu-item-link", "submenu-item-link" ] ] <> attrs)
          children
        ]

    signInMenu ∷ Array (H.HTML a Query)
    signInMenu =
      case state.providers of
        Nothing → []
        Just ps →
          [ HH.div
            [ HP.classes [ container, HH.ClassName "sign-in-menu-container" ] ] $
            -- if
            [ HH.button
                [ HP.class_ $ HH.ClassName "sign-in-menu-button "
                , HE.onClick $ HE.input_ $ ToggleMenu SignInMenu
                ]
                [ I.unlockSm, HH.text "Sign in" ]
            ] <>
              if state.menuOpen == Just SignInMenu then
                [ submenu $ sitem <$> ps ]
              else
                []
          ]

    helpMenu ∷ H.HTML a Query
    helpMenu =
      HH.div
        [ HP.classes [ container, HH.ClassName "help-menu-container" ] ] $
        [ HH.button
          [ HP.class_ $ HH.ClassName "help-menu-button"
          , HE.onClick $ HE.input_ $ ToggleMenu HelpMenu
          ]
          [ I.helpSm, HH.text "Help" ]
        ] <>
          if state.menuOpen == Just HelpMenu then
            [ submenu
              [ hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/users-guide.html" ]
                  [ HH.text "User guide" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/administration-guide.html" ]
                  [ HH.text "Administrator guide" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/developers-guide.html" ]
                  [ HH.text "Developer guide" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/helpful-tips.html" ]
                  [ HH.text "Helpful tips" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/sql-squared-reference.html" ]
                  [ HH.text "SQL² reference" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/slamdown-reference.html" ]
                  [ HH.text "SlamDown reference" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/troubleshooting-faq.html" ]
                  [ HH.text "Troubleshooting FAQ" ]
              , HH.li [ submenuItem ]
                  [ HH.button
                    [ HP.classes $ HH.ClassName <$>
                        [ "menu-item-button", "submenu-item-button"
                    ]
                    , HE.onClick $ HE.input_ $ PresentAttribution
                    ]
                    [ HH.text $ "Attritubion" ]
                  ]
              ]
            ]
          else
            []

  in
    signInMenu <> [ helpMenu ]

authenticate ∷ Maybe ProviderR → DSL Unit
authenticate = maybe logOut logIn
  where
  keySuffix ∷ String
  keySuffix =
    AuthenticationMode.toKeySuffix AuthenticationMode.ChosenProvider

  logOut ∷ DSL Unit
  logOut = do
    AuthStore.removeIdToken keySuffix
    AuthStore.removeUnhashedNonce keySuffix
    AuthStore.removeProvider keySuffix
    update

  logIn ∷ ProviderR → DSL Unit
  logIn providerR = do
    { auth } ← H.lift Wiring.expose
    idToken ← H.liftAff AVar.makeVar
    H.liftAff $ Bus.write { providerR, idToken, prompt: true, keySuffix } auth.requestToken
    either signInFailure (const $ signInSuccess) =<< (H.liftAff $ AVar.takeVar idToken)

  signInSuccess ∷ DSL Unit
  signInSuccess = do
    wiring ← Wiring.expose
    update
    traverse_ (lift ∘ Persistence.queueEvalImmediate ∘ EvalCard.toAll)
      =<< (H.liftEff $ Ref.readRef wiring.auth.retryEval)
    whenM
      (H.liftEff $ Ref.readRef wiring.auth.retrySave)
      (void $ lift $ Persistence.saveWorkspace)
    H.liftAff $ Bus.write SignInSuccess wiring.auth.signIn

  signInFailure ∷ AuthenticationError → DSL Unit
  signInFailure error = do
    { auth, bus } ← H.lift Wiring.expose
    H.liftAff do
      maybe (pure unit) (flip Bus.write bus.notify) (toNotificationOptions error)
      Bus.write SignInFailure auth.signIn

presentHelp ∷ String → DSL Unit
presentHelp = H.liftEff ∘ Browser.newTab

{-
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.GlobalMenu.Component
  ( component
  , Query(..)
  , MenuOpen(..)
  , Message(..)
  , AuthenticateOrPresentHelp(..)
  , State
  , module SlamData.GlobalMenu.Bus
  ) where

import SlamData.Prelude

import Control.UI.Browser as Browser
import Control.Monad.Aff.AVar as AVar
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Eff as Eff
import Control.Monad.Eff.Ref as Ref
import Control.Monad.Eff.Exception as Exception

import Halogen as H
import Halogen.Component.Utils (busEventSource)
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.Menu.Component as Menu
import Halogen.Query.EventSource as ES
import Halogen.HTML.Events as HE

import OIDC.Crypt as Crypt

import Quasar.Advanced.Types (ProviderR)

import SlamData.AuthenticationMode as AuthenticationMode
import SlamData.Workspace.Eval.Card as EvalCard
import SlamData.GlobalError (GlobalError)
import SlamData.GlobalError as GlobalError
import SlamData.GlobalMenu.Bus (SignInMessage(..))
import SlamData.Monad (Slam)
import SlamData.Quasar as Api
import SlamData.Quasar.Auth as Auth
import SlamData.Quasar.Auth.Authentication (AuthenticationError, toNotificationOptions)
import SlamData.Quasar.Auth.Store as AuthStore
import SlamData.Render.Icon as I
import SlamData.Wiring as Wiring
import SlamData.Workspace.Eval.Persistence as Persistence

data AuthenticateOrPresentHelp

data Query a
  = Authenticate (Maybe ProviderR) a
  | DismissSubmenu a
  | HandleGlobalError GlobalError a
  | Init a
  | PresentAttribution a
  | ToggleMenu MenuOpen a

data MenuOpen
 = SignInMenu
 | HelpMenu

derive instance eqMenuOpen ∷ Eq MenuOpen

type State =
  { email ∷ Maybe String
  , loggedIn ∷ Boolean
  , menuOpen ∷ Maybe MenuOpen
  , providers ∷ Maybe (Array ProviderR)
  }

data Message =
  PresentAttributionsDialog

type HTML = H.ParentHTML Query (Menu.Query AuthenticateOrPresentHelp) Unit Slam
type DSL = H.ParentDSL State Query (Menu.Query AuthenticateOrPresentHelp) Unit Message Slam

component ∷ H.Component HH.HTML Query Unit Message Slam
component =
  H.lifecycleParentComponent
    { initialState: \_ →
      { email: Nothing
      , loggedIn: false
      , menuOpen: Nothing
      , providers: Nothing
      }
    , render
    , eval
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    , receiver: const Nothing
    }

render ∷ State → HTML
render state =
  HH.div
    [ HP.classes $ [ HH.ClassName "sd-global-menu" ] ]
    $ menu state

eval ∷ Query ~> DSL
eval = case _ of
  Init next → do
    { bus } ← H.lift Wiring.expose
    H.subscribe $ busEventSource (flip HandleGlobalError ES.Listening) bus.globalError
    update
    pure next

  DismissSubmenu next → do
    _ ← H.query unit $ H.action $ Menu.DismissSubmenu
    pure next

  HandleGlobalError error next →
    case error of
      GlobalError.Unauthorized _ → update $> next
      _ → pure next

  Authenticate providerR next → do
    authenticate providerR
    pure next

  PresentAttribution next → do
    H.raise PresentAttributionsDialog
    pure next

  ToggleMenu which next → do
    menuOpen ← H.gets _.menuOpen
    let
      m = case menuOpen, which of
        Just HelpMenu, HelpMenu → Nothing
        Just SignInMenu, SignInMenu → Nothing
        _, _ → Just which
    H.modify _{ menuOpen = m }
    pure next

update ∷ DSL Unit
update = do
  maybeIdToken ← H.lift Auth.getIdToken
  case maybeIdToken of
    Just idToken → do
      either
        (const retrieveProvidersAndUpdateMenu)
        putEmailToMenu
        (Eff.runPure $ Exception.try $ Crypt.readPayload idToken)
    Nothing →
      retrieveProvidersAndUpdateMenu
  where
  putEmailToMenu ∷ Crypt.Payload → DSL Unit
  putEmailToMenu payload =
    H.modify _{ loggedIn = true, email = map unwrap $ Crypt.pluckEmail payload }

  retrieveProvidersAndUpdateMenu ∷ DSL Unit
  retrieveProvidersAndUpdateMenu = void do
    eProviders ← Api.retrieveAuthProviders
    case eProviders of
      Right p → H.modify _{ providers = p }
      _ → pure unit

    {- H.query unit
      $ H.action
      $ Menu.Set
          { chosen: Nothing
          , submenus: case eProviders of
              _ ->
              -- Right (Just providers) →
                let
                  makeSubmenuItem provider =
                    { label: "Sign in with " ⊕ provider.displayName
                    , shortcutLabel: Nothing
                    , value: Authenticate $ Just provider
                    }
                in
                  [ { label: "🔓 Sign in"
                    , submenu: makeSubmenuItem <$> mempty -- providers
                    }
                  ]
                ⊕
              -- _ → helpMenu
          }
                -}

menu :: forall a. State → Array (H.HTML a Query)
menu state =
  let
    container ∷ HH.ClassName
    container = HH.ClassName "menu-container"

    submenuItem = HP.classes $ HH.ClassName <$> [ "menu-item", "submenu-item" ]

    submenu ∷ Array (H.HTML a Query) → H.HTML a Query
    submenu = HH.ul [ HP.class_ $ HH.ClassName "submenu" ]

    -- wraps stiff in `li > button`
    sitem ∷ ProviderR → H.HTML a Query
    sitem provider =
      HH.li [ submenuItem ]
        [ HH.button
          [ HP.classes $ HH.ClassName <$> [ "menu-item-button", "submenu-item-button" ]
          , HE.onClick $ HE.input_ $ Authenticate $ pure provider
          ]
          [ HH.text $ "Sign in with " <> provider.displayName ]
        ]

    -- wraps stuff in `li > a`
    hitem attrs children =
      HH.li [ submenuItem ]
        [ HH.a
          ([ HP.classes $ HH.ClassName <$> [ "menu-item-link", "submenu-item-link" ] ] <> attrs)
          children
        ]

    signInMenu ∷ Array (H.HTML a Query)
    signInMenu =
      case state.providers of
        Nothing → []
        Just ps →
          [ HH.div
            [ HP.classes [ container, HH.ClassName "sign-in-menu-container" ] ] $
            -- if
            [ HH.button
                [ HP.class_ $ HH.ClassName "sign-in-menu-button "
                , HE.onClick $ HE.input_ $ ToggleMenu SignInMenu
                ]
                [ I.unlockSm, HH.text "Sign in" ]
            ] <>
              if state.menuOpen == Just SignInMenu then
                [ submenu $ sitem <$> ps ]
              else
                []
          ]

    helpMenu ∷ H.HTML a Query
    helpMenu =
      HH.div
        [ HP.classes [ container, HH.ClassName "help-menu-container" ] ] $
        [ HH.button
          [ HP.class_ $ HH.ClassName "help-menu-button"
          , HE.onClick $ HE.input_ $ ToggleMenu HelpMenu
          ]
          [ I.helpSm, HH.text "Help" ]
        ] <>
          if state.menuOpen == Just HelpMenu then
            [ submenu
              [ hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/users-guide.html" ]
                  [ HH.text "User guide" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/administration-guide.html" ]
                  [ HH.text "Administrator guide" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/developers-guide.html" ]
                  [ HH.text "Developer guide" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/helpful-tips.html" ]
                  [ HH.text "Helpful tips" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/sql-squared-reference.html" ]
                  [ HH.text "SQL² reference" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/slamdown-reference.html" ]
                  [ HH.text "SlamDown reference" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/troubleshooting-faq.html" ]
                  [ HH.text "Troubleshooting FAQ" ]
              , HH.li [ submenuItem ]
                  [ HH.button
                    [ HP.classes $ HH.ClassName <$>
                        [ "menu-item-button", "submenu-item-button"
                    ]
                    , HE.onClick $ HE.input_ $ PresentAttribution
                    ]
                    [ HH.text $ "Attritubion" ]
                  ]
              ]
            ]
          else
            []

  in
    signInMenu <> [ helpMenu ]

authenticate ∷ Maybe ProviderR → DSL Unit
authenticate = maybe logOut logIn
  where
  keySuffix ∷ String
  keySuffix =
    AuthenticationMode.toKeySuffix AuthenticationMode.ChosenProvider

  logOut ∷ DSL Unit
  logOut = do
    AuthStore.removeIdToken keySuffix
    AuthStore.removeUnhashedNonce keySuffix
    AuthStore.removeProvider keySuffix
    update

  logIn ∷ ProviderR → DSL Unit
  logIn providerR = do
    { auth } ← H.lift Wiring.expose
    idToken ← H.liftAff AVar.makeVar
    H.liftAff $ Bus.write { providerR, idToken, prompt: true, keySuffix } auth.requestToken
    either signInFailure (const $ signInSuccess) =<< (H.liftAff $ AVar.takeVar idToken)

  signInSuccess ∷ DSL Unit
  signInSuccess = do
    wiring ← Wiring.expose
    update
    traverse_ (lift ∘ Persistence.queueEvalImmediate ∘ EvalCard.toAll)
      =<< (H.liftEff $ Ref.readRef wiring.auth.retryEval)
    whenM
      (H.liftEff $ Ref.readRef wiring.auth.retrySave)
      (void $ lift $ Persistence.saveWorkspace)
    H.liftAff $ Bus.write SignInSuccess wiring.auth.signIn

  signInFailure ∷ AuthenticationError → DSL Unit
  signInFailure error = do
    { auth, bus } ← H.lift Wiring.expose
    H.liftAff do
      maybe (pure unit) (flip Bus.write bus.notify) (toNotificationOptions error)
      Bus.write SignInFailure auth.signIn

presentHelp ∷ String → DSL Unit
presentHelp = H.liftEff ∘ Browser.newTab


Updated grid to have alternating square colours

module Main where

import Control.Monad.Eff
import Data.Array
import Data.Int
import Data.Maybe
import Graphics.Canvas
import Prelude

type Player = String

type Square = { x :: Int, y :: Int, rx :: Number, ry :: Number, color :: String }

type Grid = Array Square

renderSize :: Number
renderSize = 60.0

createGrid :: Int -> Int -> Grid
createGrid width height = do
  x <- 0 .. (width - 1)
  y <- 0 .. (height - 1)
  let rx = (toNumber x) * renderSize
      ry = (toNumber y) * renderSize
      color = if disj (conj (even x) (odd y)) (conj (even y) (odd x))
              then "#d18b47"
              else "#ffce9e"
  return { x: x, y: y, rx: rx, ry: ry, color: color }

renderSquare :: forall e. Context2D -> Unit -> Square -> Eff (canvas :: Canvas | e) Unit
renderSquare ctx _ square = do
  save ctx
  setFillStyle square.color ctx
  fillRect ctx { x: square.rx, y: square.ry, w: renderSize, h: renderSize }
  restore ctx
  return unit

render :: forall e. Context2D -> Grid -> Eff (canvas :: Canvas | e) Unit
render ctx grid = do
  save ctx
  foldM (renderSquare ctx) unit grid
  restore ctx
  return unit

main :: forall e. Eff (canvas :: Canvas | e) Unit
main = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      ctx <- getContext2D canvas
      render ctx (createGrid 8 8)
      return unit
    _ -> return unit

module Main where

import Control.Monad.Eff
import Data.Array
import Data.Int
import Data.Maybe
import Graphics.Canvas
import Prelude

type Player = String

type Square = { x :: Int, y :: Int }

type Grid = Array Square

renderSize :: Number
renderSize = 50.0

createGrid :: Int -> Int -> Grid
createGrid width height = do
  x <- 0 .. (width - 1)
  y <- 0 .. (height - 1)
  return { x: x, y: y }

renderRectangle :: Square -> Rectangle
renderRectangle square = { x: (toNumber square.x) * renderSize
                         , y: (toNumber square.y) * renderSize
                         , w: renderSize
                         , h: renderSize }

renderSquare :: forall e. Context2D -> Unit -> Rectangle -> Eff (canvas :: Canvas | e) Unit
renderSquare ctx _ rectangle = do
  save ctx
  setFillStyle "#ff0000" ctx
  fillRect ctx rectangle
  restore ctx
  return unit

render :: forall e. Context2D -> Array Rectangle -> Eff (canvas :: Canvas | e) Unit
render ctx grid = do
  save ctx
  foldM (renderSquare ctx) unit grid
  restore ctx
  return unit

main :: forall e. Eff (canvas :: Canvas | e) Unit
main = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      ctx <- getContext2D canvas
      render ctx (map renderRectangle (createGrid 8 8))
      return unit
    _ -> return unit