removed unneeded foreign error from addForeignPropHandler

module Halogen.HTML.Events
  ( input
  , input_
  , handler
  , onAbort
  , onError
  , onLoad
  , onScroll
  , onChange
  , onInput
  , onInvalid
  , onReset
  , onSelect
  , onSubmit
  , onTransitionEnd
  , onCopy
  , onPaste
  , onCut
  , onClick
  -- , onContextMenu
  , onDoubleClick
  , onMouseDown
  , onMouseEnter
  , onMouseLeave
  , onMouseMove
  , onMouseOver
  , onMouseOut
  , onMouseUp
  , onWheel
  , onKeyDown
  -- , onKeyPress
  , onKeyUp
  , onBlur
  , onFocus
  , onFocusIn
  , onFocusOut
  , onDrag
  , onDragEnd
  , onDragExit
  , onDragEnter
  , onDragLeave
  , onDragOver
  , onDragStart
  , onDrop
  , onTouchCancel
  , onTouchEnd
  , onTouchEnter
  , onTouchLeave
  , onTouchMove
  , onTouchStart
  , onResize
  , onValueChange
  , onValueInput
  , onSelectedIndexChange
  , onChecked
  ) where

import Prelude

import Control.Monad.Except (runExcept)
import Data.Either (either)
import Data.Maybe (Maybe(..))
import Foreign (F, Foreign, readBoolean, readInt, readString, unsafeToForeign)
import Foreign.Index (readProp)
import Halogen.HTML.Core (Prop)
import Halogen.HTML.Core as Core
import Halogen.HTML.Properties (IProp)
import Halogen.Query (Action, action)
import Halogen.Query.InputF (InputF(..))
import Unsafe.Coerce (unsafeCoerce)
import Web.Clipboard.ClipboardEvent (ClipboardEvent)
import Web.Clipboard.ClipboardEvent.EventTypes as CET
import Web.Event.Event (Event, EventType(..))
import Web.Event.Event as EE
import Web.HTML.Event.DragEvent (DragEvent)
import Web.HTML.Event.DragEvent.EventTypes as DET
import Web.HTML.Event.EventTypes as ET
import Web.TouchEvent.TouchEvent (TouchEvent)
import Web.UIEvent.FocusEvent (FocusEvent)
import Web.UIEvent.FocusEvent.EventTypes as FET
import Web.UIEvent.KeyboardEvent (KeyboardEvent)
import Web.UIEvent.KeyboardEvent.EventTypes as KET
import Web.UIEvent.MouseEvent (MouseEvent)
import Web.UIEvent.MouseEvent.EventTypes as MET
import Web.UIEvent.WheelEvent (WheelEvent)
import Web.UIEvent.WheelEvent.EventTypes as WET

input :: forall f a. (a -> Action f) -> a -> Maybe (f Unit)
input f x = Just $ action (f x)

input_ :: forall f a. Action f -> a -> Maybe (f Unit)
input_ f _ = Just $ action f

handler :: forall r i. EventType -> (Event -> Maybe i) -> IProp r i
handler et = (unsafeCoerce :: (EventType -> (Event -> Maybe i) -> Prop i) -> EventType -> (Event -> Maybe (InputF Unit i)) -> IProp r i) Core.handler et <<< map (map Query)

onAbort :: forall r i. (Event -> Maybe i) -> IProp (onAbort :: Event | r) i
onAbort = handler (EventType "abort")

onError :: forall r i. (Event -> Maybe i) -> IProp (onError :: Event | r) i
onError = handler ET.error

onLoad :: forall r i. (Event -> Maybe i) -> IProp (onLoad :: Event | r) i
onLoad = handler ET.load

onScroll :: forall r i. (Event -> Maybe i) -> IProp (onScroll :: Event | r) i
onScroll = handler (EventType "scroll")

onChange :: forall r i. (Event -> Maybe i) -> IProp (onChange :: Event | r) i
onChange = handler ET.change

onInput :: forall r i. (Event -> Maybe i) -> IProp (onInput :: Event | r) i
onInput = handler ET.input

onInvalid :: forall r i. (Event -> Maybe i) -> IProp (onInvalid :: Event | r) i
onInvalid = handler ET.invalid

onReset :: forall r i. (Event -> Maybe i) -> IProp (onReset :: Event | r) i
onReset = handler (EventType "reset")

onSelect :: forall r i. (Event -> Maybe i) -> IProp (onSelect :: Event | r) i
onSelect = handler ET.select

onSubmit :: forall r i. (Event -> Maybe i) -> IProp (onSubmit :: Event | r) i
onSubmit = handler (EventType "submit")

onTransitionEnd :: forall r i. (Event -> Maybe i) -> IProp (onTransitionEnd :: Event | r) i
onTransitionEnd = handler (EventType "transitionend")

onCopy :: forall r i. (ClipboardEvent -> Maybe i) -> IProp (onCopy :: ClipboardEvent | r) i
onCopy = handler CET.copy <<< clipboardHandler

onPaste :: forall r i. (ClipboardEvent -> Maybe i) -> IProp (onPaste :: ClipboardEvent | r) i
onPaste = handler CET.paste <<< clipboardHandler

onCut :: forall r i. (ClipboardEvent -> Maybe i) -> IProp (onCut :: ClipboardEvent | r) i
onCut = handler CET.cut <<< clipboardHandler

onClick :: forall r i. (MouseEvent -> Maybe i) -> IProp (onClick :: MouseEvent | r) i
onClick = handler MET.click <<< mouseHandler

-- onContextMenu :: forall r i. (MouseEvent -> Maybe i) -> IProp (onContextMenu :: MouseEvent | r) i
-- onContextMenu = handler ET.contextmenu <<< mouseHandler

onDoubleClick :: forall r i. (MouseEvent -> Maybe i) -> IProp (onDoubleClick :: MouseEvent | r) i
onDoubleClick = handler MET.dblclick <<< mouseHandler

onMouseDown :: forall r i. (MouseEvent -> Maybe i) -> IProp (onMouseDown :: MouseEvent | r) i
onMouseDown = handler MET.mousedown <<< mouseHandler

onMouseEnter :: forall r i. (MouseEvent -> Maybe i) -> IProp (onMouseEnter :: MouseEvent | r) i
onMouseEnter = handler MET.mouseenter <<< mouseHandler

onMouseLeave :: forall r i. (MouseEvent -> Maybe i) -> IProp (onMouseLeave :: MouseEvent | r) i
onMouseLeave = handler MET.mouseleave <<< mouseHandler

onMouseMove :: forall r i. (MouseEvent -> Maybe i) -> IProp (onMouseMove :: MouseEvent | r) i
onMouseMove = handler MET.mousemove <<< mouseHandler

onMouseOver :: forall r i. (MouseEvent -> Maybe i) -> IProp (onMouseOver :: MouseEvent | r) i
onMouseOver = handler MET.mouseover <<< mouseHandler

onMouseOut :: forall r i. (MouseEvent -> Maybe i) -> IProp (onMouseOut :: MouseEvent | r) i
onMouseOut = handler MET.mouseout <<< mouseHandler

onMouseUp :: forall r i. (MouseEvent -> Maybe i) -> IProp (onMouseUp :: MouseEvent | r) i
onMouseUp = handler MET.mouseup <<< mouseHandler

onWheel :: forall r i. (WheelEvent -> Maybe i) -> IProp (onWheel :: WheelEvent | r) i
onWheel = handler WET.wheel <<< wheelHandler

onKeyDown :: forall r i. (KeyboardEvent -> Maybe i) -> IProp (onKeyDown :: KeyboardEvent | r) i
onKeyDown = handler KET.keydown <<< keyHandler

-- onKeyPress :: forall r i. (KeyboardEvent -> Maybe i) -> IProp (onKeyPress :: KeyboardEvent | r) i
-- onKeyPress = handler KET.keypress <<< keyHandler

onKeyUp :: forall r i. (KeyboardEvent -> Maybe i) -> IProp (onKeyUp :: KeyboardEvent | r) i
onKeyUp = handler KET.keyup <<< keyHandler

onBlur :: forall r i. (FocusEvent -> Maybe i) -> IProp (onBlur :: FocusEvent | r) i
onBlur = handler ET.blur <<< focusHandler

onFocus :: forall r i. (FocusEvent -> Maybe i) -> IProp (onFocus :: FocusEvent | r) i
onFocus = handler FET.focus <<< focusHandler

onFocusIn :: forall r i. (FocusEvent -> Maybe i) -> IProp (onFocusIn :: FocusEvent | r) i
onFocusIn = handler FET.focusin <<< focusHandler

onFocusOut :: forall r i. (FocusEvent -> Maybe i) -> IProp (onFocusOut :: FocusEvent | r) i
onFocusOut = handler FET.focusout <<< focusHandler

onDrag :: forall r i. (DragEvent -> Maybe i) -> IProp (onDrag :: DragEvent | r) i
onDrag = handler DET.drag <<< dragHandler

onDragEnd :: forall r i. (DragEvent -> Maybe i) -> IProp (onDragEnd :: DragEvent | r) i
onDragEnd = handler DET.dragend <<< dragHandler

onDragExit :: forall r i. (DragEvent -> Maybe i) -> IProp (onDragExit :: DragEvent | r) i
onDragExit = handler DET.dragexit <<< dragHandler

onDragEnter :: forall r i. (DragEvent -> Maybe i) -> IProp (onDragEnter :: DragEvent | r) i
onDragEnter = handler DET.dragenter <<< dragHandler

onDragLeave :: forall r i. (DragEvent -> Maybe i) -> IProp (onDragLeave :: DragEvent | r) i
onDragLeave = handler DET.dragleave <<< dragHandler

onDragOver :: forall r i. (DragEvent -> Maybe i) -> IProp (onDragOver :: DragEvent | r) i
onDragOver = handler DET.dragover <<< dragHandler

onDragStart :: forall r i. (DragEvent -> Maybe i) -> IProp (onDragStart :: DragEvent | r) i
onDragStart = handler DET.dragstart <<< dragHandler

onDrop :: forall r i. (DragEvent -> Maybe i) -> IProp (onDrop :: DragEvent | r) i
onDrop = handler DET.drop <<< dragHandler

onTouchCancel :: forall r i. (TouchEvent -> Maybe i) -> IProp (onTouchCancel :: TouchEvent | r) i
onTouchCancel = handler (EventType "touchcancel") <<< touchHandler

onTouchEnd :: forall r i. (TouchEvent -> Maybe i) -> IProp (onTouchEnd :: TouchEvent | r) i
onTouchEnd = handler (EventType "touchend") <<< touchHandler

onTouchEnter :: forall r i. (TouchEvent -> Maybe i) -> IProp (onTouchEnter :: TouchEvent | r) i
onTouchEnter = handler (EventType "touchenter") <<< touchHandler

onTouchLeave :: forall r i. (TouchEvent -> Maybe i) -> IProp (onTouchEnter :: TouchEvent | r) i
onTouchLeave = handler (EventType "touchleave") <<< touchHandler

onTouchMove :: forall r i. (TouchEvent -> Maybe i) -> IProp (onTouchMove :: TouchEvent | r) i
onTouchMove = handler (EventType "touchmove") <<< touchHandler

onTouchStart :: forall r i. (TouchEvent -> Maybe i) -> IProp (onTouchStart :: TouchEvent | r) i
onTouchStart = handler (EventType "touchstart") <<< touchHandler

onResize :: forall r i. (Event -> Maybe i) -> IProp (onResize :: Event | r) i
onResize = handler (EventType "resize")

keyHandler :: forall i. (KeyboardEvent -> Maybe i) -> Event -> Maybe i
keyHandler = unsafeCoerce

mouseHandler :: forall i. (MouseEvent -> Maybe i) -> Event -> Maybe i
mouseHandler = unsafeCoerce

wheelHandler :: forall i. (WheelEvent -> Maybe i) -> Event -> Maybe i
wheelHandler = unsafeCoerce

focusHandler :: forall i. (FocusEvent -> Maybe i) -> Event -> Maybe i
focusHandler = unsafeCoerce

dragHandler :: forall i. (DragEvent -> Maybe i) -> Event -> Maybe i
dragHandler = unsafeCoerce

clipboardHandler :: forall i. (ClipboardEvent -> Maybe i) -> Event -> Maybe i
clipboardHandler = unsafeCoerce

touchHandler :: forall i. (TouchEvent -> Maybe i) -> Event -> Maybe i
touchHandler = unsafeCoerce

-- | Attaches event handler to event `key` with getting `prop` field as an
-- | argument of `handler`.
addForeignPropHandler :: forall r i value. EventType -> String -> (Foreign -> F value) -> (value -> Maybe i) -> IProp r i
addForeignPropHandler key prop reader f =
  handler key $ EE.currentTarget >=> \e -> either (const Nothing) f $ runExcept $ go e
  where
  go a = reader <=< readProp prop $ unsafeToForeign a

-- | Attaches an event handler which will produce an input when the value of an
-- | input field changes.
onValueChange :: forall r i. (String -> Maybe i) -> IProp (value :: String, onChange :: Event | r) i
onValueChange = addForeignPropHandler ET.change "value" readString

-- | Attaches an event handler which will produce an input when the seleced index of a
-- | `select` element changes.
onSelectedIndexChange :: forall r i. (Int -> Maybe i) -> IProp (selectedIndex :: Int, onChange :: Event | r) i
onSelectedIndexChange = addForeignPropHandler ET.change "selectedIndex" readInt

-- | Attaches an event handler which will fire on input.
onValueInput :: forall r i. (String -> Maybe i) -> IProp (value :: String, onInput :: Event | r) i
onValueInput = addForeignPropHandler ET.input "value" readString

-- | Attaches an event handler which will fire when a checkbox is checked or
-- | unchecked.
onChecked :: forall r i. (Boolean -> Maybe i) -> IProp (checked :: Boolean, onChange :: Event | r) i
onChecked = addForeignPropHandler ET.change "checked" readBoolean

module Halogen.HTML.Events
  ( input
  , input_
  , handler
  , onAbort
  , onError
  , onLoad
  , onScroll
  , onChange
  , onInput
  , onInvalid
  , onReset
  , onSelect
  , onSubmit
  , onTransitionEnd
  , onCopy
  , onPaste
  , onCut
  , onClick
  -- , onContextMenu
  , onDoubleClick
  , onMouseDown
  , onMouseEnter
  , onMouseLeave
  , onMouseMove
  , onMouseOver
  , onMouseOut
  , onMouseUp
  , onWheel
  , onKeyDown
  -- , onKeyPress
  , onKeyUp
  , onBlur
  , onFocus
  , onFocusIn
  , onFocusOut
  , onDrag
  , onDragEnd
  , onDragExit
  , onDragEnter
  , onDragLeave
  , onDragOver
  , onDragStart
  , onDrop
  , onTouchCancel
  , onTouchEnd
  , onTouchEnter
  , onTouchLeave
  , onTouchMove
  , onTouchStart
  , onResize
  , onValueChange
  , onValueInput
  , onSelectedIndexChange
  , onChecked
  ) where

import Prelude

import Control.Monad.Except (runExcept)
import Data.Either (either)
import Data.Maybe (Maybe(..))
import Foreign (F, Foreign, readBoolean, readInt, readString, unsafeToForeign, fail, ForeignError(..))
import Foreign.Index (readProp)
import Halogen.HTML.Core (Prop)
import Halogen.HTML.Core as Core
import Halogen.HTML.Properties (IProp)
import Halogen.Query (Action, action)
import Halogen.Query.InputF (InputF(..))
import Unsafe.Coerce (unsafeCoerce)
import Web.Clipboard.ClipboardEvent (ClipboardEvent)
import Web.Clipboard.ClipboardEvent.EventTypes as CET
import Web.Event.Event (Event, EventType(..))
import Web.Event.Event as EE
import Web.HTML.Event.DragEvent (DragEvent)
import Web.HTML.Event.DragEvent.EventTypes as DET
import Web.HTML.Event.EventTypes as ET
import Web.TouchEvent.TouchEvent (TouchEvent)
import Web.UIEvent.FocusEvent (FocusEvent)
import Web.UIEvent.FocusEvent.EventTypes as FET
import Web.UIEvent.KeyboardEvent (KeyboardEvent)
import Web.UIEvent.KeyboardEvent.EventTypes as KET
import Web.UIEvent.MouseEvent (MouseEvent)
import Web.UIEvent.MouseEvent.EventTypes as MET
import Web.UIEvent.WheelEvent (WheelEvent)
import Web.UIEvent.WheelEvent.EventTypes as WET

input :: forall f a. (a -> Action f) -> a -> Maybe (f Unit)
input f x = Just $ action (f x)

input_ :: forall f a. Action f -> a -> Maybe (f Unit)
input_ f _ = Just $ action f

handler :: forall r i. EventType -> (Event -> Maybe i) -> IProp r i
handler et = (unsafeCoerce :: (EventType -> (Event -> Maybe i) -> Prop i) -> EventType -> (Event -> Maybe (InputF Unit i)) -> IProp r i) Core.handler et <<< map (map Query)

onAbort :: forall r i. (Event -> Maybe i) -> IProp (onAbort :: Event | r) i
onAbort = handler (EventType "abort")

onError :: forall r i. (Event -> Maybe i) -> IProp (onError :: Event | r) i
onError = handler ET.error

onLoad :: forall r i. (Event -> Maybe i) -> IProp (onLoad :: Event | r) i
onLoad = handler ET.load

onScroll :: forall r i. (Event -> Maybe i) -> IProp (onScroll :: Event | r) i
onScroll = handler (EventType "scroll")

onChange :: forall r i. (Event -> Maybe i) -> IProp (onChange :: Event | r) i
onChange = handler ET.change

onInput :: forall r i. (Event -> Maybe i) -> IProp (onInput :: Event | r) i
onInput = handler ET.input

onInvalid :: forall r i. (Event -> Maybe i) -> IProp (onInvalid :: Event | r) i
onInvalid = handler ET.invalid

onReset :: forall r i. (Event -> Maybe i) -> IProp (onReset :: Event | r) i
onReset = handler (EventType "reset")

onSelect :: forall r i. (Event -> Maybe i) -> IProp (onSelect :: Event | r) i
onSelect = handler ET.select

onSubmit :: forall r i. (Event -> Maybe i) -> IProp (onSubmit :: Event | r) i
onSubmit = handler (EventType "submit")

onTransitionEnd :: forall r i. (Event -> Maybe i) -> IProp (onTransitionEnd :: Event | r) i
onTransitionEnd = handler (EventType "transitionend")

onCopy :: forall r i. (ClipboardEvent -> Maybe i) -> IProp (onCopy :: ClipboardEvent | r) i
onCopy = handler CET.copy <<< clipboardHandler

onPaste :: forall r i. (ClipboardEvent -> Maybe i) -> IProp (onPaste :: ClipboardEvent | r) i
onPaste = handler CET.paste <<< clipboardHandler

onCut :: forall r i. (ClipboardEvent -> Maybe i) -> IProp (onCut :: ClipboardEvent | r) i
onCut = handler CET.cut <<< clipboardHandler

onClick :: forall r i. (MouseEvent -> Maybe i) -> IProp (onClick :: MouseEvent | r) i
onClick = handler MET.click <<< mouseHandler

-- onContextMenu :: forall r i. (MouseEvent -> Maybe i) -> IProp (onContextMenu :: MouseEvent | r) i
-- onContextMenu = handler ET.contextmenu <<< mouseHandler

onDoubleClick :: forall r i. (MouseEvent -> Maybe i) -> IProp (onDoubleClick :: MouseEvent | r) i
onDoubleClick = handler MET.dblclick <<< mouseHandler

onMouseDown :: forall r i. (MouseEvent -> Maybe i) -> IProp (onMouseDown :: MouseEvent | r) i
onMouseDown = handler MET.mousedown <<< mouseHandler

onMouseEnter :: forall r i. (MouseEvent -> Maybe i) -> IProp (onMouseEnter :: MouseEvent | r) i
onMouseEnter = handler MET.mouseenter <<< mouseHandler

onMouseLeave :: forall r i. (MouseEvent -> Maybe i) -> IProp (onMouseLeave :: MouseEvent | r) i
onMouseLeave = handler MET.mouseleave <<< mouseHandler

onMouseMove :: forall r i. (MouseEvent -> Maybe i) -> IProp (onMouseMove :: MouseEvent | r) i
onMouseMove = handler MET.mousemove <<< mouseHandler

onMouseOver :: forall r i. (MouseEvent -> Maybe i) -> IProp (onMouseOver :: MouseEvent | r) i
onMouseOver = handler MET.mouseover <<< mouseHandler

onMouseOut :: forall r i. (MouseEvent -> Maybe i) -> IProp (onMouseOut :: MouseEvent | r) i
onMouseOut = handler MET.mouseout <<< mouseHandler

onMouseUp :: forall r i. (MouseEvent -> Maybe i) -> IProp (onMouseUp :: MouseEvent | r) i
onMouseUp = handler MET.mouseup <<< mouseHandler

onWheel :: forall r i. (WheelEvent -> Maybe i) -> IProp (onWheel :: WheelEvent | r) i
onWheel = handler WET.wheel <<< wheelHandler

onKeyDown :: forall r i. (KeyboardEvent -> Maybe i) -> IProp (onKeyDown :: KeyboardEvent | r) i
onKeyDown = handler KET.keydown <<< keyHandler

-- onKeyPress :: forall r i. (KeyboardEvent -> Maybe i) -> IProp (onKeyPress :: KeyboardEvent | r) i
-- onKeyPress = handler KET.keypress <<< keyHandler

onKeyUp :: forall r i. (KeyboardEvent -> Maybe i) -> IProp (onKeyUp :: KeyboardEvent | r) i
onKeyUp = handler KET.keyup <<< keyHandler

onBlur :: forall r i. (FocusEvent -> Maybe i) -> IProp (onBlur :: FocusEvent | r) i
onBlur = handler ET.blur <<< focusHandler

onFocus :: forall r i. (FocusEvent -> Maybe i) -> IProp (onFocus :: FocusEvent | r) i
onFocus = handler FET.focus <<< focusHandler

onFocusIn :: forall r i. (FocusEvent -> Maybe i) -> IProp (onFocusIn :: FocusEvent | r) i
onFocusIn = handler FET.focusin <<< focusHandler

onFocusOut :: forall r i. (FocusEvent -> Maybe i) -> IProp (onFocusOut :: FocusEvent | r) i
onFocusOut = handler FET.focusout <<< focusHandler

onDrag :: forall r i. (DragEvent -> Maybe i) -> IProp (onDrag :: DragEvent | r) i
onDrag = handler DET.drag <<< dragHandler

onDragEnd :: forall r i. (DragEvent -> Maybe i) -> IProp (onDragEnd :: DragEvent | r) i
onDragEnd = handler DET.dragend <<< dragHandler

onDragExit :: forall r i. (DragEvent -> Maybe i) -> IProp (onDragExit :: DragEvent | r) i
onDragExit = handler DET.dragexit <<< dragHandler

onDragEnter :: forall r i. (DragEvent -> Maybe i) -> IProp (onDragEnter :: DragEvent | r) i
onDragEnter = handler DET.dragenter <<< dragHandler

onDragLeave :: forall r i. (DragEvent -> Maybe i) -> IProp (onDragLeave :: DragEvent | r) i
onDragLeave = handler DET.dragleave <<< dragHandler

onDragOver :: forall r i. (DragEvent -> Maybe i) -> IProp (onDragOver :: DragEvent | r) i
onDragOver = handler DET.dragover <<< dragHandler

onDragStart :: forall r i. (DragEvent -> Maybe i) -> IProp (onDragStart :: DragEvent | r) i
onDragStart = handler DET.dragstart <<< dragHandler

onDrop :: forall r i. (DragEvent -> Maybe i) -> IProp (onDrop :: DragEvent | r) i
onDrop = handler DET.drop <<< dragHandler

onTouchCancel :: forall r i. (TouchEvent -> Maybe i) -> IProp (onTouchCancel :: TouchEvent | r) i
onTouchCancel = handler (EventType "touchcancel") <<< touchHandler

onTouchEnd :: forall r i. (TouchEvent -> Maybe i) -> IProp (onTouchEnd :: TouchEvent | r) i
onTouchEnd = handler (EventType "touchend") <<< touchHandler

onTouchEnter :: forall r i. (TouchEvent -> Maybe i) -> IProp (onTouchEnter :: TouchEvent | r) i
onTouchEnter = handler (EventType "touchenter") <<< touchHandler

onTouchLeave :: forall r i. (TouchEvent -> Maybe i) -> IProp (onTouchEnter :: TouchEvent | r) i
onTouchLeave = handler (EventType "touchleave") <<< touchHandler

onTouchMove :: forall r i. (TouchEvent -> Maybe i) -> IProp (onTouchMove :: TouchEvent | r) i
onTouchMove = handler (EventType "touchmove") <<< touchHandler

onTouchStart :: forall r i. (TouchEvent -> Maybe i) -> IProp (onTouchStart :: TouchEvent | r) i
onTouchStart = handler (EventType "touchstart") <<< touchHandler

onResize :: forall r i. (Event -> Maybe i) -> IProp (onResize :: Event | r) i
onResize = handler (EventType "resize")

keyHandler :: forall i. (KeyboardEvent -> Maybe i) -> Event -> Maybe i
keyHandler = unsafeCoerce

mouseHandler :: forall i. (MouseEvent -> Maybe i) -> Event -> Maybe i
mouseHandler = unsafeCoerce

wheelHandler :: forall i. (WheelEvent -> Maybe i) -> Event -> Maybe i
wheelHandler = unsafeCoerce

focusHandler :: forall i. (FocusEvent -> Maybe i) -> Event -> Maybe i
focusHandler = unsafeCoerce

dragHandler :: forall i. (DragEvent -> Maybe i) -> Event -> Maybe i
dragHandler = unsafeCoerce

clipboardHandler :: forall i. (ClipboardEvent -> Maybe i) -> Event -> Maybe i
clipboardHandler = unsafeCoerce

touchHandler :: forall i. (TouchEvent -> Maybe i) -> Event -> Maybe i
touchHandler = unsafeCoerce

-- | Attaches event handler to event `key` with getting `prop` field as an
-- | argument of `handler`.
addForeignPropHandler :: forall r i value. EventType -> String -> (Foreign -> F value) -> (value -> Maybe i) -> IProp r i
addForeignPropHandler key prop reader f =
  handler key \e -> either (const Nothing) f $ runExcept $ go e
  where
  go e = case EE.currentTarget e of
    Nothing -> fail $ ForeignError "addForeignPropHandler expects `currentTarget` of the event be presented"
    Just a -> reader <=< readProp prop $ unsafeToForeign a

-- | Attaches an event handler which will produce an input when the value of an
-- | input field changes.
onValueChange :: forall r i. (String -> Maybe i) -> IProp (value :: String, onChange :: Event | r) i
onValueChange = addForeignPropHandler ET.change "value" readString

-- | Attaches an event handler which will produce an input when the seleced index of a
-- | `select` element changes.
onSelectedIndexChange :: forall r i. (Int -> Maybe i) -> IProp (selectedIndex :: Int, onChange :: Event | r) i
onSelectedIndexChange = addForeignPropHandler ET.change "selectedIndex" readInt

-- | Attaches an event handler which will fire on input.
onValueInput :: forall r i. (String -> Maybe i) -> IProp (value :: String, onInput :: Event | r) i
onValueInput = addForeignPropHandler ET.input "value" readString

-- | Attaches an event handler which will fire when a checkbox is checked or
-- | unchecked.
onChecked :: forall r i. (Boolean -> Maybe i) -> IProp (checked :: Boolean, onChange :: Event | r) i
onChecked = addForeignPropHandler ET.change "checked" readBoolean


Rename generate to randomOne

Rename generate to randomOne

-- | This module defines the random generator monad used by the `Test.QuickCheck`
-- | module, as well as helper functions for constructing random generators.
module Test.QuickCheck.Gen
  ( Gen
  , unGen
  , GenState
  , Size
  , repeatable
  , stateful
  , variant
  , suchThat
  , sized
  , resize
  , choose
  , chooseInt
  , oneOf
  , frequency
  , arrayOf
  , arrayOf1
  , listOf
  , vectorOf
  , elements
  , shuffle
  , runGen
  , evalGen
  , perturbGen
  , uniform
  , sample
  , randomSample
  , randomSample'
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Lazy (class Lazy)
import Control.Monad.Gen.Class (class MonadGen)
import Control.Monad.Rec.Class (class MonadRec, Step(..), tailRecM)
import Control.Monad.State (State, runState, evalState)
import Control.Monad.State.Class (modify, state)
import Data.Array ((!!), length, zip, sortBy)
import Data.Enum (class BoundedEnum, fromEnum, toEnum)
import Data.Foldable (fold)
import Data.Int (toNumber, floor)
import Data.List (List(..), toUnfoldable)
import Data.Maybe (fromMaybe, fromJust)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (unwrap)
import Data.NonEmpty (NonEmpty, (:|))
import Data.Tuple (Tuple(..), fst, snd)
import Effect (Effect)
import Math ((%))
import Partial.Unsafe (unsafePartial)
import Random.LCG (Seed, lcgPerturb, lcgM, lcgNext, unSeed, randomSeed)

-- | Tests are parameterized by the `Size` of the randomly-generated data,
-- | the meaning of which depends on the particular generator used.
type Size = Int

-- | The state of the random generator monad
type GenState = { newSeed :: Seed, size :: Size }

-- | The random generator monad
-- |
-- | `Gen` is a state monad which encodes a linear congruential generator.
newtype Gen a = Gen (State GenState a)

derive newtype instance functorGen :: Functor Gen
derive newtype instance applyGen :: Apply Gen
derive newtype instance applicativeGen :: Applicative Gen
derive newtype instance bindGen :: Bind Gen
derive newtype instance monadGen :: Monad Gen
derive newtype instance altGen :: Alt Gen
derive newtype instance monadRecGen :: MonadRec Gen
derive newtype instance lazyGen :: Lazy (Gen a)

instance monadGenGen :: MonadGen Gen where
  chooseInt = chooseInt
  chooseFloat = choose
  chooseBool = (_ < 0.5) <$> uniform
  resize f g = sized \s -> resize (f s) g
  sized = sized

-- | Exposes the underlying State implementation.
unGen :: forall a. Gen a -> State GenState a
unGen (Gen st) = st

-- | Create a random generator for a function type.
repeatable :: forall a b. (a -> Gen b) -> Gen (a -> b)
repeatable f = Gen $ state \s -> Tuple (\a -> fst (runGen (f a) s)) (s { newSeed = lcgNext s.newSeed })

-- | Create a random generator which uses the generator state explicitly.
stateful :: forall a. (GenState -> Gen a) -> Gen a
stateful f = Gen $ state \s -> runGen (f s) s

-- | Modify a random generator by setting a new random seed.
variant :: forall a. Seed -> Gen a -> Gen a
variant n g = Gen $ state \s -> runGen g s { newSeed = n }

-- | Ensure that a generator only produces values that match a predicate. If
-- | the predicate always returns false the generator will loop forever.
suchThat :: forall a. Gen a -> (a -> Boolean) -> Gen a
suchThat gen pred = tailRecM go unit
  where
  go :: Unit -> Gen (Step Unit a)
  go _ = do
    a <- gen
    pure if pred a then Done a else Loop unit

-- | Create a random generator which depends on the size parameter.
sized :: forall a. (Size -> Gen a) -> Gen a
sized f = stateful (\s -> f s.size)

-- | Modify a random generator by setting a new size parameter.
resize :: forall a. Size -> Gen a -> Gen a
resize sz g = Gen $ state \{ newSeed, size } ->
  (_ {size = size} ) <$> runGen g { newSeed, size: sz}

-- | Create a random generator which samples a range of `Number`s i
-- | with uniform probability.
choose :: Number -> Number -> Gen Number
choose a b = (*) (max' - min') >>> (+) min' <$> uniform where
  min' = min a b
  max' = max a b

-- | Create a random generator which chooses uniformly distributed
-- | integers from the closed interval `[a, b]`.
-- | Note that very large intervals will cause a loss of uniformity.
chooseInt :: Int -> Int -> Gen Int
chooseInt a b = if a <= b then chooseInt' a b else chooseInt' b a

-- guaranteed a <= b
chooseInt' :: Int -> Int -> Gen Int
chooseInt' a b = floor <<< clamp <$> choose32BitPosNumber
  where
    choose32BitPosNumber :: Gen Number
    choose32BitPosNumber =
      (+) <$> choose31BitPosNumber <*> (((*) 2.0) <$> choose31BitPosNumber)

    choose31BitPosNumber :: Gen Number
    choose31BitPosNumber = toNumber <$> lcgStep

    clamp :: Number -> Number
    clamp x = numA + (x % (numB - numA + one))

    numA = toNumber a
    numB = toNumber b

-- | Create a random generator which selects and executes a random generator from
-- | a non-empty array of random generators with uniform probability.
oneOf :: forall a. NonEmpty Array (Gen a) -> Gen a
oneOf (x :| xs) = do
  n <- chooseInt zero (length xs)
  if n < one then x else fromMaybe x (xs !! (n - one))

-- | Create a random generator which selects and executes a random generator from
-- | a non-empty, weighted list of random generators.
frequency :: forall a. NonEmpty List (Tuple Number (Gen a)) -> Gen a
frequency (x :| xs) = let
    xxs   = Cons x xs
    total = unwrap $ fold (map (Additive <<< fst) xxs :: List (Additive Number))
    pick n d Nil = d
    pick n d (Cons (Tuple k x') xs') = if n <= k then x' else pick (n - k) d xs'
  in do
    n <- choose zero total
    pick n (snd x) xxs

-- | Create a random generator which generates an array of random values.
arrayOf :: forall a. Gen a -> Gen (Array a)
arrayOf g = sized $ \n ->
  do k <- chooseInt zero n
     vectorOf k g

-- | Create a random generator which generates a non-empty array of random values.
arrayOf1 :: forall a. Gen a -> Gen (NonEmpty Array a)
arrayOf1 g = sized $ \n ->
  do k <- chooseInt zero n
     x <- g
     xs <- vectorOf (k - one) g
     pure $ x :| xs

-- | Create a random generator for a finite enumeration.
-- | `toEnum i` must be well-behaved:
-- | It must return a value wrapped in Just for all Ints between
-- | `fromEnum bottom` and `fromEnum top`.
enum :: forall a. BoundedEnum a => Gen a
enum = do
  i <- chooseInt (fromEnum (bottom :: a)) (fromEnum (top :: a))
  pure (unsafePartial $ fromJust $ toEnum i)

replicateMRec :: forall m a. MonadRec m => Int -> m a -> m (List a)
replicateMRec k _ | k <= 0 = pure Nil
replicateMRec k gen = tailRecM go (Tuple Nil k)
  where
  go :: (Tuple (List a) Int) -> m (Step (Tuple (List a) Int) (List a))
  go (Tuple acc 0) = pure $ Done acc
  go (Tuple acc n) = gen <#> \x -> Loop (Tuple (Cons x acc) (n - 1))

-- | Create a random generator which generates a list of random values of the specified size.
listOf :: forall a. Int -> Gen a -> Gen (List a)
listOf = replicateMRec

-- | Create a random generator which generates a vector of random values of a specified size.
vectorOf :: forall a. Int -> Gen a -> Gen (Array a)
vectorOf k g = toUnfoldable <$> listOf k g

-- | Create a random generator which selects a value from a non-empty array with
-- | uniform probability.
elements :: forall a. NonEmpty Array a -> Gen a
elements (x :| xs) = do
  n <- chooseInt zero (length xs)
  pure if n == zero then x else fromMaybe x (xs !! (n - one))

-- | Generate a random permutation of the given array
shuffle :: forall a. Array a -> Gen (Array a)
shuffle xs = do
  ns <- vectorOf (length xs) (chooseInt 0 top)
  pure (map snd (sortBy (comparing fst) (zip ns xs)))

-- | Run a random generator
runGen :: forall a. Gen a -> GenState -> Tuple a GenState
runGen = runState <<< unGen

-- | Run a random generator, keeping only the randomly-generated result
evalGen :: forall a. Gen a -> GenState -> a
evalGen = evalState <<< unGen

-- | Sample a random generator
sample :: forall a. Seed -> Size -> Gen a -> Array a
sample seed sz g = evalGen (vectorOf sz g) { newSeed: seed, size: sz }

-- | Generate a single value using a randomly generated seed.
randomOne :: forall a. Gen a -> Effect a
randomOne gen = do
  seed <- randomSeed
  pure $ evalGen gen { newSeed: seed, size: 10 }

-- | Sample a random generator, using a randomly generated seed
randomSample' :: forall a. Size -> Gen a -> Effect (Array a)
randomSample' n g = do
  seed <- randomSeed
  pure $ sample seed n g

-- | Get a random sample of 10 values
randomSample :: forall a. Gen a -> Effect (Array a)
randomSample = randomSample' 10

-- | A random generator which simply outputs the current seed
lcgStep :: Gen Int
lcgStep = Gen $ state f where
  f s = Tuple (unSeed s.newSeed) (s { newSeed = lcgNext s.newSeed })

-- | A random generator which approximates a uniform random variable on `[0, 1]`
uniform :: Gen Number
uniform = (\n -> toNumber n / toNumber lcgM) <$> lcgStep

foreign import float32ToInt32 :: Number -> Int

-- | Perturb a random generator by modifying the current seed
perturbGen :: forall a. Number -> Gen a -> Gen a
perturbGen n gen = Gen do
  void $ modify \s -> s { newSeed = lcgPerturb (toNumber (float32ToInt32 n)) s.newSeed }
  unGen gen

-- | This module defines the random generator monad used by the `Test.QuickCheck`
-- | module, as well as helper functions for constructing random generators.
module Test.QuickCheck.Gen
  ( Gen
  , unGen
  , GenState
  , Size
  , repeatable
  , stateful
  , variant
  , suchThat
  , sized
  , resize
  , choose
  , chooseInt
  , oneOf
  , frequency
  , arrayOf
  , arrayOf1
  , listOf
  , vectorOf
  , elements
  , shuffle
  , runGen
  , evalGen
  , perturbGen
  , uniform
  , sample
  , randomSample
  , randomSample'
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Lazy (class Lazy)
import Control.Monad.Gen.Class (class MonadGen)
import Control.Monad.Rec.Class (class MonadRec, Step(..), tailRecM)
import Control.Monad.State (State, runState, evalState)
import Control.Monad.State.Class (modify, state)
import Data.Array ((!!), length, zip, sortBy)
import Data.Enum (class BoundedEnum, fromEnum, toEnum)
import Data.Foldable (fold)
import Data.Int (toNumber, floor)
import Data.List (List(..), toUnfoldable)
import Data.Maybe (fromMaybe, fromJust)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (unwrap)
import Data.NonEmpty (NonEmpty, (:|))
import Data.Tuple (Tuple(..), fst, snd)
import Effect (Effect)
import Math ((%))
import Partial.Unsafe (unsafePartial)
import Random.LCG (Seed, lcgPerturb, lcgM, lcgNext, unSeed, randomSeed)

-- | Tests are parameterized by the `Size` of the randomly-generated data,
-- | the meaning of which depends on the particular generator used.
type Size = Int

-- | The state of the random generator monad
type GenState = { newSeed :: Seed, size :: Size }

-- | The random generator monad
-- |
-- | `Gen` is a state monad which encodes a linear congruential generator.
newtype Gen a = Gen (State GenState a)

derive newtype instance functorGen :: Functor Gen
derive newtype instance applyGen :: Apply Gen
derive newtype instance applicativeGen :: Applicative Gen
derive newtype instance bindGen :: Bind Gen
derive newtype instance monadGen :: Monad Gen
derive newtype instance altGen :: Alt Gen
derive newtype instance monadRecGen :: MonadRec Gen
derive newtype instance lazyGen :: Lazy (Gen a)

instance monadGenGen :: MonadGen Gen where
  chooseInt = chooseInt
  chooseFloat = choose
  chooseBool = (_ < 0.5) <$> uniform
  resize f g = sized \s -> resize (f s) g
  sized = sized

-- | Exposes the underlying State implementation.
unGen :: forall a. Gen a -> State GenState a
unGen (Gen st) = st

-- | Create a random generator for a function type.
repeatable :: forall a b. (a -> Gen b) -> Gen (a -> b)
repeatable f = Gen $ state \s -> Tuple (\a -> fst (runGen (f a) s)) (s { newSeed = lcgNext s.newSeed })

-- | Create a random generator which uses the generator state explicitly.
stateful :: forall a. (GenState -> Gen a) -> Gen a
stateful f = Gen $ state \s -> runGen (f s) s

-- | Modify a random generator by setting a new random seed.
variant :: forall a. Seed -> Gen a -> Gen a
variant n g = Gen $ state \s -> runGen g s { newSeed = n }

-- | Ensure that a generator only produces values that match a predicate. If
-- | the predicate always returns false the generator will loop forever.
suchThat :: forall a. Gen a -> (a -> Boolean) -> Gen a
suchThat gen pred = tailRecM go unit
  where
  go :: Unit -> Gen (Step Unit a)
  go _ = do
    a <- gen
    pure if pred a then Done a else Loop unit

-- | Create a random generator which depends on the size parameter.
sized :: forall a. (Size -> Gen a) -> Gen a
sized f = stateful (\s -> f s.size)

-- | Modify a random generator by setting a new size parameter.
resize :: forall a. Size -> Gen a -> Gen a
resize sz g = Gen $ state \{ newSeed, size } ->
  (_ {size = size} ) <$> runGen g { newSeed, size: sz}

-- | Create a random generator which samples a range of `Number`s i
-- | with uniform probability.
choose :: Number -> Number -> Gen Number
choose a b = (*) (max' - min') >>> (+) min' <$> uniform where
  min' = min a b
  max' = max a b

-- | Create a random generator which chooses uniformly distributed
-- | integers from the closed interval `[a, b]`.
-- | Note that very large intervals will cause a loss of uniformity.
chooseInt :: Int -> Int -> Gen Int
chooseInt a b = if a <= b then chooseInt' a b else chooseInt' b a

-- guaranteed a <= b
chooseInt' :: Int -> Int -> Gen Int
chooseInt' a b = floor <<< clamp <$> choose32BitPosNumber
  where
    choose32BitPosNumber :: Gen Number
    choose32BitPosNumber =
      (+) <$> choose31BitPosNumber <*> (((*) 2.0) <$> choose31BitPosNumber)

    choose31BitPosNumber :: Gen Number
    choose31BitPosNumber = toNumber <$> lcgStep

    clamp :: Number -> Number
    clamp x = numA + (x % (numB - numA + one))

    numA = toNumber a
    numB = toNumber b

-- | Create a random generator which selects and executes a random generator from
-- | a non-empty array of random generators with uniform probability.
oneOf :: forall a. NonEmpty Array (Gen a) -> Gen a
oneOf (x :| xs) = do
  n <- chooseInt zero (length xs)
  if n < one then x else fromMaybe x (xs !! (n - one))

-- | Create a random generator which selects and executes a random generator from
-- | a non-empty, weighted list of random generators.
frequency :: forall a. NonEmpty List (Tuple Number (Gen a)) -> Gen a
frequency (x :| xs) = let
    xxs   = Cons x xs
    total = unwrap $ fold (map (Additive <<< fst) xxs :: List (Additive Number))
    pick n d Nil = d
    pick n d (Cons (Tuple k x') xs') = if n <= k then x' else pick (n - k) d xs'
  in do
    n <- choose zero total
    pick n (snd x) xxs

-- | Create a random generator which generates an array of random values.
arrayOf :: forall a. Gen a -> Gen (Array a)
arrayOf g = sized $ \n ->
  do k <- chooseInt zero n
     vectorOf k g

-- | Create a random generator which generates a non-empty array of random values.
arrayOf1 :: forall a. Gen a -> Gen (NonEmpty Array a)
arrayOf1 g = sized $ \n ->
  do k <- chooseInt zero n
     x <- g
     xs <- vectorOf (k - one) g
     pure $ x :| xs

-- | Create a random generator for a finite enumeration.
-- | `toEnum i` must be well-behaved:
-- | It must return a value wrapped in Just for all Ints between
-- | `fromEnum bottom` and `fromEnum top`.
enum :: forall a. BoundedEnum a => Gen a
enum = do
  i <- chooseInt (fromEnum (bottom :: a)) (fromEnum (top :: a))
  pure (unsafePartial $ fromJust $ toEnum i)

replicateMRec :: forall m a. MonadRec m => Int -> m a -> m (List a)
replicateMRec k _ | k <= 0 = pure Nil
replicateMRec k gen = tailRecM go (Tuple Nil k)
  where
  go :: (Tuple (List a) Int) -> m (Step (Tuple (List a) Int) (List a))
  go (Tuple acc 0) = pure $ Done acc
  go (Tuple acc n) = gen <#> \x -> Loop (Tuple (Cons x acc) (n - 1))

-- | Create a random generator which generates a list of random values of the specified size.
listOf :: forall a. Int -> Gen a -> Gen (List a)
listOf = replicateMRec

-- | Create a random generator which generates a vector of random values of a specified size.
vectorOf :: forall a. Int -> Gen a -> Gen (Array a)
vectorOf k g = toUnfoldable <$> listOf k g

-- | Create a random generator which selects a value from a non-empty array with
-- | uniform probability.
elements :: forall a. NonEmpty Array a -> Gen a
elements (x :| xs) = do
  n <- chooseInt zero (length xs)
  pure if n == zero then x else fromMaybe x (xs !! (n - one))

-- | Generate a random permutation of the given array
shuffle :: forall a. Array a -> Gen (Array a)
shuffle xs = do
  ns <- vectorOf (length xs) (chooseInt 0 top)
  pure (map snd (sortBy (comparing fst) (zip ns xs)))

-- | Run a random generator
runGen :: forall a. Gen a -> GenState -> Tuple a GenState
runGen = runState <<< unGen

-- | Run a random generator, keeping only the randomly-generated result
evalGen :: forall a. Gen a -> GenState -> a
evalGen = evalState <<< unGen

-- | Sample a random generator
sample :: forall a. Seed -> Size -> Gen a -> Array a
sample seed sz g = evalGen (vectorOf sz g) { newSeed: seed, size: sz }

-- | Generate a single value using a randomly generated seed.
generate :: forall a. Gen a -> Effect a
generate gen = do
  seed <- randomSeed
  pure $ evalGen gen { newSeed: seed, size: 10 }

-- | Sample a random generator, using a randomly generated seed
randomSample' :: forall a. Size -> Gen a -> Effect (Array a)
randomSample' n g = do
  seed <- randomSeed
  pure $ sample seed n g

-- | Get a random sample of 10 values
randomSample :: forall a. Gen a -> Effect (Array a)
randomSample = randomSample' 10

-- | A random generator which simply outputs the current seed
lcgStep :: Gen Int
lcgStep = Gen $ state f where
  f s = Tuple (unSeed s.newSeed) (s { newSeed = lcgNext s.newSeed })

-- | A random generator which approximates a uniform random variable on `[0, 1]`
uniform :: Gen Number
uniform = (\n -> toNumber n / toNumber lcgM) <$> lcgStep

foreign import float32ToInt32 :: Number -> Int

-- | Perturb a random generator by modifying the current seed
perturbGen :: forall a. Number -> Gen a -> Gen a
perturbGen n gen = Gen do
  void $ modify \s -> s { newSeed = lcgPerturb (toNumber (float32ToInt32 n)) s.newSeed }
  unGen gen


Updated logic for moving a piece to also work when jumping over the other player's piece

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.ST
import Control.MonadPlus
import Data.Array
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types
import Data.DOM.Simple.Unsafe.Events
import Data.DOM.Simple.Window
import Data.Int
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Tuple
import DOM
import Graphics.Canvas
import Math (abs, max, pi)
import Prelude

import Checkers.Constants
import Checkers.Types

createPiece :: Player -> Piece
createPiece player =
  { player: player,
    color:  if player == playerOne then colorPlayerOne else colorPlayerTwo,
    king:   false }

createGrid :: Pixel -> Int -> Int -> Int -> Grid
createGrid offset width height layers = { width: width, height: height, squares: squares }
  where
    squares = do
      x <- 0 .. (width - 1)
      y <- 0 .. (height - 1)
      let rx = (toNumber x) * renderSize
          ry = (toNumber y) * renderSize
          isPieceSquare = ((even x) && (odd y)) || ((even y) && (odd x))
          color = if isPieceSquare then colorSquareOne else colorSquareTwo
          piece = if isPieceSquare && (y < layers)
                  then Just (createPiece playerOne)
                  else if isPieceSquare && (y >= height - layers)
                       then Just (createPiece playerTwo)
                       else Nothing
      return { offset:     offset,
               coordinate: (Tuple x y),
               render:     (Tuple rx ry),
               color:      color,
               piece:      piece }

createState :: Pixel -> Int -> Int -> Int -> State
createState offset width height layers =
  { grid:                  createGrid offset width height layers,
    currentPlayer:         playerOne,
    selectedCoordinate:    Nothing,
    highlightedCoordinate: Nothing }

setPiece :: Maybe Piece -> Square -> Square
setPiece piece square = square { piece = piece }

isValid :: Grid -> Coordinate -> Boolean
isValid grid (Tuple x y) = x >= 0 && x < grid.width && y >= 0 && y < grid.height

hasPlayer :: Player -> Piece -> Boolean
hasPlayer player piece = piece.player == player

hasCoordinate :: Coordinate -> Square -> Boolean
hasCoordinate coordinate square = coordinate == square.coordinate

getSquare :: Array Square -> Coordinate -> Maybe Square
getSquare squares coordinate =
  fromMaybe Nothing $ (squares !!) <$> (findIndex (hasCoordinate coordinate) squares)

hasPlayerPiece :: Array Square -> Coordinate -> Player -> Boolean
hasPlayerPiece squares coordinate player =
  case getSquare squares coordinate of
    Nothing -> false
    Just square -> fromMaybe false $ (hasPlayer player) <$> square.piece

hasPiece :: Array Square -> Coordinate -> Boolean
hasPiece squares coordinate =
  hasPlayerPiece squares coordinate playerOne ||
  hasPlayerPiece squares coordinate playerTwo

isJumpMove :: Coordinate -> Coordinate -> Maybe Coordinate
isJumpMove (Tuple x1 y1) (Tuple x2 y2) =
  if abs (toNumber (y1 - y2)) == 2.0
  then
    let n1 = floor (max (toNumber x1) (toNumber x2) - 1.0)
        n2 = floor (max (toNumber y1) (toNumber y2) - 1.0)
    in Just (Tuple n1 n2)
  else Nothing

getDiagonalSquares :: Coordinate -> Array Coordinate
getDiagonalSquares (Tuple x y) = do
  i <- -2 : (-1 : (1 : (singleton 2)))
  j <- -2 : (-1 : (1 : (singleton 2)))
  return (Tuple (x + i) (y + j))

isOnSquare :: Pixel -> Square -> Boolean
isOnSquare (Tuple x y) square =
  let px = square.render + square.offset
      px' = px + (Tuple renderSize renderSize)
  in fst px < x && x < fst px' && snd px < y && y < snd px'

isOnActiveSquare :: Grid -> Player -> Pixel -> Square -> Boolean
isOnActiveSquare grid player pixel square =
  let moves = getMoves grid player square.coordinate
  in isOnSquare pixel square && not (null moves)

getActiveCoordinate :: Grid -> Player -> Pixel -> Maybe Coordinate
getActiveCoordinate grid player pixel =
  case findIndex (isOnActiveSquare grid player pixel) grid.squares of
    Just index -> _.coordinate <$> grid.squares !! index
    Nothing    -> Nothing

findCoordinate :: Grid -> Player -> Pixel -> Maybe Coordinate
findCoordinate grid player pixel =
  case findIndex (isOnSquare pixel) grid.squares of
    Just index -> _.coordinate <$> grid.squares !! index
    Nothing    -> Nothing

getHighlightCoordinate :: State -> Pixel -> Maybe Coordinate
getHighlightCoordinate state pixel =
  case findCoordinate state.grid state.currentPlayer pixel of
    Nothing -> Nothing
    Just to -> do
      case state.selectedCoordinate of
        Nothing -> getActiveCoordinate state.grid state.currentPlayer pixel
        Just from ->
          if isValidMove state.grid state.currentPlayer from to
          then Just to
          else getActiveCoordinate state.grid state.currentPlayer pixel

isValidMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isValidMove grid player from to =
  let d1 = from + Tuple   1    1
      d2 = from + Tuple (-1)   1
      d3 = from + Tuple   1  (-1)
      d4 = from + Tuple (-1) (-1)
      d5 = from + Tuple   2    2
      d6 = from + Tuple (-2)   2
      d7 = from + Tuple   2  (-2)
      d8 = from + Tuple (-2) (-2)
      p1 = player == playerOne && ((d1 == to) || (d2 == to) ||
                                   (d5 == to && hasPlayerPiece grid.squares d1 playerTwo) ||
                                   (d6 == to && hasPlayerPiece grid.squares d2 playerTwo))
      p2 = player == playerTwo && ((d3 == to) || (d4 == to) ||
                                   (d7 == to && hasPlayerPiece grid.squares d3 playerOne) ||
                                   (d8 == to && hasPlayerPiece grid.squares d4 playerOne))
  in isValid grid to && not hasPiece grid.squares to && (p1 || p2)

getMoves :: Grid -> Player -> Coordinate -> Array Coordinate
getMoves grid player coordinate = do
  guard $ hasPlayerPiece grid.squares coordinate player
  potential <- getDiagonalSquares coordinate
  guard $ isValidMove grid player coordinate potential
  return potential

alterPiece :: Maybe Piece -> Coordinate -> Grid -> Grid
alterPiece piece coordinate grid = grid { squares = newSquares }
  where
    index = fromJust (findIndex (hasCoordinate coordinate) grid.squares)
    newSquares = fromJust (modifyAt index (setPiece piece) grid.squares)

removePiece :: Coordinate -> Grid -> Grid
removePiece = alterPiece Nothing

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid =
  let fromIndex = fromJust (findIndex (hasCoordinate from) grid.squares)
      originalSquare = fromJust (grid.squares !! fromIndex)
  in
    case isJumpMove from to of
      Nothing -> removePiece from (alterPiece originalSquare.piece to grid)
      Just middle -> removePiece middle (removePiece from (alterPiece originalSquare.piece to grid))

otherPlayer :: Player -> Player
otherPlayer (Player 1) = Player 2
otherPlayer (Player 2) = Player 1
otherPlayer _          = Player 1

renderSquare :: forall e.
                  Context2D ->
                  Unit ->
                  Square ->
                  Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderSquare ctx _ square = do
  setFillStyle square.color ctx
  fillRect ctx { x: fst square.render,
                 y: snd square.render,
                 w: renderSize,
                 h: renderSize }
  return unit

renderPiece :: forall e.
                 State ->
                 Context2D ->
                 Unit ->
                 Square ->
                 Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderPiece state ctx _ square = do
  case square.piece of
    Just piece -> do
      setFillStyle piece.color ctx
      let arcPiece = { x: fst square.render + 0.5 * renderSize,
                       y: snd square.render + 0.5 * renderSize,
                       r: (renderSize / 2.0) * 0.8,
                       start: 0.0,
                       end: 2.0 * pi }
      fillPath ctx $ arc ctx arcPiece
      return unit
    _ -> return unit

renderBorder :: forall e. Context2D -> Grid -> Eff (canvas :: Canvas | e) Unit
renderBorder ctx grid = do
  let border = { x: 0.5,
                 y: 0.5,
                 w: (toNumber grid.width) * renderSize - 0.5,
                 h: (toNumber grid.height) * renderSize - 0.5 }
  setStrokeStyle colorBorder ctx
  strokeRect ctx border
  return unit

renderHighlight :: forall e.
                     Context2D ->
                     Array Square ->
                     Maybe Coordinate ->
                     Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderHighlight ctx squares selection = do
  case selection of
    Nothing -> return unit
    Just coordinate -> do
      let square = fromJust (getSquare squares coordinate)
          arcPiece = { x:     fst square.render + 0.5 * renderSize,
                       y:     snd square.render + 0.5 * renderSize,
                       r:     (renderSize / 2.0) * 0.8,
                       start: 0.0,
                       end:   2.0 * pi }
      setLineWidth highlightWidth ctx
      strokePath ctx $ arc ctx arcPiece
      return unit

render :: forall s e.
            Context2D ->
            STRef s State ->
            Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
render ctx st = do
  state <- readSTRef st
  withContext ctx $ do
    foldM (renderSquare ctx) unit state.grid.squares
  withContext ctx $ do
    foldM (renderPiece state ctx) unit state.grid.squares
  withContext ctx $ do
    renderBorder ctx state.grid
  withContext ctx $ do
    renderHighlight ctx state.grid.squares state.selectedCoordinate
  withContext ctx $ do
    renderHighlight ctx state.grid.squares state.highlightedCoordinate
  return unit

renderPage :: forall s e.
                STRef s State ->
                Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
renderPage st = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      setCanvasDimensions renderDimension canvas
      ctx <- getContext2D canvas
      render ctx st
      return unit
    _ -> return unit
  return unit

moveListener :: forall s e.
                  STRef s State ->
                  DOMEvent ->
                  Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
moveListener st e = do
  ux <- unsafeEventNumberProp "clientX" e
  uy <- unsafeEventNumberProp "clientY" e
  state <- readSTRef st
  let pixel = (Tuple (toNumber ux) (toNumber uy))
      highlightedCoordinate = getHighlightCoordinate state pixel
  writeSTRef st $ state { highlightedCoordinate = highlightedCoordinate }
  renderPage st
  return unit

clickListener :: forall s e.
                   STRef s State ->
                   DOMEvent ->
                   Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
clickListener st e = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      state <- readSTRef st
      ux <- unsafeEventNumberProp "clientX" e
      uy <- unsafeEventNumberProp "clientY" e
      let pixel = Tuple (toNumber ux) (toNumber uy)
          toCoordinate = getHighlightCoordinate state pixel
      case toCoordinate of
        Nothing -> return unit
        Just to -> do
          case state.selectedCoordinate of
            Nothing -> do
              writeSTRef st $ state { selectedCoordinate = Just to }
              renderPage st
              return unit
            Just from -> do
              case isValidMove state.grid state.currentPlayer from to of
                false -> do
                  writeSTRef st $ state { selectedCoordinate = if to == from
                                                               then Nothing
                                                               else Just to }
                  renderPage st
                  return unit
                true -> do
                  writeSTRef st $ state { highlightedCoordinate = Nothing,
                                          selectedCoordinate = Nothing,
                                          grid = movePiece from to state.grid,
                                          currentPlayer = otherPlayer state.currentPlayer }
                  renderPage st
                  return unit
    _ -> return unit
  return unit

main :: forall s e. Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
main = do
  doc <- document globalWindow
  mcanvas <- getElementById "canvas" doc
  case mcanvas of
    Just canvas -> do
      x <- offsetLeft canvas
      y <- offsetTop canvas
      let offset = (Tuple (toNumber x) (toNumber y))
      st <- newSTRef (createState offset defaultWidth defaultHeight layerCount)
      addMouseEventListener MouseMoveEvent (moveListener st) canvas
      addMouseEventListener MouseClickEvent (clickListener st) canvas
      renderPage st
      return unit
    _ -> return unit

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.ST
import Control.MonadPlus
import Data.Array
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types
import Data.DOM.Simple.Unsafe.Events
import Data.DOM.Simple.Window
import Data.Int
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Tuple
import DOM
import Graphics.Canvas
import Math (pi)
import Prelude

import Checkers.Constants
import Checkers.Types

createPiece :: Player -> Piece
createPiece player =
  { player: player,
    color:  if player == playerOne then colorPlayerOne else colorPlayerTwo,
    king:   false }

createGrid :: Pixel -> Int -> Int -> Int -> Grid
createGrid offset width height layers = { width: width, height: height, squares: squares }
  where
    squares = do
      x <- 0 .. (width - 1)
      y <- 0 .. (height - 1)
      let rx = (toNumber x) * renderSize
          ry = (toNumber y) * renderSize
          isPieceSquare = ((even x) && (odd y)) || ((even y) && (odd x))
          color = if isPieceSquare then colorSquareOne else colorSquareTwo
          piece = if isPieceSquare && (y < layers)
                  then Just (createPiece playerOne)
                  else if isPieceSquare && (y >= height - layers)
                       then Just (createPiece playerTwo)
                       else Nothing
      return { offset:     offset,
               coordinate: (Tuple x y),
               render:     (Tuple rx ry),
               color:      color,
               piece:      piece }

createState :: Pixel -> Int -> Int -> Int -> State
createState offset width height layers =
  { grid:                  createGrid offset width height layers,
    currentPlayer:         playerOne,
    selectedCoordinate:    Nothing,
    highlightedCoordinate: Nothing }

setPiece :: Maybe Piece -> Square -> Square
setPiece piece square = square { piece = piece }

isValid :: Grid -> Coordinate -> Boolean
isValid grid (Tuple x y) = x >= 0 && x < grid.width && y >= 0 && y < grid.height

hasPlayer :: Player -> Piece -> Boolean
hasPlayer player piece = piece.player == player

hasCoordinate :: Coordinate -> Square -> Boolean
hasCoordinate coordinate square = coordinate == square.coordinate

getSquare :: Array Square -> Coordinate -> Maybe Square
getSquare squares coordinate =
  fromMaybe Nothing $ (squares !!) <$> (findIndex (hasCoordinate coordinate) squares)

hasPlayerPiece :: Array Square -> Coordinate -> Player -> Boolean
hasPlayerPiece squares coordinate player =
  case getSquare squares coordinate of
    Nothing -> false
    Just square -> fromMaybe false $ (hasPlayer player) <$> square.piece

hasPiece :: Array Square -> Coordinate -> Boolean
hasPiece squares coordinate =
  hasPlayerPiece squares coordinate playerOne ||
  hasPlayerPiece squares coordinate playerTwo

getDiagonalSquares :: Coordinate -> Array Coordinate
getDiagonalSquares (Tuple x y) = do
  i <- -2 : (-1 : (1 : (singleton 2)))
  j <- -2 : (-1 : (1 : (singleton 2)))
  return (Tuple (x + i) (y + j))

isOnSquare :: Pixel -> Square -> Boolean
isOnSquare (Tuple x y) square =
  let px = square.render + square.offset
      px' = px + (Tuple renderSize renderSize)
  in fst px < x && x < fst px' && snd px < y && y < snd px'

isOnActiveSquare :: Grid -> Player -> Pixel -> Square -> Boolean
isOnActiveSquare grid player pixel square =
  let moves = getMoves grid player square.coordinate
  in isOnSquare pixel square && not (null moves)

getActiveCoordinate :: Grid -> Player -> Pixel -> Maybe Coordinate
getActiveCoordinate grid player pixel =
  case findIndex (isOnActiveSquare grid player pixel) grid.squares of
    Just index -> _.coordinate <$> grid.squares !! index
    Nothing    -> Nothing

findCoordinate :: Grid -> Player -> Pixel -> Maybe Coordinate
findCoordinate grid player pixel =
  case findIndex (isOnSquare pixel) grid.squares of
    Just index -> _.coordinate <$> grid.squares !! index
    Nothing    -> Nothing

getHighlightCoordinate :: State -> Pixel -> Maybe Coordinate
getHighlightCoordinate state pixel =
  case findCoordinate state.grid state.currentPlayer pixel of
    Nothing -> Nothing
    Just to -> do
      case state.selectedCoordinate of
        Nothing -> getActiveCoordinate state.grid state.currentPlayer pixel
        Just from ->
          if isValidMove state.grid state.currentPlayer from to
          then Just to
          else getActiveCoordinate state.grid state.currentPlayer pixel

isValidMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isValidMove grid player from to =
  let d1 = from + Tuple   1    1
      d2 = from + Tuple (-1)   1
      d3 = from + Tuple   1  (-1)
      d4 = from + Tuple (-1) (-1)
      d5 = from + Tuple   2    2
      d6 = from + Tuple (-2)   2
      d7 = from + Tuple   2  (-2)
      d8 = from + Tuple (-2) (-2)
      p1 = player == playerOne && ((d1 == to) || (d2 == to) ||
                                   (d5 == to && hasPlayerPiece grid.squares d1 playerTwo) ||
                                   (d6 == to && hasPlayerPiece grid.squares d2 playerTwo))
      p2 = player == playerTwo && ((d3 == to) || (d4 == to) ||
                                   (d7 == to && hasPlayerPiece grid.squares d3 playerOne) ||
                                   (d8 == to && hasPlayerPiece grid.squares d4 playerOne))
  in isValid grid to && not hasPiece grid.squares to && (p1 || p2)

getMoves :: Grid -> Player -> Coordinate -> Array Coordinate
getMoves grid player coordinate = do
  guard $ hasPlayerPiece grid.squares coordinate player
  potential <- getDiagonalSquares coordinate
  guard $ isValidMove grid player coordinate potential
  return potential

alterPiece :: Maybe Piece -> Coordinate -> Grid -> Grid
alterPiece piece coordinate grid = grid { squares = newSquares }
  where
    index = fromJust (findIndex (hasCoordinate coordinate) grid.squares)
    newSquares = fromJust (modifyAt index (setPiece piece) grid.squares)

removePiece :: Coordinate -> Grid -> Grid
removePiece = alterPiece Nothing

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid = removePiece from (alterPiece originalSquare.piece to grid)
    where
      fromIndex = fromJust (findIndex (hasCoordinate from) grid.squares)
      originalSquare = fromJust (grid.squares !! fromIndex)

otherPlayer :: Player -> Player
otherPlayer (Player 1) = Player 2
otherPlayer (Player 2) = Player 1
otherPlayer _          = Player 1

renderSquare :: forall e.
                  Context2D ->
                  Unit ->
                  Square ->
                  Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderSquare ctx _ square = do
  setFillStyle square.color ctx
  fillRect ctx { x: fst square.render,
                 y: snd square.render,
                 w: renderSize,
                 h: renderSize }
  return unit

renderPiece :: forall e.
                 State ->
                 Context2D ->
                 Unit ->
                 Square ->
                 Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderPiece state ctx _ square = do
  case square.piece of
    Just piece -> do
      setFillStyle piece.color ctx
      let arcPiece = { x: fst square.render + 0.5 * renderSize,
                       y: snd square.render + 0.5 * renderSize,
                       r: (renderSize / 2.0) * 0.8,
                       start: 0.0,
                       end: 2.0 * pi }
      fillPath ctx $ arc ctx arcPiece
      return unit
    _ -> return unit

renderBorder :: forall e. Context2D -> Grid -> Eff (canvas :: Canvas | e) Unit
renderBorder ctx grid = do
  let border = { x: 0.5,
                 y: 0.5,
                 w: (toNumber grid.width) * renderSize - 0.5,
                 h: (toNumber grid.height) * renderSize - 0.5 }
  setStrokeStyle colorBorder ctx
  strokeRect ctx border
  return unit

renderHighlight :: forall e.
                     Context2D ->
                     Array Square ->
                     Maybe Coordinate ->
                     Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderHighlight ctx squares selection = do
  case selection of
    Nothing -> return unit
    Just coordinate -> do
      let square = fromJust (getSquare squares coordinate)
          arcPiece = { x:     fst square.render + 0.5 * renderSize,
                       y:     snd square.render + 0.5 * renderSize,
                       r:     (renderSize / 2.0) * 0.8,
                       start: 0.0,
                       end:   2.0 * pi }
      setLineWidth highlightWidth ctx
      strokePath ctx $ arc ctx arcPiece
      return unit

render :: forall s e.
            Context2D ->
            STRef s State ->
            Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
render ctx st = do
  state <- readSTRef st
  withContext ctx $ do
    foldM (renderSquare ctx) unit state.grid.squares
  withContext ctx $ do
    foldM (renderPiece state ctx) unit state.grid.squares
  withContext ctx $ do
    renderBorder ctx state.grid
  withContext ctx $ do
    renderHighlight ctx state.grid.squares state.selectedCoordinate
  withContext ctx $ do
    renderHighlight ctx state.grid.squares state.highlightedCoordinate
  return unit

renderPage :: forall s e.
                STRef s State ->
                Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
renderPage st = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      setCanvasDimensions renderDimension canvas
      ctx <- getContext2D canvas
      render ctx st
      return unit
    _ -> return unit
  return unit

moveListener :: forall s e.
                  STRef s State ->
                  DOMEvent ->
                  Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
moveListener st e = do
  ux <- unsafeEventNumberProp "clientX" e
  uy <- unsafeEventNumberProp "clientY" e
  state <- readSTRef st
  let pixel = (Tuple (toNumber ux) (toNumber uy))
      highlightedCoordinate = getHighlightCoordinate state pixel
  writeSTRef st $ state { highlightedCoordinate = highlightedCoordinate }
  renderPage st
  return unit

clickListener :: forall s e.
                   STRef s State ->
                   DOMEvent ->
                   Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
clickListener st e = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      state <- readSTRef st
      ux <- unsafeEventNumberProp "clientX" e
      uy <- unsafeEventNumberProp "clientY" e
      let pixel = Tuple (toNumber ux) (toNumber uy)
          toCoordinate = getHighlightCoordinate state pixel
      case toCoordinate of
        Nothing -> return unit
        Just to -> do
          case state.selectedCoordinate of
            Nothing -> do
              writeSTRef st $ state { selectedCoordinate = Just to }
              renderPage st
              return unit
            Just from -> do
              case isValidMove state.grid state.currentPlayer from to of
                false -> do
                  writeSTRef st $ state { selectedCoordinate = if to == from
                                                               then Nothing
                                                               else Just to }
                  renderPage st
                  return unit
                true -> do
                  writeSTRef st $ state { highlightedCoordinate = Nothing,
                                          selectedCoordinate = Nothing,
                                          grid = movePiece from to state.grid,
                                          currentPlayer = otherPlayer state.currentPlayer }
                  renderPage st
                  return unit
    _ -> return unit
  return unit

main :: forall s e. Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
main = do
  doc <- document globalWindow
  mcanvas <- getElementById "canvas" doc
  case mcanvas of
    Just canvas -> do
      x <- offsetLeft canvas
      y <- offsetTop canvas
      let offset = (Tuple (toNumber x) (toNumber y))
      st <- newSTRef (createState offset defaultWidth defaultHeight layerCount)
      addMouseEventListener MouseMoveEvent (moveListener st) canvas
      addMouseEventListener MouseClickEvent (clickListener st) canvas
      renderPage st
      return unit
    _ -> return unit


Document pitfalls of Nullable, fixes #7, resolves #2

-- | This module defines types and functions for working with nullable types
-- | using the FFI.

module Data.Nullable
  ( Nullable
  , null
  , notNull
  , toMaybe
  , toNullable
  ) where

import Prelude

import Data.Eq (class Eq1)
import Data.Function (on)
import Data.Function.Uncurried (Fn3, runFn3)
import Data.Maybe (Maybe(..), maybe)
import Data.Ord (class Ord1)

-- | A nullable type. This type constructor is intended to be used for
-- | interoperating with JavaScript functions which accept or return null
-- | values.
-- |
-- | The runtime representation of `Nullable T` is the same as that of `T`,
-- | except that it may also be `null`. For example, the JavaScript values
-- | `null`, `[]`, and `[1,2,3]` may all be given the type
-- | `Nullable (Array Int)`. Similarly, the JavaScript values `[]`, `[null]`,
-- | and `[1,2,null,3]` may all be given the type `Array (Nullable Int)`.
-- |
-- | There is one pitfall with `Nullable`, which is that values of the type
-- | `Nullable T` will not function as you might expect if the type `T` happens
-- | to itself permit `null` as a valid runtime representation.
-- |
-- | In particular, values of the type `Nullable (Nullable T)` will ‘collapse’,
-- | in the sense that the PureScript expressions `notNull null` and `null`
-- | will both leave you with a value whose runtime representation is just
-- | `null`. Therefore it is important to avoid using `Nullable T` in
-- | situations where `T` itself can take `null` as a runtime representation.
-- | If in doubt, use `Maybe` instead.
-- |
-- | `Nullable` does not permit lawful `Functor`, `Applicative`, or `Monad`
-- | instances as a result of this pitfall, which is why these instances are
-- | not provided.
foreign import data Nullable :: Type -> Type

-- | The null value.
foreign import null :: forall a. Nullable a

foreign import nullable :: forall a r. Fn3 (Nullable a) r (a -> r) r

-- | Wrap a non-null value.
foreign import notNull :: forall a. a -> Nullable a

-- | Takes `Nothing` to `null`, and `Just a` to `a`.
toNullable :: forall a. Maybe a -> Nullable a
toNullable = maybe null notNull

-- | Represent `null` using `Maybe a` as `Nothing`. Note that this function
-- | can violate parametricity, as it inspects the runtime representation of
-- | its argument (see the warning about the pitfall of `Nullable` above).
toMaybe :: forall a. Nullable a -> Maybe a
toMaybe n = runFn3 nullable n Nothing Just

instance showNullable :: Show a => Show (Nullable a) where
  show = maybe "null" show <<< toMaybe

instance eqNullable :: Eq a => Eq (Nullable a) where
  eq = eq `on` toMaybe

instance eq1Nullable :: Eq1 Nullable where
  eq1 = eq

instance ordNullable :: Ord a => Ord (Nullable a) where
  compare = compare `on` toMaybe

instance ord1Nullable :: Ord1 Nullable where
  compare1 = compare

-- | This module defines types and functions for working with nullable types
-- | using the FFI.

module Data.Nullable
  ( Nullable
  , null
  , notNull
  , toMaybe
  , toNullable
  ) where

import Prelude

import Data.Eq (class Eq1)
import Data.Function (on)
import Data.Function.Uncurried (Fn3, runFn3)
import Data.Maybe (Maybe(..), maybe)
import Data.Ord (class Ord1)

-- | A nullable type.
-- |
-- | This type constructor may be useful when interoperating with JavaScript functions
-- | which accept or return null values.
foreign import data Nullable :: Type -> Type

-- | The null value.
foreign import null :: forall a. Nullable a

foreign import nullable :: forall a r. Fn3 (Nullable a) r (a -> r) r

-- | Wrap a non-null value.
foreign import notNull :: forall a. a -> Nullable a

-- | Takes `Nothing` to `null`, and `Just a` to `a`.
toNullable :: forall a. Maybe a -> Nullable a
toNullable = maybe null notNull

-- | Represent `null` using `Maybe a` as `Nothing`.
toMaybe :: forall a. Nullable a -> Maybe a
toMaybe n = runFn3 nullable n Nothing Just

instance showNullable :: Show a => Show (Nullable a) where
  show = maybe "null" show <<< toMaybe

instance eqNullable :: Eq a => Eq (Nullable a) where
  eq = eq `on` toMaybe

instance eq1Nullable :: Eq1 Nullable where
  eq1 = eq

instance ordNullable :: Ord a => Ord (Nullable a) where
  compare = compare `on` toMaybe

instance ord1Nullable :: Ord1 Nullable where
  compare1 = compare