Refactor Types

Refactor Types

module Types where

import Prelude (pure, bind, ($))

import Data.Lens (Lens', lens)
import Pux.Html.Events (FormEvent)
import Control.Monad.Aff (Aff)
import Signal.Channel (CHANNEL)
import Data.Argonaut
import Control.Monad.Eff.Exception (EXCEPTION)
import Data.Either (Either(Left))

data Action
    = ToggleEdit
    | AddTextCell
    | AddCodeCell
    | RenderCodeCell Int
    | CheckInput Int FormEvent
    | CheckNotebook
    | NoOp

newtype AppState = AppState
    { editing :: Boolean
    , notebook :: Notebook
    , totalCells :: Int
    , currentCell :: Int
    }

type EffModel state action eff =
    { state :: state
    , effects :: Array (Aff (channel :: CHANNEL, err :: EXCEPTION | eff) action)
    }

_notebook :: Lens' AppState Notebook
_notebook = lens
    (\(AppState s) -> s.notebook)
    (\(AppState s) -> (\n -> AppState (s { notebook = n})))

_totalCells :: Lens' AppState Int
_totalCells = lens
    (\(AppState s) -> s.totalCells)
    (\(AppState s) -> (\n -> AppState (s { totalCells = n})))

_currentCell :: Lens' AppState Int
_currentCell = lens
    (\(AppState s) -> s.currentCell)
    (\(AppState s) -> (\c -> AppState (s { currentCell = c})))

newtype Notebook = Notebook
    { title :: String
    , subtitle :: String
    , date :: String
    , author :: String
    , cells :: Array Cell
    }

instance encodeJsonNotebook :: EncodeJson Notebook where
    encodeJson (Notebook n)
        = "title" := n.title
       ~> "subtitle" := n.subtitle
       ~> "date" := n.date
       ~> "author" := n.author
       ~> "cells" := n.cells
       ~> jsonEmptyObject

instance decodeJsonNotebook :: DecodeJson Notebook where
    decodeJson json = do
        o <- decodeJson json
        title <- o .? "title"
        subtitle <- o .? "subtitle"
        date <- o .? "date"
        author <- o .? "author"
        cells <- o.? "cells"
        pure $ Notebook {title, subtitle, date, author, cells}

_cells :: Lens' Notebook (Array Cell)
_cells = lens
    (\(Notebook n) -> n.cells)
    (\(Notebook n) -> (\c -> Notebook (n { cells = c})))

newtype Cell = Cell
    { cellType :: CellType
    , cellId :: Int
    , cellContent :: String
    }

data CellType
    = TextCell
    | CodeCell
    | DisplayCell

instance encodeJsonCellType :: EncodeJson CellType where
    encodeJson TextCell = fromString "TextCell"
    encodeJson CodeCell = fromString "CodeCell"
    encodeJson DisplayCell = fromString "DisplayCell"

instance decodeJsonCellType :: DecodeJson CellType where
    decodeJson json = do
      s <- decodeJson json
      case s of
        "TextCell"    -> pure TextCell
        "CodeCell"    -> pure CodeCell
        "DisplayCell" -> pure DisplayCell
        _             -> Left "Could not decode display Cell"

instance encodeJsonCell :: EncodeJson Cell where
    encodeJson (Cell c)
        = "cellId" := c.cellId
       ~> "cellType" := c.cellType
       ~> "cellContent" := c.cellContent
       ~> jsonEmptyObject

instance decodeJsonCell :: DecodeJson Cell where
    decodeJson json = do
        o <- decodeJson json
        cellType <- o .? "cellType"
        cellId <- o .? "cellId"
        cellContent <- o .? "cellContent"
        pure $ Cell { cellType, cellId, cellContent }

newtype DisplayResult = DisplayResult String

module Types where

import Prelude
import Data.Lens
import Pux.Html.Events
import Control.Monad.Aff
import Signal.Channel
import Data.Argonaut
import CSS (b)
import Control.Monad.Eff.Exception (EXCEPTION)
import Data.Either (Either(Left, Right))
import Data.Show (class Show)

data Action
    = ToggleEdit
    | AddTextCell
    | AddCodeCell
    | RenderCodeCell Int
    | CheckInput Int FormEvent
    | CheckNotebook
    | NoOp

newtype AppState = AppState
    { editing :: Boolean
    , notebook :: Notebook
    , totalCells :: Int
    , currentCell :: Int
    }

type EffModel state action eff =
    { state :: state
    , effects :: Array (Aff (channel :: CHANNEL, err :: EXCEPTION | eff) action)
    }

_notebook :: Lens' AppState Notebook
_notebook = lens
    (\(AppState s) -> s.notebook)
    (\(AppState s) -> (\n -> AppState (s { notebook = n})))

_totalCells :: Lens' AppState Int
_totalCells = lens
    (\(AppState s) -> s.totalCells)
    (\(AppState s) -> (\n -> AppState (s { totalCells = n})))

_currentCell :: Lens' AppState Int
_currentCell = lens
    (\(AppState s) -> s.currentCell)
    (\(AppState s) -> (\c -> AppState (s { currentCell = c})))

newtype Notebook = Notebook
    { title :: String
    , subtitle :: String
    , date :: String
    , author :: String
    , cells :: Array Cell
    }

instance encodeJsonNotebook :: EncodeJson Notebook where
    encodeJson (Notebook n)
        = "title" := n.title
       ~> "subtitle" := n.subtitle
       ~> "date" := n.date
       ~> "author" := n.author
       ~> "cells" := n.cells
       ~> jsonEmptyObject

instance decodeJsonNotebook :: DecodeJson Notebook where
    decodeJson json = do
        o <- decodeJson json
        title <- o .? "title"
        subtitle <- o .? "subtitle"
        date <- o .? "date"
        author <- o .? "author"
        cells <- o.? "cells"
        pure $ Notebook {title, subtitle, date, author, cells}

_cells :: Lens' Notebook (Array Cell)
_cells = lens
    (\(Notebook n) -> n.cells)
    (\(Notebook n) -> (\c -> Notebook (n { cells = c})))

newtype Cell = Cell
    { cellType :: CellType
    , cellId :: Int
    , cellContent :: String
    }

data CellType
    = TextCell
    | CodeCell
    | DisplayCell

instance encodeJsonCellType :: EncodeJson CellType where
    encodeJson TextCell = fromString "TextCell"
    encodeJson CodeCell = fromString "CodeCell"
    encodeJson DisplayCell = fromString "DisplayCell"

instance decodeJsonCellType :: DecodeJson CellType where
    decodeJson json = do
      s <- decodeJson json
      case s of
        "TextCell"    -> pure TextCell
        "CodeCell"    -> pure CodeCell
        "DisplayCell" -> pure DisplayCell
        _             -> Left "Could not decode display Cell"

instance encodeJsonCell :: EncodeJson Cell where
    encodeJson (Cell c)
        = "cellId" := c.cellId
       ~> "cellType" := c.cellType
       ~> "cellContent" := c.cellContent
       ~> jsonEmptyObject

instance decodeJsonCell :: DecodeJson Cell where
    decodeJson json = do
        o <- decodeJson json
        cellType <- o .? "cellType"
        cellId <- o .? "cellId"
        cellContent <- o .? "cellContent"
        pure $ Cell { cellType, cellId, cellContent }

newtype DisplayResult = DisplayResult String


Delete trpauan.purs

Delete trpauan.purs

module Main where

import Prelude
import Data.Maybe (Maybe(..))
import Control.Monad.Eff (Eff)
import Math (pi, cos, sin)
import Graphics.Canvas (CANVAS, Context2D, getCanvasElementById, getContext2D, setFillStyle, fillRect, moveTo, lineTo, withContext, setStrokeStyle, beginPath, closePath, stroke, CanvasElement, getCanvasWidth, getCanvasHeight, clearRect)
import DOM (DOM)
import DOM.HTML (window)
import DOM.HTML.Types (Window)
import DOM.HTML.Window (requestAnimationFrame)
import Control.Monad.Eff.Ref (REF, newRef, readRef, writeRef, Ref)

-- These are functions which are useful in general
clearCanvas :: forall e. CanvasElement -> Eff (canvas :: CANVAS | e) Unit
clearCanvas canvas = do
  width <- getCanvasWidth canvas
  height <- getCanvasHeight canvas
  ctx <- getContext2D canvas
  void $ clearRect ctx { x: 0.0, y: 0.0, w: width, h: height }

loopAnimation :: forall e state.
  Window ->
  Ref state ->
  state ->
  (state -> Eff (ref :: REF, dom :: DOM | e) state) ->
  Eff (ref :: REF, dom :: DOM | e) Unit
loopAnimation window ref state step =
  void $ requestAnimationFrame
    do loopAnimation window ref state step
       state <- readRef ref
       state <- step state
       writeRef ref state
    window

withAnimation :: forall e state.
  state ->
  (state -> Eff (ref :: REF, dom :: DOM | e) state) ->
  Eff (ref :: REF, dom :: DOM | e) Unit
withAnimation state step = do
  window <- window
  ref <- newRef state
  loopAnimation window ref state step

withAnimateContext :: forall e state.
  String ->
  state ->
  (Context2D -> state -> Eff (dom :: DOM, ref :: REF, canvas :: CANVAS | e) state) ->
  Eff (dom :: DOM, ref :: REF, canvas :: CANVAS | e) Unit
withAnimateContext name state draw = do
  canvas <- getCanvasElementById name

  case canvas of
    Just canvas -> do
      ctx <- getContext2D canvas
      withAnimation state \state -> do
        clearCanvas canvas
        draw ctx state
    Nothing -> pure unit

withStroke :: forall e.
  Context2D ->
  String ->
  (Context2D -> Eff (canvas :: CANVAS | e) Context2D) ->
  Eff (canvas :: CANVAS | e) Context2D
withStroke ctx color draw = withContext ctx do
  ctx <- setStrokeStyle color ctx
  ctx <- beginPath ctx
  ctx <- draw ctx
  ctx <- closePath ctx
  stroke ctx

-- Define 3D and 2D Point objects
newtype Point3D = Point3D { x :: Number, y :: Number, z :: Number }

newtype Point2D = Point2D { x :: Number, y :: Number }

qx :: Number
qx = pi / 4.0

qy :: Number
qy = pi / 3.0

qz :: Number
qz = pi / 4.0

project :: Point3D -> Point2D
project (Point3D { x, y, z }) =
  let xRotQz = x * (cos qz) + y * (sin qz)
      yRotQz = y * (cos qz) - x * (sin qz)
      yRotQzQx = yRotQz * (cos qx) + z * (sin qx)
      zRotQzQx = z * (cos qx) - yRotQz * (sin qx)
      xRotQzQxQy = xRotQz * (cos qy) + zRotQzQx * (sin qy)
  in
    Point2D { x: xRotQzQxQy, y: yRotQzQx }

drawLine :: forall e. Context2D -> Point2D -> Point2D -> Eff (canvas :: CANVAS | e) Context2D
drawLine ctx (Point2D from) (Point2D to) = do
  ctx <- moveTo ctx from.x from.y
  lineTo ctx to.x to.y

newtype Cube = Cube
  { x :: Number
  , y :: Number
  , z :: Number
  , size :: Number
  , color :: String }

drawCube :: forall e. Context2D -> Cube -> Eff (canvas :: CANVAS | e) Context2D
drawCube ctx (Cube { color, x, y, z, size }) = do
  let half = size / 2.0
  let v1 = project $ Point3D { x: x - half, y: y - half, z: z - half }
  let v2 = project $ Point3D { x: x - half, y: y + half, z: z - half }
  let v3 = project $ Point3D { x: x - half, y: y - half, z: z + half }
  let v4 = project $ Point3D { x: x - half, y: y + half, z: z + half }
  let v5 = project $ Point3D { x: x + half, y: y - half, z: z - half }
  let v6 = project $ Point3D { x: x + half, y: y + half, z: z - half }
  let v7 = project $ Point3D { x: x + half, y: y - half, z: z + half }
  let v8 = project $ Point3D { x: x + half, y: y + half, z: z + half }
  withStroke ctx color \ctx -> do
    ctx <- drawLine ctx v1 v5
    ctx <- drawLine ctx v5 v6
    ctx <- drawLine ctx v6 v2
    ctx <- drawLine ctx v2 v1

    ctx <- drawLine ctx v3 v7
    ctx <- drawLine ctx v7 v8
    ctx <- drawLine ctx v8 v4
    ctx <- drawLine ctx v4 v3

    ctx <- drawLine ctx v1 v3
    ctx <- drawLine ctx v5 v7
    ctx <- drawLine ctx v6 v8
    drawLine ctx v2 v4

drawScene :: forall e. Context2D -> Eff (canvas :: CANVAS | e) Context2D
drawScene ctx = do
  ctx <- setFillStyle "rgb(122,230,232)" ctx
  fillRect ctx { x: 0.0, y: 0.0, w: 500.0, h: 400.0 }

main :: forall e. Eff (dom :: DOM, ref :: REF, canvas :: CANVAS | e) Unit
main =
  let
    state = { x: 300.0
            , y: 600.0
            , dx: 1.0
            , dy: 1.0 }
  in
    withAnimateContext "thecanvas" state \ctx state -> do
      ctx <- drawScene ctx
      void $ drawCube ctx $ Cube { x: state.x, y: state.y, z: 0.0, size: 200.0, color: "rgb(0,0,0)" }

      -- Update the state
      pure $ state { x = state.x + state.dx, y = state.y + state.dy }


Gauge gen

Gauge gen

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Setups.Chart.Gauge.Eval
  ( eval
  , module SlamData.Workspace.Card.Setups.Chart.Gauge.Model
  ) where

import SlamData.Prelude

import Data.Argonaut (Json, decodeJson, (.?))
import Data.Array as A
import Data.Foldable as F
import Data.List as L

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

import SlamData.Workspace.Card.CardType.ChartType (ChartType(Gauge))
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.Setups.Axis as Ax
import SlamData.Workspace.Card.Setups.Chart.ColorScheme (colors)
import SlamData.Workspace.Card.Setups.Chart.Common as SCC
import SlamData.Workspace.Card.Setups.Chart.Common.Positioning as BCP
import SlamData.Workspace.Card.Setups.Chart.Common.Tooltip as CCT
import SlamData.Workspace.Card.Setups.Chart.Gauge.Model (Model, ModelR)
import SlamData.Workspace.Card.Setups.Common.Eval as BCE
import SlamData.Workspace.Card.Setups.Dimension as D
import SlamData.Workspace.Card.Setups.Semantics as Sem

import SqlSquare as Sql

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

type GaugeItem =
  { name ∷ Maybe String
  , value ∷ Number
  }

type GaugeSerie =
  BCP.RadialPosition
  ( name ∷ Maybe String
  , items ∷ Array GaugeItem
  )

type Item =
  { measure ∷ Number
  , parallel ∷ Maybe String
  , multiple ∷ Maybe String
  }

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

buildProjections ∷ ModelR → L.List (Sql.Projection Sql.Sql)
buildProjections r = L.fromFoldable
  [ r.value # SCC.jcursorPrj # Sql.as "measure" # SCC.applyTransform r.value
  , r.multiple # maybe SCC.nullPrj SCC.jcursorPrj # Sql.as "multiple"
  , r.parallel # maybe SCC.nullPrj SCC.jcursorPrj # Sql.as "parallel"
  ]

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

buildPort ∷ ModelR → Ax.Axes → Array Json → Port.Port
buildPort m _ jarr =
  Port.ChartInstructions
    { options: buildOptions m $ buildData m jarr
    , chartType: Gauge
    }

buildData ∷ ModelR → Array Json → Array GaugeSerie
buildData r =
  foldMap (foldMap A.singleton ∘ decodeItem)
    >>> series
    >>> BCP.adjustRadialPositions

  where
  series ∷ Array Item → Array GaugeSerie
  series =
    BCE.groupOn _.parallel
      >>> map \(name × items) →
            { name
            , x: Nothing
            , y: Nothing
            , radius: Nothing
            , items: toPoint <$> items
            }

  toPoint ∷ Item → GaugeItem
  toPoint item = { name: item.multiple, value: item.measure }

buildOptions ∷ ModelR → Array GaugeSerie → DSL OptionI
buildOptions r series = do
  let
    cols =
      [ { label: D.jcursorLabel r.value, value: CCT.formatForeign ∘ _.value }
      ]
    opts = A.catMaybes
      [ r.parallel <#> \dim → { label: D.jcursorLabel dim, value: _.seriesName }
      , r.multiple <#> \dim → { label: D.jcursorLabel dim, value: _.name }
      ]

  E.tooltip do
    E.formatterItem (CCT.tableFormatter (const Nothing) (cols <> opts) ∘ pure)
    E.textStyle do
      E.fontFamily "Ubuntu, sans"
      E.fontSize 12

  E.colors colors

  E.series $ for_ series \serie → E.gauge do
    for_ serie.name E.name
    E.axisLine $ E.lineStyle $ E.setWidth $ E.pixels 10
    E.splitLine $ E.length 20
    traverse_ (E.buildGaugeRadius ∘ E.percents) serie.radius

    E.buildCenter do
      traverse_ (E.setX ∘ E.percents) serie.x
      traverse_ (E.setY ∘ E.percents) serie.y

    when (A.length serie.items > 1)
      $ E.title E.hidden

    E.detail do
      traverse_ E.formatterString serie.name
      when (A.length series < 2 ∧ A.length serie.items > 1) E.hidden
      E.buildOffsetCenter do
        E.setX $ E.percents zero
        E.setY $ E.percents 65.0
      E.textStyle do
        E.fontSize 16
        E.fontFamily "Ubuntu, sans"
        for_ (A.head colors) E.color

    if (A.length allValues > 1)
      then do
      for_ (F.minimum allValues) E.min
      for_ (F.maximum allValues) E.max
      else
      for_ (A.head allValues) \v → do
        E.min $ v / 2.0
        E.max $ v * 1.5

    E.buildItems
      $ for_ serie.items \item → E.addItem do
        E.value item.value
        traverse_ E.name item.name

  where
  allValues ∷ Array Number
  allValues = map _.value $ A.concatMap _.items series

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Setups.Chart.Gauge.Eval
  ( eval
  , module SlamData.Workspace.Card.Setups.Chart.Gauge.Model
  ) where

import SlamData.Prelude

import Control.Monad.State (class MonadState)
import Control.Monad.Throw (class MonadThrow)

import Data.Argonaut (JArray, Json)
import Data.Array as A
import Data.Foldable as F
import Data.Map as M
import Data.Lens ((^?), preview, _Just)

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

import SlamData.Quasar.Class (class QuasarDSL)
import SlamData.Workspace.Card.CardType.ChartType (ChartType(Gauge))
import SlamData.Workspace.Card.Eval.Monad as CEM
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.Setups.Chart.ColorScheme (colors)
import SlamData.Workspace.Card.Setups.Chart.Common.Positioning (RadialPosition, adjustRadialPositions)
import SlamData.Workspace.Card.Setups.Chart.Common.Tooltip as CCT
import SlamData.Workspace.Card.Setups.Chart.Gauge.Model (Model, ModelR)
import SlamData.Workspace.Card.Setups.Common.Eval (type (>>))
import SlamData.Workspace.Card.Setups.Common.Eval as BCE
import SlamData.Workspace.Card.Setups.Dimension as D
import SlamData.Workspace.Card.Setups.Semantics (getMaybeString, getValues)
import SlamData.Workspace.Card.Setups.Transform as T
import SlamData.Workspace.Card.Setups.Transform.Aggregation as Ag

eval
  ∷ ∀ m
  . ( MonadState CEM.CardState m
    , MonadThrow CEM.CardError m
    , QuasarDSL m
    )
  ⇒ Model
  → Port.Resource
  → m Port.Port
eval m = BCE.buildChartEval Gauge (const buildGauge) m \axes → m

----------------------------------------------------------------------
-- GAUGE BUILDER
----------------------------------------------------------------------

type GaugeItem =
  { name ∷ Maybe String
  , value ∷ Number
  }

type GaugeSerie =
  RadialPosition
  ( name ∷ Maybe String
  , items ∷ Array GaugeItem
  )

buildGaugeData ∷ ModelR → JArray → Array GaugeSerie
buildGaugeData r records = series
  where
  valueAndSizeMap ∷ Maybe String >> Maybe String >> Array Number
  valueAndSizeMap =
    foldl foldFn M.empty records

  foldFn
    ∷ Maybe String >> Maybe String >> Array Number
    → Json
    → Maybe String >> Maybe String >> Array Number
  foldFn acc js =
    let
       getMaybeStringFromJson = getMaybeString js
       getValuesFromJson = getValues js

       mbParallel =
         getMaybeStringFromJson =<< (preview $ D._value ∘ D._projection) =<< r.parallel
       mbMultiple =
         getMaybeStringFromJson =<< (preview $ D._value ∘ D._projection) =<< r.multiple
       values =
         getValuesFromJson $ r.value ^? D._value ∘ D._projection

       alterFn
         ∷ Maybe (Maybe String >> Array Number)
         → Maybe (Maybe String >> Array Number)
       alterFn Nothing = Just $ M.singleton mbMultiple values
       alterFn (Just multiple) =
         Just $ M.alter alterMultiple mbMultiple multiple

       alterMultiple
         ∷ Maybe (Array Number)
         → Maybe (Array Number)
       alterMultiple Nothing = Just values
       alterMultiple (Just arr) = Just $ arr ⊕ values
    in
      M.alter alterFn mbParallel acc

  mkSerie ∷ Maybe String × (Maybe String >> Array Number) → Array GaugeSerie
  mkSerie (name × mp) =
    let
      pairs ∷ Array (Maybe String × Array Number)
      pairs = A.fromFoldable $ M.toList mp
      items = pairs <#> \(name × values) →
        { name
        , value:
            Ag.runAggregation
              (fromMaybe Ag.Sum $ r.value ^? D._value ∘ D._transform ∘ _Just ∘ T._Aggregation)
              values
        }

    in [ { radius: Nothing
         , items
         , x: Nothing
         , y: Nothing
         , name
         }
       ]

  unpositionedSeries ∷ Array GaugeSerie
  unpositionedSeries =
    foldMap mkSerie $ M.toList valueAndSizeMap

  series ∷ Array GaugeSerie
  series = adjustRadialPositions unpositionedSeries

buildGauge ∷ ModelR → JArray → DSL OptionI
buildGauge r records = do
  let
    cols =
      [ { label: D.jcursorLabel r.value, value: CCT.formatForeign ∘ _.value }
      ]
    opts = A.catMaybes
      [ r.parallel <#> \dim → { label: D.jcursorLabel dim, value: _.seriesName }
      , r.multiple <#> \dim → { label: D.jcursorLabel dim, value: _.name }
      ]

  E.tooltip do
    E.formatterItem (CCT.tableFormatter (const Nothing) (cols <> opts) ∘ pure)
    E.textStyle do
      E.fontFamily "Ubuntu, sans"
      E.fontSize 12

  E.colors colors

  E.series $ for_ series \serie → E.gauge do
    for_ serie.name E.name
    E.axisLine $ E.lineStyle $ E.setWidth $ E.pixels 10
    E.splitLine $ E.length 20
    traverse_ (E.buildGaugeRadius ∘ E.percents) serie.radius

    E.buildCenter do
      traverse_ (E.setX ∘ E.percents) serie.x
      traverse_ (E.setY ∘ E.percents) serie.y

    when (A.length serie.items > 1)
      $ E.title E.hidden

    E.detail do
      traverse_ E.formatterString serie.name
      when (A.length series < 2 ∧ A.length serie.items > 1) E.hidden
      E.buildOffsetCenter do
        E.setX $ E.percents zero
        E.setY $ E.percents 65.0
      E.textStyle do
        E.fontSize 16
        E.fontFamily "Ubuntu, sans"
        for_ (A.head colors) E.color

    if (A.length allValues > 1)
      then do
      for_ (F.minimum allValues) E.min
      for_ (F.maximum allValues) E.max
      else
      for_ (A.head allValues) \v → do
        E.min $ v / 2.0
        E.max $ v * 1.5

    E.buildItems
      $ for_ serie.items \item → E.addItem do
        E.value item.value
        traverse_ E.name item.name

  where
  series ∷ Array GaugeSerie
  series = buildGaugeData r records

  allValues ∷ Array Number
  allValues = map _.value $ A.concatMap _.items series


Removed unused elements until later.

Removed unused elements until later.

module ControllerMain where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import AirConsole.Global ( getAirConsoleGlobal
                         , orientationPortrait
                         )
import Views.ControllerStart (view)
import Views.FFI (onDOMContentLoaded)
import DOM (DOM)

foreign import isNullOrUndefined :: forall a. a -> Boolean

main :: forall e. Eff (dom :: DOM, console :: CONSOLE | e) Unit
main = onDOMContentLoaded do
  ac <- getAirConsoleGlobal { orientation: orientationPortrait }
  view ac
  log "Controller Ready!"

module ControllerMain where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import AirConsole.Global ( getAirConsoleGlobal
                         , orientationPortrait
                         , screen
                         , onMessage
                         , onActivePlayersChange
                         )
import AirConsole.ControllerInputs (vibrate)
import Views.ControllerStart (view)
import Views.FFI (renderToSel, onDOMContentLoaded)

import Text.Smolder.HTML (button)
import Text.Smolder.Markup (text, on, (#!))
import Text.Smolder.Renderer.String (render)
import DOM (DOM)

foreign import isNullOrUndefined :: forall a. a -> Boolean

main :: forall e. Eff (dom :: DOM, console :: CONSOLE | e) Unit
main = onDOMContentLoaded do
  ac <- getAirConsoleGlobal { orientation: orientationPortrait }
  view ac
  log "Done!"
  -- _ <- onMessage
        -- (\from d -> if d.vibrate && from == screen
                    -- then vibrate ac 1000
                    -- else pure unit) ac
  -- _ <- onActivePlayersChange
        -- (\d -> if isNullOrUndefined d
               -- then renderToSel ".player_id" "It's a 2 player game!"
               -- else renderToSel ".player_id" ("Player " <> show d)) ac
  -- log "Controller Ready"


Nicer Swift output

Nicer Swift output

Original commit 1e3f50348d5736124dda730a6eff8320f002e3ce

module Language.Swift
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Array as A
import Data.Char.Unicode (isAlphaNum, isDigit)
import Data.Foldable (for_)
import Data.FoldableWithIndex (forWithIndex_)
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..))
import Data.Set (Set)
import Data.Set as S
import Data.String.Util (camelCase, capitalize, decapitalize, genericStringEscape, intToHex, legalizeCharacters, startWithLetter)
import Data.Tuple (Tuple(..))
import Utils (removeElement)

keywords :: Array String
keywords =
    [ "associatedtype", "class", "deinit", "enum", "extension", "fileprivate", "func", "import", "init", "inout", "internal", "let", "open", "operator", "private", "protocol", "public", "static", "struct", "subscript", "typealias", "var"
    , "break", "case", "continue", "default", "defer", "do", "else", "fallthrough", "for", "guard", "if", "in", "repeat", "return", "switch", "where", "while"
    , "as", "Any", "catch", "false", "is", "nil", "rethrows", "super", "self", "Self", "throw", "throws", "true", "try"
    , "_"
    , "associativity", "convenience", "dynamic", "didSet", "final", "get", "infix", "indirect", "lazy", "left", "mutating", "nonmutating", "optional", "override", "postfix", "precedence", "prefix", "Protocol", "required", "right", "set", "Type", "unowned", "weak", "willSet"
    , "String", "Int", "Double", "Bool", "Data", "CommandLine", "FileHandle", "JSONSerialization"
    , "checkNull", "removeNSNull", "nilToNSNull", "convertArray", "convertOptional", "convertDict", "convertDouble"
    ]

renderer :: Renderer
renderer =
    { name: "Swift"
    , aceMode: "swift"
    , extension: "swift"
    , doc: swiftDoc
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames: keywords
        , topLevelName: noForbidNamer (swiftNameStyle true)
        , unions: Just
            { predicate: unionIsNotSimpleNullable
            , properName: simpleNamer (swiftNameStyle true <<< combineNames)
            , nameFromTypes: simpleNamer (unionNameIntercalated (swiftNameStyle true) "Or")
            }
        }
    }

swiftNameStyle :: Boolean -> String -> String
swiftNameStyle isUpper =
    legalizeCharacters isPartCharacter >>> camelCase >>> startWithLetter isStartCharacter isUpper
    where
        isStartCharacter :: Char -> Boolean
        isStartCharacter c = c == '_' || (isAlphaNum c && not (isDigit c))

        isPartCharacter :: Char -> Boolean
        isPartCharacter c = c == '_' || isAlphaNum c

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = swiftNameStyle true $ combineNames names

stringEscape :: String -> String
stringEscape =
    genericStringEscape unicodeEscape
    where
        unicodeEscape i =
            ['\\', 'u', '{'] <> intToHex 0 i <> ['}']

swiftDoc :: Doc Unit
swiftDoc = do
    line "// To decode the JSON data, add this file to your project and do"
    line "//"
    forEachTopLevel_ \topLevelName topLevelType -> do
        line $ "//     guard let my" <> topLevelName <> " = " <> (decapitalize topLevelName) <> "(fromJSONData: myData)"
    blank
    line "import Foundation"
    blank
    topLevelPlural <- getTopLevelPlural
    line $ "// deserialization and serialization helper functions for top level type" <> topLevelPlural
    forEachTopLevel_ \topLevelName topLevelType -> do
        blank
        rendered <- renderType topLevelType
        line $ "func " <> (decapitalize topLevelName) <> "(fromJSONData data: Data) -> " <> rendered <> "? {"
        indent do
            line "if let json = try? JSONSerialization.jsonObject(with: data, options: []) {"
            indent do
                convertCode <- convertAny topLevelType "json"
                line $ "return " <> convertCode
            line "}"
            line "return nil"
        line "}"
        blank
        line $ "func jsonData(from" <> topLevelName <> " x: " <> rendered <> ") -> Data? {"
        indent do
            convertCode <- convertToAny topLevelType "x"
            line $ "let json = " <> convertCode
            line "return try? JSONSerialization.data(withJSONObject: json, options: [])"
        line "}"
    blank
    line "// JSON types"
    forEachClass_ \className properties -> do
        blank
        renderClassDefinition className properties
    forEachUnion_ \unionName unionTypes -> do
        blank
        renderUnionDefinition unionName unionTypes
    blank
    line """// support functions

fileprivate func convertArray<T>(converter: (Any) -> T?, json: Any) -> [T]? {
    guard let jsonArr = json as? [Any] else { return nil }
    var arr: [T] = []
    for v in jsonArr {
        if let converted = converter(v) {
            arr.append(converted)
        } else {
            return nil
        }
    }
    return arr
}

fileprivate func convertOptional<T>(converter: (Any) -> T?, json: Any?) -> T?? {
    guard let v = json
    else {
        return Optional.some(nil)
    }
    return converter(v)
}

fileprivate func convertDict<T>(converter: (Any) -> T?, json: Any?) -> [String: T]? {
    guard let jsonDict = json as? [String: Any] else { return nil }
    var dict: [String: T] = [:]
    for (k, v) in jsonDict {
        if let converted = converter(v) {
            dict[k] = converted
        } else {
            return nil
        }
    }
    return dict
}

fileprivate func convertToAny<T>(dictionary: [String: T], converter: (T) -> Any) -> Any {
    var result: [String: Any] = [:]
    for (k, v) in dictionary {
        result[k] = converter(v)
    }
    return result
}

fileprivate func convertDouble(_ v: Any) -> Double? {
    if let w = v as? Double {
        return w
    }
    if let w = v as? Int {
        return Double(w)
    }
    return nil
}

fileprivate let falseType = NSNumber(value: false).objCType
fileprivate let trueNumber = NSNumber(value: true)
fileprivate let trueType = trueNumber.objCType

fileprivate func convertBool(_ v: Any?) -> Bool? {
    guard let number = v as? NSNumber
    else {
        if let b = v as? Bool {
            return b
        }
        return nil
    }

    if number.objCType != falseType && number.objCType != trueType {
        return nil
    }
    return number.isEqual(trueNumber)
}

fileprivate func removeNSNull(_ v: Any?) -> Any? {
    if let w = v {
        if w is NSNull {
            return nil
        }
        return w
    }
    return nil
}

fileprivate func checkNull(_ v: Any?) -> Any?? {
    if v != nil {
        return Optional.none
    }
    return Optional.some(nil)
}"""

renderUnion :: IRUnionRep -> Doc String
renderUnion ur =
    case nullableFromSet $ unionToSet ur of
    Just r -> do
        rendered <- renderType r
        pure $ rendered <> "?"
    Nothing -> lookupUnionName ur

renderType :: IRType -> Doc String
renderType = case _ of
    IRNothing -> pure "Any?"
    IRNull -> pure "Any?"
    IRInteger -> pure "Int"
    IRDouble -> pure "Double"
    IRBool -> pure "Bool"
    IRString -> pure "String"
    IRArray a -> do
        rendered <- renderType a
        pure $ "[" <> rendered <> "]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderType t
        pure $ "[String: " <> rendered <> "]"
    IRUnion ur -> renderUnion ur

convertAnyFunc :: IRType -> Doc String
convertAnyFunc (IRClass i) = do
    name <- lookupClassName i
    pure $ name <> ".init"
convertAnyFunc (IRUnion ur) =
    case nullableFromSet $ unionToSet ur of
    Just t -> do
        converter <- convertAnyFunc t
        pure $ "{ (json: Any) in convertOptional(converter: " <> converter <> ", json: json) }"
    Nothing -> do
        name <- lookupUnionName ur
        pure $ name <> ".fromJson"
convertAnyFunc IRDouble =
    pure "convertDouble"
convertAnyFunc IRNull =
    pure "checkNull"
convertAnyFunc t = do
    converted <- convertAny t "json"
    pure $ "{ (json: Any) in " <> converted <> " }"

convertAny :: IRType -> String -> Doc String
convertAny (IRArray a) var = do
    converter <- convertAnyFunc a
    pure $ "convertArray(converter: " <> converter <> ", json: " <> var <> ")"
convertAny (IRMap m) var = do
    converter <- convertAnyFunc m
    pure $ "convertDict(converter: " <> converter <> ", json: " <> var <> ")"
convertAny (IRUnion ur) var =
    case nullableFromSet $ unionToSet ur of
    Just t -> do
        converter <- convertAnyFunc t
        pure $ "convertOptional(converter: " <> converter <> ", json: " <> var <> ")"
    Nothing -> do
        name <- lookupUnionName ur
        pure $ name <> ".fromJson(" <> var <> ")"
convertAny IRNothing var =
    pure var
convertAny IRBool var =
    pure $ "convertBool(" <> var <> ")"
convertAny IRInteger var =
    pure $ var <> " as? Int"
convertAny IRString var =
    pure $ var <> " as? String"
convertAny t var = do
    converter <- convertAnyFunc t
    pure $ converter <> "(" <> var <> ")"

convertToAny :: IRType -> String -> Doc String
convertToAny (IRArray a) var = do
    rendered <- renderType a
    convertCode <- convertToAny a "v"
    pure $ var <> ".map({ (v: " <> rendered <> ") in " <> convertCode <> " }) as Any"
convertToAny (IRMap m) var = do
    rendered <- renderType m
    convertCode <- convertToAny m "v"
    pure $ "convertToAny(dictionary: " <> var <> ", converter: { (v: " <> rendered <> ") in " <> convertCode <> " })"
convertToAny (IRClass i) var =
    pure $ var <> ".toJSON()"
convertToAny (IRUnion ur) var =
    case nullableFromSet $ unionToSet ur of
    Just t -> do
        rendered <- renderType t
        convertCode <- convertToAny t "v"
        pure $ var <> ".map({ (v: " <> rendered <> ") in " <> convertCode  <> " }) ?? NSNull()"
    Nothing ->
        pure $ var <> ".toJSON()"
convertToAny IRNothing var =
    pure $ var <> " ?? NSNull()"
convertToAny IRNull var =
    pure $ "NSNull() as Any"
convertToAny _ var =
    pure $ var <> " as Any"

renderClassDefinition :: String -> Map String IRType -> Doc Unit
renderClassDefinition className properties = do
    let forbidden = keywords <> ["jsonUntyped", "json"]
    let propertyNames = makePropertyNames "" forbidden
    line $ "struct " <> className <> " {"
    indent do
        forEachProperty_ properties propertyNames \_ ptype fieldName _ -> do
            rendered <- renderType ptype
            line $ "let " <> fieldName <> ": " <> rendered
        blank
        line $ "init?(_ jsonUntyped: Any) {"
        indent do
            line "guard let json = jsonUntyped as? [String: Any] else { return nil }"
            let forbiddenForUntyped = forbidden <> (A.fromFoldable $ M.keys propertyNames)
            let untypedNames = makePropertyNames "Untyped" forbiddenForUntyped
            let forbiddenForConverted = forbiddenForUntyped <> (A.fromFoldable $ M.keys untypedNames)
            let convertedNames = makePropertyNames "Converted" forbiddenForConverted
            forEachProperty_ properties untypedNames \pname ptype untypedName _ -> do
                when (canBeNull ptype) do
                    line $ "let " <> untypedName <> " = removeNSNull(json[\"" <> stringEscape pname <> "\"])"
            unless (M.isEmpty properties) do
                line "guard"
                indent do
                    forEachProperty_ properties untypedNames \pname ptype untypedName isLast -> do
                        let convertedName = lookupName pname convertedNames
                        unless (canBeNull ptype) do
                            line $ "let " <> untypedName <> " = removeNSNull(json[\"" <> stringEscape pname <> "\"]),"
                        convertCode <- convertAny ptype untypedName
                        line $ "let " <> convertedName <> " = " <> convertCode <> (if isLast then "" else ",")
                line "else {"
                indent do
                    line "return nil"
                line "}"
            forEachProperty_ properties propertyNames \pname _ fieldName _ -> do
                let convertedName = lookupName pname convertedNames
                line $ "self." <> fieldName <> " = " <> convertedName
        line "}"
        blank
        line "func toJSON() -> Any {"
        indent do
            line "var dict: [String: Any] = [:]"
            forEachProperty_ properties propertyNames \pname ptype fieldName _ -> do
                convertCode <- convertToAny ptype ("self." <> fieldName)
                line $ "dict[\"" <> stringEscape pname <> "\"] = " <> convertCode
            line "return dict"
        line "}"
    line "}"
    where
        isSimpleNullable :: IRType -> Boolean
        isSimpleNullable (IRUnion ur) = not $ unionIsNotSimpleNullable ur
        isSimpleNullable _ = false

        maybeCast :: IRType -> String
        maybeCast (IRArray _) = " as? [Any]"
        maybeCast (IRClass _) = " as? [String: Any]"
        maybeCast (IRMap _) = " as? [String: Any]"
        maybeCast _ = ""

        isBuiltInType :: IRType -> Boolean
        isBuiltInType (IRArray a) = isBuiltInType a
        isBuiltInType (IRMap m) = isBuiltInType m
        isBuiltInType (IRClass _) = false
        isBuiltInType (IRUnion ur) =
            case nullableFromSet $ unionToSet ur of
            Just t -> isBuiltInType t
            Nothing -> false
        isBuiltInType _ = true

        forEachProperty_ :: Map String IRType -> Map String String -> (String -> IRType -> String -> Boolean -> Doc Unit) -> Doc Unit
        forEachProperty_ properties propertyNames f =
            let propertyArray = M.toUnfoldable properties :: Array _
                lastIndex = (A.length propertyArray) - 1
            in
                forWithIndex_ propertyArray \i (Tuple pname ptype) -> do
                    let fieldName = lookupName pname propertyNames
                    f pname ptype fieldName (i == lastIndex)

        makePropertyNames :: String -> Array String -> Map String String
        makePropertyNames suffix forbidden =
            transformPropertyNames (fieldNamer suffix) otherField forbidden properties

        fieldNamer :: String -> Namer String
        fieldNamer suffix =
            simpleNamer \name -> swiftNameStyle false name <> suffix

        otherField :: String -> String
        otherField name =
            "other" <> capitalize name

renderUnionDefinition :: String -> Set IRType -> Doc Unit
renderUnionDefinition unionName unionTypes = do
    let { element: emptyOrNull, rest: nonNullTypes } = removeElement (_ == IRNull) unionTypes
    line $ "enum " <> unionName <> " {"
    indent do
        for_ nonNullTypes \typ -> do
            name <- caseName typ
            rendered <- renderType typ
            line $ "case " <> name <> "(" <> rendered <> ")"
        case emptyOrNull of
            Just t -> do
                name <- caseName t
                line $ "case " <> name
            Nothing -> pure unit
        blank
        line $ "static func fromJson(_ v: Any) -> " <> unionName <> "? {"
        indent do
            case emptyOrNull of
                Just t -> do
                    name <- caseName t
                    line "guard let v = removeNSNull(v)"
                    line "else {"
                    indent do
                        line $ "return " <> unionName <> "." <> name
                    line "}"
                Nothing -> pure unit
            when (S.member IRBool unionTypes) do
                renderCase IRBool
            when (S.member IRInteger unionTypes) do
                renderCase IRInteger
            for_ (S.difference nonNullTypes $ S.fromFoldable [IRBool, IRInteger]) \typ -> do
                renderCase typ
            line "return nil"
        line "}"
        blank
        line $ "func toJSON() -> Any {"
        indent do
            line $ "switch self {"
            for_ unionTypes \typ -> do
                name <- caseName typ
                let letString = if typ == IRNull then "" else "(let x)"
                line $ "case ." <> name <> letString <> ":"
                indent do
                    convertCode <- convertToAny typ "x"
                    line $ "return " <> convertCode
            line "}"
        line "}"
    line "}"
    where
        caseName :: IRType -> Doc String
        caseName t = swiftNameStyle false <$> getTypeNameForUnion t

        renderCase :: IRType -> Doc Unit
        renderCase t = do
            convertCode <- convertAny t "v"
            line $ "if let x = " <> convertCode <> " {"
            indent do
                name <- caseName t
                line $ "return " <> unionName <> "." <> name <> "(x)"
            line "}"

module Language.Swift
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Array as A
import Data.Char.Unicode (isAlphaNum, isDigit)
import Data.Foldable (for_)
import Data.FoldableWithIndex (forWithIndex_)
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..))
import Data.Set (Set)
import Data.Set as S
import Data.String.Util (camelCase, capitalize, decapitalize, genericStringEscape, intToHex, legalizeCharacters, startWithLetter)
import Data.Tuple (Tuple(..))
import Utils (removeElement)

keywords :: Array String
keywords =
    [ "associatedtype", "class", "deinit", "enum", "extension", "fileprivate", "func", "import", "init", "inout", "internal", "let", "open", "operator", "private", "protocol", "public", "static", "struct", "subscript", "typealias", "var"
    , "break", "case", "continue", "default", "defer", "do", "else", "fallthrough", "for", "guard", "if", "in", "repeat", "return", "switch", "where", "while"
    , "as", "Any", "catch", "false", "is", "nil", "rethrows", "super", "self", "Self", "throw", "throws", "true", "try"
    , "_"
    , "associativity", "convenience", "dynamic", "didSet", "final", "get", "infix", "indirect", "lazy", "left", "mutating", "nonmutating", "optional", "override", "postfix", "precedence", "prefix", "Protocol", "required", "right", "set", "Type", "unowned", "weak", "willSet"
    , "String", "Int", "Double", "Bool", "Data", "CommandLine", "FileHandle", "JSONSerialization"
    , "checkNull", "removeNSNull", "nilToNSNull", "convertArray", "convertOptional", "convertDict", "convertDouble"
    ]

renderer :: Renderer
renderer =
    { name: "Swift"
    , aceMode: "swift"
    , extension: "swift"
    , doc: swiftDoc
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames: keywords
        , topLevelName: noForbidNamer (swiftNameStyle true)
        , unions: Just
            { predicate: unionIsNotSimpleNullable
            , properName: simpleNamer (swiftNameStyle true <<< combineNames)
            , nameFromTypes: simpleNamer (unionNameIntercalated (swiftNameStyle true) "Or")
            }
        }
    }

swiftNameStyle :: Boolean -> String -> String
swiftNameStyle isUpper =
    legalizeCharacters isPartCharacter >>> camelCase >>> startWithLetter isStartCharacter isUpper
    where
        isStartCharacter :: Char -> Boolean
        isStartCharacter c = c == '_' || (isAlphaNum c && not (isDigit c))

        isPartCharacter :: Char -> Boolean
        isPartCharacter c = c == '_' || isAlphaNum c

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = swiftNameStyle true $ combineNames names

stringEscape :: String -> String
stringEscape =
    genericStringEscape unicodeEscape
    where
        unicodeEscape i =
            ['\\', 'u', '{'] <> intToHex 0 i <> ['}']

swiftDoc :: Doc Unit
swiftDoc = do
    line "import Foundation"
    forEachTopLevel_ \topLevelName topLevelType -> do
        blank
        rendered <- renderType topLevelType
        line $ "func " <> (decapitalize topLevelName) <> "(fromJSONData data: Data) -> " <> rendered <> "? {"
        indent do
            line "if let json = try? JSONSerialization.jsonObject(with: data, options: []) {"
            indent do
                convertCode <- convertAny topLevelType "json"
                line $ "return " <> convertCode
            line "}"
            line "return nil"
        line "}"
        blank
        line $ "func jsonData(from" <> topLevelName <> " x: " <> rendered <> ") -> Data? {"
        indent do
            convertCode <- convertToAny topLevelType "x"
            line $ "let json = " <> convertCode
            line "return try? JSONSerialization.data(withJSONObject: json, options: [])"
        line "}"
    forEachClass_ \className properties -> do
        blank
        renderClassDefinition className properties
    forEachUnion_ \unionName unionTypes -> do
        blank
        renderUnionDefinition unionName unionTypes
    blank
    line """func convertArray<T>(converter: (Any) -> T?, json: Any) -> [T]? {
    guard let jsonArr = json as? [Any] else { return nil }
    var arr: [T] = []
    for v in jsonArr {
        if let converted = converter(v) {
            arr.append(converted)
        } else {
            return nil
        }
    }
    return arr
}

func convertOptional<T>(converter: (Any) -> T?, json: Any?) -> T?? {
    guard let v = json
    else {
        return Optional.some(nil)
    }
    return converter(v)
}

func convertDict<T>(converter: (Any) -> T?, json: Any?) -> [String: T]? {
    guard let jsonDict = json as? [String: Any] else { return nil }
    var dict: [String: T] = [:]
    for (k, v) in jsonDict {
        if let converted = converter(v) {
            dict[k] = converted
        } else {
            return nil
        }
    }
    return dict
}

func convertToAny<T>(dictionary: [String: T], converter: (T) -> Any) -> Any {
    var result: [String: Any] = [:]
    for (k, v) in dictionary {
        result[k] = converter(v)
    }
    return result
}

func convertDouble(_ v: Any) -> Double? {
    if let w = v as? Double {
        return w
    }
    if let w = v as? Int {
        return Double(w)
    }
    return nil
}

let falseType = NSNumber(value: false).objCType
let trueNumber = NSNumber(value: true)
let trueType = trueNumber.objCType

func convertBool(_ v: Any?) -> Bool? {
    guard let number = v as? NSNumber
    else {
        if let b = v as? Bool {
            return b
        }
        return nil
    }

    if number.objCType != falseType && number.objCType != trueType {
        return nil
    }
    return number.isEqual(trueNumber)
}

func removeNSNull(_ v: Any?) -> Any? {
    if let w = v {
        if w is NSNull {
            return nil
        }
        return w
    }
    return nil
}

func checkNull(_ v: Any?) -> Any?? {
    if v != nil {
        return Optional.none
    }
    return Optional.some(nil)
}"""

renderUnion :: IRUnionRep -> Doc String
renderUnion ur =
    case nullableFromSet $ unionToSet ur of
    Just r -> do
        rendered <- renderType r
        pure $ rendered <> "?"
    Nothing -> lookupUnionName ur

renderType :: IRType -> Doc String
renderType = case _ of
    IRNothing -> pure "Any?"
    IRNull -> pure "Any?"
    IRInteger -> pure "Int"
    IRDouble -> pure "Double"
    IRBool -> pure "Bool"
    IRString -> pure "String"
    IRArray a -> do
        rendered <- renderType a
        pure $ "[" <> rendered <> "]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderType t
        pure $ "[String: " <> rendered <> "]"
    IRUnion ur -> renderUnion ur

convertAnyFunc :: IRType -> Doc String
convertAnyFunc (IRClass i) = do
    name <- lookupClassName i
    pure $ name <> ".init"
convertAnyFunc (IRUnion ur) =
    case nullableFromSet $ unionToSet ur of
    Just t -> do
        converter <- convertAnyFunc t
        pure $ "{ (json: Any) in convertOptional(converter: " <> converter <> ", json: json) }"
    Nothing -> do
        name <- lookupUnionName ur
        pure $ name <> ".fromJson"
convertAnyFunc IRDouble =
    pure "convertDouble"
convertAnyFunc IRNull =
    pure "checkNull"
convertAnyFunc t = do
    converted <- convertAny t "json"
    pure $ "{ (json: Any) in " <> converted <> " }"

convertAny :: IRType -> String -> Doc String
convertAny (IRArray a) var = do
    converter <- convertAnyFunc a
    pure $ "convertArray(converter: " <> converter <> ", json: " <> var <> ")"
convertAny (IRMap m) var = do
    converter <- convertAnyFunc m
    pure $ "convertDict(converter: " <> converter <> ", json: " <> var <> ")"
convertAny (IRUnion ur) var =
    case nullableFromSet $ unionToSet ur of
    Just t -> do
        converter <- convertAnyFunc t
        pure $ "convertOptional(converter: " <> converter <> ", json: " <> var <> ")"
    Nothing -> do
        name <- lookupUnionName ur
        pure $ name <> ".fromJson(" <> var <> ")"
convertAny IRNothing var =
    pure var
convertAny IRBool var =
    pure $ "convertBool(" <> var <> ")"
convertAny IRInteger var =
    pure $ var <> " as? Int"
convertAny IRString var =
    pure $ var <> " as? String"
convertAny t var = do
    converter <- convertAnyFunc t
    pure $ converter <> "(" <> var <> ")"

convertToAny :: IRType -> String -> Doc String
convertToAny (IRArray a) var = do
    rendered <- renderType a
    convertCode <- convertToAny a "v"
    pure $ var <> ".map({ (v: " <> rendered <> ") in " <> convertCode <> " }) as Any"
convertToAny (IRMap m) var = do
    rendered <- renderType m
    convertCode <- convertToAny m "v"
    pure $ "convertToAny(dictionary: " <> var <> ", converter: { (v: " <> rendered <> ") in " <> convertCode <> " })"
convertToAny (IRClass i) var =
    pure $ var <> ".toJSON()"
convertToAny (IRUnion ur) var =
    case nullableFromSet $ unionToSet ur of
    Just t -> do
        rendered <- renderType t
        convertCode <- convertToAny t "v"
        pure $ var <> ".map({ (v: " <> rendered <> ") in " <> convertCode  <> " }) ?? NSNull()"
    Nothing ->
        pure $ var <> ".toJSON()"
convertToAny IRNothing var =
    pure $ var <> " ?? NSNull()"
convertToAny IRNull var =
    pure $ "NSNull() as Any"
convertToAny _ var =
    pure $ var <> " as Any"

renderClassDefinition :: String -> Map String IRType -> Doc Unit
renderClassDefinition className properties = do
    let forbidden = keywords <> ["jsonUntyped", "json"]
    let propertyNames = makePropertyNames "" forbidden
    line $ "struct " <> className <> " {"
    indent do
        forEachProperty_ properties propertyNames \_ ptype fieldName _ -> do
            rendered <- renderType ptype
            line $ "let " <> fieldName <> ": " <> rendered
        blank
        line $ "init?(_ jsonUntyped: Any) {"
        indent do
            line "guard let json = jsonUntyped as? [String: Any] else { return nil }"
            let forbiddenForUntyped = forbidden <> (A.fromFoldable $ M.keys propertyNames)
            let untypedNames = makePropertyNames "Untyped" forbiddenForUntyped
            let forbiddenForConverted = forbiddenForUntyped <> (A.fromFoldable $ M.keys untypedNames)
            let convertedNames = makePropertyNames "Converted" forbiddenForConverted
            forEachProperty_ properties untypedNames \pname ptype untypedName _ -> do
                when (canBeNull ptype) do
                    line $ "let " <> untypedName <> " = removeNSNull(json[\"" <> stringEscape pname <> "\"])"
            unless (M.isEmpty properties) do
                line "guard"
                indent do
                    forEachProperty_ properties untypedNames \pname ptype untypedName isLast -> do
                        let convertedName = lookupName pname convertedNames
                        unless (canBeNull ptype) do
                            line $ "let " <> untypedName <> " = removeNSNull(json[\"" <> stringEscape pname <> "\"]),"
                        convertCode <- convertAny ptype untypedName
                        line $ "let " <> convertedName <> " = " <> convertCode <> (if isLast then "" else ",")
                line "else {"
                indent do
                    line "return nil"
                line "}"
            forEachProperty_ properties propertyNames \pname _ fieldName _ -> do
                let convertedName = lookupName pname convertedNames
                line $ "self." <> fieldName <> " = " <> convertedName
        line "}"
        blank
        line "func toJSON() -> Any {"
        indent do
            line "var dict: [String: Any] = [:]"
            forEachProperty_ properties propertyNames \pname ptype fieldName _ -> do
                convertCode <- convertToAny ptype ("self." <> fieldName)
                line $ "dict[\"" <> stringEscape pname <> "\"] = " <> convertCode
            line "return dict"
        line "}"
    line "}"
    where
        isSimpleNullable :: IRType -> Boolean
        isSimpleNullable (IRUnion ur) = not $ unionIsNotSimpleNullable ur
        isSimpleNullable _ = false

        maybeCast :: IRType -> String
        maybeCast (IRArray _) = " as? [Any]"
        maybeCast (IRClass _) = " as? [String: Any]"
        maybeCast (IRMap _) = " as? [String: Any]"
        maybeCast _ = ""

        isBuiltInType :: IRType -> Boolean
        isBuiltInType (IRArray a) = isBuiltInType a
        isBuiltInType (IRMap m) = isBuiltInType m
        isBuiltInType (IRClass _) = false
        isBuiltInType (IRUnion ur) =
            case nullableFromSet $ unionToSet ur of
            Just t -> isBuiltInType t
            Nothing -> false
        isBuiltInType _ = true

        forEachProperty_ :: Map String IRType -> Map String String -> (String -> IRType -> String -> Boolean -> Doc Unit) -> Doc Unit
        forEachProperty_ properties propertyNames f =
            let propertyArray = M.toUnfoldable properties :: Array _
                lastIndex = (A.length propertyArray) - 1
            in
                forWithIndex_ propertyArray \i (Tuple pname ptype) -> do
                    let fieldName = lookupName pname propertyNames
                    f pname ptype fieldName (i == lastIndex)

        makePropertyNames :: String -> Array String -> Map String String
        makePropertyNames suffix forbidden =
            transformPropertyNames (fieldNamer suffix) otherField forbidden properties

        fieldNamer :: String -> Namer String
        fieldNamer suffix =
            simpleNamer \name -> swiftNameStyle false name <> suffix

        otherField :: String -> String
        otherField name =
            "other" <> capitalize name

renderUnionDefinition :: String -> Set IRType -> Doc Unit
renderUnionDefinition unionName unionTypes = do
    let { element: emptyOrNull, rest: nonNullTypes } = removeElement (_ == IRNull) unionTypes
    line $ "enum " <> unionName <> " {"
    indent do
        for_ nonNullTypes \typ -> do
            name <- caseName typ
            rendered <- renderType typ
            line $ "case " <> name <> "(" <> rendered <> ")"
        case emptyOrNull of
            Just t -> do
                name <- caseName t
                line $ "case " <> name
            Nothing -> pure unit
        blank
        line $ "static func fromJson(_ v: Any) -> " <> unionName <> "? {"
        indent do
            case emptyOrNull of
                Just t -> do
                    name <- caseName t
                    line "guard let v = removeNSNull(v)"
                    line "else {"
                    indent do
                        line $ "return " <> unionName <> "." <> name
                    line "}"
                Nothing -> pure unit
            when (S.member IRBool unionTypes) do
                renderCase IRBool
            when (S.member IRInteger unionTypes) do
                renderCase IRInteger
            for_ (S.difference nonNullTypes $ S.fromFoldable [IRBool, IRInteger]) \typ -> do
                renderCase typ
            line "return nil"
        line "}"
        blank
        line $ "func toJSON() -> Any {"
        indent do
            line $ "switch self {"
            for_ unionTypes \typ -> do
                name <- caseName typ
                let letString = if typ == IRNull then "" else "(let x)"
                line $ "case ." <> name <> letString <> ":"
                indent do
                    convertCode <- convertToAny typ "x"
                    line $ "return " <> convertCode
            line "}"
        line "}"
    line "}"
    where
        caseName :: IRType -> Doc String
        caseName t = swiftNameStyle false <$> getTypeNameForUnion t

        renderCase :: IRType -> Doc Unit
        renderCase t = do
            convertCode <- convertAny t "v"
            line $ "if let x = " <> convertCode <> " {"
            indent do
                name <- caseName t
                line $ "return " <> unionName <> "." <> name <> "(x)"
            line "}"


Actually use the passed selector

Actually use the passed selector

Fixes #8

module Control.Monad.JQuery where

import Data.Foreign
import Control.Monad.Eff

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

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

-- Type of jQuery event objects
foreign import data JQueryEvent :: *

-- $(document).ready(function() { ... })
foreign import ready
  "function ready(func) { \
  \  return function () { \
  \    jQuery(document).ready(func); \
  \  }; \
  \}" :: forall eff a. Eff eff a -> Eff (dom :: DOM | eff) JQuery

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

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

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

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

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

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

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

-- .prop({ ... })
foreign import setProp
  "function setProp(p) { \
  \  return function(val) { \
  \    return function(ob) { \
  \      return function () { \
  \        return ob.prop(p, val);\
  \      }; \
  \    }; \
  \  }; \
  \}" :: forall a eff. String -> a -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .prop({ ... })
foreign import getProp
  "function getProp(p) { \
  \  return function(ob) { \
  \    return function () { \
  \      return ob.prop(p);\
  \    }; \
  \  }; \
  \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) Foreign

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

foreign import appendAtIndex
  "function appendAtIndex(i) { \
  \  return function(ob1) { \
  \    return function(ob) { \
  \      return function () { \
  \        var children = ob.children();\
  \        if (children.length > 0) {\
  \          if (i <= 0) {\
  \             ob.prepend(ob1);\
  \          } else if (i >= children.length) {\
  \             ob.append(ob1);\
  \          } else {\
  \             ob1.insertBefore(jQuery(children[i]));\
  \          }\
  \          return ob;\
  \        } else {\
  \          return ob.append(ob1); \
  \        }\
  \      }; \
  \    }; \
  \  }; \
  \}" :: forall eff. Number -> JQuery -> JQuery -> Eff (dom :: DOM | eff) JQuery

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

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

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

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

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

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

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

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

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

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

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

foreign import preventDefault
  "function preventDefault(e) { \
  \  return function() { \
  \    e.preventDefault(); \
  \ } \
  \}" :: forall eff. JQueryEvent -> Eff (dom :: DOM | eff) Unit

foreign import stopPropagation
  "function stopPropagation(e) { \
  \  return function() { \
  \    e.stopPropagation(); \
  \ } \
  \}" :: forall eff. JQueryEvent -> Eff (dom :: DOM | eff) Unit

foreign import stopImmediatePropagation
  "function stopImmediatePropagation(e) { \
  \  return function() { \
  \    e.stopImmediatePropagation(); \
  \ } \
  \}" :: forall eff. JQueryEvent -> Eff (dom :: DOM | eff) Unit

module Control.Monad.JQuery where

import Data.Foreign
import Control.Monad.Eff

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

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

-- Type of jQuery event objects
foreign import data JQueryEvent :: *

-- $(document).ready(function() { ... })
foreign import ready
  "function ready(func) { \
  \  return function () { \
  \    jQuery(document).ready(func); \
  \  }; \
  \}" :: forall eff a. Eff eff a -> Eff (dom :: DOM | eff) JQuery

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

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

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

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

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

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

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

-- .prop({ ... })
foreign import setProp
  "function setProp(p) { \
  \  return function(val) { \
  \    return function(ob) { \
  \      return function () { \
  \        return ob.prop(p, val);\
  \      }; \
  \    }; \
  \  }; \
  \}" :: forall a eff. String -> a -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .prop({ ... })
foreign import getProp
  "function getProp(p) { \
  \  return function(ob) { \
  \    return function () { \
  \      return ob.prop(p);\
  \    }; \
  \  }; \
  \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) Foreign

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

foreign import appendAtIndex
  "function appendAtIndex(i) { \
  \  return function(ob1) { \
  \    return function(ob) { \
  \      return function () { \
  \        var children = ob.children();\
  \        if (children.length > 0) {\
  \          if (i <= 0) {\
  \             ob.prepend(ob1);\
  \          } else if (i >= children.length) {\
  \             ob.append(ob1);\
  \          } else {\
  \             ob1.insertBefore(jQuery(children[i]));\
  \          }\
  \          return ob;\
  \        } else {\
  \          return ob.append(ob1); \
  \        }\
  \      }; \
  \    }; \
  \  }; \
  \}" :: forall eff. Number -> JQuery -> JQuery -> Eff (dom :: DOM | eff) JQuery

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

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

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

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

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

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

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

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

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

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

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

foreign import preventDefault
  "function preventDefault(e) { \
  \  return function() { \
  \    e.preventDefault(); \
  \ } \
  \}" :: forall eff. JQueryEvent -> Eff (dom :: DOM | eff) Unit

foreign import stopPropagation
  "function stopPropagation(e) { \
  \  return function() { \
  \    e.stopPropagation(); \
  \ } \
  \}" :: forall eff. JQueryEvent -> Eff (dom :: DOM | eff) Unit

foreign import stopImmediatePropagation
  "function stopImmediatePropagation(e) { \
  \  return function() { \
  \    e.stopImmediatePropagation(); \
  \ } \
  \}" :: forall eff. JQueryEvent -> Eff (dom :: DOM | eff) Unit


Export GraphicsF

Export GraphicsF

module Graphics.Canvas.Free
  ( Graphics()
  , GraphicsF()

  , setLineWidth
  , setFillStyle
  , setStrokeStyle
  , setShadowColor
  , setShadowBlur
  , setShadowOffsetX
  , setShadowOffsetY
  , setLineCap
  , setComposite
  , setAlpha

  , beginPath
  , stroke
  , fill
  , clip
  , lineTo
  , moveTo
  , closePath

  , arc
  , rect

  , scale
  , rotate
  , translate
  , transform

  , setFont
  , fillText
  , strokeText
  , measureText

  , save
  , restore

  , getImageData
  , putImageData

  , runGraphics
  ) where

import Control.Monad.Eff
import Control.Monad.Free
import Data.Coyoneda

import qualified Graphics.Canvas as C

data GraphicsF more
  = SetLineWidth      Number      more
  | SetFillStyle      String      more
  | SetStrokeStyle    String      more
  | SetShadowColor    String      more
  | SetShadowBlur     Number      more
  | SetShadowOffsetX  Number      more
  | SetShadowOffsetY  Number      more
  | SetLineCap        C.LineCap   more
  | SetComposite      C.Composite more
  | SetAlpha          Number      more
  | BeginPath         more
  | Stroke            more
  | Fill              more
  | Clip              more
  | LineTo            Number      Number      more
  | MoveTo            Number      Number      more
  | ClosePath         more
  | Arc               C.Arc       more
  | Rect              C.Rectangle more
  | Scale             Number      Number      more
  | Rotate            Number      more
  | Translate         Number      Number      more
  | Transform         C.Transform more
  | SetFont           String      more
  | FillText          String      Number      Number    more
  | StrokeText        String      Number      Number    more
  | MeasureText       String      (C.TextMetrics -> more)
  | Save              more
  | Restore           more
  | GetImageData      Number      Number      Number    Number   (C.ImageData -> more)
  | PutImageData      C.ImageData Number      Number    more

type Graphics a = FreeC GraphicsF a

setLineWidth :: Number -> Graphics Unit
setLineWidth w = liftFC $ SetLineWidth w unit

setFillStyle :: String -> Graphics Unit
setFillStyle s = liftFC $ SetFillStyle s unit

setStrokeStyle :: String -> Graphics Unit
setStrokeStyle s = liftFC $ SetStrokeStyle s unit

setShadowColor :: String -> Graphics Unit
setShadowColor c = liftFC $ SetShadowColor c unit

setShadowBlur :: Number -> Graphics Unit
setShadowBlur n = liftFC $ SetShadowBlur n unit

setShadowOffsetX :: Number -> Graphics Unit
setShadowOffsetX n = liftFC $ SetShadowOffsetX n unit

setShadowOffsetY :: Number -> Graphics Unit
setShadowOffsetY n = liftFC $ SetShadowOffsetY n unit

setLineCap :: C.LineCap -> Graphics Unit
setLineCap lc = liftFC $ SetLineCap lc unit

setComposite :: C.Composite -> Graphics Unit
setComposite c = liftFC $ SetComposite c unit

setAlpha :: Number -> Graphics Unit
setAlpha a = liftFC $ SetAlpha a unit

beginPath :: Graphics Unit
beginPath = liftFC $ BeginPath unit

stroke :: Graphics Unit
stroke = liftFC $ Stroke unit

fill :: Graphics Unit
fill = liftFC $ Fill unit

clip :: Graphics Unit
clip = liftFC $ Clip unit

lineTo :: Number -> Number -> Graphics Unit
lineTo x y = liftFC $ LineTo x y unit

moveTo :: Number -> Number -> Graphics Unit
moveTo x y = liftFC $ MoveTo x y unit

closePath :: Graphics Unit
closePath = liftFC $ ClosePath unit

arc :: C.Arc -> Graphics Unit
arc a = liftFC $ Arc a unit

rect :: C.Rectangle -> Graphics Unit
rect r = liftFC $ Rect r unit

scale :: Number -> Number -> Graphics Unit
scale sx sy = liftFC $ Scale sx sy unit

rotate :: Number -> Graphics Unit
rotate th = liftFC $ Rotate th unit

translate :: Number -> Number -> Graphics Unit
translate tx ty = liftFC $ Translate tx ty unit

transform :: C.Transform -> Graphics Unit
transform tx = liftFC $ Transform tx unit

setFont :: String -> Graphics Unit
setFont f = liftFC $ SetFont f unit

fillText :: String -> Number -> Number -> Graphics Unit
fillText s x y = liftFC $ FillText s x y unit

strokeText :: String -> Number -> Number -> Graphics Unit
strokeText s x y = liftFC $ StrokeText s x y unit

measureText :: String -> Graphics C.TextMetrics
measureText s = liftFC $ MeasureText s id

save :: Graphics Unit
save = liftFC $ Save unit

restore :: Graphics Unit
restore = liftFC $ Restore unit

getImageData :: Number -> Number -> Number -> Number -> Graphics C.ImageData
getImageData x y w h = liftFC $ GetImageData x y w h id

putImageData :: C.ImageData -> Number -> Number -> Graphics Unit
putImageData d x y = liftFC $ PutImageData d x y unit

runGraphics :: forall a eff. C.Context2D -> Graphics a -> Eff (canvas :: C.Canvas | eff) a
runGraphics ctx = goEffC interp
  where
  interp :: forall eff. Natural GraphicsF (Eff (canvas :: C.Canvas | eff))
  interp (SetLineWidth w a) = const a <$> C.setLineWidth w ctx
  interp (SetFillStyle s a) = const a <$> C.setFillStyle s ctx
  interp (SetStrokeStyle s a) = const a <$> C.setStrokeStyle s ctx
  interp (SetShadowColor c a) = const a <$> C.setShadowColor c ctx
  interp (SetShadowBlur n a) = const a <$> C.setShadowBlur n ctx
  interp (SetShadowOffsetX n a) = const a <$> C.setShadowOffsetX n ctx
  interp (SetShadowOffsetY n a) = const a <$> C.setShadowOffsetY n ctx
  interp (SetLineCap lc a) = const a <$> C.setLineCap lc ctx
  interp (SetComposite c a) = const a <$> C.setGlobalCompositeOperation ctx c
  interp (SetAlpha s a) = const a <$> C.setGlobalAlpha ctx s
  interp (BeginPath a) = const a <$> C.beginPath ctx
  interp (Stroke a) = const a <$> C.stroke ctx
  interp (Fill a) = const a <$> C.fill ctx
  interp (Clip a) = const a <$> C.clip ctx
  interp (LineTo x y a) = const a <$> C.lineTo ctx x y
  interp (MoveTo x y a) = const a <$> C.moveTo ctx x y
  interp (ClosePath a) = const a <$> C.closePath ctx
  interp (Arc arc a) = const a <$> C.arc ctx arc
  interp (Rect r a) = const a <$> C.rect ctx r
  interp (Scale sx sy a) = const a <$> C.scale { scaleX: sx, scaleY: sy } ctx
  interp (Rotate th a) = const a <$> C.rotate th ctx
  interp (Translate tx ty a) = const a <$> C.translate { translateX: tx, translateY: ty } ctx
  interp (Transform tx a) = const a <$> C.transform tx ctx
  interp (SetFont f a) = const a <$> C.setFont f ctx
  interp (FillText s x y a) = const a <$> C.fillText ctx s x y
  interp (StrokeText s x y a) = const a <$> C.strokeText ctx s x y
  interp (MeasureText s k) = k <$> C.measureText ctx s
  interp (Save a) = const a <$> C.save ctx
  interp (Restore a) = const a <$> C.restore ctx
  interp (GetImageData x y w h k) = k <$> C.getImageData ctx x y w h
  interp (PutImageData d x y a) = const a <$> C.putImageData ctx d x y

module Graphics.Canvas.Free
  ( Graphics()

  , setLineWidth
  , setFillStyle
  , setStrokeStyle
  , setShadowColor
  , setShadowBlur
  , setShadowOffsetX
  , setShadowOffsetY
  , setLineCap
  , setComposite
  , setAlpha

  , beginPath
  , stroke
  , fill
  , clip
  , lineTo
  , moveTo
  , closePath

  , arc
  , rect

  , scale
  , rotate
  , translate
  , transform

  , setFont
  , fillText
  , strokeText
  , measureText

  , save
  , restore

  , getImageData
  , putImageData

  , runGraphics
  ) where

import Control.Monad.Eff
import Control.Monad.Free
import Data.Coyoneda

import qualified Graphics.Canvas as C

data GraphicsF more
  = SetLineWidth      Number      more
  | SetFillStyle      String      more
  | SetStrokeStyle    String      more
  | SetShadowColor    String      more
  | SetShadowBlur     Number      more
  | SetShadowOffsetX  Number      more
  | SetShadowOffsetY  Number      more
  | SetLineCap        C.LineCap   more
  | SetComposite      C.Composite more
  | SetAlpha          Number      more
  | BeginPath         more
  | Stroke            more
  | Fill              more
  | Clip              more
  | LineTo            Number      Number      more
  | MoveTo            Number      Number      more
  | ClosePath         more
  | Arc               C.Arc       more
  | Rect              C.Rectangle more
  | Scale             Number      Number      more
  | Rotate            Number      more
  | Translate         Number      Number      more
  | Transform         C.Transform more
  | SetFont           String      more
  | FillText          String      Number      Number    more
  | StrokeText        String      Number      Number    more
  | MeasureText       String      (C.TextMetrics -> more)
  | Save              more
  | Restore           more
  | GetImageData      Number      Number      Number    Number   (C.ImageData -> more)
  | PutImageData      C.ImageData Number      Number    more

type Graphics a = FreeC GraphicsF a

setLineWidth :: Number -> Graphics Unit
setLineWidth w = liftFC $ SetLineWidth w unit

setFillStyle :: String -> Graphics Unit
setFillStyle s = liftFC $ SetFillStyle s unit

setStrokeStyle :: String -> Graphics Unit
setStrokeStyle s = liftFC $ SetStrokeStyle s unit

setShadowColor :: String -> Graphics Unit
setShadowColor c = liftFC $ SetShadowColor c unit

setShadowBlur :: Number -> Graphics Unit
setShadowBlur n = liftFC $ SetShadowBlur n unit

setShadowOffsetX :: Number -> Graphics Unit
setShadowOffsetX n = liftFC $ SetShadowOffsetX n unit

setShadowOffsetY :: Number -> Graphics Unit
setShadowOffsetY n = liftFC $ SetShadowOffsetY n unit

setLineCap :: C.LineCap -> Graphics Unit
setLineCap lc = liftFC $ SetLineCap lc unit

setComposite :: C.Composite -> Graphics Unit
setComposite c = liftFC $ SetComposite c unit

setAlpha :: Number -> Graphics Unit
setAlpha a = liftFC $ SetAlpha a unit

beginPath :: Graphics Unit
beginPath = liftFC $ BeginPath unit

stroke :: Graphics Unit
stroke = liftFC $ Stroke unit

fill :: Graphics Unit
fill = liftFC $ Fill unit

clip :: Graphics Unit
clip = liftFC $ Clip unit

lineTo :: Number -> Number -> Graphics Unit
lineTo x y = liftFC $ LineTo x y unit

moveTo :: Number -> Number -> Graphics Unit
moveTo x y = liftFC $ MoveTo x y unit

closePath :: Graphics Unit
closePath = liftFC $ ClosePath unit

arc :: C.Arc -> Graphics Unit
arc a = liftFC $ Arc a unit

rect :: C.Rectangle -> Graphics Unit
rect r = liftFC $ Rect r unit

scale :: Number -> Number -> Graphics Unit
scale sx sy = liftFC $ Scale sx sy unit

rotate :: Number -> Graphics Unit
rotate th = liftFC $ Rotate th unit

translate :: Number -> Number -> Graphics Unit
translate tx ty = liftFC $ Translate tx ty unit

transform :: C.Transform -> Graphics Unit
transform tx = liftFC $ Transform tx unit

setFont :: String -> Graphics Unit
setFont f = liftFC $ SetFont f unit

fillText :: String -> Number -> Number -> Graphics Unit
fillText s x y = liftFC $ FillText s x y unit

strokeText :: String -> Number -> Number -> Graphics Unit
strokeText s x y = liftFC $ StrokeText s x y unit

measureText :: String -> Graphics C.TextMetrics
measureText s = liftFC $ MeasureText s id

save :: Graphics Unit
save = liftFC $ Save unit

restore :: Graphics Unit
restore = liftFC $ Restore unit

getImageData :: Number -> Number -> Number -> Number -> Graphics C.ImageData
getImageData x y w h = liftFC $ GetImageData x y w h id

putImageData :: C.ImageData -> Number -> Number -> Graphics Unit
putImageData d x y = liftFC $ PutImageData d x y unit

runGraphics :: forall a eff. C.Context2D -> Graphics a -> Eff (canvas :: C.Canvas | eff) a
runGraphics ctx = goEffC interp
  where
  interp :: forall eff. Natural GraphicsF (Eff (canvas :: C.Canvas | eff))
  interp (SetLineWidth w a) = const a <$> C.setLineWidth w ctx
  interp (SetFillStyle s a) = const a <$> C.setFillStyle s ctx
  interp (SetStrokeStyle s a) = const a <$> C.setStrokeStyle s ctx
  interp (SetShadowColor c a) = const a <$> C.setShadowColor c ctx
  interp (SetShadowBlur n a) = const a <$> C.setShadowBlur n ctx
  interp (SetShadowOffsetX n a) = const a <$> C.setShadowOffsetX n ctx
  interp (SetShadowOffsetY n a) = const a <$> C.setShadowOffsetY n ctx
  interp (SetLineCap lc a) = const a <$> C.setLineCap lc ctx
  interp (SetComposite c a) = const a <$> C.setGlobalCompositeOperation ctx c
  interp (SetAlpha s a) = const a <$> C.setGlobalAlpha ctx s
  interp (BeginPath a) = const a <$> C.beginPath ctx
  interp (Stroke a) = const a <$> C.stroke ctx
  interp (Fill a) = const a <$> C.fill ctx
  interp (Clip a) = const a <$> C.clip ctx
  interp (LineTo x y a) = const a <$> C.lineTo ctx x y
  interp (MoveTo x y a) = const a <$> C.moveTo ctx x y
  interp (ClosePath a) = const a <$> C.closePath ctx
  interp (Arc arc a) = const a <$> C.arc ctx arc
  interp (Rect r a) = const a <$> C.rect ctx r
  interp (Scale sx sy a) = const a <$> C.scale { scaleX: sx, scaleY: sy } ctx
  interp (Rotate th a) = const a <$> C.rotate th ctx
  interp (Translate tx ty a) = const a <$> C.translate { translateX: tx, translateY: ty } ctx
  interp (Transform tx a) = const a <$> C.transform tx ctx
  interp (SetFont f a) = const a <$> C.setFont f ctx
  interp (FillText s x y a) = const a <$> C.fillText ctx s x y
  interp (StrokeText s x y a) = const a <$> C.strokeText ctx s x y
  interp (MeasureText s k) = k <$> C.measureText ctx s
  interp (Save a) = const a <$> C.save ctx
  interp (Restore a) = const a <$> C.restore ctx
  interp (GetImageData x y w h k) = k <$> C.getImageData ctx x y w h
  interp (PutImageData d x y a) = const a <$> C.putImageData ctx d x y