require WEBGL_depth_texture instead of WEBKIT_WEBGL_depth_texture

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
  -- enable extensions
  GL.getExtension_ "WEBGL_depth_texture"
  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 = 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
  -- enable extensions
  GL.getExtension_ "WEBKIT_WEBGL_depth_texture"
  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)


Remove unnecessary import (#316)

Remove unnecessary import (#316)

-- | This module defines the interpreter for Insect.
module Insect.Interpreter
  ( MessageType(..)
  , Message(..)
  , runInsect
  ) where

import Prelude hiding (degree)

import Data.Array (fromFoldable, singleton)
import Data.Bifunctor (lmap)
import Data.Either (Either(..))
import Data.Foldable (foldMap, intercalate, foldl)
import Data.Int (round, toNumber)
import Data.List (List(..), sortBy, filter, groupBy, (..), (:))
import Data.List.NonEmpty (NonEmptyList(..), head, length, zip)
import Data.Map (lookup, insert, delete, toUnfoldable)
import Data.Maybe (Maybe(..))
import Data.NonEmpty (NonEmpty, (:|))
import Data.String (toLower)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..), fst, snd)
import Insect.Environment (Environment, StorageType(..), StoredValue(..), FunctionDescription(..), StoredFunction(..), initialEnvironment, MathFunction)
import Insect.Format (FormattedString, Markup)
import Insect.Format as F
import Insect.Language (BinOp(..), Expression(..), Command(..), Identifier, Statement(..), EvalError(..))
import Insect.PrettyPrint (pretty, prettyQuantity)
import Quantities (Quantity, ConversionError(..))
import Quantities as Q
import Control.Apply (lift2)

-- | A type synonym for error handling. A value of type `Expect Number` is
-- | expected to be a number but might also result in an evaluation error.
type Expect = Either EvalError

-- | Different kinds of messages that will be returned by the interpreter.
data MessageType = Value | ValueSet | Info | Error

-- | The output type of the interpreter.
data Message = Message MessageType Markup | MQuit | MCopy | MClear

-- | Check if the numerical value of a quantity is finite, throw a
-- | `NumericalError` otherwise.
checkFinite ∷ Quantity → Expect Quantity
checkFinite q | Q.isFinite q = pure q
              | otherwise    = Left NumericalError

-- | Evaluate a summation or product expression like
-- | `sum(expr, var, low, high)`.
evalSpecial ∷ String
            → Environment
            → Expression
            → Expression
            → Expression
            → Expression
            → Expect Quantity
evalSpecial func env expr (Variable varname) lowExpr highExpr = do
  -- Evaluate the expressions `low` and `high`
  lowQuantity ← eval env lowExpr
  highQuantity ← eval env highExpr

  -- Try to cast to numbers (and round to integers)
  low ← lmap QConversionError (round <$> Q.toScalar lowQuantity)
  high ← lmap QConversionError (round <$> Q.toScalar highQuantity)

  let
    iteration n =
      eval (env { values = insert varname
                                  (StoredValue UserDefined (Q.scalar (toNumber n)))
                                  env.values
                }) expr

    qs = if low > high
           then Nil
           else map iteration (low .. high)

  if func == "sum"
    then
      foldl qAdd (Right (Q.scalar 0.0)) qs
    else -- product
      foldl (lift2 Q.qMultiply) (Right (Q.scalar 1.0)) qs

  where
    qAdd q1' q2' = do
      q1 ← q1'
      q2 ← q2'
      lmap QConversionError (Q.qAdd q1 q2)
evalSpecial func _ _ _ _ _ = Left (InvalidIdentifier func)

-- | Evaluate Either.. mathematical expression involving physical quantities.
eval ∷ Environment → Expression → Expect Quantity
eval _ (Scalar n)             = pure $ Q.scalar' n
eval _ (Unit u)               = pure $ Q.quantity 1.0 u
eval env (Variable name)        = case lookup name env.values of
                                    Just (StoredValue _ q) → pure q
                                    Nothing → Left (LookupError name)
eval env (Factorial x)          = eval env x >>= Q.factorial >>> lmap QConversionError
eval env (Negate x)             = Q.qNegate <$> eval env x
eval env (Apply name xs)        =
  if name == "sum" || name == "product"
    then
      case xs of
        expr :| var : low : high : Nil →
          evalSpecial name env expr var low high
        _ →
          Left (WrongArityError name 4 (length (NonEmptyList xs)))
    else
      case lookup name env.functions of
        Just (StoredFunction _ fn _) →
          traverse (eval env) xs >>= fn >>= checkFinite
        Nothing → Left (LookupError name)
eval env (BinOp op x y)         = do
  x' <- eval env x
  y' <- eval env y
  run op x' y' >>= checkFinite
  where
    run ∷ BinOp → Quantity → Quantity → Expect Quantity
    run Sub       a b = qSubtract a b
    run Add       a b = qAdd a b
    run Mul       a b = pure (Q.qMultiply a b)
    run Div       a b = pure (Q.qDivide a b)
    run Pow       a b = Q.pow a <$> toScalar b
    run Mod       a b = modulo a b
    run ConvertTo a b = convertTo a b

    wrap ∷ ∀ a. Either ConversionError a → Either EvalError a
    wrap = lmap QConversionError

    qSubtract q1 q2 = wrap (Q.qSubtract q1 q2)
    qAdd q1 q2 = wrap (Q.qAdd q1 q2)
    toScalar q = wrap (Q.toScalar' q)
    modulo q1 q2 = wrap (Q.modulo q1 q2)
    convertTo source target = wrap (Q.convertTo source (Q.derivedUnit target))

-- | Like `eval`, but calls `fullSimplify` on the result if the user did not
-- | ask for an explicit conversion.
evalAndSimplify ∷ Environment → Expression → Expect Quantity
evalAndSimplify env e@(BinOp ConvertTo _ _) = eval env e
evalAndSimplify env e = Q.fullSimplify <$> eval env e

-- | Render the error message for a conversion error.
conversionErrorMessage ∷ ConversionError → Markup
conversionErrorMessage (ConversionError u1 u2) =
  if u1 == Q.unity
    then
      [ F.error "  Conversion error:", F.nl, F.nl
      , F.text "    Cannot convert a ", F.unit "scalar"
      , F.text " to a quantity of unit ", F.unit (Q.toString u2)
      ]
    else
      if u2 == Q.unity
        then
          [ F.error "  Conversion error:", F.nl, F.nl
          , F.text "    Cannot convert quantity of unit "
          , F.unit (Q.toString u1)
          , F.text " to a ", F.unit "scalar"
          ]
        else
            [ F.error "  Conversion error:", F.nl, F.nl
            , F.text "    Cannot convert unit ", F.unit (Q.toString u1)
            ] <> baseRep u1 <>
            [ F.nl
            , F.text "                to unit ", F.unit (Q.toString u2)
            ] <> baseRep u2
  where
    baseRep u =
      if fst (Q.toStandardUnit u) == Q.unity
        then []
        else
          if Q.toString u == F.format F.fmtPlain usStrs
            then []
            else br
      where
        br = [ F.text " (base units: " ] <> usStrs <> [ F.text ")" ]
        us = Q.baseRepresentation u
        us' = sortBy (comparing Q.toString) us
        usStrs = intercalate [ F.text "·" ] $
                   map (singleton <<< F.unit <<< Q.toString) us'

-- | Get the error message for an evaluation error.
evalErrorMessage ∷ EvalError → Markup
evalErrorMessage (QConversionError ue) =
  conversionErrorMessage ue
evalErrorMessage (WrongArityError fn expected given) =
  [ F.optional (F.text "  ")
  , F.error "Wrong number of arguments:", F.nl, F.nl
  , F.text "    The function '", F.function fn, F.text "'"
  , F.text " takes ", F.val (show expected)
  , F.text (if expected == 1 then " argument" else " arguments")
  , F.text " (got ", F.val (show given), F.text ")"
  ]
evalErrorMessage (LookupError name) =
  [ F.optional (F.text "  ")
  , F.error "Unknown identifier: "
  , F.ident name]
evalErrorMessage NumericalError =
  [ F.optional (F.text "  ")
  , F.error "Numerical error: "
  , F.text "division by zero or out-of-bounds error" ]
evalErrorMessage (RedefinedConstantError name) =
  [ F.optional (F.text "  ")
  , F.error "Assignment error: ", F.text "'", F.emph name
  , F.text "' cannot be redefined." ]
evalErrorMessage (InvalidIdentifier func) =
  [ F.optional (F.text "  ")
  , F.error "Invalid identifier: ", F.text "second argument of '"
  , F.function func, F.text "' must be a variable name."
  ]

-- | Interpreter return type.
type Response = { msg ∷ Message, newEnv ∷ Environment }

-- | Show pretty-printed input and the error message.
errorWithInput ∷ Markup → Expression → Environment → EvalError → Response
errorWithInput prefix expr env err =
  { msg: Message Error $ (F.optional <$> ([ F.text "  " ] <> prefix <> pretty expr ))
                         <> [ F.optional F.nl, F.optional F.nl ]
                         <> evalErrorMessage err
  , newEnv: env
  }

-- | Check whether a given identifier is the name of a constant value/function.
isConstant ∷ Environment → Identifier → Boolean
isConstant env name = isConstantValue || isConstantFunction
  where
    isConstantValue =
      case lookup name env.values of
        Just (StoredValue Constant _)       → true
        Just (StoredValue HiddenConstant _) → true
        _ → false
    isConstantFunction =
      case lookup name env.functions of
        Just (StoredFunction Constant _ _)       → true
        Just (StoredFunction HiddenConstant _ _) → true
        _ → false

-- | Format a function definition
prettyPrintFunction ∷ Identifier → NonEmpty List Identifier → Array FormattedString
prettyPrintFunction name argNames =
  [ F.function name, F.text "(" ] <> fArgs <> [ F.text ") = " ]
  where
    fArgs = intercalate [ F.text ", " ] ((\a → [ F.ident a ]) <$> argNames)

-- | Run a single statement of an Insect program.
runInsect ∷ Environment → Statement → Response
runInsect env (Expression e) =
  case evalAndSimplify env e of
    Left evalErr → errorWithInput [] e env evalErr
    Right value →
      { msg: Message Value $    (F.optional <$> ([ F.text "  " ] <> pretty e))
                             <> (F.optional <$> [ F.nl, F.nl , F.text "   = " ])
                             <> prettyQuantity value
      , newEnv: env { values = insert "ans" (StoredValue UserDefined value) env.values }
      }

runInsect env (VariableAssignment name val) =
  case evalAndSimplify env val of
    Left evalErr → errorWithInput [ F.ident name, F.text " = " ] val env evalErr
    Right value →
      if isConstant env name
        then
          errorWithInput [ F.ident name, F.text " = " ] val env (RedefinedConstantError name)
        else
          { msg: Message ValueSet $
                      (F.optional <$> [ F.text "  ", F.ident name, F.text " = " ])
                   <> prettyQuantity value
          , newEnv: env { values = insert name (StoredValue UserDefined value) env.values
                        , functions = delete name env.functions }
          }

runInsect env (FunctionAssignment name argNames expr) =
  if isConstant env name
    then
      errorWithInput (prettyPrintFunction name argNames) expr env (RedefinedConstantError name)
    else
      { msg: Message ValueSet $ (F.optional <$> ([ F.text "  " ] <> prettyPrintFunction name argNames)) <> pretty expr
      , newEnv: env { functions = insert name (StoredFunction UserDefined userFunc (UserFunction argNames expr)) env.functions
                    , values = delete name env.values
                    }
      }
  where
    argNames' = NonEmptyList argNames
    numExpected = length argNames'

    userFunc ∷ MathFunction
    userFunc argValues =
      if numGiven == numExpected
        then evalAndSimplify functionEnv expr
        else Left (WrongArityError name numExpected numGiven)
      where
        argValues' = NonEmptyList argValues
        numGiven = length argValues'
        args = zip argNames' argValues'

        insertArg map (Tuple argName val) = insert argName (StoredValue UserDefined val) map
        functionEnv = env { values = foldl insertArg env.values args
                          , functions = delete name env.functions
                          }

runInsect env (PrettyPrintFunction name) =
  { msg: message,
    newEnv: env
  }
  where
    message =
      case lookup name env.functions of
        Just (StoredFunction _ _ (BuiltinFunction args)) →
          Message Info [ F.optional (F.text "  "),
                         F.ident name,
                         F.text "(",
                         F.text argText,
                         F.text ") = builtin function" ]
          where
            argText = case args of
                        Just 1 → "x"
                        Just 2 → "x, y"
                        Just _ → "x, y, …"
                        Nothing → "x1, x2, …"
        Just (StoredFunction _ _ (UserFunction args expr)) →
          Message Info $ (F.optional <$> ([ F.text "  " ] <> prettyPrintFunction name args)) <> pretty expr
        Nothing → Message Error [ F.text "Unknown function" ]

runInsect env (Command Help) = { msg: Message Info
  [ F.emph "insect", F.text " evaluates mathematical expressions that can", F.nl
  , F.text "involve physical quantities. You can start by trying", F.nl
  , F.text "one of these examples:", F.nl
  , F.text "", F.nl
  , F.emph "  > ", F.val "1920", F.text " / ", F.val "16", F.text " * ", F.val "9", F.text "         "
  , F.emph "  > ", F.function "sin", F.text "(", F.val "30", F.text " ", F.unit "deg", F.text ")", F.nl
  , F.text "", F.nl
  , F.emph "  > ", F.val "2", F.text " ", F.unit "min", F.text " + ", F.val "30", F.text " ", F.unit "s", F.text "          "
  , F.emph "  > ", F.val "6", F.text " ", F.unit "Mbit/s", F.text " * ", F.val "1.5", F.text " ", F.unit "h", F.text " -> ", F.unit "GB", F.nl
  , F.text "", F.nl
  , F.emph "  > ", F.text "list", F.text "                  "
  , F.emph "  > ", F.ident "r", F.text " = ", F.val "80", F.text " ", F.unit "cm", F.nl
  , F.emph "  > ", F.val "40000", F.text " ", F.unit "km", F.text " / ", F.ident "c", F.text " -> ", F.unit "ms", F.text "    "
  , F.emph "  > ", F.ident "pi", F.text " * ", F.ident "r", F.text "^", F.val "2", F.text " -> ", F.unit "m", F.text "^", F.val "2", F.nl
  , F.text "", F.nl
  , F.text "Full documentation: https://github.com/sharkdp/insect"
  ], newEnv: env }

runInsect env (Command List) =
  { msg: Message Info list, newEnv: env }
  where
    storedValue (StoredValue _ value) = value
    storageType (StoredValue t _) = t
    visibleValues = filter (\e → storageType (snd e) /= HiddenConstant) (toUnfoldable env.values)
    envTuples = sortBy (comparing (_.number <<< Q.prettyPrint' <<< storedValue <<< snd)) visibleValues
    envGrouped = groupBy (\x y → storedValue (snd x) == storedValue (snd y)) envTuples
    envSorted = sortBy (comparing (toLower <<< fst <<< head)) envGrouped
    list = [ F.text "List of variables:", F.nl ] <> foldMap toLine envSorted
    toLine kvPairs =
         [ F.nl, F.text "  " ]
      <> identifiers
      <> [ F.text " = " ]
      <> prettyQuantity val
        where
          identifiers = fromFoldable $ intercalate [ F.text " = " ] $
                          (singleton <<< F.ident <<< fst) <$> kvPairs
          val = storedValue (snd (head kvPairs))

runInsect _ (Command Reset) =
  { msg: Message Info [F.text "Environment has been reset."]
  , newEnv: initialEnvironment }

runInsect _ (Command Quit) = { msg: MQuit, newEnv: initialEnvironment }

runInsect env (Command Copy) = { msg: MCopy, newEnv: env }

runInsect env (Command Clear) = { msg: MClear, newEnv: env }

-- | This module defines the interpreter for Insect.
module Insect.Interpreter
  ( MessageType(..)
  , Message(..)
  , runInsect
  ) where

import Prelude hiding (degree)

import Data.Array (fromFoldable, singleton)
import Data.Bifunctor (lmap)
import Data.Either (Either(..))
import Data.Foldable (foldMap, intercalate, foldl)
import Data.Int (round, toNumber)
import Data.List (List(..), sortBy, filter, groupBy, (..), (:))
import Data.List.NonEmpty (NonEmptyList(..), head, length, zip)
import Data.Map (lookup, insert, delete, toUnfoldable)
import Data.Maybe (Maybe(..))
import Data.NonEmpty (NonEmpty, (:|))
import Data.Semigroup.Foldable (foldl1)
import Data.String (toLower)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..), fst, snd)
import Insect.Environment (Environment, StorageType(..), StoredValue(..), FunctionDescription(..), StoredFunction(..), initialEnvironment, MathFunction)
import Insect.Format (FormattedString, Markup)
import Insect.Format as F
import Insect.Language (BinOp(..), Expression(..), Command(..), Identifier, Statement(..), EvalError(..))
import Insect.PrettyPrint (pretty, prettyQuantity)
import Quantities (Quantity, ConversionError(..))
import Quantities as Q
import Control.Apply (lift2)

-- | A type synonym for error handling. A value of type `Expect Number` is
-- | expected to be a number but might also result in an evaluation error.
type Expect = Either EvalError

-- | Different kinds of messages that will be returned by the interpreter.
data MessageType = Value | ValueSet | Info | Error

-- | The output type of the interpreter.
data Message = Message MessageType Markup | MQuit | MCopy | MClear

-- | Check if the numerical value of a quantity is finite, throw a
-- | `NumericalError` otherwise.
checkFinite ∷ Quantity → Expect Quantity
checkFinite q | Q.isFinite q = pure q
              | otherwise    = Left NumericalError

-- | Evaluate a summation or product expression like
-- | `sum(expr, var, low, high)`.
evalSpecial ∷ String
            → Environment
            → Expression
            → Expression
            → Expression
            → Expression
            → Expect Quantity
evalSpecial func env expr (Variable varname) lowExpr highExpr = do
  -- Evaluate the expressions `low` and `high`
  lowQuantity ← eval env lowExpr
  highQuantity ← eval env highExpr

  -- Try to cast to numbers (and round to integers)
  low ← lmap QConversionError (round <$> Q.toScalar lowQuantity)
  high ← lmap QConversionError (round <$> Q.toScalar highQuantity)

  let
    iteration n =
      eval (env { values = insert varname
                                  (StoredValue UserDefined (Q.scalar (toNumber n)))
                                  env.values
                }) expr

    qs = if low > high
           then Nil
           else map iteration (low .. high)

  if func == "sum"
    then
      foldl qAdd (Right (Q.scalar 0.0)) qs
    else -- product
      foldl (lift2 Q.qMultiply) (Right (Q.scalar 1.0)) qs

  where
    qAdd q1' q2' = do
      q1 ← q1'
      q2 ← q2'
      lmap QConversionError (Q.qAdd q1 q2)
evalSpecial func _ _ _ _ _ = Left (InvalidIdentifier func)

-- | Evaluate Either.. mathematical expression involving physical quantities.
eval ∷ Environment → Expression → Expect Quantity
eval _ (Scalar n)             = pure $ Q.scalar' n
eval _ (Unit u)               = pure $ Q.quantity 1.0 u
eval env (Variable name)        = case lookup name env.values of
                                    Just (StoredValue _ q) → pure q
                                    Nothing → Left (LookupError name)
eval env (Factorial x)          = eval env x >>= Q.factorial >>> lmap QConversionError
eval env (Negate x)             = Q.qNegate <$> eval env x
eval env (Apply name xs)        =
  if name == "sum" || name == "product"
    then
      case xs of
        expr :| var : low : high : Nil →
          evalSpecial name env expr var low high
        _ →
          Left (WrongArityError name 4 (length (NonEmptyList xs)))
    else
      case lookup name env.functions of
        Just (StoredFunction _ fn _) →
          traverse (eval env) xs >>= fn >>= checkFinite
        Nothing → Left (LookupError name)
eval env (BinOp op x y)         = do
  x' <- eval env x
  y' <- eval env y
  run op x' y' >>= checkFinite
  where
    run ∷ BinOp → Quantity → Quantity → Expect Quantity
    run Sub       a b = qSubtract a b
    run Add       a b = qAdd a b
    run Mul       a b = pure (Q.qMultiply a b)
    run Div       a b = pure (Q.qDivide a b)
    run Pow       a b = Q.pow a <$> toScalar b
    run Mod       a b = modulo a b
    run ConvertTo a b = convertTo a b

    wrap ∷ ∀ a. Either ConversionError a → Either EvalError a
    wrap = lmap QConversionError

    qSubtract q1 q2 = wrap (Q.qSubtract q1 q2)
    qAdd q1 q2 = wrap (Q.qAdd q1 q2)
    toScalar q = wrap (Q.toScalar' q)
    modulo q1 q2 = wrap (Q.modulo q1 q2)
    convertTo source target = wrap (Q.convertTo source (Q.derivedUnit target))

-- | Like `eval`, but calls `fullSimplify` on the result if the user did not
-- | ask for an explicit conversion.
evalAndSimplify ∷ Environment → Expression → Expect Quantity
evalAndSimplify env e@(BinOp ConvertTo _ _) = eval env e
evalAndSimplify env e = Q.fullSimplify <$> eval env e

-- | Render the error message for a conversion error.
conversionErrorMessage ∷ ConversionError → Markup
conversionErrorMessage (ConversionError u1 u2) =
  if u1 == Q.unity
    then
      [ F.error "  Conversion error:", F.nl, F.nl
      , F.text "    Cannot convert a ", F.unit "scalar"
      , F.text " to a quantity of unit ", F.unit (Q.toString u2)
      ]
    else
      if u2 == Q.unity
        then
          [ F.error "  Conversion error:", F.nl, F.nl
          , F.text "    Cannot convert quantity of unit "
          , F.unit (Q.toString u1)
          , F.text " to a ", F.unit "scalar"
          ]
        else
            [ F.error "  Conversion error:", F.nl, F.nl
            , F.text "    Cannot convert unit ", F.unit (Q.toString u1)
            ] <> baseRep u1 <>
            [ F.nl
            , F.text "                to unit ", F.unit (Q.toString u2)
            ] <> baseRep u2
  where
    baseRep u =
      if fst (Q.toStandardUnit u) == Q.unity
        then []
        else
          if Q.toString u == F.format F.fmtPlain usStrs
            then []
            else br
      where
        br = [ F.text " (base units: " ] <> usStrs <> [ F.text ")" ]
        us = Q.baseRepresentation u
        us' = sortBy (comparing Q.toString) us
        usStrs = intercalate [ F.text "·" ] $
                   map (singleton <<< F.unit <<< Q.toString) us'

-- | Get the error message for an evaluation error.
evalErrorMessage ∷ EvalError → Markup
evalErrorMessage (QConversionError ue) =
  conversionErrorMessage ue
evalErrorMessage (WrongArityError fn expected given) =
  [ F.optional (F.text "  ")
  , F.error "Wrong number of arguments:", F.nl, F.nl
  , F.text "    The function '", F.function fn, F.text "'"
  , F.text " takes ", F.val (show expected)
  , F.text (if expected == 1 then " argument" else " arguments")
  , F.text " (got ", F.val (show given), F.text ")"
  ]
evalErrorMessage (LookupError name) =
  [ F.optional (F.text "  ")
  , F.error "Unknown identifier: "
  , F.ident name]
evalErrorMessage NumericalError =
  [ F.optional (F.text "  ")
  , F.error "Numerical error: "
  , F.text "division by zero or out-of-bounds error" ]
evalErrorMessage (RedefinedConstantError name) =
  [ F.optional (F.text "  ")
  , F.error "Assignment error: ", F.text "'", F.emph name
  , F.text "' cannot be redefined." ]
evalErrorMessage (InvalidIdentifier func) =
  [ F.optional (F.text "  ")
  , F.error "Invalid identifier: ", F.text "second argument of '"
  , F.function func, F.text "' must be a variable name."
  ]

-- | Interpreter return type.
type Response = { msg ∷ Message, newEnv ∷ Environment }

-- | Show pretty-printed input and the error message.
errorWithInput ∷ Markup → Expression → Environment → EvalError → Response
errorWithInput prefix expr env err =
  { msg: Message Error $ (F.optional <$> ([ F.text "  " ] <> prefix <> pretty expr ))
                         <> [ F.optional F.nl, F.optional F.nl ]
                         <> evalErrorMessage err
  , newEnv: env
  }

-- | Check whether a given identifier is the name of a constant value/function.
isConstant ∷ Environment → Identifier → Boolean
isConstant env name = isConstantValue || isConstantFunction
  where
    isConstantValue =
      case lookup name env.values of
        Just (StoredValue Constant _)       → true
        Just (StoredValue HiddenConstant _) → true
        _ → false
    isConstantFunction =
      case lookup name env.functions of
        Just (StoredFunction Constant _ _)       → true
        Just (StoredFunction HiddenConstant _ _) → true
        _ → false

-- | Format a function definition
prettyPrintFunction ∷ Identifier → NonEmpty List Identifier → Array FormattedString
prettyPrintFunction name argNames =
  [ F.function name, F.text "(" ] <> fArgs <> [ F.text ") = " ]
  where
    fArgs = intercalate [ F.text ", " ] ((\a → [ F.ident a ]) <$> argNames)

-- | Run a single statement of an Insect program.
runInsect ∷ Environment → Statement → Response
runInsect env (Expression e) =
  case evalAndSimplify env e of
    Left evalErr → errorWithInput [] e env evalErr
    Right value →
      { msg: Message Value $    (F.optional <$> ([ F.text "  " ] <> pretty e))
                             <> (F.optional <$> [ F.nl, F.nl , F.text "   = " ])
                             <> prettyQuantity value
      , newEnv: env { values = insert "ans" (StoredValue UserDefined value) env.values }
      }

runInsect env (VariableAssignment name val) =
  case evalAndSimplify env val of
    Left evalErr → errorWithInput [ F.ident name, F.text " = " ] val env evalErr
    Right value →
      if isConstant env name
        then
          errorWithInput [ F.ident name, F.text " = " ] val env (RedefinedConstantError name)
        else
          { msg: Message ValueSet $
                      (F.optional <$> [ F.text "  ", F.ident name, F.text " = " ])
                   <> prettyQuantity value
          , newEnv: env { values = insert name (StoredValue UserDefined value) env.values
                        , functions = delete name env.functions }
          }

runInsect env (FunctionAssignment name argNames expr) =
  if isConstant env name
    then
      errorWithInput (prettyPrintFunction name argNames) expr env (RedefinedConstantError name)
    else
      { msg: Message ValueSet $ (F.optional <$> ([ F.text "  " ] <> prettyPrintFunction name argNames)) <> pretty expr
      , newEnv: env { functions = insert name (StoredFunction UserDefined userFunc (UserFunction argNames expr)) env.functions
                    , values = delete name env.values
                    }
      }
  where
    argNames' = NonEmptyList argNames
    numExpected = length argNames'

    userFunc ∷ MathFunction
    userFunc argValues =
      if numGiven == numExpected
        then evalAndSimplify functionEnv expr
        else Left (WrongArityError name numExpected numGiven)
      where
        argValues' = NonEmptyList argValues
        numGiven = length argValues'
        args = zip argNames' argValues'

        insertArg map (Tuple argName val) = insert argName (StoredValue UserDefined val) map
        functionEnv = env { values = foldl insertArg env.values args
                          , functions = delete name env.functions
                          }

runInsect env (PrettyPrintFunction name) =
  { msg: message,
    newEnv: env
  }
  where
    message =
      case lookup name env.functions of
        Just (StoredFunction _ _ (BuiltinFunction args)) →
          Message Info [ F.optional (F.text "  "),
                         F.ident name,
                         F.text "(",
                         F.text argText,
                         F.text ") = builtin function" ]
          where
            argText = case args of
                        Just 1 → "x"
                        Just 2 → "x, y"
                        Just _ → "x, y, …"
                        Nothing → "x1, x2, …"
        Just (StoredFunction _ _ (UserFunction args expr)) →
          Message Info $ (F.optional <$> ([ F.text "  " ] <> prettyPrintFunction name args)) <> pretty expr
        Nothing → Message Error [ F.text "Unknown function" ]

runInsect env (Command Help) = { msg: Message Info
  [ F.emph "insect", F.text " evaluates mathematical expressions that can", F.nl
  , F.text "involve physical quantities. You can start by trying", F.nl
  , F.text "one of these examples:", F.nl
  , F.text "", F.nl
  , F.emph "  > ", F.val "1920", F.text " / ", F.val "16", F.text " * ", F.val "9", F.text "         "
  , F.emph "  > ", F.function "sin", F.text "(", F.val "30", F.text " ", F.unit "deg", F.text ")", F.nl
  , F.text "", F.nl
  , F.emph "  > ", F.val "2", F.text " ", F.unit "min", F.text " + ", F.val "30", F.text " ", F.unit "s", F.text "          "
  , F.emph "  > ", F.val "6", F.text " ", F.unit "Mbit/s", F.text " * ", F.val "1.5", F.text " ", F.unit "h", F.text " -> ", F.unit "GB", F.nl
  , F.text "", F.nl
  , F.emph "  > ", F.text "list", F.text "                  "
  , F.emph "  > ", F.ident "r", F.text " = ", F.val "80", F.text " ", F.unit "cm", F.nl
  , F.emph "  > ", F.val "40000", F.text " ", F.unit "km", F.text " / ", F.ident "c", F.text " -> ", F.unit "ms", F.text "    "
  , F.emph "  > ", F.ident "pi", F.text " * ", F.ident "r", F.text "^", F.val "2", F.text " -> ", F.unit "m", F.text "^", F.val "2", F.nl
  , F.text "", F.nl
  , F.text "Full documentation: https://github.com/sharkdp/insect"
  ], newEnv: env }

runInsect env (Command List) =
  { msg: Message Info list, newEnv: env }
  where
    storedValue (StoredValue _ value) = value
    storageType (StoredValue t _) = t
    visibleValues = filter (\e → storageType (snd e) /= HiddenConstant) (toUnfoldable env.values)
    envTuples = sortBy (comparing (_.number <<< Q.prettyPrint' <<< storedValue <<< snd)) visibleValues
    envGrouped = groupBy (\x y → storedValue (snd x) == storedValue (snd y)) envTuples
    envSorted = sortBy (comparing (toLower <<< fst <<< head)) envGrouped
    list = [ F.text "List of variables:", F.nl ] <> foldMap toLine envSorted
    toLine kvPairs =
         [ F.nl, F.text "  " ]
      <> identifiers
      <> [ F.text " = " ]
      <> prettyQuantity val
        where
          identifiers = fromFoldable $ intercalate [ F.text " = " ] $
                          (singleton <<< F.ident <<< fst) <$> kvPairs
          val = storedValue (snd (head kvPairs))

runInsect _ (Command Reset) =
  { msg: Message Info [F.text "Environment has been reset."]
  , newEnv: initialEnvironment }

runInsect _ (Command Quit) = { msg: MQuit, newEnv: initialEnvironment }

runInsect env (Command Copy) = { msg: MCopy, newEnv: env }

runInsect env (Command Clear) = { msg: MClear, newEnv: env }


use makeImmediate from purescript-spork

use makeImmediate from purescript-spork

module Routing.PushState
  ( PushStateEffects
  , PushStateInterface
  , LocationState
  , makeInterface
  , foldLocations
  , locations
  , foldPaths
  , paths
  , matches
  , matchesWith
  ) where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Ref (REF, modifyRef, newRef, readRef, writeRef)
import DOM (DOM)
import DOM.Event.EventTarget (addEventListener, eventListener) as DOM
import DOM.HTML (window) as DOM
import DOM.HTML.Event.EventTypes (popstate) as DOM
import DOM.HTML.History (DocumentTitle(..), URL(..), pushState, replaceState, state) as DOM
import DOM.HTML.Location (hash, pathname, search) as DOM
import DOM.HTML.Types (HISTORY)
import DOM.HTML.Types (htmlDocumentToDocument, windowToEventTarget) as DOM
import DOM.HTML.Window (document, history, location) as DOM
import DOM.Node.Document (createTextNode) as DOM
import DOM.Node.MutationObserver (mutationObserver, observe) as DOM
import DOM.Node.Node (setNodeValue) as DOM
import DOM.Node.Types (textToNode) as DOM
import Data.Either (Either(..), either)
import Data.Foldable (class Foldable, indexl, traverse_)
import Data.Foreign (Foreign)
import Data.Map as Map
import Data.Maybe (Maybe(..), maybe)
import Routing (match)
import Routing.Match (Match)

type PushStateEffects eff =
  ( history :: HISTORY
  , dom :: DOM
  , ref :: REF
  | eff
  )

-- | A `PushStateInterface` is a localized instance for making location changes
-- | and consuming the events. Since the DOM API does not provide a general
-- | event type for push state (only pop), you must use the coupled effects
-- | along with `listen` to receive events on all location changes.
-- |
-- | * `pushState` – pushes a new location state and path onto the history stack.
-- | * `replaceState` – replaces the location state and path in the history stack.
-- | * `locationState` – Dereferences the current history state
-- | * `listen` – Subscribes to location changes (both push and pop). Returns
-- |   an effect which removes the listener.
type PushStateInterface eff =
  { pushState :: Foreign -> String -> Eff eff Unit
  , replaceState :: Foreign -> String -> Eff eff Unit
  , locationState :: Eff eff LocationState
  , listen :: (LocationState -> Eff eff Unit) -> Eff eff (Eff eff Unit)
  }

type LocationState =
  { state :: Foreign
  , path :: String
  , pathname :: String
  , search :: String
  , hash :: String
  }

-- | Creates a new `PushStateInterface`. Generally you should only create one
-- | instance for your application. Since the DOM does not provide general
-- | events for location changes, listeners will only be notified on push when
-- | using the paired functions.
makeInterface :: forall eff. Eff (PushStateEffects eff) (PushStateInterface (PushStateEffects eff))
makeInterface = do
  freshRef <- newRef 0
  listenersRef <- newRef Map.empty

  let
    notify ev =
      traverse_ (_ $ ev) =<< readRef listenersRef

    listen k = do
      fresh <- readRef freshRef
      writeRef freshRef (fresh + 1)
      modifyRef listenersRef $ Map.insert fresh k
      pure $ modifyRef listenersRef $ Map.delete fresh

    locationState = do
      loc <- DOM.window >>= DOM.location
      state <- DOM.window >>= DOM.history >>= DOM.state
      pathname <- DOM.pathname loc
      search <- DOM.search loc
      hash <- DOM.hash loc
      let path = pathname <> search <> hash
      pure { state, pathname, search, hash, path }

  schedule <- makeImmediate $ notify =<< locationState
  let
    stateFn op state path = do
      DOM.window
        >>= DOM.history
        >>= op state (DOM.DocumentTitle "") (DOM.URL path)
      -- The hashchange interface is asynchronous, since hashchange events are
      -- fired on the next tick of the event loop. We want the push-state
      -- interface to behave as similarly as possible, so we use something like
      -- `setImmediate` and use `Ref Boolean` to make sure maximum one `notify` is
      -- scheduled per event loop.
      schedule

    listener =
      DOM.eventListener \_ -> notify =<< locationState

  DOM.window
    >>= DOM.windowToEventTarget
    >>> DOM.addEventListener DOM.popstate listener false

  pure
    { pushState: stateFn DOM.pushState
    , replaceState: stateFn DOM.replaceState
    , locationState
    , listen
    }

-- | Folds effectfully over location changes given callbacks for handling
-- | changes and the initial location. Returns an effect which removes the
-- | listener.
foldLocations
  :: forall eff a
   . (a -> LocationState -> Eff (PushStateEffects eff) a)
  -> (LocationState -> Eff (PushStateEffects eff) a)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
foldLocations cb init psi = do
  ref <- newRef =<< init =<< psi.locationState
  psi.listen (\loc -> writeRef ref =<< flip cb loc =<< readRef ref)

-- | Runs the callback on every location change providing the previous location
-- | and the latest location. Returns an effect which removes the listener.
locations
  :: forall eff
   . (Maybe LocationState -> LocationState -> Eff (PushStateEffects eff) Unit)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
locations cb = foldLocations go (go Nothing)
  where
  go a b = Just b <$ cb a b

-- | Folds effectfully over path changes given callbacks for handling changes
-- | and the initial path. Returns an effect which removes the listener.
foldPaths
  :: forall eff a
   . (a -> String -> Eff (PushStateEffects eff) a)
  -> (String -> Eff (PushStateEffects eff) a)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
foldPaths cb init = foldLocations (\a -> cb a <<< _.path) (init <<< _.path)

-- | Runs the callback on every path change providing the previous path and
-- | the latest path. Returns an effect which removes the listener.
paths
  :: forall eff
   . (Maybe String -> String -> Eff (PushStateEffects eff) Unit)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
paths = matchesWith Just

-- | Runs the callback on every path change using a given `Match` parser to
-- | extract a route from the path. If a path fails to parse, it is ignored.
-- | To avoid dropping paths, provide a fallback alternative in your parser.
-- | Returns an effect which removes the listener.
matches
  :: forall eff a
   . Match a
  -> (Maybe a -> a -> Eff (PushStateEffects eff) Unit)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
matches = matchesWith <<< match

-- | Runs the callback on every path change using a given custom parser to
-- | extract a route from the path. If a path fails to parse, it is ignored.
-- | To avoid dropping paths, provide a fallback alternative in your parser.
-- | Returns an effect which removes the listener.
matchesWith
  :: forall eff f a
   . Foldable f
  => (String -> f a)
  -> (Maybe a -> a -> Eff (PushStateEffects eff) Unit)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
matchesWith parser cb = foldPaths go (go Nothing)
  where
  go a =
    maybe (pure a) (\b -> Just b <$ cb a b)
      <<< indexl 0
      <<< parser

-- | Similar to `setImmediate`, it's impelemnted using microtask queue via MutationObserver
-- | to schedule callbacks. this way it's more imediate then `setTimout` would have been.
-- | We use a fresh counter so that the text change mutation always fires.
-- | from: https://github.com/natefaubion/purescript-spork/blob/3b56c4d36e84866ed9b1bc27afa7ab4762ffdd01/src/Spork/Scheduler.purs#L20
makeImmediate
  ∷ ∀ eff
  . Eff (ref ∷ REF, dom ∷ DOM | eff) Unit
  → Eff (ref ∷ REF, dom ∷ DOM | eff) (Eff (ref ∷ REF, dom ∷ DOM | eff) Unit)
makeImmediate run = do
  document ←
    DOM.window
      >>= DOM.document
      >>> map DOM.htmlDocumentToDocument
  nextTick ← newRef (Right 0)
  obsvNode ← DOM.textToNode <$> DOM.createTextNode "" document
  observer ← DOM.mutationObserver \_ _ → do
    modifyRef nextTick $ either (Right <<< add 1) Right
    run
  DOM.observe obsvNode { characterData: true } observer
  pure do
    readRef nextTick >>= traverse_ \tick → do
      writeRef nextTick $ Left (tick + 1)
      DOM.setNodeValue (show tick) obsvNode

module Routing.PushState
  ( PushStateEffects
  , PushStateInterface
  , LocationState
  , makeInterface
  , foldLocations
  , locations
  , foldPaths
  , paths
  , matches
  , matchesWith
  ) where

import Prelude

import Control.Monad.Eff (Eff, runPure)
import Control.Monad.Eff.Ref (REF, modifyRef, newRef, readRef, writeRef)
import Control.Monad.Eff.Ref.Unsafe (unsafeRunRef)
import DOM (DOM)
import DOM.Event.EventTarget (addEventListener, eventListener) as DOM
import DOM.HTML (window) as DOM
import DOM.HTML.Event.EventTypes (popstate) as DOM
import DOM.HTML.History (DocumentTitle(..), URL(..), pushState, replaceState, state) as DOM
import DOM.HTML.Location (hash, pathname, search) as DOM
import DOM.HTML.Types (HISTORY)
import DOM.HTML.Types (htmlDocumentToDocument, windowToEventTarget) as DOM
import DOM.HTML.Window (document, history, location) as DOM
import DOM.Node.Document (createTextNode) as DOM
import DOM.Node.MutationObserver (mutationObserver, observe) as DOM
import DOM.Node.Node (setNodeValue) as DOM
import DOM.Node.Types (textToNode) as DOM
import Data.Foldable (class Foldable, indexl, sequence_, traverse_)
import Data.Foreign (Foreign)
import Data.List (List(..))
import Data.Map as Map
import Data.Maybe (Maybe(..), maybe)
import Routing (match)
import Routing.Match (Match)

type PushStateEffects eff =
  ( history :: HISTORY
  , dom :: DOM
  , ref :: REF
  | eff
  )

-- | A `PushStateInterface` is a localized instance for making location changes
-- | and consuming the events. Since the DOM API does not provide a general
-- | event type for push state (only pop), you must use the coupled effects
-- | along with `listen` to receive events on all location changes.
-- |
-- | * `pushState` – pushes a new location state and path onto the history stack.
-- | * `replaceState` – replaces the location state and path in the history stack.
-- | * `locationState` – Dereferences the current history state
-- | * `listen` – Subscribes to location changes (both push and pop). Returns
-- |   an effect which removes the listener.
type PushStateInterface eff =
  { pushState :: Foreign -> String -> Eff eff Unit
  , replaceState :: Foreign -> String -> Eff eff Unit
  , locationState :: Eff eff LocationState
  , listen :: (LocationState -> Eff eff Unit) -> Eff eff (Eff eff Unit)
  }

type LocationState =
  { state :: Foreign
  , path :: String
  , pathname :: String
  , search :: String
  , hash :: String
  }

-- | Creates a new `PushStateInterface`. Generally you should only create one
-- | instance for your application. Since the DOM does not provide general
-- | events for location changes, listeners will only be notified on push when
-- | using the paired functions.
makeInterface :: forall eff. Eff (PushStateEffects eff) (PushStateInterface (PushStateEffects eff))
makeInterface = do
  schedRef <- newRef false
  freshRef <- newRef 0
  listenersRef <- newRef Map.empty

  let
    notify ev =
      traverse_ (_ $ ev) =<< readRef listenersRef

    listen k = do
      fresh <- readRef freshRef
      writeRef freshRef (fresh + 1)
      modifyRef listenersRef $ Map.insert fresh k
      pure $ modifyRef listenersRef $ Map.delete fresh

    locationState = do
      loc <- DOM.window >>= DOM.location
      state <- DOM.window >>= DOM.history >>= DOM.state
      pathname <- DOM.pathname loc
      search <- DOM.search loc
      hash <- DOM.hash loc
      let path = pathname <> search <> hash
      pure { state, pathname, search, hash, path }

  let
    stateFn op state path = do
      DOM.window
        >>= DOM.history
        >>= op state (DOM.DocumentTitle "") (DOM.URL path)
      -- The hashchange interface is asynchronous, since hashchange events are
      -- fired on the next tick of the event loop. We want the push-state
      -- interface to behave as similarly as possible, so we use something like
      -- `setImmediate` and use `Ref Boolean` to make sure maximum one `notify` is
      -- scheduled per event loop.
      unlessM (readRef schedRef) do
        writeRef schedRef true
        unsafeSetImmediate $ do
          writeRef schedRef false
          notify =<< locationState

    listener =
      DOM.eventListener \_ -> notify =<< locationState

  DOM.window
    >>= DOM.windowToEventTarget
    >>> DOM.addEventListener DOM.popstate listener false

  pure
    { pushState: stateFn DOM.pushState
    , replaceState: stateFn DOM.replaceState
    , locationState
    , listen
    }

-- | Folds effectfully over location changes given callbacks for handling
-- | changes and the initial location. Returns an effect which removes the
-- | listener.
foldLocations
  :: forall eff a
   . (a -> LocationState -> Eff (PushStateEffects eff) a)
  -> (LocationState -> Eff (PushStateEffects eff) a)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
foldLocations cb init psi = do
  ref <- newRef =<< init =<< psi.locationState
  psi.listen (\loc -> writeRef ref =<< flip cb loc =<< readRef ref)

-- | Runs the callback on every location change providing the previous location
-- | and the latest location. Returns an effect which removes the listener.
locations
  :: forall eff
   . (Maybe LocationState -> LocationState -> Eff (PushStateEffects eff) Unit)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
locations cb = foldLocations go (go Nothing)
  where
  go a b = Just b <$ cb a b

-- | Folds effectfully over path changes given callbacks for handling changes
-- | and the initial path. Returns an effect which removes the listener.
foldPaths
  :: forall eff a
   . (a -> String -> Eff (PushStateEffects eff) a)
  -> (String -> Eff (PushStateEffects eff) a)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
foldPaths cb init = foldLocations (\a -> cb a <<< _.path) (init <<< _.path)

-- | Runs the callback on every path change providing the previous path and
-- | the latest path. Returns an effect which removes the listener.
paths
  :: forall eff
   . (Maybe String -> String -> Eff (PushStateEffects eff) Unit)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
paths = matchesWith Just

-- | Runs the callback on every path change using a given `Match` parser to
-- | extract a route from the path. If a path fails to parse, it is ignored.
-- | To avoid dropping paths, provide a fallback alternative in your parser.
-- | Returns an effect which removes the listener.
matches
  :: forall eff a
   . Match a
  -> (Maybe a -> a -> Eff (PushStateEffects eff) Unit)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
matches = matchesWith <<< match

-- | Runs the callback on every path change using a given custom parser to
-- | extract a route from the path. If a path fails to parse, it is ignored.
-- | To avoid dropping paths, provide a fallback alternative in your parser.
-- | Returns an effect which removes the listener.
matchesWith
  :: forall eff f a
   . Foldable f
  => (String -> f a)
  -> (Maybe a -> a -> Eff (PushStateEffects eff) Unit)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
matchesWith parser cb = foldPaths go (go Nothing)
  where
  go a =
    maybe (pure a) (\b -> Just b <$ cb a b)
      <<< indexl 0
      <<< parser

-- | Similar to `setImmediate`, it's impelemnted using microtask queue via MutationObserver
-- | to schedule callbacks. this way it's more imediate then `setTimout` would have been.
-- | We use a fresh counter so that the text change mutation always fires.
-- |
-- | NOTE: it's not that unsafe, but we use `unsafeRunRef` and `runPure` so it's still unsafe.
unsafeSetImmediate
  :: forall r
  . Eff (ref :: REF, dom :: DOM |r) Unit -> Eff (ref :: REF, dom :: DOM |r) Unit
unsafeSetImmediate =
  let
    freshRef = runPure $ unsafeRunRef $ newRef 0
    effRef = runPure $ unsafeRunRef $ newRef Nil
    nodeRef = runPure $ unsafeRunRef $ newRef Nothing
  in \eff -> do
    modifyRef effRef $ Cons eff
    obsvNode <- readRef nodeRef >>= case _ of
      Nothing -> do
        obsvNode <-
          DOM.window
            >>= DOM.document
            >>> map DOM.htmlDocumentToDocument
            >>= DOM.createTextNode ""
            >>> map DOM.textToNode
        observer <- DOM.mutationObserver \_ _ -> do
          readRef effRef >>= sequence_
          writeRef effRef Nil
        DOM.observe obsvNode { characterData: true } observer
        pure obsvNode
      Just obsvNode ->
        pure obsvNode
    fresh ← readRef freshRef
    writeRef freshRef (fresh + 1)
    DOM.setNodeValue (show fresh) obsvNode


Purging lecherous whitespace

Purging lecherous whitespace

module JQueryUI where

import Control.Monad.Eff
import Control.Monad.JQuery(DOM(..), JQuery(..))

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

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

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

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

-- .click(f)
foreign import click
  """
  function click(f) {
    return function(ob) {
      return function() {
        ob.click(function () { return f(jQuery(this))(); });
      };
    };
  }
  """ :: forall eff a. (JQuery -> Eff (dom :: DOM | eff) JQuery) -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .each(f)
foreign import each
  """
  function each(f) {
    return function(ob) {
      return function() {
        ob.each(function() { return f(jQuery(this))(); });
      };
    };
  }
  """ :: forall eff a. (JQuery -> Eff (dom :: DOM | eff) JQuery) -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- x[0].checked = !x[0].checked
foreign import flipChecked
  """
  function flipChecked(ob) {
    return function () {
      ob[0].checked = !ob[0].checked;
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) Unit

-- .button('refresh')
foreign import refreshButton
  """
  function refreshButton(ob) {
    return function() {
      ob.button('refresh');
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) Unit

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

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

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

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

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

module JQueryUI where

import Control.Monad.Eff
import Control.Monad.JQuery(DOM(..), JQuery(..))

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

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

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

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

-- .click(f)
foreign import click
  """
  function click(f) {
    return function(ob) {
      return function() {
        ob.click(function () { return f(jQuery(this))(); });
      };
    };
  }
  """ :: forall eff a. (JQuery -> Eff (dom :: DOM | eff) JQuery) -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .each(f)
foreign import each
  """
  function each(f) {
    return function(ob) {
      return function() {
        ob.each(function() { return f(jQuery(this))(); });
      };
    };
  }
  """ :: forall eff a. (JQuery -> Eff (dom :: DOM | eff) JQuery) -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- x[0].checked = !x[0].checked
foreign import flipChecked
  """
  function flipChecked(ob) {
    return function () {
      ob[0].checked = !ob[0].checked;
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) Unit

-- .button('refresh')
foreign import refreshButton
  """
  function refreshButton(ob) {
    return function() {
      ob.button('refresh');
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) Unit

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

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

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

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

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