added tryRepeatedlyTo to switchXs, uncommented test

{-
Copyright 2015 SlamData, Inc.

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

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

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

module Test.Selenium.Notebook.Viz (test, actualCanvasScreenshot) where

import Prelude

import Control.Monad.Eff.Random (randomInt)
import Control.Monad.Eff.Class (liftEff)
import Data.List (length, List(..), fromList, filter, null, (!!))
import Data.Maybe (isJust, isNothing, Maybe(..), maybe, fromMaybe)
import Data.Maybe.Unsafe (fromJust)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..))
import Data.Foldable (foldl, traverse_)
import Data.Monoid (mempty)
import Data.Function (on)
import qualified Data.Set as S

import Selenium.Types
import Selenium.Monad
import Selenium.ActionSequence hiding (sequence)

import Test.Config
import Test.Selenium.ActionSequence (selectAll, sendDelete, sendEnter)
import Test.Selenium.Monad
import Test.Selenium.Log
import Test.Selenium.Common
import Test.Selenium.Notebook.Getters
import Test.Selenium.Notebook.Contexts
import qualified Test.Selenium.Notebook.Common as C
import qualified Config as SDConfig

import Utils (s2i)
import Utils.Random

checkNextVizCell :: Check Unit
checkNextVizCell = do
  waitNextVizCell >>= sequence <<< leftClick
  await "Viz cell has not been created"
    $ map (eq 2 <<< length) getCells
  successMsg "Ok, next cell viz works"

checkSetHeightWidth :: Check Unit
checkSetHeightWidth = withSmallZipsAllChart do
  widthInput <- waitVizWidthInput
  heightInput <- waitVizHeightInput

  w <- liftEff $ randomInt 100 400
  h <- liftEff $ randomInt 100 400

  modifierKey <- getModifierKey

  sequence do
    leftClick widthInput
    selectAll modifierKey
    sendDelete
    sendKeys $ show w

    leftClick heightInput
    selectAll modifierKey
    sendDelete
    sendKeys $ show h

  await "Dimensions has not been setted" do
    dims <- getDims
    pure
       $ dims.w == pure w
      && dims.h == pure h
  successMsg "Ok, dimensions setted"

  where
  getDims = do
    canvas <- waitCanvas
    { w: _, h: _ }
      <$> (s2i <$> getCssValue canvas "width")
      <*> (s2i <$> getCssValue canvas "height")

switchToPie :: Check Unit
switchToPie = do
  tryRepeatedlyTo $ getChartSwitchers >>= sequence <<< leftClick <<< _.pie
  await "Pie switch doesn't work" pieShown

switchToLine :: Check Unit
switchToLine = do
 tryRepeatedlyTo $ getChartSwitchers >>= sequence <<< leftClick <<< _.line
 await "Line switch doesn't work" lineShown

switchToBar :: Check Unit
switchToBar = do
 tryRepeatedlyTo $ getChartSwitchers >>= sequence <<< leftClick <<< _.bar
 await "Bar switch doesn't work" barShown

checkSwitchers :: Check Unit
checkSwitchers = withFlatVizChart do
  pieDisplayed <- pieShown
  if pieDisplayed
    then successMsg "Ok, initial chart type -- pie"
    else errorMsg "Incorrect initial chart type"

  switchToLine
  successMsg "pie -> line"

  switchToBar
  successMsg "line -> bar"

  switchToPie
  successMsg "bar -> pie"

  switchToBar
  successMsg "pie -> bar"

  switchToLine
  successMsg "bar -> line"

  switchToPie
  successMsg "line -> pie"

checkAlert :: Check Unit
checkAlert = withFlatVizMeasures do
  config <- getConfig
  tryRepeatedlyTo $ byCss config.vizSelectors.alert >>= findExact
  successMsg "ok, alert found"

checkOptions :: Check Unit
checkOptions = withFlatVizChart do
  config <- getConfig
  switchToPie
  await "incorrect pie options"
    $ map (eq config.vizOptions.flatVizAll.pie) getCurrentChartOptions
  successMsg "Ok, pie chart options are correct"

  switchToLine
  await "incorrect line options"
    $ map (eq config.vizOptions.flatVizAll.line) getCurrentChartOptions
  successMsg "Ok, line chart options are correct"

  switchToBar
  await "incorrect bar options"
    $ map (eq config.vizOptions.flatVizAll.bar) getCurrentChartOptions

  successMsg "Ok, bar chart options are correct"

-- Don't know how to name it better.
-- This test will look if after switching options in
-- category -> series1 -> series2
-- measure1 -> measure2
-- dimension -> series1 -> series2
-- are filtered
checkOptionUniqueness :: Check Unit
checkOptionUniqueness = withFlatVizChart do
  config <- getConfig

  sectionMsg "check pie uniqueness"
  switchToPie
  await "incorrect pie options"
    $ map (eq config.vizOptions.flatVizAll.pie) getCurrentChartOptions
  checkCategoryUniqueness getCategoryInput getSeriesOneInput getSeriesTwoInput

  sectionMsg "check bar uniqueness"
  switchToBar
  await "incorrect bar options"
    $ map (eq config.vizOptions.flatVizAll.bar) getCurrentChartOptions

  checkCategoryUniqueness getCategoryInput getSeriesOneInput getSeriesTwoInput

  sectionMsg "check line uniqueness"
  switchToLine
  await "incorrec line options"
    $ map (eq config.vizOptions.flatVizAll.line) getCurrentChartOptions

  checkCategoryUniqueness getDimensionInput getSeriesOneInput getSeriesTwoInput
  checkMeasureUniqueness

checkMeasureUniqueness :: Check Unit
checkMeasureUniqueness = do
  config <- getConfig
  mOne <- getMeasureOneInput
  mTwo <- getMeasureTwoInput

  toSelectOne <- filterAndGetValue mOne mTwo "measures"
  toSelectTwo <- getRandomOption mTwo

  fillSelect mTwo toSelectTwo
  fillSelect mOne toSelectTwo
  await "Options has not been dropped"
    $ map (/= toSelectTwo) $ getSelectValue mTwo

  fillSelect mTwo toSelectTwo
  fillSelect mOne config.vizOptions.clearSelection
  await "Option should be disabled"
    $ map not $ isEnabled mTwo
  successMsg "Ok, measure uniqueness"

checkCategoryUniqueness :: Check Element -> Check Element -> Check Element -> Check Unit
checkCategoryUniqueness catM serOneM serTwoM = do
  config <- getConfig
  cat <- catM
  seriesOne <- serOneM
  seriesTwo <- serTwoM

  toSelectCat <- filterAndGetValue cat seriesOne "category"
  toSelectSerOne <- filterAndGetValue seriesOne seriesTwo "series one"

  toSelectSerTwo <- getRandomOption seriesTwo
  fillSelect seriesTwo toSelectSerTwo
  fillSelect seriesOne toSelectSerTwo
  await "Options has not been dropped (one -> two)"
    $ map (/= toSelectSerTwo) $ getSelectValue seriesTwo
  successMsg "Ok, select value dropped"

  fillSelect cat toSelectSerTwo
  await "Options has not been dropped (root -> one)"
    $ map (/= toSelectSerOne) $ getSelectValue seriesOne
  successMsg "Ok, dependent selects values are dropped"

  fillSelect cat toSelectCat
  fillSelect seriesOne toSelectSerOne
  fillSelect seriesTwo toSelectSerTwo
  fillSelect cat toSelectSerTwo
  await "Optoins has not been dropped (root -> two)"
    $ map (/= toSelectSerTwo) $ getSelectValue seriesTwo

  fillSelect cat toSelectCat
  fillSelect seriesOne toSelectSerOne
  fillSelect seriesTwo toSelectSerTwo
  fillSelect seriesOne config.vizOptions.clearSelection
  await "Select should be disabled (series two)"
    $ map not $ isEnabled seriesTwo

  fillSelect seriesOne toSelectSerOne
  fillSelect seriesTwo toSelectSerTwo
  fillSelect cat config.vizOptions.clearSelection
  await "Select should be disabled (series one, series two)" do
    one <- isEnabled seriesOne
    two <- isEnabled seriesTwo
    pure $ not one && not two
  successMsg "Ok, dependent selects are disabled"

  successMsg "OK, category uniqueness"

filterAndGetValue :: Element -> Element -> String -> Check String
filterAndGetValue parent child msg = do
  toSelect <- getRandomOption parent
  fillSelect parent toSelect
  await ("Options are not filtered (" <> msg <> ")") do
    parentOptions <- optionTxts parent
    childOptions <- optionTxts child
    pure $ on eq S.fromList parentOptions (Cons toSelect childOptions)
  successMsg $ "Ok, select filtering works (" <> msg <> ")"
  pure toSelect

getSelectValue :: Element -> Check String
getSelectValue el = do
  val <- getAttribute el "value"
  getOptions (pure el) >>= foldl (foldFn val) (pure mempty)
  where
  foldFn :: String -> Check String -> Element -> Check String
  foldFn selectedVal mStr el = do
    val <- getAttribute el "value"
    if val == selectedVal
      then getInnerHtml el
      else mStr

getRandomOption :: Element -> Check String
getRandomOption el = do
  config <- getConfig
  await "there is no options"
    $ map ((> 2) <<< length) $ getOptions $ pure el
  getOptions (pure el)
    >>= traverse getInnerHtml
    >>= randomInM <<< filter (not <<< eq config.vizOptions.clearSelection)
    >>= \x -> if x == mempty
              then errorMsg "empty option list"
              else pure x
fillSelect :: Element -> String -> Check Unit
fillSelect el txt =
  sequence do
    leftClick el
    sendKeys txt
    sendEnter

fillSelectRandom :: Element -> Check Unit
fillSelectRandom el = do
  opt <- getRandomOption el
  fillSelect el opt

optionTxts :: Element -> Check (List String)
optionTxts el = getOptions (pure el) >>= traverse getInnerHtml

checkOptionAutoSelect :: Check Unit
checkOptionAutoSelect = do
  config <- getConfig
  withFlatVizOneOption do
    switchToPie
    waitPieOrBarFullyDisabled "bar"
    pOpts <- getCurrentChartOptions
    assertBoolean "Error: incorrect pie options"
      $ pOpts == config.vizOptions.flatVizOneOption.pie

    switchToBar
    waitPieOrBarFullyDisabled "pie"
    bOpts <- getCurrentChartOptions
    assertBoolean "Error: incorrect bar options"
      $ bOpts == config.vizOptions.flatVizOneOption.bar

    switchToLine
    waitForDisabled "line"
      $ [ getSeriesOneInput
        , getSeriesTwoInput
        , getDimensionInput
        , getMeasureOneInput
        , getMeasureTwoInput
        ]
    lOpts <- getCurrentChartOptions
    assertBoolean "Error: incorrect line options"
      $ lOpts == config.vizOptions.flatVizOneOption.line
  successMsg "Ok, options are correct when there is one series and one measure"
  where
  waitForDisabled msg getters =
    await ("Error: Incorrect states of selects, they must be disabled (" <> msg <> ")")
    $ foldl (\b x -> conj <$> b <*> (map not $ x >>= isEnabled)) (pure true)
    $ getters
  waitPieOrBarFullyDisabled msg =
    waitForDisabled msg
    $ [ getSeriesOneInput
      , getSeriesTwoInput
      , getMeasureOneInput
      , getCategoryInput
      ]

checkOptionSave :: Check Unit
checkOptionSave = do
  checkOptionSaveBarOrPie switchToBar "bar"
  checkOptionSaveBarOrPie switchToPie "pie"
  checkOptionSaveLine

checkOptionSaveLine :: Check Unit
checkOptionSaveLine = withFlatVizChart do
  switchToLine
  dimension <- getDimensionInput
  measureOne <- getMeasureOneInput
  measureTwo <- getMeasureTwoInput
  seriesOne <- getSeriesOneInput
  seriesTwo <- getSeriesTwoInput

  valueDimension <- filterAndGetValue dimension seriesOne "dimension"
  valueSeriesOne <- filterAndGetValue seriesOne seriesTwo "series"
  valueSeriesTwo <- getRandomOption seriesTwo
  fillSelect seriesTwo valueSeriesTwo
  valueMeasureOne <- filterAndGetValue measureOne measureTwo "measure"
  valueMeasureTwo <- getRandomOption measureTwo
  fillSelect measureTwo valueMeasureTwo

  let assertion = do
        d <- assertSelected getDimensionInput valueDimension
        m1 <- assertSelected getMeasureOneInput valueMeasureOne
        m2 <- assertSelected getMeasureTwoInput valueMeasureTwo
        s1 <- assertSelected getSeriesOneInput valueSeriesOne
        s2 <- assertSelected getSeriesTwoInput valueSeriesTwo
        pure $ d && m1 && m2 && s1 && s2

  switchToPie
  switchToLine
  await "Error: line options have not been saved" assertion

  switchToBar
  switchToLine
  await "Error: line options have not been saved" assertion

  waitTime $ SDConfig.autosaveTick * 2
  reloadAndSpyXHR

  switchToLine
  await "Error: line options saved but not permanently" assertion
  successMsg "Ok, line options saved"

assertSelected :: Check Element -> String -> Check Boolean
assertSelected getSelect value =
  map (eq value) $ getSelect >>= getSelectValue

checkOptionSaveBarOrPie :: Check Unit -> String -> Check Unit
checkOptionSaveBarOrPie switcher msg = withFlatVizChart do
  switcher
  category <- getCategoryInput
  measure <- getMeasureOneInput
  seriesOne <- getSeriesOneInput
  seriesTwo <- getSeriesTwoInput

  valueCategory <- filterAndGetValue category seriesOne "category"
  valueSeriesOne <- filterAndGetValue seriesOne seriesTwo "series"
  valueSeriesTwo <- getRandomOption seriesTwo
  valueMeasure <- getRandomOption measure

  fillSelect seriesTwo valueSeriesTwo
  fillSelect measure valueMeasure

  let assertion = do
        c <- assertSelected getCategoryInput valueCategory
        m <- assertSelected getMeasureOneInput valueMeasure
        s1 <- assertSelected getSeriesOneInput valueSeriesOne
        s2 <- assertSelected getSeriesTwoInput valueSeriesTwo
        pure $ c && m && s1 && s2

  switchToBar
  switcher
  await ("Error: Hasn't been saved (" <> msg <> ")") assertion

  switchToLine
  switcher
  await ("Error: Hasn't been saved (" <> msg <> ")") assertion

  switchToPie
  switcher
  await ("Error: Hasn't been saved (" <> msg <> ")") assertion

  successMsg $ "Ok, chart options have been saved (" <> msg <> ")"

  waitTime $ SDConfig.autosaveTick * 2
  reloadAndSpyXHR

  switcher
  getCurrentEditor
  await "Error: saved, but not permanently" assertion
  successMsg $ "Ok, chart options have been saved permanently (" <> msg <> ")"

checkTrashingVizCell :: Check Unit
checkTrashingVizCell = withFlatVizChart do
  config <- getConfig
  vizCell <- getCell 1
  byCss config.cell.trash
    >>= childExact vizCell
    >>= sequence <<< leftClick

  checkThatOneCellRemaining
  waitTime $ SDConfig.autosaveTick * 2
  reloadAndSpyXHR
  checkThatOneCellRemaining
  successMsg "Ok, trash button works"
  where
  checkThatOneCellRemaining =
    await "Error: cell has not been deleted" do
      map (eq one <<< length) getCells

checkRunRefreshEmbed :: Check Unit
checkRunRefreshEmbed = withFlatVizChart do
  switchToPie
  category <- getCategoryInput
  measure <- getMeasureOneInput
  seriesOne <- getSeriesOneInput
  seriesTwo <- getSeriesTwoInput

  valueCategory <- filterAndGetValue category seriesOne "category"
  valueSeriesOne <- filterAndGetValue seriesOne seriesTwo "series"
  valueSeriesTwo <- getRandomOption seriesTwo
  valueMeasure <- getRandomOption measure

  fillSelect seriesTwo valueSeriesTwo
  fillSelect measure valueMeasure

  saveInitialScreenshot

  findPlayButton >>= sequence <<< leftClick

  await "Error: chart has not been rendered (pie)"
    $ checkScreenshotsDiffer
  C.checkEmbedButton

  saveInitialScreenshot
  switchToBar

  categoryBar <- getCategoryInput
  measureBar <- getMeasureOneInput
  valueCategoryBar <- getRandomOption categoryBar
  valueMeasureBar <- getRandomOption measureBar
  fillSelect categoryBar valueCategoryBar
  fillSelect measureBar valueMeasureBar

  await "Error: chart has not been rendered (bar)"
    $ checkScreenshotsDiffer
  C.checkEmbedButton

  switchToLine

  saveInitialScreenshot
  dimension <- getDimensionInput
  measureLine <- getMeasureOneInput
  valueDimension <- getRandomOption categoryBar
  valueMeasureLine <- getRandomOption measureBar
  fillSelect dimension valueDimension
  fillSelect measureLine valueMeasureLine

  await "Error: chart has not been rendered (line)"
    $ checkScreenshotsDiffer
  C.checkEmbedButton

  successMsg "Ok, embed/run works"

checkScreenshotsDiffer :: Check Boolean
checkScreenshotsDiffer = do
  config <- getConfig
  if config.collectingScreenshots
    then pure true
    else do
    config <- getConfig
    saveActualScreenshot
    map not $ screenshotsEqual config.screenshot.initial

checkElementScreensDiffer :: Check Element -> Check Boolean
checkElementScreensDiffer checkEl = do
  config <- getConfig
  checkEl >>= actualElementScreenshot
  map not $ screenshotsEqual config.screenshot.initial

checkAggregation :: Check Unit
checkAggregation = withFlatVizOneOption do
  aggConfig <- map (_.screenshot >>> _.aggregation) getConfig

  switchToLine
  traverse_ (checkOneAggregation aggConfig.line "line") tpls

  switchToBar
  traverse_ (checkOneAggregation aggConfig.bar "bar") tpls

  switchToPie
  traverse_ (checkOneAggregation aggConfig.pie "pie") tpls
  successMsg "Ok, aggregation works"
  where
  tpls :: Array (Tuple (Check Unit) String)
  tpls = [ Tuple setProductAggregation "product"
         , Tuple setSumAggregation "sum"
         , Tuple setMinAggregation "min"
         , Tuple setMaxAggregation "max"
         , Tuple setAverageAggregation "average"
         ]

  checkOneAggregation :: String -> String -> Tuple (Check Unit) String -> Check Unit
  checkOneAggregation pathToExpected chartMark (Tuple setAgg aggMark) = do
    setAgg
    await ("Error: aggregation (" <> chartMark <> " - " <> aggMark <> ")") do
      actualCanvasScreenshot
      screenshotsEqual $ pathToExpected <> aggMark <> ".png"

setAggregation :: String -> Check Unit
setAggregation val = do
  sel <- getAggregationSelect
  option <- getAggregationOption sel val
  sequence do
    leftClick sel
    leftClick option
    sendEnter

setSumAggregation :: Check Unit
setSumAggregation =
  getConfig >>= _.vizAggregation >>> _.sum >>> setAggregation

setProductAggregation :: Check Unit
setProductAggregation =
  getConfig >>= _.vizAggregation >>> _.product >>> setAggregation

setMinAggregation :: Check Unit
setMinAggregation =
  getConfig >>= _.vizAggregation >>> _.min >>> setAggregation

setMaxAggregation :: Check Unit
setMaxAggregation =
  getConfig >>= _.vizAggregation >>> _.max >>> setAggregation

setAverageAggregation :: Check Unit
setAverageAggregation =
  getConfig >>= _.vizAggregation >>> _.average >>> setAggregation

checkCharts :: Check Unit
checkCharts = withFlatVizChart do
  config <- map (_.screenshot >>> _.charts) getConfig
  toSet <- map (_.vizOptions >>> _.set) getConfig
  switchToPie
  barOrPie "pie" config.pie

  switchToBar
  barOrPie "bar" config.bar

  switchToLine
  dimension <- getDimensionInput
  measureOne <- getMeasureOneInput
  measureTwo <- getMeasureTwoInput
  seriesOne <- getSeriesOneInput
  seriesTwo <- getSeriesTwoInput
  fillSelect dimension toSet.dimension
  fillSelect measureOne toSet.measureOne
  await "Error: incorrect chart (line - category)" do
    actualCanvasScreenshot
    screenshotsEqual $ config.line <> "category.png"
  fillSelect measureTwo toSet.measureTwo
  await "Error: incorrect chart (line - measure)" do
    actualCanvasScreenshot
    screenshotsEqual $ config.line <> "measure.png"
  fillSelect seriesOne toSet.seriesOne
  await "Error: incorrect chart (line - series1)" do
    actualCanvasScreenshot
    screenshotsEqual $ config.line <> "series1.png"
  fillSelect seriesTwo toSet.seriesTwo
  await "Error: incorrect chart (line - series2)" do
    actualCanvasScreenshot
    screenshotsEqual $ config.line <> "series2.png"

  successMsg "Ok, charts are correct"
  where
  barOrPie :: String -> String -> Check Unit
  barOrPie label basePath = do
    toSet <- map (_.vizOptions >>> _.set) getConfig
    category <- getCategoryInput
    measure <- getMeasureOneInput
    seriesOne <- getSeriesOneInput
    seriesTwo <- getSeriesTwoInput

    fillSelect category toSet.category
    fillSelect measure toSet.measureOne
    await ("Error: incorrect chart (" <> label <> ") - category)") do
      actualCanvasScreenshot
      screenshotsEqual $ basePath <> "category.png"

    fillSelect seriesOne toSet.seriesOne
    await ("Error: incorrect chart (" <> label <> ") - series1)") do
      actualCanvasScreenshot
      screenshotsEqual $ basePath <> "series1.png"

    fillSelect seriesTwo toSet.seriesTwo
    await ("Error: incorrect chart (" <> label <> ") - series2)") do
      actualCanvasScreenshot
      screenshotsEqual $ basePath <> "series2.png"

actualCanvasScreenshot :: Check Unit
actualCanvasScreenshot = do
  config <- getConfig
  if config.collectingScreenshots
    then do
    waitTime 5000
    waitCanvas >>= flip elementScreenshot config.tmpFileForScreenshots
    else
    waitCanvas >>= actualElementScreenshot

test :: Check Unit
test = do
  config <- getConfig

  sectionMsg "check next viz cell (search)"
  withSmallZipsSearchedAll $ checkNextVizCell

  sectionMsg "check next viz cell (explore)"
  withSmallZipsOpened $ checkNextVizCell

  sectionMsg "check next viz cell (query)"
  withSmallZipsQueriedAll $ checkNextVizCell

  sectionMsg "check set height/width"
  checkSetHeightWidth

  sectionMsg "check hide/show"
  withSmallZipsAllChart do
    config <- getConfig
    cell <- getCell 1
    C.checkHideShowCell cell config.cell.vizEditor

  sectionMsg "check switchers"
  checkSwitchers

  sectionMsg "alert when no available types"
  checkAlert

  sectionMsg "check availbale select options"
  checkOptions

  sectionMsg "check option filters"
  checkOptionUniqueness

  sectionMsg "check option auto select"
  checkOptionAutoSelect

  sectionMsg "check option save"
  checkOptionSave

  sectionMsg "trash viz cell"
  checkTrashingVizCell

  sectionMsg "run/refresh/embed"
  checkRunRefreshEmbed

  sectionMsg "aggregation"
  checkAggregation

  sectionMsg "check charts"
  checkCharts

{-
Copyright 2015 SlamData, Inc.

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

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

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

module Test.Selenium.Notebook.Viz (test, actualCanvasScreenshot) where

import Prelude

import Control.Monad.Eff.Random (randomInt)
import Control.Monad.Eff.Class (liftEff)
import Data.List (length, List(..), fromList, filter, null, (!!))
import Data.Maybe (isJust, isNothing, Maybe(..), maybe, fromMaybe)
import Data.Maybe.Unsafe (fromJust)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..))
import Data.Foldable (foldl, traverse_)
import Data.Monoid (mempty)
import Data.Function (on)
import qualified Data.Set as S

import Selenium.Types
import Selenium.Monad
import Selenium.ActionSequence hiding (sequence)

import Test.Config
import Test.Selenium.ActionSequence (selectAll, sendDelete, sendEnter)
import Test.Selenium.Monad
import Test.Selenium.Log
import Test.Selenium.Common
import Test.Selenium.Notebook.Getters
import Test.Selenium.Notebook.Contexts
import qualified Test.Selenium.Notebook.Common as C
import qualified Config as SDConfig

import Utils (s2i)
import Utils.Random

checkNextVizCell :: Check Unit
checkNextVizCell = do
  waitNextVizCell >>= sequence <<< leftClick
  await "Viz cell has not been created"
    $ map (eq 2 <<< length) getCells
  successMsg "Ok, next cell viz works"

checkSetHeightWidth :: Check Unit
checkSetHeightWidth = withSmallZipsAllChart do
  widthInput <- waitVizWidthInput
  heightInput <- waitVizHeightInput

  w <- liftEff $ randomInt 100 400
  h <- liftEff $ randomInt 100 400

  modifierKey <- getModifierKey

  sequence do
    leftClick widthInput
    selectAll modifierKey
    sendDelete
    sendKeys $ show w

    leftClick heightInput
    selectAll modifierKey
    sendDelete
    sendKeys $ show h

  await "Dimensions has not been setted" do
    dims <- getDims
    pure
       $ dims.w == pure w
      && dims.h == pure h
  successMsg "Ok, dimensions setted"

  where
  getDims = do
    canvas <- waitCanvas
    { w: _, h: _ }
      <$> (s2i <$> getCssValue canvas "width")
      <*> (s2i <$> getCssValue canvas "height")

switchToPie :: Check Unit
switchToPie = do
  getChartSwitchers >>= sequence <<< leftClick <<< _.pie
  await "Pie switch doesn't work" pieShown

switchToLine :: Check Unit
switchToLine = do
 getChartSwitchers >>= sequence <<< leftClick <<< _.line
 await "Line switch doesn't work" lineShown

switchToBar :: Check Unit
switchToBar = do
 getChartSwitchers >>= sequence <<< leftClick <<< _.bar
 await "Bar switch doesn't work" barShown

checkSwitchers :: Check Unit
checkSwitchers = withFlatVizChart do
  pieDisplayed <- pieShown
  if pieDisplayed
    then successMsg "Ok, initial chart type -- pie"
    else errorMsg "Incorrect initial chart type"

  switchToLine
  successMsg "pie -> line"

  switchToBar
  successMsg "line -> bar"

  switchToPie
  successMsg "bar -> pie"

  switchToBar
  successMsg "pie -> bar"

  switchToLine
  successMsg "bar -> line"

  switchToPie
  successMsg "line -> pie"

checkAlert :: Check Unit
checkAlert = withFlatVizMeasures do
  config <- getConfig
  tryRepeatedlyTo $ byCss config.vizSelectors.alert >>= findExact
  successMsg "ok, alert found"

checkOptions :: Check Unit
checkOptions = withFlatVizChart do
  config <- getConfig
  switchToPie
  await "incorrect pie options"
    $ map (eq config.vizOptions.flatVizAll.pie) getCurrentChartOptions
  successMsg "Ok, pie chart options are correct"

  switchToLine
  await "incorrect line options"
    $ map (eq config.vizOptions.flatVizAll.line) getCurrentChartOptions
  successMsg "Ok, line chart options are correct"

  switchToBar
  await "incorrect bar options"
    $ map (eq config.vizOptions.flatVizAll.bar) getCurrentChartOptions

  successMsg "Ok, bar chart options are correct"

-- Don't know how to name it better.
-- This test will look if after switching options in
-- category -> series1 -> series2
-- measure1 -> measure2
-- dimension -> series1 -> series2
-- are filtered
checkOptionUniqueness :: Check Unit
checkOptionUniqueness = withFlatVizChart do
  config <- getConfig

  sectionMsg "check pie uniqueness"
  switchToPie
  await "incorrect pie options"
    $ map (eq config.vizOptions.flatVizAll.pie) getCurrentChartOptions
  checkCategoryUniqueness getCategoryInput getSeriesOneInput getSeriesTwoInput

  sectionMsg "check bar uniqueness"
  switchToBar
  await "incorrect bar options"
    $ map (eq config.vizOptions.flatVizAll.bar) getCurrentChartOptions

  checkCategoryUniqueness getCategoryInput getSeriesOneInput getSeriesTwoInput

  sectionMsg "check line uniqueness"
  switchToLine
  await "incorrec line options"
    $ map (eq config.vizOptions.flatVizAll.line) getCurrentChartOptions

  checkCategoryUniqueness getDimensionInput getSeriesOneInput getSeriesTwoInput
  checkMeasureUniqueness

checkMeasureUniqueness :: Check Unit
checkMeasureUniqueness = do
  config <- getConfig
  mOne <- getMeasureOneInput
  mTwo <- getMeasureTwoInput

  toSelectOne <- filterAndGetValue mOne mTwo "measures"
  toSelectTwo <- getRandomOption mTwo

  fillSelect mTwo toSelectTwo
  fillSelect mOne toSelectTwo
  await "Options has not been dropped"
    $ map (/= toSelectTwo) $ getSelectValue mTwo

  fillSelect mTwo toSelectTwo
  fillSelect mOne config.vizOptions.clearSelection
  await "Option should be disabled"
    $ map not $ isEnabled mTwo
  successMsg "Ok, measure uniqueness"

checkCategoryUniqueness :: Check Element -> Check Element -> Check Element -> Check Unit
checkCategoryUniqueness catM serOneM serTwoM = do
  config <- getConfig
  cat <- catM
  seriesOne <- serOneM
  seriesTwo <- serTwoM

  toSelectCat <- filterAndGetValue cat seriesOne "category"
  toSelectSerOne <- filterAndGetValue seriesOne seriesTwo "series one"

  toSelectSerTwo <- getRandomOption seriesTwo
  fillSelect seriesTwo toSelectSerTwo
  fillSelect seriesOne toSelectSerTwo
  await "Options has not been dropped (one -> two)"
    $ map (/= toSelectSerTwo) $ getSelectValue seriesTwo
  successMsg "Ok, select value dropped"

  fillSelect cat toSelectSerTwo
  await "Options has not been dropped (root -> one)"
    $ map (/= toSelectSerOne) $ getSelectValue seriesOne
  successMsg "Ok, dependent selects values are dropped"

  fillSelect cat toSelectCat
  fillSelect seriesOne toSelectSerOne
  fillSelect seriesTwo toSelectSerTwo
  fillSelect cat toSelectSerTwo
  await "Optoins has not been dropped (root -> two)"
    $ map (/= toSelectSerTwo) $ getSelectValue seriesTwo

  fillSelect cat toSelectCat
  fillSelect seriesOne toSelectSerOne
  fillSelect seriesTwo toSelectSerTwo
  fillSelect seriesOne config.vizOptions.clearSelection
  await "Select should be disabled (series two)"
    $ map not $ isEnabled seriesTwo

  fillSelect seriesOne toSelectSerOne
  fillSelect seriesTwo toSelectSerTwo
  fillSelect cat config.vizOptions.clearSelection
  await "Select should be disabled (series one, series two)" do
    one <- isEnabled seriesOne
    two <- isEnabled seriesTwo
    pure $ not one && not two
  successMsg "Ok, dependent selects are disabled"

  successMsg "OK, category uniqueness"

filterAndGetValue :: Element -> Element -> String -> Check String
filterAndGetValue parent child msg = do
  toSelect <- getRandomOption parent
  fillSelect parent toSelect
  await ("Options are not filtered (" <> msg <> ")") do
    parentOptions <- optionTxts parent
    childOptions <- optionTxts child
    pure $ on eq S.fromList parentOptions (Cons toSelect childOptions)
  successMsg $ "Ok, select filtering works (" <> msg <> ")"
  pure toSelect

getSelectValue :: Element -> Check String
getSelectValue el = do
  val <- getAttribute el "value"
  getOptions (pure el) >>= foldl (foldFn val) (pure mempty)
  where
  foldFn :: String -> Check String -> Element -> Check String
  foldFn selectedVal mStr el = do
    val <- getAttribute el "value"
    if val == selectedVal
      then getInnerHtml el
      else mStr

getRandomOption :: Element -> Check String
getRandomOption el = do
  config <- getConfig
  await "there is no options"
    $ map ((> 2) <<< length) $ getOptions $ pure el
  getOptions (pure el)
    >>= traverse getInnerHtml
    >>= randomInM <<< filter (not <<< eq config.vizOptions.clearSelection)
    >>= \x -> if x == mempty
              then errorMsg "empty option list"
              else pure x
fillSelect :: Element -> String -> Check Unit
fillSelect el txt =
  sequence do
    leftClick el
    sendKeys txt
    sendEnter

fillSelectRandom :: Element -> Check Unit
fillSelectRandom el = do
  opt <- getRandomOption el
  fillSelect el opt

optionTxts :: Element -> Check (List String)
optionTxts el = getOptions (pure el) >>= traverse getInnerHtml

checkOptionAutoSelect :: Check Unit
checkOptionAutoSelect = do
  config <- getConfig
  withFlatVizOneOption do
    switchToPie
    waitPieOrBarFullyDisabled "bar"
    pOpts <- getCurrentChartOptions
    assertBoolean "Error: incorrect pie options"
      $ pOpts == config.vizOptions.flatVizOneOption.pie

    switchToBar
    waitPieOrBarFullyDisabled "pie"
    bOpts <- getCurrentChartOptions
    assertBoolean "Error: incorrect bar options"
      $ bOpts == config.vizOptions.flatVizOneOption.bar

    switchToLine
    waitForDisabled "line"
      $ [ getSeriesOneInput
        , getSeriesTwoInput
        , getDimensionInput
        , getMeasureOneInput
        , getMeasureTwoInput
        ]
    lOpts <- getCurrentChartOptions
    assertBoolean "Error: incorrect line options"
      $ lOpts == config.vizOptions.flatVizOneOption.line
  successMsg "Ok, options are correct when there is one series and one measure"
  where
  waitForDisabled msg getters =
    await ("Error: Incorrect states of selects, they must be disabled (" <> msg <> ")")
    $ foldl (\b x -> conj <$> b <*> (map not $ x >>= isEnabled)) (pure true)
    $ getters
  waitPieOrBarFullyDisabled msg =
    waitForDisabled msg
    $ [ getSeriesOneInput
      , getSeriesTwoInput
      , getMeasureOneInput
      , getCategoryInput
      ]

checkOptionSave :: Check Unit
checkOptionSave = do
  checkOptionSaveBarOrPie switchToBar "bar"
  checkOptionSaveBarOrPie switchToPie "pie"
  checkOptionSaveLine

checkOptionSaveLine :: Check Unit
checkOptionSaveLine = withFlatVizChart do
  switchToLine
  dimension <- getDimensionInput
  measureOne <- getMeasureOneInput
  measureTwo <- getMeasureTwoInput
  seriesOne <- getSeriesOneInput
  seriesTwo <- getSeriesTwoInput

  valueDimension <- filterAndGetValue dimension seriesOne "dimension"
  valueSeriesOne <- filterAndGetValue seriesOne seriesTwo "series"
  valueSeriesTwo <- getRandomOption seriesTwo
  fillSelect seriesTwo valueSeriesTwo
  valueMeasureOne <- filterAndGetValue measureOne measureTwo "measure"
  valueMeasureTwo <- getRandomOption measureTwo
  fillSelect measureTwo valueMeasureTwo

  let assertion = do
        d <- assertSelected getDimensionInput valueDimension
        m1 <- assertSelected getMeasureOneInput valueMeasureOne
        m2 <- assertSelected getMeasureTwoInput valueMeasureTwo
        s1 <- assertSelected getSeriesOneInput valueSeriesOne
        s2 <- assertSelected getSeriesTwoInput valueSeriesTwo
        pure $ d && m1 && m2 && s1 && s2

  switchToPie
  switchToLine
  await "Error: line options have not been saved" assertion

  switchToBar
  switchToLine
  await "Error: line options have not been saved" assertion

  waitTime $ SDConfig.autosaveTick * 2
  reloadAndSpyXHR

  switchToLine
  await "Error: line options saved but not permanently" assertion
  successMsg "Ok, line options saved"

assertSelected :: Check Element -> String -> Check Boolean
assertSelected getSelect value =
  map (eq value) $ getSelect >>= getSelectValue

checkOptionSaveBarOrPie :: Check Unit -> String -> Check Unit
checkOptionSaveBarOrPie switcher msg = withFlatVizChart do
  switcher
  category <- getCategoryInput
  measure <- getMeasureOneInput
  seriesOne <- getSeriesOneInput
  seriesTwo <- getSeriesTwoInput

  valueCategory <- filterAndGetValue category seriesOne "category"
  valueSeriesOne <- filterAndGetValue seriesOne seriesTwo "series"
  valueSeriesTwo <- getRandomOption seriesTwo
  valueMeasure <- getRandomOption measure

  fillSelect seriesTwo valueSeriesTwo
  fillSelect measure valueMeasure

  let assertion = do
        c <- assertSelected getCategoryInput valueCategory
        m <- assertSelected getMeasureOneInput valueMeasure
        s1 <- assertSelected getSeriesOneInput valueSeriesOne
        s2 <- assertSelected getSeriesTwoInput valueSeriesTwo
        pure $ c && m && s1 && s2

  switchToBar
  switcher
  await ("Error: Hasn't been saved (" <> msg <> ")") assertion

  switchToLine
  switcher
  await ("Error: Hasn't been saved (" <> msg <> ")") assertion

  switchToPie
  switcher
  await ("Error: Hasn't been saved (" <> msg <> ")") assertion

  successMsg $ "Ok, chart options have been saved (" <> msg <> ")"

  waitTime $ SDConfig.autosaveTick * 2
  reloadAndSpyXHR

  switcher
  getCurrentEditor
  await "Error: saved, but not permanently" assertion
  successMsg $ "Ok, chart options have been saved permanently (" <> msg <> ")"

checkTrashingVizCell :: Check Unit
checkTrashingVizCell = withFlatVizChart do
  config <- getConfig
  vizCell <- getCell 1
  byCss config.cell.trash
    >>= childExact vizCell
    >>= sequence <<< leftClick

  checkThatOneCellRemaining
  waitTime $ SDConfig.autosaveTick * 2
  reloadAndSpyXHR
  checkThatOneCellRemaining
  successMsg "Ok, trash button works"
  where
  checkThatOneCellRemaining =
    await "Error: cell has not been deleted" do
      map (eq one <<< length) getCells

checkRunRefreshEmbed :: Check Unit
checkRunRefreshEmbed = withFlatVizChart do
  switchToPie
  category <- getCategoryInput
  measure <- getMeasureOneInput
  seriesOne <- getSeriesOneInput
  seriesTwo <- getSeriesTwoInput

  valueCategory <- filterAndGetValue category seriesOne "category"
  valueSeriesOne <- filterAndGetValue seriesOne seriesTwo "series"
  valueSeriesTwo <- getRandomOption seriesTwo
  valueMeasure <- getRandomOption measure

  fillSelect seriesTwo valueSeriesTwo
  fillSelect measure valueMeasure

  saveInitialScreenshot

  findPlayButton >>= sequence <<< leftClick

  await "Error: chart has not been rendered (pie)"
    $ checkScreenshotsDiffer
  C.checkEmbedButton

  saveInitialScreenshot
  switchToBar

  categoryBar <- getCategoryInput
  measureBar <- getMeasureOneInput
  valueCategoryBar <- getRandomOption categoryBar
  valueMeasureBar <- getRandomOption measureBar
  fillSelect categoryBar valueCategoryBar
  fillSelect measureBar valueMeasureBar

  await "Error: chart has not been rendered (bar)"
    $ checkScreenshotsDiffer
  C.checkEmbedButton

  switchToLine

  saveInitialScreenshot
  dimension <- getDimensionInput
  measureLine <- getMeasureOneInput
  valueDimension <- getRandomOption categoryBar
  valueMeasureLine <- getRandomOption measureBar
  fillSelect dimension valueDimension
  fillSelect measureLine valueMeasureLine

  await "Error: chart has not been rendered (line)"
    $ checkScreenshotsDiffer
  C.checkEmbedButton

  successMsg "Ok, embed/run works"

checkScreenshotsDiffer :: Check Boolean
checkScreenshotsDiffer = do
  config <- getConfig
  if config.collectingScreenshots
    then pure true
    else do
    config <- getConfig
    saveActualScreenshot
    map not $ screenshotsEqual config.screenshot.initial

checkElementScreensDiffer :: Check Element -> Check Boolean
checkElementScreensDiffer checkEl = do
  config <- getConfig
  checkEl >>= actualElementScreenshot
  map not $ screenshotsEqual config.screenshot.initial

checkAggregation :: Check Unit
checkAggregation = withFlatVizOneOption do
  aggConfig <- map (_.screenshot >>> _.aggregation) getConfig

  switchToLine
  traverse_ (checkOneAggregation aggConfig.line "line") tpls

  switchToBar
  traverse_ (checkOneAggregation aggConfig.bar "bar") tpls

  switchToPie
  traverse_ (checkOneAggregation aggConfig.pie "pie") tpls
  successMsg "Ok, aggregation works"
  where
  tpls :: Array (Tuple (Check Unit) String)
  tpls = [ Tuple setProductAggregation "product"
         , Tuple setSumAggregation "sum"
         , Tuple setMinAggregation "min"
         , Tuple setMaxAggregation "max"
         , Tuple setAverageAggregation "average"
         ]

  checkOneAggregation :: String -> String -> Tuple (Check Unit) String -> Check Unit
  checkOneAggregation pathToExpected chartMark (Tuple setAgg aggMark) = do
    setAgg
    await ("Error: aggregation (" <> chartMark <> " - " <> aggMark <> ")") do
      actualCanvasScreenshot
      screenshotsEqual $ pathToExpected <> aggMark <> ".png"

setAggregation :: String -> Check Unit
setAggregation val = do
  sel <- getAggregationSelect
  option <- getAggregationOption sel val
  sequence do
    leftClick sel
    leftClick option
    sendEnter

setSumAggregation :: Check Unit
setSumAggregation =
  getConfig >>= _.vizAggregation >>> _.sum >>> setAggregation

setProductAggregation :: Check Unit
setProductAggregation =
  getConfig >>= _.vizAggregation >>> _.product >>> setAggregation

setMinAggregation :: Check Unit
setMinAggregation =
  getConfig >>= _.vizAggregation >>> _.min >>> setAggregation

setMaxAggregation :: Check Unit
setMaxAggregation =
  getConfig >>= _.vizAggregation >>> _.max >>> setAggregation

setAverageAggregation :: Check Unit
setAverageAggregation =
  getConfig >>= _.vizAggregation >>> _.average >>> setAggregation

checkCharts :: Check Unit
checkCharts = withFlatVizChart do
  config <- map (_.screenshot >>> _.charts) getConfig
  toSet <- map (_.vizOptions >>> _.set) getConfig
  switchToPie
  barOrPie "pie" config.pie

  switchToBar
  barOrPie "bar" config.bar

  switchToLine
  dimension <- getDimensionInput
  measureOne <- getMeasureOneInput
  measureTwo <- getMeasureTwoInput
  seriesOne <- getSeriesOneInput
  seriesTwo <- getSeriesTwoInput
  fillSelect dimension toSet.dimension
  fillSelect measureOne toSet.measureOne
  await "Error: incorrect chart (line - category)" do
    actualCanvasScreenshot
    screenshotsEqual $ config.line <> "category.png"
  fillSelect measureTwo toSet.measureTwo
  await "Error: incorrect chart (line - measure)" do
    actualCanvasScreenshot
    screenshotsEqual $ config.line <> "measure.png"
  fillSelect seriesOne toSet.seriesOne
  await "Error: incorrect chart (line - series1)" do
    actualCanvasScreenshot
    screenshotsEqual $ config.line <> "series1.png"
  fillSelect seriesTwo toSet.seriesTwo
  await "Error: incorrect chart (line - series2)" do
    actualCanvasScreenshot
    screenshotsEqual $ config.line <> "series2.png"

  successMsg "Ok, charts are correct"
  where
  barOrPie :: String -> String -> Check Unit
  barOrPie label basePath = do
    toSet <- map (_.vizOptions >>> _.set) getConfig
    category <- getCategoryInput
    measure <- getMeasureOneInput
    seriesOne <- getSeriesOneInput
    seriesTwo <- getSeriesTwoInput

    fillSelect category toSet.category
    fillSelect measure toSet.measureOne
    await ("Error: incorrect chart (" <> label <> ") - category)") do
      actualCanvasScreenshot
      screenshotsEqual $ basePath <> "category.png"

    fillSelect seriesOne toSet.seriesOne
    await ("Error: incorrect chart (" <> label <> ") - series1)") do
      actualCanvasScreenshot
      screenshotsEqual $ basePath <> "series1.png"

    fillSelect seriesTwo toSet.seriesTwo
    await ("Error: incorrect chart (" <> label <> ") - series2)") do
      actualCanvasScreenshot
      screenshotsEqual $ basePath <> "series2.png"

actualCanvasScreenshot :: Check Unit
actualCanvasScreenshot = do
  config <- getConfig
  if config.collectingScreenshots
    then do
    waitTime 5000
    waitCanvas >>= flip elementScreenshot config.tmpFileForScreenshots
    else
    waitCanvas >>= actualElementScreenshot

test :: Check Unit
test = do
  config <- getConfig

  sectionMsg "check next viz cell (search)"
  withSmallZipsSearchedAll $ checkNextVizCell

  sectionMsg "check next viz cell (explore)"
  withSmallZipsOpened $ checkNextVizCell

  sectionMsg "check next viz cell (query)"
  withSmallZipsQueriedAll $ checkNextVizCell

  sectionMsg "check set height/width"
  checkSetHeightWidth

  sectionMsg "check hide/show"
  withSmallZipsAllChart do
    config <- getConfig
    cell <- getCell 1
    C.checkHideShowCell cell config.cell.vizEditor

  sectionMsg "check switchers"
  checkSwitchers

  sectionMsg "alert when no available types"
  checkAlert

  sectionMsg "check availbale select options"
  checkOptions

  sectionMsg "check option filters"
  checkOptionUniqueness

  sectionMsg "check option auto select"
  checkOptionAutoSelect

  --sectionMsg "check option save"
  --checkOptionSave

  sectionMsg "trash viz cell"
  checkTrashingVizCell

  sectionMsg "run/refresh/embed"
  checkRunRefreshEmbed

  sectionMsg "aggregation"
  checkAggregation

  sectionMsg "check charts"
  checkCharts


clean up

clean up

module Sammy
(route, redirect, bindEvent,trigger,params,sammy,runApp,get,put,post,del, SammyCtx(..), Sammy(..),SammyApp(..),Path(..))
where

import Control.Monad.Eff

foreign import data SammyCtx :: *
foreign import data SammyApp :: *
foreign import data Sammy :: !

type Path = String

foreign import sammy
"""function sammy(selector){
     return function() {
       return Sammy(selector, function(app){
         return app;
       });
     };
   }""":: forall a eff. String -> Eff (app :: Sammy | eff) SammyApp

foreign import runApp
"""function runApp(app){
     return function(route){
       return function (){
         app.run(route);
       };
     };
   }""" :: forall eff. SammyApp -> String -> Eff (app :: Sammy | eff) Unit

foreign import route
"""function route(smy){
    return function(verb){
      return function(path){
        return function(fn){
          return function(){
            smy.route(verb,path,function(s){
              fn(s)();
            });
          };
        };
      };
    };
  }""":: forall a eff. SammyApp -> String -> Path -> (SammyCtx -> Eff (app :: Sammy | eff) a) -> Eff (app :: Sammy | eff) a

get :: forall a eff. SammyApp -> Path -> (SammyCtx -> Eff (app :: Sammy | eff) a) -> Eff (app :: Sammy | eff) a
get app path fn = route app "get" path fn

post :: forall a eff. SammyApp -> Path -> (SammyCtx -> Eff (app :: Sammy | eff) a) -> Eff (app :: Sammy | eff) a
post app path fn = route app "post" path fn

put :: forall a eff. SammyApp -> Path -> (SammyCtx -> Eff (app :: Sammy | eff) a) -> Eff (app :: Sammy | eff) a
put app path fn = route app "put" path fn

del :: forall a eff. SammyApp -> Path -> (SammyCtx -> Eff (app :: Sammy | eff) a) -> Eff (app :: Sammy | eff) a
del app path fn = route app "del" path fn

foreign import params
"""function params(smy){
     return function(paramName){
       return function(){
         var p = smy.params[paramName];
         if($.type(p) === 'string'){
           return [p];
         }else if($.type(p) === 'undefined'){
           return [];
         }else{
           return p;
         }
       };
     };
   }""" :: forall eff. SammyCtx -> String -> Eff (app :: Sammy | eff) [String]

foreign import trigger
"""function trigger(smy){
     return function(evt){
       return function(){
         smy.trigger(evt);
       };
     };
   }""" :: forall eff. SammyApp -> String -> Eff (app :: Sammy | eff) Unit

foreign import bindEvent
"""function bindEvent(smy){
     return function(evt){
       return function(fn){
         return function(){
           smy.bind(evt,function(s){
             fn(s)()
           });
         };
       };
     };
   }""" :: forall eff. SammyApp -> String -> (SammyCtx -> (Eff (app :: Sammy | eff) Unit)) ->  Eff (app :: Sammy | eff) Unit

foreign import redirect
"""function redirect(smy){
     return function(route){
       return function(){
         smy.redirect(route);
       };
     };
   }""" :: forall eff. SammyCtx -> String -> Eff (app :: Sammy | eff) Unit

module Sammy
(route, redirect, bindEvent,trigger,params,sammy,runApp,get,put,post,del, SammyCtx(..), Sammy(..),SammyApp(..))
where

import Control.Monad.Eff

foreign import data SammyCtx :: *
foreign import data SammyApp :: *
foreign import data Sammy :: !

foreign import sammy
"""function sammy(selector){
     return function() {
       return Sammy(selector, function(app){
         return app;
       });
     };
   }""":: forall a eff. String -> Eff (app :: Sammy | eff) SammyApp

foreign import runApp
"""function runApp(app){
     return function(route){
       return function (){
         app.run(route);
       };
     };
   }""" :: forall eff. SammyApp -> String -> Eff (app :: Sammy | eff) Unit

foreign import route
"""function route(smy){
    return function(verb){
      return function(path){
        return function(fn){
          return function(){
            smy.route(verb,path,function(s){
              fn(s)();
            });
          };
        };
      };
    };
  }""":: forall a eff. SammyApp -> String -> String -> (SammyCtx -> Eff (app :: Sammy | eff) a) -> Eff (app :: Sammy | eff) a

get :: forall a eff. SammyApp -> String -> (SammyCtx -> Eff (app :: Sammy | eff) a) -> Eff (app :: Sammy | eff) a
get app path fn = route app "get" path fn

post :: forall a eff. SammyApp -> String -> (SammyCtx -> Eff (app :: Sammy | eff) a) -> Eff (app :: Sammy | eff) a
post app path fn = route app "post" path fn

put :: forall a eff. SammyApp -> String -> (SammyCtx -> Eff (app :: Sammy | eff) a) -> Eff (app :: Sammy | eff) a
put app path fn = route app "put" path fn

del :: forall a eff. SammyApp -> String -> (SammyCtx -> Eff (app :: Sammy | eff) a) -> Eff (app :: Sammy | eff) a
del app path fn = route app "del" path fn

foreign import params
"""function params(smy){
     return function(paramName){
       return function(){
         var p = smy.params[paramName];
         if($.type(p) === 'string'){
           return [p];
         }else if($.type(p) === 'undefined'){
           return [];
         }else{
           return p;
         }
       };
     };
   }""" :: forall eff. SammyCtx -> String -> Eff (app :: Sammy | eff) [String]

foreign import trigger
"""function trigger(smy){
     return function(evt){
       return function(){
         smy.trigger(evt);
       };
     };
   }""" :: forall eff. SammyApp -> String -> Eff (app :: Sammy | eff) Unit

foreign import bindEvent
"""function bindEvent(smy){
     return function(evt){
       return function(fn){
         return function(){
           smy.bind(evt,function(s){
             fn(s)()
           });
         };
       };
     };
   }""" :: forall eff. SammyApp -> String -> (SammyCtx -> (Eff (app :: Sammy | eff) Unit)) ->  Eff (app :: Sammy | eff) Unit

foreign import redirect
"""function redirect(smy){
     return function(route){
       return function(){
         smy.redirect(route);
       };
     };
   }""" :: forall eff. SammyCtx -> String -> Eff (app :: Sammy | eff) Unit


Uncomment tests

Uncomment tests

module Test.Main where

import Prelude

import Test.Spec.Runner (run)
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Spec.ScannerSpec (scannerSpec)
import Test.Spec.UsageParserSpec (usageParserSpec)
import Test.Spec.DescParserSpec (descParserSpec)
import Test.Spec.GenSpec (genSpec)
import Test.Spec.GenTransSpec (genTransSpec)
import Test.Spec.SolverSpec (solverSpec)
import Test.Spec.DocoptSpec (docoptSpec)

main = run [consoleReporter] do
  scannerSpec     unit
  usageParserSpec unit
  descParserSpec  unit
  solverSpec      unit
  genSpec         unit
  genTransSpec    unit
  docoptSpec      unit

module Test.Main where

import Prelude

import Test.Spec.Runner (run)
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Spec.ScannerSpec (scannerSpec)
import Test.Spec.UsageParserSpec (usageParserSpec)
import Test.Spec.DescParserSpec (descParserSpec)
import Test.Spec.GenSpec (genSpec)
import Test.Spec.GenTransSpec (genTransSpec)
import Test.Spec.SolverSpec (solverSpec)
import Test.Spec.DocoptSpec (docoptSpec)

main = run [consoleReporter] do
  -- scannerSpec     unit
  -- usageParserSpec unit
  -- descParserSpec  unit
  -- solverSpec      unit
  -- genSpec         unit
  genTransSpec    unit
  -- docoptSpec      unit


Add a comment on absolute (Track) vs. relative (Passage) time.


Simplify JSCallback to only return Unit

Simplify JSCallback to only return Unit

module Node.FS.Async
  ( Callback (..)
  , rename
  , readFile
  , readTextFile
  , writeFile
  , writeTextFile
  , stat
  ) where

import Control.Monad.Eff
import Data.Either
import Data.Foreign
import Data.Function
import Data.Maybe
import Node.Buffer (Buffer(..))
import Node.Encoding
import Node.FS
import Node.FS.Stats
import Node.Path (FilePath())
import Global (Error(..))

type JSCallback a = Fn2 Foreign a Unit

foreign import runCallbackEff
  "function runCallbackEff (f) {\
  \  return f(); \
  \}" :: forall eff a. Eff eff a -> a

handleCallback :: forall eff a b. (Callback eff a) -> JSCallback a
handleCallback f = mkFn2 $ \err x -> runCallbackEff $ f case parseForeign read err of
  Left err -> Left $ "handleCallback failed: " ++ err
  Right (Just err') -> Left $ show (err' :: Error)
  Right Nothing -> Right x

foreign import fs "var fs = require('fs');" ::
  { rename :: Fn3 FilePath FilePath (JSCallback Unit) Unit
  , readFile :: forall a opts. Fn3 FilePath { | opts } (JSCallback a) Unit
  , writeFile :: forall a opts. Fn4 FilePath a { | opts } (JSCallback Unit) Unit
  , stat :: Fn2 FilePath (JSCallback StatsObj) Unit
  }

-- |
-- Type synonym for callback functions.
--
type Callback eff a = Either String a -> Eff eff Unit

-- |
-- Renames a file.
--
rename :: forall eff. FilePath
                   -> FilePath
                   -> Callback eff Unit
                   -> Eff (fs :: FS | eff) Unit

rename oldFile newFile cb = return $ runFn3
  fs.rename oldFile newFile (handleCallback cb)

-- |
-- Reads the entire contents of a file returning the result as a raw buffer.
--
readFile :: forall eff. FilePath
                     -> Callback eff Buffer
                     -> Eff (fs :: FS | eff) Unit

readFile file cb = return $ runFn3
  fs.readFile file {} (handleCallback cb)

-- |
-- Reads the entire contents of a text file with the specified encoding.
--
readTextFile :: forall eff. Encoding
                         -> FilePath
                         -> Callback eff String
                         -> Eff (fs :: FS | eff) Unit

readTextFile encoding file cb = return $ runFn3
  fs.readFile file { encoding: show encoding } (handleCallback cb)

-- |
-- Writes a buffer to a file.
--
writeFile :: forall eff. FilePath
                      -> Buffer
                      -> Callback eff Unit
                      -> Eff (fs :: FS | eff) Unit

writeFile file buff cb = return $ runFn4
  fs.writeFile file buff {} (handleCallback cb)

-- |
-- Writes text to a file using the specified encoding.
--
writeTextFile :: forall eff. Encoding
                          -> FilePath
                          -> String
                          -> Callback eff Unit
                          -> Eff (fs :: FS | eff) Unit

writeTextFile encoding file buff cb = return $ runFn4
  fs.writeFile file buff { encoding: show encoding } (handleCallback cb)

-- |
-- Gets file statistics.
--
stat :: forall eff. FilePath
                 -> Callback eff Stats
                 -> Eff (fs :: FS | eff) Unit

stat file cb = return $ runFn2
  fs.stat file (handleCallback $ cb <<< (<$>) Stats)

module Node.FS.Async
  ( Callback (..)
  , rename
  , readFile
  , readTextFile
  , writeFile
  , writeTextFile
  , stat
  ) where

import Control.Monad.Eff
import Data.Either
import Data.Foreign
import Data.Function
import Data.Maybe
import Node.Buffer (Buffer(..))
import Node.Encoding
import Node.FS
import Node.FS.Stats
import Node.Path (FilePath())
import Global (Error(..))

type JSCallback = Fn2 Foreign

foreign import runCallbackEff
  "function runCallbackEff (f) {\
  \  return f(); \
  \}" :: forall eff a. Eff eff a -> a

handleCallback :: forall eff a b. (Callback eff a) -> JSCallback a Unit
handleCallback f = mkFn2 $ \err x -> runCallbackEff $ f case parseForeign read err of
  Left err -> Left $ "handleCallback failed: " ++ err
  Right (Just err') -> Left $ show (err' :: Error)
  Right Nothing -> Right x

foreign import fs "var fs = require('fs');" ::
  { rename :: forall a. Fn3 FilePath FilePath (JSCallback Unit a) Unit
  , readFile :: forall a b opts. Fn3 FilePath { | opts } (JSCallback a b) Unit
  , writeFile :: forall a opts. Fn4 FilePath a { | opts } (JSCallback Unit Unit) Unit
  , stat :: forall a. Fn2 FilePath (JSCallback StatsObj a) Unit
  }

-- |
-- Type synonym for callback functions.
--
type Callback eff a = Either String a -> Eff eff Unit

-- |
-- Renames a file.
--
rename :: forall eff. FilePath
                   -> FilePath
                   -> Callback eff Unit
                   -> Eff (fs :: FS | eff) Unit

rename oldFile newFile cb = return $ runFn3
  fs.rename oldFile newFile (handleCallback cb)

-- |
-- Reads the entire contents of a file returning the result as a raw buffer.
--
readFile :: forall eff. FilePath
                     -> Callback eff Buffer
                     -> Eff (fs :: FS | eff) Unit

readFile file cb = return $ runFn3
  fs.readFile file {} (handleCallback cb)

-- |
-- Reads the entire contents of a text file with the specified encoding.
--
readTextFile :: forall eff. Encoding
                         -> FilePath
                         -> Callback eff String
                         -> Eff (fs :: FS | eff) Unit

readTextFile encoding file cb = return $ runFn3
  fs.readFile file { encoding: show encoding } (handleCallback cb)

-- |
-- Writes a buffer to a file.
--
writeFile :: forall eff. FilePath
                      -> Buffer
                      -> Callback eff Unit
                      -> Eff (fs :: FS | eff) Unit

writeFile file buff cb = return $ runFn4
  fs.writeFile file buff {} (handleCallback cb)

-- |
-- Writes text to a file using the specified encoding.
--
writeTextFile :: forall eff. Encoding
                          -> FilePath
                          -> String
                          -> Callback eff Unit
                          -> Eff (fs :: FS | eff) Unit

writeTextFile encoding file buff cb = return $ runFn4
  fs.writeFile file buff { encoding: show encoding } (handleCallback cb)

-- |
-- Gets file statistics.
--
stat :: forall eff. FilePath
                 -> Callback eff Stats
                 -> Eff (fs :: FS | eff) Unit

stat file cb = return $ runFn2
  fs.stat file (handleCallback $ cb <<< (<$>) Stats)


Make use of TestMaybe

Make use of TestMaybe

module Test.Data.Maybe where

import Data.Maybe
import Debug.Trace
import Control.Monad.Eff
import Test.QuickCheck
import Test.QuickCheck.Maybe
import Test.Classes

type Ty = Maybe Number

main = do

  let ty = Just 0

  trace "test equality"
  check1 $ \n -> Just n == Just n
  assert $ Nothing == Nothing :: Ty

  trace "test inequality"
  check1 $ \n -> Just n  /= Nothing
  check1 $ \n -> Nothing /= Just n
  check1 $ \n -> Just n  /= Just (n + 1)

  trace "test order"
  check2 $ \x y -> compare (Just x) (Just y) == compare x y
  check1 $ \x -> compare Nothing (Just x) == LT
  check1 $ \x -> compare (Just x) Nothing == GT
  check1 $ \x -> compare Nothing (Nothing :: Ty) == EQ

  trace "maybe should transform a value wrapped in a Just"
  check1 $ \n -> maybe 0 negate (Just n) == -n

  trace "maybe should return the default value when applied to Nothing"
  check1 $ \n -> maybe n id Nothing == n

  trace "isJust should return the appropriate value"
  assert $ isJust (Just {}) == true
  assert $ isJust Nothing == false

  trace "isNothing should return the appropriate value"
  assert $ isNothing Nothing == true
  assert $ isNothing (Just {}) == false

  let tty = TestMaybe (Just 0)

  trace "test functor laws"
  checkFunctor tty

  trace "test applicative laws"
  checkApplicative tty tty tty

  trace "test monad laws"
  checkMonad tty

assert :: Boolean -> QC {}
assert = quickCheck' 1

check1 :: (Number -> Boolean) -> QC {}
check1 = quickCheck

check2 :: (Number -> Number -> Boolean) -> QC {}
check2 = quickCheck

module Test.Data.Maybe where

import Data.Maybe
import Debug.Trace
import Control.Monad.Eff
import Test.QuickCheck
import Test.QuickCheck.Maybe
import Test.Classes

type Ty = Maybe Number

instance arbMaybe :: (Arbitrary a) => Arbitrary (Maybe a) where
  arbitrary = runTestMaybe <$> arbitrary

main = do

  let ty = Just 0

  trace "test equality"
  check1 $ \n -> Just n == Just n
  assert $ Nothing == Nothing :: Ty

  trace "test inequality"
  check1 $ \n -> Just n  /= Nothing
  check1 $ \n -> Nothing /= Just n
  check1 $ \n -> Just n  /= Just (n + 1)

  trace "test order"
  check2 $ \x y -> compare (Just x) (Just y) == compare x y
  check1 $ \x -> compare Nothing (Just x) == LT
  check1 $ \x -> compare (Just x) Nothing == GT
  check1 $ \x -> compare Nothing (Nothing :: Ty) == EQ

  trace "maybe should transform a value wrapped in a Just"
  check1 $ \n -> maybe 0 negate (Just n) == -n

  trace "maybe should return the default value when applied to Nothing"
  check1 $ \n -> maybe n id Nothing == n

  trace "isJust should return the appropriate value"
  assert $ isJust (Just {}) == true
  assert $ isJust Nothing == false

  trace "isNothing should return the appropriate value"
  assert $ isNothing Nothing == true
  assert $ isNothing (Just {}) == false

  trace "test functor laws"
  checkFunctor ty

  trace "test applicative laws"
  checkApplicative ty ty ty

  trace "test monad laws"
  checkMonad ty

assert :: Boolean -> QC {}
assert = quickCheck' 1

check1 :: (Number -> Boolean) -> QC {}
check1 = quickCheck

check2 :: (Number -> Number -> Boolean) -> QC {}
check2 = quickCheck

instance arbAToMaybeB :: (Arbitrary (a -> b)) => Arbitrary (a -> Maybe b) where
  arbitrary = do
    f <- arbitrary
    jn <- arbitrary
    return $ \x -> if jn then Just (f x) else Nothing


alert and disable button if not all (and at least one) fields are empty in auth section in mongodb mount dialog

{-
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.FileSystem.Dialog.Mount.MongoDB.Component
  ( comp
  , Query()
  , module SlamData.FileSystem.Dialog.Mount.Common.SettingsQuery
  , module SlamData.FileSystem.Dialog.Mount.MongoDB.Component.State
  ) where

import Prelude

import Control.Monad (when)
import Control.Monad.Aff (attempt)
import Control.Monad.Cont.Trans as Ct

import Data.Array ((..), length, null, filter)
import Data.Foldable as F
import Data.Functor (($>))
import Data.Functor.Aff (liftAff)
import Data.Identity as Id
import Data.Lens (TraversalP(), (^.), (.~))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe(..))
import Data.Path.Pathy (dir, (</>))
import Data.String.Regex as Rx

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

import Quasar.Aff as API
import Quasar.Auth as Auth

import SlamData.Effects (Slam())
import SlamData.FileSystem.Dialog.Mount.Common.Render
import SlamData.FileSystem.Dialog.Mount.Common.SettingsQuery
import SlamData.FileSystem.Dialog.Mount.MongoDB.Component.State
import SlamData.FileSystem.Resource (Mount(..))
import SlamData.Render.CSS as Rc

type Query = SettingsQuery State

comp :: Component State Query Slam
comp = component render eval

render :: State -> ComponentHTML Query
render state =
  H.div
    [ P.key "mount-mongodb"
    , P.class_ Rc.mountMongoDB
    ]
    [ section "Server(s)" [ hosts state ]
    , section "Authentication" [ userInfo state, fldPath state ]
    , section "Settings" [ propList _props state ]
    ]

eval :: Natural Query (ComponentDSL State Query Slam)
eval (ModifyState f next) = modify (processState <<< f) $> next
eval (Validate continue) = do
  state <- get
  pure $ continue $ Id.runIdentity $ flip Ct.runContT pure $ Ct.callCC \k -> do
    when (null (filter (not isEmptyHost) state.hosts))
      $ k $ Just "Please enter at least one host"
    when (userSectionTyped state) do
      when (state.user == "") $ k $ Just "Please enter user name"
      when (state.password == "") $ k $ Just "Please enter password"
      when (state.path == "") $ k $ Just "Please enter authentication database name"
    pure Nothing
  where
  userSectionTyped state =
    F.any (/= "") [state.user, state.password]

eval (Submit parent name k) = do
  st <- get
  let path = parent </> dir name
  result <- liftAff $ attempt $ Auth.authed $ API.saveMount path (mkURI st)
  pure $ k $ map (const (Database path)) result

hosts :: State -> ComponentHTML Query
hosts state =
  H.div
    [ P.class_ Rc.mountHostList ]
    $ host state <$> 0 .. (length state.hosts - 1)

host :: State -> Int -> ComponentHTML Query
host state index =
  H.div
    [ P.class_ Rc.mountHost ]
    [ label "Host"
      [ input' rejectNonHostname state (_hosts <<< ix index <<< _host) [] ]
    , label "Port"
      [ input' rejectNonPort state (_hosts <<< ix index <<< _port) [] ]
    ]
  where
  rejectNonHostname :: String -> String
  rejectNonHostname = Rx.replace rxNonHostname ""

  rxNonHostname :: Rx.Regex
  rxNonHostname =
    Rx.regex "[^0-9a-z\\-\\._~%]" (Rx.noFlags { ignoreCase = true, global = true })

  rejectNonPort :: String -> String
  rejectNonPort = Rx.replace rxNonPort ""

  rxNonPort :: Rx.Regex
  rxNonPort = Rx.regex "[^0-9]" (Rx.noFlags { global = true })

userInfo :: State -> ComponentHTML Query
userInfo state =
  H.div
    [ P.classes [B.formGroup, Rc.mountUserInfo] ]
    [ fldUser state, fldPass state ]

fldUser :: State -> ComponentHTML Query
fldUser state =
  label "Username" [ input state _user [] ]

fldPass :: State -> ComponentHTML Query
fldPass state =
  label "Password" [ input state _password [ P.inputType P.InputPassword ] ]

fldPath :: State -> ComponentHTML Query
fldPath state =
  H.div
    [ P.class_ Rc.mountPath ]
    [ label "Database" [ input state _path [] ] ]

-- | A labelled section within the form.
label :: forall i p. String -> Array (HTML p i) -> HTML p i
label text inner = H.label_ $ [ H.span_ [ H.text text ] ] ++ inner

-- | A basic text input field that uses a lens to read from and update the
-- | state.
input
  :: forall p
   . State
  -> TraversalP State String
  -> Array (Cp.InputProp Query)
  -> HTML p Query
input state lens =
  input' id state lens -- can't eta reduce further here as the typechecker doesn't like it

-- | A basic text input field that uses a lens to read from and update the
-- | state, and allows for the input value to be modified.
input'
  :: forall p
   . (String -> String)
  -> State
  -> TraversalP State String
  -> Array (Cp.InputProp Query)
  -> HTML p Query
input' f state lens attrs =
  H.input
    $ [ P.class_ B.formControl
      , E.onValueInput (E.input \val -> ModifyState (lens .~ f val))
      , P.value (state ^. lens)
      ]
    ++ attrs

{-
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.FileSystem.Dialog.Mount.MongoDB.Component
  ( comp
  , Query()
  , module SlamData.FileSystem.Dialog.Mount.Common.SettingsQuery
  , module SlamData.FileSystem.Dialog.Mount.MongoDB.Component.State
  ) where

import Prelude

import Control.Monad.Aff (attempt)

import Data.Array ((..), length, null, filter)
import Data.Functor (($>))
import Data.Functor.Aff (liftAff)
import Data.Lens (TraversalP(), (^.), (.~))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe(..))
import Data.Path.Pathy (dir, (</>))
import Data.String.Regex as Rx

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

import Quasar.Aff as API
import Quasar.Auth as Auth

import SlamData.Effects (Slam())
import SlamData.FileSystem.Dialog.Mount.Common.Render
import SlamData.FileSystem.Dialog.Mount.Common.SettingsQuery
import SlamData.FileSystem.Dialog.Mount.MongoDB.Component.State
import SlamData.FileSystem.Resource (Mount(..))
import SlamData.Render.CSS as Rc

type Query = SettingsQuery State

comp :: Component State Query Slam
comp = component render eval

render :: State -> ComponentHTML Query
render state =
  H.div
    [ P.key "mount-mongodb"
    , P.class_ Rc.mountMongoDB
    ]
    [ section "Server(s)" [ hosts state ]
    , section "Authentication" [ userInfo state, fldPath state ]
    , section "Settings" [ propList _props state ]
    ]

eval :: Natural Query (ComponentDSL State Query Slam)
eval (ModifyState f next) = modify (processState <<< f) $> next
eval (Validate k) = do
  state <- get
  pure $ k
    if null (filter (not isEmptyHost) state.hosts)
    then Just "Please enter at least one host"
    else Nothing
eval (Submit parent name k) = do
  st <- get
  let path = parent </> dir name
  result <- liftAff $ attempt $ Auth.authed $ API.saveMount path (mkURI st)
  pure $ k $ map (const (Database path)) result

hosts :: State -> ComponentHTML Query
hosts state =
  H.div
    [ P.class_ Rc.mountHostList ]
    $ host state <$> 0 .. (length state.hosts - 1)

host :: State -> Int -> ComponentHTML Query
host state index =
  H.div
    [ P.class_ Rc.mountHost ]
    [ label "Host" [ input' rejectNonHostname state (_hosts <<< ix index <<< _host) [] ]
    , label "Port" [ input' rejectNonPort state (_hosts <<< ix index <<< _port) [] ]
    ]
  where
  rejectNonHostname :: String -> String
  rejectNonHostname = Rx.replace rxNonHostname ""

  rxNonHostname :: Rx.Regex
  rxNonHostname =
    Rx.regex "[^0-9a-z\\-\\._~%]" (Rx.noFlags { ignoreCase = true, global = true })

  rejectNonPort :: String -> String
  rejectNonPort = Rx.replace rxNonPort ""

  rxNonPort :: Rx.Regex
  rxNonPort = Rx.regex "[^0-9]" (Rx.noFlags { global = true })

userInfo :: State -> ComponentHTML Query
userInfo state =
  H.div
    [ P.classes [B.formGroup, Rc.mountUserInfo] ]
    [ fldUser state, fldPass state ]

fldUser :: State -> ComponentHTML Query
fldUser state = label "Username" [ input state _user [] ]

fldPass :: State -> ComponentHTML Query
fldPass state = label "Password" [ input state _password [ P.inputType P.InputPassword ] ]

fldPath :: State -> ComponentHTML Query
fldPath state =
  H.div
    [ P.class_ Rc.mountPath ]
    [ label "Database" [ input state _path [] ] ]

-- | A labelled section within the form.
label :: forall i p. String -> Array (HTML p i) -> HTML p i
label text inner = H.label_ $ [ H.span_ [ H.text text ] ] ++ inner

-- | A basic text input field that uses a lens to read from and update the
-- | state.
input
  :: forall p
   . State
  -> TraversalP State String
  -> Array (Cp.InputProp Query)
  -> HTML p Query
input state lens = input' id state lens -- can't eta reduce further here as the typechecker doesn't like it

-- | A basic text input field that uses a lens to read from and update the
-- | state, and allows for the input value to be modified.
input'
  :: forall p
   . (String -> String)
  -> State
  -> TraversalP State String
  -> Array (Cp.InputProp Query)
  -> HTML p Query
input' f state lens attrs =
  H.input
    $ [ P.class_ B.formControl
      , E.onValueInput (E.input \val -> ModifyState (lens .~ f val))
      , P.value (state ^. lens)
      ]
    ++ attrs


update type infor earlier

update type infor earlier

module Main (main,run) where

import Debug.Trace

import Control.Bind
import Control.Timer (timeout,clearTimeout)
import Control.Monad.Eff
import Control.Monad.Eff.Ref
import Data.Date
import Data.Time
import Data.Foldable (for_, foldl)

import Ace
import Ace.Types
import qualified Ace.Editor as Editor
import qualified Ace.EditSession as Session
import qualified Ace.Range as Range

import qualified Graphics.WebGL as GL
import qualified Control.Monad.JQuery as J

import WebSocket
import DefaultText
import Data.Either
import Sample

import Data.Function
import Data.Maybe
import Data.StrMap
import Data.Tuple
import Data.Array(filter,head)

import Backend
import IR
import Mesh
import Type
import Input

import PipelineJsonDecode
import qualified Data.Argonaut as A

import Data.Matrix (Mat(..))
import Data.Matrix4
import Data.Vector3

main = return unit

{-
  control-b - compile/build
  control-n - new
-}
foreign import addCommand """
  function addCommand(editor) {
    return function(cmdName) {
      return function(winKey) {
        return function(macKey) {
          return function(cmd) {
            return function() {
              editor.commands.addCommand({
                name: cmdName,
                bindKey: {win: winKey,  mac: macKey},
                exec: function(editor) {
                  cmd(editor)();
                }
              });
            };
          };
        };
      };
    };
  }
""" :: forall eff . Editor -> String -> String -> String -> (Editor -> Eff (ace :: EAce | eff) Unit) -> Eff (ace :: EAce | eff) Unit

foreign import tokenTooltip """
  function tokenTooltip(editor) {
    return function(getTy) {
      return function() {
          editor.tokenTooltip = new myTokenTooltip(editor,getTy);
      };
    };
  }
""" :: forall eff . Editor -> (Int -> Int -> Eff (ace :: EAce | eff) TypeInfoRecord) -> Eff (ace :: EAce | eff) Unit

foreign import addMarkerImpl
  "function addMarkerImpl(range, clazz, type, inFront, self) {\
  \  return function() {\
  \    return self.addMarker(range, clazz, type, inFront);\
  \  };\
  \}" :: forall eff. Fn5 Range String String Boolean EditSession (Eff (ace :: EAce | eff) Int)

addMarker :: forall eff. Range -> String -> String -> Boolean -> EditSession -> Eff (ace :: EAce | eff) Int
addMarker range clazz _type inFront self = runFn5 addMarkerImpl range clazz _type inFront self

run = GL.runWebGL "glcanvas" (\s -> trace s) $ \context -> do
  -- setup pipeline input
  let inputSchema =
        { slots : fromList [ Tuple "stream"  {primitive: Triangles, attributes: fromList [Tuple "position"  TV3F, Tuple "normal" TV3F, Tuple "UVTex" TV2F]}
                           , Tuple "stream4" {primitive: Triangles, attributes: fromList [Tuple "position4" TV4F, Tuple "vertexUV" TV2F]}
                           ]
        , uniforms : fromList [Tuple "MVP" M44F, Tuple "MVP2" M44F]
        }
  pplInput <- mkWebGLPipelineInput inputSchema
  let --mvp = V4 (V4 0.4692207 (-0.28573585) (-0.9593549) (-0.9574381)) (V4 0.0 2.395976 (-0.122928835) (-0.12268323)) (V4 (-1.719497) (-7.797232e-2) (-0.2617912) (-0.26126814)) (V4 0.0 0.0 3.8834958 4.0755367)
      toLCMat4 :: Mat4 -> M44F
      toLCMat4 (Mat [x11, x21, x31, x41, x12, x22, x32, x42, x13, x23, x33, x43, x14, x24, x34, x44]) = let
          v1 = V4 x11 x21 x31 x41
          v2 = V4 x12 x22 x32 x42
          v3 = V4 x13 x23 x33 x43
          v4 = V4 x14 x24 x34 x44
        in V4 v1 v2 v3 v4

      updateInput t = do
        let pi = 3.141592653589793
            w  = 800
            h  = 600
            angle = pi / 24 * t
            cm = makeLookAt (vec3 3 1.3 0.3) (vec3 0 0 0) (vec3 0 1 0)
            mm = makeRotate angle (vec3 0 1 0)
            pm = makePerspective 45 (w/h) 0.1 100
            mvp = pm `mul` cm `mul` mm
        uniformM44F "MVP" pplInput.uniformSetter $ toLCMat4 mvp

  gpuCube <- compileMesh myCube

  addMesh pplInput "stream4" gpuCube []

  -- setup ace editor
  editor <- Ace.edit "editor" ace
  session <- Editor.getSession editor
  Editor.setTheme "ace/theme/terminal" editor
  Session.setMode "ace/mode/haskell" session
  Session.setValue defaultSrc session
  typeInfoRef <- newRef []
  markerRef <- newRef []
  let lessEqPos l c l' c' = l < l' || l == l' && c <= c'
  let lessPos l c l' c' = l < l' || l == l' && c < c'
  let getTypeInfo l c = do
        x <- readRef typeInfoRef
        let ps = flip filter x $ \(TypeInfo i) -> lessEqPos i.startLine i.startColumn l c && lessPos l c i.endLine i.endColumn
        let f Nothing (TypeInfo i) = Just i
            f (Just d) (TypeInfo i)
                | lessPos d.startLine d.startColumn i.startLine i.startColumn = Just i
                | otherwise = Just d
        return $ case foldl f Nothing ps of
          Nothing ->
              { startLine   : 0
              , startColumn : 0
              , endLine     : 0
              , endColumn   : 0
              , text        : ""
              }
          Just a -> a
  tokenTooltip editor getTypeInfo

  b <- J.body
  ui <- J.find "#ui" b
  messagepanel <- J.find "#messagepanel" b
  statuspanel <- J.find "#statuspanel" b
  btnCompile <- J.create "<button>"
  J.setText "Build" btnCompile
  btnCompile `J.append` ui

  pipelineRef <- newRef Nothing
  let compile s = do
        trace "compile"
        J.setText "Compiling..." statuspanel
        src <- Session.getValue session
        send s src

      render ir = do
        trace "WebGL ready"
        ppl <- allocPipeline ir -- gfx03Pipeline -- samplePipeline
        trace "Pipeline allocated"

        setPipelineInput ppl (Just pplInput)
        sortSlotObjects pplInput
        trace "Setup pipeline input"

        old <- readRef pipelineRef
        case old of
          Nothing -> return unit
          Just p -> do
            disposePipeline p
            trace "Pipeline disposed"
        writeRef pipelineRef $ Just ppl
        trace "WebGL completed"

  socket <- webSocket "ws://localhost:8000/compile" $
    { onOpen    : \s -> do
        trace "socket is ready"
        compile s
        timerRef <- newRef Nothing
        Session.onChange session $ do
          t <- readRef timerRef
          case t of
            Nothing -> return unit
            Just a -> clearTimeout a
          writeRef timerRef =<< Just <$> timeout 1000 (compile s)

    , onClose   : trace "socket is closed"
    , onMessage : \s m -> do
        case A.jsonParser m >>= A.decodeJson of
          Left e -> trace $ "decode error: " ++ e
          Right (MyLeft (TypeInfo e)) -> do
            J.setText "Error" statuspanel
            J.setText e.text messagepanel
            range <- Range.create (e.startLine - 1) (e.startColumn - 1) (e.endLine - 1) (e.endColumn - 1)
            mkr <- addMarker range "lc_error" "text" false session
            rs <- readRef markerRef
            for_ rs $ \mkr -> Session.removeMarker mkr session
            writeRef markerRef [mkr]
            return unit
          Right (MyRight p infos) -> do
            J.setText "Compiled" statuspanel
            J.setText "No errors." messagepanel
            writeRef typeInfoRef infos
            rs <- readRef markerRef
            for_ rs $ \mkr -> Session.removeMarker mkr session
            writeRef markerRef []
            render p
    , onError   : \s m -> trace m
    }
  case socket of
    Left m -> trace $ "error: " ++ m
    Right ws -> do
      flip (J.on "click") btnCompile $ \_ _ -> do
        compile ws
        trace "clicked compile"
      addCommand editor "Compile" "Ctrl-B" "Command-B" (\_ -> compile ws)
      let renderLoop = do
            Milliseconds t <- nowEpochMilliseconds
            updateInput (t / 1000)
            mppl <- readRef pipelineRef
            case mppl of
              Nothing -> return unit
              Just ppl -> renderPipeline ppl
            timeout (1000/25) renderLoop
      -- render loop
      renderLoop
      return unit

module Main (main,run) where

import Debug.Trace

import Control.Bind
import Control.Timer (timeout,clearTimeout)
import Control.Monad.Eff
import Control.Monad.Eff.Ref
import Data.Date
import Data.Time
import Data.Foldable (for_, foldl)

import Ace
import Ace.Types
import qualified Ace.Editor as Editor
import qualified Ace.EditSession as Session
import qualified Ace.Range as Range

import qualified Graphics.WebGL as GL
import qualified Control.Monad.JQuery as J

import WebSocket
import DefaultText
import Data.Either
import Sample

import Data.Function
import Data.Maybe
import Data.StrMap
import Data.Tuple
import Data.Array(filter,head)

import Backend
import IR
import Mesh
import Type
import Input

import PipelineJsonDecode
import qualified Data.Argonaut as A

import Data.Matrix (Mat(..))
import Data.Matrix4
import Data.Vector3

main = return unit

{-
  control-b - compile/build
  control-n - new
-}
foreign import addCommand """
  function addCommand(editor) {
    return function(cmdName) {
      return function(winKey) {
        return function(macKey) {
          return function(cmd) {
            return function() {
              editor.commands.addCommand({
                name: cmdName,
                bindKey: {win: winKey,  mac: macKey},
                exec: function(editor) {
                  cmd(editor)();
                }
              });
            };
          };
        };
      };
    };
  }
""" :: forall eff . Editor -> String -> String -> String -> (Editor -> Eff (ace :: EAce | eff) Unit) -> Eff (ace :: EAce | eff) Unit

foreign import tokenTooltip """
  function tokenTooltip(editor) {
    return function(getTy) {
      return function() {
          editor.tokenTooltip = new myTokenTooltip(editor,getTy);
      };
    };
  }
""" :: forall eff . Editor -> (Int -> Int -> Eff (ace :: EAce | eff) TypeInfoRecord) -> Eff (ace :: EAce | eff) Unit

foreign import addMarkerImpl
  "function addMarkerImpl(range, clazz, type, inFront, self) {\
  \  return function() {\
  \    return self.addMarker(range, clazz, type, inFront);\
  \  };\
  \}" :: forall eff. Fn5 Range String String Boolean EditSession (Eff (ace :: EAce | eff) Int)

addMarker :: forall eff. Range -> String -> String -> Boolean -> EditSession -> Eff (ace :: EAce | eff) Int
addMarker range clazz _type inFront self = runFn5 addMarkerImpl range clazz _type inFront self

run = GL.runWebGL "glcanvas" (\s -> trace s) $ \context -> do
  -- setup pipeline input
  let inputSchema =
        { slots : fromList [ Tuple "stream"  {primitive: Triangles, attributes: fromList [Tuple "position"  TV3F, Tuple "normal" TV3F, Tuple "UVTex" TV2F]}
                           , Tuple "stream4" {primitive: Triangles, attributes: fromList [Tuple "position4" TV4F, Tuple "vertexUV" TV2F]}
                           ]
        , uniforms : fromList [Tuple "MVP" M44F, Tuple "MVP2" M44F]
        }
  pplInput <- mkWebGLPipelineInput inputSchema
  let --mvp = V4 (V4 0.4692207 (-0.28573585) (-0.9593549) (-0.9574381)) (V4 0.0 2.395976 (-0.122928835) (-0.12268323)) (V4 (-1.719497) (-7.797232e-2) (-0.2617912) (-0.26126814)) (V4 0.0 0.0 3.8834958 4.0755367)
      toLCMat4 :: Mat4 -> M44F
      toLCMat4 (Mat [x11, x21, x31, x41, x12, x22, x32, x42, x13, x23, x33, x43, x14, x24, x34, x44]) = let
          v1 = V4 x11 x21 x31 x41
          v2 = V4 x12 x22 x32 x42
          v3 = V4 x13 x23 x33 x43
          v4 = V4 x14 x24 x34 x44
        in V4 v1 v2 v3 v4

      updateInput t = do
        let pi = 3.141592653589793
            w  = 800
            h  = 600
            angle = pi / 24 * t
            cm = makeLookAt (vec3 3 1.3 0.3) (vec3 0 0 0) (vec3 0 1 0)
            mm = makeRotate angle (vec3 0 1 0)
            pm = makePerspective 45 (w/h) 0.1 100
            mvp = pm `mul` cm `mul` mm
        uniformM44F "MVP" pplInput.uniformSetter $ toLCMat4 mvp

  gpuCube <- compileMesh myCube

  addMesh pplInput "stream4" gpuCube []

  -- setup ace editor
  editor <- Ace.edit "editor" ace
  session <- Editor.getSession editor
  Editor.setTheme "ace/theme/terminal" editor
  Session.setMode "ace/mode/haskell" session
  Session.setValue defaultSrc session
  typeInfoRef <- newRef []
  markerRef <- newRef []
  let lessEqPos l c l' c' = l < l' || l == l' && c <= c'
  let lessPos l c l' c' = l < l' || l == l' && c < c'
  let getTypeInfo l c = do
        x <- readRef typeInfoRef
        let ps = flip filter x $ \(TypeInfo i) -> lessEqPos i.startLine i.startColumn l c && lessPos l c i.endLine i.endColumn
        let f Nothing (TypeInfo i) = Just i
            f (Just d) (TypeInfo i)
                | lessPos d.startLine d.startColumn i.startLine i.startColumn = Just i
                | otherwise = Just d
        return $ case foldl f Nothing ps of
          Nothing ->
              { startLine   : 0
              , startColumn : 0
              , endLine     : 0
              , endColumn   : 0
              , text        : ""
              }
          Just a -> a
  tokenTooltip editor getTypeInfo

  b <- J.body
  ui <- J.find "#ui" b
  messagepanel <- J.find "#messagepanel" b
  statuspanel <- J.find "#statuspanel" b
  btnCompile <- J.create "<button>"
  J.setText "Build" btnCompile
  btnCompile `J.append` ui

  pipelineRef <- newRef Nothing
  let compile s = do
        trace "compile"
        J.setText "Compiling..." statuspanel
        src <- Session.getValue session
        send s src

      render ir = do
        trace "WebGL ready"
        ppl <- allocPipeline ir -- gfx03Pipeline -- samplePipeline
        trace "Pipeline allocated"

        setPipelineInput ppl (Just pplInput)
        sortSlotObjects pplInput
        trace "Setup pipeline input"

        old <- readRef pipelineRef
        case old of
          Nothing -> return unit
          Just p -> do
            disposePipeline p
            trace "Pipeline disposed"
        writeRef pipelineRef $ Just ppl
        trace "WebGL completed"

  socket <- webSocket "ws://localhost:8000/compile" $
    { onOpen    : \s -> do
        trace "socket is ready"
        compile s
        timerRef <- newRef Nothing
        Session.onChange session $ do
          t <- readRef timerRef
          case t of
            Nothing -> return unit
            Just a -> clearTimeout a
          writeRef timerRef =<< Just <$> timeout 1000 (compile s)

    , onClose   : trace "socket is closed"
    , onMessage : \s m -> do
        case A.jsonParser m >>= A.decodeJson of
          Left e -> trace $ "decode error: " ++ e
          Right (MyLeft (TypeInfo e)) -> do
            J.setText "Error" statuspanel
            J.setText e.text messagepanel
            range <- Range.create (e.startLine - 1) (e.startColumn - 1) (e.endLine - 1) (e.endColumn - 1)
            mkr <- addMarker range "lc_error" "text" false session
            rs <- readRef markerRef
            for_ rs $ \mkr -> Session.removeMarker mkr session
            writeRef markerRef [mkr]
            return unit
          Right (MyRight p infos) -> do
            J.setText "Compiled" statuspanel
            J.setText "No errors." messagepanel
            rs <- readRef markerRef
            for_ rs $ \mkr -> Session.removeMarker mkr session
            writeRef markerRef []
            render p
            writeRef typeInfoRef infos
    , onError   : \s m -> trace m
    }
  case socket of
    Left m -> trace $ "error: " ++ m
    Right ws -> do
      flip (J.on "click") btnCompile $ \_ _ -> do
        compile ws
        trace "clicked compile"
      addCommand editor "Compile" "Ctrl-B" "Command-B" (\_ -> compile ws)
      let renderLoop = do
            Milliseconds t <- nowEpochMilliseconds
            updateInput (t / 1000)
            mppl <- readRef pipelineRef
            case mppl of
              Nothing -> return unit
              Just ppl -> renderPipeline ppl
            timeout (1000/25) renderLoop
      -- render loop
      renderLoop
      return unit


mapCards

mapCards

module Main where

import Prelude
import Control.Monad.Eff
import Control.Monad.Eff.Console
import DOM
import DOM.HTML
import DOM.HTML.Types
import DOM.HTML.Window
import DOM.HTML.Document
import DOM.Node.Types
import qualified DOM.Node.Document as ND
import qualified DOM.Node.Element as E
import qualified DOM.Node.HTMLCollection as C
import Data.Nullable (Nullable(), toMaybe)
import Data.Maybe (Maybe(..))
import Data.Maybe.Unsafe (fromJust)
import qualified DOM.Node.Node as N
import qualified Unsafe.Coerce as U

cardImgURL :: String -> String
cardImgURL "Purelace"       = "http://magiccards.info/scans/en/4e/293.jpg"
cardImgURL "Thoughtflare"   = "http://magiccards.info/scans/en/rtr/203.jpg"
cardImgURL "Memoricide"     = "http://magiccards.info/scans/en/mbp/29.jpg"
cardImgURL "Chill"          = "http://magiccards.info/scans/en/arena/19.jpg"
cardImgURL _                = "http://magiccards.info/scans/en/uhaa/44.jpg"

coerceE :: HTMLElement -> Element
coerceE = htmlElementToElement

coerceD :: HTMLDocument -> Document
coerceD = htmlDocumentToDocument

e2n :: Element -> Node
e2n = elementToNode

n2e :: Element -> Node
n2e = U.unsafeCoerce

htmlDoc :: forall eff. Eff (dom :: DOM | eff) HTMLDocument
htmlDoc = do
  w <- window
  document w

doc' :: forall eff. Eff (dom :: DOM | eff) Document
doc' = do
  d <- htmlDoc
  return $ coerceD d

htmlBody :: forall eff. Eff (dom :: DOM | eff) (Nullable HTMLElement)
htmlBody = do
  w <- window
  d <- document w
  body d

body' :: forall eff. Eff (dom :: DOM | eff) Element
body' = do
  hb <- htmlBody
  return $ coerceE $ unsafeA hb

unsafeA :: forall a. (Nullable a) -> a
unsafeA = fromJust <<< toMaybe

mapCol :: forall a eff. HTMLCollection ->
                        (Element -> Eff (dom :: DOM | eff) a) ->
                        Eff (dom :: DOM | eff) HTMLCollection

mapCol xs f = do
  l <- C.length xs
  mapDo l xs f
    where
      mapDo 0 xs _ = return xs
      mapDo l xs f = do
        nx <- C.item (l - 1) xs
        let x = unsafeA nx
        _ <- f x
        mapDo (l - 1) xs f

mapCards :: forall eff. Eff (console :: CONSOLE, dom :: DOM | eff) HTMLCollection
mapCards = do
  d   <- doc'
  b   <- body'
  xs <- E.getElementsByClassName "card" b
  mapCol xs $ f d
    where
      f d x = do
        let xn = e2n x
        fcxn <- N.firstChild xn
        card <- N.textContent $ unsafeA fcxn
        log card
        xn1  <- N.removeChild (unsafeA fcxn) xn
        img  <- ND.createElement "img" d
        _    <- E.setAttribute "src" (cardImgURL card) img
        xn1  <- N.appendChild (e2n img) xn
        return xn1

main :: forall eff. Eff (console :: CONSOLE, dom :: DOM | eff) Unit
main = do
  mapCards
  log $ "Boom!"

module Main where

import Prelude
import Control.Monad.Eff
import Control.Monad.Eff.Console
import DOM
import DOM.HTML
import DOM.HTML.Types
import DOM.HTML.Window
import DOM.HTML.Document
import DOM.Node.Types
import qualified DOM.Node.Document as ND
import DOM.Node.Element hiding (id)
import qualified DOM.Node.Element as E
import qualified DOM.Node.HTMLCollection as C
import Data.Nullable (Nullable(), toMaybe)
import Data.Maybe (Maybe(..))
import Data.Maybe.Unsafe (fromJust)
import qualified DOM.Node.Node as N
import qualified Unsafe.Coerce as U

cardImgURL :: String -> String
cardImgURL "Purelace"       = "http://magiccards.info/scans/en/4e/293.jpg"
cardImgURL "Thoughtflare"   = "http://magiccards.info/scans/en/rtr/203.jpg"
cardImgURL "Memoricide"     = "http://magiccards.info/scans/en/mbp/29.jpg"
cardImgURL "Chill"          = "http://magiccards.info/scans/en/arena/19.jpg"
cardImgURL _                = "http://magiccards.info/scans/en/uhaa/44.jpg"

coerceE :: HTMLElement -> Element
coerceE = htmlElementToElement

coerceD :: HTMLDocument -> Document
coerceD = htmlDocumentToDocument

e2n :: Element -> Node
e2n = elementToNode

n2e :: Element -> Node
n2e = U.unsafeCoerce

htmlDoc :: forall eff. Eff (dom :: DOM | eff) HTMLDocument
htmlDoc = do
  w <- window
  document w

doc' :: forall eff. Eff (dom :: DOM | eff) Document
doc' = do
  d <- htmlDoc
  return $ coerceD d

htmlBody :: forall eff. Eff (dom :: DOM | eff) (Nullable HTMLElement)
htmlBody = do
  w <- window
  d <- document w
  body d

body' :: forall eff. Eff (dom :: DOM | eff) Element
body' = do
  hb <- htmlBody
  return $ coerceE $ unsafeA hb

unsafeA :: forall a. (Nullable a) -> a
unsafeA = fromJust <<< toMaybe

main :: forall eff. Eff (console :: CONSOLE, dom :: DOM | eff) Unit
main = do
  d <- doc'
  b <- body'
  img  <- ND.createElement "img" d
  _    <- E.setAttribute "src" (cardImgURL "Chill") img
  b1   <- N.appendChild (e2n img) (e2n b)
  src  <- E.getAttribute "src" img
  log $ show $ unsafeA src == cardImgURL "Chill"


Pipelines just work on `String` (not `Json`)

Original commit 82269fc66e1ad841aa63d492b71e9a94138724fa

module Main where

import IR
import IRGraph
import Prelude
import Transformations

import Environment (Environment(..))
import Environment as Env

import CSharp as CSharp
import Data.Argonaut.Core (Json)
import Data.Argonaut.Core (foldJson) as J
import Data.Argonaut.Decode (decodeJson) as J
import Data.Argonaut.Parser (jsonParser) as J
import Data.Array (foldl)
import Data.Array as A
import Data.Either (Either(..))
import Data.Map as Map
import Data.Maybe (Maybe(..))
import Data.Set as S
import Data.StrMap as StrMap
import Data.String.Util (singular)
import Data.Tuple (Tuple(..))
import Doc as Doc
import Golang as Golang
import JsonSchema (JSONSchema, jsonSchemaToIR)
import JsonSchema as JsonSchema
import Math (round)
import Utils (mapM)

type Error = String

type Pipeline = Doc.Renderer -> String -> Either Error String

renderers :: Array Doc.Renderer
renderers = [CSharp.renderer, Golang.renderer, JsonSchema.renderer]

makeTypeFromJson :: String -> Json -> IR IRType
makeTypeFromJson name json =
    J.foldJson
    (\_ -> pure IRNull)
    (\_ -> pure IRBool)
    (\n -> pure if round n == n then IRInteger else IRDouble)
    (\_ -> pure IRString)
    (\arr -> do
        let typeName = singular name
        IRArray <$> A.foldRecM (unify typeName) IRNothing arr)
    (\obj -> do
        let l1 = StrMap.toUnfoldable obj
        l2 <- mapM toProperty l1
        addClass $ IRClassData { names: S.singleton name, properties: Map.fromFoldable l2 })
    json
    where
        unify typeName t1 j2 = makeTypeFromJson typeName j2 >>= unifyTypes t1
        toProperty (Tuple name json) = Tuple name <$> makeTypeFromJson name json

makeTypeAndUnify :: String -> Json -> IRGraph
makeTypeAndUnify name json = execIR do
    topLevel <- makeTypeFromJson name json
    setTopLevel topLevel
    replaceSimilarClasses
    makeMaps

irFromError :: String -> IR IRType
irFromError err = do
    addClass $ IRClassData { names: S.singleton err, properties: Map.empty }

makeTypeFromSchema :: String -> JSONSchema -> Either Error IRGraph
makeTypeFromSchema name schema = eitherify $ runIR do
    topLevelOrError <- jsonSchemaToIR schema "TopLevel" schema
    case topLevelOrError of
        Left err -> pure $ Just err
        Right topLevel -> do
            setTopLevel topLevel
            pure Nothing
    where
        eitherify (Tuple (Just err) _) = Left err
        eitherify (Tuple Nothing g) = Right g

jsonPipeline :: Pipeline
jsonPipeline renderer json =
    json
    # J.jsonParser
    <#> makeTypeAndUnify "TopLevel"
    <#> regatherClassNames
    <#> Doc.runRenderer renderer

jsonSchemaPipeline :: Pipeline
jsonSchemaPipeline renderer json = do
    obj <- J.jsonParser json
    schema <- J.decodeJson obj
    graph <- makeTypeFromSchema "TopLevel" schema
    graph
        # regatherClassNames
        # Doc.runRenderer renderer
        # pure

pipelines :: Environment -> Array Pipeline
pipelines Development = [jsonSchemaPipeline, jsonPipeline]
pipelines Production = [jsonPipeline]

firstSuccess :: Array Pipeline -> Pipeline
firstSuccess pipes renderer json = foldl takeFirstRight (Left "no pipelines provided") pipes
    where
        takeFirstRight (Right output) _ = Right output
        takeFirstRight _ pipeline = pipeline renderer json

renderForUI :: Pipeline
renderForUI = firstSuccess (pipelines Env.current)

module Main where

import IR
import IRGraph
import Prelude
import Transformations

import Environment (Environment(..))
import Environment as Env

import CSharp as CSharp
import Data.Argonaut.Core (Json)
import Data.Argonaut.Core (foldJson) as J
import Data.Argonaut.Decode (decodeJson) as J
import Data.Argonaut.Parser (jsonParser) as J
import Data.Array (foldl)
import Data.Array as A
import Data.Either (Either(..))
import Data.Map as Map
import Data.Maybe (Maybe(..))
import Data.Set as S
import Data.StrMap as StrMap
import Data.String.Util (singular)
import Data.Tuple (Tuple(..))
import Doc as Doc
import Golang as Golang
import JsonSchema (JSONSchema, jsonSchemaToIR)
import JsonSchema as JsonSchema
import Math (round)
import Utils (mapM)

type Error = String

type Pipeline = Doc.Renderer -> Json -> Either Error String

renderers :: Array Doc.Renderer
renderers = [CSharp.renderer, Golang.renderer, JsonSchema.renderer]

makeTypeFromJson :: String -> Json -> IR IRType
makeTypeFromJson name json =
    J.foldJson
    (\_ -> pure IRNull)
    (\_ -> pure IRBool)
    (\n -> pure if round n == n then IRInteger else IRDouble)
    (\_ -> pure IRString)
    (\arr -> do
        let typeName = singular name
        IRArray <$> A.foldRecM (unify typeName) IRNothing arr)
    (\obj -> do
        let l1 = StrMap.toUnfoldable obj
        l2 <- mapM toProperty l1
        addClass $ IRClassData { names: S.singleton name, properties: Map.fromFoldable l2 })
    json
    where
        unify typeName t1 j2 = makeTypeFromJson typeName j2 >>= unifyTypes t1
        toProperty (Tuple name json) = Tuple name <$> makeTypeFromJson name json

makeTypeAndUnify :: String -> Json -> IRGraph
makeTypeAndUnify name json = execIR do
    topLevel <- makeTypeFromJson name json
    setTopLevel topLevel
    replaceSimilarClasses
    makeMaps

irFromError :: String -> IR IRType
irFromError err = do
    addClass $ IRClassData { names: S.singleton err, properties: Map.empty }

makeTypeFromSchema :: String -> JSONSchema -> Either Error IRGraph
makeTypeFromSchema name schema = eitherify $ runIR do
    topLevelOrError <- jsonSchemaToIR schema "TopLevel" schema
    case topLevelOrError of
        Left err -> pure $ Just err
        Right topLevel -> do
            setTopLevel topLevel
            pure Nothing
    where
        eitherify (Tuple (Just err) _) = Left err
        eitherify (Tuple Nothing g) = Right g

jsonPipeline :: Pipeline
jsonPipeline renderer json =
    json
    # makeTypeAndUnify "TopLevel"
    # regatherClassNames
    # Doc.runRenderer renderer
    # Right

jsonSchemaPipeline :: Pipeline
jsonSchemaPipeline renderer json =
    json
    # J.decodeJson
    >>= makeTypeFromSchema "TopLevel"
    <#> regatherClassNames
    <#> Doc.runRenderer renderer

pipelines :: Environment -> Array Pipeline
pipelines Development = [jsonSchemaPipeline, jsonPipeline]
pipelines Production = [jsonPipeline]

firstSuccess :: Array Pipeline -> Pipeline
firstSuccess pipes renderer json = foldl takeFirstRight (Left "no pipelines provided") pipes
    where
        takeFirstRight (Right output) _ = Right output
        takeFirstRight _ pipeline = pipeline renderer json

renderForUI :: Doc.Renderer -> String -> Either Error String
renderForUI renderer json = do
    obj <- J.jsonParser json
    firstSuccess (pipelines Env.current) renderer obj