Implement "frames" for managing horizontal placement of chr renderers

module Genetics.Browser.Track where

import Prelude

import Control.Monad.Aff (Aff, launchAff)
import Control.Monad.Aff.AVar (AVar, makeVar, takeVar)
import Control.Monad.Eff (Eff, foreachE)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Rec.Class (forever)
import Control.Monad.State (StateT(..))
import Control.Monad.State as State
import Control.Monad.Trans.Class (lift)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array as Array
import Data.Foldable (foldMap, for_, length)
import Data.Lens ((^?))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe, Maybe(..), fromJust)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (ala, alaF, unwrap, wrap)
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(..))
import Debug.Trace (trace)
import Genetics.Browser.DataSource (DataSource)
import Genetics.Browser.Glyph (Glyph, circle)
import Genetics.Browser.GlyphF.Canvas (renderGlyph)
import Genetics.Browser.Types (Bp(..), BpPerPixel(..), Chr, ChrId(..), Point, Range, bpToPixels)
import Genetics.Browser.UI.Native (getScreenSize)
import Genetics.Browser.UI.Native.View as View
import Genetics.Browser.View (View, Pixels)
import Global (readFloat)
import Graphics.Canvas (CanvasElement, Context2D, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth)
import Graphics.Canvas as C
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)

type Track aff eff a = { source :: DataSource aff a
                       , render :: Array a -> Eff eff Unit
                       , getPoint :: Point -> Array a
                       , chrSize :: Chr -> Bp
                       }

{-

Have a way to "prepare" data per-chromosome for rendering.

Then have a way to actually render that prepared data,
given some extra information such as offset, height scaling, etc.

Also need to map clicks backward, but that should be doable.

Maybe render to an offscreen canvas and copyImage.
Not sure that makes sense either
-}

-- given a size on the chromosome,
-- the position of the chromosome,
-- return a function from scale to ncanvas X-coordinate
type XPosInfo = { size :: Bp, scale :: BpPerPixel }

posPixelsX :: XPosInfo
           -> Bp
           -> Pixels
posPixelsX { scale } pos = bpToPixels scale pos

-- given a position relative to the track where 0.0 = bottom, 1.0 = top,
-- information about where the track will be drawn and how,
-- return the canvas Y-coordinate
type YPosInfo = { offset :: Pixels, height :: Pixels }

posPixelsY :: YPosInfo
           -> Number
           -> Pixels
posPixelsY { offset, height } rel = height - (rel * height + offset)

type Renderer eff a =
  { hPos :: a -> XPosInfo -> Pixels
  , vPos :: a -> YPosInfo -> Pixels
  , render :: a -> Context2D -> Eff eff Unit
  , hit :: Maybe (a -> { x :: Pixels, y :: Pixels } -> a)
  }

gwasRenderer :: {min :: Number, max :: Number}
             -> Renderer _ {score :: Number, pos :: Bp}
gwasRenderer {min, max} = { hPos, vPos, render, hit: Nothing }
  where hPos a xInfo = posPixelsX xInfo a.pos
        nScore s = (s - min) / (max - min)
        vPos a yInfo = posPixelsY yInfo (nScore a.score)
        render _ ctx = renderGlyph ctx $ circle { x: 0.0, y: 0.0 } 5.0

-- profunctors/arrows could come in here
-- or polymorphic records, maybe? would have to be (Tuple r1 a) -> (Tuple r2 a) tho
strokeRenderer :: forall a.
                  Renderer _ a
               -> Renderer _ (Tuple String a)
strokeRenderer r = {hPos, vPos, render, hit}
  where hPos (Tuple _ a) = r.hPos a
        vPos (Tuple _ a) = r.vPos a
        hit = Nothing -- TODO fix this
        render (Tuple col a) ctx = C.withContext ctx do
          _ <- C.setStrokeStyle col ctx
          r.render a ctx

fillRenderer :: forall a.
                Renderer _ a
             -> Renderer _ (Tuple String a)
fillRenderer r = {hPos, vPos, render, hit}
  where hPos (Tuple _ a) = r.hPos a
        vPos (Tuple _ a) = r.vPos a
        hit = Nothing -- TODO fix this
        render (Tuple col a) ctx = C.withContext ctx do
          _ <- C.setFillStyle col ctx
          r.render a ctx

runRenderer :: forall a.
               a
            -> Renderer _ a
            -> { xInfo :: XPosInfo, yInfo :: YPosInfo }
            -> Context2D
            -> Eff _ Unit
runRenderer a { hPos, vPos, render, hit } { xInfo, yInfo } ctx = C.withContext ctx do
  let translateX = hPos a xInfo
      translateY = vPos a yInfo
  _ <- C.translate {translateX, translateY} ctx
  render a ctx

runRendererN :: forall a.
                Renderer _ a
             -> { xInfo :: XPosInfo, yInfo :: YPosInfo }
             -> Array a
             -> Context2D
             -> Eff _ Unit
runRendererN r p as ctx =
  for_ as (\a -> runRenderer a r p ctx)

-- TODO the `offset` should probably be in XPosInfo,
-- and be the actual pixel offset for that bit on the canvas...
type Frames a = { offset :: Pixels, frames :: Array (Tuple XPosInfo a) }

frames :: forall a.
          Pixels
       -> Pixels
       -> (a -> Bp)
       -> Array a
       -> Frames a
frames width offset f chrs = {offset, frames: g <$> chrs}
  where n = length chrs
        -- TODO the scale should depend on the current size; that needs more work
        totalSize = alaF Additive foldMap f chrs
        width' = width - offset * n
        g chr = let size = f chr
                in Tuple { size, scale: BpPerPixel (unwrap totalSize / width') } chr

mapFrames :: forall a b.
             (a -> b)
          -> Frames a
          -> Frames b
mapFrames f fs = fs { frames = map f <$> fs.frames }

zipWithFrames :: forall a b.
             Array (a -> b)
          -> Frames a
          -> Frames b
zipWithFrames funs fs = fs { frames = frames }
  where frames = Array.zipWith (\fun frame -> fun <$> frame) funs fs.frames

renderFrames :: forall a.
                YPosInfo
             -> Frames a
             -> Renderer _ a
             -> Context2D
             -> Eff _ Unit
renderFrames yInfo {offset, frames} r ctx = C.withContext ctx (foreachE frames f)
  where f (Tuple {scale, size} a) = do
            void $ C.translate {translateX: offset, translateY: 0.0} ctx
            r.render a ctx
            let len = bpToPixels scale size
            void $ C.translate {translateX: len, translateY: 0.0} ctx

renderFramesN :: forall a.
                 YPosInfo
              -> Frames (Array a)
              -> Renderer _ a
              -> Context2D
              -> Eff _ Unit
renderFramesN yInfo {offset, frames} r ctx = C.withContext ctx (foreachE frames f)
  where f (Tuple xInfo@{scale, size} as) = do
            runRendererN r {xInfo, yInfo} as ctx
            log $ "scale: " <> show (unwrap scale)
            let len = bpToPixels scale size
            void $ C.translate {translateX: len+offset, translateY: 0.0} ctx

{- note:
  check purescript-drawings out.

wait, aren't these basically the same

(         a -> (Translation, Eff _ Unit))
(Identity a -> (Translation, Eff _ Unit))

(       f a ->  g           (Eff _ Unit))
(       f a ->  Identity    (Eff _ Unit))
-}

-- Commands the renderer thread can receive
data RenderCmds a =
    Render (Array { chrId :: ChrId, features :: Array a})
  | SetView View
  | Scroll Pixels

type RenderBackend = { canvas :: CanvasElement
                     , backCanvas :: CanvasElement
                     }
{-
renderer :: forall eff a.
            RenderBackend
         -> Renderer eff a
         -> AVar (RenderCmds a)
         -> StateT View (Aff _) Unit
renderer cvs r cmdVar = forever do
  cmd <- lift $ takeVar cmdVar
  case cmd of
    Render fs -> do
      -- let toRender :: Array (RenderParams -> Eff _ Unit)
      --     toRender = map r fs
      -- Use current (or provided?) View to derive RenderParams for each
      pure unit

    Scroll n -> do
      pure unit

    SetView v -> do
      State.put v
      pure unit
-}

testFetch :: String
          -> Aff _ (Array { score :: Number, pos :: Bp })
testFetch url = do
  json <- _.response <$> Affjax.get url

  let f :: Json -> Maybe {score :: Number, pos :: Bp}
      f j = do
            obj <- j ^? _Object
            pos <- Bp <$> obj ^? ix "min" <<< _Number
            pValue <- readFloat <$> obj ^? ix "pValue" <<< _String
            let score = (-1.0) * (Math.log pValue / Math.log 10.0)
            pure {pos, score}

  case traverse f =<< json ^? _Array of
    Nothing -> throwError $ error "Failed to parse JSON features"
    Just fs -> pure $ fs

testRender :: forall a.
              Renderer _ a
           -> Array a
           -> Aff _ Unit
testRender r as = do
  liftEff $ log "running"
  canvas <- liftEff $ unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- liftEff $ getContext2D canvas

  {w,h} <- liftEff do
    {w} <- getScreenSize
    h <- getCanvasHeight canvas
    _ <- setCanvasWidth (w-2.0) canvas
    pure {w, h}

  let size = Bp 122030190.0
      n = 10
      scale = BpPerPixel (unwrap size / (w / 10.0))
      xInfo = { size, scale }
      height = h
      offset = 0.0
      yInfo = { height, offset }
      colors = Tuple <$> ["yellow", "orange", "red", "purple", "blue"]

      fs :: Frames (Array _)
      fs = frames w 20.0 (const size) (Array.replicate 5 as)

      fs' :: Frames (Tuple String (Array _))
      fs' = zipWithFrames colors fs

      r' :: Renderer _ (Tuple String a)
      r' = strokeRenderer r

  liftEff $ renderFramesN yInfo fs r ctx

main = launchAff $ do
  dat <- testFetch "./gwas.json"
  let min = 0.0
      max = 50.0
  testRender (gwasRenderer {min, max}) dat

{-
trackEvents :: _
trackEvents = viewB
  where cDrag = canvasDrag canvas
        lefts = case _ of
          Left x -> Just x
          Right _ -> Nothing
        -- the alt operator <|> combines the two event streams,
        -- resulting in an event of both button-click scrolls
        -- and canvas-drag scrolls

        dragScroll = filterMap (map (ScrollPixels <<< _.x) <<< lefts) cDrag
        updateViews = btnScroll (Bp 500.0)
                  <|> dragScroll
                  <|> btnZoom (wrap <<< (_ * 0.8) <<< unwrap)
                              (wrap <<< (_ * 1.2) <<< unwrap)
                  <|> scrollZoom canvas
        viewB = FRP.fold foldView updateViews v
-}

-- a `Track` is the more or less abstract representation of the track;
-- it needs to be run to do anything.

-- TODO it also needs to be able to receive messages and send messages

-- runTrack :: forall a r.
--             View
--          -> Track _ _ a
--          -> Aff _ Unit
-- runTrack opts { source, render, getPoint, chrSize } = do
  -- ctx <- liftEff $ getContext2D opts.canvas

  -- {w,h} <- liftEff do
  --   {w} <- getScreenSize
  --   h <- getCanvasHeight opts.canvas
  --   _ <- setCanvasWidth (w-2.0) opts.canvas
  --   pure {w, h}

  -- trackState <- makeVar

  -- -- TODO handle resize
  -- let v = View.fromCanvasWidth chrSize opts

  -- feats <- fetch
  -- pure unit

{-

browser :: Aff _ Unit
browser uri = do
  canvas <- liftEff $ unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- liftEff $ getContext2D canvas

  {w,h} <- liftEff do
    {w} <- getScreenSize
    h <- getCanvasHeight canvas
    _ <- setCanvasWidth (w-2.0) canvas
    pure {w, h}

  backCanvas <- liftEff $ newCanvas {w,h}
  browserState <- makeVar

  let minView = Bp 0.0
      maxView = Bp 15000000.0
      v = View.fromCanvasWidth w { min: minView, max: maxView }
      f :: View -> Fetch _
      f = fileFetch uri

  fs <- f v

  let renderer :: View -> Array _ -> _
      renderer = renderGlyphs (browserTransform h) ctx
      fetch :: View -> Aff _ _
      fetch v = do

        let gs = glyphifyFeatures fs v
            annGs = zip fs gs
        let gs' = filterFeatures v annGs

        putVar browserState { annotatedGlyphs: annGs
                            , view: v }
        liftEff do
          clearCanvas canvas
          renderer v gs'

  let cDrag = canvasDrag canvas
      lefts = case _ of
        Left x -> Just x
        Right _ -> Nothing
      -- the alt operator <|> combines the two event streams,
      -- resulting in an event of both button-click scrolls
      -- and canvas-drag scrolls

      dragScroll = filterMap (map (ScrollPixels <<< _.x) <<< lefts) cDrag
      updateViews = btnScroll (Bp 500.0)
                <|> dragScroll
                <|> btnZoom (wrap <<< (_ * 0.8) <<< unwrap)
                            (wrap <<< (_ * 1.2) <<< unwrap)
                <|> scrollZoom canvas
      viewB = FRP.fold foldView updateViews v

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe cDrag $ case _ of
    Left _      -> pure unit
    Right {x,y} -> scrollCanvas backCanvas canvas {x: -x, y: 0.0}

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe viewB \v' -> do
    _ <- launchAff $ fetch v'

  fetch v
  -}

module Genetics.Browser.Track where

import Prelude

import Control.Monad.Aff (Aff, launchAff)
import Control.Monad.Aff.AVar (AVar, makeVar, takeVar)
import Control.Monad.Eff (Eff, foreachE)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Rec.Class (forever)
import Control.Monad.State (StateT(..))
import Control.Monad.State as State
import Control.Monad.Trans.Class (lift)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array as Array
import Data.Foldable (foldMap, for_, length)
import Data.Lens ((^?))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe, Maybe(..), fromJust)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (ala, alaF, unwrap, wrap)
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(..))
import Debug.Trace (trace)
import Genetics.Browser.DataSource (DataSource)
import Genetics.Browser.Glyph (Glyph, circle)
import Genetics.Browser.GlyphF.Canvas (renderGlyph)
import Genetics.Browser.Types (Bp(..), BpPerPixel(..), Chr, ChrId(..), Point, Range, bpToPixels)
import Genetics.Browser.UI.Native (getScreenSize)
import Genetics.Browser.UI.Native.View as View
import Genetics.Browser.View (View, Pixels)
import Global (readFloat)
import Graphics.Canvas (CanvasElement, Context2D, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth)
import Graphics.Canvas as C
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)

type Track aff eff a = { source :: DataSource aff a
                       , render :: Array a -> Eff eff Unit
                       , getPoint :: Point -> Array a
                       , chrSize :: Chr -> Bp
                       }

{-

Have a way to "prepare" data per-chromosome for rendering.

Then have a way to actually render that prepared data,
given some extra information such as offset, height scaling, etc.

Also need to map clicks backward, but that should be doable.

Maybe render to an offscreen canvas and copyImage.
Not sure that makes sense either
-}

-- given a size on the chromosome,
-- the position of the chromosome,
-- return a function from scale to ncanvas X-coordinate
type XPosInfo = { size :: Bp, scale :: BpPerPixel }

posPixelsX :: XPosInfo
           -> Bp
           -> Pixels
posPixelsX { scale } pos = bpToPixels scale pos

-- given a position relative to the track where 0.0 = bottom, 1.0 = top,
-- information about where the track will be drawn and how,
-- return the canvas Y-coordinate
type YPosInfo = { offset :: Pixels, height :: Pixels }

posPixelsY :: YPosInfo
           -> Number
           -> Pixels
posPixelsY { offset, height } rel = height - (rel * height + offset)

type Renderer eff a =
  { hPos :: a -> XPosInfo -> Pixels
  , vPos :: a -> YPosInfo -> Pixels
  , render :: a -> Context2D -> Eff eff Unit
  , hit :: Maybe (a -> { x :: Pixels, y :: Pixels } -> a)
  }

gwasRenderer :: {min :: Number, max :: Number}
             -> Renderer _ {score :: Number, pos :: Bp}
gwasRenderer {min, max} = { hPos, vPos, render, hit: Nothing }
  where hPos a xInfo = posPixelsX xInfo a.pos
        nScore s = (s - min) / (max - min)
        vPos a yInfo = posPixelsY yInfo (nScore a.score)
        render _ ctx = renderGlyph ctx $ circle { x: 0.0, y: 0.0 } 5.0

-- profunctors/arrows could come in here
-- or polymorphic records, maybe? would have to be (Tuple r1 a) -> (Tuple r2 a) tho
strokeRenderer :: forall a.
                  Renderer _ a
               -> Renderer _ (Tuple String a)
strokeRenderer r = {hPos, vPos, render, hit}
  where hPos (Tuple _ a) = r.hPos a
        vPos (Tuple _ a) = r.vPos a
        hit = Nothing -- TODO fix this
        render (Tuple col a) ctx = C.withContext ctx do
          _ <- C.setStrokeStyle col ctx
          r.render a ctx

fillRenderer :: forall a.
                Renderer _ a
             -> Renderer _ (Tuple String a)
fillRenderer r = {hPos, vPos, render, hit}
  where hPos (Tuple _ a) = r.hPos a
        vPos (Tuple _ a) = r.vPos a
        hit = Nothing -- TODO fix this
        render (Tuple col a) ctx = C.withContext ctx do
          _ <- C.setFillStyle col ctx
          r.render a ctx

runRenderer :: forall a.
               a
            -> Renderer _ a
            -> { xInfo :: XPosInfo, yInfo :: YPosInfo }
            -> Context2D
            -> Eff _ Unit
runRenderer a { hPos, vPos, render, hit } { xInfo, yInfo } ctx = C.withContext ctx do
  let translateX = hPos a xInfo
      translateY = vPos a yInfo
  _ <- C.translate {translateX, translateY} ctx
  render a ctx

runRendererN :: forall a.
                Renderer _ a
             -> { xInfo :: XPosInfo, yInfo :: YPosInfo }
             -> Array a
             -> Context2D
             -> Eff _ Unit
runRendererN r p as ctx =
  for_ as (\a -> runRenderer a r p ctx)

{- note:
  check purescript-drawings out.

wait, aren't these basically the same

(         a -> (Translation, Eff _ Unit))
(Identity a -> (Translation, Eff _ Unit))

(       f a ->  g           (Eff _ Unit))
(       f a ->  Identity    (Eff _ Unit))
-}

-- Commands the renderer thread can receive
data RenderCmds a =
    Render (Array { chrId :: ChrId, features :: Array a})
  | SetView View
  | Scroll Pixels

type RenderBackend = { canvas :: CanvasElement
                     , backCanvas :: CanvasElement
                     }
{-
renderer :: forall eff a.
            RenderBackend
         -> Renderer eff a
         -> AVar (RenderCmds a)
         -> StateT View (Aff _) Unit
renderer cvs r cmdVar = forever do
  cmd <- lift $ takeVar cmdVar
  case cmd of
    Render fs -> do
      -- let toRender :: Array (RenderParams -> Eff _ Unit)
      --     toRender = map r fs
      -- Use current (or provided?) View to derive RenderParams for each
      pure unit

    Scroll n -> do
      pure unit

    SetView v -> do
      State.put v
      pure unit
-}

testFetch :: String
          -> Aff _ (Array { score :: Number, pos :: Bp })
testFetch url = do
  json <- _.response <$> Affjax.get url

  let f :: Json -> Maybe {score :: Number, pos :: Bp}
      f j = do
            obj <- j ^? _Object
            pos <- Bp <$> obj ^? ix "min" <<< _Number
            pValue <- readFloat <$> obj ^? ix "pValue" <<< _String
            let score = (-1.0) * (Math.log pValue / Math.log 10.0)
            pure {pos, score}

  case traverse f =<< json ^? _Array of
    Nothing -> throwError $ error "Failed to parse JSON features"
    Just fs -> pure $ fs

testRender :: forall a.
              Renderer _ a
           -> Array a
           -> Aff _ Unit
testRender r as = do
  liftEff $ log "running"
  canvas <- liftEff $ unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- liftEff $ getContext2D canvas

  {w,h} <- liftEff do
    {w} <- getScreenSize
    h <- getCanvasHeight canvas
    _ <- setCanvasWidth (w-2.0) canvas
    pure {w, h}

  let size = Bp 122030190.0
      n = 10
      scale = BpPerPixel (unwrap size / (w / 10.0))
      xInfo = { size, scale }
      height = h
      offset = 0.0
      yInfo = { height, offset }
      colors = Tuple <$> ["yellow", "orange", "red", "purple", "blue"]

      fs :: Frames (Array _)
      fs = frames w 20.0 (const size) (Array.replicate 5 as)

      fs' :: Frames (Tuple String (Array _))
      fs' = zipWithFrames colors fs

      r' :: Renderer _ (Tuple String a)
      r' = strokeRenderer r

  liftEff $ renderFramesN yInfo fs r ctx

main = launchAff $ do
  dat <- testFetch "./gwas.json"
  let min = 0.0
      max = 50.0
  testRender (gwasRenderer {min, max}) dat

{-
trackEvents :: _
trackEvents = viewB
  where cDrag = canvasDrag canvas
        lefts = case _ of
          Left x -> Just x
          Right _ -> Nothing
        -- the alt operator <|> combines the two event streams,
        -- resulting in an event of both button-click scrolls
        -- and canvas-drag scrolls

        dragScroll = filterMap (map (ScrollPixels <<< _.x) <<< lefts) cDrag
        updateViews = btnScroll (Bp 500.0)
                  <|> dragScroll
                  <|> btnZoom (wrap <<< (_ * 0.8) <<< unwrap)
                              (wrap <<< (_ * 1.2) <<< unwrap)
                  <|> scrollZoom canvas
        viewB = FRP.fold foldView updateViews v
-}

-- a `Track` is the more or less abstract representation of the track;
-- it needs to be run to do anything.

-- TODO it also needs to be able to receive messages and send messages

-- runTrack :: forall a r.
--             View
--          -> Track _ _ a
--          -> Aff _ Unit
-- runTrack opts { source, render, getPoint, chrSize } = do
  -- ctx <- liftEff $ getContext2D opts.canvas

  -- {w,h} <- liftEff do
  --   {w} <- getScreenSize
  --   h <- getCanvasHeight opts.canvas
  --   _ <- setCanvasWidth (w-2.0) opts.canvas
  --   pure {w, h}

  -- trackState <- makeVar

  -- -- TODO handle resize
  -- let v = View.fromCanvasWidth chrSize opts

  -- feats <- fetch
  -- pure unit

{-

browser :: Aff _ Unit
browser uri = do
  canvas <- liftEff $ unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- liftEff $ getContext2D canvas

  {w,h} <- liftEff do
    {w} <- getScreenSize
    h <- getCanvasHeight canvas
    _ <- setCanvasWidth (w-2.0) canvas
    pure {w, h}

  backCanvas <- liftEff $ newCanvas {w,h}
  browserState <- makeVar

  let minView = Bp 0.0
      maxView = Bp 15000000.0
      v = View.fromCanvasWidth w { min: minView, max: maxView }
      f :: View -> Fetch _
      f = fileFetch uri

  fs <- f v

  let renderer :: View -> Array _ -> _
      renderer = renderGlyphs (browserTransform h) ctx
      fetch :: View -> Aff _ _
      fetch v = do

        let gs = glyphifyFeatures fs v
            annGs = zip fs gs
        let gs' = filterFeatures v annGs

        putVar browserState { annotatedGlyphs: annGs
                            , view: v }
        liftEff do
          clearCanvas canvas
          renderer v gs'

  let cDrag = canvasDrag canvas
      lefts = case _ of
        Left x -> Just x
        Right _ -> Nothing
      -- the alt operator <|> combines the two event streams,
      -- resulting in an event of both button-click scrolls
      -- and canvas-drag scrolls

      dragScroll = filterMap (map (ScrollPixels <<< _.x) <<< lefts) cDrag
      updateViews = btnScroll (Bp 500.0)
                <|> dragScroll
                <|> btnZoom (wrap <<< (_ * 0.8) <<< unwrap)
                            (wrap <<< (_ * 1.2) <<< unwrap)
                <|> scrollZoom canvas
      viewB = FRP.fold foldView updateViews v

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe cDrag $ case _ of
    Left _      -> pure unit
    Right {x,y} -> scrollCanvas backCanvas canvas {x: -x, y: 0.0}

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe viewB \v' -> do
    _ <- launchAff $ fetch v'

  fetch v
  -}


withContext is only needed in outer render function

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.Eff.Console
import Control.Monad.ST
import Data.Array
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types
import Data.DOM.Simple.Unsafe.Events (unsafeEventNumberProp)
import Data.DOM.Simple.Window
import Data.Int (even, odd, toNumber)
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Tuple
import DOM
import Graphics.Canvas
import Math (pi)
import Prelude

import Checkers.Constants
import Checkers.Types

createPiece :: Player -> Piece
createPiece player =
  let color = if player == playerOne
              then colorPlayerOne
              else colorPlayerTwo
  in { player: player, color: color, king: false }

createGrid :: Tuple Number Number -> Int -> Int -> Int -> Grid
createGrid (Tuple ox oy) width height layers = { width: width, height: height, squares: squares }
  where
    squares = do
      x <- 0 .. (width - 1)
      y <- 0 .. (height - 1)
      let rx = (toNumber x) * renderSize
          ry = (toNumber y) * renderSize
          isPieceSquare = ((even x) && (odd y)) || ((even y) && (odd x))
          color = if isPieceSquare then colorSquareOne else colorSquareTwo
          piece = if isPieceSquare && (y < layers)
                  then Just (createPiece playerOne)
                  else if isPieceSquare && (y >= height - layers)
                       then Just (createPiece playerTwo)
                       else Nothing
      return { ox: ox, oy: oy, x: x, y: y, rx: rx, ry: ry, color: color, piece: piece }

createState :: Tuple Number Number -> Int -> Int -> Int -> State
createState offset width height layers =
  { grid: (createGrid offset width height layers),
    currentPlayer: playerOne }

findPiece :: Grid -> Coordinate -> Maybe Int
findPiece grid (Tuple x y) = findIndex (\e -> e.x == x && e.y == y) grid.squares

setPiece :: Maybe Piece -> Square -> Square
setPiece piece square = square { piece = piece }

getDiagonalSquares :: Coordinate -> Array Coordinate
getDiagonalSquares (Tuple x y) = do
  i <- -1 : (singleton 1)
  j <- -1 : (singleton 1)
  return (Tuple (x + i) (y + j))

isOnSquare :: Square -> Number -> Number -> Boolean
isOnSquare square x y =
  let vx = square.rx + square.ox
      vy = square.ry + square.oy
  in vx < x && x < vx + renderSize && vy < y && y < vy + renderSize

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid = grid { squares = newSquares }
    where
      fromIndex = fromJust (findPiece grid from)
      toIndex = fromJust (findPiece grid to)
      originalSquare = fromJust (grid.squares !! fromIndex)
      afterMove = fromJust (modifyAt toIndex (setPiece originalSquare.piece) grid.squares)
      newSquares = fromJust (modifyAt fromIndex (setPiece Nothing) afterMove)

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

renderPiece :: forall e.
                 Context2D ->
                 Maybe DOMEvent ->
                 Unit ->
                 Square ->
                 Eff (canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
renderPiece ctx event _ square =
  case square.piece of
    Just piece -> do
      setFillStyle piece.color ctx
      let arcPiece = { x: square.rx + 0.5 * renderSize,
                       y: square.ry + 0.5 * renderSize,
                       r: (renderSize / 2.0) * 0.8,
                       start: 0.0,
                       end: 2.0 * pi }
      fillPath ctx $ arc ctx arcPiece
      case event of
        Nothing -> return unit
        Just e -> do
          ux <- unsafeEventNumberProp "clientX" e
          uy <- unsafeEventNumberProp "clientY" e
          case isOnSquare square (toNumber ux) (toNumber uy) of
            true -> do
              setLineWidth highlightWidth ctx
              strokePath ctx $ arc ctx arcPiece
              return unit
            false -> return unit
          return unit
      return unit
    _ -> return unit

renderBorder :: forall e. Context2D -> Grid -> Eff (canvas :: Canvas | e) Unit
renderBorder ctx grid = do
  let border = { x: 0.5,
                 y: 0.5,
                 w: (toNumber grid.width) * renderSize - 0.5,
                 h: (toNumber grid.height) * renderSize - 0.5 }
  setStrokeStyle "black" ctx
  strokeRect ctx border
  return unit

render :: forall s e.
            Context2D ->
            STRef s State ->
            Maybe DOMEvent ->
            Eff (st :: ST s, canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
render ctx st event = do
  state <- readSTRef st
  withContext ctx $ do
    foldM (renderSquare ctx event) unit state.grid.squares
  withContext ctx $ do
    foldM (renderPiece ctx event) unit state.grid.squares
  withContext ctx $ do
    renderBorder ctx state.grid
  return unit

renderPage :: forall s e.
                STRef s State ->
                Maybe DOMEvent ->
                Eff (st :: ST s, canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
renderPage st event = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      setCanvasDimensions renderDimension canvas
      ctx <- getContext2D canvas
      render ctx st event
      return unit
    _ -> return unit
  return unit

main :: forall s e. Eff (st :: ST s, canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
main = do
  doc <- document globalWindow
  mcanvas <- getElementById "canvas" doc
  case mcanvas of
    Just canvas -> do
      x <- offsetLeft canvas
      y <- offsetTop canvas
      let offset = (Tuple (toNumber x) (toNumber y))
      st <- newSTRef (createState offset defaultWidth defaultHeight layerCount)
      addMouseEventListener MouseMoveEvent (\e -> renderPage st (Just e)) canvas
      renderPage st Nothing
      return unit
    _ -> return unit

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.Eff.Console
import Control.Monad.ST
import Data.Array
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types
import Data.DOM.Simple.Unsafe.Events (unsafeEventNumberProp)
import Data.DOM.Simple.Window
import Data.Int (even, odd, toNumber)
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Tuple
import DOM
import Graphics.Canvas
import Math (pi)
import Prelude

import Checkers.Constants
import Checkers.Types

createPiece :: Player -> Piece
createPiece player =
  let color = if player == playerOne
              then colorPlayerOne
              else colorPlayerTwo
  in { player: player, color: color, king: false }

createGrid :: Tuple Number Number -> Int -> Int -> Int -> Grid
createGrid (Tuple ox oy) width height layers = { width: width, height: height, squares: squares }
  where
    squares = do
      x <- 0 .. (width - 1)
      y <- 0 .. (height - 1)
      let rx = (toNumber x) * renderSize
          ry = (toNumber y) * renderSize
          isPieceSquare = ((even x) && (odd y)) || ((even y) && (odd x))
          color = if isPieceSquare then colorSquareOne else colorSquareTwo
          piece = if isPieceSquare && (y < layers)
                  then Just (createPiece playerOne)
                  else if isPieceSquare && (y >= height - layers)
                       then Just (createPiece playerTwo)
                       else Nothing
      return { ox: ox, oy: oy, x: x, y: y, rx: rx, ry: ry, color: color, piece: piece }

createState :: Tuple Number Number -> Int -> Int -> Int -> State
createState offset width height layers =
  { grid: (createGrid offset width height layers),
    currentPlayer: playerOne }

findPiece :: Grid -> Coordinate -> Maybe Int
findPiece grid (Tuple x y) = findIndex (\e -> e.x == x && e.y == y) grid.squares

setPiece :: Maybe Piece -> Square -> Square
setPiece piece square = square { piece = piece }

getDiagonalSquares :: Coordinate -> Array Coordinate
getDiagonalSquares (Tuple x y) = do
  i <- -1 : (singleton 1)
  j <- -1 : (singleton 1)
  return (Tuple (x + i) (y + j))

isOnSquare :: Square -> Number -> Number -> Boolean
isOnSquare square x y =
  let vx = square.rx + square.ox
      vy = square.ry + square.oy
  in vx < x && x < vx + renderSize && vy < y && y < vy + renderSize

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid = grid { squares = newSquares }
    where
      fromIndex = fromJust (findPiece grid from)
      toIndex = fromJust (findPiece grid to)
      originalSquare = fromJust (grid.squares !! fromIndex)
      afterMove = fromJust (modifyAt toIndex (setPiece originalSquare.piece) grid.squares)
      newSquares = fromJust (modifyAt fromIndex (setPiece Nothing) afterMove)

renderSquare :: forall e.
                  Context2D ->
                  Maybe DOMEvent ->
                  Unit ->
                  Square ->
                  Eff (canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
renderSquare ctx event _ square = do
  withContext ctx $ do
    setFillStyle square.color ctx
    fillRect ctx { x: square.rx, y: square.ry, w: renderSize, h: renderSize }
  return unit

renderPiece :: forall e.
                 Context2D ->
                 Maybe DOMEvent ->
                 Unit ->
                 Square ->
                 Eff (canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
renderPiece ctx event _ square =
  case square.piece of
    Just piece -> do
      withContext ctx $ do
        setFillStyle piece.color ctx
        let arcPiece = { x: square.rx + 0.5 * renderSize,
                         y: square.ry + 0.5 * renderSize,
                         r: (renderSize / 2.0) * 0.8,
                         start: 0.0,
                         end: 2.0 * pi }
        fillPath ctx $ arc ctx arcPiece
        case event of
          Nothing -> return unit
          Just e -> do
            ux <- unsafeEventNumberProp "clientX" e
            uy <- unsafeEventNumberProp "clientY" e
            case isOnSquare square (toNumber ux) (toNumber uy) of
              true -> do
                setLineWidth highlightWidth ctx
                strokePath ctx $ arc ctx arcPiece
                return unit
              false -> return unit
            return unit
        return unit
    _ -> return unit

renderBorder :: forall e. Context2D -> Grid -> Eff (canvas :: Canvas | e) Unit
renderBorder ctx grid = do
  let border = { x: 0.5,
                 y: 0.5,
                 w: (toNumber grid.width) * renderSize - 0.5,
                 h: (toNumber grid.height) * renderSize - 0.5 }
  setStrokeStyle "black" ctx
  strokeRect ctx border
  return unit

render :: forall s e.
            Context2D ->
            STRef s State ->
            Maybe DOMEvent ->
            Eff (st :: ST s, canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
render ctx st event = do
  state <- readSTRef st
  withContext ctx $ do
    foldM (renderSquare ctx event) unit state.grid.squares
  withContext ctx $ do
    foldM (renderPiece ctx event) unit state.grid.squares
  withContext ctx $ do
    renderBorder ctx state.grid
  return unit

renderPage :: forall s e.
                STRef s State ->
                Maybe DOMEvent ->
                Eff (st :: ST s, canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
renderPage st event = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      setCanvasDimensions renderDimension canvas
      ctx <- getContext2D canvas
      render ctx st event
      return unit
    _ -> return unit
  return unit

main :: forall s e. Eff (st :: ST s, canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
main = do
  doc <- document globalWindow
  mcanvas <- getElementById "canvas" doc
  case mcanvas of
    Just canvas -> do
      x <- offsetLeft canvas
      y <- offsetTop canvas
      let offset = (Tuple (toNumber x) (toNumber y))
      st <- newSTRef (createState offset defaultWidth defaultHeight layerCount)
      addMouseEventListener MouseMoveEvent (\e -> renderPage st (Just e)) canvas
      renderPage st Nothing
      return unit
    _ -> return unit


Plain objects option for Java

Plain objects option for Java

module Language.Java
    ( renderer
    ) where

import Prelude

import Data.Char.Unicode (isAscii, isDigit, isLetter)
import Data.Foldable (for_)
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..))
import Data.String.Util (camelCase, capitalize, legalizeCharacters, startWithLetter, stringEscape)
import Doc (Doc, Renderer, blank, combineNames, forEachProperty_, forEachTopLevel_, getForSingleOrMultipleTopLevels, getOptionValue, getTypeNameForUnion, indent, line, lookupClassName, lookupUnionName, noForbidNamer, renderRenderItems, simpleNamer, transformPropertyNames, unionIsNotSimpleNullable, unionNameIntercalated, unlessOption)
import IRGraph (IRClassData(..), IRType(..), IRUnionRep, forUnion_, isUnionMember, nullableFromUnion, removeNullFromUnion, unionHasArray, unionHasClass, unionHasMap)
import Options (Option, booleanOption)

forbiddenNames :: Array String
forbiddenNames =
    [ "Object", "Class", "System", "Long", "Double", "Boolean", "String", "Map", "Exception", "IOException"
    , "JsonProperty", "JsonDeserialize", "JsonDeserializer", "JsonSerialize", "JsonSerializer"
    , "JsonParser", "JsonProcessingException", "DeserializationContext", "SerializerProvider"
    , "Converter"
    , "abstract", "continue", "for", "new", "switch"
    , "assert", "default", "goto", "package", "synchronized"
    , "boolean", "do", "if", "private", "this"
    , "break", "double", "implements", "protected", "throw"
    , "byte", "else", "import", "public", "throws"
    , "case", "enum", "instanceof", "return", "transient"
    , "catch", "extends", "int", "short", "try"
    , "char", "final", "interface", "static", "void"
    , "class", "finally", "long", "strictfp", "volatile"
    , "const", "float", "native", "super", "while"
    , "null", "false", "true"
    ]

pojoOption :: Option Boolean
pojoOption = booleanOption "pojo" "Plain Java objects only" false

renderer :: Renderer
renderer =
    { displayName: "Java"
    , names: [ "java" ]
    , aceMode: "java"
    , extension: "java"
    , doc: javaDoc
    , options: [pojoOption.specification]
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames: forbiddenNames
        , topLevelName: noForbidNamer (javaNameStyle true)
        , unions: Just
            { predicate: unionIsNotSimpleNullable
            , properName: simpleNamer (javaNameStyle true <<< combineNames)
            , nameFromTypes: simpleNamer (unionNameIntercalated (javaNameStyle true) "Or")
            }
        }
    }

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

isStartCharacter :: Char -> Boolean
isStartCharacter c =
    (isAscii c && isLetter c) || c == '_'

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    isStartCharacter c || (isAscii c && isDigit c)

legalize :: String -> String
legalize = legalizeCharacters isPartCharacter

javaNameStyle :: Boolean -> String -> String
javaNameStyle upper =
    legalize >>> camelCase >>> startWithLetter isStartCharacter upper

javaDoc :: Doc Unit
javaDoc = do
    unlessOption pojoOption do
        renderConverter
        blank
    renderRenderItems blank Nothing renderClassDefinition (Just renderUnionDefinition)

renderUnionWithTypeRenderer :: (Boolean -> IRType -> Doc String) -> IRUnionRep -> Doc String
renderUnionWithTypeRenderer typeRenderer ur =
    case nullableFromUnion ur of
    Just x -> typeRenderer true x
    Nothing -> lookupUnionName ur

renderType :: Boolean -> IRType -> Doc String
renderType reference = case _ of
    IRNoInformation -> pure "FIXME_THIS_SHOULD_NOT_HAPPEN"
    IRAnyType -> pure "Object"
    IRNull -> pure "Object"
    IRInteger -> pure $ if reference then "Long" else "long"
    IRDouble -> pure $ if reference then "Double" else "double"
    IRBool -> pure $ if reference then "Boolean" else "boolean"
    IRString -> pure "String"
    IRArray t -> do
        rendered <- renderType false t
        pure $ rendered <> "[]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderType true t
        pure $ "Map<String, " <> rendered <> ">"
    IRUnion ur -> renderUnionWithTypeRenderer renderType ur

renderTypeWithoutGenerics :: Boolean -> IRType -> Doc String
renderTypeWithoutGenerics reference = case _ of
    IRArray t -> do
        rendered <- renderTypeWithoutGenerics false t
        pure $ rendered <> "[]"
    IRMap t -> pure "Map"
    IRUnion ur -> renderUnionWithTypeRenderer renderTypeWithoutGenerics ur
    t -> renderType reference t

renderFileComment :: String -> Doc Unit
renderFileComment fileName = do
    line $ "// " <> fileName <> ".java"

renderPackageAndImports :: Array String -> Doc Unit
renderPackageAndImports imports = do
    pojo <- getOptionValue pojoOption
    let allImports = ["java.util.Map"] <> if pojo then [] else imports
    line "package io.quicktype;"
    blank
    for_ allImports \package -> do
        line $ "import " <> package <> ";"

renderFileHeader :: String -> Array String -> Doc Unit
renderFileHeader fileName imports = do
    renderFileComment fileName
    blank
    renderPackageAndImports imports
    blank

renderConverter :: Doc Unit
renderConverter = do
    renderFileComment "Converter"
    blank
    line """// To use this code, add the following Maven dependency to your project:
//
//     com.fasterxml.jackson.core : jackson-databind : 2.9.0
//
// Import this package:
//
//     import io.quicktype.Converter;
//
// Then you can deserialize a JSON string with
//"""
    forEachTopLevel_ \topLevelName topLevelType -> do
        topLevelTypeRendered <- renderType false topLevelType
        decoderName <- getDecoderName topLevelName
        line $ "//     " <> topLevelTypeRendered <> " data = Converter." <> decoderName <> "(jsonString);"
    blank
    renderPackageAndImports ["java.io.IOException", "com.fasterxml.jackson.databind.*", "com.fasterxml.jackson.core.JsonProcessingException"]
    blank
    line "public class Converter {"
    indent do
        line "// Serialize/deserialize helpers"
        forEachTopLevel_ \topLevelName topLevelType -> do
            blank
            topLevelTypeRendered <- renderType false topLevelType
            decoderName <- getDecoderName topLevelName
            line $ "public static " <> topLevelTypeRendered <> " " <> decoderName <> "(String json) throws IOException {"
            indent do
                getReaderName <- getReaderGetterName topLevelName
                line $ "return " <> getReaderName <> "().readValue(json);"
            line "}"
            blank
            encoderName <- getEncoderName topLevelName
            line $ "public static String " <> encoderName <> "(" <> topLevelTypeRendered <> " obj) throws JsonProcessingException {"
            indent do
                getWriterName <- getWriterGetterName topLevelName
                line $ "return " <> getWriterName <> "().writeValueAsString(obj);"
            line "}"
        forEachTopLevel_ \topLevelName topLevelType -> do
            readerName <- getFieldOrMethodName "reader" topLevelName
            writerName <- getFieldOrMethodName "writer" topLevelName
            instantiateName <- getMethodName "instantiate" "Mapper" topLevelName
            getReaderName <- getReaderGetterName topLevelName
            getWriterName <- getWriterGetterName topLevelName
            blank
            line $ "private static ObjectReader " <> readerName <> ";"
            line $ "private static ObjectWriter " <> writerName <> ";"
            blank
            line $ "private static void " <> instantiateName <> "() {"
            indent do
                renderedForClass <- renderTypeWithoutGenerics false topLevelType
                line "ObjectMapper mapper = new ObjectMapper();"
                line $ readerName <> " = mapper.reader(" <> renderedForClass <> ".class);"
                line $ writerName <> " = mapper.writerFor(" <> renderedForClass <> ".class);"
            line "}"
            blank
            line $ "private static ObjectReader " <> getReaderName <> "() {"
            indent do
                line $ "if (" <> readerName <> " == null) instantiateMapper();"
                line $ "return " <> readerName <> ";"
            line "}"
            blank
            line $ "private static ObjectWriter " <> getWriterName <> "() {"
            indent do
                line $ "if (" <> writerName <> " == null) instantiateMapper();"
                line $ "return " <> writerName <> ";"
            line "}"
    line "}"
    where
        getDecoderName = getFieldOrMethodName "fromJsonString"
        getEncoderName = getFieldOrMethodName "toJsonString"
        getReaderGetterName = getMethodName "get" "ObjectReader"
        getWriterGetterName = getMethodName "get" "ObjectWriter"

        getFieldOrMethodName :: String -> String -> Doc String
        getFieldOrMethodName methodName topLevelName =
            getForSingleOrMultipleTopLevels methodName (topLevelName <> capitalize methodName)

        getMethodName :: String -> String -> String -> Doc String
        getMethodName prefix suffix topLevelName =
            getForSingleOrMultipleTopLevels (prefix <> suffix) (prefix <> capitalize topLevelName <> suffix)

renderClassDefinition :: String -> Map String IRType -> Doc Unit
renderClassDefinition className properties = do
    renderFileHeader className ["com.fasterxml.jackson.annotation.*"]
    let propertyNames = transformPropertyNames (simpleNamer $ javaNameStyle false) (\n -> "other" <>  capitalize n) forbiddenNames properties
    pojo <- getOptionValue pojoOption
    when (M.isEmpty properties && not pojo) do
        line "@JsonAutoDetect(fieldVisibility=JsonAutoDetect.Visibility.NONE)"
    line $ "public class " <> className <> " {"
    indent do
        forEachProp_ properties propertyNames \_ javaName fieldName rendered -> do
            line $ "private " <> rendered <> " " <> fieldName <> ";"
        forEachProp_ properties propertyNames \pname javaName fieldName rendered -> do
            blank
            unless pojo do
                line $ "@JsonProperty(\"" <> stringEscape pname <> "\")"
            line $ "public " <> rendered <> " get" <> javaName <> "() { return " <> fieldName <> "; }"
            line $ "public void set" <> javaName <> "(" <> rendered <> " value) { this." <> fieldName <> " = value; }"
    line "}"
    where
        forEachProp_ :: Map String IRType -> Map String String -> (String -> String -> String -> String -> Doc Unit) -> Doc Unit
        forEachProp_ properties' propertyNames f =
            forEachProperty_ properties' propertyNames \pname ptype fieldName _ -> do
                let javaName = capitalize fieldName
                rendered <- renderType false ptype
                f pname javaName fieldName rendered

renderUnionField :: IRType -> Doc { renderedType :: String, fieldName :: String }
renderUnionField t = do
    renderedType <- renderType true t
    fieldName <- javaNameStyle false <$> (_ <> "_value") <$> getTypeNameForUnion t
    pure { renderedType, fieldName }

tokenCase :: String -> Doc Unit
tokenCase tokenType =
    line $ "case " <> tokenType <> ":"

renderNullCase :: Doc Unit
renderNullCase = do
    tokenCase "VALUE_NULL"
    indent do
        line "break;"

deserializeType :: IRType -> Doc Unit
deserializeType t = do
    { fieldName } <- renderUnionField t
    renderedType <- renderTypeWithoutGenerics true t
    line $ "value." <> fieldName <> " = jsonParser.readValueAs(" <> renderedType <> ".class);"
    line "break;"

renderPrimitiveCase :: Array String -> IRType -> IRUnionRep -> Doc Unit
renderPrimitiveCase tokenTypes t union =
    when (isUnionMember t union) do
        for_ tokenTypes \tokenType ->
            tokenCase tokenType
        indent do
            deserializeType t

renderDoubleCase :: IRUnionRep -> Doc Unit
renderDoubleCase union =
    when (isUnionMember IRDouble union) do
        unless (isUnionMember IRInteger union) do
            tokenCase "VALUE_NUMBER_INT"
        tokenCase "VALUE_NUMBER_FLOAT"
        indent do
            deserializeType IRDouble

renderGenericCase :: (IRUnionRep -> Maybe IRType) -> String -> IRUnionRep -> Doc Unit
renderGenericCase predicate tokenType union =
    case predicate union of
    Nothing -> pure unit
    Just t -> do
        tokenCase tokenType
        indent do
            deserializeType t

renderUnionDefinition :: String -> IRUnionRep -> Doc Unit
renderUnionDefinition unionName unionRep = do
    let { hasNull, nonNullUnion } = removeNullFromUnion unionRep
    renderFileHeader unionName ["java.io.IOException", "com.fasterxml.jackson.core.*", "com.fasterxml.jackson.databind.*", "com.fasterxml.jackson.databind.annotation.*"]
    pojo <- getOptionValue pojoOption
    unless pojo do
        line $ "@JsonDeserialize(using = " <> unionName <> ".Deserializer.class)"
        line $ "@JsonSerialize(using = " <> unionName <> ".Serializer.class)"
    line $ "public class " <> unionName <> " {"
    indent do
        forUnion_ nonNullUnion \t -> do
            { renderedType, fieldName } <- renderUnionField t
            line $ "public " <> renderedType <> " " <> fieldName <> ";"

        unless pojo do
            blank
            line $ "static class Deserializer extends JsonDeserializer<" <> unionName <> "> {"
            indent do
                line "@Override"
                line $ "public " <> unionName <> " deserialize(JsonParser jsonParser, DeserializationContext deserializationContext) throws IOException, JsonProcessingException {"
                indent do
                    line $ unionName <> " value = new " <> unionName <> "();"
                    line "switch (jsonParser.getCurrentToken()) {"
                    when hasNull renderNullCase
                    renderPrimitiveCase ["VALUE_NUMBER_INT"] IRInteger nonNullUnion
                    renderDoubleCase nonNullUnion
                    renderPrimitiveCase ["VALUE_TRUE", "VALUE_FALSE"] IRBool nonNullUnion
                    renderPrimitiveCase ["VALUE_STRING"] IRString nonNullUnion
                    renderGenericCase unionHasArray "START_ARRAY" nonNullUnion
                    renderGenericCase unionHasClass "START_OBJECT" nonNullUnion
                    renderGenericCase unionHasMap "START_OBJECT" nonNullUnion
                    line $ "default: throw new IOException(\"Cannot deserialize " <> unionName <> "\");"
                    line "}"
                    line "return value;"
                line "}"
            line "}"
            blank

            line $ "static class Serializer extends JsonSerializer<" <> unionName <> "> {"
            indent do
                line "@Override"
                line $ "public void serialize(" <> unionName <> " obj, JsonGenerator jsonGenerator, SerializerProvider serializerProvider) throws IOException {"
                indent do
                    forUnion_ nonNullUnion \field -> do
                        { fieldName } <- renderUnionField field
                        line $ "if (obj." <> fieldName <> " != null) {"
                        indent do
                            line $ "jsonGenerator.writeObject(obj." <> fieldName <> ");"
                            line "return;"
                        line "}"
                    if hasNull
                        then
                            line "jsonGenerator.writeNull();"
                        else
                            line $ "throw new IOException(\"" <> unionName <> " must not be null\");"
                line "}"
            line "}"
    line "}"

module Language.Java
    ( renderer
    ) where

import Prelude

import Data.Char.Unicode (isAscii, isDigit, isLetter)
import Data.Foldable (for_)
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..))
import Data.String.Util (camelCase, capitalize, legalizeCharacters, startWithLetter, stringEscape)
import Doc (Doc, Renderer, blank, combineNames, forEachProperty_, forEachTopLevel_, getForSingleOrMultipleTopLevels, getTypeNameForUnion, indent, line, lookupClassName, lookupUnionName, noForbidNamer, renderRenderItems, simpleNamer, transformPropertyNames, unionIsNotSimpleNullable, unionNameIntercalated)
import IRGraph (IRClassData(..), IRType(..), IRUnionRep, forUnion_, isUnionMember, nullableFromUnion, removeNullFromUnion, unionHasArray, unionHasClass, unionHasMap)

forbiddenNames :: Array String
forbiddenNames =
    [ "Object", "Class", "System", "Long", "Double", "Boolean", "String", "Map", "Exception", "IOException"
    , "JsonProperty", "JsonDeserialize", "JsonDeserializer", "JsonSerialize", "JsonSerializer"
    , "JsonParser", "JsonProcessingException", "DeserializationContext", "SerializerProvider"
    , "Converter"
    , "abstract", "continue", "for", "new", "switch"
    , "assert", "default", "goto", "package", "synchronized"
    , "boolean", "do", "if", "private", "this"
    , "break", "double", "implements", "protected", "throw"
    , "byte", "else", "import", "public", "throws"
    , "case", "enum", "instanceof", "return", "transient"
    , "catch", "extends", "int", "short", "try"
    , "char", "final", "interface", "static", "void"
    , "class", "finally", "long", "strictfp", "volatile"
    , "const", "float", "native", "super", "while"
    , "null", "false", "true"
    ]

renderer :: Renderer
renderer =
    { displayName: "Java"
    , names: [ "java" ]
    , aceMode: "java"
    , extension: "java"
    , doc: javaDoc
    , options: []
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames: forbiddenNames
        , topLevelName: noForbidNamer (javaNameStyle true)
        , unions: Just
            { predicate: unionIsNotSimpleNullable
            , properName: simpleNamer (javaNameStyle true <<< combineNames)
            , nameFromTypes: simpleNamer (unionNameIntercalated (javaNameStyle true) "Or")
            }
        }
    }

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

isStartCharacter :: Char -> Boolean
isStartCharacter c =
    (isAscii c && isLetter c) || c == '_'

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    isStartCharacter c || (isAscii c && isDigit c)

legalize :: String -> String
legalize = legalizeCharacters isPartCharacter

javaNameStyle :: Boolean -> String -> String
javaNameStyle upper =
    legalize >>> camelCase >>> startWithLetter isStartCharacter upper

javaDoc :: Doc Unit
javaDoc = do
    renderConverter
    blank
    renderRenderItems blank Nothing renderClassDefinition (Just renderUnionDefinition)

renderUnionWithTypeRenderer :: (Boolean -> IRType -> Doc String) -> IRUnionRep -> Doc String
renderUnionWithTypeRenderer typeRenderer ur =
    case nullableFromUnion ur of
    Just x -> typeRenderer true x
    Nothing -> lookupUnionName ur

renderType :: Boolean -> IRType -> Doc String
renderType reference = case _ of
    IRNoInformation -> pure "FIXME_THIS_SHOULD_NOT_HAPPEN"
    IRAnyType -> pure "Object"
    IRNull -> pure "Object"
    IRInteger -> pure $ if reference then "Long" else "long"
    IRDouble -> pure $ if reference then "Double" else "double"
    IRBool -> pure $ if reference then "Boolean" else "boolean"
    IRString -> pure "String"
    IRArray t -> do
        rendered <- renderType false t
        pure $ rendered <> "[]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderType true t
        pure $ "Map<String, " <> rendered <> ">"
    IRUnion ur -> renderUnionWithTypeRenderer renderType ur

renderTypeWithoutGenerics :: Boolean -> IRType -> Doc String
renderTypeWithoutGenerics reference = case _ of
    IRArray t -> do
        rendered <- renderTypeWithoutGenerics false t
        pure $ rendered <> "[]"
    IRMap t -> pure "Map"
    IRUnion ur -> renderUnionWithTypeRenderer renderTypeWithoutGenerics ur
    t -> renderType reference t

renderFileComment :: String -> Doc Unit
renderFileComment fileName = do
    line $ "// " <> fileName <> ".java"

renderPackageAndImports :: Array String -> Doc Unit
renderPackageAndImports imports = do
    line "package io.quicktype;"
    blank
    for_ imports \package -> do
        line $ "import " <> package <> ";"

renderFileHeader :: String -> Array String -> Doc Unit
renderFileHeader fileName imports = do
    renderFileComment fileName
    blank
    renderPackageAndImports imports
    blank

renderConverter :: Doc Unit
renderConverter = do
    renderFileComment "Converter"
    blank
    line """// To use this code, add the following Maven dependency to your project:
//
//     com.fasterxml.jackson.core : jackson-databind : 2.9.0
//
// Import this package:
//
//     import io.quicktype.Converter;
//
// Then you can deserialize a JSON string with
//"""
    forEachTopLevel_ \topLevelName topLevelType -> do
        topLevelTypeRendered <- renderType false topLevelType
        decoderName <- getDecoderName topLevelName
        line $ "//     " <> topLevelTypeRendered <> " data = Converter." <> decoderName <> "(jsonString);"
    blank
    renderPackageAndImports ["java.util.Map", "java.io.IOException", "com.fasterxml.jackson.databind.*", "com.fasterxml.jackson.core.JsonProcessingException"]
    blank
    line "public class Converter {"
    indent do
        line "// Serialize/deserialize helpers"
        forEachTopLevel_ \topLevelName topLevelType -> do
            blank
            topLevelTypeRendered <- renderType false topLevelType
            decoderName <- getDecoderName topLevelName
            line $ "public static " <> topLevelTypeRendered <> " " <> decoderName <> "(String json) throws IOException {"
            indent do
                getReaderName <- getReaderGetterName topLevelName
                line $ "return " <> getReaderName <> "().readValue(json);"
            line "}"
            blank
            encoderName <- getEncoderName topLevelName
            line $ "public static String " <> encoderName <> "(" <> topLevelTypeRendered <> " obj) throws JsonProcessingException {"
            indent do
                getWriterName <- getWriterGetterName topLevelName
                line $ "return " <> getWriterName <> "().writeValueAsString(obj);"
            line "}"
        forEachTopLevel_ \topLevelName topLevelType -> do
            readerName <- getFieldOrMethodName "reader" topLevelName
            writerName <- getFieldOrMethodName "writer" topLevelName
            instantiateName <- getMethodName "instantiate" "Mapper" topLevelName
            getReaderName <- getReaderGetterName topLevelName
            getWriterName <- getWriterGetterName topLevelName
            blank
            line $ "private static ObjectReader " <> readerName <> ";"
            line $ "private static ObjectWriter " <> writerName <> ";"
            blank
            line $ "private static void " <> instantiateName <> "() {"
            indent do
                renderedForClass <- renderTypeWithoutGenerics false topLevelType
                line "ObjectMapper mapper = new ObjectMapper();"
                line $ readerName <> " = mapper.reader(" <> renderedForClass <> ".class);"
                line $ writerName <> " = mapper.writerFor(" <> renderedForClass <> ".class);"
            line "}"
            blank
            line $ "private static ObjectReader " <> getReaderName <> "() {"
            indent do
                line $ "if (" <> readerName <> " == null) instantiateMapper();"
                line $ "return " <> readerName <> ";"
            line "}"
            blank
            line $ "private static ObjectWriter " <> getWriterName <> "() {"
            indent do
                line $ "if (" <> writerName <> " == null) instantiateMapper();"
                line $ "return " <> writerName <> ";"
            line "}"
    line "}"
    where
        getDecoderName = getFieldOrMethodName "fromJsonString"
        getEncoderName = getFieldOrMethodName "toJsonString"
        getReaderGetterName = getMethodName "get" "ObjectReader"
        getWriterGetterName = getMethodName "get" "ObjectWriter"

        getFieldOrMethodName :: String -> String -> Doc String
        getFieldOrMethodName methodName topLevelName =
            getForSingleOrMultipleTopLevels methodName (topLevelName <> capitalize methodName)

        getMethodName :: String -> String -> String -> Doc String
        getMethodName prefix suffix topLevelName =
            getForSingleOrMultipleTopLevels (prefix <> suffix) (prefix <> capitalize topLevelName <> suffix)

renderClassDefinition :: String -> Map String IRType -> Doc Unit
renderClassDefinition className properties = do
    renderFileHeader className ["java.util.Map", "com.fasterxml.jackson.annotation.*"]
    let propertyNames = transformPropertyNames (simpleNamer $ javaNameStyle false) (\n -> "other" <>  capitalize n) forbiddenNames properties
    when (M.isEmpty properties) do
        line "@JsonAutoDetect(fieldVisibility=JsonAutoDetect.Visibility.NONE)"
    line $ "public class " <> className <> " {"
    indent do
        forEachProp_ properties propertyNames \_ javaName fieldName rendered -> do
            line $ "private " <> rendered <> " " <> fieldName <> ";"
        forEachProp_ properties propertyNames \pname javaName fieldName rendered -> do
            blank
            line $ "@JsonProperty(\"" <> stringEscape pname <> "\")"
            line $ "public " <> rendered <> " get" <> javaName <> "() { return " <> fieldName <> "; }"
            line $ "public void set" <> javaName <> "(" <> rendered <> " value) { this." <> fieldName <> " = value; }"
    line "}"
    where
        forEachProp_ :: Map String IRType -> Map String String -> (String -> String -> String -> String -> Doc Unit) -> Doc Unit
        forEachProp_ properties' propertyNames f =
            forEachProperty_ properties' propertyNames \pname ptype fieldName _ -> do
                let javaName = capitalize fieldName
                rendered <- renderType false ptype
                f pname javaName fieldName rendered

renderUnionField :: IRType -> Doc { renderedType :: String, fieldName :: String }
renderUnionField t = do
    renderedType <- renderType true t
    fieldName <- javaNameStyle false <$> (_ <> "_value") <$> getTypeNameForUnion t
    pure { renderedType, fieldName }

tokenCase :: String -> Doc Unit
tokenCase tokenType =
    line $ "case " <> tokenType <> ":"

renderNullCase :: Doc Unit
renderNullCase = do
    tokenCase "VALUE_NULL"
    indent do
        line "break;"

deserializeType :: IRType -> Doc Unit
deserializeType t = do
    { fieldName } <- renderUnionField t
    renderedType <- renderTypeWithoutGenerics true t
    line $ "value." <> fieldName <> " = jsonParser.readValueAs(" <> renderedType <> ".class);"
    line "break;"

renderPrimitiveCase :: Array String -> IRType -> IRUnionRep -> Doc Unit
renderPrimitiveCase tokenTypes t union =
    when (isUnionMember t union) do
        for_ tokenTypes \tokenType ->
            tokenCase tokenType
        indent do
            deserializeType t

renderDoubleCase :: IRUnionRep -> Doc Unit
renderDoubleCase union =
    when (isUnionMember IRDouble union) do
        unless (isUnionMember IRInteger union) do
            tokenCase "VALUE_NUMBER_INT"
        tokenCase "VALUE_NUMBER_FLOAT"
        indent do
            deserializeType IRDouble

renderGenericCase :: (IRUnionRep -> Maybe IRType) -> String -> IRUnionRep -> Doc Unit
renderGenericCase predicate tokenType union =
    case predicate union of
    Nothing -> pure unit
    Just t -> do
        tokenCase tokenType
        indent do
            deserializeType t

renderUnionDefinition :: String -> IRUnionRep -> Doc Unit
renderUnionDefinition unionName unionRep = do
    let { hasNull, nonNullUnion } = removeNullFromUnion unionRep
    renderFileHeader unionName ["java.io.IOException", "java.util.Map", "com.fasterxml.jackson.core.*", "com.fasterxml.jackson.databind.*", "com.fasterxml.jackson.databind.annotation.*"]
    line $ "@JsonDeserialize(using = " <> unionName <> ".Deserializer.class)"
    line $ "@JsonSerialize(using = " <> unionName <> ".Serializer.class)"
    line $ "public class " <> unionName <> " {"
    indent do
        forUnion_ nonNullUnion \t -> do
            { renderedType, fieldName } <- renderUnionField t
            line $ "public " <> renderedType <> " " <> fieldName <> ";"
        blank
        line $ "static class Deserializer extends JsonDeserializer<" <> unionName <> "> {"
        indent do
            line "@Override"
            line $ "public " <> unionName <> " deserialize(JsonParser jsonParser, DeserializationContext deserializationContext) throws IOException, JsonProcessingException {"
            indent do
                line $ unionName <> " value = new " <> unionName <> "();"
                line "switch (jsonParser.getCurrentToken()) {"
                when hasNull renderNullCase
                renderPrimitiveCase ["VALUE_NUMBER_INT"] IRInteger nonNullUnion
                renderDoubleCase nonNullUnion
                renderPrimitiveCase ["VALUE_TRUE", "VALUE_FALSE"] IRBool nonNullUnion
                renderPrimitiveCase ["VALUE_STRING"] IRString nonNullUnion
                renderGenericCase unionHasArray "START_ARRAY" nonNullUnion
                renderGenericCase unionHasClass "START_OBJECT" nonNullUnion
                renderGenericCase unionHasMap "START_OBJECT" nonNullUnion
                line $ "default: throw new IOException(\"Cannot deserialize " <> unionName <> "\");"
                line "}"
                line "return value;"
            line "}"
        line "}"
        blank

        line $ "static class Serializer extends JsonSerializer<" <> unionName <> "> {"
        indent do
            line "@Override"
            line $ "public void serialize(" <> unionName <> " obj, JsonGenerator jsonGenerator, SerializerProvider serializerProvider) throws IOException {"
            indent do
                forUnion_ nonNullUnion \field -> do
                    { fieldName } <- renderUnionField field
                    line $ "if (obj." <> fieldName <> " != null) {"
                    indent do
                        line $ "jsonGenerator.writeObject(obj." <> fieldName <> ");"
                        line "return;"
                    line "}"
                if hasNull
                    then
                        line "jsonGenerator.writeNull();"
                    else
                        line $ "throw new IOException(\"" <> unionName <> " must not be null\");"
            line "}"
        line "}"
    line "}"


Added drawElements method to free monad.

-- Free Monad for WebGL
module Graphics.WebGL.Free (
	AttributeLocation(..),
	WebGL(),
	WebGLF(),
	debugWebGL,
	runWebGL,
	attachShader,
	bindBuffer,
	bufferData,
	clear,
	createBuffer,
	clearColor,
	createProgram,
	compileShader,
	createShader,
	depthFunc,
	drawArrays,
	drawElements,
	enable,
	enableVertexAttribArray,
	getAttribLocation,
	getCanvas,
	getDrawingBufferHeight,
	getDrawingBufferWidth,
	getProgramInfoLog,
	getProgramLinkStatus,
	getShaderCompileStatus,
	getShaderInfoLog,
	getUniformLocation,
	linkProgram,
	shaderSource,
	uniformMatrix4fv,
	useProgram,
	vertexAttribPointer,
	viewport
	) where

import Prelude
import Control.Monad.Eff
import Control.Monad.Eff.Console
import Control.Monad.Free
import Data.ArrayBuffer.Types (Float32Array())
import Data.Maybe
import Graphics.Canvas (Canvas(), CanvasElement())
import qualified Graphics.WebGL.Raw as R
import qualified Graphics.WebGL.Raw.Extra as R
import qualified Graphics.WebGL.Raw.Enums as GL
import Graphics.WebGL.Raw.Types

newtype AttributeLocation = AttributeLocation GLuint

data WebGLF a
	= AttachShader WebGLProgram WebGLShader a
	| BindBuffer GLenum WebGLBuffer a
	| BufferData GLenum BufferDataSource GLenum a
	| Clear GLbitfield a
	| ClearColor GLclampf GLclampf GLclampf GLclampf a
	| CompileShader WebGLShader a
	| CreateBuffer (Maybe WebGLBuffer -> a)
	| CreateProgram (Maybe WebGLProgram -> a)
	| CreateShader GLenum (Maybe WebGLShader -> a)
	| DepthFunc GLenum a
	| DrawArrays GLenum GLint GLsizei a
	| DrawElements GLenum GLsizei GLenum GLintptr a
	| Enable GLenum a
	| EnableVertexAttribArray AttributeLocation a
	| GetAttribLocation WebGLProgram DOMString (Maybe AttributeLocation -> a)
	| GetCanvas (CanvasElement -> a)
	| GetDrawingBufferHeight (Int -> a)
	| GetDrawingBufferWidth (Int -> a)
	| GetProgramInfoLog WebGLProgram (Maybe DOMString -> a)
	| GetProgramLinkStatus WebGLProgram (Boolean -> a)
	| GetShaderCompileStatus WebGLShader (Boolean -> a)
	| GetShaderInfoLog WebGLShader (Maybe DOMString -> a)
	| GetUniformLocation WebGLProgram DOMString (Maybe WebGLUniformLocation -> a)
	| LinkProgram WebGLProgram a
	| ShaderSource WebGLShader DOMString a
	| UniformMatrix4fv WebGLUniformLocation GLboolean Float32Array a
	| UseProgram WebGLProgram a
	| VertexAttribPointer AttributeLocation GLint GLenum GLboolean GLsizei GLintptr a
	| Viewport GLint GLint GLsizei GLsizei a

instance functorWebGLF :: Functor WebGLF where
	map f (AttachShader p s x) = AttachShader p s (f x)
	map f (BindBuffer t b x) = BindBuffer t b (f x)
	map f (BufferData t s u x) = BufferData t s u (f x)
	map f (Clear mask x) = Clear mask (f x)
	map f (ClearColor r g b a x) = ClearColor r g b a (f x)
	map f (CompileShader s x) = CompileShader s (f x)
	map f (CreateBuffer k) = CreateBuffer (f <<< k)
	map f (CreateProgram k) = CreateProgram (f <<< k)
	map f (CreateShader t k) = CreateShader t (f <<< k)
	map f (DepthFunc func x) = DepthFunc func (f x)
	map f (DrawArrays mode first count x) = DrawArrays mode first count (f x)
	map f (DrawElements mode count t offset x) = DrawElements mode count t offset (f x)
	map f (Enable cap x) = Enable cap (f x)
	map f (EnableVertexAttribArray i x) = EnableVertexAttribArray i (f x)
	map f (GetAttribLocation p s k) = GetAttribLocation p s (f <<< k)
	map f (GetCanvas k) = GetCanvas (f <<< k)
	map f (GetDrawingBufferHeight k) = GetDrawingBufferHeight (f <<< k)
	map f (GetDrawingBufferWidth k) = GetDrawingBufferWidth (f <<< k)
	map f (GetProgramInfoLog s k) = GetProgramInfoLog s (f <<< k)
	map f (GetProgramLinkStatus p k) = GetProgramLinkStatus p (f <<< k)
	map f (GetShaderCompileStatus s k) = GetShaderCompileStatus s (f <<< k)
	map f (GetShaderInfoLog s k) = GetShaderInfoLog s (f <<< k)
	map f (GetUniformLocation p n k) = GetUniformLocation p n (f <<< k)
	map f (LinkProgram p x) = LinkProgram p (f x)
	map f (ShaderSource sh src x) = ShaderSource sh src (f x)
	map f (UniformMatrix4fv l t v x) = UniformMatrix4fv l t v (f x)
	map f (UseProgram p x) = UseProgram p (f x)
	map f (VertexAttribPointer l s t n str o x) = VertexAttribPointer l s t n str o (f x)
	map f (Viewport x y w h a) = Viewport x y w h (f a)

type WebGL = Free WebGLF

attachShader :: WebGLProgram -> WebGLShader -> WebGL Unit
attachShader p s = liftF $ AttachShader p s unit

bindBuffer :: GLenum -> WebGLBuffer -> WebGL Unit
bindBuffer t b = liftF $ BindBuffer t b unit

bufferData :: GLenum -> BufferDataSource -> GLenum -> WebGL Unit
bufferData t s u = liftF $ BufferData t s u unit

clear :: GLbitfield -> WebGL Unit
clear mask = liftF $ Clear mask unit

clearColor :: GLclampf -> GLclampf -> GLclampf -> GLclampf -> WebGL Unit
clearColor r g b a = liftF $ ClearColor r g b a unit

compileShader :: WebGLShader -> WebGL Unit
compileShader s = liftF $ CompileShader s unit

createBuffer :: WebGL (Maybe WebGLBuffer)
createBuffer = liftF $ CreateBuffer id

createProgram :: WebGL (Maybe WebGLProgram)
createProgram = liftF $ CreateProgram id

createShader :: GLenum -> WebGL (Maybe WebGLShader)
createShader t = liftF $ CreateShader t id

depthFunc :: GLenum -> WebGL Unit
depthFunc func = liftF $ DepthFunc func unit

drawArrays :: GLenum -> GLint -> GLsizei -> WebGL Unit
drawArrays mode first count = liftF $ DrawArrays mode first count unit

drawElements :: GLenum -> GLsizei -> GLenum -> GLintptr -> WebGL Unit
drawElements mode count t offset = liftF $ DrawElements mode count t offset unit

enable :: GLenum -> WebGL Unit
enable cap = liftF $ Enable cap unit

enableVertexAttribArray :: AttributeLocation -> WebGL Unit
enableVertexAttribArray location = liftF $ EnableVertexAttribArray location unit

getAttribLocation :: WebGLProgram -> DOMString -> WebGL (Maybe AttributeLocation)
getAttribLocation program name = liftF $ GetAttribLocation program name id

getCanvas :: WebGL CanvasElement
getCanvas = liftF $ GetCanvas id

getDrawingBufferHeight :: WebGL Int
getDrawingBufferHeight = liftF $ GetDrawingBufferHeight id

getDrawingBufferWidth :: WebGL Int
getDrawingBufferWidth = liftF $ GetDrawingBufferWidth id

getProgramInfoLog :: WebGLProgram -> WebGL (Maybe DOMString)
getProgramInfoLog p = liftF $ GetProgramInfoLog p id

getProgramLinkStatus :: WebGLProgram -> WebGL Boolean
getProgramLinkStatus p = liftF $ GetProgramLinkStatus p id

getShaderCompileStatus :: WebGLShader -> WebGL Boolean
getShaderCompileStatus s = liftF $ GetShaderCompileStatus s id

getShaderInfoLog :: WebGLShader -> WebGL (Maybe DOMString)
getShaderInfoLog s = liftF $ GetShaderInfoLog s id

getUniformLocation :: WebGLProgram -> DOMString -> WebGL (Maybe WebGLUniformLocation)
getUniformLocation program name = liftF $ GetUniformLocation program name id

linkProgram :: WebGLProgram -> WebGL Unit
linkProgram p = liftF $ LinkProgram p unit

shaderSource :: WebGLShader -> DOMString -> WebGL Unit
shaderSource sh src = liftF $ ShaderSource sh src unit

uniformMatrix4fv :: WebGLUniformLocation -> GLboolean -> Float32Array -> WebGL Unit
uniformMatrix4fv location transpose value = liftF $ UniformMatrix4fv location transpose value unit

useProgram :: WebGLProgram -> WebGL Unit
useProgram p = liftF $ UseProgram p unit

vertexAttribPointer :: AttributeLocation -> GLint -> GLenum -> GLboolean -> GLsizei -> GLintptr -> WebGL Unit
vertexAttribPointer l s t n str o = liftF $ VertexAttribPointer l s t n str o unit

viewport :: GLint -> GLint -> GLsizei -> GLsizei -> WebGL Unit
viewport x y w h = liftF $ Viewport x y w h unit

interpretWebGL :: forall a eff. WebGLContext -> WebGLF (WebGL a) -> Eff (canvas :: Canvas | eff) (WebGL a)
interpretWebGL gl (AttachShader p s rest) = do
	R.attachShader gl p s
	return rest
interpretWebGL gl (BindBuffer t buffer rest) = do
	R.bindBuffer gl t buffer
	return rest
interpretWebGL gl (BufferData t source usage rest) = do
	R.bufferData gl t source usage
	return rest
interpretWebGL gl (Clear mask rest) = do
	R.clear gl mask
	return rest
interpretWebGL gl (ClearColor r g b a rest) = do
	R.clearColor gl r g b a
	return rest
interpretWebGL gl (CompileShader sh rest) = do
	R.compileShader gl sh
	return rest
interpretWebGL gl (CreateBuffer k) = do
	buffer <- R.createBuffer gl
	return $ k buffer
interpretWebGL gl (CreateProgram k) = do
	program <- R.createProgram gl
	return $ k program
interpretWebGL gl (CreateShader t k) = do
	shader <- R.createShader gl t
	return $ k shader
interpretWebGL gl (DepthFunc func rest) = do
	R.depthFunc gl func
	return rest
interpretWebGL gl (DrawArrays mode first count rest) = do
	R.drawArrays gl mode first count
	return rest
interpretWebGL gl (DrawElements mode count t offset rest) = do
	R.drawElements gl mode count t offset
	return rest
interpretWebGL gl (Enable cap rest) = do
	R.enable gl cap
	return rest
interpretWebGL gl (EnableVertexAttribArray (AttributeLocation location) rest) = do
	R.enableVertexAttribArray gl location
	return rest
interpretWebGL gl (GetAttribLocation program name k) = do
	location <- R.getAttribLocation gl program name
	if location == -1
		then return $ k Nothing
		else return $ k $ Just (AttributeLocation location)
interpretWebGL gl (GetCanvas k) = do
	el <- R.getCanvas gl
	return $ k el
interpretWebGL gl (GetDrawingBufferHeight k) = do
	h <- R.getDrawingBufferHeight gl
	return $ k h
interpretWebGL gl (GetDrawingBufferWidth k) = do
	w <- R.getDrawingBufferWidth gl
	return $ k w
interpretWebGL gl (GetProgramInfoLog p k) = do
	maybeLog <- R.getProgramInfoLog gl p
	return $ k maybeLog
interpretWebGL gl (GetProgramLinkStatus p k) = do
	Just b <- R.getProgramParameter gl p GL.linkStatus
	return $ k b
interpretWebGL gl (GetShaderCompileStatus s k) = do
	Just b <- R.getShaderParameter gl s GL.compileStatus
	return $ k b
interpretWebGL gl (GetShaderInfoLog s k) = do
	maybeLog <- R.getShaderInfoLog gl s
	return $ k maybeLog
interpretWebGL gl (GetUniformLocation program name k) = do
	location <- R.getUniformLocation gl program name
	return $ k location
interpretWebGL gl (LinkProgram p rest) = do
	R.linkProgram gl p
	return rest
interpretWebGL gl (ShaderSource sh src rest) = do
	R.shaderSource gl sh src
	return rest
interpretWebGL gl (UniformMatrix4fv location transpose value rest) = do
	R.uniformMatrix4fv_ gl location transpose value
	return rest
interpretWebGL gl (UseProgram p rest) = do
	R.useProgram gl p
	return rest
interpretWebGL gl (VertexAttribPointer (AttributeLocation l) s t n str o rest) = do
	R.vertexAttribPointer gl l s t n o str
	return rest
interpretWebGL gl (Viewport x y w h rest) = do
	R.viewport gl x y w h
	return rest

runWebGL :: forall a eff. WebGLContext -> WebGL a -> Eff (canvas :: Canvas | eff) a
runWebGL = runFreeM <<< interpretWebGL

debugWebGL :: forall a eff. WebGLContext -> WebGL a -> Eff (canvas :: Canvas, console :: CONSOLE | eff) a
debugWebGL gl = runFreeM interpretDebug
	where
	interpretDebug :: forall a. WebGLF (WebGL a) -> Eff (canvas :: Canvas, console :: CONSOLE | eff) (WebGL a)
	interpretDebug comp = do
		rest <- interpretWebGL gl comp
		err <- R.getError gl
		if err == GL.noError
			then return rest
			else do
				error $ "WebGL Error: " ++ show err
				return rest

-- Free Monad for WebGL
module Graphics.WebGL.Free (
	AttributeLocation(..),
	WebGL(),
	WebGLF(),
	debugWebGL,
	runWebGL,
	attachShader,
	bindBuffer,
	bufferData,
	clear,
	createBuffer,
	clearColor,
	createProgram,
	compileShader,
	createShader,
	depthFunc,
	drawArrays,
	enable,
	enableVertexAttribArray,
	getAttribLocation,
	getCanvas,
	getDrawingBufferHeight,
	getDrawingBufferWidth,
	getProgramInfoLog,
	getProgramLinkStatus,
	getShaderCompileStatus,
	getShaderInfoLog,
	getUniformLocation,
	linkProgram,
	shaderSource,
	uniformMatrix4fv,
	useProgram,
	vertexAttribPointer,
	viewport
	) where

import Prelude
import Control.Monad.Eff
import Control.Monad.Eff.Console
import Control.Monad.Free
import Data.ArrayBuffer.Types (Float32Array())
import Data.Maybe
import Graphics.Canvas (Canvas(), CanvasElement())
import qualified Graphics.WebGL.Raw as R
import qualified Graphics.WebGL.Raw.Extra as R
import qualified Graphics.WebGL.Raw.Enums as GL
import Graphics.WebGL.Raw.Types

newtype AttributeLocation = AttributeLocation GLuint

data WebGLF a
	= AttachShader WebGLProgram WebGLShader a
	| BindBuffer GLenum WebGLBuffer a
	| BufferData GLenum BufferDataSource GLenum a
	| Clear GLbitfield a
	| ClearColor GLclampf GLclampf GLclampf GLclampf a
	| CompileShader WebGLShader a
	| CreateBuffer (Maybe WebGLBuffer -> a)
	| CreateProgram (Maybe WebGLProgram -> a)
	| CreateShader GLenum (Maybe WebGLShader -> a)
	| DepthFunc GLenum a
	| DrawArrays GLenum GLint GLsizei a
	| Enable GLenum a
	| EnableVertexAttribArray AttributeLocation a
	| GetAttribLocation WebGLProgram DOMString (Maybe AttributeLocation -> a)
	| GetCanvas (CanvasElement -> a)
	| GetDrawingBufferHeight (Int -> a)
	| GetDrawingBufferWidth (Int -> a)
	| GetProgramInfoLog WebGLProgram (Maybe DOMString -> a)
	| GetProgramLinkStatus WebGLProgram (Boolean -> a)
	| GetShaderCompileStatus WebGLShader (Boolean -> a)
	| GetShaderInfoLog WebGLShader (Maybe DOMString -> a)
	| GetUniformLocation WebGLProgram DOMString (Maybe WebGLUniformLocation -> a)
	| LinkProgram WebGLProgram a
	| ShaderSource WebGLShader DOMString a
	| UniformMatrix4fv WebGLUniformLocation GLboolean Float32Array a
	| UseProgram WebGLProgram a
	| VertexAttribPointer AttributeLocation GLint GLenum GLboolean GLsizei GLintptr a
	| Viewport GLint GLint GLsizei GLsizei a

instance functorWebGLF :: Functor WebGLF where
	map f (AttachShader p s x) = AttachShader p s (f x)
	map f (BindBuffer t b x) = BindBuffer t b (f x)
	map f (BufferData t s u x) = BufferData t s u (f x)
	map f (Clear mask x) = Clear mask (f x)
	map f (ClearColor r g b a x) = ClearColor r g b a (f x)
	map f (CompileShader s x) = CompileShader s (f x)
	map f (CreateBuffer k) = CreateBuffer (f <<< k)
	map f (CreateProgram k) = CreateProgram (f <<< k)
	map f (CreateShader t k) = CreateShader t (f <<< k)
	map f (DepthFunc func x) = DepthFunc func (f x)
	map f (DrawArrays mode first count x) = DrawArrays mode first count (f x)
	map f (Enable cap x) = Enable cap (f x)
	map f (EnableVertexAttribArray i x) = EnableVertexAttribArray i (f x)
	map f (GetAttribLocation p s k) = GetAttribLocation p s (f <<< k)
	map f (GetCanvas k) = GetCanvas (f <<< k)
	map f (GetDrawingBufferHeight k) = GetDrawingBufferHeight (f <<< k)
	map f (GetDrawingBufferWidth k) = GetDrawingBufferWidth (f <<< k)
	map f (GetProgramInfoLog s k) = GetProgramInfoLog s (f <<< k)
	map f (GetProgramLinkStatus p k) = GetProgramLinkStatus p (f <<< k)
	map f (GetShaderCompileStatus s k) = GetShaderCompileStatus s (f <<< k)
	map f (GetShaderInfoLog s k) = GetShaderInfoLog s (f <<< k)
	map f (GetUniformLocation p n k) = GetUniformLocation p n (f <<< k)
	map f (LinkProgram p x) = LinkProgram p (f x)
	map f (ShaderSource sh src x) = ShaderSource sh src (f x)
	map f (UniformMatrix4fv l t v x) = UniformMatrix4fv l t v (f x)
	map f (UseProgram p x) = UseProgram p (f x)
	map f (VertexAttribPointer l s t n str o x) = VertexAttribPointer l s t n str o (f x)
	map f (Viewport x y w h a) = Viewport x y w h (f a)

type WebGL = Free WebGLF

attachShader :: WebGLProgram -> WebGLShader -> WebGL Unit
attachShader p s = liftF $ AttachShader p s unit

bindBuffer :: GLenum -> WebGLBuffer -> WebGL Unit
bindBuffer t b = liftF $ BindBuffer t b unit

bufferData :: GLenum -> BufferDataSource -> GLenum -> WebGL Unit
bufferData t s u = liftF $ BufferData t s u unit

clear :: GLbitfield -> WebGL Unit
clear mask = liftF $ Clear mask unit

clearColor :: GLclampf -> GLclampf -> GLclampf -> GLclampf -> WebGL Unit
clearColor r g b a = liftF $ ClearColor r g b a unit

compileShader :: WebGLShader -> WebGL Unit
compileShader s = liftF $ CompileShader s unit

createBuffer :: WebGL (Maybe WebGLBuffer)
createBuffer = liftF $ CreateBuffer id

createProgram :: WebGL (Maybe WebGLProgram)
createProgram = liftF $ CreateProgram id

createShader :: GLenum -> WebGL (Maybe WebGLShader)
createShader t = liftF $ CreateShader t id

depthFunc :: GLenum -> WebGL Unit
depthFunc func = liftF $ DepthFunc func unit

drawArrays :: GLenum -> GLint -> GLsizei -> WebGL Unit
drawArrays mode first count = liftF $ DrawArrays mode first count unit

enable :: GLenum -> WebGL Unit
enable cap = liftF $ Enable cap unit

enableVertexAttribArray :: AttributeLocation -> WebGL Unit
enableVertexAttribArray location = liftF $ EnableVertexAttribArray location unit

getAttribLocation :: WebGLProgram -> DOMString -> WebGL (Maybe AttributeLocation)
getAttribLocation program name = liftF $ GetAttribLocation program name id

getCanvas :: WebGL CanvasElement
getCanvas = liftF $ GetCanvas id

getDrawingBufferHeight :: WebGL Int
getDrawingBufferHeight = liftF $ GetDrawingBufferHeight id

getDrawingBufferWidth :: WebGL Int
getDrawingBufferWidth = liftF $ GetDrawingBufferWidth id

getProgramInfoLog :: WebGLProgram -> WebGL (Maybe DOMString)
getProgramInfoLog p = liftF $ GetProgramInfoLog p id

getProgramLinkStatus :: WebGLProgram -> WebGL Boolean
getProgramLinkStatus p = liftF $ GetProgramLinkStatus p id

getShaderCompileStatus :: WebGLShader -> WebGL Boolean
getShaderCompileStatus s = liftF $ GetShaderCompileStatus s id

getShaderInfoLog :: WebGLShader -> WebGL (Maybe DOMString)
getShaderInfoLog s = liftF $ GetShaderInfoLog s id

getUniformLocation :: WebGLProgram -> DOMString -> WebGL (Maybe WebGLUniformLocation)
getUniformLocation program name = liftF $ GetUniformLocation program name id

linkProgram :: WebGLProgram -> WebGL Unit
linkProgram p = liftF $ LinkProgram p unit

shaderSource :: WebGLShader -> DOMString -> WebGL Unit
shaderSource sh src = liftF $ ShaderSource sh src unit

uniformMatrix4fv :: WebGLUniformLocation -> GLboolean -> Float32Array -> WebGL Unit
uniformMatrix4fv location transpose value = liftF $ UniformMatrix4fv location transpose value unit

useProgram :: WebGLProgram -> WebGL Unit
useProgram p = liftF $ UseProgram p unit

vertexAttribPointer :: AttributeLocation -> GLint -> GLenum -> GLboolean -> GLsizei -> GLintptr -> WebGL Unit
vertexAttribPointer l s t n str o = liftF $ VertexAttribPointer l s t n str o unit

viewport :: GLint -> GLint -> GLsizei -> GLsizei -> WebGL Unit
viewport x y w h = liftF $ Viewport x y w h unit

interpretWebGL :: forall a eff. WebGLContext -> WebGLF (WebGL a) -> Eff (canvas :: Canvas | eff) (WebGL a)
interpretWebGL gl (AttachShader p s rest) = do
	R.attachShader gl p s
	return rest
interpretWebGL gl (BindBuffer t buffer rest) = do
	R.bindBuffer gl t buffer
	return rest
interpretWebGL gl (BufferData t source usage rest) = do
	R.bufferData gl t source usage
	return rest
interpretWebGL gl (Clear mask rest) = do
	R.clear gl mask
	return rest
interpretWebGL gl (ClearColor r g b a rest) = do
	R.clearColor gl r g b a
	return rest
interpretWebGL gl (CompileShader sh rest) = do
	R.compileShader gl sh
	return rest
interpretWebGL gl (CreateBuffer k) = do
	buffer <- R.createBuffer gl
	return $ k buffer
interpretWebGL gl (CreateProgram k) = do
	program <- R.createProgram gl
	return $ k program
interpretWebGL gl (CreateShader t k) = do
	shader <- R.createShader gl t
	return $ k shader
interpretWebGL gl (DepthFunc func rest) = do
	R.depthFunc gl func
	return rest
interpretWebGL gl (DrawArrays mode first count rest) = do
	R.drawArrays gl mode first count
	return rest
interpretWebGL gl (Enable cap rest) = do
	R.enable gl cap
	return rest
interpretWebGL gl (EnableVertexAttribArray (AttributeLocation location) rest) = do
	R.enableVertexAttribArray gl location
	return rest
interpretWebGL gl (GetAttribLocation program name k) = do
	location <- R.getAttribLocation gl program name
	if location == -1
		then return $ k Nothing
		else return $ k $ Just (AttributeLocation location)
interpretWebGL gl (GetCanvas k) = do
	el <- R.getCanvas gl
	return $ k el
interpretWebGL gl (GetDrawingBufferHeight k) = do
	h <- R.getDrawingBufferHeight gl
	return $ k h
interpretWebGL gl (GetDrawingBufferWidth k) = do
	w <- R.getDrawingBufferWidth gl
	return $ k w
interpretWebGL gl (GetProgramInfoLog p k) = do
	maybeLog <- R.getProgramInfoLog gl p
	return $ k maybeLog
interpretWebGL gl (GetProgramLinkStatus p k) = do
	Just b <- R.getProgramParameter gl p GL.linkStatus
	return $ k b
interpretWebGL gl (GetShaderCompileStatus s k) = do
	Just b <- R.getShaderParameter gl s GL.compileStatus
	return $ k b
interpretWebGL gl (GetShaderInfoLog s k) = do
	maybeLog <- R.getShaderInfoLog gl s
	return $ k maybeLog
interpretWebGL gl (GetUniformLocation program name k) = do
	location <- R.getUniformLocation gl program name
	return $ k location
interpretWebGL gl (LinkProgram p rest) = do
	R.linkProgram gl p
	return rest
interpretWebGL gl (ShaderSource sh src rest) = do
	R.shaderSource gl sh src
	return rest
interpretWebGL gl (UniformMatrix4fv location transpose value rest) = do
	R.uniformMatrix4fv_ gl location transpose value
	return rest
interpretWebGL gl (UseProgram p rest) = do
	R.useProgram gl p
	return rest
interpretWebGL gl (VertexAttribPointer (AttributeLocation l) s t n str o rest) = do
	R.vertexAttribPointer gl l s t n o str
	return rest
interpretWebGL gl (Viewport x y w h rest) = do
	R.viewport gl x y w h
	return rest

runWebGL :: forall a eff. WebGLContext -> WebGL a -> Eff (canvas :: Canvas | eff) a
runWebGL = runFreeM <<< interpretWebGL

debugWebGL :: forall a eff. WebGLContext -> WebGL a -> Eff (canvas :: Canvas, console :: CONSOLE | eff) a
debugWebGL gl = runFreeM interpretDebug
	where
	interpretDebug :: forall a. WebGLF (WebGL a) -> Eff (canvas :: Canvas, console :: CONSOLE | eff) (WebGL a)
	interpretDebug comp = do
		rest <- interpretWebGL gl comp
		err <- R.getError gl
		if err == GL.noError
			then return rest
			else do
				error $ "WebGL Error: " ++ show err
				return rest


refactor to expose expedition info getter

module KanColle.Expedition where

import Prelude
import Data.Array
import Data.Foldable
import Data.Monoid
import Data.Monoid.Endo
import qualified Data.Map as M

import KanColle.Expedition.Requirement
import KanColle.Expedition.IncomeBase
import KanColle.Expedition.Cost
import KanColle.Expedition.Base

validExpeditionId :: Int -> Boolean
validExpeditionId = getExpeditionRequirement >>> null >>> not

-- expeditionIds :: Array Int
-- expeditionIds = (1..32) <> (35..40)

getAvailableExpeditions :: forall a. Fleet a -> Array Int
getAvailableExpeditions fleet =
  filter (\eId -> checkExpedition eId fleet) allExpeditionIds

checkExpedition :: forall a. Int -> Fleet a -> Boolean
checkExpedition eId fleet = validExpeditionId eId
                         && null (unsatisfiedRequirements eId fleet)

type Expedition =
  { id :: Int
  , req :: ExpeditionRequirement
  , income :: IncomeBase
  , cost :: Cost
  }

getExpeditionInfo :: Int -> Expedition
getExpeditionInfo eId =
    { id: eId
    , req: getExpeditionRequirement eId
    , income: getExpeditionIncomeBase eId
    , cost: getExpeditionCost eId }

allExpeditions :: Array Expedition
allExpeditions = map getExpeditionInfo allExpeditionIds

module KanColle.Expedition where

import Prelude
import Data.Array
import Data.Foldable
import Data.Monoid
import Data.Monoid.Endo
import qualified Data.Map as M

import KanColle.Expedition.Requirement
import KanColle.Expedition.IncomeBase
import KanColle.Expedition.Cost
import KanColle.Expedition.Base

validExpeditionId :: Int -> Boolean
validExpeditionId = getExpeditionRequirement >>> null >>> not

-- expeditionIds :: Array Int
-- expeditionIds = (1..32) <> (35..40)

getAvailableExpeditions :: forall a. Fleet a -> Array Int
getAvailableExpeditions fleet =
  filter (\eId -> checkExpedition eId fleet) allExpeditionIds

checkExpedition :: forall a. Int -> Fleet a -> Boolean
checkExpedition eId fleet = validExpeditionId eId
                         && null (unsatisfiedRequirements eId fleet)

type Expedition =
  { id :: Int
  , req :: ExpeditionRequirement
  , income :: IncomeBase
  , cost :: Cost
  }

allExpeditions :: Array Expedition
allExpeditions = map mkEntry allExpeditionIds
  where
    mkEntry eId = { id: eId
                  , req: getExpeditionRequirement eId
                  , income: getExpeditionIncomeBase eId
                  , cost: getExpeditionCost eId }