Test array replicate

Test array replicate

module Test.Data.Array (testArray) where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log, CONSOLE)

import Data.Array (range, replicate, foldM, unzip, zip, zipWithA, zipWith, intersectBy, intersect, (\\), deleteBy, delete, unionBy, union, nubBy, nub, groupBy, group', group, span, dropWhile, drop, takeWhile, take, sortBy, sort, catMaybes, mapMaybe, mapWithIndex, filterM, filter, concat, concatMap, reverse, alterAt, modifyAt, updateAt, deleteAt, insertAt, findLastIndex, findIndex, elemLastIndex, elemIndex, (!!), uncons, init, tail, last, head, insertBy, insert, snoc, (:), length, null, singleton, fromFoldable)
import Data.Foldable (for_, foldMapDefaultR, class Foldable, all)
import Data.Maybe (Maybe(..), isNothing, fromJust)
import Data.Tuple (Tuple(..))
import Data.Unfoldable (replicateA)

import Partial.Unsafe (unsafePartial)

import Test.Assert (assert, ASSERT)

testArray :: forall eff. Eff (console :: CONSOLE, assert :: ASSERT | eff) Unit
testArray = do

  log "singleton should construct an array with a single value"
  assert $ singleton 1 == [1]
  assert $ singleton "foo" == ["foo"]
  assert $ singleton nil == [[]]

  log "range should create an inclusive array of integers for the specified start and end"
  assert $ (range 0 5) == [0, 1, 2, 3, 4, 5]
  assert $ (range 2 (-3)) == [2, 1, 0, -1, -2, -3]

  log "replicate should produce an array containg an item a specified number of times"
  assert $ replicate 3 true == [true, true, true]
  assert $ replicate 1 "foo" == ["foo"]
  assert $ replicate 0 "foo" == []
  assert $ replicate (-1) "foo" == []

  log "replicateA should perform the monadic action the correct number of times"
  assert $ replicateA 3 (Just 1) == Just [1, 1, 1]
  assert $ replicateA 1 (Just 1) == Just [1]
  assert $ replicateA 0 (Just 1) == Just []
  assert $ replicateA (-1) (Just 1) == Just []

  log "replicateA should be stack safe"
  for_ [1, 1000, 2000, 20000, 50000] \n -> do
    assert $ replicateA n (Just unit) == Just (replicate n unit :: Array Unit)

  -- some
  -- many

  log "null should return false for non-empty arrays"
  assert $ null [1] == false
  assert $ null [1, 2, 3] == false

  log "null should return true for an empty array"
  assert $ null nil == true

  log "length should return the number of items in an array"
  assert $ length nil == 0
  assert $ length [1] == 1
  assert $ length [1, 2, 3, 4, 5] == 5

  log "cons should add an item to the start of an array"
  assert $ 4 : [1, 2, 3] == [4, 1, 2, 3]
  assert $ 1 : nil == [1]

  log "snoc should add an item to the end of an array"
  assert $ [1, 2, 3] `snoc` 4 == [1, 2, 3, 4]
  assert $ nil `snoc` 1 == [1]

  log "insert should add an item at the appropriate place in a sorted array"
  assert $ insert 1.5 [1.0, 2.0, 3.0] == [1.0, 1.5, 2.0, 3.0]
  assert $ insert 4 [1, 2, 3] == [1, 2, 3, 4]
  assert $ insert 0 [1, 2, 3] == [0, 1, 2, 3]

  log "insertBy should add an item at the appropriate place in a sorted array using the specified comparison"
  assert $ insertBy (flip compare) 1.5 [1.0, 2.0, 3.0] == [1.0, 2.0, 3.0, 1.5]
  assert $ insertBy (flip compare) 4 [1, 2, 3] == [4, 1, 2, 3]
  assert $ insertBy (flip compare) 0 [1, 2, 3] == [1, 2, 3, 0]

  log "head should return a Just-wrapped first value of a non-empty array"
  assert $ head ["foo", "bar"] == Just "foo"

  log "head should return Nothing for an empty array"
  assert $ head nil == Nothing

  log "last should return a Just-wrapped last value of a non-empty array"
  assert $ last ["foo", "bar"] == Just "bar"

  log "last should return Nothing for an empty array"
  assert $ last nil == Nothing

  log "tail should return a Just-wrapped array containing all the items in an array apart from the first for a non-empty array"
  assert $ tail ["foo", "bar", "baz"] == Just ["bar", "baz"]

  log "tail should return Nothing for an empty array"
  assert $ tail nil == Nothing

  log "init should return a Just-wrapped array containing all the items in an array apart from the first for a non-empty array"
  assert $ init ["foo", "bar", "baz"] == Just ["foo", "bar"]

  log "init should return Nothing for an empty array"
  assert $ init nil == Nothing

  log "uncons should return nothing when used on an empty array"
  assert $ isNothing (uncons nil)

  log "uncons should split an array into a head and tail record when there is at least one item"
  let u1 = uncons [1]
  assert $ (unsafePartial $ fromJust u1).head == 1
  assert $ (unsafePartial $ fromJust u1).tail == []
  let u2 = uncons [1, 2, 3]
  assert $ (unsafePartial $ fromJust u2).head == 1
  assert $ (unsafePartial $ fromJust u2).tail == [2, 3]

  log "(!!) should return Just x when the index is within the bounds of the array"
  assert $ [1, 2, 3] !! 0 == (Just 1)
  assert $ [1, 2, 3] !! 1 == (Just 2)
  assert $ [1, 2, 3] !! 2 == (Just 3)

  log "(!!) should return Nothing when the index is outside of the bounds of the array"
  assert $ [1, 2, 3] !! 6 == Nothing
  assert $ [1, 2, 3] !! (-1) == Nothing

  log "elemIndex should return the index of an item that a predicate returns true for in an array"
  assert $ (elemIndex 1 [1, 2, 1]) == Just 0
  assert $ (elemIndex 4 [1, 2, 1]) == Nothing

  log "elemLastIndex should return the last index of an item in an array"
  assert $ (elemLastIndex 1 [1, 2, 1]) == Just 2
  assert $ (elemLastIndex 4 [1, 2, 1]) == Nothing

  log "findIndex should return the index of an item that a predicate returns true for in an array"
  assert $ (findIndex (_ /= 1) [1, 2, 1]) == Just 1
  assert $ (findIndex (_ == 3) [1, 2, 1]) == Nothing

  log "findLastIndex should return the last index of an item in an array"
  assert $ (findLastIndex (_ /= 1) [2, 1, 2]) == Just 2
  assert $ (findLastIndex (_ == 3) [2, 1, 2]) == Nothing

  log "insertAt should add an item at the specified index"
  assert $ (insertAt 0 1 [2, 3]) == Just [1, 2, 3]
  assert $ (insertAt 1 1 [2, 3]) == Just [2, 1, 3]
  assert $ (insertAt 2 1 [2, 3]) == Just [2, 3, 1]

  log "insertAt should return Nothing if the index is out of range"
  assert $ (insertAt 2 1 nil) == Nothing

  log "deleteAt should remove an item at the specified index"
  assert $ (deleteAt 0 [1, 2, 3]) == Just [2, 3]
  assert $ (deleteAt 1 [1, 2, 3]) == Just [1, 3]

  log "deleteAt should return Nothing if the index is out of range"
  assert $ (deleteAt 1 nil) == Nothing

  log "updateAt should replace an item at the specified index"
  assert $ (updateAt 0 9 [1, 2, 3]) == Just [9, 2, 3]
  assert $ (updateAt 1 9 [1, 2, 3]) == Just [1, 9, 3]

  log "updateAt should return Nothing if the index is out of range"
  assert $ (updateAt 1 9 nil) == Nothing

  log "modifyAt should update an item at the specified index"
  assert $ (modifyAt 0 (_ + 1) [1, 2, 3]) == Just [2, 2, 3]
  assert $ (modifyAt 1 (_ + 1) [1, 2, 3]) == Just [1, 3, 3]

  log "modifyAt should return Nothing if the index is out of range"
  assert $ (modifyAt 1 (_ + 1) nil) == Nothing

  log "alterAt should update an item at the specified index when the function returns Just"
  assert $ (alterAt 0 (Just <<< (_ + 1)) [1, 2, 3]) == Just [2, 2, 3]
  assert $ (alterAt 1 (Just <<< (_ + 1)) [1, 2, 3]) == Just [1, 3, 3]

  log "alterAt should drop an item at the specified index when the function returns Nothing"
  assert $ (alterAt 0 (const Nothing) [1, 2, 3]) == Just [2, 3]
  assert $ (alterAt 1 (const Nothing) [1, 2, 3]) == Just [1, 3]

  log "alterAt should return Nothing if the index is out of range"
  assert $ (alterAt 1 (Just <<< (_ + 1)) nil) == Nothing

  log "reverse should reverse the order of items in an array"
  assert $ (reverse [1, 2, 3]) == [3, 2, 1]
  assert $ (reverse nil) == nil

  log "concat should join an array of arrays"
  assert $ (concat [[1, 2], [3, 4]]) == [1, 2, 3, 4]
  assert $ (concat [[1], nil]) == [1]
  assert $ (concat [nil, nil]) == nil

  log "concatMap should be equivalent to (concat <<< map)"
  assert $ concatMap doubleAndOrig [1, 2, 3] == concat (map doubleAndOrig [1, 2, 3])

  log "filter should remove items that don't match a predicate"
  assert $ filter odd (range 0 10) == [1, 3, 5, 7, 9]

  log "filterM should remove items that don't match a predicate while using a monadic behaviour"
  assert $ filterM (Just <<< odd) (range 0 10) == Just [1, 3, 5, 7, 9]
  assert $ filterM (const Nothing) (range 0 10) == Nothing

  log "mapMaybe should transform every item in an array, throwing out Nothing values"
  assert $ mapMaybe (\x -> if x /= 0 then Just x else Nothing) [0, 1, 0, 0, 2, 3] == [1, 2, 3]

  log "catMaybe should take an array of Maybe values and throw out Nothings"
  assert $ catMaybes [Nothing, Just 2, Nothing, Just 4] == [2, 4]

  log "mapWithIndex applies a function with an index for every element"
  assert $ mapWithIndex (\i x -> x - i) [9,8,7,6,5] == [9,7,5,3,1]

  log "sort should reorder a list into ascending order based on the result of compare"
  assert $ sort [1, 3, 2, 5, 6, 4] == [1, 2, 3, 4, 5, 6]

  log "sortBy should reorder a list into ascending order based on the result of a comparison function"
  assert $ sortBy (flip compare) [1, 3, 2, 5, 6, 4] == [6, 5, 4, 3, 2, 1]

  log "take should keep the specified number of items from the front of an array, discarding the rest"
  assert $ (take 1 [1, 2, 3]) == [1]
  assert $ (take 2 [1, 2, 3]) == [1, 2]
  assert $ (take 1 nil) == nil

  log "takeWhile should keep all values that match a predicate from the front of an array"
  assert $ (takeWhile (_ /= 2) [1, 2, 3]) == [1]
  assert $ (takeWhile (_ /= 3) [1, 2, 3]) == [1, 2]
  assert $ (takeWhile (_ /= 1) nil) == nil

  log "drop should remove the specified number of items from the front of an array"
  assert $ (drop 1 [1, 2, 3]) == [2, 3]
  assert $ (drop 2 [1, 2, 3]) == [3]
  assert $ (drop 1 nil) == nil

  log "dropWhile should remove all values that match a predicate from the front of an array"
  assert $ (dropWhile (_ /= 1) [1, 2, 3]) == [1, 2, 3]
  assert $ (dropWhile (_ /= 2) [1, 2, 3]) == [2, 3]
  assert $ (dropWhile (_ /= 1) nil) == nil

  log "take and drop should treat negative arguments as zero"
  assert $ (take (-2) [1, 2, 3]) == nil
  assert $ (drop (-2) [1, 2, 3]) == [1, 2, 3]

  log "span should split an array in two based on a predicate"
  let spanResult = span (_ < 4) [1, 2, 3, 4, 5, 6, 7]
  assert $ spanResult.init == [1, 2, 3]
  assert $ spanResult.rest == [4, 5, 6, 7]

  log "group should group consecutive equal elements into arrays"
  assert $ group [1, 2, 2, 3, 3, 3, 1] == [[1], [2, 2], [3, 3, 3], [1]]

  log "group' should sort then group consecutive equal elements into arrays"
  assert $ group' [1, 2, 2, 3, 3, 3, 1] == [[1, 1], [2, 2], [3, 3, 3]]

  log "groupBy should group consecutive equal elements into arrays based on an equivalence relation"
  assert $ groupBy (\x y -> odd x && odd y) [1, 1, 2, 2, 3, 3] == [[1, 1], [2], [2], [3, 3]]

  log "nub should remove duplicate elements from the list, keeping the first occurence"
  assert $ nub [1, 2, 2, 3, 4, 1] == [1, 2, 3, 4]

  log "nubBy should remove duplicate items from the list using a supplied predicate"
  let nubPred = \x y -> if odd x then false else x == y
  assert $ nubBy nubPred [1, 2, 2, 3, 3, 4, 4, 1] == [1, 2, 3, 3, 4, 1]

  log "union should produce the union of two arrays"
  assert $ union [1, 2, 3] [2, 3, 4] == [1, 2, 3, 4]
  assert $ union [1, 1, 2, 3] [2, 3, 4] == [1, 1, 2, 3, 4]

  log "unionBy should produce the union of two arrays using the specified equality relation"
  assert $ unionBy (\_ y -> y < 5) [1, 2, 3] [2, 3, 4, 5, 6] == [1, 2, 3, 5, 6]

  log "delete should remove the first matching item from an array"
  assert $ delete 1 [1, 2, 1] == [2, 1]
  assert $ delete 2 [1, 2, 1] == [1, 1]

  log "deleteBy should remove the first equality-relation-matching item from an array"
  assert $ deleteBy (/=) 2 [1, 2, 1] == [2, 1]
  assert $ deleteBy (/=) 1 [1, 2, 1] == [1, 1]

  log "(\\\\) should return the difference between two lists"
  assert $ [1, 2, 3, 4, 3, 2, 1] \\ [1, 1, 2, 3] == [4, 3, 2]

  log "intersect should return the intersection of two arrays"
  assert $ intersect [1, 2, 3, 4, 3, 2, 1] [1, 1, 2, 3] == [1, 2, 3, 3, 2, 1]

  log "intersectBy should return the intersection of two arrays using the specified equivalence relation"
  assert $ intersectBy (\x y -> (x * 2) == y) [1, 2, 3] [2, 6] == [1, 3]

  log "zipWith should use the specified function to zip two lists together"
  assert $ zipWith (\x y -> [show x, y]) [1, 2, 3] ["a", "b", "c"] == [["1", "a"], ["2", "b"], ["3", "c"]]

  log "zipWithA should use the specified function to zip two lists together"
  assert $ zipWithA (\x y -> Just $ Tuple x y) [1, 2, 3] ["a", "b", "c"] == Just [Tuple 1 "a", Tuple 2 "b", Tuple 3 "c"]

  log "zip should use the specified function to zip two lists together"
  assert $ zip [1, 2, 3] ["a", "b", "c"] == [Tuple 1 "a", Tuple 2 "b", Tuple 3 "c"]

  log "unzip should deconstruct a list of tuples into a tuple of lists"
  assert $ unzip [Tuple 1 "a", Tuple 2 "b", Tuple 3 "c"] == Tuple [1, 2, 3] ["a", "b", "c"]

  log "foldM should perform a fold using a monadic step function"
  assert $ foldM (\x y -> Just (x + y)) 0 (range 1 10) == Just 55
  assert $ foldM (\_ _ -> Nothing) 0 (range 1 10) == Nothing

  log "fromFoldable"
  for_ [[], [1], [1,2], [1,2,3,4,5]] \xs -> do
    assert $ fromFoldable xs == xs

  log "fromFoldable is stack safe"
  for_ [1, 1000, 10000, 20000, 50000] \n -> do
    let elem = 0
    let arr = fromFoldable (Replicated n elem)
    assert $ length arr == n
    assert $ all (_ == elem) arr

nil :: Array Int
nil = []

odd :: Int -> Boolean
odd n = n `mod` 2 /= zero

doubleAndOrig :: Int -> Array Int
doubleAndOrig x = [x * 2, x]

data Replicated a = Replicated Int a

instance foldableReplicated :: Foldable Replicated where
  foldr f z (Replicated n x) = applyN n (f x) z
  foldl f z (Replicated n x) = applyN n (flip f x) z
  foldMap = foldMapDefaultR

applyN :: forall a. Int -> (a -> a) -> a -> a
applyN n f x
  | n <= 0    = x
  | otherwise = applyN (n - 1) f (f x)

module Test.Data.Array (testArray) where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log, CONSOLE)

import Data.Array (range, foldM, unzip, zip, zipWithA, zipWith, intersectBy, intersect, (\\), deleteBy, delete, unionBy, union, nubBy, nub, groupBy, group', group, span, dropWhile, drop, takeWhile, take, sortBy, sort, catMaybes, mapMaybe, mapWithIndex, filterM, filter, concat, concatMap, reverse, alterAt, modifyAt, updateAt, deleteAt, insertAt, findLastIndex, findIndex, elemLastIndex, elemIndex, (!!), uncons, init, tail, last, head, insertBy, insert, snoc, (:), length, null, singleton, fromFoldable)
import Data.Foldable (for_, foldMapDefaultR, class Foldable, all)
import Data.Maybe (Maybe(..), isNothing, fromJust)
import Data.Tuple (Tuple(..))
import Data.Unfoldable (replicate, replicateA)

import Partial.Unsafe (unsafePartial)

import Test.Assert (assert, ASSERT)

testArray :: forall eff. Eff (console :: CONSOLE, assert :: ASSERT | eff) Unit
testArray = do

  log "singleton should construct an array with a single value"
  assert $ singleton 1 == [1]
  assert $ singleton "foo" == ["foo"]
  assert $ singleton nil == [[]]

  log "range should create an inclusive array of integers for the specified start and end"
  assert $ (range 0 5) == [0, 1, 2, 3, 4, 5]
  assert $ (range 2 (-3)) == [2, 1, 0, -1, -2, -3]

  log "replicate should produce an array containg an item a specified number of times"
  assert $ replicate 3 true == [true, true, true]
  assert $ replicate 1 "foo" == ["foo"]
  assert $ replicate 0 "foo" == []
  assert $ replicate (-1) "foo" == []

  log "replicateA should perform the monadic action the correct number of times"
  assert $ replicateA 3 (Just 1) == Just [1, 1, 1]
  assert $ replicateA 1 (Just 1) == Just [1]
  assert $ replicateA 0 (Just 1) == Just []
  assert $ replicateA (-1) (Just 1) == Just []

  log "replicateA should be stack safe"
  for_ [1, 1000, 2000, 20000, 50000] \n -> do
    assert $ replicateA n (Just unit) == Just (replicate n unit :: Array Unit)

  -- some
  -- many

  log "null should return false for non-empty arrays"
  assert $ null [1] == false
  assert $ null [1, 2, 3] == false

  log "null should return true for an empty array"
  assert $ null nil == true

  log "length should return the number of items in an array"
  assert $ length nil == 0
  assert $ length [1] == 1
  assert $ length [1, 2, 3, 4, 5] == 5

  log "cons should add an item to the start of an array"
  assert $ 4 : [1, 2, 3] == [4, 1, 2, 3]
  assert $ 1 : nil == [1]

  log "snoc should add an item to the end of an array"
  assert $ [1, 2, 3] `snoc` 4 == [1, 2, 3, 4]
  assert $ nil `snoc` 1 == [1]

  log "insert should add an item at the appropriate place in a sorted array"
  assert $ insert 1.5 [1.0, 2.0, 3.0] == [1.0, 1.5, 2.0, 3.0]
  assert $ insert 4 [1, 2, 3] == [1, 2, 3, 4]
  assert $ insert 0 [1, 2, 3] == [0, 1, 2, 3]

  log "insertBy should add an item at the appropriate place in a sorted array using the specified comparison"
  assert $ insertBy (flip compare) 1.5 [1.0, 2.0, 3.0] == [1.0, 2.0, 3.0, 1.5]
  assert $ insertBy (flip compare) 4 [1, 2, 3] == [4, 1, 2, 3]
  assert $ insertBy (flip compare) 0 [1, 2, 3] == [1, 2, 3, 0]

  log "head should return a Just-wrapped first value of a non-empty array"
  assert $ head ["foo", "bar"] == Just "foo"

  log "head should return Nothing for an empty array"
  assert $ head nil == Nothing

  log "last should return a Just-wrapped last value of a non-empty array"
  assert $ last ["foo", "bar"] == Just "bar"

  log "last should return Nothing for an empty array"
  assert $ last nil == Nothing

  log "tail should return a Just-wrapped array containing all the items in an array apart from the first for a non-empty array"
  assert $ tail ["foo", "bar", "baz"] == Just ["bar", "baz"]

  log "tail should return Nothing for an empty array"
  assert $ tail nil == Nothing

  log "init should return a Just-wrapped array containing all the items in an array apart from the first for a non-empty array"
  assert $ init ["foo", "bar", "baz"] == Just ["foo", "bar"]

  log "init should return Nothing for an empty array"
  assert $ init nil == Nothing

  log "uncons should return nothing when used on an empty array"
  assert $ isNothing (uncons nil)

  log "uncons should split an array into a head and tail record when there is at least one item"
  let u1 = uncons [1]
  assert $ (unsafePartial $ fromJust u1).head == 1
  assert $ (unsafePartial $ fromJust u1).tail == []
  let u2 = uncons [1, 2, 3]
  assert $ (unsafePartial $ fromJust u2).head == 1
  assert $ (unsafePartial $ fromJust u2).tail == [2, 3]

  log "(!!) should return Just x when the index is within the bounds of the array"
  assert $ [1, 2, 3] !! 0 == (Just 1)
  assert $ [1, 2, 3] !! 1 == (Just 2)
  assert $ [1, 2, 3] !! 2 == (Just 3)

  log "(!!) should return Nothing when the index is outside of the bounds of the array"
  assert $ [1, 2, 3] !! 6 == Nothing
  assert $ [1, 2, 3] !! (-1) == Nothing

  log "elemIndex should return the index of an item that a predicate returns true for in an array"
  assert $ (elemIndex 1 [1, 2, 1]) == Just 0
  assert $ (elemIndex 4 [1, 2, 1]) == Nothing

  log "elemLastIndex should return the last index of an item in an array"
  assert $ (elemLastIndex 1 [1, 2, 1]) == Just 2
  assert $ (elemLastIndex 4 [1, 2, 1]) == Nothing

  log "findIndex should return the index of an item that a predicate returns true for in an array"
  assert $ (findIndex (_ /= 1) [1, 2, 1]) == Just 1
  assert $ (findIndex (_ == 3) [1, 2, 1]) == Nothing

  log "findLastIndex should return the last index of an item in an array"
  assert $ (findLastIndex (_ /= 1) [2, 1, 2]) == Just 2
  assert $ (findLastIndex (_ == 3) [2, 1, 2]) == Nothing

  log "insertAt should add an item at the specified index"
  assert $ (insertAt 0 1 [2, 3]) == Just [1, 2, 3]
  assert $ (insertAt 1 1 [2, 3]) == Just [2, 1, 3]
  assert $ (insertAt 2 1 [2, 3]) == Just [2, 3, 1]

  log "insertAt should return Nothing if the index is out of range"
  assert $ (insertAt 2 1 nil) == Nothing

  log "deleteAt should remove an item at the specified index"
  assert $ (deleteAt 0 [1, 2, 3]) == Just [2, 3]
  assert $ (deleteAt 1 [1, 2, 3]) == Just [1, 3]

  log "deleteAt should return Nothing if the index is out of range"
  assert $ (deleteAt 1 nil) == Nothing

  log "updateAt should replace an item at the specified index"
  assert $ (updateAt 0 9 [1, 2, 3]) == Just [9, 2, 3]
  assert $ (updateAt 1 9 [1, 2, 3]) == Just [1, 9, 3]

  log "updateAt should return Nothing if the index is out of range"
  assert $ (updateAt 1 9 nil) == Nothing

  log "modifyAt should update an item at the specified index"
  assert $ (modifyAt 0 (_ + 1) [1, 2, 3]) == Just [2, 2, 3]
  assert $ (modifyAt 1 (_ + 1) [1, 2, 3]) == Just [1, 3, 3]

  log "modifyAt should return Nothing if the index is out of range"
  assert $ (modifyAt 1 (_ + 1) nil) == Nothing

  log "alterAt should update an item at the specified index when the function returns Just"
  assert $ (alterAt 0 (Just <<< (_ + 1)) [1, 2, 3]) == Just [2, 2, 3]
  assert $ (alterAt 1 (Just <<< (_ + 1)) [1, 2, 3]) == Just [1, 3, 3]

  log "alterAt should drop an item at the specified index when the function returns Nothing"
  assert $ (alterAt 0 (const Nothing) [1, 2, 3]) == Just [2, 3]
  assert $ (alterAt 1 (const Nothing) [1, 2, 3]) == Just [1, 3]

  log "alterAt should return Nothing if the index is out of range"
  assert $ (alterAt 1 (Just <<< (_ + 1)) nil) == Nothing

  log "reverse should reverse the order of items in an array"
  assert $ (reverse [1, 2, 3]) == [3, 2, 1]
  assert $ (reverse nil) == nil

  log "concat should join an array of arrays"
  assert $ (concat [[1, 2], [3, 4]]) == [1, 2, 3, 4]
  assert $ (concat [[1], nil]) == [1]
  assert $ (concat [nil, nil]) == nil

  log "concatMap should be equivalent to (concat <<< map)"
  assert $ concatMap doubleAndOrig [1, 2, 3] == concat (map doubleAndOrig [1, 2, 3])

  log "filter should remove items that don't match a predicate"
  assert $ filter odd (range 0 10) == [1, 3, 5, 7, 9]

  log "filterM should remove items that don't match a predicate while using a monadic behaviour"
  assert $ filterM (Just <<< odd) (range 0 10) == Just [1, 3, 5, 7, 9]
  assert $ filterM (const Nothing) (range 0 10) == Nothing

  log "mapMaybe should transform every item in an array, throwing out Nothing values"
  assert $ mapMaybe (\x -> if x /= 0 then Just x else Nothing) [0, 1, 0, 0, 2, 3] == [1, 2, 3]

  log "catMaybe should take an array of Maybe values and throw out Nothings"
  assert $ catMaybes [Nothing, Just 2, Nothing, Just 4] == [2, 4]

  log "mapWithIndex applies a function with an index for every element"
  assert $ mapWithIndex (\i x -> x - i) [9,8,7,6,5] == [9,7,5,3,1]

  log "sort should reorder a list into ascending order based on the result of compare"
  assert $ sort [1, 3, 2, 5, 6, 4] == [1, 2, 3, 4, 5, 6]

  log "sortBy should reorder a list into ascending order based on the result of a comparison function"
  assert $ sortBy (flip compare) [1, 3, 2, 5, 6, 4] == [6, 5, 4, 3, 2, 1]

  log "take should keep the specified number of items from the front of an array, discarding the rest"
  assert $ (take 1 [1, 2, 3]) == [1]
  assert $ (take 2 [1, 2, 3]) == [1, 2]
  assert $ (take 1 nil) == nil

  log "takeWhile should keep all values that match a predicate from the front of an array"
  assert $ (takeWhile (_ /= 2) [1, 2, 3]) == [1]
  assert $ (takeWhile (_ /= 3) [1, 2, 3]) == [1, 2]
  assert $ (takeWhile (_ /= 1) nil) == nil

  log "drop should remove the specified number of items from the front of an array"
  assert $ (drop 1 [1, 2, 3]) == [2, 3]
  assert $ (drop 2 [1, 2, 3]) == [3]
  assert $ (drop 1 nil) == nil

  log "dropWhile should remove all values that match a predicate from the front of an array"
  assert $ (dropWhile (_ /= 1) [1, 2, 3]) == [1, 2, 3]
  assert $ (dropWhile (_ /= 2) [1, 2, 3]) == [2, 3]
  assert $ (dropWhile (_ /= 1) nil) == nil

  log "take and drop should treat negative arguments as zero"
  assert $ (take (-2) [1, 2, 3]) == nil
  assert $ (drop (-2) [1, 2, 3]) == [1, 2, 3]

  log "span should split an array in two based on a predicate"
  let spanResult = span (_ < 4) [1, 2, 3, 4, 5, 6, 7]
  assert $ spanResult.init == [1, 2, 3]
  assert $ spanResult.rest == [4, 5, 6, 7]

  log "group should group consecutive equal elements into arrays"
  assert $ group [1, 2, 2, 3, 3, 3, 1] == [[1], [2, 2], [3, 3, 3], [1]]

  log "group' should sort then group consecutive equal elements into arrays"
  assert $ group' [1, 2, 2, 3, 3, 3, 1] == [[1, 1], [2, 2], [3, 3, 3]]

  log "groupBy should group consecutive equal elements into arrays based on an equivalence relation"
  assert $ groupBy (\x y -> odd x && odd y) [1, 1, 2, 2, 3, 3] == [[1, 1], [2], [2], [3, 3]]

  log "nub should remove duplicate elements from the list, keeping the first occurence"
  assert $ nub [1, 2, 2, 3, 4, 1] == [1, 2, 3, 4]

  log "nubBy should remove duplicate items from the list using a supplied predicate"
  let nubPred = \x y -> if odd x then false else x == y
  assert $ nubBy nubPred [1, 2, 2, 3, 3, 4, 4, 1] == [1, 2, 3, 3, 4, 1]

  log "union should produce the union of two arrays"
  assert $ union [1, 2, 3] [2, 3, 4] == [1, 2, 3, 4]
  assert $ union [1, 1, 2, 3] [2, 3, 4] == [1, 1, 2, 3, 4]

  log "unionBy should produce the union of two arrays using the specified equality relation"
  assert $ unionBy (\_ y -> y < 5) [1, 2, 3] [2, 3, 4, 5, 6] == [1, 2, 3, 5, 6]

  log "delete should remove the first matching item from an array"
  assert $ delete 1 [1, 2, 1] == [2, 1]
  assert $ delete 2 [1, 2, 1] == [1, 1]

  log "deleteBy should remove the first equality-relation-matching item from an array"
  assert $ deleteBy (/=) 2 [1, 2, 1] == [2, 1]
  assert $ deleteBy (/=) 1 [1, 2, 1] == [1, 1]

  log "(\\\\) should return the difference between two lists"
  assert $ [1, 2, 3, 4, 3, 2, 1] \\ [1, 1, 2, 3] == [4, 3, 2]

  log "intersect should return the intersection of two arrays"
  assert $ intersect [1, 2, 3, 4, 3, 2, 1] [1, 1, 2, 3] == [1, 2, 3, 3, 2, 1]

  log "intersectBy should return the intersection of two arrays using the specified equivalence relation"
  assert $ intersectBy (\x y -> (x * 2) == y) [1, 2, 3] [2, 6] == [1, 3]

  log "zipWith should use the specified function to zip two lists together"
  assert $ zipWith (\x y -> [show x, y]) [1, 2, 3] ["a", "b", "c"] == [["1", "a"], ["2", "b"], ["3", "c"]]

  log "zipWithA should use the specified function to zip two lists together"
  assert $ zipWithA (\x y -> Just $ Tuple x y) [1, 2, 3] ["a", "b", "c"] == Just [Tuple 1 "a", Tuple 2 "b", Tuple 3 "c"]

  log "zip should use the specified function to zip two lists together"
  assert $ zip [1, 2, 3] ["a", "b", "c"] == [Tuple 1 "a", Tuple 2 "b", Tuple 3 "c"]

  log "unzip should deconstruct a list of tuples into a tuple of lists"
  assert $ unzip [Tuple 1 "a", Tuple 2 "b", Tuple 3 "c"] == Tuple [1, 2, 3] ["a", "b", "c"]

  log "foldM should perform a fold using a monadic step function"
  assert $ foldM (\x y -> Just (x + y)) 0 (range 1 10) == Just 55
  assert $ foldM (\_ _ -> Nothing) 0 (range 1 10) == Nothing

  log "fromFoldable"
  for_ [[], [1], [1,2], [1,2,3,4,5]] \xs -> do
    assert $ fromFoldable xs == xs

  log "fromFoldable is stack safe"
  for_ [1, 1000, 10000, 20000, 50000] \n -> do
    let elem = 0
    let arr = fromFoldable (Replicated n elem)
    assert $ length arr == n
    assert $ all (_ == elem) arr

nil :: Array Int
nil = []

odd :: Int -> Boolean
odd n = n `mod` 2 /= zero

doubleAndOrig :: Int -> Array Int
doubleAndOrig x = [x * 2, x]

data Replicated a = Replicated Int a

instance foldableReplicated :: Foldable Replicated where
  foldr f z (Replicated n x) = applyN n (f x) z
  foldl f z (Replicated n x) = applyN n (flip f x) z
  foldMap = foldMapDefaultR

applyN :: forall a. Int -> (a -> a) -> a -> a
applyN n f x
  | n <= 0    = x
  | otherwise = applyN (n - 1) f (f x)


Fixing example to use delay instead of later'

module Main where

import Prelude
import Control.Monad.Aff (delay)
import Control.Monad.Eff (Eff)
import Data.Time.Duration (Milliseconds(..))
import Test.Spec (pending, describe, it)
import Test.Spec.Assertions (shouldEqual)
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Spec.Runner (RunnerEffects, run)

main :: Eff (RunnerEffects ()) Unit
main = run [consoleReporter] do
  describe "purescript-spec" do
    describe "Attributes" do
      it "awesome" do
        let isAwesome = true
        isAwesome `shouldEqual` true
      pending "feature complete"
    describe "Features" do
      it "runs in NodeJS" $ pure unit
      it "runs in the browser" $ pure unit
      it "supports streaming reporters" $ pure unit
      it "supports async specs" do
        res <- delay (Milliseconds 100.0) *> pure "Alligator"
        res `shouldEqual` "Alligator"
      it "is PureScript 0.10.x compatible" $ pure unit

module Main where

import Prelude
import Control.Monad.Aff (later')
import Control.Monad.Eff (Eff)
import Test.Spec (pending, describe, it)
import Test.Spec.Assertions (shouldEqual)
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Spec.Runner (RunnerEffects, run)

main :: Eff (RunnerEffects ()) Unit
main = run [consoleReporter] do
  describe "purescript-spec" do
    describe "Attributes" do
      it "awesome" do
        let isAwesome = true
        isAwesome `shouldEqual` true
      pending "feature complete"
    describe "Features" do
      it "runs in NodeJS" $ pure unit
      it "runs in the browser" $ pure unit
      it "supports streaming reporters" $ pure unit
      it "supports async specs" do
        res <- later' 100 $ pure "Alligator"
        res `shouldEqual` "Alligator"
      it "is PureScript 0.10.x compatible" $ pure unit


C++: disable rank-N types support

C++: disable rank-N types support

module Data.Maybe where

import Prelude

import Control.Alt (Alt)
import Control.Alternative (Alternative)
import Control.Extend (Extend)
import Control.MonadPlus (MonadPlus)
import Control.Plus (Plus)
import Data.Functor.Invariant (Invariant, imapF)
import Data.Monoid (Monoid)

-- | The `Maybe` type is used to represent optional values and can be seen as
-- | something like a type-safe `null`, where `Nothing` is `null` and `Just x`
-- | is the non-null value `x`.
data Maybe a = Nothing | Just a

-- | Takes a default value, a function, and a `Maybe` value. If the `Maybe`
-- | value is `Nothing` the default value is returned, otherwise the function
-- | is applied to the value inside the `Just` and the result is returned.
-- |
-- | ``` purescript
-- | maybe x f Nothing == x
-- | maybe x f (Just y) == f y
-- | ```
maybe :: forall a b. b -> (a -> b) -> Maybe a -> b
maybe b _ Nothing = b
maybe _ f (Just a) = f a

-- | Similar to `maybe` but for use in cases where the default value may be
-- | expensive to compute. As PureScript is not lazy, the standard `maybe` has
-- | to evaluate the default value before returning the result, whereas here
-- | the value is only computed when the `Maybe` is known to be `Nothing`.
-- |
-- | ``` purescript
-- | maybe' (\_ -> x) f Nothing == x
-- | maybe' (\_ -> x) f (Just y) == f y
-- | ```
maybe' :: forall a b. (Unit -> b) -> (a -> b) -> Maybe a -> b
maybe' g _ Nothing = g unit
maybe' _ f (Just a) = f a

-- | Takes a default value, and a `Maybe` value. If the `Maybe` value is
-- | `Nothing` the default value is returned, otherwise the value inside the
-- | `Just` is returned.
-- |
-- | ``` purescript
-- | fromMaybe x Nothing == x
-- | fromMaybe x (Just y) == y
-- | ```
fromMaybe :: forall a. a -> Maybe a -> a
fromMaybe a = maybe a id

-- | Similar to `fromMaybe` but for use in cases where the default value may be
-- | expensive to compute. As PureScript is not lazy, the standard `fromMaybe`
-- | has to evaluate the default value before returning the result, whereas here
-- | the value is only computed when the `Maybe` is known to be `Nothing`.
-- |
-- | ``` purescript
-- | fromMaybe' (\_ -> x) Nothing == x
-- | fromMaybe' (\_ -> x) (Just y) == y
-- | ```
fromMaybe' :: forall a. (Unit -> a) -> Maybe a -> a
fromMaybe' a = maybe' a id

-- | Returns `true` when the `Maybe` value was constructed with `Just`.
isJust :: forall a. Maybe a -> Boolean
isJust = maybe false (const true)

-- | Returns `true` when the `Maybe` value is `Nothing`.
isNothing :: forall a. Maybe a -> Boolean
isNothing = maybe true (const false)

-- | The `Functor` instance allows functions to transform the contents of a
-- | `Just` with the `<$>` operator:
-- |
-- | ``` purescript
-- | f <$> Just x == Just (f x)
-- | ```
-- |
-- | `Nothing` values are left untouched:
-- |
-- | ``` purescript
-- | f <$> Nothing == Nothing
-- | ```
instance functorMaybe :: Functor Maybe where
  map fn (Just x) = Just (fn x)
  map _  _        = Nothing

-- | The `Apply` instance allows functions contained within a `Just` to
-- | transform a value contained within a `Just` using the `apply` operator:
-- |
-- | ``` purescript
-- | Just f <*> Just x == Just (f x)
-- | ```
-- |
-- | `Nothing` values are left untouched:
-- |
-- | ``` purescript
-- | Just f <*> Nothing == Nothing
-- | Nothing <*> Just x == Nothing
-- | ```
-- |
-- | Combining `Functor`'s `<$>` with `Apply`'s `<*>` can be used transform a
-- | pure function to take `Maybe`-typed arguments so `f :: a -> b -> c`
-- | becomes `f :: Maybe a -> Maybe b -> Maybe c`:
-- |
-- | ``` purescript
-- | f <$> Just x <*> Just y == Just (f x y)
-- | ```
-- |
-- | The `Nothing`-preserving behaviour of both operators means the result of
-- | an expression like the above but where any one of the values is `Nothing`
-- | means the whole result becomes `Nothing` also:
-- |
-- | ``` purescript
-- | f <$> Nothing <*> Just y == Nothing
-- | f <$> Just x <*> Nothing == Nothing
-- | f <$> Nothing <*> Nothing == Nothing
-- | ```
instance applyMaybe :: Apply Maybe where
  apply (Just fn) x = fn <$> x
  apply Nothing   _ = Nothing

-- | The `Applicative` instance enables lifting of values into `Maybe` with the
-- | `pure` or `return` function (`return` is an alias for `pure`):
-- |
-- | ``` purescript
-- | pure x :: Maybe _ == Just x
-- | return x :: Maybe _ == Just x
-- | ```
-- |
-- | Combining `Functor`'s `<$>` with `Apply`'s `<*>` and `Applicative`'s
-- | `pure` can be used to pass a mixture of `Maybe` and non-`Maybe` typed
-- | values to a function that does not usually expect them, by using `pure`
-- | for any value that is not already `Maybe` typed:
-- |
-- | ``` purescript
-- | f <$> Just x <*> pure y == Just (f x y)
-- | ```
-- |
-- | Even though `pure = Just` it is recommended to use `pure` in situations
-- | like this as it allows the choice of `Applicative` to be changed later
-- | without having to go through and replace `Just` with a new constructor.
instance applicativeMaybe :: Applicative Maybe where
  pure = Just

-- | The `Alt` instance allows for a choice to be made between two `Maybe`
-- | values with the `<|>` operator, where the first `Just` encountered
-- | is taken.
-- |
-- | ``` purescript
-- | Just x <|> Just y == Just x
-- | Nothing <|> Just y == Just y
-- | Nothing <|> Nothing == Nothing
-- | ```
instance altMaybe :: Alt Maybe where
  alt Nothing r = r
  alt l       _ = l

-- | The `Plus` instance provides a default `Maybe` value:
-- |
-- | ``` purescript
-- | empty :: Maybe _ == Nothing
-- | ```
instance plusMaybe :: Plus Maybe where
  empty = Nothing

-- | The `Alternative` instance guarantees that there are both `Applicative` and
-- | `Plus` instances for `Maybe`.
instance alternativeMaybe :: Alternative Maybe

-- | The `Bind` instance allows sequencing of `Maybe` values and functions that
-- | return a `Maybe` by using the `>>=` operator:
-- |
-- | ``` purescript
-- | Just x >>= f = f x
-- | Nothing >>= f = Nothing
-- | ```
instance bindMaybe :: Bind Maybe where
  bind (Just x) k = k x
  bind Nothing  _ = Nothing

-- | The `Monad` instance guarantees that there are both `Applicative` and
-- | `Bind` instances for `Maybe`. This also enables the `do` syntactic sugar:
-- |
-- | ``` purescript
-- | do
-- |   x' <- x
-- |   y' <- y
-- |   pure (f x' y')
-- | ```
-- |
-- | Which is equivalent to:
-- |
-- | ``` purescript
-- | x >>= (\x' -> y >>= (\y' -> pure (f x' y')))
-- | ```
instance monadMaybe :: Monad Maybe

-- | The `MonadPlus` instance guarantees that there are both `Monad` and
-- | `Alternative` instances for `Maybe`.
instance monadPlusMaybe :: MonadPlus Maybe

-- | The `Extend` instance allows sequencing of `Maybe` values and functions
-- | that accept a `Maybe a` and return a non-`Maybe` result using the
-- | `<<=` operator.
-- |
-- | ``` purescript
-- | f <<= Nothing = Nothing
-- | f <<= Just x = Just (f x)
-- | ```
instance extendMaybe :: Extend Maybe where
  extend _ Nothing  = Nothing
  extend f x        = Just (f x)

instance invariantMaybe :: Invariant Maybe where
  imap = imapF

-- | The `Semigroup` instance enables use of the operator `<>` on `Maybe` values
-- | whenever there is a `Semigroup` instance for the type the `Maybe` contains.
-- | The exact behaviour of `<>` depends on the "inner" `Semigroup` instance,
-- | but generally captures the notion of appending or combining things.
-- |
-- | ``` purescript
-- | Just x <> Just y = Just (x <> y)
-- | Just x <> Nothing = Just x
-- | Nothing <> Just y = Just y
-- | Nothing <> Nothing = Nothing
-- | ```
instance semigroupMaybe :: (Semigroup a) => Semigroup (Maybe a) where
  append Nothing y = y
  append x Nothing = x
  append (Just x) (Just y) = Just (x <> y)

instance monoidMaybe :: (Semigroup a) => Monoid (Maybe a) where
  mempty = Nothing

instance semiringMaybe :: (Semiring a) => Semiring (Maybe a) where
  add x y = add <$> x <*> y
  one = Just one
  mul x y = mul <$> x <*> y
  zero = Just zero

instance moduloSemiringMaybe :: (ModuloSemiring a) => ModuloSemiring (Maybe a) where
  mod x y = mod <$> x <*> y
  div x y = div <$> x <*> y

instance ringMaybe :: (Ring a) => Ring (Maybe a) where
  sub x y = sub <$> x <*> y

instance divisionRingMaybe :: (DivisionRing a) => DivisionRing (Maybe a)

instance numMaybe :: (Num a) => Num (Maybe a)

-- | The `Eq` instance allows `Maybe` values to be checked for equality with
-- | `==` and inequality with `/=` whenever there is an `Eq` instance for the
-- | type the `Maybe` contains.
instance eqMaybe :: (Eq a) => Eq (Maybe a) where
  eq Nothing   Nothing   = true
  eq (Just a1) (Just a2) = a1 == a2
  eq _         _         = false

-- | The `Ord` instance allows `Maybe` values to be compared with
-- | `compare`, `>`, `>=`, `<` and `<=` whenever there is an `Ord` instance for
-- | the type the `Maybe` contains.
-- |
-- | `Nothing` is considered to be less than any `Just` value.
instance ordMaybe :: (Ord a) => Ord (Maybe a) where
  compare (Just x) (Just y) = compare x y
  compare Nothing  Nothing  = EQ
  compare Nothing  _        = LT
  compare _        Nothing  = GT

instance boundedMaybe :: (Bounded a) => Bounded (Maybe a) where
  top = Just top
  bottom = Nothing

instance boundedOrdMaybe :: (BoundedOrd a) => BoundedOrd (Maybe a)

instance booleanAlgebraMaybe :: (BooleanAlgebra a) => BooleanAlgebra (Maybe a) where
  conj x y = conj <$> x <*> y
  disj x y = disj <$> x <*> y
  not = map not

-- | The `Show` instance allows `Maybe` values to be rendered as a string with
-- | `show` whenever there is an `Show` instance for the type the `Maybe`
-- | contains.
instance showMaybe :: (Show a) => Show (Maybe a) where
  show (Just x) = "Just (" ++ show x ++ ")"
  show Nothing  = "Nothing"

module Data.Maybe where

import Prelude

import Control.Alt (Alt)
import Control.Alternative (Alternative)
import Control.Extend (Extend)
import Control.MonadPlus (MonadPlus)
import Control.Plus (Plus)
import Data.Functor.Invariant (Invariant, imapF)
import Data.Monoid (Monoid)

-- | The `Maybe` type is used to represent optional values and can be seen as
-- | something like a type-safe `null`, where `Nothing` is `null` and `Just x`
-- | is the non-null value `x`.
data Maybe a = Nothing | Just a

-- | Takes a default value, a function, and a `Maybe` value. If the `Maybe`
-- | value is `Nothing` the default value is returned, otherwise the function
-- | is applied to the value inside the `Just` and the result is returned.
-- |
-- | ``` purescript
-- | maybe x f Nothing == x
-- | maybe x f (Just y) == f y
-- | ```
maybe :: forall a b. b -> (a -> b) -> Maybe a -> b
maybe b _ Nothing = b
maybe _ f (Just a) = f a

-- | Similar to `maybe` but for use in cases where the default value may be
-- | expensive to compute. As PureScript is not lazy, the standard `maybe` has
-- | to evaluate the default value before returning the result, whereas here
-- | the value is only computed when the `Maybe` is known to be `Nothing`.
-- |
-- | ``` purescript
-- | maybe' (\_ -> x) f Nothing == x
-- | maybe' (\_ -> x) f (Just y) == f y
-- | ```
maybe' :: forall a b. (Unit -> b) -> (a -> b) -> Maybe a -> b
maybe' g _ Nothing = g unit
maybe' _ f (Just a) = f a

-- | Takes a default value, and a `Maybe` value. If the `Maybe` value is
-- | `Nothing` the default value is returned, otherwise the value inside the
-- | `Just` is returned.
-- |
-- | ``` purescript
-- | fromMaybe x Nothing == x
-- | fromMaybe x (Just y) == y
-- | ```
fromMaybe :: forall a. a -> Maybe a -> a
fromMaybe a = maybe a (id :: forall a. a -> a)

-- | Similar to `fromMaybe` but for use in cases where the default value may be
-- | expensive to compute. As PureScript is not lazy, the standard `fromMaybe`
-- | has to evaluate the default value before returning the result, whereas here
-- | the value is only computed when the `Maybe` is known to be `Nothing`.
-- |
-- | ``` purescript
-- | fromMaybe' (\_ -> x) Nothing == x
-- | fromMaybe' (\_ -> x) (Just y) == y
-- | ```
fromMaybe' :: forall a. (Unit -> a) -> Maybe a -> a
fromMaybe' a = maybe' a (id :: forall a. a -> a)

-- | Returns `true` when the `Maybe` value was constructed with `Just`.
isJust :: forall a. Maybe a -> Boolean
isJust = maybe false (const true)

-- | Returns `true` when the `Maybe` value is `Nothing`.
isNothing :: forall a. Maybe a -> Boolean
isNothing = maybe true (const false)

-- | The `Functor` instance allows functions to transform the contents of a
-- | `Just` with the `<$>` operator:
-- |
-- | ``` purescript
-- | f <$> Just x == Just (f x)
-- | ```
-- |
-- | `Nothing` values are left untouched:
-- |
-- | ``` purescript
-- | f <$> Nothing == Nothing
-- | ```
instance functorMaybe :: Functor Maybe where
  map fn (Just x) = Just (fn x)
  map _  _        = Nothing

-- | The `Apply` instance allows functions contained within a `Just` to
-- | transform a value contained within a `Just` using the `apply` operator:
-- |
-- | ``` purescript
-- | Just f <*> Just x == Just (f x)
-- | ```
-- |
-- | `Nothing` values are left untouched:
-- |
-- | ``` purescript
-- | Just f <*> Nothing == Nothing
-- | Nothing <*> Just x == Nothing
-- | ```
-- |
-- | Combining `Functor`'s `<$>` with `Apply`'s `<*>` can be used transform a
-- | pure function to take `Maybe`-typed arguments so `f :: a -> b -> c`
-- | becomes `f :: Maybe a -> Maybe b -> Maybe c`:
-- |
-- | ``` purescript
-- | f <$> Just x <*> Just y == Just (f x y)
-- | ```
-- |
-- | The `Nothing`-preserving behaviour of both operators means the result of
-- | an expression like the above but where any one of the values is `Nothing`
-- | means the whole result becomes `Nothing` also:
-- |
-- | ``` purescript
-- | f <$> Nothing <*> Just y == Nothing
-- | f <$> Just x <*> Nothing == Nothing
-- | f <$> Nothing <*> Nothing == Nothing
-- | ```
instance applyMaybe :: Apply Maybe where
  apply (Just fn) x = fn <$> x
  apply Nothing   _ = Nothing

-- | The `Applicative` instance enables lifting of values into `Maybe` with the
-- | `pure` or `return` function (`return` is an alias for `pure`):
-- |
-- | ``` purescript
-- | pure x :: Maybe _ == Just x
-- | return x :: Maybe _ == Just x
-- | ```
-- |
-- | Combining `Functor`'s `<$>` with `Apply`'s `<*>` and `Applicative`'s
-- | `pure` can be used to pass a mixture of `Maybe` and non-`Maybe` typed
-- | values to a function that does not usually expect them, by using `pure`
-- | for any value that is not already `Maybe` typed:
-- |
-- | ``` purescript
-- | f <$> Just x <*> pure y == Just (f x y)
-- | ```
-- |
-- | Even though `pure = Just` it is recommended to use `pure` in situations
-- | like this as it allows the choice of `Applicative` to be changed later
-- | without having to go through and replace `Just` with a new constructor.
instance applicativeMaybe :: Applicative Maybe where
  pure = Just

-- | The `Alt` instance allows for a choice to be made between two `Maybe`
-- | values with the `<|>` operator, where the first `Just` encountered
-- | is taken.
-- |
-- | ``` purescript
-- | Just x <|> Just y == Just x
-- | Nothing <|> Just y == Just y
-- | Nothing <|> Nothing == Nothing
-- | ```
instance altMaybe :: Alt Maybe where
  alt Nothing r = r
  alt l       _ = l

-- | The `Plus` instance provides a default `Maybe` value:
-- |
-- | ``` purescript
-- | empty :: Maybe _ == Nothing
-- | ```
instance plusMaybe :: Plus Maybe where
  empty = Nothing

-- | The `Alternative` instance guarantees that there are both `Applicative` and
-- | `Plus` instances for `Maybe`.
instance alternativeMaybe :: Alternative Maybe

-- | The `Bind` instance allows sequencing of `Maybe` values and functions that
-- | return a `Maybe` by using the `>>=` operator:
-- |
-- | ``` purescript
-- | Just x >>= f = f x
-- | Nothing >>= f = Nothing
-- | ```
instance bindMaybe :: Bind Maybe where
  bind (Just x) k = k x
  bind Nothing  _ = Nothing

-- | The `Monad` instance guarantees that there are both `Applicative` and
-- | `Bind` instances for `Maybe`. This also enables the `do` syntactic sugar:
-- |
-- | ``` purescript
-- | do
-- |   x' <- x
-- |   y' <- y
-- |   pure (f x' y')
-- | ```
-- |
-- | Which is equivalent to:
-- |
-- | ``` purescript
-- | x >>= (\x' -> y >>= (\y' -> pure (f x' y')))
-- | ```
instance monadMaybe :: Monad Maybe

-- | The `MonadPlus` instance guarantees that there are both `Monad` and
-- | `Alternative` instances for `Maybe`.
instance monadPlusMaybe :: MonadPlus Maybe

-- | The `Extend` instance allows sequencing of `Maybe` values and functions
-- | that accept a `Maybe a` and return a non-`Maybe` result using the
-- | `<<=` operator.
-- |
-- | ``` purescript
-- | f <<= Nothing = Nothing
-- | f <<= Just x = Just (f x)
-- | ```
instance extendMaybe :: Extend Maybe where
  extend _ Nothing  = Nothing
  extend f x        = Just (f x)

instance invariantMaybe :: Invariant Maybe where
  imap = imapF

-- | The `Semigroup` instance enables use of the operator `<>` on `Maybe` values
-- | whenever there is a `Semigroup` instance for the type the `Maybe` contains.
-- | The exact behaviour of `<>` depends on the "inner" `Semigroup` instance,
-- | but generally captures the notion of appending or combining things.
-- |
-- | ``` purescript
-- | Just x <> Just y = Just (x <> y)
-- | Just x <> Nothing = Just x
-- | Nothing <> Just y = Just y
-- | Nothing <> Nothing = Nothing
-- | ```
instance semigroupMaybe :: (Semigroup a) => Semigroup (Maybe a) where
  append Nothing y = y
  append x Nothing = x
  append (Just x) (Just y) = Just (x <> y)

instance monoidMaybe :: (Semigroup a) => Monoid (Maybe a) where
  mempty = Nothing

instance semiringMaybe :: (Semiring a) => Semiring (Maybe a) where
  add x y = add <$> x <*> y
  one = Just one
  mul x y = mul <$> x <*> y
  zero = Just zero

instance moduloSemiringMaybe :: (ModuloSemiring a) => ModuloSemiring (Maybe a) where
  mod x y = mod <$> x <*> y
  div x y = div <$> x <*> y

instance ringMaybe :: (Ring a) => Ring (Maybe a) where
  sub x y = sub <$> x <*> y

instance divisionRingMaybe :: (DivisionRing a) => DivisionRing (Maybe a)

instance numMaybe :: (Num a) => Num (Maybe a)

-- | The `Eq` instance allows `Maybe` values to be checked for equality with
-- | `==` and inequality with `/=` whenever there is an `Eq` instance for the
-- | type the `Maybe` contains.
instance eqMaybe :: (Eq a) => Eq (Maybe a) where
  eq Nothing   Nothing   = true
  eq (Just a1) (Just a2) = a1 == a2
  eq _         _         = false

-- | The `Ord` instance allows `Maybe` values to be compared with
-- | `compare`, `>`, `>=`, `<` and `<=` whenever there is an `Ord` instance for
-- | the type the `Maybe` contains.
-- |
-- | `Nothing` is considered to be less than any `Just` value.
instance ordMaybe :: (Ord a) => Ord (Maybe a) where
  compare (Just x) (Just y) = compare x y
  compare Nothing  Nothing  = EQ
  compare Nothing  _        = LT
  compare _        Nothing  = GT

instance boundedMaybe :: (Bounded a) => Bounded (Maybe a) where
  top = Just top
  bottom = Nothing

instance boundedOrdMaybe :: (BoundedOrd a) => BoundedOrd (Maybe a)

instance booleanAlgebraMaybe :: (BooleanAlgebra a) => BooleanAlgebra (Maybe a) where
  conj x y = conj <$> x <*> y
  disj x y = disj <$> x <*> y
  not = map not

-- | The `Show` instance allows `Maybe` values to be rendered as a string with
-- | `show` whenever there is an `Show` instance for the type the `Maybe`
-- | contains.
instance showMaybe :: (Show a) => Show (Maybe a) where
  show (Just x) = "Just (" ++ show x ++ ")"
  show Nothing  = "Nothing"


Updated isOnActiveSquare to match current behaviour as used in renderPiece

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.ST
import Control.MonadPlus (guard)
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 (unsafeEventNumberProp)
import Data.DOM.Simple.Window
import Data.Int (even, odd, toNumber)
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 }

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

getCoordinateIndex :: Array Square -> Coordinate -> Maybe Int
getCoordinateIndex squares coordinate = findIndex (\s -> s.coordinate == coordinate) squares

hasPlayerPiece :: Array Square -> Coordinate -> Player -> Boolean
hasPlayerPiece squares coordinate player =
  case getCoordinateIndex squares coordinate of
    Nothing -> false
    Just index ->
      case (fromJust (squares !! index)).piece of
        Nothing -> false
        Just p -> p.player == player

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 <- -1 : (singleton 1)
  j <- -1 : (singleton 1)
  return (Tuple (x + i) (y + j))

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

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

isValidMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isValidMove grid player from to = not hasPiece grid.squares to &&
  ((player == playerOne && snd to > snd from) ||
   (player == playerTwo && snd to < snd from))

getMoves :: Grid -> Player -> Coordinate -> Array Coordinate
getMoves grid player coordinate = do
  potential <- getDiagonalSquares coordinate
  guard $ (isValid grid potential && isValidMove grid player coordinate potential)
  return potential

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid = grid { squares = newSquares }
    where
      fromIndex = fromJust (getCoordinateIndex grid.squares from)
      toIndex = fromJust (getCoordinateIndex grid.squares to)
      originalSquare = fromJust (grid.squares !! fromIndex)
      afterMove = fromJust (modifyAt toIndex (setPiece originalSquare.piece) grid.squares)
      newSquares = fromJust (modifyAt fromIndex (setPiece Nothing) afterMove)

renderSquare :: forall e.
                  Context2D ->
                  Maybe DOMEvent ->
                  Unit ->
                  Square ->
                  Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderSquare ctx event _ 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 ->
                 Maybe DOMEvent ->
                 Unit ->
                 Square ->
                 Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderPiece state ctx event _ square =
  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
      case event of
        Nothing -> return unit
        Just e -> do
          ux <- unsafeEventNumberProp "clientX" e
          uy <- unsafeEventNumberProp "clientY" e
          let pixel = Tuple (toNumber ux) (toNumber uy)
          case isOnActiveSquare state.grid state.currentPlayer pixel square of
            true -> highlightPiece ctx square
            false -> return unit
          return unit
      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 "black" ctx
  strokeRect ctx border
  return unit

highlightPiece :: forall e. Context2D -> Square -> Eff (canvas :: Canvas | e) Unit
highlightPiece ctx square = do
  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 }
  setLineWidth highlightWidth ctx
  strokePath ctx $ arc ctx arcPiece
  return unit

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

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

clickListener :: forall s e.
                   STRef s State ->
                   DOMEvent ->
                   Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
clickListener st event = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      renderPage st (Just event)
      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 (\e -> renderPage st (Just e)) canvas
      addMouseEventListener MouseClickEvent (\e -> clickListener st e) canvas
      renderPage st Nothing
      return unit
    _ -> return unit

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.ST
import Control.MonadPlus (guard)
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 (unsafeEventNumberProp)
import Data.DOM.Simple.Window
import Data.Int (even, odd, toNumber)
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 }

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

getCoordinateIndex :: Array Square -> Coordinate -> Maybe Int
getCoordinateIndex squares coordinate = findIndex (\s -> s.coordinate == coordinate) squares

hasPlayerPiece :: Array Square -> Coordinate -> Player -> Boolean
hasPlayerPiece squares coordinate player =
  case getCoordinateIndex squares coordinate of
    Nothing -> false
    Just index ->
      case (fromJust (squares !! index)).piece of
        Nothing -> false
        Just p -> p.player == player

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 <- -1 : (singleton 1)
  j <- -1 : (singleton 1)
  return (Tuple (x + i) (y + j))

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

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

isValidMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isValidMove grid player from to = not hasPiece grid.squares to &&
  ((player == playerOne && snd to > snd from) ||
   (player == playerTwo && snd to < snd from))

getMoves :: Grid -> Player -> Coordinate -> Array Coordinate
getMoves grid player coordinate = do
  potential <- getDiagonalSquares coordinate
  guard $ (isValid grid potential && isValidMove grid player coordinate potential)
  return potential

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid = grid { squares = newSquares }
    where
      fromIndex = fromJust (getCoordinateIndex grid.squares from)
      toIndex = fromJust (getCoordinateIndex grid.squares to)
      originalSquare = fromJust (grid.squares !! fromIndex)
      afterMove = fromJust (modifyAt toIndex (setPiece originalSquare.piece) grid.squares)
      newSquares = fromJust (modifyAt fromIndex (setPiece Nothing) afterMove)

renderSquare :: forall e.
                  Context2D ->
                  Maybe DOMEvent ->
                  Unit ->
                  Square ->
                  Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderSquare ctx event _ 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 ->
                 Maybe DOMEvent ->
                 Unit ->
                 Square ->
                 Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderPiece state ctx event _ square =
  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
      case event of
        Nothing -> return unit
        Just e -> do
          ux <- unsafeEventNumberProp "clientX" e
          uy <- unsafeEventNumberProp "clientY" e
          let pixel = Tuple (toNumber ux) (toNumber uy)
          case isOnActiveSquare state.grid state.currentPlayer pixel square of
            true -> highlightPiece ctx square
            false -> return unit
          return unit
      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 "black" ctx
  strokeRect ctx border
  return unit

highlightPiece :: forall e. Context2D -> Square -> Eff (canvas :: Canvas | e) Unit
highlightPiece ctx square = do
  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 }
  setLineWidth highlightWidth ctx
  strokePath ctx $ arc ctx arcPiece
  return unit

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

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

clickListener :: forall s e.
                   STRef s State ->
                   DOMEvent ->
                   Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
clickListener st event = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      renderPage st (Just event)
      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 (\e -> renderPage st (Just e)) canvas
      addMouseEventListener MouseClickEvent (\e -> clickListener st e) canvas
      renderPage st Nothing
      return unit
    _ -> return unit


Remove trailing whitespace

Remove trailing whitespace

module Data.Array.ST
  ( STArray(..)
  , runSTArray
  , emptySTArray
  , peekSTArray
  , pokeSTArray
  , pushSTArray
  ) where

import Data.Maybe
import Data.Function

import Control.Monad.Eff
import Control.Monad.ST (ST())

foreign import data STArray :: * -> * -> *

foreign import runSTArray """
  function runSTArray(f) {
    return f;
  }""" :: forall a r. (forall h. Eff (st :: ST h | r) (STArray h a)) -> Eff r [a]

foreign import emptySTArray """
  function emptySTArray() {
    return [];
  }""" :: forall a h r. Eff (st :: ST h | r) (STArray h a)

foreign import peekSTArrayImpl """
  function peekSTArrayImpl(arr, i, s, f) {
    return function() {
      var index = ~~i;
      if (0 <= index && index < arr.length) {
        return s(arr[index]);
      } else {
        return f;
      }
    };
  }""" :: forall a h e r. Fn4 (STArray h a)
                              Number
                              (a -> r)
                              r
                              (Eff (st :: ST h | e) r)

peekSTArray :: forall a h r. STArray h a -> Number -> Eff (st :: ST h | r) (Maybe a)
peekSTArray arr i = runFn4 peekSTArrayImpl arr i Just Nothing

foreign import pokeSTArrayImpl """
  function pokeSTArrayImpl(arr, i, a) {
    return function() {
      var index = ~~i;
      if (0 <= index && index <= arr.length) {
        arr[index] = a;
        return true;
      }
      return false;
    };
  }""" :: forall a h e. Fn3 (STArray h a)
                            Number
                            a
                            (Eff (st :: ST h | e) Boolean)

pokeSTArray :: forall a h r. STArray h a -> Number -> a -> Eff (st :: ST h | r) Boolean
pokeSTArray arr i a = runFn3 pokeSTArrayImpl arr i a

foreign import pushSTArrayImpl """
  function pushSTArrayImpl(arr, a) {
    return function() {
      arr.push(a);
      return {};
    };
  }""" :: forall a h e. Fn2 (STArray h a)
                            a
                            (Eff (st :: ST h | e) Unit)

pushSTArray :: forall a h r. STArray h a -> a -> Eff (st :: ST h | r) Unit
pushSTArray arr a = runFn2 pushSTArrayImpl arr a


Add Java explanation comment

Add Java explanation comment

Original commit e00e64cfc41797ba95b7ef8644c29c905200dd6f

module Language.Java
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Array as A
import Data.Char.Unicode (GeneralCategory(..), generalCategory, isSpace)
import Data.Foldable (find, for_)
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..), isJust, isNothing)
import Data.Set (Set)
import Data.Set as S
import Data.String.Util (camelCase, decapitalize, isLetterOrLetterNumber, legalizeCharacters, startWithLetter, stringEscape)
import Data.Tuple (Tuple(..))
import Utils (removeElement)

forbiddenNames :: Array String
forbiddenNames =
    [ "Object", "Class", "System", "Long", "Double", "Boolean", "String", "Map", "Exception", "IOException"
    , "JsonProperty", "JsonDeserialize", "JsonDeserializer", "JsonSerialize", "JsonSerializer"
    , "JsonParser", "JsonProcessingException", "DeserializationContext", "SerializerProvider"
    , "Converter"
    ]

renderer :: Renderer
renderer =
    { name: "Java"
    , aceMode: "java"
    , extension: "java"
    , doc: javaDoc
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames: forbiddenNames
        , topLevelName: noForbidNamer javaNameStyle
        , unions: Just
            { predicate: unionIsNotSimpleNullable
            , properName: simpleNamer (javaNameStyle <<< combineNames)
            , nameFromTypes: simpleNamer (unionNameIntercalated javaNameStyle "Or")
            }
        }
    }

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = javaNameStyle $ combineNames names

javaNameStyle :: String -> String
javaNameStyle =
    legalizeCharacters isPartCharacter >>> camelCase >>> startWithLetter isStartCharacter true
    where
        isStartCharacter :: Char -> Boolean
        isStartCharacter c =
            case generalCategory c of
            Just CurrencySymbol -> true
            Just ConnectorPunctuation -> true
            _ -> isLetterOrLetterNumber c

        isPartCharacter :: Char -> Boolean
        isPartCharacter c =
            case generalCategory c of
            Just DecimalNumber -> true
            Just SpacingCombiningMark -> true
            Just NonSpacingMark -> true
            Just Format -> true
            Just Control -> not $ isSpace c
            _ -> isStartCharacter c

javaDoc :: Doc Unit
javaDoc = do
    renderConverter
    forEachClass_ \className properties -> do
        blank
        renderClassDefinition className properties
    forEachUnion_ \unionName unionTypes -> do
        blank
        renderUnionDefinition unionName unionTypes

renderUnionWithTypeRenderer :: (Boolean -> IRType -> Doc String) -> IRUnionRep -> Doc String
renderUnionWithTypeRenderer typeRenderer ur =
    case nullableFromSet $ unionToSet ur of
    Just x -> typeRenderer true x
    Nothing -> lookupUnionName ur

renderType :: Boolean -> IRType -> Doc String
renderType reference = case _ of
    IRNothing -> pure "Object"
    IRNull -> pure "Object"
    IRInteger -> pure $ if reference then "Long" else "long"
    IRDouble -> pure $ if reference then "Double" else "double"
    IRBool -> pure $ if reference then "Boolean" else "boolean"
    IRString -> pure "String"
    IRArray t -> do
        rendered <- renderType false t
        pure $ rendered <> "[]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderType true t
        pure $ "Map<String, " <> rendered <> ">"
    IRUnion ur -> renderUnionWithTypeRenderer renderType ur

renderTypeWithoutGenerics :: Boolean -> IRType -> Doc String
renderTypeWithoutGenerics reference = case _ of
    IRArray t -> do
        rendered <- renderTypeWithoutGenerics false t
        pure $ rendered <> "[]"
    IRMap t -> pure "Map"
    IRUnion ur -> renderUnionWithTypeRenderer renderTypeWithoutGenerics ur
    t -> renderType reference t

renderFileComment :: String -> Doc Unit
renderFileComment fileName = do
    line $ "// " <> fileName <> ".java"

renderPackageAndImports :: Array String -> Doc Unit
renderPackageAndImports imports = do
    line "package io.quicktype;"
    blank
    for_ imports \package -> do
        line $ "import " <> package <> ";"

renderFileHeader :: String -> Array String -> Doc Unit
renderFileHeader fileName imports = do
    renderFileComment fileName
    blank
    renderPackageAndImports imports
    blank

renderConverter :: Doc Unit
renderConverter = do
    renderFileComment "Converter"
    blank
    line """// To use this code, add the following Maven dependency to your project:
//
//     com.fasterxml.jackson.core : jackson-databind : 2.9.0
//
// Import this package:
//
//     import io.quicktype.Converter;
//
// Then you can deserialize a JSON string with
//"""
    forEachTopLevel_ \_ topLevelType -> do
        topLevelTypeRendered <- renderType false topLevelType
        line $ "//     " <> topLevelTypeRendered <> " data = Converter.FromJsonString(jsonString);"
    blank
    renderPackageAndImports ["java.util.Map", "java.io.IOException", "com.fasterxml.jackson.databind.ObjectMapper", "com.fasterxml.jackson.core.JsonProcessingException"]
    blank
    line "public class Converter {"
    indent do
        line "// Serialize/deserialize helpers"
        forEachTopLevel_ \topLevelName topLevelType -> do
            blank
            topLevelTypeRendered <- renderType false topLevelType
            fromJsonPrefix <- getDecoderHelperPrefix topLevelName
            line $ "public static " <> topLevelTypeRendered <> " " <> fromJsonPrefix <> "FromJsonString(String json) throws IOException {"
            indent do
                line "ObjectMapper mapper = new ObjectMapper();"
                renderedForClass <- renderTypeWithoutGenerics false topLevelType
                line $ "return mapper.readValue(json, " <> renderedForClass <> ".class);"
            line "}"
            blank
            line $ "public static String " <> fromJsonPrefix <> "ToJsonString(" <> topLevelTypeRendered <> " obj) throws JsonProcessingException {"
            indent do
                line "ObjectMapper mapper = new ObjectMapper();"
                line "return mapper.writeValueAsString(obj);"
            line "}"
    line "}"
    where
        getDecoderHelperPrefix :: String -> Doc String
        getDecoderHelperPrefix topLevelName = getForSingleOrMultipleTopLevels "" topLevelName

renderClassDefinition :: String -> Map String IRType -> Doc Unit
renderClassDefinition className properties = do
    renderFileHeader className ["java.util.Map", "com.fasterxml.jackson.annotation.*"]
    let propertyNames = transformPropertyNames (simpleNamer javaNameStyle) ("Other" <> _) ["Class"] properties
    when (M.isEmpty properties) do
        line "@JsonAutoDetect(fieldVisibility=JsonAutoDetect.Visibility.NONE)"
    line $ "public class " <> className <> " {"
    indent do
        forEachProperty_ properties propertyNames \_ javaName fieldName rendered -> do
            line $ "private " <> rendered <> " " <> fieldName <> ";"
        forEachProperty_ properties propertyNames \pname javaName fieldName rendered -> do
            blank
            line $ "@JsonProperty(\"" <> stringEscape pname <> "\")"
            line $ "public " <> rendered <> " get" <> javaName <> "() { return " <> fieldName <> "; }"
            line $ "public void set" <> javaName <> "(" <> rendered <> " value) { " <> fieldName <> " = value; }"
    line "}"
    where
        forEachProperty_ :: Map String IRType -> Map String String -> (String -> String -> String -> String -> Doc Unit) -> Doc Unit
        forEachProperty_ properties propertyNames f =
            for_ (M.toUnfoldable properties :: Array _) \(Tuple pname ptype) -> do
                let javaName = lookupName pname propertyNames
                let fieldName = fieldNameForJavaName javaName
                rendered <- renderType false ptype
                f pname javaName fieldName rendered

        fieldNameForJavaName :: String -> String
        fieldNameForJavaName = decapitalize >>> ("_" <> _)

renderUnionField :: IRType -> Doc { renderedType :: String, fieldName :: String }
renderUnionField t = do
    renderedType <- renderType true t
    fieldName <- decapitalize <$> javaNameStyle <$> (_ <> "_value") <$> getTypeNameForUnion t
    pure { renderedType, fieldName }

tokenCase :: String -> Doc Unit
tokenCase tokenType =
    line $ "case " <> tokenType <> ":"

renderNullCase :: Set IRType -> Doc Unit
renderNullCase types =
    when (S.member IRNull types) do
        tokenCase "VALUE_NULL"
        indent do
            line "break;"

deserializeType :: IRType -> Doc Unit
deserializeType t = do
    { fieldName } <- renderUnionField t
    renderedType <- renderTypeWithoutGenerics true t
    line $ "value." <> fieldName <> " = jsonParser.readValueAs(" <> renderedType <> ".class);"
    line "break;"

renderPrimitiveCase :: Array String -> IRType -> Set IRType -> Doc Unit
renderPrimitiveCase tokenTypes t types =
    when (S.member t types) do
        for_ tokenTypes \tokenType ->
            tokenCase tokenType
        indent do
            deserializeType t

renderDoubleCase :: Set IRType -> Doc Unit
renderDoubleCase types =
    when (S.member IRDouble types) do
        unless (S.member IRInteger types) do
            tokenCase "VALUE_NUMBER_INT"
        tokenCase "VALUE_NUMBER_FLOAT"
        indent do
            deserializeType IRDouble

renderGenericCase :: (IRType -> Boolean) -> String -> Set IRType -> Doc Unit
renderGenericCase predicate tokenType types =
    case find predicate types of
    Nothing -> pure unit
    Just t -> do
        tokenCase tokenType
        indent do
            deserializeType t

renderUnionDefinition :: String -> Set IRType -> Doc Unit
renderUnionDefinition unionName unionTypes = do
    let { element: emptyOrNull, rest: nonNullTypes } = removeElement (_ == IRNull) unionTypes
    renderFileHeader unionName ["java.io.IOException", "java.util.Map", "com.fasterxml.jackson.core.*", "com.fasterxml.jackson.databind.*", "com.fasterxml.jackson.databind.annotation.*"]
    line $ "@JsonDeserialize(using = " <> unionName <> ".Deserializer.class)"
    line $ "@JsonSerialize(using = " <> unionName <> ".Serializer.class)"
    line $ "public class " <> unionName <> " {"
    indent do
        for_ nonNullTypes \t -> do
            { renderedType, fieldName } <- renderUnionField t
            line $ "public " <> renderedType <> " " <> fieldName <> ";"
        blank
        line $ "static class Deserializer extends JsonDeserializer<" <> unionName <> "> {"
        indent do
            line "@Override"
            line $ "public " <> unionName <> " deserialize(JsonParser jsonParser, DeserializationContext deserializationContext) throws IOException, JsonProcessingException {"
            indent do
                line $ unionName <> " value = new " <> unionName <> "();"
                line "switch (jsonParser.getCurrentToken()) {"
                renderNullCase unionTypes
                renderPrimitiveCase ["VALUE_NUMBER_INT"] IRInteger unionTypes
                renderDoubleCase unionTypes
                renderPrimitiveCase ["VALUE_TRUE", "VALUE_FALSE"] IRBool unionTypes
                renderPrimitiveCase ["VALUE_STRING"] IRString unionTypes
                renderGenericCase isArray "START_ARRAY" unionTypes
                renderGenericCase isClass "START_OBJECT" unionTypes
                renderGenericCase isMap "START_OBJECT" unionTypes
                line $ "default: throw new IOException(\"Cannot deserialize " <> unionName <> "\");"
                line "}"
                line "return value;"
            line "}"
        line "}"
        blank

        line $ "static class Serializer extends JsonSerializer<" <> unionName <> "> {"
        indent do
            line "@Override"
            line $ "public void serialize(" <> unionName <> " obj, JsonGenerator jsonGenerator, SerializerProvider serializerProvider) throws IOException {"
            indent do
                for_ (A.fromFoldable nonNullTypes) \field -> do
                    { fieldName } <- renderUnionField field
                    line $ "if (obj." <> fieldName <> " != null) {"
                    indent do
                        line $ "jsonGenerator.writeObject(obj." <> fieldName <> ");"
                        line "return;"
                    line "}"
                when (isJust emptyOrNull) do
                    line "jsonGenerator.writeNull();"
                when (isNothing emptyOrNull) do
                    line $ "throw new IOException(\"" <> unionName <> " must not be null\");"
            line "}"
        line "}"
    line "}"

module Language.Java
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Array as A
import Data.Char.Unicode (GeneralCategory(..), generalCategory, isSpace)
import Data.Foldable (find, for_)
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..), isJust, isNothing)
import Data.Set (Set)
import Data.Set as S
import Data.String.Util (camelCase, decapitalize, isLetterOrLetterNumber, legalizeCharacters, startWithLetter, stringEscape)
import Data.Tuple (Tuple(..))
import Utils (removeElement)

forbiddenNames :: Array String
forbiddenNames =
    [ "Object", "Class", "System", "Long", "Double", "Boolean", "String", "Map", "Exception", "IOException"
    , "JsonProperty", "JsonDeserialize", "JsonDeserializer", "JsonSerialize", "JsonSerializer"
    , "JsonParser", "JsonProcessingException", "DeserializationContext", "SerializerProvider"
    , "Converter"
    ]

renderer :: Renderer
renderer =
    { name: "Java"
    , aceMode: "java"
    , extension: "java"
    , doc: javaDoc
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames: forbiddenNames
        , topLevelName: noForbidNamer javaNameStyle
        , unions: Just
            { predicate: unionIsNotSimpleNullable
            , properName: simpleNamer (javaNameStyle <<< combineNames)
            , nameFromTypes: simpleNamer (unionNameIntercalated javaNameStyle "Or")
            }
        }
    }

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = javaNameStyle $ combineNames names

javaNameStyle :: String -> String
javaNameStyle =
    legalizeCharacters isPartCharacter >>> camelCase >>> startWithLetter isStartCharacter true
    where
        isStartCharacter :: Char -> Boolean
        isStartCharacter c =
            case generalCategory c of
            Just CurrencySymbol -> true
            Just ConnectorPunctuation -> true
            _ -> isLetterOrLetterNumber c

        isPartCharacter :: Char -> Boolean
        isPartCharacter c =
            case generalCategory c of
            Just DecimalNumber -> true
            Just SpacingCombiningMark -> true
            Just NonSpacingMark -> true
            Just Format -> true
            Just Control -> not $ isSpace c
            _ -> isStartCharacter c

javaDoc :: Doc Unit
javaDoc = do
    renderConverter
    forEachClass_ \className properties -> do
        blank
        renderClassDefinition className properties
    forEachUnion_ \unionName unionTypes -> do
        blank
        renderUnionDefinition unionName unionTypes

renderUnionWithTypeRenderer :: (Boolean -> IRType -> Doc String) -> IRUnionRep -> Doc String
renderUnionWithTypeRenderer typeRenderer ur =
    case nullableFromSet $ unionToSet ur of
    Just x -> typeRenderer true x
    Nothing -> lookupUnionName ur

renderType :: Boolean -> IRType -> Doc String
renderType reference = case _ of
    IRNothing -> pure "Object"
    IRNull -> pure "Object"
    IRInteger -> pure $ if reference then "Long" else "long"
    IRDouble -> pure $ if reference then "Double" else "double"
    IRBool -> pure $ if reference then "Boolean" else "boolean"
    IRString -> pure "String"
    IRArray t -> do
        rendered <- renderType false t
        pure $ rendered <> "[]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderType true t
        pure $ "Map<String, " <> rendered <> ">"
    IRUnion ur -> renderUnionWithTypeRenderer renderType ur

renderTypeWithoutGenerics :: Boolean -> IRType -> Doc String
renderTypeWithoutGenerics reference = case _ of
    IRArray t -> do
        rendered <- renderTypeWithoutGenerics false t
        pure $ rendered <> "[]"
    IRMap t -> pure "Map"
    IRUnion ur -> renderUnionWithTypeRenderer renderTypeWithoutGenerics ur
    t -> renderType reference t

renderFileHeader :: String -> Array String -> Doc Unit
renderFileHeader fileName imports = do
    line $ "// " <> fileName <> ".java"
    blank
    line "package io.quicktype;"
    blank
    for_ imports \package -> do
        line $ "import " <> package <> ";"
    blank

renderConverter :: Doc Unit
renderConverter = do
    renderFileHeader "Converter" ["java.util.Map", "java.io.IOException", "com.fasterxml.jackson.databind.ObjectMapper", "com.fasterxml.jackson.core.JsonProcessingException"]
    line "public class Converter {"
    indent do
        line "// Serialize/deserialize helpers"
        forEachTopLevel_ \topLevelName topLevelType -> do
            blank
            topLevelTypeRendered <- renderType false topLevelType
            fromJsonPrefix <- getDecoderHelperPrefix topLevelName
            line $ "public static " <> topLevelTypeRendered <> " " <> fromJsonPrefix <> "FromJsonString(String json) throws IOException {"
            indent do
                line "ObjectMapper mapper = new ObjectMapper();"
                renderedForClass <- renderTypeWithoutGenerics false topLevelType
                line $ "return mapper.readValue(json, " <> renderedForClass <> ".class);"
            line "}"
            blank
            line $ "public static String " <> fromJsonPrefix <> "ToJsonString(" <> topLevelTypeRendered <> " obj) throws JsonProcessingException {"
            indent do
                line "ObjectMapper mapper = new ObjectMapper();"
                line "return mapper.writeValueAsString(obj);"
            line "}"
    line "}"
    where
        getDecoderHelperPrefix :: String -> Doc String
        getDecoderHelperPrefix topLevelName = getForSingleOrMultipleTopLevels "" topLevelName

renderClassDefinition :: String -> Map String IRType -> Doc Unit
renderClassDefinition className properties = do
    renderFileHeader className ["java.util.Map", "com.fasterxml.jackson.annotation.*"]
    let propertyNames = transformPropertyNames (simpleNamer javaNameStyle) ("Other" <> _) ["Class"] properties
    when (M.isEmpty properties) do
        line "@JsonAutoDetect(fieldVisibility=JsonAutoDetect.Visibility.NONE)"
    line $ "public class " <> className <> " {"
    indent do
        forEachProperty_ properties propertyNames \_ javaName fieldName rendered -> do
            line $ "private " <> rendered <> " " <> fieldName <> ";"
        forEachProperty_ properties propertyNames \pname javaName fieldName rendered -> do
            blank
            line $ "@JsonProperty(\"" <> stringEscape pname <> "\")"
            line $ "public " <> rendered <> " get" <> javaName <> "() { return " <> fieldName <> "; }"
            line $ "public void set" <> javaName <> "(" <> rendered <> " value) { " <> fieldName <> " = value; }"
    line "}"
    where
        forEachProperty_ :: Map String IRType -> Map String String -> (String -> String -> String -> String -> Doc Unit) -> Doc Unit
        forEachProperty_ properties propertyNames f =
            for_ (M.toUnfoldable properties :: Array _) \(Tuple pname ptype) -> do
                let javaName = lookupName pname propertyNames
                let fieldName = fieldNameForJavaName javaName
                rendered <- renderType false ptype
                f pname javaName fieldName rendered

        fieldNameForJavaName :: String -> String
        fieldNameForJavaName = decapitalize >>> ("_" <> _)

renderUnionField :: IRType -> Doc { renderedType :: String, fieldName :: String }
renderUnionField t = do
    renderedType <- renderType true t
    fieldName <- decapitalize <$> javaNameStyle <$> (_ <> "_value") <$> getTypeNameForUnion t
    pure { renderedType, fieldName }

tokenCase :: String -> Doc Unit
tokenCase tokenType =
    line $ "case " <> tokenType <> ":"

renderNullCase :: Set IRType -> Doc Unit
renderNullCase types =
    when (S.member IRNull types) do
        tokenCase "VALUE_NULL"
        indent do
            line "break;"

deserializeType :: IRType -> Doc Unit
deserializeType t = do
    { fieldName } <- renderUnionField t
    renderedType <- renderTypeWithoutGenerics true t
    line $ "value." <> fieldName <> " = jsonParser.readValueAs(" <> renderedType <> ".class);"
    line "break;"

renderPrimitiveCase :: Array String -> IRType -> Set IRType -> Doc Unit
renderPrimitiveCase tokenTypes t types =
    when (S.member t types) do
        for_ tokenTypes \tokenType ->
            tokenCase tokenType
        indent do
            deserializeType t

renderDoubleCase :: Set IRType -> Doc Unit
renderDoubleCase types =
    when (S.member IRDouble types) do
        unless (S.member IRInteger types) do
            tokenCase "VALUE_NUMBER_INT"
        tokenCase "VALUE_NUMBER_FLOAT"
        indent do
            deserializeType IRDouble

renderGenericCase :: (IRType -> Boolean) -> String -> Set IRType -> Doc Unit
renderGenericCase predicate tokenType types =
    case find predicate types of
    Nothing -> pure unit
    Just t -> do
        tokenCase tokenType
        indent do
            deserializeType t

renderUnionDefinition :: String -> Set IRType -> Doc Unit
renderUnionDefinition unionName unionTypes = do
    let { element: emptyOrNull, rest: nonNullTypes } = removeElement (_ == IRNull) unionTypes
    renderFileHeader unionName ["java.io.IOException", "java.util.Map", "com.fasterxml.jackson.core.*", "com.fasterxml.jackson.databind.*", "com.fasterxml.jackson.databind.annotation.*"]
    line $ "@JsonDeserialize(using = " <> unionName <> ".Deserializer.class)"
    line $ "@JsonSerialize(using = " <> unionName <> ".Serializer.class)"
    line $ "public class " <> unionName <> " {"
    indent do
        for_ nonNullTypes \t -> do
            { renderedType, fieldName } <- renderUnionField t
            line $ "public " <> renderedType <> " " <> fieldName <> ";"
        blank
        line $ "static class Deserializer extends JsonDeserializer<" <> unionName <> "> {"
        indent do
            line "@Override"
            line $ "public " <> unionName <> " deserialize(JsonParser jsonParser, DeserializationContext deserializationContext) throws IOException, JsonProcessingException {"
            indent do
                line $ unionName <> " value = new " <> unionName <> "();"
                line "switch (jsonParser.getCurrentToken()) {"
                renderNullCase unionTypes
                renderPrimitiveCase ["VALUE_NUMBER_INT"] IRInteger unionTypes
                renderDoubleCase unionTypes
                renderPrimitiveCase ["VALUE_TRUE", "VALUE_FALSE"] IRBool unionTypes
                renderPrimitiveCase ["VALUE_STRING"] IRString unionTypes
                renderGenericCase isArray "START_ARRAY" unionTypes
                renderGenericCase isClass "START_OBJECT" unionTypes
                renderGenericCase isMap "START_OBJECT" unionTypes
                line $ "default: throw new IOException(\"Cannot deserialize " <> unionName <> "\");"
                line "}"
                line "return value;"
            line "}"
        line "}"
        blank

        line $ "static class Serializer extends JsonSerializer<" <> unionName <> "> {"
        indent do
            line "@Override"
            line $ "public void serialize(" <> unionName <> " obj, JsonGenerator jsonGenerator, SerializerProvider serializerProvider) throws IOException {"
            indent do
                for_ (A.fromFoldable nonNullTypes) \field -> do
                    { fieldName } <- renderUnionField field
                    line $ "if (obj." <> fieldName <> " != null) {"
                    indent do
                        line $ "jsonGenerator.writeObject(obj." <> fieldName <> ");"
                        line "return;"
                    line "}"
                when (isJust emptyOrNull) do
                    line "jsonGenerator.writeNull();"
                when (isNothing emptyOrNull) do
                    line $ "throw new IOException(\"" <> unionName <> " must not be null\");"
            line "}"
        line "}"
    line "}"