extract partial array given a boolean arr

module KanColle.Expedition.New.EArray
  ( EArray()
  , mkEA
  , indEA
  , imapEA
  , unEA
  , extractEA
  ) where

import Prelude
import Partial.Unsafe
import Partial
import Data.Array as A
import Data.Array.Partial as AP
import Data.Traversable
import Data.Unfoldable
import Data.Tuple

-- array wrappered for all 40 expeditions
newtype EArray a = EA (Array a)

allExpeds :: Array Int
allExpeds = A.range 1 40

mkEA :: forall a. Array a -> EArray a
mkEA xs
    | A.length xs == 40 = EA xs
    | otherwise = unsafePartial (crash "expecting exactly 40 elements")

indEA :: forall a. EArray a -> Int -> a
indEA (EA xs) i
    | 1 <= i && i <= 40 = unsafePartial (AP.unsafeIndex xs (i-1))
    | otherwise = unsafePartial (crash "index out of range")

imapEA :: forall a b. (Int -> a -> b) -> EArray a -> EArray b
imapEA f (EA xs) = EA (A.zipWith f allExpeds xs)

unEA :: forall a. EArray a -> Array a
unEA (EA xs) = xs

-- is functor instance necessary?
instance functorEArray :: Functor EArray where
  map f (EA xs) = EA (map f xs)

pureEA :: forall a. a -> EArray a
pureEA =
    -- no need for passing through the smart constructor
    -- at the cost of being more careful about our code
    replicate 40 >>> EA

appEA :: forall a b. EArray (a -> b) -> EArray a -> EArray b
appEA (EA fs) (EA xs) = EA (A.zipWith ($) fs xs)

extractEA :: forall a. EArray Boolean -> EArray a -> Array a
extractEA (EA bs) (EA xs) = map snd (A.filter fst (A.zip bs xs))

instance applyEArray :: Apply EArray where
  apply = appEA

instance applicativeEArray :: Applicative EArray where
  pure = pureEA

instance foldableEArray :: Foldable EArray where
  foldr f z (EA xs) = foldr f z xs
  foldl f z (EA xs) = foldl f z xs
  foldMap f (EA xs) = foldMap f xs

instance traversableEArray :: Traversable EArray where
  traverse f (EA xs) = EA <$> traverse f xs
  sequence (EA ms) = EA <$> sequence ms

module KanColle.Expedition.New.EArray
  ( EArray()
  , mkEA
  , indEA
  , imapEA
  , unEA
  ) where

import Prelude
import Partial.Unsafe
import Partial
import Data.Array as A
import Data.Array.Partial as AP
import Data.Traversable
import Data.Unfoldable

-- array wrappered for all 40 expeditions
newtype EArray a = EA (Array a)

allExpeds :: Array Int
allExpeds = A.range 1 40

mkEA :: forall a. Array a -> EArray a
mkEA xs
    | A.length xs == 40 = EA xs
    | otherwise = unsafePartial (crash "expecting exactly 40 elements")

indEA :: forall a. EArray a -> Int -> a
indEA (EA xs) i
    | 1 <= i && i <= 40 = unsafePartial (AP.unsafeIndex xs (i-1))
    | otherwise = unsafePartial (crash "index out of range")

imapEA :: forall a b. (Int -> a -> b) -> EArray a -> EArray b
imapEA f (EA xs) = EA (A.zipWith f allExpeds xs)

unEA :: forall a. EArray a -> Array a
unEA (EA xs) = xs

-- is functor instance necessary?
instance functorEArray :: Functor EArray where
  map f (EA xs) = EA (map f xs)

pureEA :: forall a. a -> EArray a
pureEA =
    -- no need for passing through the smart constructor
    -- at the cost of being more careful about our code
    replicate 40 >>> EA

appEA :: forall a b. EArray (a -> b) -> EArray a -> EArray b
appEA (EA fs) (EA xs) = EA (A.zipWith ($) fs xs)

instance applyEArray :: Apply EArray where
  apply = appEA

instance applicativeEArray :: Applicative EArray where
  pure = pureEA

instance foldableEArray :: Foldable EArray where
  foldr f z (EA xs) = foldr f z xs
  foldl f z (EA xs) = foldl f z xs
  foldMap f (EA xs) = foldMap f xs

instance traversableEArray :: Traversable EArray where
  traverse f (EA xs) = EA <$> traverse f xs
  sequence (EA ms) = EA <$> sequence ms


Cleanup, add foldWithEffect

Cleanup, add foldWithEffect

module Run
  ( Run(..)
  , run
  , runBase
  , runBaseWithCont
  , runWithBase
  , runWithEffect
  , interpretWithBase
  , interpretWithEffect
  , foldWithEffect
  , liftEffect
  , liftBase
  , peel
  , send
  , expand
  , BaseEff
  , BaseAff
  , module Data.Functor.Variant
  , module Exports
  ) where

import Prelude

import Control.Monad.Aff (Aff)
import Control.Monad.Aff.Class (class MonadAff, liftAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Free (Free, liftF, runFree, foldFree, resume')
import Control.Monad.Rec.Class (class MonadRec, Step(..))
import Data.Either (Either(..))
import Data.Functor.Variant (VariantF, FProxy(..), inj, on, case_, default)
import Data.Newtype (class Newtype, unwrap)
import Data.Symbol (SProxy(..)) as Exports
import Data.Symbol (SProxy(..), class IsSymbol)
import Data.Tuple (Tuple, uncurry)
import Partial.Unsafe (unsafeCrashWith)
import Type.Equality (class TypeEquals)
import Unsafe.Coerce (unsafeCoerce)

-- | An extensible effect Monad, indexed by a set of effect functors. Effects
-- | are eliminated by interpretation into a pure value or into some base
-- | effect Monad. The `Run` Monad is an alternative to Monad Transformers.
-- |
-- | An example using `State` and `Except`:
-- | ```purescript
-- | type MyEffects =
-- |   ( state ∷ STATE Int
-- |   , except ∷ EXCEPT String
-- |   , base ∷ BaseEff (console ∷ CONSOLE)
-- |   )
-- |
-- | yesProgram ∷ Run MyEffects Unit
-- | yesProgram = do
-- |   whenM (gets (_ < 0)) do
-- |     throw "Number is less than 0"
-- |   whileM_ (gets (_ > 0)) do
-- |     liftEff $ log "Yes"
-- |     modify (_ - 1)
-- |
-- | main =
-- |   yesProgram
-- |     # catch (liftEff <<< log)
-- |     # runState 10
-- |     # runBase
-- |     # void
-- | ````
newtype Run (r ∷ # Type) a = Run (Free (VariantF r) a)

derive instance newtypeRun ∷ Newtype (Run r a) _
derive newtype instance functorRun :: Functor (Run r)
derive newtype instance applyRun :: Apply (Run r)
derive newtype instance applicativeRun :: Applicative (Run r)
derive newtype instance bindRun :: Bind (Run r)
derive newtype instance monadRun :: Monad (Run r)

-- | Lifts an effect functor into the `Run` Monad according to the provided
-- | `SProxy` slot.
liftEffect
  ∷ ∀ sym r1 r2 f a
  . RowCons sym (FProxy f) r1 r2
  ⇒ IsSymbol sym
  ⇒ Functor f
  ⇒ SProxy sym
  → f a
  → Run r2 a
liftEffect p = Run <<< liftF <<< inj p

-- | Lifts a base effect into the `Run` Monad (eg. `Eff`, `Aff`, or `IO`).
liftBase
  ∷ ∀ r f a
  . Functor f
  ⇒ f a
  → Run (base ∷ FProxy f | r) a
liftBase = Run <<< liftF <<< inj (SProxy ∷ SProxy "base")

-- | Reflects the next instruction or the final value if there are no more
-- | instructions.
peel
  ∷ ∀ a r
  . Run r a
  → Either (VariantF r (Run r a)) a
peel = resume Left Right

resume
  ∷ ∀ a b r
  . (VariantF r (Run r a) → b)
  → (a → b)
  → Run r a
  → b
resume k1 k2 = resume' (\x f → k1 (Run <<< f <$> x)) k2 <<< unwrap

-- | Enqueues an instruction in the `Run` Monad.
send
  ∷ ∀ a r
  . VariantF r a
  → Run r a
send = Run <<< liftF

-- | Casts some set of effects to a wider set of effects via a left-biased
-- | union. For example, you could take a closed effect and unify it with
-- | a superset of effects because we know the additional effects never
-- | occur.
expand
  ∷ ∀ r1 r2 rx a
  . Union r1 rx r2
  ⇒ Run r1 a
  → Run r2 a
expand = unsafeCoerce

-- | Extracts the value from a fully interpreted program.
run ∷ ∀ a. Run () a → a
run = unwrap >>> runFree \_ → unsafeCrashWith "Control.Monad.Run: the impossible happened"

unBase ∷ ∀ f. VariantF (base ∷ FProxy f) ~> f
unBase = case_ # on (SProxy ∷ SProxy "base") id

-- | Extracts the value from a program with only base effects. This assumes
-- | stack safety under Monadic recursion.
runBase
  ∷ ∀ f a
  . Monad f
  ⇒ Run (base ∷ FProxy f) a
  → f a
runBase = loop
  where
  loop ∷ Run (base ∷ FProxy f) a → f a
  loop = resume (\b → loop =<< unBase b) pure

-- | Extracts the value from a program with only base effects using `MonadRec`
-- | to preserve stack safety.
runBaseRec
  ∷ ∀ f a
  . MonadRec f
  ⇒ Run (base ∷ FProxy f) a
  → f a
runBaseRec = foldFree unBase <<< unwrap

-- | Interprets the base effect into some Monad `m` via continuation passing.
runBaseWithCont
  ∷ ∀ f m a b
  . Monad m
  ⇒ (f (m b) → m b)
  → (a → m b)
  → Run (base ∷ FProxy f) a
  → m b
runBaseWithCont k1 k2 = loop
  where
  loop ∷ Run (base ∷ FProxy f) a → m b
  loop = resume (\b -> k1 (unBase (loop <$> b))) k2

-- | Interprets an effect functor into the base effect via a natural
-- | transformation, eliminating the label.
interpretWithBase
  ∷ ∀ sym f m r1 r2 a
  . RowCons sym (FProxy f) (base ∷ FProxy m | r2) r1
  ⇒ IsSymbol sym
  ⇒ Functor m
  ⇒ SProxy sym
  → (f ~> m)
  → Run r1 a
  → Run (base ∷ FProxy m | r2) a
interpretWithBase = runWithBase

-- | The same as `interpretWithBase`, but with a less restrictive type for the
-- | interpreter.
runWithBase
  ∷ ∀ sym f m r1 r2 a
  . RowCons sym (FProxy f) (base ∷ FProxy m | r2) r1
  ⇒ IsSymbol sym
  ⇒ Functor m
  ⇒ SProxy sym
  → (f (Run r1 a) → m (Run r1 a))
  → Run r1 a
  → Run (base ∷ FProxy m | r2) a
runWithBase p k = runWithEffect p (liftBase <<< k)

-- | Interprets an effect functor in terms of other `Run` effects, eliminating
-- | the label.
interpretWithEffect
  ∷ ∀ sym f r1 r2 a
  . RowCons sym (FProxy f) r2 r1
  ⇒ IsSymbol sym
  ⇒ SProxy sym
  → (f ~> Run r2)
  → Run r1 a
  → Run r2 a
interpretWithEffect = runWithEffect

-- | The same as `interpretWithEffect` but with a less restrictive type for the
-- | interpreter.
runWithEffect
  ∷ ∀ sym f r1 r2 a
  . RowCons sym (FProxy f) r2 r1
  ⇒ IsSymbol sym
  ⇒ SProxy sym
  → (f (Run r1 a) → Run r2 (Run r1 a))
  → Run r1 a
  → Run r2 a
runWithEffect p k = loop
  where
  handle ∷ VariantF r1 (Run r1 a) → Run r2 (Run r1 a)
  handle = on p k send

  loop ∷ Run r1 a → Run r2 a
  loop = resume (\b → handle b >>= loop) pure

-- | Interprets an effect in terms of other `Run` effects with an internal
-- | accumulator.
foldWithEffect
  ∷ ∀ sym f r1 r2 s a b
  . RowCons sym (FProxy f) r2 r1
  ⇒ IsSymbol sym
  ⇒ SProxy sym
  → (s → f (Run r1 a) → Run r2 (Tuple s (Run r1 a)))
  → Run r2 s
  → Run r1 a
  → Run r2 a
foldWithEffect p k init r = init >>= flip loop r
  where
  handle ∷ s → VariantF r1 (Run r1 a) → Run r2 a
  handle acc =
    on p
      (k acc >=> uncurry loop)
      (send >=> loop acc)

  loop ∷ s → Run r1 a → Run r2 a
  loop acc = resume (handle acc) pure

data R (r ∷ # Type)

-- Type synonym for using `Eff` as a base effect.
type BaseEff eff = FProxy (Eff eff)

-- Type synonym for using `Aff` as a base effect.
type BaseAff eff = FProxy (Aff eff)

instance monadRecRun ∷ MonadRec (Run r) where
  tailRecM f = loop
    where
    loop a = do
      b ← f a
      case b of
        Done r → pure r
        Loop n → loop n

instance monadEffRun ∷ (TypeEquals (R rs) (R (base ∷ FProxy m | r)), MonadEff eff m) ⇒ MonadEff eff (Run rs) where
  liftEff = coerceR <<< liftBase <<< liftEff
    where
    coerceR ∷ Run (base ∷ FProxy m | r) ~> Run rs
    coerceR = unsafeCoerce

instance monadAffRun ∷ (TypeEquals (R rs) (R (base ∷ FProxy m | r)), MonadAff eff m) ⇒ MonadAff eff (Run rs) where
  liftAff = coerceR <<< liftBase <<< liftAff
    where
    coerceR ∷ Run (base ∷ FProxy m | r) ~> Run rs
    coerceR = unsafeCoerce

module Run
  ( Run
  , run
  , runBase
  , runBaseWithCont
  , runWithBase
  , runWithEffect
  , liftEffect
  , liftBase
  , peel
  , send
  , expand
  , BaseEff
  , BaseAff
  , module Data.Functor.Variant
  , module Exports
  ) where

import Prelude

import Control.Monad.Aff (Aff)
import Control.Monad.Aff.Class (class MonadAff, liftAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Free (Free, liftF, runFree, foldFree, resume')
import Control.Monad.Rec.Class (class MonadRec, Step(..))
import Data.Either (Either(..))
import Data.Functor.Variant (VariantF, FProxy(..), inj, on, case_, default)
import Data.Newtype (class Newtype, unwrap)
import Data.Symbol (SProxy(..)) as Exports
import Data.Symbol (SProxy(..), class IsSymbol)
import Partial.Unsafe (unsafeCrashWith)
import Type.Equality (class TypeEquals)
import Unsafe.Coerce (unsafeCoerce)

-- | An extensible effect Monad, indexed by a set of effect functors. Effects
-- | are eliminated by interpretation into a pure value or into some base
-- | effect Monad. The `Run` Monad is an alternative to Monad Transformers,
-- | and can represent both associative and non-associative effects.
-- |
-- | An example using `State` and `Except`:
-- | ```purescript
-- | type MyEffects =
-- |   ( state ∷ STATE Int
-- |   , except ∷ EXCEPT String
-- |   , base ∷ BaseEff (console ∷ CONSOLE)
-- |   )
-- |
-- | yesProgram ∷ Run MyEffects Unit
-- | yesProgram = do
-- |   whenM (gets (_ < 0)) do
-- |     throw "Number is less than 0"
-- |   whileM_ (gets (_ > 0)) do
-- |     liftEff $ log "Yes"
-- |     modify (_ - 1)
-- |
-- | main =
-- |   yesProgram
-- |     # catch (liftEff <<< log)
-- |     # runState 10
-- |     # runBase
-- |     # void
-- | ````
newtype Run (r ∷ # Type) a = RunM (Free (VariantF r) a)

derive instance newtypeRun ∷ Newtype (Run r a) _
derive newtype instance functorRun :: Functor (Run r)
derive newtype instance applyRun :: Apply (Run r)
derive newtype instance applicativeRun :: Applicative (Run r)
derive newtype instance bindRun :: Bind (Run r)
derive newtype instance monadRun :: Monad (Run r)

-- | Lifts an effect functor into the `Run` Monad according to the provided
-- | `SProxy` slot.
liftEffect
  ∷ ∀ sym r1 r2 f a
  . RowCons sym (FProxy f) r1 r2
  ⇒ IsSymbol sym
  ⇒ Functor f
  ⇒ SProxy sym
  → f a
  → Run r2 a
liftEffect p = RunM <<< liftF <<< inj p

-- | Lifts a base effect into the `Run` Monad (eg. `Eff`, `Aff`, or `IO`).
liftBase
  ∷ ∀ r f a
  . Functor f
  ⇒ f a
  → Run (base ∷ FProxy f | r) a
liftBase = RunM <<< liftF <<< inj (SProxy ∷ SProxy "base")

-- | Reflects the next instruction or the final value if there are no more
-- | instructions.
peel
  ∷ ∀ a r
  . Run r a
  → Either (VariantF r (Run r a)) a
peel = unwrap >>> resume' (\b f → Left (RunM <<< f <$> b)) Right

-- | Enqueues an instruction in the `Run` Monad.
send
  ∷ ∀ a r
  . VariantF r a
  → Run r a
send = RunM <<< liftF

-- | Casts some set of effects to a wider set of effects via a left-biased
-- | union.
expand
  ∷ ∀ r1 r2 rx a
  . Union r1 rx r2
  ⇒ Run r1 a
  → Run r2 a
expand = unsafeCoerce

-- | Extracts the value from a fully interpreted program.
run ∷ ∀ a. Run () a → a
run = unwrap >>> runFree \_ → unsafeCrashWith "Control.Monad.Run: the impossible happened"

unBase ∷ ∀ f. VariantF (base ∷ FProxy f) ~> f
unBase = case_ # on (SProxy ∷ SProxy "base") id

-- | Extracts the value from a program with only base effects. This assumes
-- | stack safety under Monadic recursion.
runBase
  ∷ ∀ f a
  . Monad f
  ⇒ Run (base ∷ FProxy f) a
  → f a
runBase = unwrap >>> loop
  where
  loop = resume' (\b f → f <$> unBase b >>= loop) pure

-- | Extracts the value from a program with only base effects using `MonadRec`
-- | to preserve stack safety.
runBaseRec
  ∷ ∀ f a
  . MonadRec f
  ⇒ Run (base ∷ FProxy f) a
  → f a
runBaseRec = unwrap >>> foldFree unBase

-- | Interprets the base effect into some Monad `m` via continuation passing.
runBaseWithCont
  ∷ ∀ f m a b
  . Monad m
  ⇒ (f (Unit → m b) → m b)
  → (a → m b)
  → Run (base ∷ FProxy f) a
  → m b
runBaseWithCont k1 k2 = unwrap >>> loop
  where
  loop = resume' (\b f → k1 (unBase $ (\b' _ → loop (f b')) <$> b)) k2

-- | Interprets an effect functor into the base effect, eliminating the label.
runWithBase
  ∷ ∀ sym f m r1 r2 a
  . RowCons sym (FProxy f) (base ∷ FProxy m | r2) r1
  ⇒ IsSymbol sym
  ⇒ Functor m
  ⇒ SProxy sym
  → (f (Run r1 a) → m (Run r1 a))
  → Run r1 a
  → Run (base ∷ FProxy m | r2) a
runWithBase p k = runWithEffect p (liftBase <<< k)

-- | Interprets an effect functor in terms of other `Run` effects, eliminating
-- | the label.
runWithEffect
  ∷ ∀ sym f r1 r2 a
  . RowCons sym (FProxy f) r2 r1
  ⇒ IsSymbol sym
  ⇒ SProxy sym
  → (f (Run r1 a) → Run r2 (Run r1 a))
  → Run r1 a
  → Run r2 a
runWithEffect p k = loop
  where
  handle = on p k send
  loop   = unwrap >>> resume' (\b f → handle (RunM <<< f <$> b) >>= loop) pure

data R (r ∷ # Type)

-- Type synonym for using `Eff` as a base effect.
type BaseEff eff = FProxy (Eff eff)

-- Type synonym for using `Aff` as a base effect.
type BaseAff eff = FProxy (Aff eff)

instance monadRecRun ∷ MonadRec (Run r) where
  tailRecM f = loop
    where
    loop a = do
      b ← f a
      case b of
        Done r → pure r
        Loop n → loop n

instance monadEffRun ∷ (TypeEquals (R rs) (R (base ∷ FProxy m | r)), MonadEff eff m) ⇒ MonadEff eff (Run rs) where
  liftEff = coerceR <<< liftBase <<< liftEff
    where
    coerceR ∷ Run (base ∷ FProxy m | r) ~> Run rs
    coerceR = unsafeCoerce

instance monadAffRun ∷ (TypeEquals (R rs) (R (base ∷ FProxy m | r)), MonadAff eff m) ⇒ MonadAff eff (Run rs) where
  liftAff = coerceR <<< liftBase <<< liftAff
    where
    coerceR ∷ Run (base ∷ FProxy m | r) ~> Run rs
    coerceR = unsafeCoerce


Keyboard controls now move the rendered camera position.

-- | Functions for converting the simulation state into pixels on the screen
module Jundo.Rendering (
  RenderingContext(),
  initialiseWebGL,
  render
  ) where

import Prelude
import Jundo.Cube
import Jundo.Shaders
import Jundo.Simulation
import Jundo.Vectors
import Control.Monad.Eff
import Control.Monad.Eff.Exception
import Data.ArrayBuffer.Types (Float32Array())
import Data.Int (toNumber)
import Data.Int.Bits ((.|.))
import Data.Matrix (toArray)
import Data.Matrix4
import Data.Tuple
import Data.TypedArray (asFloat32Array)
import qualified Data.Vector as V
import Data.Vector3 (vec3, Vec3(), i3, j3)
import Data.Vector4
import qualified DOM as D
import qualified DOM.Node.Element.Experimental as D
import qualified DOM.Node.Types as D
import Graphics.WebGL.Context
import Graphics.WebGL.Free
import Graphics.WebGL.Raw.Types
import Graphics.Canvas (Canvas(), CanvasElement(), setCanvasDimensions)
import Math

-- | The matrix library is based on plain JavaScript arrays. Extract the backing array from the matrix and convert
-- | it to a typed array so we can use it with WebGL.
matrixToFloat32Array :: Mat4 -> Float32Array
matrixToFloat32Array = asFloat32Array <<< toArray

cubeModelMatrix :: CubeState -> Mat4
cubeModelMatrix cs = mulM (makeTranslate cs.position) (makeRotate cs.angle j3)

viewMatrix :: CameraState -> Mat4
viewMatrix cs = mulM rotationMatrix translationMatrix
  where
  rotationMatrix = mulM (makeRotate cs.pitch (rotateVec3 j3 cs.yaw i3)) (makeRotate cs.yaw j3)
  translationMatrix = makeTranslate $ V.scale (-1.0) cs.position

-- | Get the cube's model view matrix from the simulation state
cubeMVMatrix :: SimulationState -> Float32Array
cubeMVMatrix state = matrixToFloat32Array $ mulM (viewMatrix state.camera) (cubeModelMatrix state.cube)

-- | Get a perspective matrix as a typed array for the given buffer dimensions
perspectiveMatrix :: Int -> Int -> Float32Array
perspectiveMatrix width height = matrixToFloat32Array $ makePerspective 45.0 (toNumber width / toNumber height) 0.1 100.0

-- | Type to hold canvas properties such as the WebGL context and references to shader program variables
newtype RenderingContext = RenderingContext {
  canvas :: CanvasElement,
  el :: D.Element,
  gl :: WebGLContext,
  program :: WebGLProgram,
  shaderVariables :: ShaderVariables,
  cubeBuffers :: CubeBuffers
  }

-- | Perform initial set up of the canvas, returning a context containing variables required by the render function
initialiseWebGL :: forall eff. D.Element -> CanvasElement -> Eff (canvas :: Canvas, dom :: D.DOM, err :: EXCEPTION | eff) RenderingContext
initialiseWebGL el canvas = do
  gl <- getWebGLContext canvas
  Tuple program shaderVariables <- initialiseShaderProgram gl
  cubeBuffers <- runWebGL gl do
    clearColor 0.0 0.0 0.0 1.0
    enable depthTest
    depthFunc lequal
    initialiseBuffers program
  return $ RenderingContext {gl: gl, canvas: canvas, el: el, shaderVariables: shaderVariables, cubeBuffers: cubeBuffers, program: program}

-- | Render the simulation state to the canvas
render :: forall eff. RenderingContext -> SimulationState -> Eff (canvas :: Canvas, dom :: D.DOM | eff) Unit
render (RenderingContext ctx) simulationState = do
  -- Update the canvas dimensions in case the element dimensions have changed
  height <- D.clientHeight $ ctx.el
  width <- D.clientWidth $ ctx.el
  setCanvasDimensions {height: toNumber height, width: toNumber width} ctx.canvas

  runWebGL ctx.gl do
    -- Update the WebGL viewport dimensions to match the available drawing buffer
    bufferHeight <- getDrawingBufferHeight
    bufferWidth <- getDrawingBufferWidth
    viewport 0 0 bufferWidth bufferHeight

    -- Clear the canvas
    clear $ colorBufferBit .|. depthBufferBit

    -- Draw the cube!
    programOperation ctx.program do
      uniformMatrix4fv ctx.shaderVariables.pMatrix false $ perspectiveMatrix bufferWidth bufferHeight
      uniformMatrix4fv ctx.shaderVariables.mvMatrix false $ cubeMVMatrix simulationState
      arrayBufferOperation ctx.cubeBuffers.vertex $ vertexAttribPointer ctx.shaderVariables.aVertex 3 false 0 0
      elementArrayBufferOperation ctx.cubeBuffers.index $ drawElements triangles 36 0
  return unit

-- | Functions for converting the simulation state into pixels on the screen
module Jundo.Rendering (
  RenderingContext(),
  initialiseWebGL,
  render
  ) where

import Prelude
import Jundo.Cube
import Jundo.Shaders
import Jundo.Simulation
import Jundo.Vectors
import Control.Monad.Eff
import Control.Monad.Eff.Exception
import Data.ArrayBuffer.Types (Float32Array())
import Data.Int (toNumber)
import Data.Int.Bits ((.|.))
import Data.Matrix
import Data.Matrix4
import Data.Tuple
import Data.TypedArray (asFloat32Array)
import Data.Vector3 (vec3, Vec3(), i3, j3)
import Data.Vector4
import qualified DOM as D
import qualified DOM.Node.Element.Experimental as D
import qualified DOM.Node.Types as D
import Graphics.WebGL.Context
import Graphics.WebGL.Free
import Graphics.WebGL.Raw.Types
import Graphics.Canvas (Canvas(), CanvasElement(), setCanvasDimensions)
import Math

-- | The matrix library is based on plain JavaScript arrays. Extract the backing array from the matrix and convert
-- | it to a typed array so we can use it with WebGL.
matrixToFloat32Array :: Mat4 -> Float32Array
matrixToFloat32Array = asFloat32Array <<< toArray

cubeModelMatrix :: CubeState -> Mat4
cubeModelMatrix cs = mulM (makeTranslate cs.position) (makeRotate cs.angle j3)

viewMatrix :: Radians -> Radians -> Mat4
viewMatrix pitch yaw = mulM (makeRotate pitch (rotateVec3 j3 yaw i3)) (makeRotate yaw j3)

-- | Get the cube's model view matrix from the camera and cube angles
cubeMVMatrix :: CubeState -> Radians -> Radians -> Float32Array
cubeMVMatrix cs pitch yaw = matrixToFloat32Array $ mulM (viewMatrix pitch yaw) (cubeModelMatrix cs)

-- | Get a perspective matrix as a typed array for the given buffer dimensions
perspectiveMatrix :: Int -> Int -> Float32Array
perspectiveMatrix width height = matrixToFloat32Array $ makePerspective 45.0 (toNumber width / toNumber height) 0.1 100.0

-- | Type to hold canvas properties such as the WebGL context and references to shader program variables
newtype RenderingContext = RenderingContext {
  canvas :: CanvasElement,
  el :: D.Element,
  gl :: WebGLContext,
  program :: WebGLProgram,
  shaderVariables :: ShaderVariables,
  cubeBuffers :: CubeBuffers
  }

-- | Perform initial set up of the canvas, returning a context containing variables required by the render function
initialiseWebGL :: forall eff. D.Element -> CanvasElement -> Eff (canvas :: Canvas, dom :: D.DOM, err :: EXCEPTION | eff) RenderingContext
initialiseWebGL el canvas = do
  gl <- getWebGLContext canvas
  Tuple program shaderVariables <- initialiseShaderProgram gl
  cubeBuffers <- runWebGL gl do
    clearColor 0.0 0.0 0.0 1.0
    enable depthTest
    depthFunc lequal
    initialiseBuffers program
  return $ RenderingContext {gl: gl, canvas: canvas, el: el, shaderVariables: shaderVariables, cubeBuffers: cubeBuffers, program: program}

-- | Render the simulation state to the canvas
render :: forall eff. RenderingContext -> SimulationState -> Eff (canvas :: Canvas, dom :: D.DOM | eff) Unit
render (RenderingContext ctx) {cube: cubeState, camera: cameraState} = do
  -- Update the canvas dimensions in case the element dimensions have changed
  height <- D.clientHeight $ ctx.el
  width <- D.clientWidth $ ctx.el
  setCanvasDimensions {height: toNumber height, width: toNumber width} ctx.canvas

  runWebGL ctx.gl do
    -- Update the WebGL viewport dimensions to match the available drawing buffer
    bufferHeight <- getDrawingBufferHeight
    bufferWidth <- getDrawingBufferWidth
    viewport 0 0 bufferWidth bufferHeight

    -- Clear the canvas
    clear $ colorBufferBit .|. depthBufferBit

    -- Draw the cube!
    programOperation ctx.program do
      uniformMatrix4fv ctx.shaderVariables.pMatrix false $ perspectiveMatrix bufferWidth bufferHeight
      uniformMatrix4fv ctx.shaderVariables.mvMatrix false $ cubeMVMatrix cubeState cameraState.pitch cameraState.yaw
      arrayBufferOperation ctx.cubeBuffers.vertex $ vertexAttribPointer ctx.shaderVariables.aVertex 3 false 0 0
      elementArrayBufferOperation ctx.cubeBuffers.index $ drawElements triangles 36 0
  return unit


Change comment style

Change comment style

{-

# Transform a `ExpandedOptionsLayout` into a `SolvedLayout`

This transform expands `[...-options]` reference tags into real options.
This transform must be careful not to expand options that are already
present in the same "free" grouping. We define a "free" grouping of such
elements whose position does not matter.

Since `[...-options]` reference tags strictly evaluate to "free" elements,
that is short- and long options (practically speaking), the position of
insertion does *NOT* matter, that is it must not necessarily occur in place
of the actual tag, as long as it is within the same grouping.

The method of performing this transform is roughly as follows, where
`<* E...  *>` denotes an "free" chunk of elements `E` and
`<! E...  !>` denotes an "fixed" chunk of elements `E`:

Each top-level branch is solved independently. Given the following
help text:

  usage: prog foo -a [-b (-d -e)] [options] [-f] bar
    or: prog foo bar --qux
  options:
    -d
    -z

We proceed as follows (for each top-level):

1. flatten the entire top-level and annotate each element w/ it's index:

  prog foo -a [-b (-d -e)] [options] [-f] bar

  becomes:

  prog (1:foo) (2:-a) (3:-b) (4:-d) (5:-e) (6:[options]) (7:-f) (8:bar)

2. we chunk the output, such that "free" elements appear next to one
   another:

  prog <!(1:foo)!> <*(2:-a) (3:-b) (4:-d) (5:-e) (6:[options]) (7:-f)*>
       <!(8:bar)!>

3. we then expand any `[options]` elements into it's surrounding. We must make
sure not to expand an option into it's surrounding that is already present.
since the options section defined an `-d` (see above), but it is already present
in the surrounding area, we only expand `-z`

  prog <!(1:foo)!> <*(2:-a) (3:-b) (4:-d) (5:-e) (6:[options: -z]) (7:-f)*>
       <!(8:bar)!>

4. finally, we apply expansion to the actual tree, using the indices as lookups
into the tree structure:

  prog foo -a [-b (-d -e)] ([-z]) [-f] bar

-}

module Neodoc.Solve.ExpandReferences where

import Prelude

import Debug.Trace
import Data.Either (Either(..))
import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.Traversable (traverse, for)
import Data.NonEmpty (NonEmpty, (:|))
import Data.NonEmpty.Extra as NonEmpty
import Data.Map as Map
import Data.List (List(..), (:), fromFoldable, length, catMaybes, concat, filter)
import Data.Tuple (Tuple, fst, snd)
import Data.Tuple.Nested ((/\))
import Data.Foldable (any, intercalate)
import Data.Pretty
import Control.Monad.State
import Control.Monad.State as State
import Control.MonadPlus.Partial (mrights, mlefts, mpartition)
import Control.Comonad (extract)

import Neodoc.Spec
import Neodoc.Data.SolvedLayout
import Neodoc.Data.SolvedLayout as Solved
import Neodoc.Data.EmptyableLayout
import Neodoc.Data.Description
import Neodoc.Data.Chunk
import Neodoc.Data.Layout
import Neodoc.Data.LayoutConversion
import Neodoc.Data.Indexed
import Neodoc.Data.Indexed as Indexed
import Neodoc.ArgKey.Class
import Neodoc.Solve.Error
import Neodoc.Solve.ExpandOptions
import Neodoc.Evaluate.Annotate

import Partial.Unsafe (unsafePartial)

type IndexedLayout a = Layout (IndexedLayoutArg a)
type IndexedLayoutArg a = Indexed a

expandReferences
  :: Spec ExpandedOptionsLayout
  -> Either SolveError (Spec SolvedLayout)
expandReferences (Spec (spec@{ layouts, descriptions })) = do
  let -- expand the references per top-level branch, then remove any branches
      -- that yieleded `Nothing`.
      layouts' = (catMaybes <$> _)
          $ fromFoldable
          $ (expandReferencesInBranch <$> _) <$> layouts
      layouts'' = case layouts' of
                    Nil    -> Nil :| Nil -- create empty top-level branch
                    x : xs ->   x :| xs

  pure (Spec $ spec { layouts = layouts'' })

  where
  expandReferencesInBranch
    :: NonEmpty List ExpandedOptionsLayout
    -> Maybe _
  expandReferencesInBranch branch =
    let -- 1. assign an index from left to right, to each layout element
        indexedBranch = indexBranch branch

        -- 2. flatten the branch, removing any recursion
        flatBranch = flattenBranch indexedBranch

        -- 3. chunk the flat branch into fixed/free args
        chunks = chunkBranch flatBranch

        -- 4. for each chunk, find out the args that a reference tag needs to
        --    resolve to. References are resolved left to right.
        --    (XXX: should they be aware of each other, so not to expand
        --          duplicates if they are adjacent? this would mean we'd need
        --          to run this in e.g. the State monad)
        indexToArgs = Indexed.toMap $ concat
                        $ fromFoldable $ expandChunk descriptions <$> chunks

        -- 6. expand the reference tags using the `index => [ arg ]` mapping.
        --    note that since branches could now be empty, we must be use a
        --    a slightly different intermediate structure that allows for empty
        --    lists.
        --    (XXX: it might be worth exploring if `Layout a` can be generalised
        --          to work on data structures other than `List a`s)
        expand = case _ of
          (EmptyableGroup o r xs) -> EmptyableGroup o r $ (expand <$> _) <$> xs
          (EmptyableElem (Indexed _ (SolvedArg x))) -> EmptyableElem x
          (EmptyableElem (Indexed ix (ReferenceArg n))) ->
            EmptyableGroup false false $ maybe Nil (_:Nil) do
              args <- Map.lookup ix indexToArgs
              pure $ args <#> \arg ->
                EmptyableGroup true false ((EmptyableElem arg:Nil):Nil)

     in toStrictBranch $ toEmptyableBranch indexedBranch <#> expand

expandChunk
  :: List Description
  -> Chunk _
  -> List (Indexed (List SolvedLayoutArg))
expandChunk _ (Fixed _) = Nil
expandChunk descriptions (Free xs) =
  let partitioned = partition xs
      surrounding = toArgKey <$> mlefts partitioned
      references = mrights partitioned
      isSurroundedBy k = any (_ == k) surrounding

   in references <#> \(Indexed ix n) ->
      let
        -- XXX: currently, references *always* refer to all descriptions
        --      this is work to be done, tracked in issue #57.
        descriptions' = descriptions

        -- 5. for each description associated with each reference,
        --    expand only those descriptions that are not already
        --    present in the same chunk. We determine presence based
        --    on all known `ArgKey`s of the argument.
        args = catMaybes $ descriptions' <#> case _ of
            (OptionDescription aliases@(a:|_) r mA _ _) ->
              if not $ any (isSurroundedBy <<< toArgKey) aliases
                then Just (Option a mA r)
                else Nothing
            _ -> Nothing
       in Indexed ix args

partition
  :: ∀ a b
   . List (Indexed ExpandedOptionsLayoutArg)
  -> List (Either SolvedLayoutArg (Indexed String))
partition xs = xs <#> case _ of
  Indexed _  (SolvedArg a)    -> Left a
  Indexed ix (ReferenceArg n) -> Right $ Indexed ix n

-- Chunk a branch
--   E(foo) G(-a -b -c) E(-x) => [Fixed([E(foo)]), Free([G(-a -b -c), E(-x)])]
chunkBranch
  :: NonEmpty     List (Indexed ExpandedOptionsLayoutArg)
  -> List (Chunk (List (Indexed ExpandedOptionsLayoutArg)))
chunkBranch = fromFoldable >>> chunk case _ of
  Indexed _ (ReferenceArg _) -> true
  Indexed _ (SolvedArg    a) -> Solved.isFreeLayout (Elem a)

-- Assign a numerical index to each element in a layout on the given branch,
-- as if the branch was completely flat, from left to right, i.e.:
--
--      -a (-b | -c)
--
-- would become:
--
--      (1:-a) ((2:-b) | (3:-c))
--
indexBranch
  :: ∀ a
   . NonEmpty List (Layout a)
  -> NonEmpty List (IndexedLayout a)
indexBranch branch = flip evalState 0 $ for branch indexLayout
  where
  indexLayout (Group o r xs) = Group o r <$> do
    for xs (traverse indexLayout)
  indexLayout (Elem x) = do
    i <- State.get
    State.put (i + 1)
    pure (Elem (Indexed i x))

-- Flatten a branch into a single list of elements, i.e.:
--
--      -a (-b | -c)
--
-- would become:
--
--      -a -b -c
--
flattenBranch
  :: ∀ a
   . NonEmpty List (Layout a)
  -> NonEmpty List a
flattenBranch branch = NonEmpty.concat $ flattenLayout <$> branch
  where
  flattenLayout (Elem x) = x :| Nil
  flattenLayout (Group _ _ branches)
    = NonEmpty.concat $ NonEmpty.concat $ (flattenLayout <$> _) <$> branches

-- | Transform a `ExpandedOptionsLayout` into a `SolvedLayout`
-- |
-- | This transform expands `[...-options]` reference tags into real options.
-- | This transform must be careful not to expand options that are already
-- | present in the same "free" grouping. We define a "free" grouping of such
-- | elements whose position does not matter.
-- |
-- | Since `[...-options]` reference tags strictly evaluate to "free" elements,
-- | that is short- and long options (practically speaking), the position of
-- | insertion does *NOT* matter, that is it must not necessarily occur in place
-- | of the actual tag, as long as it is within the same grouping.
-- |
-- | The method of performing this transform is roughly as follows, where
-- | `<* E...  *>` denotes an "free" chunk of elements `E` and
-- | `<! E...  !>` denotes an "fixed" chunk of elements `E`:
-- |
-- | Each top-level branch is solved independently. Given the following
-- | help text:
-- |
-- |    usage: prog foo -a [-b (-d -e)] [options] [-f] bar
-- |       or: prog foo bar --qux
-- |    options:
-- |      -d
-- |      -z
-- |
-- | We proceed as follows (for each top-level):
-- |
-- | 1. flatten the entire top-level and annotate each element w/ it's index:
-- |
-- |        prog foo -a [-b (-d -e)] [options] [-f] bar
-- |
-- |    becomes:
-- |
-- |        prog (1:foo) (2:-a) (3:-b) (4:-d) (5:-e) (6:[options]) (7:-f) (8:bar)
-- |
-- | 2. we chunk the output, such that "free" elements appear next to one
-- |    another:
-- |
-- |        prog <!(1:foo)!> <*(2:-a) (3:-b) (4:-d) (5:-e) (6:[options])
-- |             (7:-f)*> <!(8:bar)!>
-- |
-- | 3. we then expand any `[options]` elements into it's surrounding. We must
-- |    make sure not to expand an option into it's surrounding that is already
-- |    present. since the options section defined an `-d` (see above), but it
-- |    is already present in the surrounding area, we only expand `-z`
-- |
-- |        prog <!(1:foo)!> <*(2:-a) (3:-b) (4:-d) (5:-e) (6:[options: -z])
-- |             (7:-f)*> <!(8:bar)!>
-- |
-- | 4. finally, we apply expansion to the actual tree, using the indices as
-- |    lookups into the tree structure:
-- |
-- |        prog foo -a [-b (-d -e)] ([-z]) [-f] bar

module Neodoc.Solve.ExpandReferences where

import Prelude

import Debug.Trace
import Data.Either (Either(..))
import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.Traversable (traverse, for)
import Data.NonEmpty (NonEmpty, (:|))
import Data.NonEmpty.Extra as NonEmpty
import Data.Map as Map
import Data.List (List(..), (:), fromFoldable, length, catMaybes, concat, filter)
import Data.Tuple (Tuple, fst, snd)
import Data.Tuple.Nested ((/\))
import Data.Foldable (any, intercalate)
import Data.Pretty
import Control.Monad.State
import Control.Monad.State as State
import Control.MonadPlus.Partial (mrights, mlefts, mpartition)
import Control.Comonad (extract)

import Neodoc.Spec
import Neodoc.Data.SolvedLayout
import Neodoc.Data.SolvedLayout as Solved
import Neodoc.Data.EmptyableLayout
import Neodoc.Data.Description
import Neodoc.Data.Chunk
import Neodoc.Data.Layout
import Neodoc.Data.LayoutConversion
import Neodoc.Data.Indexed
import Neodoc.Data.Indexed as Indexed
import Neodoc.ArgKey.Class
import Neodoc.Solve.Error
import Neodoc.Solve.ExpandOptions
import Neodoc.Evaluate.Annotate

import Partial.Unsafe (unsafePartial)

type IndexedLayout a = Layout (IndexedLayoutArg a)
type IndexedLayoutArg a = Indexed a

expandReferences
  :: Spec ExpandedOptionsLayout
  -> Either SolveError (Spec SolvedLayout)
expandReferences (Spec (spec@{ layouts, descriptions })) = do
  let -- expand the references per top-level branch, then remove any branches
      -- that yieleded `Nothing`.
      layouts' = (catMaybes <$> _)
          $ fromFoldable
          $ (expandReferencesInBranch <$> _) <$> layouts
      layouts'' = case layouts' of
                    Nil    -> Nil :| Nil -- create empty top-level branch
                    x : xs ->   x :| xs

  pure (Spec $ spec { layouts = layouts'' })

  where
  expandReferencesInBranch
    :: NonEmpty List ExpandedOptionsLayout
    -> Maybe _
  expandReferencesInBranch branch =
    let -- 1. assign an index from left to right, to each layout element
        indexedBranch = indexBranch branch

        -- 2. flatten the branch, removing any recursion
        flatBranch = flattenBranch indexedBranch

        -- 3. chunk the flat branch into fixed/free args
        chunks = chunkBranch flatBranch

        -- 4. for each chunk, find out the args that a reference tag needs to
        --    resolve to. References are resolved left to right.
        --    (XXX: should they be aware of each other, so not to expand
        --          duplicates if they are adjacent? this would mean we'd need
        --          to run this in e.g. the State monad)
        indexToArgs = Indexed.toMap $ concat
                        $ fromFoldable $ expandChunk descriptions <$> chunks

        -- 6. expand the reference tags using the `index => [ arg ]` mapping.
        --    note that since branches could now be empty, we must be use a
        --    a slightly different intermediate structure that allows for empty
        --    lists.
        --    (XXX: it might be worth exploring if `Layout a` can be generalised
        --          to work on data structures other than `List a`s)
        expand = case _ of
          (EmptyableGroup o r xs) -> EmptyableGroup o r $ (expand <$> _) <$> xs
          (EmptyableElem (Indexed _ (SolvedArg x))) -> EmptyableElem x
          (EmptyableElem (Indexed ix (ReferenceArg n))) ->
            EmptyableGroup false false $ maybe Nil (_:Nil) do
              args <- Map.lookup ix indexToArgs
              pure $ args <#> \arg ->
                EmptyableGroup true false ((EmptyableElem arg:Nil):Nil)

     in toStrictBranch $ toEmptyableBranch indexedBranch <#> expand

expandChunk
  :: List Description
  -> Chunk _
  -> List (Indexed (List SolvedLayoutArg))
expandChunk _ (Fixed _) = Nil
expandChunk descriptions (Free xs) =
  let partitioned = partition xs
      surrounding = toArgKey <$> mlefts partitioned
      references = mrights partitioned
      isSurroundedBy k = any (_ == k) surrounding

   in references <#> \(Indexed ix n) ->
      let
        -- XXX: currently, references *always* refer to all descriptions
        --      this is work to be done, tracked in issue #57.
        descriptions' = descriptions

        -- 5. for each description associated with each reference,
        --    expand only those descriptions that are not already
        --    present in the same chunk. We determine presence based
        --    on all known `ArgKey`s of the argument.
        args = catMaybes $ descriptions' <#> case _ of
            (OptionDescription aliases@(a:|_) r mA _ _) ->
              if not $ any (isSurroundedBy <<< toArgKey) aliases
                then Just (Option a mA r)
                else Nothing
            _ -> Nothing
       in Indexed ix args

partition
  :: ∀ a b
   . List (Indexed ExpandedOptionsLayoutArg)
  -> List (Either SolvedLayoutArg (Indexed String))
partition xs = xs <#> case _ of
  Indexed _  (SolvedArg a)    -> Left a
  Indexed ix (ReferenceArg n) -> Right $ Indexed ix n

-- Chunk a branch
--   E(foo) G(-a -b -c) E(-x) => [Fixed([E(foo)]), Free([G(-a -b -c), E(-x)])]
chunkBranch
  :: NonEmpty     List (Indexed ExpandedOptionsLayoutArg)
  -> List (Chunk (List (Indexed ExpandedOptionsLayoutArg)))
chunkBranch = fromFoldable >>> chunk case _ of
  Indexed _ (ReferenceArg _) -> true
  Indexed _ (SolvedArg    a) -> Solved.isFreeLayout (Elem a)

-- Assign a numerical index to each element in a layout on the given branch,
-- as if the branch was completely flat, from left to right, i.e.:
--
--      -a (-b | -c)
--
-- would become:
--
--      (1:-a) ((2:-b) | (3:-c))
--
indexBranch
  :: ∀ a
   . NonEmpty List (Layout a)
  -> NonEmpty List (IndexedLayout a)
indexBranch branch = flip evalState 0 $ for branch indexLayout
  where
  indexLayout (Group o r xs) = Group o r <$> do
    for xs (traverse indexLayout)
  indexLayout (Elem x) = do
    i <- State.get
    State.put (i + 1)
    pure (Elem (Indexed i x))

-- Flatten a branch into a single list of elements, i.e.:
--
--      -a (-b | -c)
--
-- would become:
--
--      -a -b -c
--
flattenBranch
  :: ∀ a
   . NonEmpty List (Layout a)
  -> NonEmpty List a
flattenBranch branch = NonEmpty.concat $ flattenLayout <$> branch
  where
  flattenLayout (Elem x) = x :| Nil
  flattenLayout (Group _ _ branches)
    = NonEmpty.concat $ NonEmpty.concat $ (flattenLayout <$> _) <$> branches


Add forgotten import.

Add forgotten import.

module CanvasInterpreter where

import Prelude
import Canvas
import Effect
import Language
import Control.Monad
import Control.Monad.Free (runFreeM)
import Control.Monad.State (State, evalState, get, modify_, put)
import Data.Tuple
import Data.Foldable
import Math (sin, cos, pi, (%))

-- | x, y, rotation, isPenDown
data Turtle = Turtle Distance Distance Angle Boolean

instance turtleShow :: Show Turtle where
  show (Turtle x y angle isPenDown) = "(Turtle " <> show x <> " " <> show y <> " " <> show angle <> " " <> show isPenDown <> ")"

interpretTurtleProg :: forall a. TurtleProg a -> Context2D -> Effect Context2D
interpretTurtleProg turtleProg ctx = foldl (>>=) (pure ctx) (interpretTurtleProg' turtleProg)

interpretTurtleProg' :: forall a. TurtleProg a -> Array (Context2D -> Effect Context2D)
interpretTurtleProg' turtleProg =

  evalState turtleProgState (Turtle 0.0 0.0 0.0 true)

  where turtleProg' = const [] <$> turtleProg
        turtleProgState = interpretTurtleProg'' turtleProg'

-- | A natural transformation from `TurtleProg` to `State Turtle`.
interpretTurtleProg'' :: TurtleProg   (Array (Context2D -> Effect Context2D))
                      -> State Turtle (Array (Context2D -> Effect Context2D))
interpretTurtleProg'' = runFreeM interpret

  -- pick off the outermost TurtleCmd from the TurtleProg and process it
  where interpret :: TurtleCmd    (TurtleProg (Array (Context2D -> Effect Context2D)))
                  -> State Turtle (TurtleProg (Array (Context2D -> Effect Context2D)))

        interpret (Forward r rest) = do
          Turtle x y angle p <- get
          let x' = x + adjacent r angle
              y' = y + opposite r angle
              instr = lineTo x' y'
          put (Turtle x' y' angle p)

          pure ((\prog -> prog <> [instr]) <$> rest)

        interpret (Arc r arcAngleDeg rest) = do
          Turtle x y turtleAngle p <- get
          let angleEnd = turtleAngle + rad arcAngleDeg
              angle'   = angleEnd + rad 90.0
              x'       = x + adjacent r angleEnd
              y'       = y + opposite r angleEnd
              instr    = drawArc x y r turtleAngle angleEnd

          put (Turtle x' y' angle' p)
          pure (rest <#> (_ <> [instr]))

        interpret (Right angleDeg rest) = do
          let angle = rad angleDeg
          modify_ $ \(Turtle x y angle0 p) -> Turtle x y (angle0 + angle) p
          pure rest

        interpret (PenUp rest) = do
          modify_ $ \(Turtle x y angle _) -> Turtle x y angle false
          pure ((\prog -> prog <> [endStroke]) <$> rest)

        interpret (PenDown rest) = do
          Turtle x y angle p <- get
          put (Turtle x y angle true)
          pure ((\prog -> prog <> [beginStroke, moveTo x y]) <$> rest)

        interpret (UseColor col rest) = do
          pure ((\prog -> prog <> [setStrokeStyle $ colorToCanvasStyle col]) <$> rest)

adjacent r angle = r * cos angle
opposite r angle = r * sin angle
rad angleDegrees = (2.0 * pi * (angleDegrees % 360.0)) / 360.0

renderTurtleProgOnCanvas :: String -> TurtleProg Unit -> Effect Context2D
renderTurtleProgOnCanvas canvasId prog =
  get2DContext canvasId >>=
  initContext (colorToCanvasStyle Purple) >>=
  moveTo 0.0 0.0 >>=
  beginStroke >>=
  interpretTurtleProg prog >>=
  endStroke

module CanvasInterpreter where

import Prelude
import Canvas
import Language
import Control.Monad
import Control.Monad.Free (runFreeM)
import Control.Monad.State (State, evalState, get, modify_, put)
import Data.Tuple
import Data.Foldable
import Effect (Effect)
import Math (sin, cos, pi, (%))

-- | x, y, rotation, isPenDown
data Turtle = Turtle Distance Distance Angle Boolean

instance turtleShow :: Show Turtle where
  show (Turtle x y angle isPenDown) = "(Turtle " <> show x <> " " <> show y <> " " <> show angle <> " " <> show isPenDown <> ")"

interpretTurtleProg :: forall a. TurtleProg a -> Context2D -> Effect Context2D
interpretTurtleProg turtleProg ctx = foldl (>>=) (pure ctx) (interpretTurtleProg' turtleProg)

interpretTurtleProg' :: forall a. TurtleProg a -> Array (Context2D -> Effect Context2D)
interpretTurtleProg' turtleProg =

  evalState turtleProgState (Turtle 0.0 0.0 0.0 true)

  where turtleProg' = const [] <$> turtleProg
        turtleProgState = interpretTurtleProg'' turtleProg'

-- | A natural transformation from `TurtleProg` to `State Turtle`.
interpretTurtleProg'' :: TurtleProg   (Array (Context2D -> Effect Context2D))
                      -> State Turtle (Array (Context2D -> Effect Context2D))
interpretTurtleProg'' = runFreeM interpret

  -- pick off the outermost TurtleCmd from the TurtleProg and process it
  where interpret :: TurtleCmd    (TurtleProg (Array (Context2D -> Effect Context2D)))
                  -> State Turtle (TurtleProg (Array (Context2D -> Effect Context2D)))

        interpret (Forward r rest) = do
          Turtle x y angle p <- get
          let x' = x + adjacent r angle
              y' = y + opposite r angle
              instr = lineTo x' y'
          put (Turtle x' y' angle p)

          pure ((\prog -> prog <> [instr]) <$> rest)

        interpret (Arc r arcAngleDeg rest) = do
          Turtle x y turtleAngle p <- get
          let angleEnd = turtleAngle + rad arcAngleDeg
              angle'   = angleEnd + rad 90.0
              x'       = x + adjacent r angleEnd
              y'       = y + opposite r angleEnd
              instr    = drawArc x y r turtleAngle angleEnd

          put (Turtle x' y' angle' p)
          pure (rest <#> (_ <> [instr]))

        interpret (Right angleDeg rest) = do
          let angle = rad angleDeg
          modify_ $ \(Turtle x y angle0 p) -> Turtle x y (angle0 + angle) p
          pure rest

        interpret (PenUp rest) = do
          modify_ $ \(Turtle x y angle _) -> Turtle x y angle false
          pure ((\prog -> prog <> [endStroke]) <$> rest)

        interpret (PenDown rest) = do
          Turtle x y angle p <- get
          put (Turtle x y angle true)
          pure ((\prog -> prog <> [beginStroke, moveTo x y]) <$> rest)

        interpret (UseColor col rest) = do
          pure ((\prog -> prog <> [setStrokeStyle $ colorToCanvasStyle col]) <$> rest)

adjacent r angle = r * cos angle
opposite r angle = r * sin angle
rad angleDegrees = (2.0 * pi * (angleDegrees % 360.0)) / 360.0

renderTurtleProgOnCanvas :: String -> TurtleProg Unit -> Effect Context2D
renderTurtleProgOnCanvas canvasId prog =
  get2DContext canvasId >>=
  initContext (colorToCanvasStyle Purple) >>=
  moveTo 0.0 0.0 >>=
  beginStroke >>=
  interpretTurtleProg prog >>=
  endStroke


Thread def cleanup

Thread def cleanup

module Control.Monad.Aff
  ( Aff
  , Thread
  , ParAff(..)
  , Canceler(..)
  , nonCanceler
  , makeAff
  , launchAff
  , runAff
  , forkAff
  , liftEff'
  , bracket
  , delay
  , finally
  , atomically
  , killThread
  , joinThread
  , module Exports
  ) where

import Prelude
import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Apply (lift2)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Exception (Error, EXCEPTION, error)
import Control.Monad.Eff.Ref (newRef, readRef, writeRef)
import Control.Monad.Eff.Ref.Unsafe (unsafeRunRef)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Error.Class (class MonadError, class MonadThrow, throwError, catchError, try)
import Control.Monad.Error.Class (try) as Exports
import Control.Monad.Rec.Class (class MonadRec, Step(..))
import Control.MonadPlus (class MonadPlus)
import Control.MonadZero (class MonadZero)
import Control.Parallel (parSequence_)
import Control.Parallel.Class (class Parallel)
import Control.Plus (class Plus, empty)
import Data.Either (Either(..), isLeft)
import Data.Function.Uncurried as Fn
import Data.Maybe (Maybe(..))
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype)
import Data.Time.Duration (Milliseconds(..))
import Partial.Unsafe (unsafeCrashWith)

foreign import data Aff ∷ # Effect → Type → Type

instance functorAff ∷ Functor (Aff eff) where
  map = _map

instance applyAff ∷ Apply (Aff eff) where
  apply = ap

instance applicativeAff ∷ Applicative (Aff eff) where
  pure = _pure

instance bindAff ∷ Bind (Aff eff) where
  bind = _bind

instance monadAff ∷ Monad (Aff eff)

instance semigroupAff ∷ Semigroup a ⇒ Semigroup (Aff eff a) where
  append = lift2 append

instance monoidAff ∷ Monoid a ⇒ Monoid (Aff eff a) where
  mempty = pure mempty

instance altAff ∷ Alt (Aff eff) where
  alt a1 a2 = catchError a1 (const a2)

instance plusAff ∷ Plus (Aff eff) where
  empty = throwError (error "Always fails")

instance alternativeAff ∷ Alternative (Aff eff)

instance monadZeroAff ∷ MonadZero (Aff eff)

instance monadPlusAff ∷ MonadPlus (Aff eff)

instance monadRecAff ∷ MonadRec (Aff eff) where
  tailRecM k = go
    where
    go a = do
      res ← k a
      case res of
        Done r → pure r
        Loop b → go b

instance monadThrowAff ∷ MonadThrow Error (Aff eff) where
  throwError = _throwError

instance monadErrorAff ∷ MonadError Error (Aff eff) where
  catchError = _catchError

instance monadEffAff ∷ MonadEff eff (Aff eff) where
  liftEff = _liftEff

newtype ParAff eff a = ParAff (Aff eff a)

derive instance newtypeParAff ∷ Newtype (ParAff eff a) _

derive newtype instance functorParAff ∷ Functor (ParAff eff)

instance applyParAff ∷ Apply (ParAff eff) where
  apply (ParAff ff) (ParAff fa) = ParAff $ makeAff \k → do
    ref1 ← unsafeRunRef $ newRef Nothing
    ref2 ← unsafeRunRef $ newRef Nothing

    t1 ← launchAff do
      f ← try ff
      liftEff do
        ma ← unsafeRunRef $ readRef ref2
        case ma of
          Nothing → unsafeRunRef $ writeRef ref1 (Just f)
          Just a  → k (f <*> a)

    t2 ← launchAff do
      a ← try fa
      liftEff do
        mf ← unsafeRunRef $ readRef ref1
        case mf of
          Nothing → unsafeRunRef $ writeRef ref2 (Just a)
          Just f  → k (f <*> a)

    pure $ Canceler \err →
      parSequence_
        [ killThread err t1
        , killThread err t2
        ]

instance applicativeParAff ∷ Applicative (ParAff eff) where
  pure = ParAff <<< pure

instance semigroupParAff ∷ Semigroup a ⇒ Semigroup (ParAff eff a) where
  append = lift2 append

instance monoidParAff ∷ Monoid a ⇒ Monoid (ParAff eff a) where
  mempty = pure mempty

data AltStatus a
  = Pending
  | Completed a

instance altParAff ∷ Alt (ParAff eff) where
  alt = runAlt
    where
    runAlt ∷ ∀ a. ParAff eff a → ParAff eff a → ParAff eff a
    runAlt (ParAff a1) (ParAff a2) = ParAff $ makeAff \k → do
      ref ← unsafeRunRef $ newRef Nothing
      t1 ← launchAff a1
      t2 ← launchAff a2

      let
        completed ∷ Thread eff a → Either Error a → Aff eff Unit
        completed t res = do
          val ← liftEff $ unsafeRunRef $ readRef ref
          case val, res of
            _, Right _ → do
              killThread (error "Alt ParAff: early exit") t
              liftEff (k res)
            Nothing, _ →
              liftEff $ unsafeRunRef $ writeRef ref (Just res)
            Just res', _ →
              liftEff (k res')

      t3 ← launchAff $ completed t2 =<< try (joinThread t1)
      t4 ← launchAff $ completed t1 =<< try (joinThread t2)

      pure $ Canceler \err →
        parSequence_
          [ killThread err t3
          , killThread err t4
          , killThread err t1
          , killThread err t2
          ]

instance plusParAff ∷ Plus (ParAff e) where
  empty = ParAff empty

instance alternativeParAff ∷ Alternative (ParAff e)

instance parallelAff ∷ Parallel (ParAff eff) (Aff eff) where
  parallel = ParAff
  sequential (ParAff aff) = aff

newtype Thread eff a = Thread
  { kill ∷ Error → Aff eff Unit
  , join ∷ Aff eff a
  }

instance functorThread ∷ Functor (Thread eff) where
  map f (Thread { kill, join }) = Thread
    { kill
    , join: memoAff (f <$> join)
    }

instance applyThread ∷ Apply (Thread eff) where
  apply t1 t2 = Thread
    { kill: \err → parSequence_ [ killThread err t1, killThread err t2 ]
    , join: memoAff (joinThread t1 <*> joinThread t2)
    }

instance applicativeThread ∷ Applicative (Thread eff) where
  pure a = Thread
    { kill: const (pure unit)
    , join: pure a
    }

killThread ∷ ∀ eff a. Error → Thread eff a → Aff eff Unit
killThread e (Thread t) = t.kill e

joinThread ∷ ∀ eff a. Thread eff a → Aff eff a
joinThread (Thread t) = t.join

newtype Canceler eff = Canceler (Error → Aff eff Unit)

derive instance newtypeCanceler ∷ Newtype (Canceler eff) _

instance semigroupCanceler ∷ Semigroup (Canceler eff) where
  append (Canceler c1) (Canceler c2) =
    Canceler \err → parSequence_ [ c1 err, c2 err ]

instance monoidCanceler ∷ Monoid (Canceler eff) where
  mempty = nonCanceler

nonCanceler ∷ ∀ eff. Canceler eff
nonCanceler = Canceler (const (pure unit))

launchAff ∷ ∀ eff a. Aff eff a → Eff eff (Thread eff a)
launchAff aff = Fn.runFn6 _launchAff isLeft unsafeFromLeft unsafeFromRight Left Right aff

runAff ∷ ∀ eff a. (Either Error a → Eff eff Unit) → Aff eff a → Eff eff Unit
runAff k aff = void $ launchAff $ liftEff <<< k =<< try aff

forkAff ∷ ∀ eff a. Aff eff a → Aff eff (Thread eff a)
forkAff = liftEff <<< launchAff

delay ∷ ∀ eff. Milliseconds → Aff eff Unit
delay (Milliseconds n) = Fn.runFn2 _delay Right n

liftEff' ∷ ∀ eff a. Eff (exception ∷ EXCEPTION | eff) a → Aff eff a
liftEff' = liftEff <<< unsafeCoerceEff

finally ∷ ∀ eff a. Aff eff Unit → Aff eff a → Aff eff a
finally fin a = bracket (pure unit) (const fin) (const a)

atomically ∷ ∀ eff a. Aff eff a → Aff eff a
atomically a = bracket a (const (pure unit)) pure

foreign import _pure ∷ ∀ eff a. a → Aff eff a
foreign import _throwError ∷ ∀ eff a. Error → Aff eff a
foreign import _catchError ∷ ∀ eff a. Aff eff a → (Error → Aff eff a) → Aff eff a
foreign import _map ∷ ∀ eff a b. (a → b) → Aff eff a → Aff eff b
foreign import _bind ∷ ∀ eff a b. Aff eff a → (a → Aff eff b) → Aff eff b
foreign import _delay ∷ ∀ a eff. Fn.Fn2 (Unit → Either a Unit) Number (Aff eff Unit)
foreign import _liftEff ∷ ∀ eff a. Eff eff a → Aff eff a
foreign import bracket ∷ ∀ eff a b. Aff eff a → (a → Aff eff Unit) → (a → Aff eff b) → Aff eff b
foreign import makeAff ∷ ∀ eff a. ((Either Error a → Eff eff Unit) → Eff eff (Canceler eff)) → Aff eff a
foreign import memoAff ∷ ∀ eff a. Aff eff a → Aff eff a

foreign import _launchAff
  ∷ ∀ eff a
  . Fn.Fn6
      (Either Error a → Boolean)
      (Either Error a → Error)
      (Either Error a → a)
      (Error → Either Error a)
      (a → Either Error a)
      (Aff eff a)
      (Eff eff (Thread eff a))

unsafeFromLeft ∷ ∀ x y. Either x y → x
unsafeFromLeft = case _ of
  Left a  → a
  Right _ → unsafeCrashWith "unsafeFromLeft: Right"

unsafeFromRight ∷ ∀ x y. Either x y → y
unsafeFromRight = case _ of
  Right a → a
  Left  _ → unsafeCrashWith "unsafeFromRight: Left"

module Control.Monad.Aff
  ( Aff
  , Thread
  , ParAff(..)
  , Canceler(..)
  , nonCanceler
  , makeAff
  , launchAff
  , runAff
  , forkAff
  , liftEff'
  , bracket
  , delay
  , finally
  , atomically
  , killThread
  , joinThread
  , module Exports
  ) where

import Prelude
import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Apply (lift2)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Exception (Error, EXCEPTION, error)
import Control.Monad.Eff.Ref (newRef, readRef, writeRef)
import Control.Monad.Eff.Ref.Unsafe (unsafeRunRef)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Error.Class (class MonadError, class MonadThrow, throwError, catchError, try)
import Control.Monad.Error.Class (try) as Exports
import Control.Monad.Rec.Class (class MonadRec, Step(..))
import Control.MonadPlus (class MonadPlus)
import Control.MonadZero (class MonadZero)
import Control.Parallel (parSequence_)
import Control.Parallel.Class (class Parallel, parallel, sequential)
import Control.Plus (class Plus, empty)
import Data.Either (Either(..), isLeft)
import Data.Function.Uncurried as Fn
import Data.Maybe (Maybe(..))
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype)
import Data.Time.Duration (Milliseconds(..))
import Partial.Unsafe (unsafeCrashWith)

foreign import data Aff ∷ # Effect → Type → Type

instance functorAff ∷ Functor (Aff eff) where
  map = _map

instance applyAff ∷ Apply (Aff eff) where
  apply = ap

instance applicativeAff ∷ Applicative (Aff eff) where
  pure = _pure

instance bindAff ∷ Bind (Aff eff) where
  bind = _bind

instance monadAff ∷ Monad (Aff eff)

instance semigroupAff ∷ Semigroup a ⇒ Semigroup (Aff eff a) where
  append = lift2 append

instance monoidAff ∷ Monoid a ⇒ Monoid (Aff eff a) where
  mempty = pure mempty

instance altAff ∷ Alt (Aff eff) where
  alt a1 a2 = catchError a1 (const a2)

instance plusAff ∷ Plus (Aff eff) where
  empty = throwError (error "Always fails")

instance alternativeAff ∷ Alternative (Aff eff)

instance monadZeroAff ∷ MonadZero (Aff eff)

instance monadPlusAff ∷ MonadPlus (Aff eff)

instance monadRecAff ∷ MonadRec (Aff eff) where
  tailRecM k = go
    where
    go a = do
      res ← k a
      case res of
        Done r → pure r
        Loop b → go b

instance monadThrowAff ∷ MonadThrow Error (Aff eff) where
  throwError = _throwError

instance monadErrorAff ∷ MonadError Error (Aff eff) where
  catchError = _catchError

instance monadEffAff ∷ MonadEff eff (Aff eff) where
  liftEff = _liftEff

newtype ParAff eff a = ParAff (Aff eff a)

derive instance newtypeParAff ∷ Newtype (ParAff eff a) _

derive newtype instance functorParAff ∷ Functor (ParAff eff)

instance applyParAff ∷ Apply (ParAff eff) where
  apply (ParAff ff) (ParAff fa) = ParAff $ makeAff \k → do
    ref1 ← unsafeRunRef $ newRef Nothing
    ref2 ← unsafeRunRef $ newRef Nothing

    t1 ← launchAff do
      f ← try ff
      liftEff do
        ma ← unsafeRunRef $ readRef ref2
        case ma of
          Nothing → unsafeRunRef $ writeRef ref1 (Just f)
          Just a  → k (f <*> a)

    t2 ← launchAff do
      a ← try fa
      liftEff do
        mf ← unsafeRunRef $ readRef ref1
        case mf of
          Nothing → unsafeRunRef $ writeRef ref2 (Just a)
          Just f  → k (f <*> a)

    pure $ Canceler \err →
      parSequence_
        [ killThread err t1
        , killThread err t2
        ]

instance applicativeParAff ∷ Applicative (ParAff eff) where
  pure = ParAff <<< pure

instance semigroupParAff ∷ Semigroup a ⇒ Semigroup (ParAff eff a) where
  append = lift2 append

instance monoidParAff ∷ Monoid a ⇒ Monoid (ParAff eff a) where
  mempty = pure mempty

data AltStatus a
  = Pending
  | Completed a

instance altParAff ∷ Alt (ParAff eff) where
  alt = runAlt
    where
    runAlt ∷ ∀ a. ParAff eff a → ParAff eff a → ParAff eff a
    runAlt (ParAff a1) (ParAff a2) = ParAff $ makeAff \k → do
      ref ← unsafeRunRef $ newRef Nothing
      t1 ← launchAff a1
      t2 ← launchAff a2

      let
        completed ∷ Thread eff a → Either Error a → Aff eff Unit
        completed t res = do
          val ← liftEff $ unsafeRunRef $ readRef ref
          case val, res of
            _, Right _ → do
              killThread (error "Alt ParAff: early exit") t
              liftEff (k res)
            Nothing, _ →
              liftEff $ unsafeRunRef $ writeRef ref (Just res)
            Just res', _ →
              liftEff (k res')

      t3 ← launchAff $ completed t2 =<< try (joinThread t1)
      t4 ← launchAff $ completed t1 =<< try (joinThread t2)

      pure $ Canceler \err →
        parSequence_
          [ killThread err t3
          , killThread err t4
          , killThread err t1
          , killThread err t2
          ]

instance plusParAff ∷ Plus (ParAff e) where
  empty = ParAff empty

instance alternativeParAff ∷ Alternative (ParAff e)

instance parallelAff ∷ Parallel (ParAff eff) (Aff eff) where
  parallel = ParAff
  sequential (ParAff aff) = aff

newtype Thread eff a = Thread
  { kill ∷ Error → Aff eff Unit
  , join ∷ Aff eff a
  }

instance functorThread ∷ Functor (Thread eff) where
  map f (Thread { kill, join }) = Thread
    { kill
    , join: memoAff (f <$> join)
    }

instance applyThread ∷ Apply (Thread eff) where
  apply t1 t2 = Thread
    { kill: \err → sequential $ parallel (killThread err t1) *> parallel (killThread err t2)
    , join: memoAff do
        f ← joinThread t1
        a ← joinThread t2
        pure (f a)
    }

instance applicativeThread ∷ Applicative (Thread eff) where
  pure a = Thread
    { kill: const (pure unit)
    , join: pure a
    }

killThread ∷ ∀ eff a. Error → Thread eff a → Aff eff Unit
killThread e (Thread t) = t.kill e

joinThread ∷ ∀ eff a. Thread eff a → Aff eff a
joinThread (Thread t) = t.join

newtype Canceler eff = Canceler (Error → Aff eff Unit)

derive instance newtypeCanceler ∷ Newtype (Canceler eff) _

instance semigroupCanceler ∷ Semigroup (Canceler eff) where
  append (Canceler c1) (Canceler c2) =
    Canceler \err → parSequence_ [ c1 err, c2 err ]

instance monoidCanceler ∷ Monoid (Canceler eff) where
  mempty = nonCanceler

nonCanceler ∷ ∀ eff. Canceler eff
nonCanceler = Canceler (const (pure unit))

launchAff ∷ ∀ eff a. Aff eff a → Eff eff (Thread eff a)
launchAff aff = Fn.runFn6 _launchAff isLeft unsafeFromLeft unsafeFromRight Left Right aff

runAff ∷ ∀ eff a. (Either Error a → Eff eff Unit) → Aff eff a → Eff eff Unit
runAff k aff = void $ launchAff $ liftEff <<< k =<< try aff

forkAff ∷ ∀ eff a. Aff eff a → Aff eff (Thread eff a)
forkAff = liftEff <<< launchAff

delay ∷ ∀ eff. Milliseconds → Aff eff Unit
delay (Milliseconds n) = Fn.runFn2 _delay Right n

liftEff' ∷ ∀ eff a. Eff (exception ∷ EXCEPTION | eff) a → Aff eff a
liftEff' = liftEff <<< unsafeCoerceEff

finally ∷ ∀ eff a. Aff eff Unit → Aff eff a → Aff eff a
finally fin a = bracket (pure unit) (const fin) (const a)

atomically ∷ ∀ eff a. Aff eff a → Aff eff a
atomically a = bracket a (const (pure unit)) pure

foreign import _pure ∷ ∀ eff a. a → Aff eff a
foreign import _throwError ∷ ∀ eff a. Error → Aff eff a
foreign import _catchError ∷ ∀ eff a. Aff eff a → (Error → Aff eff a) → Aff eff a
foreign import _map ∷ ∀ eff a b. (a → b) → Aff eff a → Aff eff b
foreign import _bind ∷ ∀ eff a b. Aff eff a → (a → Aff eff b) → Aff eff b
foreign import _delay ∷ ∀ a eff. Fn.Fn2 (Unit → Either a Unit) Number (Aff eff Unit)
foreign import _liftEff ∷ ∀ eff a. Eff eff a → Aff eff a
foreign import bracket ∷ ∀ eff a b. Aff eff a → (a → Aff eff Unit) → (a → Aff eff b) → Aff eff b
foreign import makeAff ∷ ∀ eff a. ((Either Error a → Eff eff Unit) → Eff eff (Canceler eff)) → Aff eff a
foreign import memoAff ∷ ∀ eff a. Aff eff a → Aff eff a

foreign import _launchAff
  ∷ ∀ eff a
  . Fn.Fn6
      (Either Error a → Boolean)
      (Either Error a → Error)
      (Either Error a → a)
      (Error → Either Error a)
      (a → Either Error a)
      (Aff eff a)
      (Eff eff (Thread eff a))

unsafeFromLeft ∷ ∀ x y. Either x y → x
unsafeFromLeft = case _ of
  Left a  → a
  Right _ → unsafeCrashWith "unsafeFromLeft: Right"

unsafeFromRight ∷ ∀ x y. Either x y → y
unsafeFromRight = case _ of
  Right a → a
  Left  _ → unsafeCrashWith "unsafeFromRight: Left"


Make sure effects aren't performed too early

module Node.ChildProcess
  ( Handle()
  , ChildProcess()
  , CHILD_PROCESS()
  , stderr
  , stdout
  , stdin
  , pid
  , connected
  , kill
  , send
  , disconnect
  , ChildProcessError()
  , ChildProcessExit(..)
  , onExit
  , onClose
  , onDisconnect
  , onMessage
  , onError
  , spawn
  , fork
  , SpawnOptions()
  , defaultSpawnOptions
  , StdIOBehaviour(..)
  , pipe
  , inherit
  , ignore
  ) where

import Prelude

import Control.Alt ((<|>))
import Control.Bind ((>=>))
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Exception.Unsafe (unsafeThrow)

import Data.StrMap (StrMap())
import Data.Function (Fn2(), runFn2)
import Data.Nullable (Nullable(), toNullable, toMaybe)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Foreign (Foreign())
import Data.Posix (Pid())
import Data.Posix.Signal (Signal())
import Data.Posix.Signal as Signal
import Unsafe.Coerce (unsafeCoerce)

import Node.FS as FS
import Node.Stream (Readable(), Writable(), Stream())

-- | A handle for inter-process communication (IPC).
foreign import data Handle :: *

-- | The effect for creating and interacting with child processes.
foreign import data CHILD_PROCESS :: !

newtype ChildProcess = ChildProcess ChildProcessRec

runChildProcess :: ChildProcess -> ChildProcessRec
runChildProcess (ChildProcess r) = r

-- | Note: some of these types are lies, and so it is unsafe to access some of
-- | these record fields directly.
type ChildProcessRec =
  { stdin      :: forall eff. Nullable (Writable () (cp :: CHILD_PROCESS | eff))
  , stdout     :: forall eff. Nullable (Readable () (cp :: CHILD_PROCESS | eff))
  , stderr     :: forall eff. Nullable (Readable () (cp :: CHILD_PROCESS | eff))
  , pid        :: Pid
  , connected  :: Boolean
  , kill       :: String -> Boolean
  , send       :: forall r. Fn2 { | r} Handle Boolean
  , disconnect :: forall eff. Eff eff Unit
  }

-- | The standard input stream of a child process. Note that this is only
-- | available if the process was spawned with the stdin option set to "pipe".
stdin :: forall eff. ChildProcess -> Writable () (cp :: CHILD_PROCESS | eff)
stdin = unsafeFromNullable (missingStream "stdin") <<< _.stdin <<< runChildProcess

-- | The standard output stream of a child process. Note that this is only
-- | available if the process was spawned with the stdout option set to "pipe".
stdout :: forall eff. ChildProcess -> Readable () (cp :: CHILD_PROCESS | eff)
stdout = unsafeFromNullable (missingStream "stdout") <<< _.stdout <<< runChildProcess

-- | The standard error stream of a child process. Note that this is only
-- | available if the process was spawned with the stderr option set to "pipe".
stderr :: forall eff. ChildProcess -> Readable () (cp :: CHILD_PROCESS| eff)
stderr = unsafeFromNullable (missingStream "stderr") <<< _.stderr <<< runChildProcess

missingStream :: String -> String
missingStream str =
  "Node.ChildProcess: stream not available: " <> str <> "\nThis is probably "
  <> "because you passed something other than Pipe to the stdio option when "
  <> "you spawned it."

foreign import unsafeFromNullable :: forall a. String -> Nullable a -> a

-- | The process ID of a child process. Note that if the process has already
-- | exited, another process may have taken the same ID, so be careful!
pid :: ChildProcess -> Pid
pid = _.pid <<< runChildProcess

connected :: forall eff. ChildProcess -> Eff (cp :: CHILD_PROCESS | eff) Boolean
connected (ChildProcess cp) = mkEff \_ -> cp.connected

send :: forall eff props. { | props } -> Handle -> ChildProcess -> Eff (cp :: CHILD_PROCESS | eff) Boolean
send msg handle (ChildProcess cp) = mkEff \_ -> runFn2 cp.send msg handle

disconnect :: forall eff. ChildProcess -> Eff (cp :: CHILD_PROCESS | eff) Unit
disconnect = _.disconnect <<< runChildProcess

-- | Send a signal to a child process. It's an unfortunate historical decision
-- | that this function is called "kill", as sending a signal to a child
-- | process won't necessarily kill it.
kill :: forall eff. Signal -> ChildProcess -> Eff (cp :: CHILD_PROCESS | eff) Boolean
kill sig (ChildProcess cp) = mkEff \_ -> cp.kill (Signal.toString sig)

mkEff :: forall eff a. (Unit -> a) -> Eff eff a
mkEff = unsafeCoerce

-- | Specifies how a child process exited; normally (with an exit code), or
-- | due to a signal.
data ChildProcessExit
  = Normally Int
  | BySignal Signal

instance showChildProcessExit :: Show ChildProcessExit where
  show (Normally x) = "Normally " <> show x
  show (BySignal sig) = "BySignal " <> show sig

type SpawnOptions =
  { cwd       :: Maybe String
  , stdio     :: Array (Maybe StdIOBehaviour)
  , env       :: Maybe (StrMap String)
  , detached  :: Boolean
  , uid       :: Maybe Int
  , gid       :: Maybe Int
  }

mkChildProcessExit :: Nullable Int -> Nullable String -> ChildProcessExit
mkChildProcessExit code signal =
  case fromCode code <|> fromSignal signal of
    Just e -> e
    Nothing -> unsafeThrow "Node.ChildProcess.mkChildProcessExit: Invalid arguments"
  where
  fromCode   = toMaybe >>> map Normally
  fromSignal = toMaybe >=> Signal.fromString >>> map BySignal

onExit :: forall eff. ChildProcess -> (ChildProcessExit -> Eff eff Unit) -> Eff eff Unit
onExit = mkOnExit mkChildProcessExit

foreign import mkOnExit :: forall eff.
          (Nullable Int -> Nullable String -> ChildProcessExit)
          -> ChildProcess -> (ChildProcessExit -> Eff eff Unit) -> Eff eff Unit

onClose :: forall eff. ChildProcess -> (ChildProcessExit -> Eff eff Unit) -> Eff eff Unit
onClose = mkOnClose mkChildProcessExit

foreign import mkOnClose :: forall eff.
          (Nullable Int -> Nullable String -> ChildProcessExit)
          -> ChildProcess -> (ChildProcessExit -> Eff eff Unit) -> Eff eff Unit

onMessage :: forall eff.  ChildProcess -> (Foreign -> Maybe Handle -> Eff eff Unit) -> Eff eff Unit
onMessage = mkOnMessage Nothing Just

foreign import mkOnMessage :: forall a eff.
          Maybe a -> (a -> Maybe a) ->
          ChildProcess -> (Foreign -> Maybe Handle -> Eff eff Unit) -> Eff eff Unit

foreign import onDisconnect :: forall eff. ChildProcess -> Eff eff Unit -> Eff eff Unit
foreign import onError :: forall eff. ChildProcess -> (ChildProcessError -> Eff eff Unit) -> Eff eff Unit

-- | Spawn a child process. Note that, in the event that a child process could
-- | not be spawned (for example, if the executable was not found) this will
-- | not throw an error. Instead, the `ChildProcess` will be created anyway,
-- | but it will immediately emit an 'error' event.
spawn :: forall eff. String -> Array String -> SpawnOptions -> Eff (cp :: CHILD_PROCESS | eff) ChildProcess
spawn cmd args opts = spawnImpl cmd args (convertOpts opts)
  where
  convertOpts opts =
    { cwd: fromMaybe undefined opts.cwd
    , stdio: toActualStdIOOptions opts.stdio
    , env: toNullable opts.env
    , detached: opts.detached
    , uid: fromMaybe undefined opts.uid
    , gid: fromMaybe undefined opts.gid
    }

foreign import spawnImpl :: forall opts eff. String -> Array String -> { | opts } -> Eff (cp :: CHILD_PROCESS | eff) ChildProcess

-- There's gotta be a better way.
foreign import undefined :: forall a. a

-- | A special case of `spawn` for creating Node.js child processes. The first
-- | argument is the module to be run, and the second is the argv (command line
-- | arguments).
foreign import fork :: forall eff. String -> Array String -> Eff (cp :: CHILD_PROCESS | eff) ChildProcess

defaultSpawnOptions :: SpawnOptions
defaultSpawnOptions =
  { cwd: Nothing
  , stdio: pipe
  , env: Nothing
  , detached: false
  , uid: Nothing
  , gid: Nothing
  }

-- | An error which occurred inside a child process.
type ChildProcessError =
  { code :: String
  , errno :: String
  , syscall :: String
  }

-- | Behaviour for standard IO streams (eg, standard input, standard output) of
-- | a child process.
-- |
-- | * `Pipe`: creates a pipe between the child and parent process, which can
-- |   then be accessed as a `Stream` via the `stdin`, `stdout`, or `stderr`
-- |   functions.
-- | * `Ignore`: ignore this stream. This will cause Node to open /dev/null and
-- |   connect it to the stream.
-- | * `ShareStream`: Connect the supplied stream to the corresponding file
-- |    descriptor in the child.
-- | * `ShareFD`: Connect the supplied file descriptor (which should be open
-- |   in the parent) to the corresponding file descriptor in the child.
data StdIOBehaviour
  = Pipe
  | Ignore
  | ShareStream (forall r eff. Stream r eff)
  | ShareFD FS.FileDescriptor

-- | Create pipes for each of the three standard IO streams.
pipe :: Array (Maybe StdIOBehaviour)
pipe = map Just [Pipe, Pipe, Pipe]

-- | Share stdin with stdin, stdout with stdout, and stderr with stderr.
inherit :: Array (Maybe StdIOBehaviour)
inherit = map Just
  [ ShareStream process.stdin
  , ShareStream process.stdout
  , ShareStream process.stderr
  ]

foreign import process :: forall props. { | props }

-- | Ignore all streams.
ignore :: Array (Maybe StdIOBehaviour)
ignore = map Just [Ignore, Ignore, Ignore]

foreign import data ActualStdIOBehaviour :: *

toActualStdIOBehaviour :: StdIOBehaviour -> ActualStdIOBehaviour
toActualStdIOBehaviour b = case b of
  Pipe               -> c "pipe"
  Ignore             -> c "ignore"
  ShareFD x          -> c x
  ShareStream stream -> c stream
  where
  c :: forall a. a -> ActualStdIOBehaviour
  c = unsafeCoerce

type ActualStdIOOptions = Array (Nullable ActualStdIOBehaviour)

toActualStdIOOptions :: Array (Maybe StdIOBehaviour) -> ActualStdIOOptions
toActualStdIOOptions = map (toNullable <<< map toActualStdIOBehaviour)

module Node.ChildProcess
  ( Handle()
  , ChildProcess()
  , CHILD_PROCESS()
  , stderr
  , stdout
  , stdin
  , pid
  , connected
  , kill
  , send
  , disconnect
  , ChildProcessError()
  , ChildProcessExit(..)
  , onExit
  , onClose
  , onDisconnect
  , onMessage
  , onError
  , spawn
  , fork
  , SpawnOptions()
  , defaultSpawnOptions
  , StdIOBehaviour(..)
  , pipe
  , inherit
  , ignore
  ) where

import Prelude

import Control.Alt ((<|>))
import Control.Bind ((>=>))
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Exception.Unsafe (unsafeThrow)

import Data.StrMap (StrMap())
import Data.Function (Fn2(), runFn2)
import Data.Nullable (Nullable(), toNullable, toMaybe)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Foreign (Foreign())
import Data.Posix (Pid())
import Data.Posix.Signal (Signal())
import Data.Posix.Signal as Signal
import Unsafe.Coerce (unsafeCoerce)

import Node.FS as FS
import Node.Stream (Readable(), Writable(), Stream())

-- | A handle for inter-process communication (IPC).
foreign import data Handle :: *

-- | The effect for creating and interacting with child processes.
foreign import data CHILD_PROCESS :: !

newtype ChildProcess = ChildProcess ChildProcessRec

runChildProcess :: ChildProcess -> ChildProcessRec
runChildProcess (ChildProcess r) = r

-- | Note: some of these types are lies, and so it is unsafe to access some of
-- | these record fields directly.
type ChildProcessRec =
  { stdin      :: forall eff. Nullable (Writable () (cp :: CHILD_PROCESS | eff))
  , stdout     :: forall eff. Nullable (Readable () (cp :: CHILD_PROCESS | eff))
  , stderr     :: forall eff. Nullable (Readable () (cp :: CHILD_PROCESS | eff))
  , pid        :: Pid
  , connected  :: Boolean
  , kill       :: String -> Boolean
  , send       :: forall r. Fn2 { | r} Handle Boolean
  , disconnect :: forall eff. Eff eff Unit
  }

-- | The standard input stream of a child process. Note that this is only
-- | available if the process was spawned with the stdin option set to "pipe".
stdin :: forall eff. ChildProcess -> Writable () (cp :: CHILD_PROCESS | eff)
stdin = unsafeFromNullable (missingStream "stdin") <<< _.stdin <<< runChildProcess

-- | The standard output stream of a child process. Note that this is only
-- | available if the process was spawned with the stdout option set to "pipe".
stdout :: forall eff. ChildProcess -> Readable () (cp :: CHILD_PROCESS | eff)
stdout = unsafeFromNullable (missingStream "stdout") <<< _.stdout <<< runChildProcess

-- | The standard error stream of a child process. Note that this is only
-- | available if the process was spawned with the stderr option set to "pipe".
stderr :: forall eff. ChildProcess -> Readable () (cp :: CHILD_PROCESS| eff)
stderr = unsafeFromNullable (missingStream "stderr") <<< _.stderr <<< runChildProcess

missingStream :: String -> String
missingStream str =
  "Node.ChildProcess: stream not available: " <> str <> "\nThis is probably "
  <> "because you passed something other than Pipe to the stdio option when "
  <> "you spawned it."

foreign import unsafeFromNullable :: forall a. String -> Nullable a -> a

-- | The process ID of a child process. Note that if the process has already
-- | exited, another process may have taken the same ID, so be careful!
pid :: ChildProcess -> Pid
pid = _.pid <<< runChildProcess

connected :: forall eff. ChildProcess -> Eff (cp :: CHILD_PROCESS | eff) Boolean
connected = pure <<< _.connected <<< runChildProcess

send :: forall eff props. { | props } -> Handle -> ChildProcess -> Eff (cp :: CHILD_PROCESS | eff) Boolean
send msg handle (ChildProcess cp) = pure (runFn2 cp.send msg handle)

disconnect :: forall eff. ChildProcess -> Eff (cp :: CHILD_PROCESS | eff) Unit
disconnect = _.disconnect <<< runChildProcess

-- | Send a signal to a child process. It's an unfortunate historical decision
-- | that this function is called "kill", as sending a signal to a child
-- | process won't necessarily kill it.
kill :: forall eff. Signal -> ChildProcess -> Eff (cp :: CHILD_PROCESS | eff) Boolean
kill sig (ChildProcess cp) = pure (cp.kill (Signal.toString sig))

-- | Specifies how a child process exited; normally (with an exit code), or
-- | due to a signal.
data ChildProcessExit
  = Normally Int
  | BySignal Signal

instance showChildProcessExit :: Show ChildProcessExit where
  show (Normally x) = "Normally " <> show x
  show (BySignal sig) = "BySignal " <> show sig

type SpawnOptions =
  { cwd       :: Maybe String
  , stdio     :: Array (Maybe StdIOBehaviour)
  , env       :: Maybe (StrMap String)
  , detached  :: Boolean
  , uid       :: Maybe Int
  , gid       :: Maybe Int
  }

mkChildProcessExit :: Nullable Int -> Nullable String -> ChildProcessExit
mkChildProcessExit code signal =
  case fromCode code <|> fromSignal signal of
    Just e -> e
    Nothing -> unsafeThrow "Node.ChildProcess.mkChildProcessExit: Invalid arguments"
  where
  fromCode   = toMaybe >>> map Normally
  fromSignal = toMaybe >=> Signal.fromString >>> map BySignal

onExit :: forall eff. ChildProcess -> (ChildProcessExit -> Eff eff Unit) -> Eff eff Unit
onExit = mkOnExit mkChildProcessExit

foreign import mkOnExit :: forall eff.
          (Nullable Int -> Nullable String -> ChildProcessExit)
          -> ChildProcess -> (ChildProcessExit -> Eff eff Unit) -> Eff eff Unit

onClose :: forall eff. ChildProcess -> (ChildProcessExit -> Eff eff Unit) -> Eff eff Unit
onClose = mkOnClose mkChildProcessExit

foreign import mkOnClose :: forall eff.
          (Nullable Int -> Nullable String -> ChildProcessExit)
          -> ChildProcess -> (ChildProcessExit -> Eff eff Unit) -> Eff eff Unit

onMessage :: forall eff.  ChildProcess -> (Foreign -> Maybe Handle -> Eff eff Unit) -> Eff eff Unit
onMessage = mkOnMessage Nothing Just

foreign import mkOnMessage :: forall a eff.
          Maybe a -> (a -> Maybe a) ->
          ChildProcess -> (Foreign -> Maybe Handle -> Eff eff Unit) -> Eff eff Unit

foreign import onDisconnect :: forall eff. ChildProcess -> Eff eff Unit -> Eff eff Unit
foreign import onError :: forall eff. ChildProcess -> (ChildProcessError -> Eff eff Unit) -> Eff eff Unit

-- | Spawn a child process. Note that, in the event that a child process could
-- | not be spawned (for example, if the executable was not found) this will
-- | not throw an error. Instead, the `ChildProcess` will be created anyway,
-- | but it will immediately emit an 'error' event.
spawn :: forall eff. String -> Array String -> SpawnOptions -> Eff (cp :: CHILD_PROCESS | eff) ChildProcess
spawn cmd args opts = spawnImpl cmd args (convertOpts opts)
  where
  convertOpts opts =
    { cwd: fromMaybe undefined opts.cwd
    , stdio: toActualStdIOOptions opts.stdio
    , env: toNullable opts.env
    , detached: opts.detached
    , uid: fromMaybe undefined opts.uid
    , gid: fromMaybe undefined opts.gid
    }

foreign import spawnImpl :: forall opts eff. String -> Array String -> { | opts } -> Eff (cp :: CHILD_PROCESS | eff) ChildProcess

-- There's gotta be a better way.
foreign import undefined :: forall a. a

-- | A special case of `spawn` for creating Node.js child processes. The first
-- | argument is the module to be run, and the second is the argv (command line
-- | arguments).
foreign import fork :: forall eff. String -> Array String -> Eff (cp :: CHILD_PROCESS | eff) ChildProcess

defaultSpawnOptions :: SpawnOptions
defaultSpawnOptions =
  { cwd: Nothing
  , stdio: pipe
  , env: Nothing
  , detached: false
  , uid: Nothing
  , gid: Nothing
  }

-- | An error which occurred inside a child process.
type ChildProcessError =
  { code :: String
  , errno :: String
  , syscall :: String
  }

-- | Behaviour for standard IO streams (eg, standard input, standard output) of
-- | a child process.
-- |
-- | * `Pipe`: creates a pipe between the child and parent process, which can
-- |   then be accessed as a `Stream` via the `stdin`, `stdout`, or `stderr`
-- |   functions.
-- | * `Ignore`: ignore this stream. This will cause Node to open /dev/null and
-- |   connect it to the stream.
-- | * `ShareStream`: Connect the supplied stream to the corresponding file
-- |    descriptor in the child.
-- | * `ShareFD`: Connect the supplied file descriptor (which should be open
-- |   in the parent) to the corresponding file descriptor in the child.
data StdIOBehaviour
  = Pipe
  | Ignore
  | ShareStream (forall r eff. Stream r eff)
  | ShareFD FS.FileDescriptor

-- | Create pipes for each of the three standard IO streams.
pipe :: Array (Maybe StdIOBehaviour)
pipe = map Just [Pipe, Pipe, Pipe]

-- | Share stdin with stdin, stdout with stdout, and stderr with stderr.
inherit :: Array (Maybe StdIOBehaviour)
inherit = map Just
  [ ShareStream process.stdin
  , ShareStream process.stdout
  , ShareStream process.stderr
  ]

foreign import process :: forall props. { | props }

-- | Ignore all streams.
ignore :: Array (Maybe StdIOBehaviour)
ignore = map Just [Ignore, Ignore, Ignore]

foreign import data ActualStdIOBehaviour :: *

toActualStdIOBehaviour :: StdIOBehaviour -> ActualStdIOBehaviour
toActualStdIOBehaviour b = case b of
  Pipe               -> c "pipe"
  Ignore             -> c "ignore"
  ShareFD x          -> c x
  ShareStream stream -> c stream
  where
  c :: forall a. a -> ActualStdIOBehaviour
  c = unsafeCoerce

type ActualStdIOOptions = Array (Nullable ActualStdIOBehaviour)

toActualStdIOOptions :: Array (Maybe StdIOBehaviour) -> ActualStdIOOptions
toActualStdIOOptions = map (toNullable <<< map toActualStdIOBehaviour)