refine the code

refine the code

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Chart.BuildOptions.Radar where

import SlamData.Prelude

import Data.Argonaut (JCursor)
import Data.Foldable (minimum, maximum)
import Data.Array ((!!))
import Data.Array as A
import Data.Function (on)
import Data.List (List(..))
import Data.List as L
import Data.Map (Map)
import Data.Int (toNumber)
import Math ((%))

import ECharts as EC

import SlamData.Workspace.Card.Chart.Aggregation (Aggregation(..), runAggregation)
import SlamData.Workspace.Card.Chart.Axis as Ax
import SlamData.Workspace.Card.Chart.ChartConfiguration (ChartConfiguration)
import SlamData.Workspace.Card.Chart.BuildOptions.Common (SeriesKey, ChartAxises, colors, buildChartAxises, keyName)

--sample data:
-- Tuple ['dimA', 'dimB']
--       [ (Tuple '' [(Tuple 'series1' [1, 5]), (Tuple 'series2' [1, 5])]) ]
type RadarData = Tuple (Array String) (Array (Tuple String (Array (Tuple String (Array Number)))))

radarData ∷ ChartAxises → RadarData
radarData axises = Tuple (A.fromFoldable distinctDims) $
  A.fromFoldable
    $ map (map (A.fromFoldable <<< L.catMaybes <<< map checkDimAndTransform))
    -- output sample:
    -- ( Tuple ''
    --         ( (Tuple 'series1' (Tuple 'dimA' 1 : Tuple 'dimB' 5))
    --         : (Tuple 'series2' (Tuple 'dimA' 1 : Tuple 'dimB' 5)) )
    -- )
    $ map (map (map combineDim))
    -- output sample:
    -- ( Tuple ''
    --         ( (Tuple 'series1' (Tuple 'dimA' 1 : Tuple 'dimB' 2 : Tuple 'dimB' 3))
    --         : (Tuple 'series2' (Tuple 'dimA' 1 : Tuple 'dimB' 2 : Tuple 'dimB' 3)) )
    -- )
    $ map (map (L.catMaybes <<< map combineSerie))
    -- output sample:
    -- ( Tuple ''
    --         ( (Tuple 'series1' (Tuple 'dimA' 1) : Tuple 'series1' (Tuple 'dimB' 2) : Tuple 'series1' (Tuple 'dimB' 3))
    --         : (Tuple 'series2' (Tuple 'dimA' 1) : Tuple 'series2' (Tuple 'dimB' 2) : Tuple 'series2' (Tuple 'dimB' 3)) )
    -- )
    $ map (map (L.groupBy ((==) `on` fst) <<< L.sortBy (compare `on` fst)))
    -- output sample:
    -- ( Tuple ''
    --         ( Tuple 'series1' (Tuple 'dimA' 1) : Tuple 'series1' (Tuple 'dimB' 2)
    --         : Tuple 'series1' (Tuple 'dimB' 3) : Tuple 'series2' (Tuple 'dimA' 1)
    --         : Tuple 'series2' (Tuple 'dimB' 2) : Tuple 'series2' (Tuple 'dimB' 3) )
    -- )
    $ L.catMaybes
    $ map combineDup
    -- output sample:
    -- (( Tuple '' (Tuple 'series1' (Tuple 'dimA' 1)) : Tuple '' (Tuple 'series1' (Tuple 'dimB' 2))
    --  : Tuple '' (Tuple 'series1' (Tuple 'dimB' 3)) : Tuple '' (Tuple 'series2' (Tuple 'dimA' 1))
    --  : Tuple '' (Tuple 'series2' (Tuple 'dimB' 2)) : Tuple '' (Tuple 'series2' (Tuple 'dimB' 3)) ))
    $ L.groupBy ((==) `on` fst)
    $ L.sortBy (compare `on` fst)
    -- output sample:
    -- ( Tuple '' (Tuple 'series1' (Tuple 'dimA' 1)) : Tuple '' (Tuple 'series1' (Tuple 'dimB' 2))
    -- : Tuple '' (Tuple 'series1' (Tuple 'dimB' 3)) : Tuple '' (Tuple 'series2' (Tuple 'dimA' 1))
    -- : Tuple '' (Tuple 'series2' (Tuple 'dimB' 2)) : Tuple '' (Tuple 'series2' (Tuple 'dimB' 3)) )
    $ L.catMaybes
    $ map filterInvalid
    $ tagDuplications duplications
    $ tagSeriesKey seriesKeys
    $ L.zip dimensions values

  where
  dimensions ∷ List (Maybe String)
  dimensions = fromMaybe Nil $ axises.dimensions !! 0

  values ∷ List (Maybe Number)
  values = fromMaybe Nil $ axises.measures !! 0

  series ∷ List (Maybe String)
  series = fromMaybe Nil $ axises.series !! 0

  duplications ∷ List (Maybe String)
  duplications = fromMaybe Nil $ axises.series !! 1

  agg ∷ Maybe Aggregation
  agg = fromMaybe (Just Sum) $ join (axises.aggregations !! 0)

  distinctDims ∷ List String
  distinctDims = L.sort $ L.catMaybes $ L.nub dimensions

  tagDuplications
    ∷ List (Maybe String)
    → List (Tuple SeriesKey (Tuple (Maybe String) (Maybe Number)))
    → List (Tuple (Maybe String) (Tuple SeriesKey (Tuple (Maybe String) (Maybe Number))))
  tagDuplications d v = case L.null d of
    true → map (Tuple Nothing) v
    false → L.zip d v

  tagSeriesKey
    ∷ List SeriesKey
    → List (Tuple (Maybe String) (Maybe Number))
    → List (Tuple SeriesKey (Tuple (Maybe String) (Maybe Number)))
  tagSeriesKey k v = case L.null k of
    true → map (Tuple Nothing) v
    false → L.zip k v

  seriesKeys ∷ List SeriesKey
  seriesKeys = map (\x → mkSeriesKey x Nothing) series

  mkSeriesKey ∷ Maybe String → Maybe String → SeriesKey
  mkSeriesKey f s =
    f >>= \f → pure $ Tuple f s

  filterInvalid
    ∷ Tuple (Maybe String) (Tuple SeriesKey (Tuple (Maybe String) (Maybe Number)))
    → Maybe (Tuple String (Tuple String (Tuple String Number)))
  filterInvalid (a × b × c × d) =
    case c, d of
      Just c', Just d' →
        Just $ Tuple
                ( case a of
                    Just a' → a'
                    _ → ""
                )
                (Tuple (keyName (Tuple "" b)) (Tuple c' d'))
      _, _ → Nothing

  combineDup
    ∷ List (Tuple String (Tuple String (Tuple String Number)))
    → Maybe (Tuple String (List (Tuple String (Tuple String Number))))
  combineDup x = do
    d ← L.head $ map fst x
    pure $ Tuple d $ map snd x

  combineSerie
    ∷ List (Tuple String (Tuple String Number))
    → Maybe (Tuple String (List (Tuple String Number)))
  combineSerie x = do
    k ← L.head $ map fst x
    pure $ Tuple k $ map snd x

  combineDim
    ∷ Tuple String (List (Tuple String Number))
    → Tuple String (List (Tuple String Number))
  combineDim x =
    map (L.catMaybes <<< map combine <<< L.groupBy ((==) `on` fst) <<< L.sortBy (compare `on` fst)) x
    where
    combine ∷ List (Tuple String Number) → Maybe (Tuple String Number)
    combine x = do
      d ← (L.head $ map fst x)
      pure $ Tuple d (applyAggregation $ map snd x)

  applyAggregation ∷ List Number → Number
  applyAggregation a = case agg of
    Just agg' → runAggregation agg' a
    _ → runAggregation Sum a

  checkDimAndTransform
    ∷ Tuple String (List (Tuple String Number))
    → Maybe (Tuple String (Array Number))
  checkDimAndTransform a = case (L.length $ snd a) == L.length distinctDims of
    true → Just $
      Tuple
        (fst a)
        (A.fromFoldable $ map snd $ snd a)
    _ → Nothing

buildRadar
  ∷ Map JCursor Ax.Axis
  → ChartConfiguration
  → EC.Option
buildRadar axises conf =
    EC.Option EC.optionDefault
      { series = Just $ map Just series
      , polar = Just polars
      , tooltip = Just tooltip
      , legend = Just $ legends
      , color = Just colors
      }
  where

  legends ∷ EC.Legend
  legends =
    EC.Legend EC.legendDefault
      { "data" = Just $ map EC.legendItemDefault serieNames
      , x = Just EC.XLeft
      , y = Just EC.YTop
      , orient = Just EC.Vertical
      , textStyle = Just $ EC.TextStyle EC.textStyleDefault
          { fontFamily = Just "Ubuntu" }
      }

  tooltip ∷ EC.Tooltip
  tooltip = EC.Tooltip $ EC.tooltipDefault
    { trigger = Just EC.TriggerAxis
    , textStyle = Just $ EC.TextStyle EC.textStyleDefault
        { fontFamily = Just "Ubuntu"
        , fontSize = Just 12.0
        }
    }

  serieNames ∷ Array String
  serieNames =
    A.nub
      $ A.filter (\e → e /= "")
      $ A.concat
      $ map (map fst)
      $ map snd
      $ snd extracted

  polars ∷ Array EC.Polar
  polars =
    let
      numPolar = A.length $ snd extracted
    in
      map (mkPolar numPolar) (A.range 0 $ numPolar - 1)
    where
    mkPolar ∷ Int → Int → EC.Polar
    mkPolar n i =
      let
        -- max number of plot in one row: 4
        maxCol = 4
        nRow = (n / maxCol + 1)
        nCol = if n <= maxCol then n else maxCol
        row = toNumber (i / nCol)
        col = (toNumber i) % (toNumber nCol)
      in
        EC.Polar EC.polarDefault
          { indicator = Just $ mkIndicatorSet i
          , center = Just $ Tuple
                            ( EC.Percent (100.0 * (2.0 * col + 1.0) / (toNumber (nCol * 2))) )
                            ( EC.Percent (100.0 * (2.0 * row + 1.0) / (toNumber (nRow * 2))) )
          , radius = Just $ EC.Percent (75.0 / (if nRow > nCol then toNumber nRow else toNumber nCol))
          }

  mkIndicatorSet ∷ Int → Array EC.Indicator
  mkIndicatorSet i =
    let
      dupName = fromMaybe "" $ (map fst $ snd extracted) !! i
    in
      map (mkIndicator dupName) (fst extracted)

  mkIndicator ∷ String → String → EC.Indicator
  mkIndicator dupName dim =
    EC.Indicator EC.indicatorDefault
      { text = Just $ dupName <> (if dupName == "" then "" else ": ") <> dim
      , min = minVal
      , max = maxVal
      }

  allValues ∷ Array Number
  allValues = A.concat
    $ map snd
    $ A.concat
    $ map snd
    $ snd extracted

  minVal ∷ Maybe Number
  minVal = minimum allValues

  maxVal ∷ Maybe Number
  maxVal = maximum allValues

  series ∷ Array EC.Series
  series = mkSeries extracted

  extracted ∷ RadarData
  extracted = radarData $ buildChartAxises axises conf

mkSeries
  ∷ RadarData
  → (Array EC.Series)
mkSeries rData =
  map serie (A.zip (A.range 0 ((A.length $ snd rData) - 1)) (snd rData))
  where
  serie
    ∷ Tuple Int (Tuple String (Array (Tuple String (Array Number))))
    → EC.Series
  serie (Tuple ind (Tuple dup a)) =
    EC.RadarSeries
      { common: EC.universalSeriesDefault
        { name = guard (dup == "") $> dup
        , tooltip = if A.null a
                    then Just $ EC.Tooltip $ EC.tooltipDefault
                      -- To overwrite the top tooltip display config.
                      -- Other configurations here cannot overwrite the top one,
                      -- maybe due to some echarts' bugs
                      { trigger = Just EC.TriggerItem
                      , formatter = Just $ EC.Template " "
                      , show = Just false }
                    else Nothing
        }
      , radarSeries: EC.radarSeriesDefault
        { polarIndex = Just $ toNumber ind
        , "data" = Just if A.null a
                   then [blankData]
                   else map makeData a
        , symbol = Just if A.null a
                   then EC.NoSymbol
                   else EC.Circle
        }
      }

  makeData
    ∷ Tuple String (Array Number)
    → EC.ItemData
  makeData (Tuple name values) = EC.Dat
    { name: Just name
    , value: EC.Many values
    , tooltip: Nothing
    , itemStyle: Nothing
    , selected: Nothing
    }

  blankData ∷ EC.ItemData
  blankData = EC.Dat
    { name: Nothing
      -- set a value to avoid display issue
    , value: EC.Many [0.0]
    , tooltip: Just $ EC.Tooltip $ EC.tooltipDefault
      { show = Just false }
    , itemStyle: Nothing
    , selected: Nothing
    }

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Chart.BuildOptions.Radar where

import SlamData.Prelude

import Data.Argonaut (JCursor)
import Data.Foldable (minimum, maximum)
import Data.Array ((!!))
import Data.Array as A
import Data.Function (on)
import Data.List (List(..))
import Data.List as L
import Data.Map (Map)
import Data.Int (toNumber)
import Math ((%))

import ECharts as EC

import SlamData.Workspace.Card.Chart.Aggregation (Aggregation(..), runAggregation)
import SlamData.Workspace.Card.Chart.Axis as Ax
import SlamData.Workspace.Card.Chart.ChartConfiguration (ChartConfiguration)
import SlamData.Workspace.Card.Chart.BuildOptions.Common (SeriesKey, ChartAxises, colors, buildChartAxises, keyName)

--sample data:
-- Tuple ['dimA', 'dimB']
--       [ (Tuple '' [(Tuple 'series1' [1, 5]), (Tuple 'series2' [1, 5])]) ]
type RadarData = Tuple (Array String) (Array (Tuple String (Array (Tuple String (Array Number)))))

radarData ∷ ChartAxises → RadarData
radarData axises = Tuple (A.fromFoldable distinctDims) $
  A.fromFoldable
    $ map (\x → Tuple
                  (fst x)
                  (A.fromFoldable $ L.catMaybes $ map checkDimAndTransform $ snd x))
    -- output sample:
    -- ( Tuple ''
    --         ( (Tuple 'series1' (Tuple 'dimA' 1 : Tuple 'dimB' 5))
    --         : (Tuple 'series2' (Tuple 'dimA' 1 : Tuple 'dimB' 5)) )
    -- )
    $ map (\x → Tuple
                  (fst x)
                  (map combineDim $ snd x))
    -- output sample:
    -- ( Tuple ''
    --         ( (Tuple 'series1' (Tuple 'dimA' 1 : Tuple 'dimB' 2 : Tuple 'dimB' 3))
    --         : (Tuple 'series2' (Tuple 'dimA' 1 : Tuple 'dimB' 2 : Tuple 'dimB' 3)) )
    -- )
    $ map (\x → Tuple
                  (fst x)
                  (L.catMaybes $ map combineSerie $ snd x))
    -- output sample:
    -- ( Tuple ''
    --         ( (Tuple 'series1' (Tuple 'dimA' 1) : Tuple 'series1' (Tuple 'dimB' 2) : Tuple 'series1' (Tuple 'dimB' 3))
    --         : (Tuple 'series2' (Tuple 'dimA' 1) : Tuple 'series2' (Tuple 'dimB' 2) : Tuple 'series2' (Tuple 'dimB' 3)) )
    -- )
    $ map (\x → Tuple
                  (fst x)
                  (L.groupBy ((==) `on` fst) $ L.sortBy (compare `on` fst) $ snd x))
    -- output sample:
    -- ( Tuple ''
    --         ( Tuple 'series1' (Tuple 'dimA' 1) : Tuple 'series1' (Tuple 'dimB' 2)
    --         : Tuple 'series1' (Tuple 'dimB' 3) : Tuple 'series2' (Tuple 'dimA' 1)
    --         : Tuple 'series2' (Tuple 'dimB' 2) : Tuple 'series2' (Tuple 'dimB' 3) )
    -- )
    $ L.catMaybes
    $ map combineDup
    -- output sample:
    -- (( Tuple '' (Tuple 'series1' (Tuple 'dimA' 1)) : Tuple '' (Tuple 'series1' (Tuple 'dimB' 2))
    --  : Tuple '' (Tuple 'series1' (Tuple 'dimB' 3)) : Tuple '' (Tuple 'series2' (Tuple 'dimA' 1))
    --  : Tuple '' (Tuple 'series2' (Tuple 'dimB' 2)) : Tuple '' (Tuple 'series2' (Tuple 'dimB' 3)) ))
    $ L.groupBy ((==) `on` fst)
    $ L.sortBy (compare `on` fst)
    -- output sample:
    -- ( Tuple '' (Tuple 'series1' (Tuple 'dimA' 1)) : Tuple '' (Tuple 'series1' (Tuple 'dimB' 2))
    -- : Tuple '' (Tuple 'series1' (Tuple 'dimB' 3)) : Tuple '' (Tuple 'series2' (Tuple 'dimA' 1))
    -- : Tuple '' (Tuple 'series2' (Tuple 'dimB' 2)) : Tuple '' (Tuple 'series2' (Tuple 'dimB' 3)) )
    $ L.catMaybes
    $ map filterInvalid
    $ tagDuplications duplications
    $ tagSeriesKey seriesKeys
    $ L.zip dimensions values

  where
  dimensions ∷ List (Maybe String)
  dimensions = fromMaybe Nil $ axises.dimensions !! 0

  values ∷ List (Maybe Number)
  values = fromMaybe Nil $ axises.measures !! 0

  series ∷ List (Maybe String)
  series = fromMaybe Nil $ axises.series !! 0

  duplications ∷ List (Maybe String)
  duplications = fromMaybe Nil $ axises.series !! 1

  agg ∷ Maybe Aggregation
  agg = fromMaybe (Just Sum) $ join (axises.aggregations !! 0)

  distinctDims ∷ List String
  distinctDims = L.sort $ L.catMaybes $ L.nub dimensions

  tagDuplications
    ∷ List (Maybe String)
    → List (Tuple SeriesKey (Tuple (Maybe String) (Maybe Number)))
    → List (Tuple (Maybe String) (Tuple SeriesKey (Tuple (Maybe String) (Maybe Number))))
  tagDuplications d v = case L.null d of
    true → map (Tuple Nothing) v
    false → L.zip d v

  tagSeriesKey
    ∷ List SeriesKey
    → List (Tuple (Maybe String) (Maybe Number))
    → List (Tuple SeriesKey (Tuple (Maybe String) (Maybe Number)))
  tagSeriesKey k v = case L.null k of
    true → map (Tuple Nothing) v
    false → L.zip k v

  seriesKeys ∷ List SeriesKey
  seriesKeys = map (\x → mkSeriesKey x Nothing) series

  mkSeriesKey ∷ Maybe String → Maybe String → SeriesKey
  mkSeriesKey f s =
    f >>= \f → pure $ Tuple f s

  filterInvalid
    ∷ Tuple (Maybe String) (Tuple SeriesKey (Tuple (Maybe String) (Maybe Number)))
    → Maybe (Tuple String (Tuple String (Tuple String Number)))
  filterInvalid (Tuple a (Tuple b (Tuple c d))) =
    case c, d of
      Just c', Just d' →
        Just $ Tuple
                ( case a of
                    Just a' → a'
                    _ → ""
                )
                (Tuple (keyName (Tuple "" b)) (Tuple c' d'))
      _, _ → Nothing

  combineDup
    ∷ List (Tuple String (Tuple String (Tuple String Number)))
    → Maybe (Tuple String (List (Tuple String (Tuple String Number))))
  combineDup x = do
    d ← (L.head $ map fst x)
    pure $ Tuple d $ map snd x

  combineSerie
    ∷ List (Tuple String (Tuple String Number))
    → Maybe (Tuple String (List (Tuple String Number)))
  combineSerie x = do
    k ← (L.head $ map fst x)
    pure $ Tuple k $ map snd x

  combineDim
    ∷ Tuple String (List (Tuple String Number))
    → Tuple String (List (Tuple String Number))
  combineDim x =
    Tuple
      (fst x)
      (L.catMaybes $ map combine groupsByDim)
    where
    groupsByDim ∷ List (List (Tuple String Number))
    groupsByDim = L.groupBy ((==) `on` fst) $ L.sortBy (compare `on` fst) $ snd x

    combine ∷ List (Tuple String Number) → Maybe (Tuple String Number)
    combine x = do
      d ← (L.head $ map fst x)
      pure $ Tuple d (applyAggregation $ map snd x)

  applyAggregation ∷ List Number → Number
  applyAggregation a = case agg of
    Just agg' → runAggregation agg' a
    _ → runAggregation Sum a

  checkDimAndTransform
    ∷ Tuple String (List (Tuple String Number))
    → Maybe (Tuple String (Array Number))
  checkDimAndTransform a = case (L.length $ snd a) == L.length distinctDims of
    true → Just $
      Tuple
        (fst a)
        (A.fromFoldable $ map snd $ snd a)
    _ → Nothing

buildRadar
  ∷ Map JCursor Ax.Axis
  → ChartConfiguration
  → EC.Option
buildRadar axises conf = case preSeries of
  series →
    EC.Option EC.optionDefault
      { series = Just $ map Just series
      , polar = Just polars
      , tooltip = Just tooltip
      , legend = Just $ legends
      , color = Just colors
      }
  where

  legends ∷ EC.Legend
  legends =
    EC.Legend EC.legendDefault
      { "data" = Just $ map EC.legendItemDefault serieNames
      , x = Just EC.XLeft
      , y = Just EC.YTop
      , orient = Just EC.Vertical
      , textStyle = Just $ EC.TextStyle EC.textStyleDefault
          { fontFamily = Just "Ubuntu" }
      }

  tooltip ∷ EC.Tooltip
  tooltip = EC.Tooltip $ EC.tooltipDefault
    { trigger = Just EC.TriggerAxis
    , textStyle = Just $ EC.TextStyle EC.textStyleDefault
        { fontFamily = Just "Ubuntu"
        , fontSize = Just 12.0
        }
    }

  serieNames ∷ Array String
  serieNames =
    A.nub
      $ A.filter (\e → e /= "")
      $ A.concat
      $ map (map fst)
      $ map snd
      $ snd extracted

  polars ∷ Array EC.Polar
  polars =
    let
      numPolar = A.length $ snd extracted
    in
      map (mkPolar numPolar) (A.range 0 $ numPolar - 1)
    where
    mkPolar ∷ Int → Int → EC.Polar
    mkPolar n i =
      let
        -- max number of plot in one row: 4
        maxCol = 4
        nRow = (n / maxCol + 1)
        nCol = if n <= maxCol then n else maxCol
        row = toNumber (i / nCol)
        col = (toNumber i) % (toNumber nCol)
      in
        EC.Polar EC.polarDefault
          { indicator = Just $ mkIndicatorSet i
          , center = Just $ Tuple
                            ( EC.Percent (100.0 * (2.0 * col + 1.0) / (toNumber (nCol * 2))) )
                            ( EC.Percent (100.0 * (2.0 * row + 1.0) / (toNumber (nRow * 2))) )
          , radius = Just $ EC.Percent (75.0 / (if nRow > nCol then toNumber nRow else toNumber nCol))
          }

  mkIndicatorSet ∷ Int → Array EC.Indicator
  mkIndicatorSet i =
    let
      dupName = fromMaybe "" $ (map fst $ snd extracted) !! i
    in
      map (mkIndicator dupName) (fst extracted)

  mkIndicator ∷ String → String → EC.Indicator
  mkIndicator dupName dim =
    EC.Indicator EC.indicatorDefault
      { text = Just $ dupName <> (if dupName == "" then "" else ": ") <> dim
      , min = minVal
      , max = maxVal
      }

  allValues ∷ Array Number
  allValues = A.concat
    $ map snd
    $ A.concat
    $ map snd
    $ snd extracted

  minVal ∷ Maybe Number
  minVal = case A.null allValues of
    true → Nothing
    false → minimum allValues

  maxVal ∷ Maybe Number
  maxVal = case A.null allValues of
    true → Nothing
    false → maximum allValues

  preSeries ∷ Array EC.Series
  preSeries = mkSeries extracted

  extracted ∷ RadarData
  extracted = radarData $ buildChartAxises axises conf

mkSeries
  ∷ RadarData
  → (Array EC.Series)
mkSeries rData =
  map serie (A.zip (A.range 0 ((A.length $ snd rData) - 1)) (snd rData))
  where
  serie
    ∷ Tuple Int (Tuple String (Array (Tuple String (Array Number))))
    → EC.Series
  serie (Tuple ind (Tuple dup a)) =
    EC.RadarSeries
      { common: EC.universalSeriesDefault
        { name = if dup ≡ ""
                 then Nothing
                 else Just dup
        , tooltip = if A.null a
                    then Just $ EC.Tooltip $ EC.tooltipDefault
                      -- To overwrite the top tooltip display config.
                      -- Other configurations here cannot overwrite the top one,
                      -- maybe due to some echarts' bugs
                      { trigger = Just EC.TriggerItem
                      , formatter = Just $ EC.Template " "
                      , show = Just false }
                    else Nothing
        }
      , radarSeries: EC.radarSeriesDefault
        { polarIndex = Just $ toNumber ind
        , "data" = if A.null a
                   then Just [blankData]
                   else Just $ map makeData a
        , symbol = if A.null a
                   then Just $ EC.NoSymbol
                   else Just $ EC.Circle
        }
      }

  makeData
    ∷ Tuple String (Array Number)
    → EC.ItemData
  makeData (Tuple name values) = EC.Dat
    { name: Just name
    , value: EC.Many values
    , tooltip: Nothing
    , itemStyle: Nothing
    , selected: Nothing
    }

  blankData ∷ EC.ItemData
  blankData = EC.Dat
    { name: Nothing
      -- set a value to avoid display issue
    , value: EC.Many [0.0]
    , tooltip: Just $ EC.Tooltip $ EC.tooltipDefault
      { show = Just false }
    , itemStyle: Nothing
    , selected: Nothing
    }


formatted

formatted

module Blueprint.Components.Alert where

import Blueprint.ComponentsClasses (alertClass)
import Blueprint.PropTypes (Intent, Prop, PropsEx, UnknownEventType, UnknownStyleType)
import React

type AlertProps = AlertPropsEx ()

-- DISCUSS: Do we need this to be extensible?
type AlertPropsEx r  = PropsEx
  ( cancelButtonText :: String
  , confirmButtonText :: String
  , iconName :: String
  , intent :: Intent
  , isOpen :: Boolean
  , style :: UnknownStyleType
  , onCancel ::  UnknownEventType
  , onConfirm :: UnknownEventType
  | r
  )

alert :: Prop AlertProps -> Array ReactElement -> ReactElement
alert = createElement alertClass

module Blueprint.Components.Alert where

import React
import Blueprint.ComponentsClasses (alertClass)
import Blueprint.PropTypes

type AlertProps  = AlertPropsEx ()

type AlertPropsEx  r  = IPropsEx ( cancelButtonText :: String
                                 , confirmButtonText :: String
                                 , iconName :: String
                                 , intent :: Intent
                                 , isOpen :: Boolean
                                 , style :: UnknownStyleType
                                 , onCancel ::  UnknownEventType
                                 , onConfirm :: UnknownEventType
                                 | r
                                 )

alert :: Prop AlertProps -> Array ReactElement -> ReactElement
alert = createElement alertClass


add Detail

add Detail

module Data.GetStampRallyResponse where

import Data.Foreign (F, Foreign, readString)
import Data.Foreign.Class (class IsForeign, readProp)
import Data.Foreign.Index (prop)
import Data.Foreign.Null (readNull, unNull)
import Data.Maybe (maybe)
import Data.Show (class Show, show)
import Prelude (($), (<>), bind, id, pure)

data Detail = Detail { id :: Int
                     , name :: String
                     , value :: String
                     }

instance detailShow :: Show Detail where
  show (Detail { id
               , name
               , value
               }) =
    "(Detail { "
    <> "id: " <> show id <> ", "
    <> "name: " <> show name <> ", "
    <> "value: " <> show value <> " "
    <> "})"

instance detailIsForeign :: IsForeign Detail where
  read v = do
    id <- readProp "id" v
    name <- readProp "name" v
    value <- readProp "value" v
    pure $ Detail { id
                  , name
                  , value
                  }

data GetStampRallyResponse = GetStampRallyResponse
  { id :: String
  , description :: String
  , details :: Array Detail
  , display :: Boolean
  , displayEndDatetime :: String -- DateTimeString
  , displayName :: String
  , displayStartDatetime :: String -- DateTimeString
  , endDatetime :: String -- DateTimeString
  -- , images :: [] -- TODO
  , mapVisible :: Boolean
  , open :: Boolean
  , spotRadiusDefault :: Number
  , spotStampByLocationDefault :: Boolean
  , spotStampByQrCodeDefault :: Boolean
  , startDatetime :: String -- DateTimeString
  , tagline :: String
  , themeBackgroundPattern :: Int
  , themeRewardPattern :: Int
  , themeSpotPattern :: Int
  }

instance getStampRallyResponseShow :: Show GetStampRallyResponse where
  show (GetStampRallyResponse { id
                              , details
                              , description
                              , display
                              , displayEndDatetime
                              , displayName
                              , displayStartDatetime
                              , endDatetime
                              , mapVisible
                              , open
                              , spotRadiusDefault
                              , spotStampByLocationDefault
                              , spotStampByQrCodeDefault
                              , startDatetime
                              , tagline
                              , themeBackgroundPattern
                              , themeRewardPattern
                              , themeSpotPattern
                              }) =
    "(GetStampRallyResponse { "
    <> "id: " <> show id <> ", "
    <> "details: " <> show details <> ", "
    <> "description: " <> show description <> ", "
    <> "display: " <> show display <> ", "
    <> "displayEndDatetime: " <> show displayEndDatetime <> ", "
    <> "displayName: " <> show displayName <> ", "
    <> "displayStartDatetime: " <> show displayStartDatetime <> ", "
    <> "endDatetime: " <> show endDatetime <> ", "
    <> "mapVisible: " <> show mapVisible <> ", "
    <> "open: " <> show open <> ", "
    <> "spotRadiusDefault: " <> show spotRadiusDefault <> ", "
    <> "spotStampByLocationDefault: "
      <> show spotStampByLocationDefault
      <> ", "
    <> "spotStampByQrCodeDefault: " <> show spotStampByQrCodeDefault <> ", "
    <> "startDatetime: " <> show startDatetime <> ", "
    <> "tagline: " <> show tagline <> ", "
    <> "themeBackgroundPattern: " <> show themeBackgroundPattern <> ", "
    <> "themeRewardPattern: " <> show themeRewardPattern <> ", "
    <> "themeSpotPattern: " <> show themeSpotPattern <> " "
    <> "})"

readNullProp :: String -> String -> Foreign -> F String
readNullProp p defaultValue o = do
  pv <- prop p o
  ns <- readNull readString pv
  pure $ maybe defaultValue id $ unNull ns

instance getStampRallyResponseIsForeign :: IsForeign GetStampRallyResponse where
  read value = do
    id <- readProp "id" value
    details <- readProp "details" value
    description <- readNullProp "description" "" value
    display <- readProp "display" value
    displayEndDatetime <- readProp "displayEndDatetime" value
    displayName <- readProp "displayName" value
    displayStartDatetime <- readProp "displayStartDatetime" value
    endDatetime <- readProp "endDatetime" value
    mapVisible <- readProp "mapVisible" value
    open <- readProp "open" value
    spotRadiusDefault <- readProp "spotRadiusDefault" value
    spotStampByLocationDefault <- readProp "spotStampByLocationDefault" value
    spotStampByQrCodeDefault <- readProp "spotStampByQrCodeDefault" value
    startDatetime <- readProp "startDatetime" value
    tagline <- readNullProp "tagline" "" value
    themeBackgroundPattern <- readProp "themeBackgroundPattern" value
    themeRewardPattern <- readProp "themeRewardPattern" value
    themeSpotPattern <- readProp "themeSpotPattern" value
    pure $ GetStampRallyResponse { id
                                 , details
                                 , description
                                 , display
                                 , displayEndDatetime
                                 , displayName
                                 , displayStartDatetime
                                 , endDatetime
                                 , mapVisible
                                 , open
                                 , spotRadiusDefault
                                 , spotStampByLocationDefault
                                 , spotStampByQrCodeDefault
                                 , startDatetime
                                 , tagline
                                 , themeBackgroundPattern
                                 , themeRewardPattern
                                 , themeSpotPattern
                                 }

module Data.GetStampRallyResponse where

import Data.Foreign (F, Foreign, readString)
import Data.Foreign.Class (class IsForeign, readProp)
import Data.Foreign.Index (prop)
import Data.Foreign.Null (readNull, unNull)
import Data.Maybe (maybe)
import Data.Show (class Show, show)
import Prelude (($), (<>), bind, id, pure)

data GetStampRallyResponse = GetStampRallyResponse
  { id :: String
  , description :: String
  -- , details :: [] -- TODO
  , display :: Boolean
  , displayEndDatetime :: String -- DateTimeString
  , displayName :: String
  , displayStartDatetime :: String -- DateTimeString
  , endDatetime :: String -- DateTimeString
  -- , images :: [] -- TODO
  , mapVisible :: Boolean
  , open :: Boolean
  , spotRadiusDefault :: Number
  , spotStampByLocationDefault :: Boolean
  , spotStampByQrCodeDefault :: Boolean
  , startDatetime :: String -- DateTimeString
  , tagline :: String
  , themeBackgroundPattern :: Int
  , themeRewardPattern :: Int
  , themeSpotPattern :: Int
  }

instance getStampRallyResponseShow :: Show GetStampRallyResponse where
  show (GetStampRallyResponse { id
                              , description
                              , display
                              , displayEndDatetime
                              , displayName
                              , displayStartDatetime
                              , endDatetime
                              , mapVisible
                              , open
                              , spotRadiusDefault
                              , spotStampByLocationDefault
                              , spotStampByQrCodeDefault
                              , startDatetime
                              , tagline
                              , themeBackgroundPattern
                              , themeRewardPattern
                              , themeSpotPattern
                              }) =
    "(GetStampRallyResponse { "
    <> "id: " <> show id <> ", "
    <> "description: " <> show description <> ", "
    <> "display: " <> show display <> ", "
    <> "displayEndDatetime: " <> show displayEndDatetime <> ", "
    <> "displayName: " <> show displayName <> ", "
    <> "displayStartDatetime: " <> show displayStartDatetime <> ", "
    <> "endDatetime: " <> show endDatetime <> ", "
    <> "mapVisible: " <> show mapVisible <> ", "
    <> "open: " <> show open <> ", "
    <> "spotRadiusDefault: " <> show spotRadiusDefault <> ", "
    <> "spotStampByLocationDefault: "
      <> show spotStampByLocationDefault
      <> ", "
    <> "spotStampByQrCodeDefault: " <> show spotStampByQrCodeDefault <> ", "
    <> "startDatetime: " <> show startDatetime <> ", "
    <> "tagline: " <> show tagline <> ", "
    <> "themeBackgroundPattern: " <> show themeBackgroundPattern <> ", "
    <> "themeRewardPattern: " <> show themeRewardPattern <> ", "
    <> "themeSpotPattern: " <> show themeSpotPattern <> " "
    <> "})"

readNullProp :: String -> String -> Foreign -> F String
readNullProp p defaultValue o = do
  pv <- prop p o
  ns <- readNull readString pv
  pure $ maybe defaultValue id $ unNull ns

instance getStampRallyResponseIsForeign :: IsForeign GetStampRallyResponse where
  read value = do
    id <- readProp "id" value
    description <- readNullProp "description" "" value
    display <- readProp "display" value
    displayEndDatetime <- readProp "displayEndDatetime" value
    displayName <- readProp "displayName" value
    displayStartDatetime <- readProp "displayStartDatetime" value
    endDatetime <- readProp "endDatetime" value
    mapVisible <- readProp "mapVisible" value
    open <- readProp "open" value
    spotRadiusDefault <- readProp "spotRadiusDefault" value
    spotStampByLocationDefault <- readProp "spotStampByLocationDefault" value
    spotStampByQrCodeDefault <- readProp "spotStampByQrCodeDefault" value
    startDatetime <- readProp "startDatetime" value
    tagline <- readNullProp "tagline" "" value
    themeBackgroundPattern <- readProp "themeBackgroundPattern" value
    themeRewardPattern <- readProp "themeRewardPattern" value
    themeSpotPattern <- readProp "themeSpotPattern" value
    pure $ GetStampRallyResponse { id
                                 , description
                                 , display
                                 , displayEndDatetime
                                 , displayName
                                 , displayStartDatetime
                                 , endDatetime
                                 , mapVisible
                                 , open
                                 , spotRadiusDefault
                                 , spotStampByLocationDefault
                                 , spotStampByQrCodeDefault
                                 , startDatetime
                                 , tagline
                                 , themeBackgroundPattern
                                 , themeRewardPattern
                                 , themeSpotPattern
                                 }


better usage of space

better usage of space

module Main where

import Data.Void
import Data.Tuple
import Data.Maybe
import Data.Either
import Data.Array (zipWith, length, modifyAt, deleteAt, (..), (!!), map)

import qualified Data.String as S

import Debug.Trace

import Control.Functor (($>))
import Control.Alternative
import Control.Bind
import Control.Monad.Eff

import DOM

import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Types
import Data.DOM.Simple.Window

import Halogen
import Halogen.Signal
import Halogen.Component

import qualified Halogen.Mixin.UndoRedo as Undo
import qualified Halogen.Mixin.Router as Router

import qualified Halogen.HTML as H
import qualified Halogen.HTML.Attributes as A
import qualified Halogen.HTML.Events as A
import qualified Halogen.HTML.Events.Forms as A
import qualified Halogen.HTML.Events.Handler as E

import qualified Halogen.Themes.Bootstrap3 as B
import qualified Halogen.Themes.Bootstrap3.InputGroup as BI

import Models.Action
import Models.Channel
import Models.Group
import Models.Input
import Models.User
import Models.Message
import Models.State
import Views.Channel
--import Views.Input
import Views.Message

appendToBody :: forall eff. HTMLElement -> Eff (dom :: DOM | eff) Unit
appendToBody e = document globalWindow >>= (body >=> flip appendChild e)

user1 :: User
user1 =
    { name: "Harry"
    , email: "harry@hogwarts.com"
    }

user2 :: User
user2 =
    { name: "Ben"
    , email: "ben@kenobi.ch"
    }

messages :: [Message]
messages =
    [
        { from: user1
        , to: user2
        , message: TextMessage
            { text: """Two households, both alike in dignity,
  In fair Verona, where we lay our scene,
From ancient grudge break to new mutiny,
  Where civil blood makes civil hands unclean.
From forth the fatal loins of these two foes
  A pair of star-cross'd lovers take their life;
Whose misadventur'd piteous overthrows
  Doth with their death bury their parents' strife.
The fearful passage of their death-mark'd love,
  And the continuance of their parents' rage,
Which but their children's end naught could remove,
  Is now the two hours' traffic of our stage;
The which, if you with patient ears attend,
What here shall miss, our toil shall strive to mend."""
            }
        }
    ,
        { from: user2
        , to: user1
        , message: TextMessage
            { text: """
            Actual happiness always looks pretty squalid in comparison with the overcompensations for misery.
            And, of course, stability isn't nearly so spectacular as instability.
            And being contented has none of the glamour of a good fight against misfortune, none of the picturesqueness of a struggle with temptation, or a fatal overthrow by passion or doubt. Happiness is never grand.
            - Aldous Huxley, Brave New World"""
            }
        }
    ,
        { from: user1
        , to: user2
        , message: TextMessage
            { text: """Most human beings have an almost infinite capacity for taking things for granted. - Aldous Huxley, Brave New World"""
            }
        }
    ,
        { from: user2
        , to: user1
        , message: TextMessage
            { text: """
            Actual happiness always looks pretty squalid in comparison with the overcompensations for misery.
            And, of course, stability isn't nearly so spectacular as instability.
            And being contented has none of the glamour of a good fight against misfortune, none of the picturesqueness of a struggle with temptation, or a fatal overthrow by passion or doubt. Happiness is never grand.
            - Aldous Huxley, Brave New World"""
            }
        }
    ,
        { from: user2
        , to: user1
        , message: CodeMessage
            { language: "haskell"
            , text: "add a b = a + b" }
        }
    ,
        { from: user1
        , to: user2
        , message: CodeMessage
            { language: "javascript"
            , text: "function(a, b) { return a + b; }" }
        }
    ]

channels :: [ Channel ]
channels =
    [ Channel { name: "PureScript" }
    , Channel { name: "F#" }
    , Channel { name: "Haskell" }
    , Channel { name: "Elm" }
    , Channel { name: "Idris" }
    ]

testState :: State
testState =
	{ messages: messages
	, user: Nothing
	, channels: channels
	, selectedChannel: Just (Channel { name: "PureScript" })
	}

-- | The view is a state machine, consuming inputs, and generating HTML documents which in turn, generate new inputs
ui :: forall p m. (Alternative m) => Component m _ _
ui = render <$> stateful testState update
    where
    render :: State -> H.HTML (m _)
    render st =
        H.div
            [ A.class_ B.container ]
            [ H.div
                [ A.class_ B.row ]
                [ H.div
                    [ A.class_ B.colMd2 ]
                    [ channelsView channels st.selectedChannel
                    ]
                , H.div
                    [ A.class_ B.colMd10 ]
                    [ messagesView messages st.selectedChannel
                    ]
                ]
            ]

    update :: State -> _ -> State
    update st _ = st

main = do
    Tuple node driver <- runUI ui
    appendToBody node

module Main where

import Data.Void
import Data.Tuple
import Data.Maybe
import Data.Either
import Data.Array (zipWith, length, modifyAt, deleteAt, (..), (!!), map)

import qualified Data.String as S

import Debug.Trace

import Control.Functor (($>))
import Control.Alternative
import Control.Bind
import Control.Monad.Eff

import DOM

import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Types
import Data.DOM.Simple.Window

import Halogen
import Halogen.Signal
import Halogen.Component

import qualified Halogen.Mixin.UndoRedo as Undo
import qualified Halogen.Mixin.Router as Router

import qualified Halogen.HTML as H
import qualified Halogen.HTML.Attributes as A
import qualified Halogen.HTML.Events as A
import qualified Halogen.HTML.Events.Forms as A
import qualified Halogen.HTML.Events.Handler as E

import qualified Halogen.Themes.Bootstrap3 as B
import qualified Halogen.Themes.Bootstrap3.InputGroup as BI

import Models.Action
import Models.Channel
import Models.Group
import Models.Input
import Models.User
import Models.Message
import Models.State
import Views.Channel
--import Views.Input
import Views.Message

appendToBody :: forall eff. HTMLElement -> Eff (dom :: DOM | eff) Unit
appendToBody e = document globalWindow >>= (body >=> flip appendChild e)

user1 :: User
user1 =
    { name: "Harry"
    , email: "harry@hogwarts.com"
    }

user2 :: User
user2 =
    { name: "Ben"
    , email: "ben@kenobi.ch"
    }

messages :: [Message]
messages =
    [
        { from: user1
        , to: user2
        , message: TextMessage
            { text: """Two households, both alike in dignity,
  In fair Verona, where we lay our scene,
From ancient grudge break to new mutiny,
  Where civil blood makes civil hands unclean.
From forth the fatal loins of these two foes
  A pair of star-cross'd lovers take their life;
Whose misadventur'd piteous overthrows
  Doth with their death bury their parents' strife.
The fearful passage of their death-mark'd love,
  And the continuance of their parents' rage,
Which but their children's end naught could remove,
  Is now the two hours' traffic of our stage;
The which, if you with patient ears attend,
What here shall miss, our toil shall strive to mend."""
            }
        }
    ,
        { from: user2
        , to: user1
        , message: TextMessage
            { text: """
            Actual happiness always looks pretty squalid in comparison with the overcompensations for misery.
            And, of course, stability isn't nearly so spectacular as instability.
            And being contented has none of the glamour of a good fight against misfortune, none of the picturesqueness of a struggle with temptation, or a fatal overthrow by passion or doubt. Happiness is never grand.
            - Aldous Huxley, Brave New World"""
            }
        }
    ,
        { from: user1
        , to: user2
        , message: TextMessage
            { text: """Most human beings have an almost infinite capacity for taking things for granted. - Aldous Huxley, Brave New World"""
            }
        }
    ,
        { from: user2
        , to: user1
        , message: TextMessage
            { text: """
            Actual happiness always looks pretty squalid in comparison with the overcompensations for misery.
            And, of course, stability isn't nearly so spectacular as instability.
            And being contented has none of the glamour of a good fight against misfortune, none of the picturesqueness of a struggle with temptation, or a fatal overthrow by passion or doubt. Happiness is never grand.
            - Aldous Huxley, Brave New World"""
            }
        }
    ,
        { from: user2
        , to: user1
        , message: CodeMessage
            { language: "haskell"
            , text: "add a b = a + b" }
        }
    ,
        { from: user1
        , to: user2
        , message: CodeMessage
            { language: "javascript"
            , text: "function(a, b) { return a + b; }" }
        }
    ]

channels :: [ Channel ]
channels =
    [ Channel { name: "PureScript" }
    , Channel { name: "F#" }
    , Channel { name: "Haskell" }
    , Channel { name: "Elm" }
    , Channel { name: "Idris" }
    ]

testState :: State
testState =
	{ messages: messages
	, user: Nothing
	, channels: channels
	, selectedChannel: Just (Channel { name: "PureScript" })
	}

-- | The view is a state machine, consuming inputs, and generating HTML documents which in turn, generate new inputs
ui :: forall p m. (Alternative m) => Component m _ _
ui = render <$> stateful testState update
    where
    render :: State -> H.HTML (m _)
    render st =
        H.div
            [ A.class_ B.container ]
            [ H.div
                [ A.class_ B.row ]
                [ H.div
                    [ A.class_ B.colMd3 ]
                    [ channelsView channels st.selectedChannel
                    ]
                , H.div
                    [ A.class_ B.colMd9 ]
                    [ messagesView messages st.selectedChannel
                    ]
                ]
            ]

    update :: State -> _ -> State
    update st _ = st

main = do
    Tuple node driver <- runUI ui
    appendToBody node


Assign keyboard event listeners to the document rather than the canvas since the canvas doesn't seem to emit them.

-- | The application entry point
module Main where

import Prelude
import Jundo.Rendering
import Jundo.Simulation
import Control.Monad.Eff
import Control.Monad.Eff.Exception
import Control.Monad.ST
import Data.Date (Now(), nowEpochMilliseconds)
import Data.Time (Milliseconds(..))
import Data.Maybe
import Data.Nullable
import Data.Tuple
import qualified DOM as D
import qualified DOM.Event.EventTarget as D
import qualified DOM.Event.Experimental as D
import qualified DOM.Event.KeyboardEvent as D
import qualified DOM.Event.MouseEvent as D
import qualified DOM.Event.Types (Event(), EventTarget(), KeyboardEvent(), MouseEvent()) as D
import qualified DOM.HTML as D
import qualified DOM.HTML.Types as D
import qualified DOM.HTML.Window as D
import qualified DOM.Node.Document.Experimental as D
import qualified DOM.Node.Element as D
import qualified DOM.Node.Element.Experimental as D
import qualified DOM.Node.Types as D
import qualified DOM.RequestAnimationFrame as D
import Graphics.Canvas (Canvas(), getCanvasElementById)
import Graphics.Canvas.Element

-- | Get the global document as a Document type
globalDocument :: forall eff. Eff (dom :: D.DOM | eff) D.Document
globalDocument = D.window >>= D.document >>= pure <<< D.htmlDocumentToDocument

-- | Returns true if we are in full screen and have pointer lock
inFullscreen :: forall eff. Eff (dom :: D.DOM | eff) Boolean
inFullscreen = do
  document <- globalDocument
  maybeFullscreenEl <- D.fullscreenElement document >>= pure <<< toMaybe
  maybePointerLockEl <- D.pointerLockElement document >>= pure <<< toMaybe
  -- TODO: Check that the full screen and pointer lock elements are our canvas
  case Tuple maybeFullscreenEl maybePointerLockEl of
    Tuple (Just _) (Just _) -> return true
    Tuple _ _ -> return false

-- | Type for tracking which keys are currently depressed
type KeyboardState = {w :: Boolean, a :: Boolean, s :: Boolean, d :: Boolean}

-- | Update the state of the key with the given key code if it is one we are tracking
updateKey :: Int -> Boolean -> KeyboardState -> KeyboardState
updateKey code isDown ks | code == D.wKeyCode = {w: isDown, a: ks.a, d: ks.d, s: ks.s}
updateKey code isDown ks | code == D.aKeyCode = {w: ks.w, a: isDown, d: ks.d, s: ks.s}
updateKey code isDown ks | code == D.dKeyCode = {w: ks.w, a: ks.a, d: isDown, s: ks.s}
updateKey code isDown ks | code == D.sKeyCode = {w: ks.w, a: ks.a, d: ks.d, s: isDown}
updateKey _ _ ks = ks

-- Type for passing application state between event listeners and the render loop
type AppState = {keyboard :: KeyboardState, simulation :: SimulationState}

modifyKeyboardState :: (KeyboardState -> KeyboardState) -> AppState -> AppState
modifyKeyboardState f state = {keyboard: f state.keyboard, simulation: state.simulation}

modifySimulationState :: (SimulationState -> SimulationState) -> AppState -> AppState
modifySimulationState f state = {keyboard: state.keyboard, simulation: f state.simulation}

-- | Handle canvas mousemove events by updating the simulation state.
canvasMousemove :: forall eff h. STRef h AppState -> D.MouseEvent -> Eff (dom :: D.DOM, st :: ST h | eff) Unit
canvasMousemove stateRef e = do
  movement <- pure $ Tuple (D.movementX e) (D.movementY e)
  return unit

-- | Handle canvas clicks. If we are not in full screen, open the canvas in full screen.
-- | Otherwise, toggle the direction of the cube's rotation.
canvasClick :: forall eff h. STRef h AppState -> D.Element -> D.MouseEvent -> Eff (dom :: D.DOM, st :: ST h | eff) Unit
canvasClick stateRef el _ = do
  fullScreen <- inFullscreen
  if fullScreen
    then do
      modifySTRef stateRef $ modifySimulationState toggleDirection
      return unit
    else do
      D.requestFullscreen el
      D.requestPointerLock el

-- | Monitor document keydown events so we can track which keys are depressed
documentKeydown :: forall eff h. STRef h AppState -> D.KeyboardEvent -> Eff (dom :: D.DOM, st :: ST h | eff) Unit
documentKeydown stateRef e = do
  modifySTRef stateRef $ modifyKeyboardState $ updateKey (D.keyCode e) true
  return unit

-- | Monitor document keyup events so we can track which keys are depressed
documentKeyup :: forall eff h. STRef h AppState -> D.KeyboardEvent -> Eff (dom :: D.DOM, st :: ST h | eff) Unit
documentKeyup stateRef e = do
  modifySTRef stateRef $ modifyKeyboardState $ updateKey (D.keyCode e) false
  return unit

-- | Add keyboard and mouse move event listeners when we enter full screen, and remove them when we leave it
documentFullscreenChange :: forall eff. D.KeyboardEventListener (dom :: D.DOM | eff) -> D.KeyboardEventListener (dom :: D.DOM | eff)
  -> D.MouseEventListener (dom :: D.DOM | eff) -> D.EventTarget -> D.EventTarget -> D.Event -> Eff (dom :: D.DOM | eff) Unit
documentFullscreenChange keyupListener keydownListener moveListener targetCanvas targetDocument _ = do
  fullScreen <- inFullscreen
  if fullScreen
    then do
      D.addKeyboardEventListener D.keyup keyupListener false targetDocument
      D.addKeyboardEventListener D.keydown keydownListener false targetDocument
      D.addMouseEventListener D.mousemove moveListener false targetCanvas
    else do
      D.removeKeyboardEventListener D.keyup keyupListener false targetDocument
      D.removeKeyboardEventListener D.keydown keydownListener false targetDocument
      D.removeMouseEventListener D.mousemove moveListener false targetCanvas

-- | Main loop. Steps the simulation state forwards in time then renders the new state.
tick :: forall eff h. RenderingContext -> STRef h AppState -> Milliseconds -> Eff (canvas :: Canvas, dom :: D.DOM, now :: Now, st :: ST h | eff) Unit
tick ctx stateRef time = do
  newTime <- nowEpochMilliseconds
  state <- modifySTRef stateRef $ modifySimulationState (timestep (newTime - time))
  render ctx state.simulation
  D.requestAnimationFrame $ tick ctx stateRef newTime

-- | Start the application: set up the canvas and start the render loop
main :: Eff (canvas :: Canvas, dom :: D.DOM, err :: EXCEPTION, now :: Now) Unit
main = do
  Just canvas <- getCanvasElementById "easel"
  el <- pure $ toElement canvas
  renderingContext <- initialiseWebGL el canvas
  time <- nowEpochMilliseconds
  elEventTarget <- pure $ D.elementToEventTarget el
  documentEventTarget <- globalDocument >>= pure <<< D.documentToEventTarget

  -- Aaa mutable state!
  -- The event listeners need to update the state read by the render loop somehow, so let's use a mutable reference cell
  runST do
    stateRef <- newSTRef {simulation: initialSimulationState, keyboard: {w: false, a: false, s: false, d: false}}

    -- Event listeners added and removed when we enter and leave full screen
    keyupListener <- pure $ D.keyboardEventListener (documentKeyup stateRef)
    keydownListener <- pure $ D.keyboardEventListener (documentKeydown stateRef)
    moveListener <- pure $ D.mouseEventListener (canvasMousemove stateRef)

    -- Listener for pointer lock and full screen change events
    fullscreenListener <- pure $ D.eventListener (documentFullscreenChange keyupListener keydownListener moveListener elEventTarget documentEventTarget)
    D.addEventListener D.fullscreenChange fullscreenListener false documentEventTarget
    D.addEventListener D.pointerLockChange fullscreenListener false documentEventTarget

    D.addMouseEventListener D.click (D.mouseEventListener (canvasClick stateRef el)) false elEventTarget
    tick renderingContext stateRef time

-- | The application entry point
module Main where

import Prelude
import Jundo.Rendering
import Jundo.Simulation
import Control.Monad.Eff
import Control.Monad.Eff.Exception
import Control.Monad.ST
import Data.Date (Now(), nowEpochMilliseconds)
import Data.Time (Milliseconds(..))
import Data.Maybe
import Data.Nullable
import Data.Tuple
import qualified DOM as D
import qualified DOM.Event.EventTarget as D
import qualified DOM.Event.Experimental as D
import qualified DOM.Event.KeyboardEvent as D
import qualified DOM.Event.MouseEvent as D
import qualified DOM.Event.Types (Event(), EventTarget(), KeyboardEvent(), MouseEvent()) as D
import qualified DOM.HTML as D
import qualified DOM.HTML.Types as D
import qualified DOM.HTML.Window as D
import qualified DOM.Node.Document.Experimental as D
import qualified DOM.Node.Element as D
import qualified DOM.Node.Element.Experimental as D
import qualified DOM.Node.Types as D
import qualified DOM.RequestAnimationFrame as D
import Graphics.Canvas (Canvas(), getCanvasElementById)
import Graphics.Canvas.Element

-- | Get the global document as a Document type
globalDocument :: forall eff. Eff (dom :: D.DOM | eff) D.Document
globalDocument = D.window >>= D.document >>= pure <<< D.htmlDocumentToDocument

-- | Returns true if we are in full screen and have pointer lock
inFullscreen :: forall eff. Eff (dom :: D.DOM | eff) Boolean
inFullscreen = do
  document <- globalDocument
  maybeFullscreenEl <- D.fullscreenElement document >>= pure <<< toMaybe
  maybePointerLockEl <- D.pointerLockElement document >>= pure <<< toMaybe
  -- TODO: Check that the full screen and pointer lock elements are our canvas
  case Tuple maybeFullscreenEl maybePointerLockEl of
    Tuple (Just _) (Just _) -> return true
    Tuple _ _ -> return false

-- | Type for tracking which keys are currently depressed
type KeyboardState = {w :: Boolean, a :: Boolean, s :: Boolean, d :: Boolean}

-- | Update the state of the key with the given key code if it is one we are tracking
updateKey :: Int -> Boolean -> KeyboardState -> KeyboardState
updateKey code isDown ks | code == D.wKeyCode = {w: isDown, a: ks.a, d: ks.d, s: ks.s}
updateKey code isDown ks | code == D.aKeyCode = {w: ks.w, a: isDown, d: ks.d, s: ks.s}
updateKey code isDown ks | code == D.dKeyCode = {w: ks.w, a: ks.a, d: isDown, s: ks.s}
updateKey code isDown ks | code == D.sKeyCode = {w: ks.w, a: ks.a, d: ks.d, s: isDown}
updateKey _ _ ks = ks

-- Type for passing application state between event listeners and the render loop
type AppState = {keyboard :: KeyboardState, simulation :: SimulationState}

modifyKeyboardState :: (KeyboardState -> KeyboardState) -> AppState -> AppState
modifyKeyboardState f state = {keyboard: f state.keyboard, simulation: state.simulation}

modifySimulationState :: (SimulationState -> SimulationState) -> AppState -> AppState
modifySimulationState f state = {keyboard: state.keyboard, simulation: f state.simulation}

-- | Handle canvas mousemove events by updating the simulation state.
canvasMousemove :: forall eff h. STRef h AppState -> D.MouseEvent -> Eff (dom :: D.DOM, st :: ST h | eff) Unit
canvasMousemove stateRef e = do
  movement <- pure $ Tuple (D.movementX e) (D.movementY e)
  return unit

-- | Monitor canvas keydown events so we can track which keys are depressed
canvasKeydown :: forall eff h. STRef h AppState -> D.KeyboardEvent -> Eff (dom :: D.DOM, st :: ST h | eff) Unit
canvasKeydown stateRef e = do
  modifySTRef stateRef $ modifyKeyboardState $ updateKey (D.keyCode e) true
  return unit

-- | Monitor canvas keyup events so we can track which keys are depressed
canvasKeyup :: forall eff h. STRef h AppState -> D.KeyboardEvent -> Eff (dom :: D.DOM, st :: ST h | eff) Unit
canvasKeyup stateRef e = do
  modifySTRef stateRef $ modifyKeyboardState $ updateKey (D.keyCode e) false
  return unit

-- | Handle canvas clicks. If we are not in full screen, open the canvas in full screen.
-- | Otherwise, toggle the direction of the cube's rotation.
canvasClick :: forall eff h. STRef h AppState -> D.Element -> D.MouseEvent -> Eff (dom :: D.DOM, st :: ST h | eff) Unit
canvasClick stateRef el _ = do
  fullScreen <- inFullscreen
  if fullScreen
    then do
      modifySTRef stateRef $ modifySimulationState toggleDirection
      return unit
    else do
      D.requestFullscreen el
      D.requestPointerLock el

-- | Add keyboard and mouse move event listeners when we enter full screen, and remove them when we leave it
documentFullscreenChange :: forall eff. D.KeyboardEventListener (dom :: D.DOM | eff) -> D.KeyboardEventListener (dom :: D.DOM | eff)
  -> D.MouseEventListener (dom :: D.DOM | eff) -> D.EventTarget -> D.Event -> Eff (dom :: D.DOM | eff) Unit
documentFullscreenChange keyupListener keydownListener moveListener targetCanvas _ = do
  fullScreen <- inFullscreen
  if fullScreen
    then do
      D.addKeyboardEventListener D.keyup keyupListener false targetCanvas
      D.addKeyboardEventListener D.keydown keydownListener false targetCanvas
      D.addMouseEventListener D.mousemove moveListener false targetCanvas
    else do
      D.removeKeyboardEventListener D.keyup keyupListener false targetCanvas
      D.removeKeyboardEventListener D.keydown keydownListener false targetCanvas
      D.removeMouseEventListener D.mousemove moveListener false targetCanvas

-- | Main loop. Steps the simulation state forwards in time then renders the new state.
tick :: forall eff h. RenderingContext -> STRef h AppState -> Milliseconds -> Eff (canvas :: Canvas, dom :: D.DOM, now :: Now, st :: ST h | eff) Unit
tick ctx stateRef time = do
  newTime <- nowEpochMilliseconds
  state <- modifySTRef stateRef $ modifySimulationState (timestep (newTime - time))
  render ctx state.simulation
  D.requestAnimationFrame $ tick ctx stateRef newTime

-- | Start the application: set up the canvas and start the render loop
main :: Eff (canvas :: Canvas, dom :: D.DOM, err :: EXCEPTION, now :: Now) Unit
main = do
  Just canvas <- getCanvasElementById "easel"
  el <- pure $ toElement canvas
  renderingContext <- initialiseWebGL el canvas
  time <- nowEpochMilliseconds
  elEventTarget <- pure $ D.elementToEventTarget el

  -- Aaa mutable state!
  -- The event listeners need to update the state read by the render loop somehow, so let's use a mutable reference cell
  runST do
    stateRef <- newSTRef {simulation: initialSimulationState, keyboard: {w: false, a: false, s: false, d: false}}

    -- Event listeners added and removed when we enter and leave full screen
    keyupListener <- pure $ D.keyboardEventListener (canvasKeyup stateRef)
    keydownListener <- pure $ D.keyboardEventListener (canvasKeydown stateRef)
    moveListener <- pure $ D.mouseEventListener (canvasMousemove stateRef)

    -- Listener for pointer lock and full screen change events
    fullscreenListener <- pure $ D.eventListener (documentFullscreenChange keyupListener keydownListener moveListener elEventTarget)
    documentEventTarget <- globalDocument >>= pure <<< D.documentToEventTarget
    D.addEventListener D.fullscreenChange fullscreenListener false documentEventTarget
    D.addEventListener D.pointerLockChange fullscreenListener false documentEventTarget

    D.addMouseEventListener D.click (D.mouseEventListener (canvasClick stateRef el)) false elEventTarget
    tick renderingContext stateRef time


Expose lis as an HTMLCollection

Expose lis as an HTMLCollection

module Main where

import Control.Applicative (pure)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import DOM (DOM)
import DOM.Classy.Node (fromNode)
import DOM.Classy.Element (fromElement, toElement)
import DOM.Classy.ParentNode (toParentNode)
import DOM.Event.Event (target)
import DOM.Event.EventTarget (addEventListener, eventListener)
import DOM.Event.Types (Event)
import DOM.HTML (window)
import DOM.HTML.Event.EventTypes (keyup)
import DOM.HTML.HTMLTextAreaElement (value)
import DOM.HTML.Types ( HTMLTextAreaElement
                      , HTMLUListElement
                      , htmlDocumentToParentNode
                      )
import DOM.HTML.Window (document)
import DOM.Node.ParentNode (querySelector, QuerySelector(QuerySelector), children)
import DOM.Node.Types (elementToEventTarget, ParentNode)
import Data.Maybe (Maybe, maybe)
import Prelude (Unit, bind, show, (<<<), (>>=), ($), (<$>), (<*>), (=<<))
import Util.Parse (parse)
import Data.Argonaut (encodeJson)

--------------------------------------------------------------------------------

data Nodes = Nodes HTMLTextAreaElement HTMLUListElement

--------------------------------------------------------------------------------

updateDOM :: HTMLUListElement
          -> String
          -> forall eff. Eff (dom :: DOM, console :: CONSOLE | eff) Unit
updateDOM ul input = do
  lis <- children (toParentNode ul)
  log sketchPalette

    where
      sketchPalette = (show <<< encodeJson <<< parse) input

--------------------------------------------------------------------------------

onTextChange :: forall eff. HTMLUListElement
                         -> Event
                         -> Eff (dom :: DOM, console :: CONSOLE | eff) Unit
onTextChange ul e = maybe
  (log "No textarea node found")
  (\textarea -> value (textarea :: HTMLTextAreaElement) >>= updateDOM ul)
  ((fromNode <<< target) e)

--------------------------------------------------------------------------------

queryNodes :: forall eff. ParentNode -> Eff (dom :: DOM | eff) (Maybe Nodes)
queryNodes docNode = do

  -- querySelector qs docNode :: Eff ( dom ∷ DOM | eff ) (Maybe Element)
  -- (=<<) fromElement        :: (Element -> Maybe SpecialisedElement)
  --                             -> Maybe Element
  --                             -> Maybe SpecialisedElement
  --
  -- Thus we lift that into Eff so that we can extract a Maybe SpecialisedElement

  textarea <- (=<<) fromElement <$> querySelector (QuerySelector "#in")  docNode
  ul       <- (=<<) fromElement <$> querySelector (QuerySelector "#out") docNode

  pure $ Nodes <$> textarea <*> ul

--------------------------------------------------------------------------------

bindDOM :: forall eff. Nodes -> Eff (dom :: DOM, console :: CONSOLE | eff) Unit
bindDOM (Nodes textarea ul) = do
  let listener    = eventListener (onTextChange ul)
      eventTarget = elementToEventTarget (toElement textarea)
  addEventListener keyup listener true eventTarget

--------------------------------------------------------------------------------

main :: forall eff. Eff (dom :: DOM, console :: CONSOLE | eff) Unit
main = window
  >>= document
  >>= (queryNodes <<< htmlDocumentToParentNode)
  >>= (maybe (log "Could not access elements") bindDOM)

--------------------------------------------------------------------------------

module Main where

import Control.Applicative (pure)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import DOM (DOM)
import DOM.Classy.Node (fromNode)
import DOM.Classy.Element (fromElement, toElement)
import DOM.Event.Event (target)
import DOM.Event.EventTarget (addEventListener, eventListener)
import DOM.Event.Types (Event)
import DOM.HTML (window)
import DOM.HTML.Event.EventTypes (keyup)
import DOM.HTML.HTMLTextAreaElement (value)
import DOM.HTML.Types ( HTMLTextAreaElement
                      , HTMLUListElement
                      , htmlDocumentToParentNode
                      )
import DOM.HTML.Window (document)
import DOM.Node.ParentNode (querySelector, QuerySelector(QuerySelector))
import DOM.Node.Types (elementToEventTarget, ParentNode)
import Data.Maybe (Maybe, maybe)
import Prelude (Unit, bind, show, (<<<), (>>=), ($), (<$>), (<*>), (=<<))
import Util.Parse (parse)
import Data.Argonaut (encodeJson)

--------------------------------------------------------------------------------

data Nodes = Nodes HTMLTextAreaElement HTMLUListElement

--------------------------------------------------------------------------------

-- Ok! Lets empty the UL and populate it with <li> elements next time!
updateDOM :: HTMLUListElement
          -> String
          -> forall eff. Eff (console :: CONSOLE | eff) Unit
updateDOM ul input = log sketchPalette where
  sketchPalette = (show <<< encodeJson <<< parse) input

--------------------------------------------------------------------------------

onTextChange :: forall eff. HTMLUListElement
                         -> Event
                         -> Eff (dom :: DOM, console :: CONSOLE | eff) Unit
onTextChange ul e = maybe
  (log "No textarea node found")
  (\textarea -> value (textarea :: HTMLTextAreaElement) >>= updateDOM ul)
  ((fromNode <<< target) e)

--------------------------------------------------------------------------------

queryNodes :: forall eff. ParentNode -> Eff (dom :: DOM | eff) (Maybe Nodes)
queryNodes docNode = do

  -- querySelector qs docNode :: Eff ( dom ∷ DOM | eff ) (Maybe Element)
  -- (=<<) fromElement        :: (Element -> Maybe SpecialisedElement)
  --                             -> Maybe Element
  --                             -> Maybe SpecialisedElement
  --
  -- Thus we lift that into Eff so that we can extract a Maybe SpecialisedElement

  textarea <- (=<<) fromElement <$> querySelector (QuerySelector "#in")  docNode
  ul       <- (=<<) fromElement <$> querySelector (QuerySelector "#out") docNode

  pure $ Nodes <$> textarea <*> ul

--------------------------------------------------------------------------------

bindDOM :: forall eff. Nodes -> Eff (dom :: DOM, console :: CONSOLE | eff) Unit
bindDOM (Nodes textarea ul) = do
  let listener    = eventListener (onTextChange ul)
      eventTarget = elementToEventTarget (toElement textarea)
  addEventListener keyup listener true eventTarget

--------------------------------------------------------------------------------

main :: forall eff. Eff (dom :: DOM, console :: CONSOLE | eff) Unit
main = window
  >>= document
  >>= (queryNodes <<< htmlDocumentToParentNode)
  >>= (maybe (log "Could not access elements") bindDOM)

--------------------------------------------------------------------------------


More names

More names

Original commit f54d99816bb60bbe4f13f4e8a3e080438d74a960

module Main
    ( renderFromJson
    , renderFromJsonSchema
    , renderFromJsonStringPossiblyAsSchemaInDevelopment
    , renderers
    ) 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 SourceCode = String

type Pipeline input = Doc.Renderer -> input -> Either Error SourceCode

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

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

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

pipelines :: Environment -> Array (Pipeline Json)
pipelines Development = [renderFromJsonSchema, renderFromJson]
pipelines Production = [renderFromJson]

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

renderFromJsonStringPossiblyAsSchemaInDevelopment :: Pipeline String
renderFromJsonStringPossiblyAsSchemaInDevelopment renderer jsonString = do
    obj <- J.jsonParser jsonString
    firstSuccess (pipelines Env.current) renderer obj

module Main
    ( renderFromJson
    , renderFromJsonSchema
    , renderFromJsonStringPossiblyAsSchemaInDevelopment
    , renderers
    ) 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 a = Doc.Renderer -> a -> 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

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

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

pipelines :: Environment -> Array (Pipeline Json)
pipelines Development = [renderFromJsonSchema, renderFromJson]
pipelines Production = [renderFromJson]

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

renderFromJsonStringPossiblyAsSchemaInDevelopment :: Pipeline String
renderFromJsonStringPossiblyAsSchemaInDevelopment renderer jsonString = do
    obj <- J.jsonParser jsonString
    firstSuccess (pipelines Env.current) renderer obj


cleanup

cleanup

module Main where

import Prelude hiding (div)
import Data.Maybe(Maybe(..))
import Control.Monad.Eff (Eff)
import Pux (CoreEffects, EffModel, start)
import Pux.DOM.Events (onClick)
import Pux.DOM.HTML (HTML)
import Pux.Renderer.React (renderToDOM)
import Text.Smolder.HTML (button, div, br, p)
import Text.Smolder.Markup (text, (#!))
import Content.Render (render)
import Model.Presentation as P

data Event = Next | Previous | Restart

slideSource :: String
slideSource = """
# Slide One

On this slide we have lots of coolness.

---
# Slide Two

## Let me tell you

This is weird.

## Let me tell you something else

_Really_ weird.

---
# Final Slide

Wasn't that just the greatest presentation?

"""

type State = P.Presentation

initialState :: State
initialState = P.create slideSource

numSlides :: State -> Int
numSlides = P.size

handle :: Event -> State -> State
handle Next s = P.next s
handle Previous s = P.previous s
handle Restart s = P.reset s

foldp :: ∀ fx. Event -> State -> EffModel State Event fx
foldp ev s = { state: handle ev s, effects: [] }

view :: State -> HTML Event
view state =
  case P.slide state of
     Nothing -> div $ p $ text "No slide."
     Just {number, content} -> do
        button #! onClick (const Previous) $ text "Previous"
        button #! onClick (const Next) $ text "Next"
        button #! onClick (const Restart) $ text "Restart"
        br
        div $ text $ "Slide " <> (show number) <> "/" <> show (P.size state)
        br
        render content

main :: ∀ fx. Eff (CoreEffects fx) Unit
main = do
  app <- start
    { initialState
    , view
    , foldp
    , inputs: []
    }
  renderToDOM "#app" app.markup app.input

module Main where

import Prelude hiding (div)
import Data.List (List, length, (!!))
import Data.Maybe(Maybe(..))
import Data.Either (Either(..))
import Control.Monad.Eff (Eff)
import Pux (CoreEffects, EffModel, start)
import Pux.DOM.Events (onClick)
import Pux.DOM.HTML (HTML)
import Pux.Renderer.React (renderToDOM)
import Text.Smolder.HTML (button, div, br, p)
import Text.Smolder.Markup (text, (#!))
import Text.Markdown.SlamDown (SlamDown)
import Text.Markdown.SlamDown.Parser (parseMd)
import Content.Slide (slides)
import Content.Render (render)
import Model.Presentation as P

data Event = Next | Previous | Restart

slideSource :: String
slideSource = """
# Slide One

On this slide we have lots of coolness.

---
# Slide Two

## Let me tell you

This is weird.

## Let me tell you something else

_Really_ weird.

---
# Final Slide

Wasn't that just the greatest presentation?

"""

type State = P.Presentation

initialState :: State
initialState = P.create slideSource

numSlides :: State -> Int
numSlides = P.size

handle :: Event -> State -> State
handle Next s = P.next s
handle Previous s = P.previous s
handle Restart s = P.reset s

foldp :: ∀ fx. Event -> State -> EffModel State Event fx
foldp ev s = { state: handle ev s, effects: [] }

view :: State -> HTML Event
view state =
  case P.slide state of
     Nothing -> div $ p $ text "No slide."
     Just {number, content} -> do
        button #! onClick (const Previous) $ text "Previous"
        button #! onClick (const Next) $ text "Next"
        button #! onClick (const Restart) $ text "Restart"
        br
        div $ text $ "Slide " <> (show number) <> "/" <> show (P.size state)
        br
        render content

main :: ∀ fx. Eff (CoreEffects fx) Unit
main = do
  app <- start
    { initialState
    , view
    , foldp
    , inputs: []
    }
  renderToDOM "#app" app.markup app.input


EnvT - Traversable (#104)

EnvT - Traversable (#104)

* EnvT - Traversable

* fixed typo

-- | This module defines the environment comonad transformer, `EnvT`.

module Control.Comonad.Env.Trans where

import Prelude

import Control.Comonad (class Comonad, extract)
import Control.Comonad.Trans.Class (class ComonadTrans)
import Control.Extend (class Extend, (<<=))

import Data.Traversable (class Traversable, class Foldable, foldl, foldr, foldMap, traverse, sequence)
import Data.Tuple (Tuple(..))
import Data.Newtype (class Newtype)

-- | The environment comonad transformer.
-- |
-- | This comonad transformer extends the context of a value in the base comonad with a _global environment_ of
-- | type `e`.
-- |
-- | The `ComonadEnv` type class describes the operations supported by this comonad.
newtype EnvT e w a = EnvT (Tuple e (w a))

-- | Unwrap a value in the `EnvT` comonad.
runEnvT :: forall e w a. EnvT e w a -> Tuple e (w a)
runEnvT (EnvT x) = x

-- | Change the environment type in an `EnvT` context.
withEnvT :: forall e1 e2 w a. (e1 -> e2) -> EnvT e1 w a -> EnvT e2 w a
withEnvT f (EnvT (Tuple e x)) = EnvT $ Tuple (f e) x

-- | Change the underlying comonad and data type in an `EnvT` context.
mapEnvT :: forall e w1 w2 a b. (w1 a -> w2 b) -> EnvT e w1 a -> EnvT e w2 b
mapEnvT f (EnvT (Tuple e x)) = EnvT $ Tuple e (f x)

derive instance newtypeEnvT :: Newtype (EnvT e w a) _

instance functorEnvT :: Functor w => Functor (EnvT e w) where
  map f (EnvT (Tuple e x)) = EnvT $ Tuple e (f <$> x)

instance extendEnvT :: Extend w => Extend (EnvT e w) where
  extend f (EnvT (Tuple e x)) = EnvT $ Tuple e (f <$> ((Tuple e >>> EnvT) <<= x))

instance comonadEnvT :: Comonad w => Comonad (EnvT e w) where
  extract (EnvT (Tuple e x)) = extract x

instance comonadTransEnvT :: ComonadTrans (EnvT e) where
  lower (EnvT (Tuple e x)) = x

instance foldableEnvT :: Foldable f => Foldable (EnvT e f) where
  foldl fn a (EnvT (Tuple _ x)) = foldl fn a x
  foldr fn a (EnvT (Tuple _ x)) = foldr fn a x
  foldMap fn (EnvT (Tuple _ x)) = foldMap fn x

instance traversableEnvT :: Traversable f => Traversable (EnvT e f) where
  sequence (EnvT (Tuple a x)) = EnvT <$> Tuple a <$> sequence x
  traverse f (EnvT (Tuple a x)) = EnvT <$> Tuple a <$> traverse f x

-- | This module defines the environment comonad transformer, `EnvT`.

module Control.Comonad.Env.Trans where

import Prelude

import Control.Comonad (class Comonad, extract)
import Control.Comonad.Trans.Class (class ComonadTrans)
import Control.Extend (class Extend, (<<=))

import Data.Tuple (Tuple(..))
import Data.Newtype (class Newtype)

-- | The environment comonad transformer.
-- |
-- | This comonad transformer extends the context of a value in the base comonad with a _global environment_ of
-- | type `e`.
-- |
-- | The `ComonadEnv` type class describes the operations supported by this comonad.
newtype EnvT e w a = EnvT (Tuple e (w a))

-- | Unwrap a value in the `EnvT` comonad.
runEnvT :: forall e w a. EnvT e w a -> Tuple e (w a)
runEnvT (EnvT x) = x

-- | Change the environment type in an `EnvT` context.
withEnvT :: forall e1 e2 w a. (e1 -> e2) -> EnvT e1 w a -> EnvT e2 w a
withEnvT f (EnvT (Tuple e x)) = EnvT $ Tuple (f e) x

-- | Change the underlying comonad and data type in an `EnvT` context.
mapEnvT :: forall e w1 w2 a b. (w1 a -> w2 b) -> EnvT e w1 a -> EnvT e w2 b
mapEnvT f (EnvT (Tuple e x)) = EnvT $ Tuple e (f x)

derive instance newtypeEnvT :: Newtype (EnvT e w a) _

instance functorEnvT :: Functor w => Functor (EnvT e w) where
  map f (EnvT (Tuple e x)) = EnvT $ Tuple e (f <$> x)

instance extendEnvT :: Extend w => Extend (EnvT e w) where
  extend f (EnvT (Tuple e x)) = EnvT $ Tuple e (f <$> ((Tuple e >>> EnvT) <<= x))

instance comonadEnvT :: Comonad w => Comonad (EnvT e w) where
  extract (EnvT (Tuple e x)) = extract x

instance comonadTransEnvT :: ComonadTrans (EnvT e) where
  lower (EnvT (Tuple e x)) = x