Added uniformMatrix4fv method to free monad.

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

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

newtype AttributeLocation = AttributeLocation GLuint

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

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

type WebGL = Free WebGLF

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

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

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

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

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

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

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

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

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

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

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

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

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

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

getCanvas :: WebGL CanvasElement
getCanvas = liftF $ GetCanvas id

getDrawingBufferHeight :: WebGL Int
getDrawingBufferHeight = liftF $ GetDrawingBufferHeight id

getDrawingBufferWidth :: WebGL Int
getDrawingBufferWidth = liftF $ GetDrawingBufferWidth id

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

newtype AttributeLocation = AttributeLocation GLuint

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

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

type WebGL = Free WebGLF

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

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

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

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

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

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

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

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

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

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

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

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

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

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

getCanvas :: WebGL CanvasElement
getCanvas = liftF $ GetCanvas id

getDrawingBufferHeight :: WebGL Int
getDrawingBufferHeight = liftF $ GetDrawingBufferHeight id

getDrawingBufferWidth :: WebGL Int
getDrawingBufferWidth = liftF $ GetDrawingBufferWidth id

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

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

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

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

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

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

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

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

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

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

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

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

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


EQ, Semigroup and Show instances or URL

EQ, Semigroup and Show instances or URL

-- | This module defines a type of _link targets_, which can be used as the target of a hyperlink or button.
-- |
-- | This type is quite useful when defining reusable components.

module Halogen.HTML.Target
  ( URL()
  , url
  , runURL

  , Target(..)
  , target
  ) where

import Control.Functor (($>))

import Control.Alt

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

-- | A type-safe wrapper for a URL
data URL = URL String

instance eqURL :: Eq URL where
  (==) (URL a) (URL b) = a == b
  (/=) a       b       = not (a == b)

instance semigroupURL :: Semigroup URL where
  (<>) (URL a) (URL b) = URL (a <> b)

instance showURL :: Show URL where
  show (URL a) = "url " ++ show a

-- | Create a `URL`
url :: String -> URL
url = URL

-- | Unwrap a URL
runURL :: URL -> String
runURL (URL s) = s

-- | There are two types of target:
-- |
-- | - `LinkTarget` creates a target which links to a URL.
-- | - `DataTarget` creates a target which carries data which may be used to generate inputs or requests.
data Target a = LinkTarget URL | DataTarget a

-- | Attach a `Target` to an element using the `href` or `onclick` attribute as appropriate
target :: forall i. Target i -> [A.Attr i]
target (LinkTarget url) = [ A.href (runURL url) ]
target (DataTarget i) = [ A.href "#", E.onClick (\_ -> E.preventDefault $> i) ]

-- | This module defines a type of _link targets_, which can be used as the target of a hyperlink or button.
-- |
-- | This type is quite useful when defining reusable components.

module Halogen.HTML.Target
  ( URL()
  , url
  , runURL

  , Target(..)
  , target
  ) where

import Control.Functor (($>))

import Control.Alt

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

-- | A type-safe wrapper for a URL
data URL = URL String

-- | Create a `URL`
url :: String -> URL
url = URL

-- | Unwrap a URL
runURL :: URL -> String
runURL (URL s) = s

-- | There are two types of target:
-- |
-- | - `LinkTarget` creates a target which links to a URL.
-- | - `DataTarget` creates a target which carries data which may be used to generate inputs or requests.
data Target a = LinkTarget URL | DataTarget a

-- | Attach a `Target` to an element using the `href` or `onclick` attribute as appropriate
target :: forall i. Target i -> [A.Attr i]
target (LinkTarget url) = [ A.href (runURL url) ]
target (DataTarget i) = [ A.href "#", E.onClick (\_ -> E.preventDefault $> i) ]


fixing tests

fixing tests

module Test.Main where

import Prelude
import App.Graph
import App.ColorScheme (ColorScheme(..))
import App.Cycle (Cycle(..), cut, joinCycles)
import App.Geometry (Point(..), Stroke(..), flip)
import App.Update (updateCycles)
import Data.List (List(..), singleton, (:))
import Data.Map (empty, insert, keys, lookup, showTree)
import Data.Maybe (Maybe(..))
import Data.Unfoldable (unfoldr)
import Test.Spec (describe, it)
import Test.Spec.Assertions (shouldEqual)
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Spec.Runner (run)

p1 = Point 1.0 0.0
p2 = Point 2.0 0.0
p3 = Point 3.0 0.0
p4 = Point 4.0 0.0

l12 = Line p1 p2
l23 = Line p2 p3
l34 = Line p3 p4
l41 = Line p4 p1

l21 = Line p2 p1
l32 = Line p3 p2
l43 = Line p4 p3
l14 = Line p1 p4

l31 = Line p3 p1
l13 = Line p1 p3
l42 = Line p4 p2
l24 = Line p2 p4

c1234 = Cycle $ l12 : l23 : l34 : l41 : Nil
c123 = Cycle $ l12 : l23 : l31 : Nil
c134 = Cycle $ l13 : l34 : l41 : Nil

g = addStroke l12
  $ addStroke l23
  $ emptyGraph

g2 = addStroke l31 g

g3 = addStroke l12
   $ addStroke l23
   $ addStroke l34
   $ addStroke l41
   $ addStroke l13
   $ emptyGraph

cycles = insert c1234 Red $ empty

main = run [consoleReporter] do
  describe "addStroke" do
    it "should insert strokes in both directions and in correct order" do
      keys g `shouldEqual` (p1 : p2 : p3 : Nil)
      lookup p2 g `shouldEqual` Just (flip l12 : l23 : Nil)

  describe "getNextEdges" do
    it "should generate the list of next edges to follow" do
      getNextEdges (singleton l12) g `shouldEqual` Nil
      getNextEdges (singleton l23) g `shouldEqual` (singleton $ flip l12)

  describe "unfoldr traverseRight" do
    it "should generate all traversals" do
      (unfoldr traverseRight $ Traversal (singleton $ singleton l23) g)
        `shouldEqual` ((singleton l23) : (l12 : l23 : Nil) : Nil)
      (unfoldr traverseRight $ Traversal (singleton $ singleton l12) g2)
        `shouldEqual` ((l12 : Nil) : (l31 : l12 : Nil) : (l23 : l31 : l12 : Nil) : Nil)

  describe "cutCycle" do
    it "should cut the cycle and orient it the right way" do
      cut c123 l13 `shouldEqual` (l32 : l21 : Nil)
      cut c134 (flip l13) `shouldEqual` (l14 : l43 : Nil)

  describe "joinCycles" do
    it "should join two cycles that share an edge" do
      joinCycles c123 c134 l13 `shouldEqual` c1234

  describe "findCycle" do
    it "should find the cycle!" do
      findCycle g l12 `shouldEqual` Nothing
      findCycle g2 l31 `shouldEqual` Just (Cycle (l12 : l23 : l31 : Nil))

  describe "findCycles" do
    it "should find all cycles!" do
      findCycles g `shouldEqual` Nil
      findCycles g2 `shouldEqual` (Cycle (l12 : l23 : l31 : Nil) : Nil)

  describe "updateCycles" do
    it "should split a cycle" do
      updateCycles cycles g3 empty (singleton l13) `shouldEqual` (insert c123 Red $ insert c134 Red $ empty)

module Test.Main where

import Prelude
import App.Graph
import App.ColorScheme (ColorScheme(..))
import App.Geometry (Point(..), Stroke(..), reverse)
import Data.List (List(..), singleton, (:))
import Data.Map (empty, insert, keys, lookup, showTree)
import Data.Maybe (Maybe(..))
import Data.Unfoldable (unfoldr)
import Test.Spec (describe, it)
import Test.Spec.Assertions (shouldEqual)
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Spec.Runner (run)

p1 = Point 1.0 0.0
p2 = Point 2.0 0.0
p3 = Point 3.0 0.0
p4 = Point 4.0 0.0

l12 = Line p1 p2
l23 = Line p2 p3
l34 = Line p3 p4
l41 = Line p4 p1

l21 = Line p2 p1
l32 = Line p3 p2
l43 = Line p4 p3
l14 = Line p1 p4

l31 = Line p3 p1
l13 = Line p1 p3
l42 = Line p4 p2
l24 = Line p2 p4

c1234 = Cycle $ l12 : l23 : l34 : l41 : Nil
c123 = Cycle $ l12 : l23 : l31 : Nil
c134 = Cycle $ l13 : l34 : l41 : Nil

g = addStroke l12
  $ addStroke l23
  $ emptyGraph

g2 = addStroke l31 g

g3 = addStroke l12
   $ addStroke l23
   $ addStroke l34
   $ addStroke l41
   $ addStroke l13
   $ emptyGraph

cycles = insert c1234 Red $ empty

main = run [consoleReporter] do
  describe "addStroke" do
    it "should insert strokes in both directions and in correct order" do
      keys g `shouldEqual` (p1 : p2 : p3 : Nil)
      lookup p2 g `shouldEqual` Just (reverse l12 : l23 : Nil)

  describe "getNextEdges" do
    it "should generate the list of next edges to follow" do
      getNextEdges (singleton l12) g `shouldEqual` Nil
      getNextEdges (singleton l23) g `shouldEqual` (singleton $ reverse l12)

  describe "unfoldr traverseRight" do
    it "should generate all traversals" do
      (unfoldr traverseRight $ Traversal (singleton $ singleton l23) g)
        `shouldEqual` ((singleton l23) : (l12 : l23 : Nil) : Nil)
      (unfoldr traverseRight $ Traversal (singleton $ singleton l12) g2)
        `shouldEqual` ((l12 : Nil) : (l31 : l12 : Nil) : (l23 : l31 : l12 : Nil) : Nil)

  describe "cutCycle" do
    it "should cut the cycle and orient it the right way" do
      cut c123 l13 `shouldEqual` (l32 : l21 : Nil)
      cut c134 (reverse l13) `shouldEqual` (l14 : l43 : Nil)

  describe "joinCycles" do
    it "should join two cycles that share an edge" do
      joinCycles c123 c134 l13 `shouldEqual` c1234

  describe "findCycle" do
    it "should find the cycle!" do
      findCycle g l12 `shouldEqual` Nothing
      findCycle g2 l31 `shouldEqual` Just (Cycle (l12 : l23 : l31 : Nil))

  describe "findCycles" do
    it "should find all cycles!" do
      findCycles g `shouldEqual` Nil
      findCycles g2 `shouldEqual` (Cycle (l12 : l23 : l31 : Nil) : Nil)

  describe "updateCycles" do
    it "should split a cycle" do
      updateCycles cycles g3 l13 `shouldEqual` (insert c123 Red $ insert c134 Red $ empty)


instance MonadThrow and MonadError for HandlerM

module Node.Express.Handler
    ( HandlerM(..)
    , Handler()
    , runHandlerM, next, nextThrow
    ) where

import Prelude

import Control.Monad.Aff (Aff, runAff_)
import Control.Monad.Aff.Class (class MonadAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Exception (Error)
import Data.Either (either)
import Data.Function.Uncurried (runFn2)
import Node.Express.Internal.Utils (nextWithError)
import Node.Express.Types (EXPRESS, ExpressM, Response, Request)
import Control.Monad.Error.Class (class MonadError, class MonadThrow, throwError, catchError)

-- | Monad responsible for handling single request.
newtype HandlerM e a = HandlerM (Request -> Response -> Eff e Unit -> Aff e a)

type Handler e = HandlerM (express :: EXPRESS | e) Unit

instance functorHandlerM :: Functor (HandlerM e) where
    map f (HandlerM h) = HandlerM \req resp nxt ->
        (h req resp nxt >>= \r -> pure $ f r)

instance applyHandlerM :: Apply (HandlerM e) where
    apply (HandlerM f) (HandlerM h) = HandlerM \req resp nxt -> do
        res   <- h req resp nxt
        trans <- f req resp nxt
        pure $ trans res

instance applicativeHandlerM :: Applicative (HandlerM e) where
    pure x = HandlerM \_ _ _ -> pure x

instance bindHandlerM :: Bind (HandlerM e) where
    bind (HandlerM h) f = HandlerM \req resp nxt -> do
        (HandlerM g) <- liftM1 f $ h req resp nxt
        g req resp nxt

instance monadHandlerM :: Monad (HandlerM e)

instance monadEffHandlerM :: MonadEff eff (HandlerM eff) where
    liftEff act = HandlerM \_ _ _ -> liftEff act

instance monadAffHandlerM :: MonadAff eff (HandlerM eff) where
    liftAff act = HandlerM \_ _ _ -> act

runHandlerM :: forall e. Handler e -> Request -> Response -> ExpressM e Unit -> ExpressM e Unit
runHandlerM (HandlerM h) req res nxt = void $ runAff_ (either (runFn2 nextWithError nxt) pure) (h req res nxt)

-- | Call next handler/middleware in a chain.
next :: forall e. Handler e
next = HandlerM \_ _ nxt -> liftEff nxt

-- | Call next handler/middleware and pass error to it.
nextThrow :: forall e a. Error -> HandlerM (express :: EXPRESS | e) a
nextThrow err = HandlerM \_ _ nxt ->
    liftEff $ runFn2 nextWithError nxt err

instance monadThrowHandlerM :: MonadThrow Error (HandlerM eff) where
    throwError err = HandlerM \_ _ nxt -> throwError err

instance monadErrorHandlerM ∷ MonadError Error (HandlerM eff) where
    catchError (HandlerM m) h = HandlerM $ \req res nxt ->
        catchError (m req res nxt) $ \e -> case h e of HandlerM m0 -> m0 req res nxt

module Node.Express.Handler
    ( HandlerM(..)
    , Handler()
    , runHandlerM, next, nextThrow
    ) where

import Prelude

import Control.Monad.Aff (Aff, runAff_)
import Control.Monad.Aff.Class (class MonadAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Exception (Error)
import Data.Either (either)
import Data.Function.Uncurried (runFn2)
import Node.Express.Internal.Utils (nextWithError)
import Node.Express.Types (EXPRESS, ExpressM, Response, Request)

-- | Monad responsible for handling single request.
newtype HandlerM e a = HandlerM (Request -> Response -> Eff e Unit -> Aff e a)

type Handler e = HandlerM (express :: EXPRESS | e) Unit

instance functorHandlerM :: Functor (HandlerM e) where
    map f (HandlerM h) = HandlerM \req resp nxt ->
        (h req resp nxt >>= \r -> pure $ f r)

instance applyHandlerM :: Apply (HandlerM e) where
    apply (HandlerM f) (HandlerM h) = HandlerM \req resp nxt -> do
        res   <- h req resp nxt
        trans <- f req resp nxt
        pure $ trans res

instance applicativeHandlerM :: Applicative (HandlerM e) where
    pure x = HandlerM \_ _ _ -> pure x

instance bindHandlerM :: Bind (HandlerM e) where
    bind (HandlerM h) f = HandlerM \req resp nxt -> do
        (HandlerM g) <- liftM1 f $ h req resp nxt
        g req resp nxt

instance monadHandlerM :: Monad (HandlerM e)

instance monadEffHandlerM :: MonadEff eff (HandlerM eff) where
    liftEff act = HandlerM \_ _ _ -> liftEff act

instance monadAffHandlerM :: MonadAff eff (HandlerM eff) where
    liftAff act = HandlerM \_ _ _ -> act

runHandlerM :: forall e. Handler e -> Request -> Response -> ExpressM e Unit -> ExpressM e Unit
runHandlerM (HandlerM h) req res nxt = void $ runAff_ (either (runFn2 nextWithError nxt) pure) (h req res nxt)

-- | Call next handler/middleware in a chain.
next :: forall e. Handler e
next = HandlerM \_ _ nxt -> liftEff nxt

-- | Call next handler/middleware and pass error to it.
nextThrow :: forall e a. Error -> HandlerM (express :: EXPRESS | e) a
nextThrow err = HandlerM \_ _ nxt ->
    liftEff $ runFn2 nextWithError nxt err


[RCD-48] explorer frontend: Update testnet link in footer

module Explorer.View.Footer (footerView) where

import Prelude

import Data.Foldable (for_)
import Data.Lens ((^.))
import Data.String (take)
import Explorer.I18n.Lang (Language, langCode, translate)
import Explorer.I18n.Lenses (footer, fooCardanoOpenSource, fooCardanoHub
  , fooCardanoChat, fooCardanoForum, fooDisclaimerPt1, fooDisclaimerPt2, fooCardanoFoundation
  , fooEmail, fooGithub, fooIohkSupportP, fooCardanoDocumentation, fooCardanoTestnet
  , fooCardanoSource, fooCardanoFoundationYoutube, fooCardanoFoundationTwitter
  , fooDaedalusPlatform, fooWhyCardano, fooCardanoRoadmap, fooCardanoReddit, fooCardanoCommunity
  , fooIOHK, fooIOHKBlog, fooIOHKYoutube, fooTwitter, fooProject, fooFoundation
  , fooLearnMore, fooProtocol) as I18nL
import Explorer.Lenses.State (lang, testnet)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (State)
import Explorer.Util.Config (commitHash, version)
import Explorer.View.Common (langItems)
import Pux.DOM.Events (onClick) as P
import Pux.DOM.HTML (HTML) as P
import Text.Smolder.HTML (div, nav, a, li, p, span, ul) as S
import Text.Smolder.HTML.Attributes (className, href, title) as S
import Text.Smolder.Markup ((!), (#!))
import Text.Smolder.Markup (text) as S

footerView :: State -> P.HTML Action
footerView state =
    let lang' = state ^. lang
        footerHiddenClazz = if (state ^. testnet) then " hide" else ""
    in
    S.div ! S.className ("explorer-footer" <> footerHiddenClazz) $ do
        S.div ! S.className "explorer-footer__top" $ do
            S.div ! S.className "explorer-footer__container" $ do
                S.div ! S.className "explorer-footer__top--content" $ do
                    S.div ! S.className "content__container content__container--left" $ do
                        langView
                        S.a ! S.className "nav__item--link link-open-source"
                            ! S.href "https://opensource.org/licenses/MIT"
                            $ S.text (translate (I18nL.footer <<< I18nL.fooCardanoOpenSource) lang')
                        S.p ! S.className "disclaimer"
                            $ S.text (translate (I18nL.footer <<< I18nL.fooDisclaimerPt1) lang')
                        S.p ! S.className "disclaimer"
                            $ S.text (translate (I18nL.footer <<< I18nL.fooDisclaimerPt2) lang')
                        navBottomListView $ navBottmItems lang'
                    S.div ! S.className "content__container content__container--right" $ do
                          socialListView $ socialItems lang'
                          S.nav ! S.className "nav__container" $ do
                              navListView $ navItemsLeft lang'
                              navListView $ navItemsRight lang'
        S.div ! S.className "explorer-footer__bottom" $ do
            S.div ! S.className "explorer-footer__container" $ do
                S.div ! S.className "logo__wrapper" $ do
                    S.div ! S.className "logo__container" $ do
                        S.a ! S.className "logo__cardano-name bg-logo-cardano-name"
                            ! S.href "//iohk.io/projects/cardano/"
                            $ S.text ""
                    S.span  ! S.className "split"
                            $ S.text ""
                    S.a ! S.className "support"
                        ! S.href "//iohk.io/projects/cardano/"
                        $ S.text (translate (I18nL.footer <<< I18nL.fooIohkSupportP) lang')
                    S.div ! S.className "logo__container"
                          $ S.a ! S.className "logo__iohk-name bg-iohk-logo"
                                ! S.href "//iohk.io/"
                                $ S.text ""
            S.div ! S.className "explorer-footer__container explorer-footer__meta" $ do
                S.span  ! S.className "version"
                        $ S.text ("v. " <> version)
                S.a ! S.className "commit"
                    ! S.href ("https://github.com/input-output-hk/cardano-sl/commit/" <> commitHash)
                    $ S.text $ "( " <> (take 7 $ commitHash) <> " )"

-- lang

-- TODO(jk) move lagn views into Common.purs

langView :: P.HTML Action
langView =
    S.ul  ! S.className "lang-nav__container"
          $ for_ langItems langItemView

langItemView :: Language -> P.HTML Action
langItemView lang' =
    let flagClazz = "bg-icon-lang-" <> langCode lang' in
    S.li ! S.className ("lang-nav__item " <> flagClazz )
        #! P.onClick (const $ SetLanguage lang')
        $ S.text (show lang')

-- social

type SocialItem =
    { link :: String
    , label :: String
    , iconClazz :: String
    }

socialItems :: Language -> Array SocialItem
socialItems lang =
    [ { label: translate (I18nL.footer <<< I18nL.fooTwitter) lang
      , link: "https://twitter.com/cardanostiftung"
      , iconClazz: "bg-icon-twitter"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooEmail) lang
      , link: "mailto:info@cardanohub.org"
      , iconClazz: "bg-icon-email"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooGithub) lang
      , link: "https://github.com/input-output-hk/cardano-sl/"
      , iconClazz: "bg-icon-github"
      }
    ]

socialListView :: Array SocialItem -> P.HTML Action
socialListView items =
    S.ul  ! S.className "social-nav__container"
          $ for_ items socialItemView

socialItemView :: SocialItem -> P.HTML Action
socialItemView item =
    S.li ! S.className "social-nav__item "
         $ S.a  ! S.className "social-nav__item--link"
                ! S.href item.link
                ! S.title item.label
                $ S.span  ! S.className ("icon "
                              <> item.iconClazz)
                          $ S.text ""

-- nav

type NavItem =
    { label :: String
    , link :: String
    }

navItemsLeft :: Language -> Array NavItem
navItemsLeft lang =
    [ { label: translate (I18nL.footer <<< I18nL.fooCardanoDocumentation) lang
      , link: "//cardanodocs.com"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooCardanoRoadmap) lang
      , link: "https://cardanoroadmap.com"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooCardanoTestnet) lang
      , link: "https://testnet.iohkdev.io"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooCardanoSource) lang
      , link: "https://github.com/input-output-hk/cardano-sl"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooCardanoFoundation) lang
      , link: "https://cardanofoundation.org"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooCardanoHub) lang
      , link: "https://cardanohub.org"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooWhyCardano) lang
      , link: "https://whycardano.com"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooCardanoFoundationYoutube) lang
      , link: "https://www.youtube.com/channel/UCbQ9vGfezru1YRI1zDCtTGg"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooCardanoFoundationTwitter) lang
      , link: "https://twitter.com/CardanoStiftung"
      }
    ]

navItemsRight :: Language -> Array NavItem
navItemsRight lang =
    [ { label: translate (I18nL.footer <<< I18nL.fooCardanoChat) lang
      , link: "https://chat.cardanohub.org/"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooCardanoForum) lang
      , link: "https://forum.cardanohub.org/"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooCardanoReddit) lang
      , link: "https://www.reddit.com/r/cardano/"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooCardanoCommunity) lang
      , link: "https://cardanohub.org"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooDaedalusPlatform) lang
      , link: "https://daedaluswallet.io"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooIOHK) lang
      , link: "https://iohk.io"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooIOHKBlog) lang
      , link: "https://iohk.io/blog/"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooIOHKYoutube) lang
      , link: "https://www.youtube.com/channel/UCBJ0p9aCW-W82TwNM-z3V2w"
      }
    ]

navListView :: Array NavItem -> P.HTML Action
navListView items =
    S.ul  ! S.className "nav__list"
          $ for_ items navItemView

navItemView :: NavItem -> P.HTML Action
navItemView item =
    S.li ! S.className "nav__item"
         $ S.a  ! S.className "nav__item--link"
                ! S.href item.link
                $ S.text item.label

navBottmItems :: Language -> Array NavItem
navBottmItems lang =
    [ { label: translate (I18nL.footer <<< I18nL.fooProject) lang
      , link: "https://cardanofoundation.org/project/"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooProtocol) lang
      , link: "https://cardanofoundation.org/protocol/"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooFoundation) lang
      , link: "https://cardanofoundation.org/foundation/"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooLearnMore) lang
      , link: "https://cardanofoundation.org/learn-more/"
      }
    ]

navBottomListView :: Array NavItem -> P.HTML Action
navBottomListView items =
    S.ul  ! S.className "nav-bottom__list"
          $ for_ items navBottomItemView

navBottomItemView :: NavItem -> P.HTML Action
navBottomItemView item =
    S.li ! S.className "nav-bottom__item"
         $ S.a  ! S.className "nav-bottom__item--link"
                ! S.href item.link
                $ S.text item.label

module Explorer.View.Footer (footerView) where

import Prelude

import Data.Foldable (for_)
import Data.Lens ((^.))
import Data.String (take)
import Explorer.I18n.Lang (Language, langCode, translate)
import Explorer.I18n.Lenses (footer, fooCardanoOpenSource, fooCardanoHub
  , fooCardanoChat, fooCardanoForum, fooDisclaimerPt1, fooDisclaimerPt2, fooCardanoFoundation
  , fooEmail, fooGithub, fooIohkSupportP, fooCardanoDocumentation, fooCardanoTestnet
  , fooCardanoSource, fooCardanoFoundationYoutube, fooCardanoFoundationTwitter
  , fooDaedalusPlatform, fooWhyCardano, fooCardanoRoadmap, fooCardanoReddit, fooCardanoCommunity
  , fooIOHK, fooIOHKBlog, fooIOHKYoutube, fooTwitter, fooProject, fooFoundation
  , fooLearnMore, fooProtocol) as I18nL
import Explorer.Lenses.State (lang, testnet)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (State)
import Explorer.Util.Config (commitHash, version)
import Explorer.View.Common (langItems)
import Pux.DOM.Events (onClick) as P
import Pux.DOM.HTML (HTML) as P
import Text.Smolder.HTML (div, nav, a, li, p, span, ul) as S
import Text.Smolder.HTML.Attributes (className, href, title) as S
import Text.Smolder.Markup ((!), (#!))
import Text.Smolder.Markup (text) as S

footerView :: State -> P.HTML Action
footerView state =
    let lang' = state ^. lang
        footerHiddenClazz = if (state ^. testnet) then " hide" else ""
    in
    S.div ! S.className ("explorer-footer" <> footerHiddenClazz) $ do
        S.div ! S.className "explorer-footer__top" $ do
            S.div ! S.className "explorer-footer__container" $ do
                S.div ! S.className "explorer-footer__top--content" $ do
                    S.div ! S.className "content__container content__container--left" $ do
                        langView
                        S.a ! S.className "nav__item--link link-open-source"
                            ! S.href "https://opensource.org/licenses/MIT"
                            $ S.text (translate (I18nL.footer <<< I18nL.fooCardanoOpenSource) lang')
                        S.p ! S.className "disclaimer"
                            $ S.text (translate (I18nL.footer <<< I18nL.fooDisclaimerPt1) lang')
                        S.p ! S.className "disclaimer"
                            $ S.text (translate (I18nL.footer <<< I18nL.fooDisclaimerPt2) lang')
                        navBottomListView $ navBottmItems lang'
                    S.div ! S.className "content__container content__container--right" $ do
                          socialListView $ socialItems lang'
                          S.nav ! S.className "nav__container" $ do
                              navListView $ navItemsLeft lang'
                              navListView $ navItemsRight lang'
        S.div ! S.className "explorer-footer__bottom" $ do
            S.div ! S.className "explorer-footer__container" $ do
                S.div ! S.className "logo__wrapper" $ do
                    S.div ! S.className "logo__container" $ do
                        S.a ! S.className "logo__cardano-name bg-logo-cardano-name"
                            ! S.href "//iohk.io/projects/cardano/"
                            $ S.text ""
                    S.span  ! S.className "split"
                            $ S.text ""
                    S.a ! S.className "support"
                        ! S.href "//iohk.io/projects/cardano/"
                        $ S.text (translate (I18nL.footer <<< I18nL.fooIohkSupportP) lang')
                    S.div ! S.className "logo__container"
                          $ S.a ! S.className "logo__iohk-name bg-iohk-logo"
                                ! S.href "//iohk.io/"
                                $ S.text ""
            S.div ! S.className "explorer-footer__container explorer-footer__meta" $ do
                S.span  ! S.className "version"
                        $ S.text ("v. " <> version)
                S.a ! S.className "commit"
                    ! S.href ("https://github.com/input-output-hk/cardano-sl/commit/" <> commitHash)
                    $ S.text $ "( " <> (take 7 $ commitHash) <> " )"

-- lang

-- TODO(jk) move lagn views into Common.purs

langView :: P.HTML Action
langView =
    S.ul  ! S.className "lang-nav__container"
          $ for_ langItems langItemView

langItemView :: Language -> P.HTML Action
langItemView lang' =
    let flagClazz = "bg-icon-lang-" <> langCode lang' in
    S.li ! S.className ("lang-nav__item " <> flagClazz )
        #! P.onClick (const $ SetLanguage lang')
        $ S.text (show lang')

-- social

type SocialItem =
    { link :: String
    , label :: String
    , iconClazz :: String
    }

socialItems :: Language -> Array SocialItem
socialItems lang =
    [ { label: translate (I18nL.footer <<< I18nL.fooTwitter) lang
      , link: "https://twitter.com/cardanostiftung"
      , iconClazz: "bg-icon-twitter"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooEmail) lang
      , link: "mailto:info@cardanohub.org"
      , iconClazz: "bg-icon-email"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooGithub) lang
      , link: "https://github.com/input-output-hk/cardano-sl/"
      , iconClazz: "bg-icon-github"
      }
    ]

socialListView :: Array SocialItem -> P.HTML Action
socialListView items =
    S.ul  ! S.className "social-nav__container"
          $ for_ items socialItemView

socialItemView :: SocialItem -> P.HTML Action
socialItemView item =
    S.li ! S.className "social-nav__item "
         $ S.a  ! S.className "social-nav__item--link"
                ! S.href item.link
                ! S.title item.label
                $ S.span  ! S.className ("icon "
                              <> item.iconClazz)
                          $ S.text ""

-- nav

type NavItem =
    { label :: String
    , link :: String
    }

navItemsLeft :: Language -> Array NavItem
navItemsLeft lang =
    [ { label: translate (I18nL.footer <<< I18nL.fooCardanoDocumentation) lang
      , link: "//cardanodocs.com"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooCardanoRoadmap) lang
      , link: "https://cardanoroadmap.com"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooCardanoTestnet) lang
      , link: "https://tada.iohk.io"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooCardanoSource) lang
      , link: "https://github.com/input-output-hk/cardano-sl"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooCardanoFoundation) lang
      , link: "https://cardanofoundation.org"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooCardanoHub) lang
      , link: "https://cardanohub.org"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooWhyCardano) lang
      , link: "https://whycardano.com"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooCardanoFoundationYoutube) lang
      , link: "https://www.youtube.com/channel/UCbQ9vGfezru1YRI1zDCtTGg"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooCardanoFoundationTwitter) lang
      , link: "https://twitter.com/CardanoStiftung"
      }
    ]

navItemsRight :: Language -> Array NavItem
navItemsRight lang =
    [ { label: translate (I18nL.footer <<< I18nL.fooCardanoChat) lang
      , link: "https://chat.cardanohub.org/"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooCardanoForum) lang
      , link: "https://forum.cardanohub.org/"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooCardanoReddit) lang
      , link: "https://www.reddit.com/r/cardano/"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooCardanoCommunity) lang
      , link: "https://cardanohub.org"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooDaedalusPlatform) lang
      , link: "https://daedaluswallet.io"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooIOHK) lang
      , link: "https://iohk.io"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooIOHKBlog) lang
      , link: "https://iohk.io/blog/"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooIOHKYoutube) lang
      , link: "https://www.youtube.com/channel/UCBJ0p9aCW-W82TwNM-z3V2w"
      }
    ]

navListView :: Array NavItem -> P.HTML Action
navListView items =
    S.ul  ! S.className "nav__list"
          $ for_ items navItemView

navItemView :: NavItem -> P.HTML Action
navItemView item =
    S.li ! S.className "nav__item"
         $ S.a  ! S.className "nav__item--link"
                ! S.href item.link
                $ S.text item.label

navBottmItems :: Language -> Array NavItem
navBottmItems lang =
    [ { label: translate (I18nL.footer <<< I18nL.fooProject) lang
      , link: "https://cardanofoundation.org/project/"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooProtocol) lang
      , link: "https://cardanofoundation.org/protocol/"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooFoundation) lang
      , link: "https://cardanofoundation.org/foundation/"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooLearnMore) lang
      , link: "https://cardanofoundation.org/learn-more/"
      }
    ]

navBottomListView :: Array NavItem -> P.HTML Action
navBottomListView items =
    S.ul  ! S.className "nav-bottom__list"
          $ for_ items navBottomItemView

navBottomItemView :: NavItem -> P.HTML Action
navBottomItemView item =
    S.li ! S.className "nav-bottom__item"
         $ S.a  ! S.className "nav-bottom__item--link"
                ! S.href item.link
                $ S.text item.label