fix: nullWebGLFramebuffer is null now

fix: nullWebGLFramebuffer is null now

module Backend where

import Debug.Trace
import Prelude.Unsafe (unsafeIndex)

import qualified Graphics.WebGLRaw as GL
import Control.Monad.Eff.Exception
import Control.Monad.Eff.WebGL
import Control.Monad.Eff.Ref
import Control.Monad.Eff
import Control.Monad
import Control.Bind
import Data.Foldable
import Data.Traversable
import qualified Data.StrMap as StrMap
import qualified Data.Map as Map
import Data.Tuple
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Array

import Type
import IR
import Util
import Input

setupRasterContext :: RasterContext -> GFX Unit
setupRasterContext = cvt
  where
    cff :: FrontFace -> GL.GLenum
    cff CCW = GL._CCW
    cff CW  = GL._CW

    -- not presented in WebGL
    {-
    setProvokingVertex :: ProvokingVertex -> IO ()
    setProvokingVertex pv = glProvokingVertex $ case pv of
        FirstVertex -> gl_FIRST_VERTEX_CONVENTION
        LastVertex  -> gl_LAST_VERTEX_CONVENTION
    -}

    setPointSize :: PointSize -> GFX Unit
    setPointSize ps = case ps of
        ProgramPointSize    -> return unit
        PointSize s         -> trace "PointSize is not supported!"

    cvt :: RasterContext -> GFX Unit
    cvt (PointCtx ps fts sc) = do
        setPointSize ps
        {-
        glPointParameterf gl_POINT_FADE_THRESHOLD_SIZE (realToFrac fts)
        glPointParameterf gl_POINT_SPRITE_COORD_ORIGIN $ realToFrac $ case sc of
            LowerLeft   -> gl_LOWER_LEFT
            UpperLeft   -> gl_UPPER_LEFT
        -}

    cvt (LineCtx lw pv) = do
        GL.lineWidth_ lw
        --setProvokingVertex pv

    cvt (TriangleCtx cm pm po pv) = do
        -- cull mode
        case cm of
            CullNone    -> GL.disable_ GL._CULL_FACE
            CullFront f -> do
                GL.enable_    GL._CULL_FACE
                GL.cullFace_  GL._FRONT
                GL.frontFace_ $ cff f
            CullBack f -> do
                GL.enable_    GL._CULL_FACE
                GL.cullFace_  GL._BACK
                GL.frontFace_ $ cff f

        -- polygon mode
        -- not presented
        {-
        case pm of
            PolygonPoint ps -> do
                setPointSize ps
                glPolygonMode gl_FRONT_AND_BACK gl_POINT
            PolygonLine lw  -> do
                GL.lineWidth_ lw
                glPolygonMode gl_FRONT_AND_BACK gl_LINE
            PolygonFill  -> glPolygonMode gl_FRONT_AND_BACK gl_FILL
        -}
        -- polygon offset
        -- not presented: glDisable gl_POLYGON_OFFSET_POINT
        -- not presented: glDisable gl_POLYGON_OFFSET_LINE
        GL.disable_ GL._POLYGON_OFFSET_FILL
        case po of
            NoOffset -> return unit
            Offset f u -> do
                GL.polygonOffset_ f u
                GL.enable_ GL._POLYGON_OFFSET_FILL

        -- provoking vertex
        -- not presented: setProvokingVertex pv

setupAccumulationContext :: AccumulationContext -> GFX Unit
setupAccumulationContext (AccumulationContext {accViewportName = n, accOperations = ops}) = cvt ops
  where
    cvt :: [FragmentOperation] -> GFX Unit
    cvt (StencilOp a b c : DepthOp f m : xs) = do
        -- TODO
        cvtC 0 xs
    cvt (StencilOp a b c : xs) = do
        -- TODO
        cvtC 0 xs
    cvt (DepthOp df dm : xs) = do
        -- TODO
        GL.disable_ GL._STENCIL_TEST
        let glDF = comparisonFunctionToGLType df
        case glDF == comparisonFunctionToGLType Always && dm == false of
            true    -> GL.disable_ GL._DEPTH_TEST
            false   -> do
                GL.enable_ GL._DEPTH_TEST
                GL.depthFunc_ glDF
                GL.depthMask_ dm
        cvtC 0 xs
    cvt xs = do
        GL.disable_ GL._DEPTH_TEST
        GL.disable_ GL._STENCIL_TEST
        cvtC 0 xs

    cvtC :: Int -> [FragmentOperation] -> GFX Unit
    cvtC i (ColorOp b m : xs) = do
        -- TODO
        case b of
            NoBlending -> do
                -- FIXME: requires GL 3.1
                --glDisablei gl_BLEND $ fromIntegral gl_DRAW_BUFFER0 + fromIntegral i
                GL.disable_ GL._BLEND -- workaround
                -- not presented: GL.disable_ GL._COLOR_LOGIC_OP
            BlendLogicOp op -> do
                GL.disable_ GL._BLEND
                -- not presented: GL.enable_  GL._COLOR_LOGIC_OP
                -- not presented: GL.logicOp_ $ logicOperationToGLType op
                trace "not presented: BlendLogicOp"
            Blend eq fac (V4 r g b a) -> do
                -- not presented: glDisable gl_COLOR_LOGIC_OP
                -- FIXME: requires GL 3.1
                --glEnablei gl_BLEND $ fromIntegral gl_DRAW_BUFFER0 + fromIntegral i
                GL.enable_ GL._BLEND -- workaround
                GL.blendEquationSeparate_ (blendEquationToGLType eq.colorEq) (blendEquationToGLType eq.alphaEq)
                GL.blendColor_ r g b a
                BlendingFactorPair colorF <- pure fac.colorF
                BlendingFactorPair alphaF <- pure fac.alphaF
                GL.blendFuncSeparate_ (blendingFactorToGLType colorF.src) (blendingFactorToGLType colorF.dst)
                                      (blendingFactorToGLType alphaF.src) (blendingFactorToGLType alphaF.dst)
        case m of
          VBool r           -> GL.colorMask_ r true true true
          VV2B (V2 r g)     -> GL.colorMask_ r g true true
          VV3B (V3 r g b)   -> GL.colorMask_ r g b true
          VV4B (V4 r g b a) -> GL.colorMask_ r g b a
          _                 -> GL.colorMask_ true true true true
        cvtC (i + 1) xs
    cvtC _ [] = return unit

clearRenderTarget :: [ClearImage] -> GFX Unit
clearRenderTarget values = do
    let setClearValue {mask:m,index:i} (ClearImage val) = case val of
            {semantic = Depth, value = VFloat v} -> do
                GL.depthMask_ true
                GL.clearDepth_ v
                return {mask:m .|. GL._DEPTH_BUFFER_BIT, index:i}
            {semantic = Stencil, value = VWord v} -> do
                GL.clearStencil_ v
                return {mask:m .|. GL._STENCIL_BUFFER_BIT, index:i}
            {semantic = Color, value = c} -> do
                case c of
                  VFloat r            -> GL.clearColor_ r 0 0 1
                  VV2F (V2 r g)       -> GL.clearColor_ r g 0 1
                  VV3F (V3 r g b)     -> GL.clearColor_ r g b 1
                  VV4F (V4 r g b a)   -> GL.clearColor_ r g b a
                  _                   -> GL.clearColor_ 0 0 0 1
                GL.colorMask_ true true true true
                return {mask:m .|. GL._COLOR_BUFFER_BIT, index:i+1}
            _ -> throwException $ error "internal error (clearRenderTarget)"
    m <- foldM setClearValue {mask:0,index:0} values
    GL.clear_ m.mask

compileProgram :: StrMap.StrMap InputType -> Program -> GFX GLProgram
compileProgram uniTrie (Program p) = do
    po <- GL.createProgram_
    let createAndAttach src t = do
          o <- GL.createShader_ t
          GL.shaderSource_ o src
          GL.compileShader_ o
          log <- GL.getShaderInfoLog_ o
          trace log
          status <- GL.getShaderParameter_ o GL._COMPILE_STATUS
          when (status /= true) $ throwException $ error "compileShader failed!"
          GL.attachShader_ po o
          --putStr "    + compile shader source: " >> printGLStatus
          return o

    objV <- createAndAttach p.vertexShader GL._VERTEX_SHADER
    objF <- createAndAttach p.fragmentShader GL._FRAGMENT_SHADER

    GL.linkProgram_ po
    prgLog <- GL.getProgramInfoLog_ po
    trace prgLog

    -- check link status
    status <- GL.getProgramParameter_ po GL._LINK_STATUS
    when (status /= true) $ throwException $ error "link program failed!"

    uniformLocation <- StrMap.fromList <$> for (StrMap.toList p.programUniforms) (\(Tuple uniName uniType) -> do
      loc <- GL.getUniformLocation_ po uniName
      return $ Tuple uniName loc)

    samplerLocation <- StrMap.fromList <$> for (StrMap.toList p.programInTextures) (\(Tuple uniName uniType) -> do
      loc <- GL.getUniformLocation_ po uniName
      return $ Tuple uniName loc)

    streamLocation <- StrMap.fromList <$> for (StrMap.toList p.programStreams) (\(Tuple streamName (Parameter s)) -> do
      loc <- GL.getAttribLocation_ po streamName
      trace $ "attrib location " ++ streamName ++" " ++ show loc
      return $ Tuple streamName {location: loc, slotAttribute: s.name})

    return {program: po, shaders: [objV,objF], inputUniforms: uniformLocation, inputSamplers:samplerLocation, inputStreams: streamLocation}

foreign import nullWebGLFramebuffer "var nullWebGLFramebuffer = null" :: GL.WebGLFramebuffer

compileRenderTarget :: [TextureDescriptor] -> [GLTexture] -> RenderTarget -> GFX GLRenderTarget
compileRenderTarget texs glTexs (RenderTarget rt) = do
  let targets = rt.renderTargets
      isFB (Framebuffer _)    = true
      isFB _                  = false
      images = map (\(TargetItem a) -> fromJust a.ref) $ filter (\(TargetItem a) -> isJust a.ref) targets
      act1 = case all isFB images of
          true -> do
              let isColor Color = true
                  isColor _ = false
                  cvt (TargetItem a) = case a.ref of
                      Nothing                     -> return GL._NONE
                      Just (Framebuffer Color)    -> return GL._BACK
                      _                           -> throwException $ error "internal error (compileRenderTarget)!"
              bufs <- traverse cvt $ filter (\(TargetItem a) -> isColor a.semantic) targets
              return $
                  { framebufferObject: nullWebGLFramebuffer
                  , framebufferDrawbuffers: Just bufs
                  }
          false -> do
              when (any isFB images) $ throwException $ error "internal error (compileRenderTarget)!"
              fbo <- GL.createFramebuffer_
              GL.bindFramebuffer_ GL._FRAMEBUFFER fbo
              let attach attachment (TextureImage texIdx level Nothing) = do
                      let glTex = glTexs `unsafeIndex` texIdx
                          tex = texs `unsafeIndex` texIdx
                          txLevel = level
                          txTarget = glTex.textureTarget
                          txObj = glTex.textureObject
                          attach2D    = GL.framebufferTexture2D_ GL._FRAMEBUFFER attachment txTarget txObj txLevel
                          act0 = case tex of
                            TextureDescriptor t -> case t.textureType of
                              Texture2D     _ 1 -> attach2D
                              _ -> throwException $ error "invalid texture format!"
                      act0
                  attach _ _ = throwException $ error "invalid texture format!"
                  go a (TargetItem {semantic:Stencil, ref:Just img}) = do
                      throwException $ error "Stencil support is not implemented yet!"
                      return a
                  go a (TargetItem {semantic: Depth,ref: Just img}) = do
                      attach GL._DEPTH_ATTACHMENT img
                      return a
                  go (Tuple bufs colorIdx) (TargetItem {semantic: Color,ref: Just img}) = do
                      let attachment = GL._COLOR_ATTACHMENT0
                      attach attachment img
                      return (Tuple (attachment : bufs) (colorIdx + 1))
                  go (Tuple bufs colorIdx) (TargetItem {semantic: Color,ref: Nothing}) = return (Tuple (GL._NONE : bufs) (colorIdx + 1))
                  go a _ = return a
              (Tuple bufs _) <- foldM go (Tuple [] 0) targets
              return $
                  { framebufferObject: fbo
                  , framebufferDrawbuffers: Nothing
                  }
  act1

allocPipeline :: Pipeline -> GFX WebGLPipeline
allocPipeline (Pipeline p) = do
  texs <- traverse compileTexture p.textures
  trgs <- traverse (compileRenderTarget p.textures texs) p.targets
  prgs <- traverse (compileProgram StrMap.empty) p.programs
  input <- newRef Nothing
  curProg <- newRef Nothing
  return
    { targets: trgs
    , textures: texs
    , programs: prgs
    , commands: p.commands
    , input: input
    , slotPrograms: map (\(Slot a) -> a.slotPrograms) p.slots
    , slotNames: map (\(Slot a) -> a.slotName) p.slots
    , curProgram: curProg
    }

renderPipeline :: WebGLPipeline -> GFX Unit
renderPipeline p = do
  writeRef p.curProgram Nothing
  for_ p.commands $ \cmd -> case cmd of
      SetRenderTarget i -> do
        let rt = p.targets `unsafeIndex` i
        ic' <- readRef p.input
        case ic' of
            Nothing -> return unit
            Just (InputConnection ic) -> do
                        V2 w h <- readRef ic.input.screenSize
                        GL.viewport_ 0 0 w h
        -- TODO: set FBO target viewport
        GL.bindFramebuffer_ GL._FRAMEBUFFER rt.framebufferObject
        {-
        case bufs of
            Nothing -> return unit
            Just bl -> withArray bl $ glDrawBuffers (fromIntegral $ length bl)
        -}
      SetSamplerUniform n tu -> do
        readRef p.curProgram >>= \cp -> case cp of
          Nothing -> throwException $ error "invalid pipeline, no active program"
          Just progIdx -> case StrMap.lookup n (p.programs `unsafeIndex` progIdx).inputSamplers of
            Nothing -> throwException $ error "internal error (SetSamplerUniform)!"
            Just i  -> GL.uniform1i_ i tu

      SetTexture tu i -> do
        GL.activeTexture_ (GL._TEXTURE0 + tu)
        let tx = p.textures `unsafeIndex` i
        GL.bindTexture_ tx.textureTarget tx.textureObject
      SetRasterContext rCtx -> do
        --trace "SetRasterContext"
        setupRasterContext rCtx
      SetAccumulationContext aCtx -> do
        --trace "SetAccumulationContext"
        setupAccumulationContext aCtx
      ClearRenderTarget t -> do
        --trace "ClearRenderTarget"
        clearRenderTarget t
      SetProgram i -> do
        --trace $ "SetProgram " ++ show i
        writeRef p.curProgram (Just i)
        GL.useProgram_ $ (p.programs `unsafeIndex` i).program
      RenderSlot slotIdx -> do
        --trace $ "RenderSlot " ++ show slotIdx
        readRef p.curProgram >>= \cp -> case cp of
          Nothing -> throwException $ error "invalid pipeline, no active program"
          Just progIdx -> readRef p.input >>= \input -> case input of
              Nothing -> return unit
              Just (InputConnection ic) -> do
                s <- readRef (ic.input.slotVector `unsafeIndex` (ic.slotMapPipelineToInput `unsafeIndex` slotIdx))
                --trace $ "#" ++ show (length s.sortedObjects)
                for_ s.sortedObjects $ \(Tuple _ obj) -> do
                  enabled <- readRef obj.enabled
                  when enabled $ do
                    cmd <- readRef obj.commands
                    renderSlot $ (cmd `unsafeIndex` ic.id) `unsafeIndex` progIdx
      _ -> return unit

renderSlot :: [GLObjectCommand] -> GFX Unit
renderSlot cmds = do
  for_ cmds $ \cmd -> case cmd of
    GLSetVertexAttribArray idx buf size typ ptr -> do
      --trace $ "GLSetVertexAttribArray " ++ show [idx,size,ptr]
      GL.bindBuffer_ GL._ARRAY_BUFFER buf
      GL.enableVertexAttribArray_ idx
      GL.vertexAttribPointer_ idx size typ false 0 ptr
    GLDrawArrays mode first count -> do
      --trace $ "GLDrawArrays " ++ show [first,count]
      GL.drawArrays_ mode first count
    GLDrawElements mode count typ buf indicesPtr -> do
      --trace "GLDrawElements"
      GL.bindBuffer_ GL._ELEMENT_ARRAY_BUFFER buf
      GL.drawElements_ mode count typ indicesPtr
    GLSetVertexAttrib idx val -> do
      --trace $ "GLSetVertexAttrib " ++ show idx
      GL.disableVertexAttribArray_ idx
      setVertexAttrib idx val
    GLSetUniform idx uni -> do
      --trace "GLSetUniform"
      setUniform idx uni
{-
        GLBindTexture txTarget tuRef (GLUniform _ ref)  -> do
                                                            txObjVal <- readIORef ref
                                                            -- HINT: ugly and hacky
                                                            with txObjVal $ \txObjPtr -> do
                                                                txObj <- peek $ castPtr txObjPtr :: IO GLuint
                                                                texUnit <- readIORef tuRef
                                                                glActiveTexture $ gl_TEXTURE0 + fromIntegral texUnit
                                                                glBindTexture txTarget txObj
-}

disposePipeline :: WebGLPipeline -> GFX Unit
disposePipeline p = do
  setPipelineInput p Nothing
  for_ p.programs $ \prg -> do
      GL.deleteProgram_ prg.program
      traverse_ GL.deleteShader_ prg.shaders
  {- TODO: targets, textures
  let targets = glTargets p
  withArray (map framebufferObject $ V.toList targets) $ (glDeleteFramebuffers $ fromIntegral $ V.length targets)
  let textures = glTextures p
  withArray (map glTextureObject $ V.toList textures) $ (glDeleteTextures $ fromIntegral $ V.length textures)
  with (glVAO p) $ (glDeleteVertexArrays 1)
  -}

setPipelineInput :: WebGLPipeline -> Maybe WebGLPipelineInput -> GFX Unit
setPipelineInput p input' = do
    -- TODO: check matching input schema
    ic' <- readRef p.input
    case ic' of
        Nothing -> return unit
        Just (InputConnection ic) -> do
            modifyRef ic.input.pipelines $ \v -> updateAt ic.id Nothing v
            for_ ic.slotMapPipelineToInput $ \slotIdx -> do
                slot <- readRef (ic.input.slotVector `unsafeIndex` slotIdx)
                for_ (Map.values slot.objectMap) $ \obj -> do
                    modifyRef obj.commands $ \v -> updateAt ic.id [] v
    {-
        addition:
            - get an id from pipeline input
            - add to attached pipelines
            - generate slot mappings
            - update used slots, and generate object commands for objects in the related slots
    -}
    case input' of
        Nothing -> writeRef p.input Nothing
        Just input -> do
            oldPipelineV <- readRef input.pipelines
            Tuple idx shouldExtend <- case findIndex isNothing oldPipelineV of
                (-1) -> do
                    -- we don't have empty space, hence we double the vector size
                    let len = length oldPipelineV
                    modifyRef input.pipelines $ \v -> updateAt len (Just p) (concat [v,replicate len Nothing])
                    return $ Tuple len (Just len)
                i -> do
                    modifyRef input.pipelines $ \v -> updateAt i (Just p) v
                    return $ Tuple i Nothing
            -- create input connection
            pToI <- for p.slotNames $ \n -> case StrMap.lookup n input.slotMap of
              Nothing -> throwException $ error "internal error: unknown slot name in input"
              Just i -> return i
            let iToP = foldr (\(Tuple i v) -> updateAt v (Just i)) (replicate (StrMap.size input.slotMap) Nothing) (zip (0..length pToI) pToI)
            writeRef p.input $ Just $ InputConnection {id: idx, input: input, slotMapPipelineToInput: pToI, slotMapInputToPipeline: iToP}

            -- generate object commands for related slots
            {-
                for each slot in pipeline:
                    map slot name to input slot name
                    for each object:
                        generate command program vector => for each dependent program:
                            generate object commands
            -}
            let texUnitMap = {} --TODO: glTexUnitMapping p
                topUnis = input.uniformSetup
                emptyV  = replicate (length p.programs) []
                extend v = case shouldExtend of
                    Nothing -> v
                    Just l  -> concat [v,replicate l []]
            for_ (zip pToI p.slotPrograms) $ \(Tuple slotIdx prgs) -> do
                slot <- readRef $ input.slotVector `unsafeIndex` slotIdx
                for_ (Map.values slot.objectMap) $ \obj -> do
                    let updateCmds v prgIdx = updateAt prgIdx (createObjectCommands texUnitMap topUnis obj (p.programs `unsafeIndex` prgIdx)) v
                        cmdV = foldl updateCmds emptyV prgs
                    modifyRef obj.commands $ \v -> updateAt idx cmdV (extend v)

module Backend where

import Debug.Trace
import Prelude.Unsafe (unsafeIndex)

import qualified Graphics.WebGLRaw as GL
import Control.Monad.Eff.Exception
import Control.Monad.Eff.WebGL
import Control.Monad.Eff.Ref
import Control.Monad.Eff
import Control.Monad
import Control.Bind
import Data.Foldable
import Data.Traversable
import qualified Data.StrMap as StrMap
import qualified Data.Map as Map
import Data.Tuple
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Array

import Type
import IR
import Util
import Input

setupRasterContext :: RasterContext -> GFX Unit
setupRasterContext = cvt
  where
    cff :: FrontFace -> GL.GLenum
    cff CCW = GL._CCW
    cff CW  = GL._CW

    -- not presented in WebGL
    {-
    setProvokingVertex :: ProvokingVertex -> IO ()
    setProvokingVertex pv = glProvokingVertex $ case pv of
        FirstVertex -> gl_FIRST_VERTEX_CONVENTION
        LastVertex  -> gl_LAST_VERTEX_CONVENTION
    -}

    setPointSize :: PointSize -> GFX Unit
    setPointSize ps = case ps of
        ProgramPointSize    -> return unit
        PointSize s         -> trace "PointSize is not supported!"

    cvt :: RasterContext -> GFX Unit
    cvt (PointCtx ps fts sc) = do
        setPointSize ps
        {-
        glPointParameterf gl_POINT_FADE_THRESHOLD_SIZE (realToFrac fts)
        glPointParameterf gl_POINT_SPRITE_COORD_ORIGIN $ realToFrac $ case sc of
            LowerLeft   -> gl_LOWER_LEFT
            UpperLeft   -> gl_UPPER_LEFT
        -}

    cvt (LineCtx lw pv) = do
        GL.lineWidth_ lw
        --setProvokingVertex pv

    cvt (TriangleCtx cm pm po pv) = do
        -- cull mode
        case cm of
            CullNone    -> GL.disable_ GL._CULL_FACE
            CullFront f -> do
                GL.enable_    GL._CULL_FACE
                GL.cullFace_  GL._FRONT
                GL.frontFace_ $ cff f
            CullBack f -> do
                GL.enable_    GL._CULL_FACE
                GL.cullFace_  GL._BACK
                GL.frontFace_ $ cff f

        -- polygon mode
        -- not presented
        {-
        case pm of
            PolygonPoint ps -> do
                setPointSize ps
                glPolygonMode gl_FRONT_AND_BACK gl_POINT
            PolygonLine lw  -> do
                GL.lineWidth_ lw
                glPolygonMode gl_FRONT_AND_BACK gl_LINE
            PolygonFill  -> glPolygonMode gl_FRONT_AND_BACK gl_FILL
        -}
        -- polygon offset
        -- not presented: glDisable gl_POLYGON_OFFSET_POINT
        -- not presented: glDisable gl_POLYGON_OFFSET_LINE
        GL.disable_ GL._POLYGON_OFFSET_FILL
        case po of
            NoOffset -> return unit
            Offset f u -> do
                GL.polygonOffset_ f u
                GL.enable_ GL._POLYGON_OFFSET_FILL

        -- provoking vertex
        -- not presented: setProvokingVertex pv

setupAccumulationContext :: AccumulationContext -> GFX Unit
setupAccumulationContext (AccumulationContext {accViewportName = n, accOperations = ops}) = cvt ops
  where
    cvt :: [FragmentOperation] -> GFX Unit
    cvt (StencilOp a b c : DepthOp f m : xs) = do
        -- TODO
        cvtC 0 xs
    cvt (StencilOp a b c : xs) = do
        -- TODO
        cvtC 0 xs
    cvt (DepthOp df dm : xs) = do
        -- TODO
        GL.disable_ GL._STENCIL_TEST
        let glDF = comparisonFunctionToGLType df
        case glDF == comparisonFunctionToGLType Always && dm == false of
            true    -> GL.disable_ GL._DEPTH_TEST
            false   -> do
                GL.enable_ GL._DEPTH_TEST
                GL.depthFunc_ glDF
                GL.depthMask_ dm
        cvtC 0 xs
    cvt xs = do
        GL.disable_ GL._DEPTH_TEST
        GL.disable_ GL._STENCIL_TEST
        cvtC 0 xs

    cvtC :: Int -> [FragmentOperation] -> GFX Unit
    cvtC i (ColorOp b m : xs) = do
        -- TODO
        case b of
            NoBlending -> do
                -- FIXME: requires GL 3.1
                --glDisablei gl_BLEND $ fromIntegral gl_DRAW_BUFFER0 + fromIntegral i
                GL.disable_ GL._BLEND -- workaround
                -- not presented: GL.disable_ GL._COLOR_LOGIC_OP
            BlendLogicOp op -> do
                GL.disable_ GL._BLEND
                -- not presented: GL.enable_  GL._COLOR_LOGIC_OP
                -- not presented: GL.logicOp_ $ logicOperationToGLType op
                trace "not presented: BlendLogicOp"
            Blend eq fac (V4 r g b a) -> do
                -- not presented: glDisable gl_COLOR_LOGIC_OP
                -- FIXME: requires GL 3.1
                --glEnablei gl_BLEND $ fromIntegral gl_DRAW_BUFFER0 + fromIntegral i
                GL.enable_ GL._BLEND -- workaround
                GL.blendEquationSeparate_ (blendEquationToGLType eq.colorEq) (blendEquationToGLType eq.alphaEq)
                GL.blendColor_ r g b a
                BlendingFactorPair colorF <- pure fac.colorF
                BlendingFactorPair alphaF <- pure fac.alphaF
                GL.blendFuncSeparate_ (blendingFactorToGLType colorF.src) (blendingFactorToGLType colorF.dst)
                                      (blendingFactorToGLType alphaF.src) (blendingFactorToGLType alphaF.dst)
        case m of
          VBool r           -> GL.colorMask_ r true true true
          VV2B (V2 r g)     -> GL.colorMask_ r g true true
          VV3B (V3 r g b)   -> GL.colorMask_ r g b true
          VV4B (V4 r g b a) -> GL.colorMask_ r g b a
          _                 -> GL.colorMask_ true true true true
        cvtC (i + 1) xs
    cvtC _ [] = return unit

clearRenderTarget :: [ClearImage] -> GFX Unit
clearRenderTarget values = do
    let setClearValue {mask:m,index:i} (ClearImage val) = case val of
            {semantic = Depth, value = VFloat v} -> do
                GL.depthMask_ true
                GL.clearDepth_ v
                return {mask:m .|. GL._DEPTH_BUFFER_BIT, index:i}
            {semantic = Stencil, value = VWord v} -> do
                GL.clearStencil_ v
                return {mask:m .|. GL._STENCIL_BUFFER_BIT, index:i}
            {semantic = Color, value = c} -> do
                case c of
                  VFloat r            -> GL.clearColor_ r 0 0 1
                  VV2F (V2 r g)       -> GL.clearColor_ r g 0 1
                  VV3F (V3 r g b)     -> GL.clearColor_ r g b 1
                  VV4F (V4 r g b a)   -> GL.clearColor_ r g b a
                  _                   -> GL.clearColor_ 0 0 0 1
                GL.colorMask_ true true true true
                return {mask:m .|. GL._COLOR_BUFFER_BIT, index:i+1}
            _ -> throwException $ error "internal error (clearRenderTarget)"
    m <- foldM setClearValue {mask:0,index:0} values
    GL.clear_ m.mask

compileProgram :: StrMap.StrMap InputType -> Program -> GFX GLProgram
compileProgram uniTrie (Program p) = do
    po <- GL.createProgram_
    let createAndAttach src t = do
          o <- GL.createShader_ t
          GL.shaderSource_ o src
          GL.compileShader_ o
          log <- GL.getShaderInfoLog_ o
          trace log
          status <- GL.getShaderParameter_ o GL._COMPILE_STATUS
          when (status /= true) $ throwException $ error "compileShader failed!"
          GL.attachShader_ po o
          --putStr "    + compile shader source: " >> printGLStatus
          return o

    objV <- createAndAttach p.vertexShader GL._VERTEX_SHADER
    objF <- createAndAttach p.fragmentShader GL._FRAGMENT_SHADER

    GL.linkProgram_ po
    prgLog <- GL.getProgramInfoLog_ po
    trace prgLog

    -- check link status
    status <- GL.getProgramParameter_ po GL._LINK_STATUS
    when (status /= true) $ throwException $ error "link program failed!"

    uniformLocation <- StrMap.fromList <$> for (StrMap.toList p.programUniforms) (\(Tuple uniName uniType) -> do
      loc <- GL.getUniformLocation_ po uniName
      return $ Tuple uniName loc)

    samplerLocation <- StrMap.fromList <$> for (StrMap.toList p.programInTextures) (\(Tuple uniName uniType) -> do
      loc <- GL.getUniformLocation_ po uniName
      return $ Tuple uniName loc)

    streamLocation <- StrMap.fromList <$> for (StrMap.toList p.programStreams) (\(Tuple streamName (Parameter s)) -> do
      loc <- GL.getAttribLocation_ po streamName
      trace $ "attrib location " ++ streamName ++" " ++ show loc
      return $ Tuple streamName {location: loc, slotAttribute: s.name})

    return {program: po, shaders: [objV,objF], inputUniforms: uniformLocation, inputSamplers:samplerLocation, inputStreams: streamLocation}

foreign import nullWebGLFramebuffer "var nullWebGLFramebuffer = 0" :: GL.WebGLFramebuffer

compileRenderTarget :: [TextureDescriptor] -> [GLTexture] -> RenderTarget -> GFX GLRenderTarget
compileRenderTarget texs glTexs (RenderTarget rt) = do
  let targets = rt.renderTargets
      isFB (Framebuffer _)    = true
      isFB _                  = false
      images = map (\(TargetItem a) -> fromJust a.ref) $ filter (\(TargetItem a) -> isJust a.ref) targets
      act1 = case all isFB images of
          true -> do
              let isColor Color = true
                  isColor _ = false
                  cvt (TargetItem a) = case a.ref of
                      Nothing                     -> return GL._NONE
                      Just (Framebuffer Color)    -> return GL._BACK
                      _                           -> throwException $ error "internal error (compileRenderTarget)!"
              bufs <- traverse cvt $ filter (\(TargetItem a) -> isColor a.semantic) targets
              return $
                  { framebufferObject: nullWebGLFramebuffer
                  , framebufferDrawbuffers: Just bufs
                  }
          false -> do
              when (any isFB images) $ throwException $ error "internal error (compileRenderTarget)!"
              fbo <- GL.createFramebuffer_
              GL.bindFramebuffer_ GL._FRAMEBUFFER fbo
              let attach attachment (TextureImage texIdx level Nothing) = do
                      let glTex = glTexs `unsafeIndex` texIdx
                          tex = texs `unsafeIndex` texIdx
                          txLevel = level
                          txTarget = glTex.textureTarget
                          txObj = glTex.textureObject
                          attach2D    = GL.framebufferTexture2D_ GL._FRAMEBUFFER attachment txTarget txObj txLevel
                          act0 = case tex of
                            TextureDescriptor t -> case t.textureType of
                              Texture2D     _ 1 -> attach2D
                              _ -> throwException $ error "invalid texture format!"
                      act0
                  attach _ _ = throwException $ error "invalid texture format!"
                  go a (TargetItem {semantic:Stencil, ref:Just img}) = do
                      throwException $ error "Stencil support is not implemented yet!"
                      return a
                  go a (TargetItem {semantic: Depth,ref: Just img}) = do
                      attach GL._DEPTH_ATTACHMENT img
                      return a
                  go (Tuple bufs colorIdx) (TargetItem {semantic: Color,ref: Just img}) = do
                      let attachment = GL._COLOR_ATTACHMENT0
                      attach attachment img
                      return (Tuple (attachment : bufs) (colorIdx + 1))
                  go (Tuple bufs colorIdx) (TargetItem {semantic: Color,ref: Nothing}) = return (Tuple (GL._NONE : bufs) (colorIdx + 1))
                  go a _ = return a
              (Tuple bufs _) <- foldM go (Tuple [] 0) targets
              return $
                  { framebufferObject: fbo
                  , framebufferDrawbuffers: Nothing
                  }
  act1

allocPipeline :: Pipeline -> GFX WebGLPipeline
allocPipeline (Pipeline p) = do
  texs <- traverse compileTexture p.textures
  trgs <- traverse (compileRenderTarget p.textures texs) p.targets
  prgs <- traverse (compileProgram StrMap.empty) p.programs
  input <- newRef Nothing
  curProg <- newRef Nothing
  return
    { targets: trgs
    , textures: texs
    , programs: prgs
    , commands: p.commands
    , input: input
    , slotPrograms: map (\(Slot a) -> a.slotPrograms) p.slots
    , slotNames: map (\(Slot a) -> a.slotName) p.slots
    , curProgram: curProg
    }

renderPipeline :: WebGLPipeline -> GFX Unit
renderPipeline p = do
  writeRef p.curProgram Nothing
  for_ p.commands $ \cmd -> case cmd of
      SetRenderTarget i -> do
        let rt = p.targets `unsafeIndex` i
        ic' <- readRef p.input
        case ic' of
            Nothing -> return unit
            Just (InputConnection ic) -> do
                        V2 w h <- readRef ic.input.screenSize
                        GL.viewport_ 0 0 w h
        -- TODO: set FBO target viewport
        GL.bindFramebuffer_ GL._FRAMEBUFFER rt.framebufferObject
        {-
        case bufs of
            Nothing -> return unit
            Just bl -> withArray bl $ glDrawBuffers (fromIntegral $ length bl)
        -}
      SetSamplerUniform n tu -> do
        readRef p.curProgram >>= \cp -> case cp of
          Nothing -> throwException $ error "invalid pipeline, no active program"
          Just progIdx -> case StrMap.lookup n (p.programs `unsafeIndex` progIdx).inputSamplers of
            Nothing -> throwException $ error "internal error (SetSamplerUniform)!"
            Just i  -> GL.uniform1i_ i tu

      SetTexture tu i -> do
        GL.activeTexture_ (GL._TEXTURE0 + tu)
        let tx = p.textures `unsafeIndex` i
        GL.bindTexture_ tx.textureTarget tx.textureObject
      SetRasterContext rCtx -> do
        --trace "SetRasterContext"
        setupRasterContext rCtx
      SetAccumulationContext aCtx -> do
        --trace "SetAccumulationContext"
        setupAccumulationContext aCtx
      ClearRenderTarget t -> do
        --trace "ClearRenderTarget"
        clearRenderTarget t
      SetProgram i -> do
        --trace $ "SetProgram " ++ show i
        writeRef p.curProgram (Just i)
        GL.useProgram_ $ (p.programs `unsafeIndex` i).program
      RenderSlot slotIdx -> do
        --trace $ "RenderSlot " ++ show slotIdx
        readRef p.curProgram >>= \cp -> case cp of
          Nothing -> throwException $ error "invalid pipeline, no active program"
          Just progIdx -> readRef p.input >>= \input -> case input of
              Nothing -> return unit
              Just (InputConnection ic) -> do
                s <- readRef (ic.input.slotVector `unsafeIndex` (ic.slotMapPipelineToInput `unsafeIndex` slotIdx))
                --trace $ "#" ++ show (length s.sortedObjects)
                for_ s.sortedObjects $ \(Tuple _ obj) -> do
                  enabled <- readRef obj.enabled
                  when enabled $ do
                    cmd <- readRef obj.commands
                    renderSlot $ (cmd `unsafeIndex` ic.id) `unsafeIndex` progIdx
      _ -> return unit

renderSlot :: [GLObjectCommand] -> GFX Unit
renderSlot cmds = do
  for_ cmds $ \cmd -> case cmd of
    GLSetVertexAttribArray idx buf size typ ptr -> do
      --trace $ "GLSetVertexAttribArray " ++ show [idx,size,ptr]
      GL.bindBuffer_ GL._ARRAY_BUFFER buf
      GL.enableVertexAttribArray_ idx
      GL.vertexAttribPointer_ idx size typ false 0 ptr
    GLDrawArrays mode first count -> do
      --trace $ "GLDrawArrays " ++ show [first,count]
      GL.drawArrays_ mode first count
    GLDrawElements mode count typ buf indicesPtr -> do
      --trace "GLDrawElements"
      GL.bindBuffer_ GL._ELEMENT_ARRAY_BUFFER buf
      GL.drawElements_ mode count typ indicesPtr
    GLSetVertexAttrib idx val -> do
      --trace $ "GLSetVertexAttrib " ++ show idx
      GL.disableVertexAttribArray_ idx
      setVertexAttrib idx val
    GLSetUniform idx uni -> do
      --trace "GLSetUniform"
      setUniform idx uni
{-
        GLBindTexture txTarget tuRef (GLUniform _ ref)  -> do
                                                            txObjVal <- readIORef ref
                                                            -- HINT: ugly and hacky
                                                            with txObjVal $ \txObjPtr -> do
                                                                txObj <- peek $ castPtr txObjPtr :: IO GLuint
                                                                texUnit <- readIORef tuRef
                                                                glActiveTexture $ gl_TEXTURE0 + fromIntegral texUnit
                                                                glBindTexture txTarget txObj
-}

disposePipeline :: WebGLPipeline -> GFX Unit
disposePipeline p = do
  setPipelineInput p Nothing
  for_ p.programs $ \prg -> do
      GL.deleteProgram_ prg.program
      traverse_ GL.deleteShader_ prg.shaders
  {- TODO: targets, textures
  let targets = glTargets p
  withArray (map framebufferObject $ V.toList targets) $ (glDeleteFramebuffers $ fromIntegral $ V.length targets)
  let textures = glTextures p
  withArray (map glTextureObject $ V.toList textures) $ (glDeleteTextures $ fromIntegral $ V.length textures)
  with (glVAO p) $ (glDeleteVertexArrays 1)
  -}

setPipelineInput :: WebGLPipeline -> Maybe WebGLPipelineInput -> GFX Unit
setPipelineInput p input' = do
    -- TODO: check matching input schema
    ic' <- readRef p.input
    case ic' of
        Nothing -> return unit
        Just (InputConnection ic) -> do
            modifyRef ic.input.pipelines $ \v -> updateAt ic.id Nothing v
            for_ ic.slotMapPipelineToInput $ \slotIdx -> do
                slot <- readRef (ic.input.slotVector `unsafeIndex` slotIdx)
                for_ (Map.values slot.objectMap) $ \obj -> do
                    modifyRef obj.commands $ \v -> updateAt ic.id [] v
    {-
        addition:
            - get an id from pipeline input
            - add to attached pipelines
            - generate slot mappings
            - update used slots, and generate object commands for objects in the related slots
    -}
    case input' of
        Nothing -> writeRef p.input Nothing
        Just input -> do
            oldPipelineV <- readRef input.pipelines
            Tuple idx shouldExtend <- case findIndex isNothing oldPipelineV of
                (-1) -> do
                    -- we don't have empty space, hence we double the vector size
                    let len = length oldPipelineV
                    modifyRef input.pipelines $ \v -> updateAt len (Just p) (concat [v,replicate len Nothing])
                    return $ Tuple len (Just len)
                i -> do
                    modifyRef input.pipelines $ \v -> updateAt i (Just p) v
                    return $ Tuple i Nothing
            -- create input connection
            pToI <- for p.slotNames $ \n -> case StrMap.lookup n input.slotMap of
              Nothing -> throwException $ error "internal error: unknown slot name in input"
              Just i -> return i
            let iToP = foldr (\(Tuple i v) -> updateAt v (Just i)) (replicate (StrMap.size input.slotMap) Nothing) (zip (0..length pToI) pToI)
            writeRef p.input $ Just $ InputConnection {id: idx, input: input, slotMapPipelineToInput: pToI, slotMapInputToPipeline: iToP}

            -- generate object commands for related slots
            {-
                for each slot in pipeline:
                    map slot name to input slot name
                    for each object:
                        generate command program vector => for each dependent program:
                            generate object commands
            -}
            let texUnitMap = {} --TODO: glTexUnitMapping p
                topUnis = input.uniformSetup
                emptyV  = replicate (length p.programs) []
                extend v = case shouldExtend of
                    Nothing -> v
                    Just l  -> concat [v,replicate l []]
            for_ (zip pToI p.slotPrograms) $ \(Tuple slotIdx prgs) -> do
                slot <- readRef $ input.slotVector `unsafeIndex` slotIdx
                for_ (Map.values slot.objectMap) $ \obj -> do
                    let updateCmds v prgIdx = updateAt prgIdx (createObjectCommands texUnitMap topUnis obj (p.programs `unsafeIndex` prgIdx)) v
                        cmdV = foldl updateCmds emptyV prgs
                    modifyRef obj.commands $ \v -> updateAt idx cmdV (extend v)


Cards/Minor: Add new cards

Cards/Minor: Add new cards

module Cards(Card(..), cards, Faction(..)) where

import Prelude(Show)

data Faction = Choobar | Einar | Jacob | Jandar | Ullar | Utgar | Vydar

instance showFaction :: Show Faction where
  show Choobar = "choobar"
  show Einar   = "einar"
  show Jacob   = "jacob"
  show Jandar  = "jandar"
  show Ullar   = "ullar"
  show Utgar   = "utgar"
  show Vydar   = "vydar"

data Card = Card
  { name      :: String
  , isEnabled :: Boolean
  , faction   :: Faction
  }

cards :: Array Card
cards =
  [ Card { name: "Agent Carr",                  isEnabled: true,  faction: Vydar   }
  , Card { name: "Airborne Elite",              isEnabled: true,  faction: Jandar  }
  , Card { name: "Alastair MacDirk",            isEnabled: true,  faction: Jandar  }
  , Card { name: "Anubian Wolves",              isEnabled: true,  faction: Utgar   }
  , Card { name: "Aphotia",                     isEnabled: true,  faction: Choobar }
  , Card { name: "Ariella",                     isEnabled: true,  faction: Ullar   }
  , Card { name: "Arkmer",                      isEnabled: true,  faction: Ullar   }
  , Card { name: "Arrow Gruts",                 isEnabled: true,  faction: Utgar   }
  , Card { name: "Aubrien Archers",             isEnabled: true,  faction: Ullar   }
  , Card { name: "Basilisk",                    isEnabled: false, faction: Choobar }
  , Card { name: "Belthasar",                   isEnabled: true,  faction: Choobar }
  , Card { name: "Blade Gruts",                 isEnabled: true,  faction: Utgar   }
  , Card { name: "Blastatrons",                 isEnabled: true,  faction: Vydar   }
  , Card { name: "Braxas",                      isEnabled: true,  faction: Vydar   }
  , Card { name: "Brunak",                      isEnabled: true,  faction: Utgar   }
  , Card { name: "Chardris",                    isEnabled: true,  faction: Ullar   }
  , Card { name: "Charon",                      isEnabled: false, faction: Jacob   }
  , Card { name: "Charos",                      isEnabled: true,  faction: Ullar   }
  , Card { name: "Concan",                      isEnabled: true,  faction: Jandar  }
  , Card { name: "Crixus",                      isEnabled: true,  faction: Einar   }
  , Card { name: "Crucian",                     isEnabled: true,  faction: Choobar }
  , Card { name: "Deadeye Dan",                 isEnabled: true,  faction: Ullar   }
  , Card { name: "Deadwood",                    isEnabled: true,  faction: Choobar }
  , Card { name: "Deathstalkers",               isEnabled: true,  faction: Utgar   }
  , Card { name: "Deathwalker 7000",            isEnabled: true,  faction: Utgar   }
  , Card { name: "Deathwalker 8000",            isEnabled: true,  faction: Utgar   }
  , Card { name: "Deathwalker 9000",            isEnabled: true,  faction: Utgar   }
  , Card { name: "Dumutef Guard",               isEnabled: true,  faction: Utgar   }
  , Card { name: "Dund",                        isEnabled: true,  faction: Vydar   }
  , Card { name: "Elemental Golems",            isEnabled: true,  faction: Vydar   }
  , Card { name: "Elite Onyx Vipers",           isEnabled: true,  faction: Ullar   }
  , Card { name: "Emirroon",                    isEnabled: true,  faction: Ullar   }
  , Card { name: "Fenril",                      isEnabled: false, faction: Jacob   }
  , Card { name: "Festus",                      isEnabled: true,  faction: Jacob   }
  , Card { name: "Finn",                        isEnabled: true,  faction: Jandar  }
  , Card { name: "Firefly",                     isEnabled: true,  faction: Ullar   }
  , Card { name: "Frank Farmer",                isEnabled: false, faction: Vydar   }
  , Card { name: "Galf",                        isEnabled: false, faction: Choobar }
  , Card { name: "Gladiatrons",                 isEnabled: true,  faction: Vydar   }
  , Card { name: "Gorillinators",               isEnabled: true,  faction: Vydar   }
  , Card { name: "Grimnak",                     isEnabled: true,  faction: Utgar   }
  , Card { name: "Grok Riders",                 isEnabled: true,  faction: Utgar   }
  , Card { name: "Guilty McCreech",             isEnabled: true,  faction: Einar   }
  , Card { name: "Izumi Samurai",               isEnabled: true,  faction: Einar   }
  , Card { name: "James Murphy",                isEnabled: true,  faction: Vydar   }
  , Card { name: "Johnny 'Shotgun' Sullivan",   isEnabled: true,  faction: Jandar  }
  , Card { name: "Jotun",                       isEnabled: true,  faction: Ullar   }
  , Card { name: "Kato Katsuro",                isEnabled: true,  faction: Einar   }
  , Card { name: "Kelda",                       isEnabled: true,  faction: Jandar  }
  , Card { name: "Kenku Sneak",                 isEnabled: true,  faction: Choobar }
  , Card { name: "Khosumet",                    isEnabled: true,  faction: Utgar   }
  , Card { name: "Knights of Weston",           isEnabled: true,  faction: Jandar  }
  , Card { name: "Kozuke Samurai",              isEnabled: true,  faction: Einar   }
  , Card { name: "Krav Maga Agents",            isEnabled: true,  faction: Vydar   }
  , Card { name: "Krug",                        isEnabled: true,  faction: Utgar   }
  , Card { name: "Lilith",                      isEnabled: true,  faction: Choobar }
  , Card { name: "MacDirk Warriors",            isEnabled: true,  faction: Jandar  }
  , Card { name: "Maggotbrain Zombies",         isEnabled: false, faction: Utgar   }
  , Card { name: "Major Q10",                   isEnabled: true,  faction: Vydar   }
  , Card { name: "Major Q9",                    isEnabled: true,  faction: Vydar   }
  , Card { name: "Major X17",                   isEnabled: true,  faction: Vydar   }
  , Card { name: "Marcus Decimus",              isEnabled: true,  faction: Einar   }
  , Card { name: "Marrden Hounds",              isEnabled: true,  faction: Utgar   }
  , Card { name: "Marrden Nagrubs",             isEnabled: true,  faction: Utgar   }
  , Card { name: "Marro Drones",                isEnabled: true,  faction: Utgar   }
  , Card { name: "Marro Drudge",                isEnabled: true,  faction: Utgar   }
  , Card { name: "Marro Hive",                  isEnabled: false, faction: Utgar   }
  , Card { name: "Marro Stingers",              isEnabled: true,  faction: Utgar   }
  , Card { name: "Marro Warriors",              isEnabled: true,  faction: Utgar   }
  , Card { name: "Me-Burq-Sa",                  isEnabled: true,  faction: Utgar   }
  , Card { name: "Microcorp Agents",            isEnabled: true,  faction: Vydar   }
  , Card { name: "Mimring",                     isEnabled: true,  faction: Utgar   }
  , Card { name: "Minions of Utgar",            isEnabled: true,  faction: Utgar   }
  , Card { name: "Minutemen",                   isEnabled: true,  faction: Jandar  }
  , Card { name: "Moriko",                      isEnabled: true,  faction: Ullar   }
  , Card { name: "Morsbane",                    isEnabled: true,  faction: Ullar   }
  , Card { name: "Nakita Agents",               isEnabled: true,  faction: Vydar   }
  , Card { name: "Nathril",                     isEnabled: true,  faction: Jacob   }
  , Card { name: "Ne-Gok-Sa",                   isEnabled: true,  faction: Utgar   }
  , Card { name: "Nilfheim",                    isEnabled: true,  faction: Jandar  }
  , Card { name: "Ninjas of the Northern Wind", isEnabled: true,  faction: Einar   }
  , Card { name: "Nixy",                        isEnabled: true,  faction: Jacob   }
  , Card { name: "Obsidian Guards",             isEnabled: true,  faction: Utgar   }
  , Card { name: "Omnicron Snipers",            isEnabled: true,  faction: Jandar  }
  , Card { name: "Otonashi",                    isEnabled: true,  faction: Vydar   }
  , Card { name: "Parmenio",                    isEnabled: true,  faction: Einar   }
  , Card { name: "R-66Y",                       isEnabled: true,  faction: Ullar   }
  , Card { name: "Raelin, 1st Edition",         isEnabled: true,  faction: Jandar  }
  , Card { name: "Raelin, 2nd Edition",         isEnabled: true,  faction: Jandar  }
  , Card { name: "Rat Bastards",                isEnabled: true,  faction: Utgar   }
  , Card { name: "Red Coats",                   isEnabled: true,  faction: Einar   }
  , Card { name: "Retiarius",                   isEnabled: true,  faction: Einar   }
  , Card { name: "Roman Archers",               isEnabled: true,  faction: Einar   }
  , Card { name: "Roman Legionnaires",          isEnabled: true,  faction: Einar   }
  , Card { name: "Sacred Band",                 isEnabled: true,  faction: Einar   }
  , Card { name: "Saylind",                     isEnabled: true,  faction: Ullar   }
  , Card { name: "Sentinels of Jandar",         isEnabled: true,  faction: Jandar  }
  , Card { name: "Sgt. Drake, 1st Edition",     isEnabled: true,  faction: Jandar  }
  , Card { name: "Sgt. Drake, 2nd Edition",     isEnabled: true,  faction: Jandar  }
  , Card { name: "Shaolin Ascetic",             isEnabled: true,  faction: Ullar   }
  , Card { name: "Shaolin Monks",               isEnabled: true,  faction: Ullar   }
  , Card { name: "Shiori",                      isEnabled: true,  faction: Einar   }
  , Card { name: "Sir Denrick",                 isEnabled: true,  faction: Jandar  }
  , Card { name: "Sir Dupuis",                  isEnabled: true,  faction: Jandar  }
  , Card { name: "Slimeclaw",                   isEnabled: true,  faction: Vydar   }
  , Card { name: "Sonic Boom",                  isEnabled: false, faction: Choobar }
  , Card { name: "Sonlen",                      isEnabled: true,  faction: Ullar   }
  , Card { name: "Spartacus",                   isEnabled: true,  faction: Einar   }
  , Card { name: "Su-Bak-Na",                   isEnabled: true,  faction: Utgar   }
  , Card { name: "Sudema",                      isEnabled: true,  faction: Vydar   }
  , Card { name: "Swog Rider",                  isEnabled: true,  faction: Utgar   }
  , Card { name: "Syvarris",                    isEnabled: true,  faction: Ullar   }
  , Card { name: "Taelord",                     isEnabled: true,  faction: Utgar   }
  , Card { name: "Tagawa Samurai",              isEnabled: true,  faction: Einar   }
  , Card { name: "Tarn Viking Warriors",        isEnabled: true,  faction: Jandar  }
  , Card { name: "Tarsus",                      isEnabled: true,  faction: Ullar   }
  , Card { name: "Templar Cavalry",             isEnabled: false, faction: Jandar  }
  , Card { name: "Theracus",                    isEnabled: true,  faction: Ullar   }
  , Card { name: "Thorgrim",                    isEnabled: true,  faction: Jandar  }
  , Card { name: "Tor-Kul-Na",                  isEnabled: false, faction: Utgar   }
  , Card { name: "Tornak",                      isEnabled: true,  faction: Utgar   }
  , Card { name: "Ulginesh",                    isEnabled: true,  faction: Ullar   }
  , Card { name: "Valguard",                    isEnabled: true,  faction: Einar   }
  , Card { name: "Venoc Devourers",             isEnabled: true,  faction: Ullar   }
  , Card { name: "Venoc Vipers",                isEnabled: true,  faction: Ullar   }
  , Card { name: "Venoc Warlord",               isEnabled: true,  faction: Ullar   }
  , Card { name: "Venomancer",                  isEnabled: true,  faction: Ullar   }
  , Card { name: "Veshnir",                     isEnabled: true,  faction: Ullar   }
  , Card { name: "Warriors of Ashra",           isEnabled: true,  faction: Ullar   }
  , Card { name: "Wolves of Badru",             isEnabled: true,  faction: Utgar   }
  , Card { name: "Zettian Guards",              isEnabled: true,  faction: Utgar   }
  ]

module Cards(Card(..), cards, Faction(..)) where

import Prelude(Show)

data Faction = Choobar | Einar | Jacob | Jandar | Ullar | Utgar | Vydar

instance showFaction :: Show Faction where
  show Choobar = "choobar"
  show Einar   = "einar"
  show Jacob   = "jacob"
  show Jandar  = "jandar"
  show Ullar   = "ullar"
  show Utgar   = "utgar"
  show Vydar   = "vydar"

data Card = Card
  { name      :: String
  , isEnabled :: Boolean
  , faction   :: Faction
  }

cards :: Array Card
cards =
  [ Card { name: "Agent Carr",                  isEnabled: true,  faction: Vydar   }
  , Card { name: "Airborne Elite",              isEnabled: true,  faction: Jandar  }
  , Card { name: "Alastair MacDirk",            isEnabled: true,  faction: Jandar  }
  , Card { name: "Anubian Wolves",              isEnabled: true,  faction: Utgar   }
  , Card { name: "Aphotia",                     isEnabled: true,  faction: Choobar }
  , Card { name: "Arkmer",                      isEnabled: true,  faction: Ullar   }
  , Card { name: "Arrow Gruts",                 isEnabled: true,  faction: Utgar   }
  , Card { name: "Aubrien Archers",             isEnabled: true,  faction: Ullar   }
  , Card { name: "Basilisk",                    isEnabled: false, faction: Choobar }
  , Card { name: "Blade Gruts",                 isEnabled: true,  faction: Utgar   }
  , Card { name: "Blastatrons",                 isEnabled: true,  faction: Vydar   }
  , Card { name: "Braxas",                      isEnabled: true,  faction: Vydar   }
  , Card { name: "Brunak",                      isEnabled: true,  faction: Utgar   }
  , Card { name: "Chardris",                    isEnabled: true,  faction: Ullar   }
  , Card { name: "Charos",                      isEnabled: true,  faction: Ullar   }
  , Card { name: "Concan",                      isEnabled: true,  faction: Jandar  }
  , Card { name: "Crixus",                      isEnabled: true,  faction: Einar   }
  , Card { name: "Crucian",                     isEnabled: true,  faction: Choobar }
  , Card { name: "Deadeye Dan",                 isEnabled: true,  faction: Ullar   }
  , Card { name: "Deadwood",                    isEnabled: true,  faction: Choobar }
  , Card { name: "Deathstalkers",               isEnabled: true,  faction: Utgar   }
  , Card { name: "Deathwalker 7000",            isEnabled: true,  faction: Utgar   }
  , Card { name: "Deathwalker 8000",            isEnabled: true,  faction: Utgar   }
  , Card { name: "Deathwalker 9000",            isEnabled: true,  faction: Utgar   }
  , Card { name: "Dumutef Guard",               isEnabled: true,  faction: Utgar   }
  , Card { name: "Dund",                        isEnabled: true,  faction: Vydar   }
  , Card { name: "Elemental Golems",            isEnabled: true,  faction: Vydar   }
  , Card { name: "Elite Onyx Vipers",           isEnabled: true,  faction: Ullar   }
  , Card { name: "Emirroon",                    isEnabled: true,  faction: Ullar   }
  , Card { name: "Festus",                      isEnabled: true,  faction: Jacob   }
  , Card { name: "Finn",                        isEnabled: true,  faction: Jandar  }
  , Card { name: "Firefly",                     isEnabled: true,  faction: Ullar   }
  , Card { name: "Gladiatrons",                 isEnabled: true,  faction: Vydar   }
  , Card { name: "Gorillinators",               isEnabled: true,  faction: Vydar   }
  , Card { name: "Grimnak",                     isEnabled: true,  faction: Utgar   }
  , Card { name: "Grok Riders",                 isEnabled: true,  faction: Utgar   }
  , Card { name: "Guilty McCreech",             isEnabled: true,  faction: Einar   }
  , Card { name: "Izumi Samurai",               isEnabled: true,  faction: Einar   }
  , Card { name: "James Murphy",                isEnabled: true,  faction: Vydar   }
  , Card { name: "Johnny 'Shotgun' Sullivan",   isEnabled: true,  faction: Jandar  }
  , Card { name: "Jotun",                       isEnabled: true,  faction: Ullar   }
  , Card { name: "Kato Katsuro",                isEnabled: true,  faction: Einar   }
  , Card { name: "Kelda",                       isEnabled: true,  faction: Jandar  }
  , Card { name: "Kenku Sneak",                 isEnabled: true,  faction: Choobar }
  , Card { name: "Khosumet",                    isEnabled: true,  faction: Utgar   }
  , Card { name: "Knights of Weston",           isEnabled: true,  faction: Jandar  }
  , Card { name: "Kozuke Samurai",              isEnabled: true,  faction: Einar   }
  , Card { name: "Krav Maga Agents",            isEnabled: true,  faction: Vydar   }
  , Card { name: "Krug",                        isEnabled: true,  faction: Utgar   }
  , Card { name: "MacDirk Warriors",            isEnabled: true,  faction: Jandar  }
  , Card { name: "Major Q10",                   isEnabled: true,  faction: Vydar   }
  , Card { name: "Major Q9",                    isEnabled: true,  faction: Vydar   }
  , Card { name: "Major X17",                   isEnabled: true,  faction: Vydar   }
  , Card { name: "Marcus Decimus",              isEnabled: true,  faction: Einar   }
  , Card { name: "Marrden Hounds",              isEnabled: true,  faction: Utgar   }
  , Card { name: "Marrden Nagrubs",             isEnabled: true,  faction: Utgar   }
  , Card { name: "Marro Drones",                isEnabled: true,  faction: Utgar   }
  , Card { name: "Marro Drudge",                isEnabled: true,  faction: Utgar   }
  , Card { name: "Marro Hive",                  isEnabled: false, faction: Utgar   }
  , Card { name: "Marro Stingers",              isEnabled: true,  faction: Utgar   }
  , Card { name: "Marro Warriors",              isEnabled: true,  faction: Utgar   }
  , Card { name: "Me-Burq-Sa",                  isEnabled: true,  faction: Utgar   }
  , Card { name: "Microcorp Agents",            isEnabled: true,  faction: Vydar   }
  , Card { name: "Mimring",                     isEnabled: true,  faction: Utgar   }
  , Card { name: "Minions of Utgar",            isEnabled: true,  faction: Utgar   }
  , Card { name: "Minutemen",                   isEnabled: true,  faction: Jandar  }
  , Card { name: "Moriko",                      isEnabled: true,  faction: Ullar   }
  , Card { name: "Morsbane",                    isEnabled: true,  faction: Ullar   }
  , Card { name: "Nakita Agents",               isEnabled: true,  faction: Vydar   }
  , Card { name: "Nathril",                     isEnabled: true,  faction: Jacob   }
  , Card { name: "Ne-Gok-Sa",                   isEnabled: true,  faction: Utgar   }
  , Card { name: "Nilfheim",                    isEnabled: true,  faction: Jandar  }
  , Card { name: "Ninjas of the Northern Wind", isEnabled: true,  faction: Einar   }
  , Card { name: "Nixy",                        isEnabled: true,  faction: Jacob   }
  , Card { name: "Obsidian Guards",             isEnabled: true,  faction: Utgar   }
  , Card { name: "Omnicron Snipers",            isEnabled: true,  faction: Jandar  }
  , Card { name: "Otonashi",                    isEnabled: true,  faction: Vydar   }
  , Card { name: "Parmenio",                    isEnabled: true,  faction: Einar   }
  , Card { name: "Raelin, 1st Edition",         isEnabled: true,  faction: Jandar  }
  , Card { name: "Raelin, 2nd Edition",         isEnabled: true,  faction: Jandar  }
  , Card { name: "Rat Bastards",                isEnabled: true,  faction: Utgar   }
  , Card { name: "Red Coats",                   isEnabled: true,  faction: Einar   }
  , Card { name: "Retiarius",                   isEnabled: true,  faction: Einar   }
  , Card { name: "Roman Archers",               isEnabled: true,  faction: Einar   }
  , Card { name: "Roman Legionnaires",          isEnabled: true,  faction: Einar   }
  , Card { name: "Sacred Band",                 isEnabled: true,  faction: Einar   }
  , Card { name: "Saylind",                     isEnabled: true,  faction: Ullar   }
  , Card { name: "Sentinels of Jandar",         isEnabled: true,  faction: Jandar  }
  , Card { name: "Sgt. Drake, 1st Edition",     isEnabled: true,  faction: Jandar  }
  , Card { name: "Sgt. Drake, 2nd Edition",     isEnabled: true,  faction: Jandar  }
  , Card { name: "Shaolin Monks",               isEnabled: true,  faction: Ullar   }
  , Card { name: "Shiori",                      isEnabled: true,  faction: Einar   }
  , Card { name: "Sir Denrick",                 isEnabled: true,  faction: Jandar  }
  , Card { name: "Sir Dupuis",                  isEnabled: true,  faction: Jandar  }
  , Card { name: "Sonic Boom",                  isEnabled: false, faction: Choobar }
  , Card { name: "Sonlen",                      isEnabled: true,  faction: Ullar   }
  , Card { name: "Spartacus",                   isEnabled: true,  faction: Einar   }
  , Card { name: "Su-Bak-Na",                   isEnabled: true,  faction: Utgar   }
  , Card { name: "Sudema",                      isEnabled: true,  faction: Vydar   }
  , Card { name: "Swog Rider",                  isEnabled: true,  faction: Utgar   }
  , Card { name: "Syvarris",                    isEnabled: true,  faction: Ullar   }
  , Card { name: "Taelord",                     isEnabled: true,  faction: Utgar   }
  , Card { name: "Tagawa Samurai",              isEnabled: true,  faction: Einar   }
  , Card { name: "Tarn Viking Warriors",        isEnabled: true,  faction: Jandar  }
  , Card { name: "Templar Cavalry",             isEnabled: false, faction: Jandar  }
  , Card { name: "Theracus",                    isEnabled: true,  faction: Ullar   }
  , Card { name: "Thorgrim",                    isEnabled: true,  faction: Jandar  }
  , Card { name: "Tor-Kul-Na",                  isEnabled: false, faction: Utgar   }
  , Card { name: "Tornak",                      isEnabled: true,  faction: Utgar   }
  , Card { name: "Ulginesh",                    isEnabled: true,  faction: Ullar   }
  , Card { name: "Valguard",                    isEnabled: true,  faction: Einar   }
  , Card { name: "Venoc Devourers",             isEnabled: true,  faction: Ullar   }
  , Card { name: "Venoc Vipers",                isEnabled: true,  faction: Ullar   }
  , Card { name: "Venoc Warlord",               isEnabled: true,  faction: Ullar   }
  , Card { name: "Veshnir",                     isEnabled: true,  faction: Ullar   }
  , Card { name: "Warriors of Ashra",           isEnabled: true,  faction: Ullar   }
  , Card { name: "Wolves of Badru",             isEnabled: true,  faction: Utgar   }
  , Card { name: "Zettian Guards",              isEnabled: true,  faction: Utgar   }
  ]


Update xpath in tests for columns markup change

module Test.SlamData.Feature.Interactions where

import SlamData.Prelude

import Data.Argonaut (encodeJson)
import Data.Array as Arr
import Data.Map as Map
import Data.String as S
import Data.String.Regex as RX
import Data.String.Regex.Flags as RXF
import Data.StrMap as SM

import Global (encodeURIComponent)

import Selenium.Monad (get, refresh, getCurrentUrl, tryRepeatedlyTo)

import Test.Feature as Feature
import Test.SlamData.Feature.Monad (SlamFeature, getConfig, waitTime)
import Test.SlamData.Feature.XPaths as XPaths
import Test.Utils (appendToCwd)

import XPath as XPath

import Utils (prettyJson)
import Utils.Array (enumerate)

followingLastPreviousCardGripper :: String -> String
followingLastPreviousCardGripper = XPath.following lastPreviousCardGripperXPath
  where
  lastPreviousCardGripperXPath = XPath.last $ XPath.anywhere XPaths.previousCardGripper

launchSlamData ∷ SlamFeature Unit
launchSlamData = get ∘ _.slamdataUrl =<< getConfig

accessWorkspaceWithModifiedURL ∷ (String → String) → SlamFeature Unit
accessWorkspaceWithModifiedURL modifier =
  getCurrentUrl >>= modifier >>> get

mountTestDatabase ∷ SlamFeature Unit
mountTestDatabase = do
  -- If we don't wait for "Configure database" to appear in the toolbar the
  -- wrong item will be clicked for "Mount database" due to a timing issue. Yay.
  Feature.expectPresented (XPath.anywhere XPaths.accessConfigureMount)
  Feature.click (XPath.anywhere XPaths.accessMountDatabase)
  Feature.provideFieldValue (XPath.anywhere XPaths.mountName) "test-mount"
  Feature.selectFromDropdown (XPath.anywhere XPaths.mountType) "MongoDB"
  Feature.click (XPath.anywhere $ XPaths.mountName)
  Feature.provideFieldValue (XPath.index (XPath.anywhere XPaths.mountPort) 1) "63174"
  Feature.provideFieldValue (XPath.index (XPath.anywhere XPaths.mountHost) 1) "localhost"
  Feature.provideFieldValue (XPath.anywhere XPaths.mountDatabase) "testDb"
  Feature.click (XPath.anywhere XPaths.mountButton)

skipGuide ∷ SlamFeature Unit
skipGuide =
  Feature.click $ XPath.anywhere $ XPath.anyWithExactText "Skip"

dismissHint ∷ SlamFeature Unit
dismissHint =
  Feature.click $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Dismiss"

accessFile ∷ String → SlamFeature Unit
accessFile =
  Feature.click ∘ XPath.anywhere ∘ XPaths.accessFile

exploreFile ∷ String → SlamFeature Unit
exploreFile name = do
  Feature.provideFieldValue (XPath.anywhere $ XPath.anyWithExactAriaLabel "New workspace name") name
  Feature.click $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Explore file"

accessBreadcrumb ∷ String → SlamFeature Unit
accessBreadcrumb = Feature.click ∘ XPath.anywhere ∘ XPaths.accessBreadcrumb

browseRootFolder ∷ SlamFeature Unit
browseRootFolder = do
  Feature.click $ XPath.anywhere XPaths.headerGripper
  Feature.click $ XPath.index (XPath.anywhere XPaths.browseRootFolder) 1

browseTestFolder ∷ SlamFeature Unit
browseTestFolder =
  browseRootFolder *> accessFile "test-mount" *> accessFile "testDb"

createWorkspace ∷ SlamFeature Unit
createWorkspace = Feature.click $ XPath.anywhere XPaths.createWorkspace

nameDeck ∷ String → SlamFeature Unit
nameDeck name = do
  flipDeck
  Feature.click $ XPath.anywhere XPaths.renameDeck
  Feature.provideFieldValue (XPath.anywhere $ XPath.nodeWithExactAriaLabel "input" "Deck name") name
  Feature.click $ XPath.anywhere $ XPath.anyWithExactText "Save"

deleteFile ∷ String → SlamFeature Unit
deleteFile name =
  Feature.click (XPath.anywhere $ XPaths.selectFile name)
    *> Feature.click (XPath.anywhere $ XPaths.removeFile name)
    *> Feature.expectNotPresented (XPath.anywhere $ XPaths.selectFile name)

shareFile ∷ String → SlamFeature Unit
shareFile name = do
  Feature.click (XPath.anywhere $ XPaths.selectFile name)
  tryRepeatedlyTo $ clickShareFile <|> clickShareWorkspace
  where
  clickShareFile =
    Feature.clickNotRepeatedly (XPath.anywhere $ XPaths.shareFile name)
  clickShareWorkspace =
    Feature.clickNotRepeatedly (XPath.anywhere $ XPaths.shareFile $ name <> ".slam")

renameFile ∷ String → String → SlamFeature Unit
renameFile oldName newName = do
  selectFile oldName
  clickMove oldName
  Feature.provideFieldValueWithProperties
    (Map.singleton "value" $ Just oldName)
    (XPath.anywhere "input")
    newName
  Feature.click $ XPath.anywhere XPaths.renameButton
  where
  oldWorkspaceName = oldName <> ".slam"

moveFile ∷ String → String → String → SlamFeature Unit
moveFile fileName oldLocation newLocation = do
  selectFile fileName
  clickMove fileName
  Feature.click $ XPath.anywhere XPaths.selectADestinationFolder
  Feature.click $ XPath.anywhere $ XPath.anyWithExactText newLocation
  Feature.click $ XPath.anywhere XPaths.renameButton

clickMove ∷ String → SlamFeature Unit
clickMove name =
  tryRepeatedlyTo $ clickMoveFile <|> clickMoveWorkspace
  where
  clickMoveFile =
    Feature.clickNotRepeatedly $ XPath.anywhere $ XPaths.moveFile name
  clickMoveWorkspace =
    Feature.clickNotRepeatedly $ XPath.anywhere $ XPaths.moveFile $ name <> ".slam"

uploadFile ∷ String → SlamFeature Unit
uploadFile =
  Feature.provideFileInputValue (XPath.anywhere $ XPaths.uploadFile)
    <=< appendToCwd

provideFileSearchString ∷ String → SlamFeature Unit
provideFileSearchString value =
  Feature.provideFieldValue (XPath.anywhere XPaths.fileSearchInput) value

selectFile ∷ String → SlamFeature Unit
selectFile name =
  tryRepeatedlyTo (selectFile' <|> selectWorkspace)
  where
  selectFile' =
    Feature.clickNotRepeatedly $ XPath.anywhere $ XPaths.selectFile name
  selectWorkspace =
    Feature.clickNotRepeatedly $ XPath.anywhere $ XPaths.selectFile $ name <> ".slam"

createWorkspaceInTestFolder ∷ String → SlamFeature Unit
createWorkspaceInTestFolder name = do
  browseTestFolder
  createWorkspace
  nameDeck name
  browseTestFolder
  renameFile "Untitled Workspace" name
  accessFile $ name <> ".slam"

createFolder ∷ SlamFeature Unit
createFolder = Feature.click $ XPath.anywhere XPaths.createFolder

deleteFileInTestFolder ∷ String → SlamFeature Unit
deleteFileInTestFolder name = browseTestFolder *> deleteFile name

reopenCurrentWorkspace ∷ SlamFeature Unit
reopenCurrentWorkspace = waitTime 2000 *> refresh

expandNewCardMenu ∷ SlamFeature Unit
expandNewCardMenu = Feature.click (XPath.anywhere XPaths.insertCard)

accessNextCardInLastDeck ∷ SlamFeature Unit
accessNextCardInLastDeck =
  Feature.dragAndDrop
    (XPath.last $ XPath.anywhere $ XPaths.enabledNextCardGripper)
    (XPath.last $ XPath.anywhere $ XPaths.previousCardGripper)

accessPreviousCardInLastDeck ∷ SlamFeature Unit
accessPreviousCardInLastDeck =
  Feature.dragAndDrop
    (XPath.last $ XPath.anywhere $ XPaths.enabledPreviousCardGripper)
    (XPath.last $ XPath.anywhere $ XPaths.nextCardGripper)

insertSearchCardInLastDeck ∷ SlamFeature Unit
insertSearchCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertSearchCard

insertQueryCardInLastDeck ∷ SlamFeature Unit
insertQueryCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertQueryCard

insertMdCardInLastDeck ∷ SlamFeature Unit
insertMdCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertMdCard

insertOpenCardInLastDeck ∷ SlamFeature Unit
insertOpenCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertOpenCard

insertChartOptionsCardInLastDeck ∷ SlamFeature Unit
insertChartOptionsCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertChartOptionsCard

insertDisplayMarkdownCardInLastDeck ∷ SlamFeature Unit
insertDisplayMarkdownCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertDisplayMarkdownCard

insertTableCardInLastDeck ∷ SlamFeature Unit
insertTableCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertTableCard

insertChartCardInLastDeck ∷ SlamFeature Unit
insertChartCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertChartCard

insertCacheCardInLastDeck ∷ SlamFeature Unit
insertCacheCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertCacheCard

insertVariablesCardInLastDeck ∷ SlamFeature Unit
insertVariablesCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertVariablesCard

insertTroubleshootCardInLastDeck ∷ SlamFeature Unit
insertTroubleshootCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertTroubleshootCard

selectBuildChart ∷ SlamFeature Unit
selectBuildChart =
  Feature.click $ followingLastPreviousCardGripper XPaths.selectBuildChart

insertPivotCard ∷ SlamFeature Unit
insertPivotCard =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertPivotCard

insertBuildBarChartCard ∷ SlamFeature Unit
insertBuildBarChartCard =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertBuildBarChartCard

addColumn ∷ String → SlamFeature Unit
addColumn str = do
  Feature.click $ XPath.last $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Add column"
  Feature.click $ XPath.last $ XPath.anywhere $ XPath.anyWithExactAriaLabel $ "Select " ⊕ str
  Feature.click $ XPath.last $ XPath.anywhere $ XPath.anyWithExactText "Confirm"

selectInMillerColumns ∷ Array String → SlamFeature Unit
selectInMillerColumns ps = do
  for_ (enumerate $ Arr.filter (\s → S.length s > 0) ps) \(ix × path) →
    Feature.click $ resourceXPath (ix + one) path
  where
  ariaLabel ∷ String → String
  ariaLabel rPath = "Select " ⊕ rPath

  resourceXPath ∷ Int → String → String
  resourceXPath ix rPath =
    XPath.last
      $ XPath.anywhere
      $ (XPath.nodeAtPosition ix $ XPath.anyWithExactAriaLabel "Column")
      ⊕ "/ul/"
      ⊕ (XPath.anyWithExactAriaLabel $ ariaLabel rPath)

selectFileForLastOpenCard ∷ String → SlamFeature Unit
selectFileForLastOpenCard s =
  selectInMillerColumns $ S.split (S.Pattern "/") s

selectInChartBuilder ∷ Array String → SlamFeature Unit
selectInChartBuilder ps = do
  selectInMillerColumns ps
  Feature.click $ XPath.last $ XPath.anywhere $ XPath.anyWithExactText "Confirm"

provideSearchStringInLastSearchCard ∷ String → SlamFeature Unit
provideSearchStringInLastSearchCard =
  Feature.provideFieldValue $ XPath.last $ XPath.anywhere XPaths.searchStringInput

provideMdInLastMdCard ∷ String → SlamFeature Unit
provideMdInLastMdCard =
  Feature.provideFieldValue
    $ XPath.last $ XPath.anywhere XPaths.aceEditor

provideQueryInLastQueryCard ∷ String → SlamFeature Unit
provideQueryInLastQueryCard =
  Feature.provideFieldValue
    $ XPath.last $ XPath.anywhere XPaths.aceEditor

provideSaveDestinationInLastCacheCard ∷ String → SlamFeature Unit
provideSaveDestinationInLastCacheCard =
  Feature.provideFieldValue (XPath.last $ XPath.anywhere XPaths.saveDestinationInput)

doSaveInLastCacheCard ∷ SlamFeature Unit
doSaveInLastCacheCard =
  Feature.click (XPath.last $ XPath.anywhere XPaths.saveSubmitButton)

provideFieldValueInLastDeck ∷ String → String → SlamFeature Unit
provideFieldValueInLastDeck labelText =
  Feature.provideFieldValue
    $ followingLastPreviousCardGripper
    $ "input" `XPath.withLabelWithExactText` labelText

checkFieldInLastDeck ∷ String → SlamFeature Unit
checkFieldInLastDeck labelText =
  Feature.check
    $ followingLastPreviousCardGripper
    $ "input" `XPath.withLabelWithExactText` labelText

uncheckFieldInLastDeck ∷ String → SlamFeature Unit
uncheckFieldInLastDeck labelText =
  Feature.uncheck
    $ followingLastPreviousCardGripper
    $ "input" `XPath.withLabelWithExactText` labelText

pushRadioButtonInLastDeck ∷ String → SlamFeature Unit
pushRadioButtonInLastDeck labelText =
  Feature.pushRadioButton
    $ followingLastPreviousCardGripper
    $ "input" `XPath.withLabelWithExactText` labelText

selectFromDropdownInLastDeck ∷ String → String → SlamFeature Unit
selectFromDropdownInLastDeck labelText =
  Feature.selectFromDropdown
    $ followingLastPreviousCardGripper
    $ "select" `XPath.withLabelWithExactText` labelText

accessSharingUrl ∷ SlamFeature Unit
accessSharingUrl = Feature.accessUrlFromFieldValue $ XPath.anywhere XPaths.sharingUrl

accessPublishingUrl ∷ SlamFeature Unit
accessPublishingUrl = Feature.accessUrlFromFieldValue $ XPath.anywhere XPaths.publishingUrl

downloadFileAsCSV ∷ String → SlamFeature Unit
downloadFileAsCSV fileName = do
  selectFile fileName
  Feature.click $ XPath.anywhere $ XPaths.downloadFile fileName
  Feature.click $ XPath.anywhere $ XPaths.downloadButton
  Feature.click $ XPath.anywhere $ XPaths.cancelButton

downloadFileAsJSON ∷ String → SlamFeature Unit
downloadFileAsJSON fileName = do
  selectFile fileName
  Feature.click $ XPath.anywhere $ XPaths.downloadFile fileName
  Feature.click $ XPath.anywhere $ XPath.anyWithText "JSON"
  Feature.click $ XPath.anywhere $ XPaths.downloadButton
  Feature.click $ XPath.anywhere $ XPaths.cancelButton

showHiddenFiles ∷ SlamFeature Unit
showHiddenFiles =
  Feature.click $ XPath.anywhere $ XPaths.showHiddenFiles

hideHiddenFiles ∷ SlamFeature Unit
hideHiddenFiles =
  Feature.click $ XPath.anywhere $ XPaths.hideHiddenFiles

type ApiVarName = String
type ApiVarType = String
type ApiVarValue = String

provideApiVariableBindingsForVariablesCard
  ∷ ApiVarName
  → ApiVarType
  → ApiVarValue
  → SlamFeature Unit
provideApiVariableBindingsForVariablesCard name ty val = do
  provideValueForVariablesCard
  provideTypeForVariablesCard
  provideDefaultValueForVariablesCard
  where
  provideValueForVariablesCard ∷ SlamFeature Unit
  provideValueForVariablesCard = do
    Feature.provideFieldValue
      (XPath.first $ XPath.anywhere $ XPaths.variablesCardVariableName)
      name
    Feature.pressEnter
  provideTypeForVariablesCard ∷ SlamFeature Unit
  provideTypeForVariablesCard = do
    Feature.selectFromDropdown
      (XPath.first $ XPath.anywhere $ XPaths.variablesCardVariableTypeFor name)
      ty
    Feature.pressEnter

  provideDefaultValueForVariablesCard ∷ SlamFeature Unit
  provideDefaultValueForVariablesCard = do
    Feature.provideFieldValue
      (XPath.first $ XPath.anywhere $ XPaths.variablesCardDefaultValueFor name)
      val
    Feature.pressEnter

activateCategoryForChartBuilder ∷ SlamFeature Unit
activateCategoryForChartBuilder =
  Feature.click $ XPath.last $ XPath.anywhere $ XPaths.chartCategorySelector

activateStackForChartBuilder ∷ SlamFeature Unit
activateStackForChartBuilder =
  Feature.click $ XPath.last $ XPath.anywhere $ XPaths.chartStackSelector

flipDeck ∷ SlamFeature Unit
flipDeck =
  Feature.click $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Flip deck"

trashActiveOrLastCard ∷ SlamFeature Unit
trashActiveOrLastCard =
  Feature.click $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Delete card"

shareDeck ∷ SlamFeature Unit
shareDeck =
  Feature.click $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Share deck"

publishDeck ∷ SlamFeature Unit
publishDeck =
  Feature.click $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Publish deck"

filterDeckAndCardActions ∷ String → SlamFeature Unit
filterDeckAndCardActions =
  Feature.provideFieldValue (XPath.anywhere $ XPath.anyWithExactAriaLabel "Filter deck and card actions")

filterNextActions ∷ String → SlamFeature Unit
filterNextActions =
  Feature.provideFieldValue (XPath.anywhere $ XPath.anyWithExactAriaLabel "Filter next actions")

confirmDeckAction ∷ SlamFeature Unit
confirmDeckAction =
  Feature.click $ XPath.anywhere $ XPath.anyWithExactText "Confirm"

runQuery ∷ SlamFeature Unit
runQuery =
  Feature.click $ XPath.last $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Run query"

setVarMapForCurrentDeck ∷ SM.StrMap String → SlamFeature Unit
setVarMapForCurrentDeck vm = accessWorkspaceWithModifiedURL \urlStr →
  let
    deckIdRgx = unsafePartial fromRight $ RX.regex "\\.slam\\/([^\\/]+)" RXF.noFlags
    mbDeckId = join $ RX.match deckIdRgx urlStr >>= flip Arr.index 1
  in case mbDeckId of
    Nothing → urlStr
    Just did →
      let
        varsValue =
          encodeURIComponent
          $ prettyJson
          $ encodeJson
          $ SM.singleton did vm
      in
       urlStr ⊕ "/?vars=" ⊕ varsValue

module Test.SlamData.Feature.Interactions where

import SlamData.Prelude

import Data.Argonaut (encodeJson)
import Data.Array as Arr
import Data.Map as Map
import Data.String as S
import Data.String.Regex as RX
import Data.String.Regex.Flags as RXF
import Data.StrMap as SM

import Global (encodeURIComponent)

import Selenium.Monad (get, refresh, getCurrentUrl, tryRepeatedlyTo)

import Test.Feature as Feature
import Test.SlamData.Feature.Monad (SlamFeature, getConfig, waitTime)
import Test.SlamData.Feature.XPaths as XPaths
import Test.Utils (appendToCwd)

import XPath as XPath

import Utils (prettyJson)
import Utils.Array (enumerate)

followingLastPreviousCardGripper :: String -> String
followingLastPreviousCardGripper = XPath.following lastPreviousCardGripperXPath
  where
  lastPreviousCardGripperXPath = XPath.last $ XPath.anywhere XPaths.previousCardGripper

launchSlamData ∷ SlamFeature Unit
launchSlamData = get ∘ _.slamdataUrl =<< getConfig

accessWorkspaceWithModifiedURL ∷ (String → String) → SlamFeature Unit
accessWorkspaceWithModifiedURL modifier =
  getCurrentUrl >>= modifier >>> get

mountTestDatabase ∷ SlamFeature Unit
mountTestDatabase = do
  -- If we don't wait for "Configure database" to appear in the toolbar the
  -- wrong item will be clicked for "Mount database" due to a timing issue. Yay.
  Feature.expectPresented (XPath.anywhere XPaths.accessConfigureMount)
  Feature.click (XPath.anywhere XPaths.accessMountDatabase)
  Feature.provideFieldValue (XPath.anywhere XPaths.mountName) "test-mount"
  Feature.selectFromDropdown (XPath.anywhere XPaths.mountType) "MongoDB"
  Feature.click (XPath.anywhere $ XPaths.mountName)
  Feature.provideFieldValue (XPath.index (XPath.anywhere XPaths.mountPort) 1) "63174"
  Feature.provideFieldValue (XPath.index (XPath.anywhere XPaths.mountHost) 1) "localhost"
  Feature.provideFieldValue (XPath.anywhere XPaths.mountDatabase) "testDb"
  Feature.click (XPath.anywhere XPaths.mountButton)

skipGuide ∷ SlamFeature Unit
skipGuide =
  Feature.click $ XPath.anywhere $ XPath.anyWithExactText "Skip"

dismissHint ∷ SlamFeature Unit
dismissHint =
  Feature.click $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Dismiss"

accessFile ∷ String → SlamFeature Unit
accessFile =
  Feature.click ∘ XPath.anywhere ∘ XPaths.accessFile

exploreFile ∷ String → SlamFeature Unit
exploreFile name = do
  Feature.provideFieldValue (XPath.anywhere $ XPath.anyWithExactAriaLabel "New workspace name") name
  Feature.click $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Explore file"

accessBreadcrumb ∷ String → SlamFeature Unit
accessBreadcrumb = Feature.click ∘ XPath.anywhere ∘ XPaths.accessBreadcrumb

browseRootFolder ∷ SlamFeature Unit
browseRootFolder = do
  Feature.click $ XPath.anywhere XPaths.headerGripper
  Feature.click $ XPath.index (XPath.anywhere XPaths.browseRootFolder) 1

browseTestFolder ∷ SlamFeature Unit
browseTestFolder =
  browseRootFolder *> accessFile "test-mount" *> accessFile "testDb"

createWorkspace ∷ SlamFeature Unit
createWorkspace = Feature.click $ XPath.anywhere XPaths.createWorkspace

nameDeck ∷ String → SlamFeature Unit
nameDeck name = do
  flipDeck
  Feature.click $ XPath.anywhere XPaths.renameDeck
  Feature.provideFieldValue (XPath.anywhere $ XPath.nodeWithExactAriaLabel "input" "Deck name") name
  Feature.click $ XPath.anywhere $ XPath.anyWithExactText "Save"

deleteFile ∷ String → SlamFeature Unit
deleteFile name =
  Feature.click (XPath.anywhere $ XPaths.selectFile name)
    *> Feature.click (XPath.anywhere $ XPaths.removeFile name)
    *> Feature.expectNotPresented (XPath.anywhere $ XPaths.selectFile name)

shareFile ∷ String → SlamFeature Unit
shareFile name = do
  Feature.click (XPath.anywhere $ XPaths.selectFile name)
  tryRepeatedlyTo $ clickShareFile <|> clickShareWorkspace
  where
  clickShareFile =
    Feature.clickNotRepeatedly (XPath.anywhere $ XPaths.shareFile name)
  clickShareWorkspace =
    Feature.clickNotRepeatedly (XPath.anywhere $ XPaths.shareFile $ name <> ".slam")

renameFile ∷ String → String → SlamFeature Unit
renameFile oldName newName = do
  selectFile oldName
  clickMove oldName
  Feature.provideFieldValueWithProperties
    (Map.singleton "value" $ Just oldName)
    (XPath.anywhere "input")
    newName
  Feature.click $ XPath.anywhere XPaths.renameButton
  where
  oldWorkspaceName = oldName <> ".slam"

moveFile ∷ String → String → String → SlamFeature Unit
moveFile fileName oldLocation newLocation = do
  selectFile fileName
  clickMove fileName
  Feature.click $ XPath.anywhere XPaths.selectADestinationFolder
  Feature.click $ XPath.anywhere $ XPath.anyWithExactText newLocation
  Feature.click $ XPath.anywhere XPaths.renameButton

clickMove ∷ String → SlamFeature Unit
clickMove name =
  tryRepeatedlyTo $ clickMoveFile <|> clickMoveWorkspace
  where
  clickMoveFile =
    Feature.clickNotRepeatedly $ XPath.anywhere $ XPaths.moveFile name
  clickMoveWorkspace =
    Feature.clickNotRepeatedly $ XPath.anywhere $ XPaths.moveFile $ name <> ".slam"

uploadFile ∷ String → SlamFeature Unit
uploadFile =
  Feature.provideFileInputValue (XPath.anywhere $ XPaths.uploadFile)
    <=< appendToCwd

provideFileSearchString ∷ String → SlamFeature Unit
provideFileSearchString value =
  Feature.provideFieldValue (XPath.anywhere XPaths.fileSearchInput) value

selectFile ∷ String → SlamFeature Unit
selectFile name =
  tryRepeatedlyTo (selectFile' <|> selectWorkspace)
  where
  selectFile' =
    Feature.clickNotRepeatedly $ XPath.anywhere $ XPaths.selectFile name
  selectWorkspace =
    Feature.clickNotRepeatedly $ XPath.anywhere $ XPaths.selectFile $ name <> ".slam"

createWorkspaceInTestFolder ∷ String → SlamFeature Unit
createWorkspaceInTestFolder name = do
  browseTestFolder
  createWorkspace
  nameDeck name
  browseTestFolder
  renameFile "Untitled Workspace" name
  accessFile $ name <> ".slam"

createFolder ∷ SlamFeature Unit
createFolder = Feature.click $ XPath.anywhere XPaths.createFolder

deleteFileInTestFolder ∷ String → SlamFeature Unit
deleteFileInTestFolder name = browseTestFolder *> deleteFile name

reopenCurrentWorkspace ∷ SlamFeature Unit
reopenCurrentWorkspace = waitTime 2000 *> refresh

expandNewCardMenu ∷ SlamFeature Unit
expandNewCardMenu = Feature.click (XPath.anywhere XPaths.insertCard)

accessNextCardInLastDeck ∷ SlamFeature Unit
accessNextCardInLastDeck =
  Feature.dragAndDrop
    (XPath.last $ XPath.anywhere $ XPaths.enabledNextCardGripper)
    (XPath.last $ XPath.anywhere $ XPaths.previousCardGripper)

accessPreviousCardInLastDeck ∷ SlamFeature Unit
accessPreviousCardInLastDeck =
  Feature.dragAndDrop
    (XPath.last $ XPath.anywhere $ XPaths.enabledPreviousCardGripper)
    (XPath.last $ XPath.anywhere $ XPaths.nextCardGripper)

insertSearchCardInLastDeck ∷ SlamFeature Unit
insertSearchCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertSearchCard

insertQueryCardInLastDeck ∷ SlamFeature Unit
insertQueryCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertQueryCard

insertMdCardInLastDeck ∷ SlamFeature Unit
insertMdCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertMdCard

insertOpenCardInLastDeck ∷ SlamFeature Unit
insertOpenCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertOpenCard

insertChartOptionsCardInLastDeck ∷ SlamFeature Unit
insertChartOptionsCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertChartOptionsCard

insertDisplayMarkdownCardInLastDeck ∷ SlamFeature Unit
insertDisplayMarkdownCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertDisplayMarkdownCard

insertTableCardInLastDeck ∷ SlamFeature Unit
insertTableCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertTableCard

insertChartCardInLastDeck ∷ SlamFeature Unit
insertChartCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertChartCard

insertCacheCardInLastDeck ∷ SlamFeature Unit
insertCacheCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertCacheCard

insertVariablesCardInLastDeck ∷ SlamFeature Unit
insertVariablesCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertVariablesCard

insertTroubleshootCardInLastDeck ∷ SlamFeature Unit
insertTroubleshootCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertTroubleshootCard

selectBuildChart ∷ SlamFeature Unit
selectBuildChart =
  Feature.click $ followingLastPreviousCardGripper XPaths.selectBuildChart

insertPivotCard ∷ SlamFeature Unit
insertPivotCard =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertPivotCard

insertBuildBarChartCard ∷ SlamFeature Unit
insertBuildBarChartCard =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertBuildBarChartCard

addColumn ∷ String → SlamFeature Unit
addColumn str = do
  Feature.click $ XPath.last $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Add column"
  Feature.click $ XPath.last $ XPath.anywhere $ XPath.anyWithExactAriaLabel $ "Select " ⊕ str
  Feature.click $ XPath.last $ XPath.anywhere $ XPath.anyWithExactText "Confirm"

selectInMillerColumns ∷ Array String → SlamFeature Unit
selectInMillerColumns ps = do
  for_ (enumerate $ Arr.filter (\s → S.length s > 0) ps) \(ix × path) →
    Feature.click $ resourceXPath (ix + one) path
  where
  ariaLabel ∷ String → String
  ariaLabel rPath = "Select " ⊕ rPath

  resourceXPath ∷ Int → String → String
  resourceXPath ix rPath =
    XPath.last
      $ XPath.anywhere
      $ (XPath.nodeAtPosition ix $ XPath.anyWithExactAriaLabel "Column")
      ⊕ "/"
      ⊕ (XPath.anyWithExactAriaLabel $ ariaLabel rPath)

selectFileForLastOpenCard ∷ String → SlamFeature Unit
selectFileForLastOpenCard s =
  selectInMillerColumns $ S.split (S.Pattern "/") s

selectInChartBuilder ∷ Array String → SlamFeature Unit
selectInChartBuilder ps = do
  selectInMillerColumns ps
  Feature.click $ XPath.last $ XPath.anywhere $ XPath.anyWithExactText "Confirm"

provideSearchStringInLastSearchCard ∷ String → SlamFeature Unit
provideSearchStringInLastSearchCard =
  Feature.provideFieldValue $ XPath.last $ XPath.anywhere XPaths.searchStringInput

provideMdInLastMdCard ∷ String → SlamFeature Unit
provideMdInLastMdCard =
  Feature.provideFieldValue
    $ XPath.last $ XPath.anywhere XPaths.aceEditor

provideQueryInLastQueryCard ∷ String → SlamFeature Unit
provideQueryInLastQueryCard =
  Feature.provideFieldValue
    $ XPath.last $ XPath.anywhere XPaths.aceEditor

provideSaveDestinationInLastCacheCard ∷ String → SlamFeature Unit
provideSaveDestinationInLastCacheCard =
  Feature.provideFieldValue (XPath.last $ XPath.anywhere XPaths.saveDestinationInput)

doSaveInLastCacheCard ∷ SlamFeature Unit
doSaveInLastCacheCard =
  Feature.click (XPath.last $ XPath.anywhere XPaths.saveSubmitButton)

provideFieldValueInLastDeck ∷ String → String → SlamFeature Unit
provideFieldValueInLastDeck labelText =
  Feature.provideFieldValue
    $ followingLastPreviousCardGripper
    $ "input" `XPath.withLabelWithExactText` labelText

checkFieldInLastDeck ∷ String → SlamFeature Unit
checkFieldInLastDeck labelText =
  Feature.check
    $ followingLastPreviousCardGripper
    $ "input" `XPath.withLabelWithExactText` labelText

uncheckFieldInLastDeck ∷ String → SlamFeature Unit
uncheckFieldInLastDeck labelText =
  Feature.uncheck
    $ followingLastPreviousCardGripper
    $ "input" `XPath.withLabelWithExactText` labelText

pushRadioButtonInLastDeck ∷ String → SlamFeature Unit
pushRadioButtonInLastDeck labelText =
  Feature.pushRadioButton
    $ followingLastPreviousCardGripper
    $ "input" `XPath.withLabelWithExactText` labelText

selectFromDropdownInLastDeck ∷ String → String → SlamFeature Unit
selectFromDropdownInLastDeck labelText =
  Feature.selectFromDropdown
    $ followingLastPreviousCardGripper
    $ "select" `XPath.withLabelWithExactText` labelText

accessSharingUrl ∷ SlamFeature Unit
accessSharingUrl = Feature.accessUrlFromFieldValue $ XPath.anywhere XPaths.sharingUrl

accessPublishingUrl ∷ SlamFeature Unit
accessPublishingUrl = Feature.accessUrlFromFieldValue $ XPath.anywhere XPaths.publishingUrl

downloadFileAsCSV ∷ String → SlamFeature Unit
downloadFileAsCSV fileName = do
  selectFile fileName
  Feature.click $ XPath.anywhere $ XPaths.downloadFile fileName
  Feature.click $ XPath.anywhere $ XPaths.downloadButton
  Feature.click $ XPath.anywhere $ XPaths.cancelButton

downloadFileAsJSON ∷ String → SlamFeature Unit
downloadFileAsJSON fileName = do
  selectFile fileName
  Feature.click $ XPath.anywhere $ XPaths.downloadFile fileName
  Feature.click $ XPath.anywhere $ XPath.anyWithText "JSON"
  Feature.click $ XPath.anywhere $ XPaths.downloadButton
  Feature.click $ XPath.anywhere $ XPaths.cancelButton

showHiddenFiles ∷ SlamFeature Unit
showHiddenFiles =
  Feature.click $ XPath.anywhere $ XPaths.showHiddenFiles

hideHiddenFiles ∷ SlamFeature Unit
hideHiddenFiles =
  Feature.click $ XPath.anywhere $ XPaths.hideHiddenFiles

type ApiVarName = String
type ApiVarType = String
type ApiVarValue = String

provideApiVariableBindingsForVariablesCard
  ∷ ApiVarName
  → ApiVarType
  → ApiVarValue
  → SlamFeature Unit
provideApiVariableBindingsForVariablesCard name ty val = do
  provideValueForVariablesCard
  provideTypeForVariablesCard
  provideDefaultValueForVariablesCard
  where
  provideValueForVariablesCard ∷ SlamFeature Unit
  provideValueForVariablesCard = do
    Feature.provideFieldValue
      (XPath.first $ XPath.anywhere $ XPaths.variablesCardVariableName)
      name
    Feature.pressEnter
  provideTypeForVariablesCard ∷ SlamFeature Unit
  provideTypeForVariablesCard = do
    Feature.selectFromDropdown
      (XPath.first $ XPath.anywhere $ XPaths.variablesCardVariableTypeFor name)
      ty
    Feature.pressEnter

  provideDefaultValueForVariablesCard ∷ SlamFeature Unit
  provideDefaultValueForVariablesCard = do
    Feature.provideFieldValue
      (XPath.first $ XPath.anywhere $ XPaths.variablesCardDefaultValueFor name)
      val
    Feature.pressEnter

activateCategoryForChartBuilder ∷ SlamFeature Unit
activateCategoryForChartBuilder =
  Feature.click $ XPath.last $ XPath.anywhere $ XPaths.chartCategorySelector

activateStackForChartBuilder ∷ SlamFeature Unit
activateStackForChartBuilder =
  Feature.click $ XPath.last $ XPath.anywhere $ XPaths.chartStackSelector

flipDeck ∷ SlamFeature Unit
flipDeck =
  Feature.click $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Flip deck"

trashActiveOrLastCard ∷ SlamFeature Unit
trashActiveOrLastCard =
  Feature.click $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Delete card"

shareDeck ∷ SlamFeature Unit
shareDeck =
  Feature.click $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Share deck"

publishDeck ∷ SlamFeature Unit
publishDeck =
  Feature.click $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Publish deck"

filterDeckAndCardActions ∷ String → SlamFeature Unit
filterDeckAndCardActions =
  Feature.provideFieldValue (XPath.anywhere $ XPath.anyWithExactAriaLabel "Filter deck and card actions")

filterNextActions ∷ String → SlamFeature Unit
filterNextActions =
  Feature.provideFieldValue (XPath.anywhere $ XPath.anyWithExactAriaLabel "Filter next actions")

confirmDeckAction ∷ SlamFeature Unit
confirmDeckAction =
  Feature.click $ XPath.anywhere $ XPath.anyWithExactText "Confirm"

runQuery ∷ SlamFeature Unit
runQuery =
  Feature.click $ XPath.last $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Run query"

setVarMapForCurrentDeck ∷ SM.StrMap String → SlamFeature Unit
setVarMapForCurrentDeck vm = accessWorkspaceWithModifiedURL \urlStr →
  let
    deckIdRgx = unsafePartial fromRight $ RX.regex "\\.slam\\/([^\\/]+)" RXF.noFlags
    mbDeckId = join $ RX.match deckIdRgx urlStr >>= flip Arr.index 1
  in case mbDeckId of
    Nothing → urlStr
    Just did →
      let
        varsValue =
          encodeURIComponent
          $ prettyJson
          $ encodeJson
          $ SM.singleton did vm
      in
       urlStr ⊕ "/?vars=" ⊕ varsValue