Click event callback encoding (Eff)

Click event callback encoding (Eff)

module Graphics.D3.Selection
  ( Selection()
  , Update()
  , Enter()
  , Exit()
  , Transition()
  , Void()
  , AttrValue
  , Existing
  , Appendable
  , Clickable
  , rootSelect
  , rootSelectAll
  , select
  , selectAll
  , bind
  , enter
  , exit
  , transition
  , append
  , remove
  , attr
  , attr'
  , attr''
  , style
  , style'
  , style''
  , text
  , text'
  , text''
  , delay
  , delay'
  , delay''
  , duration
  , duration'
  , duration''
  , onClick
  , onDoubleClick
  ) where

import Graphics.D3.Base
import Control.Monad.Eff

import Data.Foreign
import Data.Foreign.EasyFFI

ffi = unsafeForeignFunction

-- The "selection-y" types, parameterized by the type of their bound data
foreign import data Selection :: * -> *
foreign import data Update :: * -> *
foreign import data Enter :: * -> *
foreign import data Transition :: * -> *

-- Exit selections have the same semantics as regular selections
type Exit d = Selection d

-- The (uninhabited) type of an unbound selection's data
data Void

-- The class of types which element attribute values can have (numbers and strings)
class AttrValue a

instance attrValNumber :: AttrValue Number
instance attrValString :: AttrValue String

rootSelect :: String -> D3Eff (Selection Void)
rootSelect = ffi ["selector", ""] "d3.select(selector)"

rootSelectAll :: String -> D3Eff (Selection Void)
rootSelectAll = ffi ["selector", ""] "d3.selectAll(selector)"

select :: forall d. String -> Selection d -> D3Eff (Selection d)
select = ffi ["selector", "selection", ""] "selection.select(selector)"

selectAll :: forall d. String -> Selection d -> D3Eff (Selection Void)
selectAll = ffi ["selector", "selection", ""] "selection.selectAll(selector)"

bind :: forall oldData newData. [newData] -> Selection oldData -> D3Eff (Update newData)
bind = ffi ["array", "selection", ""] "selection.data(array)"

enter :: forall d. Update d -> D3Eff (Enter d)
enter = ffi ["update", ""] "update.enter()"

exit :: forall d. Update d -> D3Eff (Exit d)
exit = ffi ["update", ""] "update.exit()"

transition :: forall s d. (Existing s) => s d -> D3Eff (Transition d)
transition = ffi ["selection", ""] "selection.transition()"

unsafeAppend :: forall x y. String -> x -> D3Eff y
unsafeAppend = ffi ["tag", "selection", ""] "selection.append(tag)"

unsafeRemove :: forall s. s -> D3Eff Unit
unsafeRemove = ffi ["selection", ""] "selection.remove()"

unsafeAttr :: forall d v s. (AttrValue v) => String -> v -> s -> D3Eff s
unsafeAttr = ffi ["key", "val", "selection", ""] "selection.attr(key, val)"

unsafeAttr' :: forall d v s. (AttrValue v) => String -> (d -> v) -> s -> D3Eff s
unsafeAttr' = ffi ["key", "val", "selection", ""] "selection.attr(key, val)"

unsafeAttr'' :: forall d v s. (AttrValue v) => String -> (d -> Number -> v) -> s -> D3Eff s
unsafeAttr'' = ffi
  ["key", "val", "selection", ""]
  "selection.attr(key, function (d, i) { return val(d)(i); })"

unsafeStyle :: forall d s. String -> String -> s -> D3Eff s
unsafeStyle = ffi ["key", "val", "selection", ""] "selection.style(key, val)"

unsafeStyle' :: forall d s. String -> (d -> String) -> s -> D3Eff s
unsafeStyle' = ffi ["key", "val", "selection", ""] "selection.style(key, val)"

unsafeStyle'' :: forall d s. String -> (d -> Number -> String) -> s -> D3Eff s
unsafeStyle'' = ffi
  ["key", "val", "selection", ""]
  "selection.style(key, function (d, i) { return val(d)(i); })"

unsafeText :: forall d s. String -> s -> D3Eff s
unsafeText = ffi ["text", "selection", ""] "selection.text(text)"

unsafeText' :: forall d s. (d -> String) -> s -> D3Eff s
unsafeText' = ffi ["text", "selection", ""] "selection.text(text)"

unsafeText'' :: forall d s. (d -> Number -> String) -> s -> D3Eff s
unsafeText'' = ffi
  ["text", "selection", ""]
  "selection.text(function (d, i) { return text(d)(i); })"

unsafeOnClick :: forall eff c i r. (Clickable c) => (i -> Eff eff r) -> c -> D3Eff c
unsafeOnClick = ffi ["callback", "clickable", ""] "clickable.on('click', function(data) { callback(data)(); })"

unsafeOnDoubleClick :: forall eff c i r. (Clickable c) => (i -> Eff eff r) -> c -> D3Eff c
unsafeOnDoubleClick = ffi ["callback", "clickable", ""] "clickable.on('dblclick', function (data) { callback(data)(); })"

-- Transition-only stuff
delay :: forall d. Number -> Transition d -> D3Eff (Transition d)
delay = ffi ["delay", "transition", ""] "transition.delay(delay)"

delay' :: forall d. (d -> Number) -> Transition d -> D3Eff (Transition d)
delay' = ffi ["delay", "transition", ""] "transition.delay(delay)"

delay'' :: forall d. (d -> Number -> Number) -> Transition d -> D3Eff (Transition d)
delay'' = ffi
  ["delay", "transition", ""]
  "transition.delay(function (d, i) { return delay(d)(i); })"

duration :: forall d. Number -> Transition d -> D3Eff (Transition d)
duration = ffi ["duration", "transition", ""] "transition.duration(duration)"

duration' :: forall d. (d -> Number) -> Transition d -> D3Eff (Transition d)
duration' = ffi ["duration", "transition", ""] "transition.duration(duration)"

duration'' :: forall d. (d -> Number -> Number) -> Transition d -> D3Eff (Transition d)
duration'' = ffi
  ["duration", "transition", ""]
  "transition.duration(function (d, i) { return duration(d)(i); })"

-- Selection-y things which can be appended to / inserted into
class Appendable s where
  append :: forall d. String -> s d -> D3Eff (Selection d)

instance appendableSelection  :: Appendable Selection where
  append = unsafeAppend

instance appendableUpdate     :: Appendable Update where
  append = unsafeAppend

instance appendableEnter      :: Appendable Enter where
  append = unsafeAppend

-- Selection-y things that contain existing DOM elements
class Existing s where
  attr :: forall d v. (AttrValue v) => String -> v -> s d -> D3Eff (s d)
  attr' :: forall d v. (AttrValue v) => String -> (d -> v) -> s d -> D3Eff (s d)
  attr'' :: forall d v. (AttrValue v) => String -> (d -> Number -> v) -> s d -> D3Eff (s d)
  style :: forall d. String -> String -> s d -> D3Eff (s d)
  style' :: forall d. String -> (d -> String) -> s d -> D3Eff (s d)
  style'' :: forall d. String -> (d -> Number -> String) -> s d -> D3Eff (s d)
  text :: forall d. String -> s d -> D3Eff (s d)
  text' :: forall d. (d -> String) -> s d -> D3Eff (s d)
  text'' :: forall d. (d -> Number -> String) -> s d -> D3Eff (s d)
  remove :: forall d. s d -> D3Eff Unit

instance existingSelection :: Existing Selection where
  attr = unsafeAttr
  attr' = unsafeAttr'
  attr'' = unsafeAttr''
  style = unsafeStyle
  style' = unsafeStyle'
  style'' = unsafeStyle''
  text = unsafeText
  text' = unsafeText'
  text'' = unsafeText''
  remove = unsafeRemove

instance existingUpdate :: Existing Update where
  attr = unsafeAttr
  attr' = unsafeAttr'
  attr'' = unsafeAttr''
  style = unsafeStyle
  style' = unsafeStyle'
  style'' = unsafeStyle''
  text = unsafeText
  text' = unsafeText'
  text'' = unsafeText''
  remove = unsafeRemove

instance existingTransition :: Existing Transition where
  attr = unsafeAttr
  attr' = unsafeAttr'
  attr'' = unsafeAttr''
  style = unsafeStyle
  style' = unsafeStyle'
  style'' = unsafeStyle''
  text = unsafeText
  text' = unsafeText'
  text'' = unsafeText''
  remove = unsafeRemove

class Clickable c where
  onClick :: forall eff r. (Foreign -> Eff eff r) -> c -> D3Eff c
  onDoubleClick :: forall eff r. (Foreign -> Eff eff r) -> c -> D3Eff c

instance clickableSelection :: Clickable (Selection a) where
  onClick = unsafeOnClick
  onDoubleClick = unsafeOnDoubleClick

module Graphics.D3.Selection
  ( Selection()
  , Update()
  , Enter()
  , Exit()
  , Transition()
  , Void()
  , AttrValue
  , Existing
  , Appendable
  , Clickable
  , rootSelect
  , rootSelectAll
  , select
  , selectAll
  , bind
  , enter
  , exit
  , transition
  , append
  , remove
  , attr
  , attr'
  , attr''
  , style
  , style'
  , style''
  , text
  , text'
  , text''
  , delay
  , delay'
  , delay''
  , duration
  , duration'
  , duration''
  , onClick
  , onDoubleClick
  ) where

import Graphics.D3.Base
import Control.Monad.Eff

import Data.Foreign
import Data.Foreign.EasyFFI

ffi = unsafeForeignFunction

-- The "selection-y" types, parameterized by the type of their bound data
foreign import data Selection :: * -> *
foreign import data Update :: * -> *
foreign import data Enter :: * -> *
foreign import data Transition :: * -> *

-- Exit selections have the same semantics as regular selections
type Exit d = Selection d

-- The (uninhabited) type of an unbound selection's data
data Void

-- The class of types which element attribute values can have (numbers and strings)
class AttrValue a

instance attrValNumber :: AttrValue Number
instance attrValString :: AttrValue String

rootSelect :: String -> D3Eff (Selection Void)
rootSelect = ffi ["selector", ""] "d3.select(selector)"

rootSelectAll :: String -> D3Eff (Selection Void)
rootSelectAll = ffi ["selector", ""] "d3.selectAll(selector)"

select :: forall d. String -> Selection d -> D3Eff (Selection d)
select = ffi ["selector", "selection", ""] "selection.select(selector)"

selectAll :: forall d. String -> Selection d -> D3Eff (Selection Void)
selectAll = ffi ["selector", "selection", ""] "selection.selectAll(selector)"

bind :: forall oldData newData. [newData] -> Selection oldData -> D3Eff (Update newData)
bind = ffi ["array", "selection", ""] "selection.data(array)"

enter :: forall d. Update d -> D3Eff (Enter d)
enter = ffi ["update", ""] "update.enter()"

exit :: forall d. Update d -> D3Eff (Exit d)
exit = ffi ["update", ""] "update.exit()"

transition :: forall s d. (Existing s) => s d -> D3Eff (Transition d)
transition = ffi ["selection", ""] "selection.transition()"

unsafeAppend :: forall x y. String -> x -> D3Eff y
unsafeAppend = ffi ["tag", "selection", ""] "selection.append(tag)"

unsafeRemove :: forall s. s -> D3Eff Unit
unsafeRemove = ffi ["selection", ""] "selection.remove()"

unsafeAttr :: forall d v s. (AttrValue v) => String -> v -> s -> D3Eff s
unsafeAttr = ffi ["key", "val", "selection", ""] "selection.attr(key, val)"

unsafeAttr' :: forall d v s. (AttrValue v) => String -> (d -> v) -> s -> D3Eff s
unsafeAttr' = ffi ["key", "val", "selection", ""] "selection.attr(key, val)"

unsafeAttr'' :: forall d v s. (AttrValue v) => String -> (d -> Number -> v) -> s -> D3Eff s
unsafeAttr'' = ffi
  ["key", "val", "selection", ""]
  "selection.attr(key, function (d, i) { return val(d)(i); })"

unsafeStyle :: forall d s. String -> String -> s -> D3Eff s
unsafeStyle = ffi ["key", "val", "selection", ""] "selection.style(key, val)"

unsafeStyle' :: forall d s. String -> (d -> String) -> s -> D3Eff s
unsafeStyle' = ffi ["key", "val", "selection", ""] "selection.style(key, val)"

unsafeStyle'' :: forall d s. String -> (d -> Number -> String) -> s -> D3Eff s
unsafeStyle'' = ffi
  ["key", "val", "selection", ""]
  "selection.style(key, function (d, i) { return val(d)(i); })"

unsafeText :: forall d s. String -> s -> D3Eff s
unsafeText = ffi ["text", "selection", ""] "selection.text(text)"

unsafeText' :: forall d s. (d -> String) -> s -> D3Eff s
unsafeText' = ffi ["text", "selection", ""] "selection.text(text)"

unsafeText'' :: forall d s. (d -> Number -> String) -> s -> D3Eff s
unsafeText'' = ffi
  ["text", "selection", ""]
  "selection.text(function (d, i) { return text(d)(i); })"

unsafeOnClick :: forall eff c i r. (Clickable c) => (i -> Eff eff r) -> c -> D3Eff c
unsafeOnClick = ffi ["callback", "clickable", ""] "clickable.on('click', callback)"

unsafeOnDoubleClick :: forall eff c i r. (Clickable c) => (i -> Eff eff r) -> c -> D3Eff c
unsafeOnDoubleClick = ffi ["callback", "clickable", ""] "clickable.on('dblclick', callback)"

-- Transition-only stuff
delay :: forall d. Number -> Transition d -> D3Eff (Transition d)
delay = ffi ["delay", "transition", ""] "transition.delay(delay)"

delay' :: forall d. (d -> Number) -> Transition d -> D3Eff (Transition d)
delay' = ffi ["delay", "transition", ""] "transition.delay(delay)"

delay'' :: forall d. (d -> Number -> Number) -> Transition d -> D3Eff (Transition d)
delay'' = ffi
  ["delay", "transition", ""]
  "transition.delay(function (d, i) { return delay(d)(i); })"

duration :: forall d. Number -> Transition d -> D3Eff (Transition d)
duration = ffi ["duration", "transition", ""] "transition.duration(duration)"

duration' :: forall d. (d -> Number) -> Transition d -> D3Eff (Transition d)
duration' = ffi ["duration", "transition", ""] "transition.duration(duration)"

duration'' :: forall d. (d -> Number -> Number) -> Transition d -> D3Eff (Transition d)
duration'' = ffi
  ["duration", "transition", ""]
  "transition.duration(function (d, i) { return duration(d)(i); })"

-- Selection-y things which can be appended to / inserted into
class Appendable s where
  append :: forall d. String -> s d -> D3Eff (Selection d)

instance appendableSelection  :: Appendable Selection where
  append = unsafeAppend

instance appendableUpdate     :: Appendable Update where
  append = unsafeAppend

instance appendableEnter      :: Appendable Enter where
  append = unsafeAppend

-- Selection-y things that contain existing DOM elements
class Existing s where
  attr :: forall d v. (AttrValue v) => String -> v -> s d -> D3Eff (s d)
  attr' :: forall d v. (AttrValue v) => String -> (d -> v) -> s d -> D3Eff (s d)
  attr'' :: forall d v. (AttrValue v) => String -> (d -> Number -> v) -> s d -> D3Eff (s d)
  style :: forall d. String -> String -> s d -> D3Eff (s d)
  style' :: forall d. String -> (d -> String) -> s d -> D3Eff (s d)
  style'' :: forall d. String -> (d -> Number -> String) -> s d -> D3Eff (s d)
  text :: forall d. String -> s d -> D3Eff (s d)
  text' :: forall d. (d -> String) -> s d -> D3Eff (s d)
  text'' :: forall d. (d -> Number -> String) -> s d -> D3Eff (s d)
  remove :: forall d. s d -> D3Eff Unit

instance existingSelection :: Existing Selection where
  attr = unsafeAttr
  attr' = unsafeAttr'
  attr'' = unsafeAttr''
  style = unsafeStyle
  style' = unsafeStyle'
  style'' = unsafeStyle''
  text = unsafeText
  text' = unsafeText'
  text'' = unsafeText''
  remove = unsafeRemove

instance existingUpdate :: Existing Update where
  attr = unsafeAttr
  attr' = unsafeAttr'
  attr'' = unsafeAttr''
  style = unsafeStyle
  style' = unsafeStyle'
  style'' = unsafeStyle''
  text = unsafeText
  text' = unsafeText'
  text'' = unsafeText''
  remove = unsafeRemove

instance existingTransition :: Existing Transition where
  attr = unsafeAttr
  attr' = unsafeAttr'
  attr'' = unsafeAttr''
  style = unsafeStyle
  style' = unsafeStyle'
  style'' = unsafeStyle''
  text = unsafeText
  text' = unsafeText'
  text'' = unsafeText''
  remove = unsafeRemove

class Clickable c where
  onClick :: forall eff r. (Foreign -> Eff eff r) -> c -> D3Eff c
  onDoubleClick :: forall eff r. (Foreign -> Eff eff r) -> c -> D3Eff c

instance clickableSelection :: Clickable (Selection a) where
  onClick = unsafeOnClick
  onDoubleClick = unsafeOnDoubleClick


Write reporter tests

Write reporter tests

module Main where

import Data.Array
import Control.Monad.Eff.Exception
import Test.Spec
import Test.Spec.Node
import Test.Spec.Assertions
import qualified Test.Spec.Reporter as R

successTest =
  describe "a" do
    describe "b" do
      it "works" do
        1 `shouldEqual` 1

sharedDescribeTest =
  describe "a" do
    describe "b" do
      it "works" do
        1 `shouldEqual` 1
    describe "c" do
      it "also works" do
        1 `shouldEqual` 1

failureTest = it "fails" $ 1 `shouldEqual` 2

pendingTest = pending "is not written yet"

main = runNode $
  describe "Test" do
    describe "Spec" do
      describe "Runner" do
        it "collects \"it\" and \"pending\" in Describe groups" do
          results <- collect successTest
          results `shouldEqual` [Describe "a" [Describe "b" [It "works" Success]]]
        it "collects \"it\" and \"pending\" with shared Describes" do
          results <- collect sharedDescribeTest
          results `shouldEqual` [Describe "a" [Describe "b" [It "works" Success],
                                               Describe "c" [It "also works" Success]]]
      describe "Reporter" do
        it "collapses groups into entries with names" do
          results <- collect successTest
          concatMap R.collapse results `shouldEqual` [
              R.Describe ["a", "b"],
              R.It "works" Success
            ]
        it "collapses groups into entries with shared describes" do
          results <- collect sharedDescribeTest
          concatMap R.collapse results `shouldEqual` [
              R.Describe ["a", "b"],
              R.It "works" Success,
              R.Describe ["a", "c"],
              R.It "also works" Success
            ]
        it "reports failured tests" do
          results <- collect failureTest
          concatMap R.collapse results `shouldEqual` [
            R.It "fails" (Failure (error "1 ≠ 2"))
          ]
        it "reports pending tests" do
          results <- collect pendingTest
          concatMap R.collapse results `shouldEqual` [
            R.Pending "is not written yet"
          ]

module Main where

import Data.Array
import Test.Spec
import Test.Spec.Node
import Test.Spec.Assertions
import qualified Test.Spec.Reporter as R

successTest =
  describe "a" do
    describe "b" do
      it "works" do
        1 `shouldEqual` 1

sharedDescribeTest =
  describe "a" do
    describe "b" do
      it "works" do
        1 `shouldEqual` 1
    describe "c" do
      it "also works" do
        1 `shouldEqual` 1

main = runNode $
  describe "Test" do
    describe "Spec" do
      describe "Runner" do
        it "collects \"it\" and \"pending\" in Describe groups" do
          results <- collect successTest
          results `shouldEqual` [Describe "a" [Describe "b" [It "works" Success]]]
        it "collects \"it\" and \"pending\" with shared Describes" do
          results <- collect sharedDescribeTest
          results `shouldEqual` [Describe "a" [Describe "b" [It "works" Success],
                                               Describe "c" [It "also works" Success]]]
      describe "Reporter" do
        it "collapses groups into entries with names" do
          results <- collect successTest
          concatMap R.collapse results `shouldEqual` [
              R.Describe ["a", "b"],
              R.It "works" Success
            ]
        it "collapses groups into entries with shared describes" do
          results <- collect sharedDescribeTest
          concatMap R.collapse results `shouldEqual` [
              R.Describe ["a", "b"],
              R.It "works" Success,
              R.Describe ["a", "c"],
              R.It "also works" Success
            ]
        pending "reports errors"
        pending "reports pending"


Fix inequality test to actually test /=

Fix inequality test to actually test /=

module Main where

import Data.Maybe
import Debug.Trace
import Control.Monad.Eff
import Test.QuickCheck
import Test.QuickCheck.Functions
import Test.QuickCheck.Classes

type Ty = Maybe Number

main = do

  let ty = Just 0

  trace "test equality"
  check1 $ \n -> Just n == Just n
  assert $ Nothing == Nothing :: Ty

  trace "test inequality"
  check1 $ \n -> Just n  /= Nothing
  check1 $ \n -> Nothing /= Just n
  check1 $ \n -> Just n  /= Just (n + 1)

  trace "test order"
  check2 $ \x y -> compare (Just x) (Just y) == compare x y
  check1 $ \x -> compare Nothing (Just x) == LT
  check1 $ \x -> compare (Just x) Nothing == GT
  check1 $ \x -> compare Nothing (Nothing :: Ty) == EQ

  trace "maybe should transform a value wrapped in a Just"
  check1 $ \n -> maybe 0 negate (Just n) == -n

  trace "maybe should return the default value when applied to Nothing"
  check1 $ \n -> maybe n id Nothing == n

  trace "isJust should return the appropriate value"
  assert $ isJust (Just {}) == true
  assert $ isJust Nothing == false

  trace "isNothing should return the appropriate value"
  assert $ isNothing Nothing == true
  assert $ isNothing (Just {}) == false

  trace "test functor laws"
  checkFunctor ty

  trace "test applicative laws"
  checkApplicative ty ty ty

  trace "test monad laws"
  checkMonad ty

assert :: Boolean -> QC
assert = quickCheck' 1

check1 :: (Number -> Boolean) -> QC
check1 = quickCheck

check2 :: (Number -> Number -> Boolean) -> QC
check2 = quickCheck

instance arbAToMaybeB :: (Arb (a -> b)) => Arb (a -> Maybe b) where
  arb = do
    f <- arb
    return $ \x -> Just (f x)

instance showAToMaybeB :: (Arb (a -> b)) => Show (a -> Maybe b) where
  show _ = "<a -> Maybe b>"

module Main where

import Data.Maybe
import Debug.Trace
import Control.Monad.Eff
import Test.QuickCheck
import Test.QuickCheck.Functions
import Test.QuickCheck.Classes

main = do

  let ty = Just 0

  trace "test equality"
  check1 $ \n -> Just n == Just n
  assert $ Nothing == Nothing :: Maybe Number

  trace "test inequality"
  check1 $ \n -> not $ Just n == Nothing
  check1 $ \n -> not $ Nothing == Just n
  check1 $ \n -> not $ Just n == Just (n + 1)

  trace "test order"
  check2 $ \x y -> compare (Just x) (Just y) == compare x y
  check1 $ \x -> compare Nothing (Just x) == LT
  check1 $ \x -> compare (Just x) Nothing == GT
  check1 $ \x -> compare Nothing (Nothing :: Maybe Number) == EQ

  trace "maybe should transform a value wrapped in a Just"
  check1 $ \n -> maybe 0 negate (Just n) == -n

  trace "maybe should return the default value when applied to Nothing"
  check1 $ \n -> maybe n id Nothing == n

  trace "isJust should return the appropriate value"
  assert $ isJust (Just {}) == true
  assert $ isJust Nothing == false

  trace "isNothing should return the appropriate value"
  assert $ isNothing Nothing == true
  assert $ isNothing (Just {}) == false

  trace "test functor laws"
  checkFunctor ty

  trace "test applicative laws"
  checkApplicative ty ty ty

  trace "test monad laws"
  checkMonad ty

assert :: Boolean -> QC
assert = quickCheck' 1

check1 :: (Number -> Boolean) -> QC
check1 = quickCheck

check2 :: (Number -> Number -> Boolean) -> QC
check2 = quickCheck

instance arbAToMaybeB :: (Arb (a -> b)) => Arb (a -> Maybe b) where
  arb = do
    f <- arb
    return $ \x -> Just (f x)

instance showAToMaybeB :: (Arb (a -> b)) => Show (a -> Maybe b) where
  show _ = "<a -> Maybe b>"


Remove orphan Bounded Char instances

Remove orphan Bounded Char instances

-- | A type and functions for single characters.
module Data.Char
  ( toString
  , fromCharCode
  , toCharCode
  , toLower
  , toUpper
  ) where

import Prelude

-- | Returns the string of length `1` containing only the given character.
foreign import toString :: Char -> String

-- | Returns the numeric Unicode value of the character.
foreign import toCharCode :: Char -> Int

-- | Constructs a character from the given Unicode numeric value.
foreign import fromCharCode :: Int -> Char

-- | Converts a character to lowercase.
foreign import toLower :: Char -> Char

-- | Converts a character to uppercase.
foreign import toUpper :: Char -> Char

-- | Characters fall within the Unicode range.
instance boundedChar :: Bounded Char where
  top = fromCharCode zero
  bottom = fromCharCode 65535


export all type class functions

export all type class functions

module Data.Enum
  ( Enum
  , Cardinality(..)
  , cardinality
  , firstEnum
  , fromEnum
  , lastEnum
  , pred
  , runCardinality
  , succ
  , toEnum
  ) where

  import Data.Maybe
  import Data.Tuple
  import Data.Maybe.Unsafe

  newtype Cardinality a = Cardinality Number

  runCardinality :: forall a. Cardinality a -> Number
  runCardinality (Cardinality a) = a

  -- | Type class for enumerations. This should not be considered a part of a
  -- | numeric hierarchy, ala Haskell. Rather, this is a type class for small,
  -- | ordered sum types with statically-determined cardinality and the ability
  -- | to easily compute successor and predecessor elements. e.g. DayOfWeek, etc.
  -- |
  -- | Laws:
  -- |   succ firstEnum >>= succ >>= succ ... succ [cardinality times] == lastEnum
  -- |   pred lastEnum  >>= pred >>= pred ... pred [cardinality times] == firstEnum
  -- |
  -- |   Just $ e1 `compare` e2 == fromEnum e1 `compare` fromEnum e2
  -- |
  -- |   for all a > firstEnum: pred a >>= succ == Just a
  -- |   for all a < lastEnum:  succ a >>= pred == Just a
  class (Ord a) <= Enum a where
    cardinality :: Cardinality a

    firstEnum :: a

    lastEnum :: a

    succ :: a -> Maybe a

    pred :: a -> Maybe a

  toEnum :: forall a. (Enum a) => Number -> Maybe a
  toEnum n | n < 0 = Nothing
  toEnum 0         = Just firstEnum
  toEnum n         = toEnum (n - 1) >>= succ

  fromEnum :: forall a. (Enum a) => a -> Number
  fromEnum e = maybe 0 ((+) 1 <<< fromEnum) (pred e)

  maybeCardinality :: forall a. (Enum a) => Cardinality a -> Cardinality (Maybe a)
  maybeCardinality c = Cardinality $ 1 + (runCardinality c)

  instance enumMaybe :: (Enum a) => Enum (Maybe a) where
    cardinality = maybeCardinality cardinality

    firstEnum = Nothing

    lastEnum = Just $ lastEnum

    succ Nothing = Just $ firstEnum
    succ (Just a) = Just <$> succ a

    pred Nothing = Nothing
    pred (Just a) = Just <$> pred a

  instance enumBoolean :: Enum Boolean where
    cardinality = Cardinality 2

    firstEnum = false

    lastEnum = true

    succ false = Just true
    succ _     = Nothing

    pred true  = Just false
    pred _     = Nothing

  instance enumTuple :: (Enum a, Enum b) => Enum (Tuple a b) where
    cardinality = tupleCardinality cardinality cardinality

    firstEnum = Tuple firstEnum firstEnum

    lastEnum = Tuple lastEnum lastEnum

    succ (Tuple a b) = maybe (flip Tuple firstEnum <$> succ a) (Just <<< Tuple a) (succ b)

    pred (Tuple a b) = maybe (flip Tuple firstEnum <$> pred a) (Just <<< Tuple a) (pred b)

  tupleCardinality :: forall a b. (Enum a, Enum b) => Cardinality a -> Cardinality b -> Cardinality (Tuple a b)
  tupleCardinality l r = Cardinality $ (runCardinality l) * (runCardinality r)

module Data.Enum
  ( Enum
  , Cardinality(..)
  , fromEnum
  , runCardinality
  , toEnum
  ) where

  import Data.Maybe
  import Data.Tuple
  import Data.Maybe.Unsafe

  newtype Cardinality a = Cardinality Number

  runCardinality :: forall a. Cardinality a -> Number
  runCardinality (Cardinality a) = a

  -- | Type class for enumerations. This should not be considered a part of a
  -- | numeric hierarchy, ala Haskell. Rather, this is a type class for small,
  -- | ordered sum types with statically-determined cardinality and the ability
  -- | to easily compute successor and predecessor elements. e.g. DayOfWeek, etc.
  -- |
  -- | Laws:
  -- |   succ firstEnum >>= succ >>= succ ... succ [cardinality times] == lastEnum
  -- |   pred lastEnum  >>= pred >>= pred ... pred [cardinality times] == firstEnum
  -- |
  -- |   Just $ e1 `compare` e2 == fromEnum e1 `compare` fromEnum e2
  -- |
  -- |   for all a > firstEnum: pred a >>= succ == Just a
  -- |   for all a < lastEnum:  succ a >>= pred == Just a
  class (Ord a) <= Enum a where
    cardinality :: Cardinality a

    firstEnum :: a

    lastEnum :: a

    succ :: a -> Maybe a

    pred :: a -> Maybe a

  toEnum :: forall a. (Enum a) => Number -> Maybe a
  toEnum n | n < 0 = Nothing
  toEnum 0         = Just firstEnum
  toEnum n         = toEnum (n - 1) >>= succ

  fromEnum :: forall a. (Enum a) => a -> Number
  fromEnum e = maybe 0 ((+) 1 <<< fromEnum) (pred e)

  maybeCardinality :: forall a. (Enum a) => Cardinality a -> Cardinality (Maybe a)
  maybeCardinality c = Cardinality $ 1 + (runCardinality c)

  instance enumMaybe :: (Enum a) => Enum (Maybe a) where
    cardinality = maybeCardinality cardinality

    firstEnum = Nothing

    lastEnum = Just $ lastEnum

    succ Nothing = Just $ firstEnum
    succ (Just a) = Just <$> succ a

    pred Nothing = Nothing
    pred (Just a) = Just <$> pred a

  instance enumBoolean :: Enum Boolean where
    cardinality = Cardinality 2

    firstEnum = false

    lastEnum = true

    succ false = Just true
    succ _     = Nothing

    pred true  = Just false
    pred _     = Nothing

  instance enumTuple :: (Enum a, Enum b) => Enum (Tuple a b) where
    cardinality = tupleCardinality cardinality cardinality

    firstEnum = Tuple firstEnum firstEnum

    lastEnum = Tuple lastEnum lastEnum

    succ (Tuple a b) = maybe (flip Tuple firstEnum <$> succ a) (Just <<< Tuple a) (succ b)

    pred (Tuple a b) = maybe (flip Tuple firstEnum <$> pred a) (Just <<< Tuple a) (pred b)

  tupleCardinality :: forall a b. (Enum a, Enum b) => Cardinality a -> Cardinality b -> Cardinality (Tuple a b)
  tupleCardinality l r = Cardinality $ (runCardinality l) * (runCardinality r)


Tweak showJSONImpl, readJSONArray

Tweak showJSONImpl, readJSONArray

module Data.JSON
  ( JSON(..)
  , JSONParser(JSONParser)
  , ReadJSON
  , runParser
  , readJSON
  , readJSONProp
  , parseJSON
  ) where

import Prelude
import Data.Array
import Data.Either
import Data.Maybe
import Data.Tuple
import Control.Monad

foreign import data JSON :: *

foreign import fromString
  "function fromString (str) { \
  \  try { \
  \    return _ps.Data_Either.Right(JSON.parse(str)); \
  \  } catch (e) { \
  \    return _ps.Data_Either.Left(e.toString()); \
  \  } \
  \}" :: String -> Either String JSON

foreign import readPrimType
  "function readPrimType (typeName) { \
  \  return function (value) { \
  \    if (toString.call(value) == '[object ' + typeName + ']') { \
  \      return _ps.Data_Either.Right(value);\
  \    } \
  \    return _ps.Data_Either.Left('Value is not a ' + typeName + ''); \
  \  }; \
  \}" :: forall a. String -> JSON -> Either String a

foreign import readMaybe
  "function readMaybe (value) { \
  \  return value === undefined || value === null ? _ps.Data_Maybe.Nothing : _ps.Data_Maybe.Just(value); \
  \}" :: forall a. JSON -> Maybe JSON

foreign import readProp
  "function readProp (k) { \
  \  return function (obj) { \
  \    return _ps.Data_Either.Right(obj[k]);\
  \  }; \
  \}" :: forall a. String -> JSON -> Either String JSON

foreign import showJSONImpl "var showJSONImpl = JSON.stringify;" :: JSON -> String

instance showJSON :: Prelude.Show JSON where
  show = showJSONImpl

data JSONParser a = JSONParser (JSON -> Either String a)

runParser :: forall a. JSONParser a -> JSON -> Either String a
runParser (JSONParser p) x = p x

instance monadJSONParser :: Prelude.Monad JSONParser where
  return x = JSONParser \_ -> Right x
  (>>=) (JSONParser p) f = JSONParser \x -> case p x of
      Left err -> Left err
      Right x' -> runParser (f x') x

instance applicativeJSONParser :: Prelude.Applicative JSONParser where
  pure x = JSONParser \_ -> Right x
  (<*>) (JSONParser f) (JSONParser p) = JSONParser \x -> case f x of
      Left err -> Left err
      Right f' -> f' <$> p x

instance functorJSONParser :: Prelude.Functor JSONParser where
  (<$>) f (JSONParser p) = JSONParser \x -> f <$> p x

class ReadJSON a where
  readJSON :: JSONParser a

instance readJSONString :: ReadJSON String where
  readJSON = JSONParser $ readPrimType "String"

instance readJSONNumber :: ReadJSON Number where
  readJSON = JSONParser $ readPrimType "Number"

instance readJSONBoolean :: ReadJSON Boolean where
  readJSON = JSONParser $ readPrimType "Boolean"

instance readJSONArray :: (ReadJSON a) => ReadJSON [a] where
  readJSON =
    let arrayItem (Tuple i x) = case runParser readJSON x of
      Right result -> Right result
      Left err -> Left $ "Error reading item at index " ++ (show i) ++ ":\n" ++ err
    in
    (JSONParser $ readPrimType "Array") >>= \xs -> JSONParser \_ ->
      arrayItem `mapM` (zip (range 0 (length xs)) xs)

instance readJSONMaybe :: (ReadJSON a) => ReadJSON (Maybe a) where
  readJSON = (JSONParser $ Right <<< readMaybe) >>= \x -> JSONParser \_ ->
    case x of
      Just x' -> runParser readJSON x' >>= return <<< Just
      Nothing -> return Nothing

readJSONProp :: forall a. (ReadJSON a) => String -> JSONParser a
readJSONProp p = (JSONParser \x -> readProp p x) >>= \x -> JSONParser \_ ->
  case runParser readJSON x of
    Right result -> Right result
    Left err -> Left $ "Error reading property '" ++ p ++ "':\n" ++ err

parseJSON :: forall a. (ReadJSON a) => String -> Either String a
parseJSON json = fromString json >>= runParser readJSON

module Data.JSON
  ( JSON(..)
  , JSONParser(JSONParser)
  , ReadJSON
  , runParser
  , readJSON
  , readJSONProp
  , parseJSON
  ) where

import Prelude
import Data.Array
import Data.Either
import Data.Maybe
import Data.Tuple
import Control.Monad

foreign import data JSON :: *

foreign import fromString
  "function fromString (str) { \
  \  try { \
  \    return _ps.Data_Either.Right(JSON.parse(str)); \
  \  } catch (e) { \
  \    return _ps.Data_Either.Left(e.toString()); \
  \  } \
  \}" :: String -> Either String JSON

foreign import readPrimType
  "function readPrimType (typeName) { \
  \  return function (value) { \
  \    if (toString.call(value) == '[object ' + typeName + ']') { \
  \      return _ps.Data_Either.Right(value);\
  \    } \
  \    return _ps.Data_Either.Left('Value is not a ' + typeName + ''); \
  \  }; \
  \}" :: forall a. String -> JSON -> Either String a

foreign import readMaybe
  "function readMaybe (value) { \
  \  return value === undefined || value === null ? _ps.Data_Maybe.Nothing : _ps.Data_Maybe.Just(value); \
  \}" :: forall a. JSON -> Maybe JSON

foreign import readProp
  "function readProp (k) { \
  \  return function (obj) { \
  \    return _ps.Data_Either.Right(obj[k]);\
  \  }; \
  \}" :: forall a. String -> JSON -> Either String JSON

foreign import showJSONImpl
  "function showJSONImpl (obj) { \
  \  return JSON.stringify(obj); \
  \}" :: JSON -> String

instance showJSON :: Prelude.Show JSON where
  show = showJSONImpl

data JSONParser a = JSONParser (JSON -> Either String a)

runParser :: forall a. JSONParser a -> JSON -> Either String a
runParser (JSONParser p) x = p x

instance monadJSONParser :: Prelude.Monad JSONParser where
  return x = JSONParser \_ -> Right x
  (>>=) (JSONParser p) f = JSONParser \x -> case p x of
      Left err -> Left err
      Right x' -> runParser (f x') x

instance applicativeJSONParser :: Prelude.Applicative JSONParser where
  pure x = JSONParser \_ -> Right x
  (<*>) (JSONParser f) (JSONParser p) = JSONParser \x -> case f x of
      Left err -> Left err
      Right f' -> f' <$> p x

instance functorJSONParser :: Prelude.Functor JSONParser where
  (<$>) f (JSONParser p) = JSONParser \x -> f <$> p x

class ReadJSON a where
  readJSON :: JSONParser a

instance readJSONString :: ReadJSON String where
  readJSON = JSONParser $ readPrimType "String"

instance readJSONNumber :: ReadJSON Number where
  readJSON = JSONParser $ readPrimType "Number"

instance readJSONBoolean :: ReadJSON Boolean where
  readJSON = JSONParser $ readPrimType "Boolean"

instance readJSONArray :: (ReadJSON a) => ReadJSON [a] where
  readJSON = (JSONParser $ readPrimType "Array") >>= \xs -> JSONParser \_ ->
    readJSONArrayItem `mapM` (zip (range 0 (length xs)) xs)

readJSONArrayItem :: forall a. (ReadJSON a) => Tuple Number JSON -> Either String a
readJSONArrayItem (Tuple i x) = case runParser readJSON x of
    Right result -> Right result
    Left err -> Left $ "Error reading item at index " ++ (show i) ++ ":\n" ++ err

instance readJSONMaybe :: (ReadJSON a) => ReadJSON (Maybe a) where
  readJSON = (JSONParser $ Right <<< readMaybe) >>= \x -> JSONParser \_ ->
    case x of
      Just x' -> runParser readJSON x' >>= return <<< Just
      Nothing -> return Nothing

readJSONProp :: forall a. (ReadJSON a) => String -> JSONParser a
readJSONProp p = (JSONParser \x -> readProp p x) >>= \x -> JSONParser \_ ->
  case runParser readJSON x of
    Right result -> Right result
    Left err -> Left $ "Error reading property '" ++ p ++ "':\n" ++ err

parseJSON :: forall a. (ReadJSON a) => String -> Either String a
parseJSON json = fromString json >>= runParser readJSON


Match list literals with conses, and vice versa.

module Evaluator
  ( Path(..)
  , Env()
  , evalPath1
  , defsToEnv
  ) where

import Data.Array    (head, mapMaybe, (!!), updateAt, elemIndex, length, concat, concatMap, nub, (\\), intersect, drop)
import Data.StrMap   (StrMap(), empty, lookup, insert, delete, values)
import Data.Tuple    (Tuple(Tuple), fst, snd)
import Data.Maybe
import Data.Foldable (foldl, foldr, foldMap, any)
import Data.Traversable (zipWithA, traverse)
import Data.Identity
import Data.Either

import Math (pow)

import Control.Apply ((*>))
import Control.Alt ((<|>))
import qualified Control.Plus as P
import Control.Monad.State
import Control.Monad.State.Trans
import Control.Monad.State.Class

import Control.Monad.Writer
import Control.Monad.Writer.Trans
import Control.Monad.Writer.Class

import Control.Monad.Error
import Control.Monad.Error.Trans
import Control.Monad.Error.Class

import Control.Monad.Trans

import AST

type Matching = Tuple Atom Expr

type Evaluator = ErrorT String Identity

runEvalM :: forall a. Evaluator a -> Either String a
runEvalM = runIdentity <<< runErrorT

data Path = Nth Number Path
          | Fst Path
          | Snd Path
          | Thrd Path
          | End

instance showPath :: Show Path where
  show p = case p of
    Nth i p -> "(Nth " ++ show i ++ " " ++ show p ++")"
    Fst   p -> "(Fst " ++ show p ++")"
    Snd   p -> "(Snd " ++ show p ++")"
    Thrd   p -> "(Thrd " ++ show p ++")"
    End     -> "End"

mapWithPath :: Path -> (Expr -> Evaluator Expr) -> Expr -> Evaluator Expr
mapWithPath p f = go p
  where
  go End e     = f e
  go (Fst p) e = case e of
    Binary op e1 e2 -> Binary op <$> go p e1 <*> pure e2
    Unary op e      -> Unary op  <$> go p e
    SectL e op      -> SectL     <$> go p e <*> pure op
    IfExpr ce te ee -> IfExpr <$> go p ce <*> pure te <*> pure ee
    Lambda bs body  -> Lambda bs <$> go p body
    App e es        -> App       <$> go p e <*> pure es
    _               -> throwError $ "Cannot match " ++ show (Fst p) ++ " with " ++ show e
  go (Snd p) e = case e of
    Binary op e1 e2 -> Binary op e1 <$> go p e2
    SectR op e      -> SectR op     <$> go p e
    IfExpr ce te ee -> IfExpr <$> pure ce <*> go p te <*> pure ee
    _               -> throwError $ "Cannot match " ++ show (Snd p) ++ " with " ++ show e
  go (Thrd p) e = case e of
    IfExpr ce te ee -> IfExpr <$> pure ce <*> pure te <*> go p ee
    _               -> throwError $ "Cannot match " ++ show (Thrd p) ++ " with " ++ show e
  go (Nth n p) e = case e of
    List es  -> List  <$> mapIndex n (go p) es
    NTuple es -> NTuple <$> mapIndex n (go p) es
    App e es -> App e <$> mapIndex n (go p) es
    _        -> throwError $ "Cannot match " ++ show (Nth n p) ++ " with " ++ show e

mapIndex :: forall m a. Number -> (a -> Evaluator a) -> [a] -> Evaluator [a]
mapIndex i f as = do
  case as !! i of
    Nothing -> throwError $ "Nothing at index " ++ show i ++ "! (length = " ++ show (length as) ++ ")"
    Just a  -> do
      a' <- f a
      return $ updateAt i a' as

evalPath1 :: Env -> Path -> Expr -> Either String Expr
evalPath1 env path expr = runEvalM $ mapWithPath path (eval1 env) expr

type Env = StrMap [Tuple [Binding] Expr]

defsToEnv :: [Definition] -> Env
defsToEnv = foldl insertDef empty

insertDef :: Env -> Definition -> Env
insertDef env (Def name bindings body) = case lookup name env of
  Nothing   -> insert name [Tuple bindings body] env
  Just defs -> insert name (defs ++ [Tuple bindings body]) env

eval1 :: Env -> Expr -> Evaluator Expr
eval1 env expr = case expr of
  (Binary op e1 e2)                  -> binary op e1 e2
  (Unary op e)                       -> unary op e
  (Atom (Name name))                 -> apply env name []
  (IfExpr (Atom (Bool true)) te _)   -> return te
  (IfExpr (Atom (Bool false)) _ ee)  -> return ee
--  (List (e:es))                      -> return $ Binary Cons e (List es)
  (App (Binary Composition f g) [e]) -> return $ App f [App g [e]]
  (App (Lambda binds body) args)     -> matchls' binds args >>= flip replace' body >>= wrapLambda binds args
  (App (SectL e1 op) [e2])           -> return $ Binary op e1 e2
  (App (SectR op e2) [e1])           -> return $ Binary op e1 e2
  (App (Prefix op) [e1, e2])         -> return $ Binary op e1 e2
  (App (Atom (Name name)) args)      -> apply env name args
  (App (App func es) es')            -> return $ App func (es ++ es')
  _ -> throwError $ "Cannot evaluate " ++ show expr

wrapLambda :: [Binding] -> [Expr] -> Expr -> Evaluator Expr
wrapLambda binds args body =
  case compare (length binds) (length args) of
    EQ -> return body
    GT -> return $ Lambda (drop (length args) binds) body
    LT -> return $ App body (drop (length binds) args)

binary :: Op -> Expr -> Expr -> Evaluator Expr
binary = go
  where
  retA = return <<< Atom
  go Power (Atom (Num i)) (Atom (Num j)) = retA $ Num $ pow i j

  go Mul (Atom (Num i)) (Atom (Num j)) = retA $ Num $ i * j
  go Div (Atom (Num i)) (Atom (Num 0)) = throwError "Division by zero!"
  go Div (Atom (Num i)) (Atom (Num j)) = retA $ Num $ Math.floor (i / j)
  go Mod (Atom (Num i)) (Atom (Num 0)) = throwError "Mod by zero!"
  go Mod (Atom (Num i)) (Atom (Num j)) = retA $ Num $ i % j

  go Add (Atom (Num i)) (Atom (Num j)) = retA $ Num $ i + j
  go Sub (Atom (Num i)) (Atom (Num j)) = retA $ Num $ i - j

  go Cons   e          (List es)  = return $ List $ e:es
  go Append (List es1) (List es2) = return $ List $ es1 ++ es2

  go Eq  (Atom a1) (Atom a2) = retA $ Bool $ a1 == a2
  go Neq (Atom a1) (Atom a2) = retA $ Bool $ a1 /= a2
  go Leq (Atom (Num i)) (Atom (Num j)) = retA $ Bool $ i <= j
  go Lt  (Atom (Num i)) (Atom (Num j)) = retA $ Bool $ i < j
  go Geq (Atom (Num i)) (Atom (Num j)) = retA $ Bool $ i >= j
  go Gt  (Atom (Num i)) (Atom (Num j)) = retA $ Bool $ i > j

  go And (Atom (Bool true))  b = return b
  go And (Atom (Bool false)) _ = retA $ Bool $ false

  go Or  (Atom (Bool true))  _ = retA $ Bool $ true
  go Or  (Atom (Bool false)) b = return b

  go Dollar f e = return $ App f [e]

  go op e1 e2 = throwError $ "Cannot apply operator " ++ show op ++  " to " ++ show e1 ++ " and " ++ show e2

unary :: Op -> Expr -> Evaluator Expr
unary Sub (Atom (Num i)) = return $ Atom $ Num (-i)
unary op e = throwError $ "Cannot apply unary operator " ++ show op ++ " to " ++ show e

apply :: Env -> String -> [Expr] -> Evaluator Expr
apply env name args = case lookup name env of
  Nothing    -> throwError $ "Unknown function: " ++ name
  Just cases -> case runEvalM $ foldl (<|>) P.empty (app <$> cases) of
    Right expr -> return expr
    Left msg   -> throwError $ "No matching funnction found for " ++ name ++ "(last reason: " ++ msg ++ ")"
  where
  app :: Tuple [Binding] Expr -> Evaluator Expr
  app (Tuple binds body) | length binds == length args = matchls' binds args >>= flip replace' body
                         | otherwise                   = throwError $ "Wrong number of arguments!"

matchls' :: [Binding] -> [Expr] -> Evaluator (StrMap Expr)
matchls' bs es = execStateT (zipWithA match' bs es) empty

match' :: Binding -> Expr -> StateT (StrMap Expr) Evaluator Unit
match' (Lit (Name name)) e                             = modify (insert name e)
match' (Lit ba)          (Atom ea)          | ba == ea = return unit
match' (ConsLit b bs)    (Binary Cons e es)            = match' b e *> match' bs es
match' (ConsLit b bs)    (List (e:es))                 = match' (ConsLit b bs) (Binary Cons e (List es))
match' (ListLit bs)      (List es)          | length bs == length es = void $ zipWithA match' bs es
match' (ListLit bs)      (Binary Cons e (List es))     = match' (ListLit bs) (List (e:es))
match' (NTupleLit bs)    (NTuple es)        | length bs == length es = void $ zipWithA match' bs es
match' b                 e                             = throwError $ "Cannot match " ++ show b ++ " with " ++ show e

replace' :: StrMap Expr -> Expr -> Evaluator Expr
replace' subs = go
  where
  go expr = case expr of
    a@(Atom (Name name)) -> case lookup name subs of
      Just subExpr -> return subExpr
      Nothing      -> return a
    (List exprs)         -> List <$> (traverse go exprs)
    (NTuple exprs)       -> NTuple <$> (traverse go exprs)
    (Binary op e1 e2)    -> Binary <$> pure op <*> go e1 <*> go e2
    (Unary op e)         -> Unary <$> pure op <*> go e
    (SectL e op)         -> SectL <$> go e <*> pure op
    (SectR op e)         -> SectR <$> pure op <*> go e
    (Lambda binds body)  -> (avoidCapture subs binds) *> (Lambda <$> pure binds <*> replace' (foldr delete subs (boundNames' binds)) body)
    (App func exprs)     -> App <$> go func <*> traverse go exprs
    e                    -> return e

avoidCapture :: StrMap Expr -> [Binding] -> Evaluator Unit
avoidCapture subs binds = case intersect (concatMap freeVariables $ values subs) (boundNames' binds) of
  []       -> return unit
  captures -> throwError $ "Some variables have been captured: " ++ show captures

freeVariables :: Expr -> [String]
freeVariables = nub <<< foldExpr
  (\a -> case a of
    Name name -> [name]
    _         -> [])
  concat
  concat
  (\_ f1 f2 -> f1 ++ f2)
  (\_ f -> f)
  (\f _ -> f)
  (\_ f -> f)
  (\_ -> [])
  (\f1 f2 f3 -> f1 ++ f2 ++ f3)
  (\bs f -> nub f \\ boundNames' bs)
  (\f fs -> f ++ concat fs)

boundNames' :: [Binding] -> [String]
boundNames' = concatMap boundNames

boundNames :: Binding -> [String]
boundNames = go
  where
  go (Lit (Name name)) = [name]
  go (ConsLit b1 b2)   = go b1 ++ go b2
  go (ListLit bs)      = foldMap go bs
  go (NTupleLit bs)    = foldMap go bs

module Evaluator
  ( Path(..)
  , Env()
  , evalPath1
  , defsToEnv
  ) where

import Data.Array    (head, mapMaybe, (!!), updateAt, elemIndex, length, concat, concatMap, nub, (\\), intersect, drop)
import Data.StrMap   (StrMap(), empty, lookup, insert, delete, values)
import Data.Tuple    (Tuple(Tuple), fst, snd)
import Data.Maybe
import Data.Foldable (foldl, foldr, foldMap, any)
import Data.Traversable (zipWithA, traverse)
import Data.Identity
import Data.Either

import Math (pow)

import Control.Apply ((*>))
import Control.Alt ((<|>))
import qualified Control.Plus as P
import Control.Monad.State
import Control.Monad.State.Trans
import Control.Monad.State.Class

import Control.Monad.Writer
import Control.Monad.Writer.Trans
import Control.Monad.Writer.Class

import Control.Monad.Error
import Control.Monad.Error.Trans
import Control.Monad.Error.Class

import Control.Monad.Trans

import AST

type Matching = Tuple Atom Expr

type Evaluator = ErrorT String Identity

runEvalM :: forall a. Evaluator a -> Either String a
runEvalM = runIdentity <<< runErrorT

data Path = Nth Number Path
          | Fst Path
          | Snd Path
          | Thrd Path
          | End

instance showPath :: Show Path where
  show p = case p of
    Nth i p -> "(Nth " ++ show i ++ " " ++ show p ++")"
    Fst   p -> "(Fst " ++ show p ++")"
    Snd   p -> "(Snd " ++ show p ++")"
    Thrd   p -> "(Thrd " ++ show p ++")"
    End     -> "End"

mapWithPath :: Path -> (Expr -> Evaluator Expr) -> Expr -> Evaluator Expr
mapWithPath p f = go p
  where
  go End e     = f e
  go (Fst p) e = case e of
    Binary op e1 e2 -> Binary op <$> go p e1 <*> pure e2
    Unary op e      -> Unary op  <$> go p e
    SectL e op      -> SectL     <$> go p e <*> pure op
    IfExpr ce te ee -> IfExpr <$> go p ce <*> pure te <*> pure ee
    Lambda bs body  -> Lambda bs <$> go p body
    App e es        -> App       <$> go p e <*> pure es
    _               -> throwError $ "Cannot match " ++ show (Fst p) ++ " with " ++ show e
  go (Snd p) e = case e of
    Binary op e1 e2 -> Binary op e1 <$> go p e2
    SectR op e      -> SectR op     <$> go p e
    IfExpr ce te ee -> IfExpr <$> pure ce <*> go p te <*> pure ee
    _               -> throwError $ "Cannot match " ++ show (Snd p) ++ " with " ++ show e
  go (Thrd p) e = case e of
    IfExpr ce te ee -> IfExpr <$> pure ce <*> pure te <*> go p ee
    _               -> throwError $ "Cannot match " ++ show (Thrd p) ++ " with " ++ show e
  go (Nth n p) e = case e of
    List es  -> List  <$> mapIndex n (go p) es
    NTuple es -> NTuple <$> mapIndex n (go p) es
    App e es -> App e <$> mapIndex n (go p) es
    _        -> throwError $ "Cannot match " ++ show (Nth n p) ++ " with " ++ show e

mapIndex :: forall m a. Number -> (a -> Evaluator a) -> [a] -> Evaluator [a]
mapIndex i f as = do
  case as !! i of
    Nothing -> throwError $ "Nothing at index " ++ show i ++ "! (length = " ++ show (length as) ++ ")"
    Just a  -> do
      a' <- f a
      return $ updateAt i a' as

evalPath1 :: Env -> Path -> Expr -> Either String Expr
evalPath1 env path expr = runEvalM $ mapWithPath path (eval1 env) expr

type Env = StrMap [Tuple [Binding] Expr]

defsToEnv :: [Definition] -> Env
defsToEnv = foldl insertDef empty

insertDef :: Env -> Definition -> Env
insertDef env (Def name bindings body) = case lookup name env of
  Nothing   -> insert name [Tuple bindings body] env
  Just defs -> insert name (defs ++ [Tuple bindings body]) env

eval1 :: Env -> Expr -> Evaluator Expr
eval1 env expr = case expr of
  (Binary op e1 e2)                  -> binary op e1 e2
  (Unary op e)                       -> unary op e
  (Atom (Name name))                 -> apply env name []
  (IfExpr (Atom (Bool true)) te _)   -> return te
  (IfExpr (Atom (Bool false)) _ ee)  -> return ee
  (List (e:es))                      -> return $ Binary Cons e (List es)
  (App (Binary Composition f g) [e]) -> return $ App f [App g [e]]
  (App (Lambda binds body) args)     -> matchls' binds args >>= flip replace' body >>= wrapLambda binds args
  (App (SectL e1 op) [e2])           -> return $ Binary op e1 e2
  (App (SectR op e2) [e1])           -> return $ Binary op e1 e2
  (App (Prefix op) [e1, e2])         -> return $ Binary op e1 e2
  (App (Atom (Name name)) args)      -> apply env name args
  (App (App func es) es')            -> return $ App func (es ++ es')
  _ -> throwError $ "Cannot evaluate " ++ show expr

wrapLambda :: [Binding] -> [Expr] -> Expr -> Evaluator Expr
wrapLambda binds args body =
  case compare (length binds) (length args) of
    EQ -> return body
    GT -> return $ Lambda (drop (length args) binds) body
    LT -> return $ App body (drop (length binds) args)

binary :: Op -> Expr -> Expr -> Evaluator Expr
binary = go
  where
  retA = return <<< Atom
  go Power (Atom (Num i)) (Atom (Num j)) = retA $ Num $ pow i j

  go Mul (Atom (Num i)) (Atom (Num j)) = retA $ Num $ i * j
  go Div (Atom (Num i)) (Atom (Num 0)) = throwError "Division by zero!"
  go Div (Atom (Num i)) (Atom (Num j)) = retA $ Num $ Math.floor (i / j)
  go Mod (Atom (Num i)) (Atom (Num 0)) = throwError "Mod by zero!"
  go Mod (Atom (Num i)) (Atom (Num j)) = retA $ Num $ i % j

  go Add (Atom (Num i)) (Atom (Num j)) = retA $ Num $ i + j
  go Sub (Atom (Num i)) (Atom (Num j)) = retA $ Num $ i - j

  go Cons   e          (List es)  = return $ List $ e:es
  go Append (List es1) (List es2) = return $ List $ es1 ++ es2

  go Eq  (Atom a1) (Atom a2) = retA $ Bool $ a1 == a2
  go Neq (Atom a1) (Atom a2) = retA $ Bool $ a1 /= a2
  go Leq (Atom (Num i)) (Atom (Num j)) = retA $ Bool $ i <= j
  go Lt  (Atom (Num i)) (Atom (Num j)) = retA $ Bool $ i < j
  go Geq (Atom (Num i)) (Atom (Num j)) = retA $ Bool $ i >= j
  go Gt  (Atom (Num i)) (Atom (Num j)) = retA $ Bool $ i > j

  go And (Atom (Bool true))  b = return b
  go And (Atom (Bool false)) _ = retA $ Bool $ false

  go Or  (Atom (Bool true))  _ = retA $ Bool $ true
  go Or  (Atom (Bool false)) b = return b

  go Dollar f e = return $ App f [e]

  go op e1 e2 = throwError $ "Cannot apply operator " ++ show op ++  " to " ++ show e1 ++ " and " ++ show e2

unary :: Op -> Expr -> Evaluator Expr
unary Sub (Atom (Num i)) = return $ Atom $ Num (-i)
unary op e = throwError $ "Cannot apply unary operator " ++ show op ++ " to " ++ show e

apply :: Env -> String -> [Expr] -> Evaluator Expr
apply env name args = case lookup name env of
  Nothing    -> throwError $ "Unknown function: " ++ name
  Just cases -> case runEvalM $ foldl (<|>) P.empty (app <$> cases) of
    Right expr -> return expr
    Left msg   -> throwError $ "No matching funnction found for " ++ name ++ "(last reason: " ++ msg ++ ")"
  where
  app :: Tuple [Binding] Expr -> Evaluator Expr
  app (Tuple binds body) | length binds == length args = matchls' binds args >>= flip replace' body
                         | otherwise                   = throwError $ "Wrong number of arguments!"

matchls' :: [Binding] -> [Expr] -> Evaluator (StrMap Expr)
matchls' bs es = execStateT (zipWithA match' bs es) empty

match' :: Binding -> Expr -> StateT (StrMap Expr) Evaluator Unit
match' (Lit (Name name)) e                             = modify (insert name e)
match' (Lit ba)          (Atom ea)          | ba == ea = return unit
match' (ConsLit b bs)    (Binary Cons e es)            = match' b e *> match' bs es
match' (ListLit bs)      (List es)          | length bs == length es = void $ zipWithA match' bs es
match' (NTupleLit bs)    (NTuple es)        | length bs == length es = void $ zipWithA match' bs es
match' b                 e                             = throwError $ "Cannot match " ++ show b ++ " with " ++ show e

replace' :: StrMap Expr -> Expr -> Evaluator Expr
replace' subs = go
  where
  go expr = case expr of
    a@(Atom (Name name)) -> case lookup name subs of
      Just subExpr -> return subExpr
      Nothing      -> return a
    (List exprs)         -> List <$> (traverse go exprs)
    (NTuple exprs)       -> NTuple <$> (traverse go exprs)
    (Binary op e1 e2)    -> Binary <$> pure op <*> go e1 <*> go e2
    (Unary op e)         -> Unary <$> pure op <*> go e
    (SectL e op)         -> SectL <$> go e <*> pure op
    (SectR op e)         -> SectR <$> pure op <*> go e
    (Lambda binds body)  -> (avoidCapture subs binds) *> (Lambda <$> pure binds <*> replace' (foldr delete subs (boundNames' binds)) body)
    (App func exprs)     -> App <$> go func <*> traverse go exprs
    e                    -> return e

avoidCapture :: StrMap Expr -> [Binding] -> Evaluator Unit
avoidCapture subs binds = case intersect (concatMap freeVariables $ values subs) (boundNames' binds) of
  []       -> return unit
  captures -> throwError $ "Some variables have been captured: " ++ show captures

freeVariables :: Expr -> [String]
freeVariables = nub <<< foldExpr
  (\a -> case a of
    Name name -> [name]
    _         -> [])
  concat
  concat
  (\_ f1 f2 -> f1 ++ f2)
  (\_ f -> f)
  (\f _ -> f)
  (\_ f -> f)
  (\_ -> [])
  (\f1 f2 f3 -> f1 ++ f2 ++ f3)
  (\bs f -> nub f \\ boundNames' bs)
  (\f fs -> f ++ concat fs)

boundNames' :: [Binding] -> [String]
boundNames' = concatMap boundNames

boundNames :: Binding -> [String]
boundNames = go
  where
  go (Lit (Name name)) = [name]
  go (ConsLit b1 b2)   = go b1 ++ go b2
  go (ListLit bs)      = foldMap go bs
  go (NTupleLit bs)    = foldMap go bs


Save model directly instead of going through component queries (#861)

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Card.Draftboard.Component
  ( draftboardComponent
  , module SlamData.Workspace.Card.Draftboard.Component.Query
  , module SlamData.Workspace.Card.Draftboard.Component.State
  ) where

import SlamData.Prelude

import Control.Monad.Maybe.Trans (MaybeT(..), runMaybeT)

import Data.Array as Array
import Data.Function (on)
import Data.Lens ((.~), (?~))
import Data.List as List
import Data.Map as Map
import CSS as CSS

import DOM.HTML.Types (HTMLElement)

import Halogen as H
import Halogen.Component.Opaque.Unsafe (opaqueState)
import Halogen.Component.Utils.Drag as Drag
import Halogen.Component.Utils (raise')
import Halogen.CustomEvents (mouseEventToPageEvent)
import Halogen.HTML.CSS.Indexed as HC
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP

import Math (round, floor)

import SlamData.Config as Config
import SlamData.Effects (Slam)
import SlamData.Workspace.AccessType as AT
import SlamData.Workspace.Card.CardId as CID
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.Common (CardOptions)
import SlamData.Workspace.Card.Component as CC
import SlamData.Workspace.Card.Draftboard.Common (deleteGraph, unsafeUpdateCachedDraftboard)
import SlamData.Workspace.Card.Draftboard.Component.CSS as CCSS
import SlamData.Workspace.Card.Draftboard.Component.Query (Query(..), QueryP, QueryC)
import SlamData.Workspace.Card.Draftboard.Component.State (State, DeckPosition, initialState, encode, decode, _moving, _inserting, _grouping, modelFromState)
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.Deck.Common (wrappedDeck, defaultPosition)
import SlamData.Workspace.Deck.Component.Nested.Query as DNQ
import SlamData.Workspace.Deck.Component.Nested.State as DNS
import SlamData.Workspace.Deck.Component.Query as DCQ
import SlamData.Workspace.Deck.Component.State as DCS
import SlamData.Workspace.Deck.DeckId (DeckId, deckIdToString, freshDeckId)
import SlamData.Workspace.Deck.DeckLevel as DL
import SlamData.Workspace.Deck.Model as DM
import SlamData.Workspace.Wiring (putDeck)

import Utils.CSS (zIndex)
import Utils.DOM (elementEq, scrollTop, scrollLeft, getOffsetClientRect)

type DraftboardDSL = H.ParentDSL State DNS.State QueryC DNQ.QueryP Slam DeckId

type DraftboardHTML = H.ParentHTML DNS.State QueryC DNQ.QueryP Slam DeckId

draftboardComponent ∷ CardOptions → CC.CardComponent
draftboardComponent opts = CC.makeCardComponent
  { cardType: CT.Draftboard
  , component: H.parentComponent
      { render: render opts
      , eval: coproduct evalCard (evalBoard opts)
      , peek: Just (peek opts)
      }
  , initialState: H.parentState initialState
  , _State: CC._DraftboardState
  , _Query: CC.makeQueryPrism' CC._DraftboardQuery
  }

render ∷ CardOptions → State → DraftboardHTML
render opts state =
  HH.div_
    [ HH.div [ HP.class_ CCSS.insetShadow ] []
    , HH.div
        [ HP.class_ CCSS.grid
        , HC.style bgSize
        , HP.ref (right ∘ H.action ∘ SetElement)
        , HE.onClick \e → pure $
            guard (AT.isEditable opts.deck.accessType && not state.inserting) $>
            right (H.action $ AddDeck e)
        ]
        $ map renderDeck (foldl Array.snoc [] $ Map.toList state.decks)
    ]

  where
  renderDeck (deckId × rect) =
    HH.div
      [ HP.key $ deckIdToString deckId
      , HP.classes $
          case state.grouping of
            Just deckId' | deckId == deckId' → [ HH.className "grouping" ]
            _ → []
      , HC.style $
          case state.moving of
            Just (deckId' × rect') | deckId == deckId' → zIndex 2 *> cssPos rect'
            _ → cssPos rect
      ]
      [ HH.slot deckId $ mkDeckComponent deckId ]

  mkDeckComponent id _ =
    { component: opts.deckComponent (opaqueState $ DCS.initialDeck opts.deck.path id)
    , initialState: DNS.initialState
    }

  cssPos rect = do
    CSS.position CSS.absolute
    CSS.top $ CSS.px $ gridToPx rect.y
    CSS.left $ CSS.px $ gridToPx rect.x
    CSS.width $ CSS.px $ gridToPx rect.width
    CSS.height $ CSS.px $ gridToPx rect.height

  bgSize = do
    let size = foldr maxSize { width: 0.0, height: 0.0 } state.decks
        size' = maybe size (flip maxSize size ∘ snd) state.moving
    CSS.width $ CSS.px $ gridToPx $ size'.width + 1.0
    CSS.height $ CSS.px $ gridToPx $ size'.height + 1.0

evalCard ∷ Natural CC.CardEvalQuery DraftboardDSL
evalCard = case _ of
  CC.EvalCard _ _ next →
    pure next
  CC.SetDimensions _ next →
    pure next
  CC.Save k →
    map (k ∘ Card.Draftboard ∘ modelFromState) H.get
  CC.Load card next → do
    case card of
      Card.Draftboard model → do
        H.modify _ { decks = model.decks }
        loadDecks
      _ → pure unit
    pure next
  CC.ModelUpdated _ next →
    pure next
  CC.ZoomIn next →
    pure next

evalBoard ∷ CardOptions → Natural Query DraftboardDSL
evalBoard opts = case _ of
  Grabbing deckId ev next → do
    case ev of
      Drag.Move _ d → do
        st ← H.get
        for_ (Map.lookup deckId (st.decks)) \rect →
        for_ st.canvas \el → do
          coords ← pageToGrid d el
          let
            cursorRect =
              { x: coords.x
              , y: coords.y
              , width: 1.0
              , height: 1.0
              }
            newRect = clampDeck rect
              { x = rect.x + (pxToGrid d.offsetX)
              , y = rect.y + (pxToGrid d.offsetY)
              }
            grouping =
              case overlapping cursorRect (Map.toList st.decks) of
                List.Cons (deckId' × _) _ | deckId ≠ deckId' → Just deckId'
                _ → Nothing
          H.modify
            $ (_moving ?~ Tuple deckId newRect)
            ∘ (_grouping .~ grouping)
      Drag.Done _ → do
        stopDragging opts
        CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  Resizing deckId ev next → do
    case ev of
      Drag.Move _ d → do
        H.gets (Map.lookup deckId ∘ _.decks) >>= traverse_ \rect → do
          let
            newRect = clampDeck rect
              { width = rect.width + (pxToGrid d.offsetX)
              , height = rect.height + (pxToGrid d.offsetY)
              }
          H.modify $ _moving ?~ Tuple deckId newRect
      Drag.Done _ → do
        stopDragging opts
        CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  SetElement el next → do
    H.modify _ { canvas = el }
    pure next
  AddDeck e next → do
    let e' = mouseEventToPageEvent e
    H.gets _.canvas >>= traverse_ \el → do
      same ← H.fromEff (elementEq el e'.target)
      when same do
        coords ← pageToGrid { x: e'.pageX, y: e'.pageY } el
        addDeck opts DM.emptyDeck
          { x: floor $ coords.x + 1.0
          , y: floor $ coords.y
          }
        CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  LoadDeck deckId next → do
    queryDeck deckId
      $ H.action
      $ DCQ.Load opts.deck.path deckId (DL.succ opts.deck.level)
    pure next
  -- TODO: hopefully we can get rid of this later, as it's relatively expensive
  -- and will run quite frequently, as it's used to enable the `Unwrap` action.
  -- If we can add a real mechanism for handling card-specific actions on the
  -- deck backside we should be able to do something much more sensible, only
  -- building the decks' value here when we actually trigger an unwrap. -gb
  GetDecks k → do
    decks ← H.gets _.decks
    decks' ← runMaybeT $ for (Map.toList decks) \(deckId × position) -> do
      model ← MaybeT $ queryDeck deckId $ H.request DCQ.GetModel
      pure (deckId × (position × model))
    pure $ k $ maybe Map.empty Map.fromList decks'

peek ∷ ∀ a. CardOptions → H.ChildF DeckId DNQ.QueryP a → DraftboardDSL Unit
peek opts (H.ChildF deckId q) = coproduct (const (pure unit)) peekDeck q
  where
  peekDeck ∷ DCQ.Query a → DraftboardDSL Unit
  peekDeck = case _ of
    DCQ.GrabDeck ev _ → startDragging deckId ev Grabbing
    DCQ.ResizeDeck ev _ → startDragging deckId ev Resizing
    DCQ.DoAction DCQ.DeleteDeck _ → do
      deleteDeck opts deckId
      CC.raiseUpdatedP' CC.EvalModelUpdate
    DCQ.DoAction DCQ.Wrap _ → do
      wrapDeck opts deckId
      CC.raiseUpdatedP' CC.EvalModelUpdate
    DCQ.DoAction (DCQ.Unwrap decks) _ → do
      unwrapDeck opts deckId decks
      CC.raiseUpdatedP' CC.EvalModelUpdate
    DCQ.DoAction DCQ.Mirror _ → do
      mirrorDeck opts deckId
      CC.raiseUpdatedP' CC.EvalModelUpdate
    _ → pure unit

  startDragging deckId ev tag =
    H.gets (Map.lookup deckId ∘ _.decks) >>= traverse_ \rect → do
      H.modify $ _moving ?~ Tuple deckId rect
      void
        $ Drag.subscribe' ev
        $ right ∘ H.action ∘ tag deckId

pageToGrid
  ∷ ∀ r
  . { x ∷ Number, y ∷ Number | r }
  → HTMLElement
  → DraftboardDSL { x ∷ Number, y ∷ Number }
pageToGrid e el = do
  rect ← H.fromEff $ getOffsetClientRect el
  scroll ←
    { top: _, left: _ }
    <$> H.fromEff (scrollTop el)
    <*> H.fromEff (scrollLeft el)
  pure
    { x: pxToGrid $ e.x - rect.left + scroll.left
    , y: pxToGrid $ e.y - rect.top + scroll.top
    }

pxToGrid ∷ Number → Number
pxToGrid = (_ / Config.gridPx)

gridToPx ∷ Number → Number
gridToPx = (_ * Config.gridPx)

stopDragging ∷ CardOptions → DraftboardDSL Unit
stopDragging opts = do
  st ← H.get
  for_ st.moving \(deckId × rect) → do
    let rect' = roundDeck rect
        decks = List.filter ((deckId /= _) ∘ fst) $ Map.toList st.decks
    case st.grouping of
      Just deckId' →
        groupDecks opts deckId deckId'
      Nothing →
        when (List.null $ overlapping rect' decks) do
          H.modify \s → s { decks = Map.insert deckId rect' s.decks }
  H.modify _
    { moving = Nothing
    , grouping = Nothing
    }

maxSize
  ∷ DeckPosition
  → { width ∷ Number, height ∷ Number }
  → { width ∷ Number, height ∷ Number }
maxSize deck size =
  { width: if x > size.width then x else size.width
  , height: if y > size.height then y else size.height
  }
  where
  x = deck.x + deck.width
  y = deck.y + deck.height

clampDeck ∷ DeckPosition → DeckPosition
clampDeck rect =
  { x: if rect.x < 0.0 then 0.0 else rect.x
  , y: if rect.y < 0.0 then 0.0 else rect.y
  , width: if rect.width < 10.0 then 10.0 else rect.width
  , height: if rect.height < 10.0 then 10.0 else rect.height
  }

roundDeck ∷ DeckPosition → DeckPosition
roundDeck rect =
  { x: round rect.x
  , y: round rect.y
  , width: round rect.width
  , height: round rect.height
  }

overlapping
  ∷ DeckPosition
  → List.List (DeckId × DeckPosition)
  → List.List (DeckId × DeckPosition)
overlapping a = List.filter go
  where
  go (_ × b) =
    not $ a.x + a.width <= b.x
       || b.x + b.width <= a.x
       || a.y + a.height <= b.y
       || b.y + b.height <= a.y

accomodateDeck
  ∷ List.List (DeckId × DeckPosition)
  → { x ∷ Number, y ∷ Number }
  → DeckPosition
  → Maybe DeckPosition
accomodateDeck bs = go List.Nil
  where
  go hist c a =
    case overlapping a bs of
      List.Nil →
        Just a
      bs' | not $ List.null $ List.intersectBy (eq `on` fst) hist bs' →
        Nothing
      List.Cons b _ →
        let a' = clampDeck $ reposition c a (snd b)
            c' = { x: a'.x + (floor (a'.width / 2.0)), y: a'.y }
        in  go (List.Cons b hist) c' a'

  reposition c a b
    | c.x >= b.x && c.x < b.x + b.width = a { y = b.y - a.height }
    | c.x >= b.x + b.width = a { x = b.x + b.width }
    | c.y < b.x = a { x = b.x - a.width }
    | otherwise = a

reallyAccomodateDeck
  ∷ List.List (DeckId × DeckPosition)
  → DeckPosition
  → DeckPosition
reallyAccomodateDeck decks deckPos =
  let deckPos' = deckPos { y = deckPos.y + deckPos.height }
      coords = { x: floor (deckPos'.x + deckPos'.x / 2.0), y: deckPos'.y }
  in
      case accomodateDeck decks coords deckPos of
        Nothing → reallyAccomodateDeck decks deckPos'
        Just a → a

loadDecks ∷ DraftboardDSL Unit
loadDecks =
  H.gets (Map.keys ∘ _.decks) >>=
    traverse_ (raise' ∘ right ∘ H.action ∘ LoadDeck)

addDeck ∷ CardOptions → DM.Deck → { x ∷ Number, y ∷ Number } → DraftboardDSL Unit
addDeck opts deck coords = do
  decks ← Map.toList <$> H.gets _.decks
  let
    deckPos = clampDeck $ defaultPosition
      { x = coords.x - 10.0
      , y = coords.y
      }
  for_ (accomodateDeck decks coords deckPos) $
    addDeckAt opts deck

addDeckAt ∷ CardOptions → DM.Deck → DeckPosition → DraftboardDSL Unit
addDeckAt { deck: opts, deckId: parentId, cardId } deck deckPos = do
  let deck' = deck { parent = Just (parentId × cardId) }
  H.modify $ _inserting .~ true
  deckId ← H.fromEff freshDeckId
  putDeck opts.path deckId deck' opts.wiring.decks >>= case _ of
    Left err → do
      H.modify $ _inserting .~ false
      -- TODO: do something to notify the user saving failed
      pure unit
    Right _ → void do
      H.modify \s → s
        { decks = Map.insert deckId deckPos s.decks
        , inserting = false
        }
      queryDeck deckId
        $ H.action
        $ DCQ.Load opts.path deckId (DL.succ opts.level)

deleteDeck ∷ CardOptions → DeckId → DraftboardDSL Unit
deleteDeck { deck } deckId = do
  res ← deleteGraph deck.path deckId
  case res of
    Left err →
      -- TODO: do something to notify the user deleting failed
      pure unit
    Right _ →
      H.modify \s → s { decks = Map.delete deckId s.decks }

wrapDeck ∷ CardOptions → DeckId → DraftboardDSL Unit
wrapDeck { cardId, deckId: parentId, deck } oldId = do
  H.gets (Map.lookup oldId ∘ _.decks) >>= traverse_ \deckPos → do
    let
      deckPos' = deckPos { x = 1.0, y = 1.0 }
      newDeck = (wrappedDeck deckPos' oldId) { parent = Just (parentId × cardId) }
    newId ← H.fromEff freshDeckId
    putDeck deck.path newId newDeck deck.wiring.decks >>= case _ of
      Left err → do
        -- TODO: do something to notify the user saving failed
        pure unit
      Right _ → void do
        traverse_ (queryDeck oldId ∘ H.action)
          [ DCQ.SetParent (newId × CID.CardId 0)
          , DCQ.Save Nothing
          ]
        H.modify \s → s
          { decks
              = Map.insert newId deckPos
              $ Map.delete oldId
              $ s.decks
          }
        queryDeck newId
          $ H.action
          $ DCQ.Load deck.path newId (DL.succ deck.level)

unwrapDeck
  ∷ CardOptions
  → DeckId
  → Map.Map DeckId (DeckPosition × DM.Deck)
  → DraftboardDSL Unit
unwrapDeck { deckId, cardId, deck: opts } oldId decks = void $ runMaybeT do
  -- sort the decks here so they are ordered by position, this ensures that if
  -- decks need to be accomodated when broken out, the decks in the top left
  -- corner will maintain their position and the others will be accomodated.
  let deckList = List.sortBy (compare `on` toCoords) $ Map.toList decks
  let coord = deckId × cardId
  let level' = DL.succ opts.level
  offset ← MaybeT $ H.gets (Map.lookup oldId ∘ _.decks)
  lift do
    H.modify \s →
      s { decks = foldl (reinsert offset) (Map.delete oldId s.decks) deckList }
    for_ deckList \(deckId × (_ × deck)) → do
      let deck' = deck { parent = Just coord }
      putDeck opts.path deckId deck' opts.wiring.decks
      queryDeck deckId
        $ H.action
        $ DCQ.Load opts.path deckId level'
  where
  reinsert offset acc (deckId × (pos × deck)) =
    Map.insert deckId (updatePos (Map.toList acc) offset pos) acc
  updatePos currentDecks offset pos =
    reallyAccomodateDeck currentDecks $
      pos
        { x = pos.x + offset.x + 1.0
        , y = pos.y + offset.y + 1.0
        }
  toCoords (_ × (pos × _)) = Tuple pos.x pos.y

mirrorDeck ∷ CardOptions → DeckId → DraftboardDSL Unit
mirrorDeck opts oldId = do
  queryDeck oldId (H.request DCQ.GetModelCards) >>= traverse_ \modelCards → do
    let modelCards' = Array.span (not ∘ eq oldId ∘ fst) modelCards
    if Array.null modelCards'.rest
      then insertNewDeck DM.emptyDeck { mirror = DCS.coordModelToCoord <$> modelCards'.init }
      else do
        let
          newDeck =
            { parent: Nothing
            , mirror: map _.cardId <$> modelCards'.init
            , cards: snd <$> modelCards'.rest
            , name: ""
            }
        newId ← H.fromEff freshDeckId
        putDeck opts.deck.path newId newDeck opts.deck.wiring.decks >>= case _ of
          Left _ →
            -- TODO: do something to notify the user saving failed
            pure unit
          Right _ → do
            let modelCards'' = modelCards'.init <> map (lmap (const newId)) modelCards'.rest
            queryDeck oldId $ H.action $ DCQ.SetModelCards modelCards''
            insertNewDeck DM.emptyDeck { mirror = DCS.coordModelToCoord <$> modelCards'' }
  where
  insertNewDeck deck = do
    st ← H.get
    for_ (Map.lookup oldId st.decks) \deckPos →
      addDeckAt opts deck $
        reallyAccomodateDeck (Map.toList st.decks) deckPos

groupDecks ∷ CardOptions → DeckId → DeckId → DraftboardDSL Unit
groupDecks { cardId, deckId, deck } deckFrom deckTo = do
  st ← H.get
  for_ (Map.lookup deckFrom st.decks) \rectFrom →
  for_ (Map.lookup deckTo st.decks) \rectTo →
    queryDeck deckTo (H.request DCQ.GetModelCards) >>= case _ of
      Just [ deckId' × { cardId, model: Card.Draftboard { decks } } ] → void do
        let
          rectFrom' =
            reallyAccomodateDeck (Map.toList decks) $
              rectFrom { x = 1.0, y = 1.0 }
          decks' = Map.insert deckFrom rectFrom' decks
          card = { cardId, model: Card.Draftboard { decks: decks' } }
        unsafeUpdateCachedDraftboard deck.wiring deckId' card
        H.modify \s → s { decks = Map.delete deckFrom s.decks }
        queryDeck deckTo
          $ H.action
          $ DCQ.SetModelCards [ deckId' × card ]

      _ → do
        let
          rectTo' = rectTo { x = 1.0, y = 1.0 }
          rectFrom' = rectFrom { x = 1.0, y = rectTo.height + 2.0 }
          newDeck = DM.emptyDeck
            { parent = Just (deckId × cardId)
            , cards = pure
              { cardId: CID.CardId 0
              , model: Card.Draftboard
                { decks: Map.fromFoldable
                  [ deckTo × rectTo'
                  , deckFrom × rectFrom'
                  ]
                }
              }
            }
        newId ← H.fromEff freshDeckId
        putDeck deck.path newId newDeck deck.wiring.decks >>= case _ of
          Left err → do
            -- TODO: do something to notify the user saving failed
            pure unit
          Right _ → void do
            H.modify \s → s
              { decks
                  = Map.insert newId rectTo
                  $ Map.delete deckFrom
                  $ Map.delete deckTo
                  $ s.decks
              }
            queryDeck newId
              $ H.action
              $ DCQ.Load deck.path newId (DL.succ deck.level)

queryDeck ∷ ∀ a. DeckId → DCQ.Query a → DraftboardDSL (Maybe a)
queryDeck deckId = H.query deckId ∘ right

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Card.Draftboard.Component
  ( draftboardComponent
  , module SlamData.Workspace.Card.Draftboard.Component.Query
  , module SlamData.Workspace.Card.Draftboard.Component.State
  ) where

import SlamData.Prelude

import Control.Monad.Maybe.Trans (MaybeT(..), runMaybeT)

import Data.Array as Array
import Data.Function (on)
import Data.Lens ((.~), (?~))
import Data.List as List
import Data.Map as Map
import CSS as CSS

import DOM.HTML.Types (HTMLElement)

import Halogen as H
import Halogen.Component.Opaque.Unsafe (opaqueState)
import Halogen.Component.Utils.Drag as Drag
import Halogen.Component.Utils (raise')
import Halogen.CustomEvents (mouseEventToPageEvent)
import Halogen.HTML.CSS.Indexed as HC
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP

import Math (round, floor)

import SlamData.Config as Config
import SlamData.Effects (Slam)
import SlamData.Workspace.AccessType as AT
import SlamData.Workspace.Card.CardId as CID
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.Common (CardOptions)
import SlamData.Workspace.Card.Component as CC
import SlamData.Workspace.Card.Draftboard.Common (deleteGraph, unsafeUpdateCachedDraftboard)
import SlamData.Workspace.Card.Draftboard.Component.CSS as CCSS
import SlamData.Workspace.Card.Draftboard.Component.Query (Query(..), QueryP, QueryC)
import SlamData.Workspace.Card.Draftboard.Component.State (State, DeckPosition, initialState, encode, decode, _moving, _inserting, _grouping, modelFromState)
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.Deck.Common (wrappedDeck, defaultPosition)
import SlamData.Workspace.Deck.Component.Nested.Query as DNQ
import SlamData.Workspace.Deck.Component.Nested.State as DNS
import SlamData.Workspace.Deck.Component.Query as DCQ
import SlamData.Workspace.Deck.Component.State as DCS
import SlamData.Workspace.Deck.DeckId (DeckId, deckIdToString, freshDeckId)
import SlamData.Workspace.Deck.DeckLevel as DL
import SlamData.Workspace.Deck.Model as DM
import SlamData.Workspace.Wiring (putDeck)

import Utils.CSS (zIndex)
import Utils.DOM (elementEq, scrollTop, scrollLeft, getOffsetClientRect)

type DraftboardDSL = H.ParentDSL State DNS.State QueryC DNQ.QueryP Slam DeckId

type DraftboardHTML = H.ParentHTML DNS.State QueryC DNQ.QueryP Slam DeckId

draftboardComponent ∷ CardOptions → CC.CardComponent
draftboardComponent opts = CC.makeCardComponent
  { cardType: CT.Draftboard
  , component: H.parentComponent
      { render: render opts
      , eval: coproduct evalCard (evalBoard opts)
      , peek: Just (peek opts)
      }
  , initialState: H.parentState initialState
  , _State: CC._DraftboardState
  , _Query: CC.makeQueryPrism' CC._DraftboardQuery
  }

render ∷ CardOptions → State → DraftboardHTML
render opts state =
  HH.div_
    [ HH.div [ HP.class_ CCSS.insetShadow ] []
    , HH.div
        [ HP.class_ CCSS.grid
        , HC.style bgSize
        , HP.ref (right ∘ H.action ∘ SetElement)
        , HE.onClick \e → pure $
            guard (AT.isEditable opts.deck.accessType && not state.inserting) $>
            right (H.action $ AddDeck e)
        ]
        $ map renderDeck (foldl Array.snoc [] $ Map.toList state.decks)
    ]

  where
  renderDeck (deckId × rect) =
    HH.div
      [ HP.key $ deckIdToString deckId
      , HP.classes $
          case state.grouping of
            Just deckId' | deckId == deckId' → [ HH.className "grouping" ]
            _ → []
      , HC.style $
          case state.moving of
            Just (deckId' × rect') | deckId == deckId' → zIndex 2 *> cssPos rect'
            _ → cssPos rect
      ]
      [ HH.slot deckId $ mkDeckComponent deckId ]

  mkDeckComponent id _ =
    { component: opts.deckComponent (opaqueState $ DCS.initialDeck opts.deck.path id)
    , initialState: DNS.initialState
    }

  cssPos rect = do
    CSS.position CSS.absolute
    CSS.top $ CSS.px $ gridToPx rect.y
    CSS.left $ CSS.px $ gridToPx rect.x
    CSS.width $ CSS.px $ gridToPx rect.width
    CSS.height $ CSS.px $ gridToPx rect.height

  bgSize = do
    let size = foldr maxSize { width: 0.0, height: 0.0 } state.decks
        size' = maybe size (flip maxSize size ∘ snd) state.moving
    CSS.width $ CSS.px $ gridToPx $ size'.width + 1.0
    CSS.height $ CSS.px $ gridToPx $ size'.height + 1.0

evalCard ∷ Natural CC.CardEvalQuery DraftboardDSL
evalCard = case _ of
  CC.EvalCard _ _ next →
    pure next
  CC.SetDimensions _ next →
    pure next
  CC.Save k →
    map (k ∘ Card.Draftboard ∘ modelFromState) H.get
  CC.Load card next → do
    case card of
      Card.Draftboard model → do
        H.modify _ { decks = model.decks }
        loadDecks
      _ → pure unit
    pure next
  CC.ModelUpdated _ next →
    pure next
  CC.ZoomIn next →
    pure next

evalBoard ∷ CardOptions → Natural Query DraftboardDSL
evalBoard opts = case _ of
  Grabbing deckId ev next → do
    case ev of
      Drag.Move _ d → do
        st ← H.get
        for_ (Map.lookup deckId (st.decks)) \rect →
        for_ st.canvas \el → do
          coords ← pageToGrid d el
          let
            cursorRect =
              { x: coords.x
              , y: coords.y
              , width: 1.0
              , height: 1.0
              }
            newRect = clampDeck rect
              { x = rect.x + (pxToGrid d.offsetX)
              , y = rect.y + (pxToGrid d.offsetY)
              }
            grouping =
              case overlapping cursorRect (Map.toList st.decks) of
                List.Cons (deckId' × _) _ | deckId ≠ deckId' → Just deckId'
                _ → Nothing
          H.modify
            $ (_moving ?~ Tuple deckId newRect)
            ∘ (_grouping .~ grouping)
      Drag.Done _ → do
        stopDragging opts
        CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  Resizing deckId ev next → do
    case ev of
      Drag.Move _ d → do
        H.gets (Map.lookup deckId ∘ _.decks) >>= traverse_ \rect → do
          let
            newRect = clampDeck rect
              { width = rect.width + (pxToGrid d.offsetX)
              , height = rect.height + (pxToGrid d.offsetY)
              }
          H.modify $ _moving ?~ Tuple deckId newRect
      Drag.Done _ → do
        stopDragging opts
        CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  SetElement el next → do
    H.modify _ { canvas = el }
    pure next
  AddDeck e next → do
    let e' = mouseEventToPageEvent e
    H.gets _.canvas >>= traverse_ \el → do
      same ← H.fromEff (elementEq el e'.target)
      when same do
        coords ← pageToGrid { x: e'.pageX, y: e'.pageY } el
        addDeck opts DM.emptyDeck
          { x: floor $ coords.x + 1.0
          , y: floor $ coords.y
          }
        CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  LoadDeck deckId next → do
    queryDeck deckId
      $ H.action
      $ DCQ.Load opts.deck.path deckId (DL.succ opts.deck.level)
    pure next
  -- TODO: hopefully we can get rid of this later, as it's relatively expensive
  -- and will run quite frequently, as it's used to enable the `Unwrap` action.
  -- If we can add a real mechanism for handling card-specific actions on the
  -- deck backside we should be able to do something much more sensible, only
  -- building the decks' value here when we actually trigger an unwrap. -gb
  GetDecks k → do
    decks ← H.gets _.decks
    decks' ← runMaybeT $ for (Map.toList decks) \(deckId × position) -> do
      model ← MaybeT $ queryDeck deckId $ H.request DCQ.GetModel
      pure (deckId × (position × model))
    pure $ k $ maybe Map.empty Map.fromList decks'

peek ∷ ∀ a. CardOptions → H.ChildF DeckId DNQ.QueryP a → DraftboardDSL Unit
peek opts (H.ChildF deckId q) = coproduct (const (pure unit)) peekDeck q
  where
  peekDeck ∷ DCQ.Query a → DraftboardDSL Unit
  peekDeck = case _ of
    DCQ.GrabDeck ev _ → startDragging deckId ev Grabbing
    DCQ.ResizeDeck ev _ → startDragging deckId ev Resizing
    DCQ.DoAction DCQ.DeleteDeck _ → do
      deleteDeck opts deckId
      CC.raiseUpdatedP' CC.EvalModelUpdate
    DCQ.DoAction DCQ.Wrap _ → do
      wrapDeck opts deckId
      CC.raiseUpdatedP' CC.EvalModelUpdate
    DCQ.DoAction (DCQ.Unwrap decks) _ → do
      unwrapDeck opts deckId decks
      CC.raiseUpdatedP' CC.EvalModelUpdate
    DCQ.DoAction DCQ.Mirror _ → do
      mirrorDeck opts deckId
      CC.raiseUpdatedP' CC.EvalModelUpdate
    _ → pure unit

  startDragging deckId ev tag =
    H.gets (Map.lookup deckId ∘ _.decks) >>= traverse_ \rect → do
      H.modify $ _moving ?~ Tuple deckId rect
      void
        $ Drag.subscribe' ev
        $ right ∘ H.action ∘ tag deckId

pageToGrid
  ∷ ∀ r
  . { x ∷ Number, y ∷ Number | r }
  → HTMLElement
  → DraftboardDSL { x ∷ Number, y ∷ Number }
pageToGrid e el = do
  rect ← H.fromEff $ getOffsetClientRect el
  scroll ←
    { top: _, left: _ }
    <$> H.fromEff (scrollTop el)
    <*> H.fromEff (scrollLeft el)
  pure
    { x: pxToGrid $ e.x - rect.left + scroll.left
    , y: pxToGrid $ e.y - rect.top + scroll.top
    }

pxToGrid ∷ Number → Number
pxToGrid = (_ / Config.gridPx)

gridToPx ∷ Number → Number
gridToPx = (_ * Config.gridPx)

stopDragging ∷ CardOptions → DraftboardDSL Unit
stopDragging opts = do
  st ← H.get
  for_ st.moving \(deckId × rect) → do
    let rect' = roundDeck rect
        decks = List.filter ((deckId /= _) ∘ fst) $ Map.toList st.decks
    case st.grouping of
      Just deckId' →
        groupDecks opts deckId deckId'
      Nothing →
        when (List.null $ overlapping rect' decks) do
          H.modify \s → s { decks = Map.insert deckId rect' s.decks }
  H.modify _
    { moving = Nothing
    , grouping = Nothing
    }

maxSize
  ∷ DeckPosition
  → { width ∷ Number, height ∷ Number }
  → { width ∷ Number, height ∷ Number }
maxSize deck size =
  { width: if x > size.width then x else size.width
  , height: if y > size.height then y else size.height
  }
  where
  x = deck.x + deck.width
  y = deck.y + deck.height

clampDeck ∷ DeckPosition → DeckPosition
clampDeck rect =
  { x: if rect.x < 0.0 then 0.0 else rect.x
  , y: if rect.y < 0.0 then 0.0 else rect.y
  , width: if rect.width < 10.0 then 10.0 else rect.width
  , height: if rect.height < 10.0 then 10.0 else rect.height
  }

roundDeck ∷ DeckPosition → DeckPosition
roundDeck rect =
  { x: round rect.x
  , y: round rect.y
  , width: round rect.width
  , height: round rect.height
  }

overlapping
  ∷ DeckPosition
  → List.List (DeckId × DeckPosition)
  → List.List (DeckId × DeckPosition)
overlapping a = List.filter go
  where
  go (_ × b) =
    not $ a.x + a.width <= b.x
       || b.x + b.width <= a.x
       || a.y + a.height <= b.y
       || b.y + b.height <= a.y

accomodateDeck
  ∷ List.List (DeckId × DeckPosition)
  → { x ∷ Number, y ∷ Number }
  → DeckPosition
  → Maybe DeckPosition
accomodateDeck bs = go List.Nil
  where
  go hist c a =
    case overlapping a bs of
      List.Nil →
        Just a
      bs' | not $ List.null $ List.intersectBy (eq `on` fst) hist bs' →
        Nothing
      List.Cons b _ →
        let a' = clampDeck $ reposition c a (snd b)
            c' = { x: a'.x + (floor (a'.width / 2.0)), y: a'.y }
        in  go (List.Cons b hist) c' a'

  reposition c a b
    | c.x >= b.x && c.x < b.x + b.width = a { y = b.y - a.height }
    | c.x >= b.x + b.width = a { x = b.x + b.width }
    | c.y < b.x = a { x = b.x - a.width }
    | otherwise = a

reallyAccomodateDeck
  ∷ List.List (DeckId × DeckPosition)
  → DeckPosition
  → DeckPosition
reallyAccomodateDeck decks deckPos =
  let deckPos' = deckPos { y = deckPos.y + deckPos.height }
      coords = { x: floor (deckPos'.x + deckPos'.x / 2.0), y: deckPos'.y }
  in
      case accomodateDeck decks coords deckPos of
        Nothing → reallyAccomodateDeck decks deckPos'
        Just a → a

loadDecks ∷ DraftboardDSL Unit
loadDecks =
  H.gets (Map.keys ∘ _.decks) >>=
    traverse_ (raise' ∘ right ∘ H.action ∘ LoadDeck)

addDeck ∷ CardOptions → DM.Deck → { x ∷ Number, y ∷ Number } → DraftboardDSL Unit
addDeck opts deck coords = do
  decks ← Map.toList <$> H.gets _.decks
  let
    deckPos = clampDeck $ defaultPosition
      { x = coords.x - 10.0
      , y = coords.y
      }
  for_ (accomodateDeck decks coords deckPos) $
    addDeckAt opts deck

addDeckAt ∷ CardOptions → DM.Deck → DeckPosition → DraftboardDSL Unit
addDeckAt { deck: opts, deckId: parentId, cardId } deck deckPos = do
  let deck' = deck { parent = Just (parentId × cardId) }
  H.modify $ _inserting .~ true
  deckId ← H.fromEff freshDeckId
  putDeck opts.path deckId deck' opts.wiring.decks >>= case _ of
    Left err → do
      H.modify $ _inserting .~ false
      -- TODO: do something to notify the user saving failed
      pure unit
    Right _ → void do
      H.modify \s → s
        { decks = Map.insert deckId deckPos s.decks
        , inserting = false
        }
      queryDeck deckId
        $ H.action
        $ DCQ.Load opts.path deckId (DL.succ opts.level)

deleteDeck ∷ CardOptions → DeckId → DraftboardDSL Unit
deleteDeck { deck } deckId = do
  res ← deleteGraph deck.path deckId
  case res of
    Left err →
      -- TODO: do something to notify the user deleting failed
      pure unit
    Right _ →
      H.modify \s → s { decks = Map.delete deckId s.decks }

wrapDeck ∷ CardOptions → DeckId → DraftboardDSL Unit
wrapDeck { cardId, deckId: parentId, deck } oldId = do
  H.gets (Map.lookup oldId ∘ _.decks) >>= traverse_ \deckPos → do
    let
      deckPos' = deckPos { x = 1.0, y = 1.0 }
      newDeck = (wrappedDeck deckPos' oldId) { parent = Just (parentId × cardId) }
    newId ← H.fromEff freshDeckId
    putDeck deck.path newId newDeck deck.wiring.decks >>= case _ of
      Left err → do
        -- TODO: do something to notify the user saving failed
        pure unit
      Right _ → void do
        traverse_ (queryDeck oldId ∘ H.action)
          [ DCQ.SetParent (newId × CID.CardId 0)
          , DCQ.Save Nothing
          ]
        H.modify \s → s
          { decks
              = Map.insert newId deckPos
              $ Map.delete oldId
              $ s.decks
          }
        queryDeck newId
          $ H.action
          $ DCQ.Load deck.path newId (DL.succ deck.level)

unwrapDeck
  ∷ CardOptions
  → DeckId
  → Map.Map DeckId (DeckPosition × DM.Deck)
  → DraftboardDSL Unit
unwrapDeck { deckId, cardId, deck } oldId decks = void $ runMaybeT do
  -- sort the decks here so they are ordered by position, this ensures that if
  -- decks need to be accomodated when broken out, the decks in the top left
  -- corner will maintain their position and the others will be accomodated.
  let deckList = List.sortBy (compare `on` toCoords) $ Map.toList decks
  let coord = deckId × cardId
  let level' = DL.succ deck.level
  offset ← MaybeT $ H.gets (Map.lookup oldId ∘ _.decks)
  lift do
    H.modify \s →
      s { decks = foldl (reinsert offset) (Map.delete oldId s.decks) deckList }
    for_ deckList \(deckId × (_ × deck)) → do
      let deck' = deck { parent = Just coord }
      queryDeck deckId $ H.action $ DCQ.SetModel deckId deck' level'
      queryDeck deckId $ H.action $ DCQ.Save Nothing
  where
  reinsert offset acc (deckId × (pos × deck)) =
    Map.insert deckId (updatePos (Map.toList acc) offset pos) acc
  updatePos currentDecks offset pos =
    reallyAccomodateDeck currentDecks $
      pos
        { x = pos.x + offset.x + 1.0
        , y = pos.y + offset.y + 1.0
        }
  toCoords (_ × (pos × _)) = Tuple pos.x pos.y

mirrorDeck ∷ CardOptions → DeckId → DraftboardDSL Unit
mirrorDeck opts oldId = do
  queryDeck oldId (H.request DCQ.GetModelCards) >>= traverse_ \modelCards → do
    let modelCards' = Array.span (not ∘ eq oldId ∘ fst) modelCards
    if Array.null modelCards'.rest
      then insertNewDeck DM.emptyDeck { mirror = DCS.coordModelToCoord <$> modelCards'.init }
      else do
        let
          newDeck =
            { parent: Nothing
            , mirror: map _.cardId <$> modelCards'.init
            , cards: snd <$> modelCards'.rest
            , name: ""
            }
        newId ← H.fromEff freshDeckId
        putDeck opts.deck.path newId newDeck opts.deck.wiring.decks >>= case _ of
          Left _ →
            -- TODO: do something to notify the user saving failed
            pure unit
          Right _ → do
            let modelCards'' = modelCards'.init <> map (lmap (const newId)) modelCards'.rest
            queryDeck oldId $ H.action $ DCQ.SetModelCards modelCards''
            insertNewDeck DM.emptyDeck { mirror = DCS.coordModelToCoord <$> modelCards'' }
  where
  insertNewDeck deck = do
    st ← H.get
    for_ (Map.lookup oldId st.decks) \deckPos →
      addDeckAt opts deck $
        reallyAccomodateDeck (Map.toList st.decks) deckPos

groupDecks ∷ CardOptions → DeckId → DeckId → DraftboardDSL Unit
groupDecks { cardId, deckId, deck } deckFrom deckTo = do
  st ← H.get
  for_ (Map.lookup deckFrom st.decks) \rectFrom →
  for_ (Map.lookup deckTo st.decks) \rectTo →
    queryDeck deckTo (H.request DCQ.GetModelCards) >>= case _ of
      Just [ deckId' × { cardId, model: Card.Draftboard { decks } } ] → void do
        let
          rectFrom' =
            reallyAccomodateDeck (Map.toList decks) $
              rectFrom { x = 1.0, y = 1.0 }
          decks' = Map.insert deckFrom rectFrom' decks
          card = { cardId, model: Card.Draftboard { decks: decks' } }
        unsafeUpdateCachedDraftboard deck.wiring deckId' card
        H.modify \s → s { decks = Map.delete deckFrom s.decks }
        queryDeck deckTo
          $ H.action
          $ DCQ.SetModelCards [ deckId' × card ]

      _ → do
        let
          rectTo' = rectTo { x = 1.0, y = 1.0 }
          rectFrom' = rectFrom { x = 1.0, y = rectTo.height + 2.0 }
          newDeck = DM.emptyDeck
            { parent = Just (deckId × cardId)
            , cards = pure
              { cardId: CID.CardId 0
              , model: Card.Draftboard
                { decks: Map.fromFoldable
                  [ deckTo × rectTo'
                  , deckFrom × rectFrom'
                  ]
                }
              }
            }
        newId ← H.fromEff freshDeckId
        putDeck deck.path newId newDeck deck.wiring.decks >>= case _ of
          Left err → do
            -- TODO: do something to notify the user saving failed
            pure unit
          Right _ → void do
            H.modify \s → s
              { decks
                  = Map.insert newId rectTo
                  $ Map.delete deckFrom
                  $ Map.delete deckTo
                  $ s.decks
              }
            queryDeck newId
              $ H.action
              $ DCQ.Load deck.path newId (DL.succ deck.level)

queryDeck ∷ ∀ a. DeckId → DCQ.Query a → DraftboardDSL (Maybe a)
queryDeck deckId = H.query deckId ∘ right


Add the `writer` function

Add the `writer` function

-- | This module defines the `Writer` monad.

module Control.Monad.Writer
  ( Writer
  , runWriter
  , execWriter
  , mapWriter
  , module Control.Monad.Writer.Class
  , module Control.Monad.Writer.Trans
  ) where

import Prelude

import Control.Monad.Writer.Class (class MonadTell, tell, class MonadWriter, censor, listen, listens, pass)
import Control.Monad.Writer.Trans (class MonadTrans, WriterT(..), execWriterT, lift, mapWriterT, runWriterT)

import Data.Identity (Identity(..))
import Data.Newtype (unwrap)
import Data.Tuple (Tuple, snd)

-- | The `Writer` monad is a synonym for the `WriterT` monad transformer, applied
-- | to the `Identity` monad.
type Writer w = WriterT w Identity

-- | Creates a `Writer` from a result and output pair.
writer :: forall w a. Tuple a w -> Writer w a
writer = WriterT <<< pure

-- | Run a computation in the `Writer` monad
runWriter :: forall w a. Writer w a -> Tuple a w
runWriter = unwrap <<< runWriterT

-- | Run a computation in the `Writer` monad, discarding the result
execWriter :: forall w a. Writer w a -> w
execWriter m = snd (runWriter m)

-- | Change the result and accumulator types in a `Writer` monad action
mapWriter :: forall w1 w2 a b. (Tuple a w1 -> Tuple b w2) -> Writer w1 a -> Writer w2 b
mapWriter f = mapWriterT (Identity <<< f <<< unwrap)

-- | This module defines the `Writer` monad.

module Control.Monad.Writer
  ( Writer
  , runWriter
  , execWriter
  , mapWriter
  , module Control.Monad.Writer.Class
  , module Control.Monad.Writer.Trans
  ) where

import Prelude

import Control.Monad.Writer.Class (class MonadTell, tell, class MonadWriter, censor, listen, listens, pass)
import Control.Monad.Writer.Trans (class MonadTrans, WriterT(..), execWriterT, lift, mapWriterT, runWriterT)

import Data.Identity (Identity(..))
import Data.Newtype (unwrap)
import Data.Tuple (Tuple, snd)

-- | The `Writer` monad is a synonym for the `WriterT` monad transformer, applied
-- | to the `Identity` monad.
type Writer w = WriterT w Identity

-- | Run a computation in the `Writer` monad
runWriter :: forall w a. Writer w a -> Tuple a w
runWriter = unwrap <<< runWriterT

-- | Run a computation in the `Writer` monad, discarding the result
execWriter :: forall w a. Writer w a -> w
execWriter m = snd (runWriter m)

-- | Change the result and accumulator types in a `Writer` monad action
mapWriter :: forall w1 w2 a b. (Tuple a w1 -> Tuple b w2) -> Writer w1 a -> Writer w2 b
mapWriter f = mapWriterT (Identity <<< f <<< unwrap)


adding tests for arc construction

adding tests for arc construction

module Test.Geometry where

import Prelude
import App.Geometry
import Data.List (List(..), (:))
import Math (pi)
import Test.Spec (describe, it)
import Test.Spec.Assertions (shouldEqual)

spec = do
  describe "App.Geometry" do
    describe "Arc" do
      it "should be constructed correctly" do
        (constructArc (Point 1.0 1.0) (Point 2.0 1.0)) `shouldEqual` Arc (Point 1.0 1.0) 1.0 0.0 (2.0 * pi)
        (constructArc (Point 1.0 1.0) (Point 1.0 2.0)) `shouldEqual` Arc (Point 1.0 1.0) 1.0 (pi / 2.0) (2.0 * pi)

      it "should report back firstPoint correctly" do
        firstPoint (Arc (Point 1.0 1.0) 1.0 0.0 (2.0 * pi)) `shouldEqual` Point 2.0 1.0
        firstPoint (Arc (Point 1.0 1.0) 1.0 (pi / 2.0) (2.0 * pi)) `shouldEqual` Point 1.0 2.0
        firstPoint (Arc (Point 1.0 1.0) 1.0 (-pi / 2.0) (2.0 * pi)) `shouldEqual` Point 1.0 0.0
        firstPoint (Arc (Point 1.0 1.0) 1.0 pi (2.0 * pi)) `shouldEqual` Point 0.0 1.0

        (firstPoint $ constructArc (Point 10.0 10.0) (Point 20.0 20.0))
          `shouldEqual` Point 20.0 20.0

      it "should report back secondPoint correctly" do
        (secondPoint $ constructArc (Point 10.0 10.0) (Point 20.0 20.0))
          `shouldEqual` Point 20.0 20.0

        secondPoint (Arc (Point 1.0 1.0) 1.0 pi pi) `shouldEqual` Point 2.0 1.0

    describe "intersect" do
      it "should find an intersection point" do
        intersect (Line (Point 0.0 0.0) (Point 1.0 1.0)) (Line (Point 0.0 1.0) (Point 1.0 0.0))
          `shouldEqual` ((Point 0.5 0.5) : Nil)

      it "should not find an intersection point for parallel lines" do
        intersect (Line (Point 0.0 0.0) (Point 0.0 1.0)) (Line (Point 1.0 0.0) (Point 1.0 1.0))
          `shouldEqual` Nil

    describe "split" do
      it "should split a line, in order" do
        split (Line (Point 0.0 0.0) (Point 1.0 1.0)) ((Point 0.2 0.2) : (Point 0.7 0.7) : (Point 0.5 0.5) : Nil)
          `shouldEqual`
          ( (Line (Point 0.0 0.0) (Point 0.2 0.2))
          : (Line (Point 0.2 0.2) (Point 0.5 0.5))
          : (Line (Point 0.5 0.5) (Point 0.7 0.7))
          : (Line (Point 0.7 0.7) (Point 1.0 1.0))
          : Nil)

module Test.Geometry where

import Prelude
import App.Geometry
import Data.List (List(..), (:))
import Test.Spec (describe, it)
import Test.Spec.Assertions (shouldEqual)

p1 = Point 0.0 0.0
p2 = Point 1.0 1.0
p3 = Point 1.0 0.0
p4 = Point 0.0 1.0

l12 = Line p1 p2
l34 = Line p3 p4

spec = do
  describe "App.Geometry" do
    describe "intersect" do
      it "should find an intersection point" do
        intersect (Line (Point 0.0 0.0) (Point 1.0 1.0)) (Line (Point 0.0 1.0) (Point 1.0 0.0))
          `shouldEqual` ((Point 0.5 0.5) : Nil)

      it "should not find an intersection point for parallel lines" do
        intersect (Line (Point 0.0 0.0) (Point 0.0 1.0)) (Line (Point 1.0 0.0) (Point 1.0 1.0))
          `shouldEqual` Nil

    describe "split" do
      it "should split a line, in order" do
        split (Line (Point 0.0 0.0) (Point 1.0 1.0)) ((Point 0.2 0.2) : (Point 0.7 0.7) : (Point 0.5 0.5) : Nil)
          `shouldEqual`
          ( (Line (Point 0.0 0.0) (Point 0.2 0.2))
          : (Line (Point 0.2 0.2) (Point 0.5 0.5))
          : (Line (Point 0.5 0.5) (Point 0.7 0.7))
          : (Line (Point 0.7 0.7) (Point 1.0 1.0))
          : Nil)