export list and additional fns

export list and additional fns

module Data.Array.NonEmpty
  ( NonEmptyArray
  , fromArray
  , fromNonEmpty
  , toArray
  , toNonEmpty

  , fromFoldable
  , toUnfoldable
  , singleton
  , (..), range
  , replicate
  , some
-- TODO
--  , many

  , length

  , (:), cons
  , cons'
  , snoc
  , snoc'
  , appendArray
  , insert
  , insertBy

  , head
  , last
  , tail
  , init
  , uncons
  , unsnoc

  , (!!), index
  , elemIndex
  , elemLastIndex
  , findIndex
  , findLastIndex
  , insertAt
  , deleteAt
  , updateAt
  , updateAtIndices
  , modifyAt
  , modifyAtIndices
  , alterAt

  , reverse
  , concat
  , concatMap
  , filter
  , partition
  , filterA
  , mapMaybe
  , catMaybes

  , sort
  , sortBy
  , sortWith
  , slice
  , take
  , takeEnd
  , takeWhile
  , drop
  , dropEnd
  , dropWhile
  , span

-- TODO
--  , group
--  , group'
--  , groupBy

  , nub
  , nubBy
--  , union
--  , unionBy
  , delete
  , deleteBy

--  , (\\), difference
--  , intersect
--  , intersectBy

  , zipWith
  , zipWithA
  , zip
  , unzip

  , foldM
  , foldRecM

  , unsafeIndex

--  , module Exports
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Lazy (class Lazy)
import Control.Monad.Rec.Class (class MonadRec)
import Data.Array as A
import Data.Bifunctor (bimap)
import Data.Eq (class Eq1)
import Data.Foldable (class Foldable)
import Data.FoldableWithIndex (class FoldableWithIndex)
import Data.FunctorWithIndex (class FunctorWithIndex)
import Data.Maybe (Maybe(..), fromJust)
import Data.NonEmpty (NonEmpty, (:|))
import Data.Ord (class Ord1)
import Data.Traversable (class Traversable)
import Data.TraversableWithIndex (class TraversableWithIndex)
import Data.Tuple (Tuple)
import Data.Unfoldable (class Unfoldable)
import Partial.Unsafe (unsafePartial)

newtype NonEmptyArray a = NonEmptyArray (Array a)

instance showNonEmptyArray :: Show a => Show (NonEmptyArray a) where
  show (NonEmptyArray xs) = "(NonEmptyArray " <> show xs <> ")"

derive newtype instance eqNonEmptyArray :: Eq a => Eq (NonEmptyArray a)
derive newtype instance eq1NonEmptyArray :: Eq1 NonEmptyArray

derive newtype instance ordNonEmptyArray :: Ord a => Ord (NonEmptyArray a)
derive newtype instance ord1NonEmptyArray :: Ord1 NonEmptyArray

derive newtype instance functorNonEmptyArray :: Functor NonEmptyArray
derive newtype instance functorWithIndexNonEmptyArray :: FunctorWithIndex Int NonEmptyArray

derive newtype instance foldableNonEmptyArray :: Foldable NonEmptyArray
derive newtype instance foldableWithIndexNonEmptyArray :: FoldableWithIndex Int NonEmptyArray

derive newtype instance traversableNonEmptyArray :: Traversable NonEmptyArray
derive newtype instance traversableWithIndexNonEmptyArray :: TraversableWithIndex Int NonEmptyArray

derive newtype instance applyNonEmptyArray :: Apply NonEmptyArray

derive newtype instance applicativeNonEmptyArray :: Applicative NonEmptyArray

derive newtype instance bindNonEmptyArray :: Bind NonEmptyArray

derive newtype instance monadNonEmptyArray :: Monad NonEmptyArray

derive newtype instance altNonEmptyArray :: Alt NonEmptyArray

-- | Internal - adapt an Array transform to NonEmptyArray
--
-- Note that this is unsafe: if the transform returns an empty array, this can
-- explode at runtime.
unsafeAdapt :: forall a b. (Array a -> Array b) -> NonEmptyArray a -> NonEmptyArray b
unsafeAdapt f = NonEmptyArray <<< adaptAny f

-- | Internal - adapt an Array transform with argument to NonEmptyArray
--
-- Note that this is unsafe: if the transform returns an empty array, this can
-- explode at runtime.
unsafeAdapt' :: forall a b c. (a -> Array b -> Array c) -> a -> NonEmptyArray b -> NonEmptyArray c
unsafeAdapt' f = unsafeAdapt <<< f

-- | Internal - adapt an Array transform with two arguments to NonEmptyArray
--
-- Note that this is unsafe: if the transform returns an empty array, this can
-- explode at runtime.
unsafeAdapt'' :: forall a b c d. (a -> b -> Array c -> Array d) -> a -> b -> NonEmptyArray c -> NonEmptyArray d
unsafeAdapt'' f = unsafeAdapt' <<< f

-- | Internal - adapt an Array transform to NonEmptyArray,
--   with polymorphic result.
--
-- Note that this is unsafe: if the transform returns an empty array, this can
-- explode at runtime.
adaptAny :: forall a b. (Array a -> b) -> NonEmptyArray a -> b
adaptAny f = f <<< toArray

-- | Internal - adapt an Array transform with argument to NonEmptyArray,
--   with polymorphic result.
adaptAny' :: forall a b c. (a -> Array b -> c) -> a -> NonEmptyArray b -> c
adaptAny' f = adaptAny <<< f

-- | Internal - adapt an Array transform with two arguments to NonEmptyArray,
--   with polymorphic result.
adaptAny'' :: forall a b c d. (a -> b -> Array c -> d) -> a -> b -> NonEmptyArray c -> d
adaptAny'' f = adaptAny' <<< f

-- | Internal - adapt Array functions returning Maybes to NonEmptyArray
adaptMaybe :: forall a b. (Array a -> Maybe b) -> NonEmptyArray a -> b
adaptMaybe f = unsafePartial $ fromJust <<< f <<< toArray

fromArray :: forall a. Array a -> Maybe (NonEmptyArray a)
fromArray xs
  | A.length xs > 0 = Just (NonEmptyArray xs)
  | otherwise       = Nothing

-- | INTERNAL
unsafeFromArray :: forall a. Array a -> NonEmptyArray a
unsafeFromArray = NonEmptyArray

fromNonEmpty :: forall a. NonEmpty Array a -> NonEmptyArray a
fromNonEmpty (x :| xs) = cons' x xs

toArray :: forall a. NonEmptyArray a -> Array a
toArray (NonEmptyArray xs) = xs

toNonEmpty :: forall a. NonEmptyArray a -> NonEmpty Array a
toNonEmpty = uncons >>> \{head: x, tail: xs} -> x :| xs

fromFoldable :: forall f a. Foldable f => f a -> Maybe (NonEmptyArray a)
fromFoldable = fromArray <<< A.fromFoldable

toUnfoldable :: forall f a. Unfoldable f => NonEmptyArray a -> f a
toUnfoldable = adaptAny A.toUnfoldable

singleton :: forall a. a -> NonEmptyArray a
singleton = NonEmptyArray <<< A.singleton

range :: Int -> Int -> NonEmptyArray Int
range x y = NonEmptyArray $ A.range x y

infix 8 range as ..

replicate :: forall a. Int -> a -> Maybe (NonEmptyArray a)
replicate i x
  | i > 0     = Just $ NonEmptyArray $ A.replicate i x
  | otherwise = Nothing

some
  :: forall f a
   . Alternative f
  => Lazy (f (Array a))
  => f a -> f (NonEmptyArray a)
some = map NonEmptyArray <<< A.some

length :: forall a. NonEmptyArray a -> Int
length = adaptAny A.length

cons :: forall a. a -> NonEmptyArray a -> NonEmptyArray a
cons = unsafeAdapt' A.cons

infixr 6 cons as :

cons' :: forall a. a -> Array a -> NonEmptyArray a
cons' x xs = unsafeFromArray $ A.cons x xs

snoc :: forall a. NonEmptyArray a -> a -> NonEmptyArray a
snoc xs x = unsafeFromArray $ A.snoc (toArray xs) x

snoc' :: forall a. Array a -> a -> NonEmptyArray a
snoc' xs x = unsafeFromArray $ A.snoc xs x

appendArray :: forall a. NonEmptyArray a -> Array a -> NonEmptyArray a
appendArray xs ys = unsafeFromArray $ toArray xs <> ys

insert :: forall a. Ord a => a -> NonEmptyArray a -> NonEmptyArray a
insert = unsafeAdapt' A.insert

insertBy :: forall a. (a -> a -> Ordering) -> a -> NonEmptyArray a -> NonEmptyArray a
insertBy = unsafeAdapt'' A.insertBy

head :: forall a. NonEmptyArray a -> a
head = adaptMaybe A.head

last :: forall a. NonEmptyArray a -> a
last = adaptMaybe A.last

tail :: forall a. NonEmptyArray a -> Array a
tail = adaptMaybe A.tail

init :: forall a. NonEmptyArray a -> Array a
init = adaptMaybe A.init

uncons :: forall a. NonEmptyArray a -> { head :: a, tail :: Array a }
uncons = adaptMaybe A.uncons

unsnoc :: forall a. NonEmptyArray a -> { init :: Array a, last :: a }
unsnoc = adaptMaybe A.unsnoc

index :: forall a. NonEmptyArray a -> Int -> Maybe a
index = adaptAny A.index

infixl 8 index as !!

elemIndex :: forall a. Eq a => a -> NonEmptyArray a -> Maybe Int
elemIndex = adaptAny' A.elemIndex

elemLastIndex :: forall a. Eq a => a -> NonEmptyArray a -> Maybe Int
elemLastIndex = adaptAny' A.elemLastIndex

findIndex :: forall a. (a -> Boolean) -> NonEmptyArray a -> Maybe Int
findIndex = adaptAny' A.findIndex

findLastIndex :: forall a. (a -> Boolean) -> NonEmptyArray a -> Maybe Int
findLastIndex = adaptAny' A.findLastIndex

insertAt :: forall a. Int -> a -> NonEmptyArray a -> Maybe (NonEmptyArray a)
insertAt i x = map NonEmptyArray <<< A.insertAt i x <<< toArray

deleteAt :: forall a. Int -> NonEmptyArray a -> Maybe (Array a)
deleteAt = adaptAny' A.deleteAt

updateAt :: forall a. Int -> a -> NonEmptyArray a -> Maybe (NonEmptyArray a)
updateAt i x = map NonEmptyArray <<< A.updateAt i x <<< toArray

updateAtIndices :: forall t a. Foldable t => t (Tuple Int a) -> NonEmptyArray a -> NonEmptyArray a
updateAtIndices = unsafeAdapt' A.updateAtIndices

modifyAt :: forall a. Int -> (a -> a) -> NonEmptyArray a -> Maybe (NonEmptyArray a)
modifyAt i f = map NonEmptyArray <<< A.modifyAt i f <<< toArray

modifyAtIndices :: forall t a. Foldable t => t Int -> (a -> a) -> NonEmptyArray a -> NonEmptyArray a
modifyAtIndices = unsafeAdapt'' A.modifyAtIndices

alterAt :: forall a. Int -> (a -> Maybe a) -> NonEmptyArray a -> Maybe (Array a)
alterAt i f = A.alterAt i f <<< toArray

reverse :: forall a. NonEmptyArray a -> NonEmptyArray a
reverse = unsafeAdapt A.reverse

concat :: forall a. NonEmptyArray (NonEmptyArray a) -> NonEmptyArray a
concat = NonEmptyArray <<< A.concat <<< toArray <<< map toArray

concatMap :: forall a b. (a -> NonEmptyArray b) -> NonEmptyArray a -> NonEmptyArray b
concatMap = flip bind

filter :: forall a. (a -> Boolean) -> NonEmptyArray a -> Array a
filter = adaptAny' A.filter

partition
  :: forall a
   . (a -> Boolean)
  -> NonEmptyArray a
  -> { yes :: Array a, no :: Array a}
partition = adaptAny' A.partition

filterA
  :: forall a f
   . Applicative f
  => (a -> f Boolean)
  -> NonEmptyArray a
  -> f (Array a)
filterA = adaptAny' A.filterA

mapMaybe :: forall a b. (a -> Maybe b) -> NonEmptyArray a -> Array b
mapMaybe = adaptAny' A.mapMaybe

catMaybes :: forall a. NonEmptyArray (Maybe a) -> Array a
catMaybes = adaptAny A.catMaybes

sort :: forall a. Ord a => NonEmptyArray a -> NonEmptyArray a
sort = unsafeAdapt A.sort

sortBy :: forall a. (a -> a -> Ordering) -> NonEmptyArray a -> NonEmptyArray a
sortBy = unsafeAdapt' A.sortBy

sortWith :: forall a b. Ord b => (a -> b) -> NonEmptyArray a -> NonEmptyArray a
sortWith = unsafeAdapt' A.sortWith

slice :: forall a. Int -> Int -> NonEmptyArray a -> Array a
slice = adaptAny'' A.slice

take :: forall a. Int -> NonEmptyArray a -> Array a
take = adaptAny' A.take

takeEnd :: forall a. Int -> NonEmptyArray a -> Array a
takeEnd = adaptAny' A.takeEnd

takeWhile :: forall a. (a -> Boolean) -> NonEmptyArray a -> Array a
takeWhile = adaptAny' A.takeWhile

drop :: forall a. Int -> NonEmptyArray a -> Array a
drop = adaptAny' A.drop

dropEnd :: forall a. Int -> NonEmptyArray a -> Array a
dropEnd = adaptAny' A.dropEnd

dropWhile :: forall a. (a -> Boolean) -> NonEmptyArray a -> Array a
dropWhile = adaptAny' A.dropWhile

span
  :: forall a
   . (a -> Boolean)
  -> NonEmptyArray a
  -> { init :: Array a, rest :: Array a }
span = adaptAny' A.span

--TODO
--group :: forall a. Eq a => NonEmptyArray a -> NonEmptyArray (NonEmptyArray a)

--TODO
--group' :: forall a. Ord a => NonEmptyArray a -> NonEmptyArray (NonEmptyArray a)

--TODO
--groupBy :: forall a. (a -> a -> Boolean) -> NonEmptyArray a -> NonEmptyArray (NonEmptyArray a)

nub :: forall a. Eq a => NonEmptyArray a -> NonEmptyArray a
nub = unsafeAdapt A.nub

nubBy :: forall a. (a -> a -> Boolean) -> NonEmptyArray a -> NonEmptyArray a
nubBy = unsafeAdapt' A.nubBy

delete :: forall a. Eq a => a -> NonEmptyArray a -> Array a
delete = adaptAny' A.delete

deleteBy :: forall a. (a -> a -> Boolean) -> a -> NonEmptyArray a -> Array a
deleteBy = adaptAny'' A.deleteBy

zipWith
  :: forall a b c
   . (a -> b -> c)
  -> NonEmptyArray a
  -> NonEmptyArray b
  -> NonEmptyArray c
zipWith f xs ys = NonEmptyArray $ A.zipWith f (toArray xs) (toArray ys)

zipWithA
  :: forall m a b c
   . Applicative m
  => (a -> b -> m c)
  -> NonEmptyArray a
  -> NonEmptyArray b
  -> m (NonEmptyArray c)
zipWithA f xs ys = NonEmptyArray <$> A.zipWithA f (toArray xs) (toArray ys)

zip :: forall a b. NonEmptyArray a -> NonEmptyArray b -> NonEmptyArray (Tuple a b)
zip xs ys = NonEmptyArray $ toArray xs `A.zip` toArray ys

unzip :: forall a b. NonEmptyArray (Tuple a b) -> Tuple (NonEmptyArray a) (NonEmptyArray b)
unzip = bimap NonEmptyArray NonEmptyArray <<< A.unzip <<< toArray

foldM :: forall m a b. Monad m => (a -> b -> m a) -> a -> NonEmptyArray b -> m a
foldM = adaptAny'' A.foldM

foldRecM :: forall m a b. MonadRec m => (a -> b -> m a) -> a -> NonEmptyArray b -> m a
foldRecM = adaptAny'' A.foldRecM

unsafeIndex :: forall a. Partial => NonEmptyArray a -> Int -> a
unsafeIndex = adaptAny A.unsafeIndex

module Data.Array.NonEmpty where

import Prelude

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Lazy (class Lazy)
import Control.Monad.Rec.Class (class MonadRec)
import Data.Array as A
import Data.Bifunctor (bimap)
import Data.Eq (class Eq1)
import Data.Foldable (class Foldable)
import Data.FoldableWithIndex (class FoldableWithIndex)
import Data.FunctorWithIndex (class FunctorWithIndex)
import Data.Maybe (Maybe(..), fromJust)
import Data.NonEmpty (NonEmpty, (:|))
import Data.Ord (class Ord1)
import Data.Traversable (class Traversable)
import Data.TraversableWithIndex (class TraversableWithIndex)
import Data.Tuple (Tuple)
import Data.Unfoldable (class Unfoldable)
import Partial.Unsafe (unsafePartial)

newtype NonEmptyArray a = NonEmptyArray (Array a)

instance showNonEmptyArray :: Show a => Show (NonEmptyArray a) where
  show (NonEmptyArray xs) = "(NonEmptyArray " <> show xs <> ")"

derive newtype instance eqNonEmptyArray :: Eq a => Eq (NonEmptyArray a)
derive newtype instance eq1NonEmptyArray :: Eq1 NonEmptyArray

derive newtype instance ordNonEmptyArray :: Ord a => Ord (NonEmptyArray a)
derive newtype instance ord1NonEmptyArray :: Ord1 NonEmptyArray

derive newtype instance functorNonEmptyArray :: Functor NonEmptyArray
derive newtype instance functorWithIndexNonEmptyArray :: FunctorWithIndex Int NonEmptyArray

derive newtype instance foldableNonEmptyArray :: Foldable NonEmptyArray
derive newtype instance foldableWithIndexNonEmptyArray :: FoldableWithIndex Int NonEmptyArray

derive newtype instance traversableNonEmptyArray :: Traversable NonEmptyArray
derive newtype instance traversableWithIndexNonEmptyArray :: TraversableWithIndex Int NonEmptyArray

derive newtype instance applyNonEmptyArray :: Apply NonEmptyArray

derive newtype instance applicativeNonEmptyArray :: Applicative NonEmptyArray

derive newtype instance bindNonEmptyArray :: Bind NonEmptyArray

derive newtype instance monadNonEmptyArray :: Monad NonEmptyArray

derive newtype instance altNonEmptyArray :: Alt NonEmptyArray

-- | Internal - adapt an Array transform to NonEmptyArray
--
-- Note that this is unsafe: if the transform returns an empty array, this can
-- explode at runtime.
unsafeAdapt :: forall a b. (Array a -> Array b) -> NonEmptyArray a -> NonEmptyArray b
unsafeAdapt f = NonEmptyArray <<< adaptAny f

-- | Internal - adapt an Array transform with argument to NonEmptyArray
--
-- Note that this is unsafe: if the transform returns an empty array, this can
-- explode at runtime.
unsafeAdapt' :: forall a b c. (a -> Array b -> Array c) -> a -> NonEmptyArray b -> NonEmptyArray c
unsafeAdapt' f = unsafeAdapt <<< f

-- | Internal - adapt an Array transform with two arguments to NonEmptyArray
--
-- Note that this is unsafe: if the transform returns an empty array, this can
-- explode at runtime.
unsafeAdapt'' :: forall a b c d. (a -> b -> Array c -> Array d) -> a -> b -> NonEmptyArray c -> NonEmptyArray d
unsafeAdapt'' f = unsafeAdapt' <<< f

-- | Internal - adapt an Array transform to NonEmptyArray,
--   with polymorphic result.
--
-- Note that this is unsafe: if the transform returns an empty array, this can
-- explode at runtime.
adaptAny :: forall a b. (Array a -> b) -> NonEmptyArray a -> b
adaptAny f = f <<< toArray

-- | Internal - adapt an Array transform with argument to NonEmptyArray,
--   with polymorphic result.
adaptAny' :: forall a b c. (a -> Array b -> c) -> a -> NonEmptyArray b -> c
adaptAny' f = adaptAny <<< f

-- | Internal - adapt an Array transform with two arguments to NonEmptyArray,
--   with polymorphic result.
adaptAny'' :: forall a b c d. (a -> b -> Array c -> d) -> a -> b -> NonEmptyArray c -> d
adaptAny'' f = adaptAny' <<< f

-- | Internal - adapt Array functions returning Maybes to NonEmptyArray
adaptMaybe :: forall a b. (Array a -> Maybe b) -> NonEmptyArray a -> b
adaptMaybe f = unsafePartial $ fromJust <<< f <<< toArray

fromArray :: forall a. Array a -> Maybe (NonEmptyArray a)
fromArray xs
  | A.length xs > 0 = Just (NonEmptyArray xs)
  | otherwise       = Nothing

unsafeFromArray :: forall a. Array a -> NonEmptyArray a
unsafeFromArray = NonEmptyArray

fromNonEmpty :: forall a. NonEmpty Array a -> NonEmptyArray a
fromNonEmpty (x :| xs) = cons' x xs

toArray :: forall a. NonEmptyArray a -> Array a
toArray (NonEmptyArray xs) = xs

toNonEmpty :: forall a. NonEmptyArray a -> NonEmpty Array a
toNonEmpty = uncons >>> \{head: x, tail: xs} -> x :| xs

toUnfoldable :: forall f a. Unfoldable f => NonEmptyArray a -> f a
toUnfoldable = adaptAny A.toUnfoldable

fromFoldable :: forall f a. Foldable f => f a -> Maybe (NonEmptyArray a)
fromFoldable = fromArray <<< A.fromFoldable

singleton :: forall a. a -> NonEmptyArray a
singleton = NonEmptyArray <<< A.singleton

range :: Int -> Int -> NonEmptyArray Int
range x y = NonEmptyArray $ A.range x y

infix 8 range as ..

replicate :: forall a. Int -> a -> Maybe (NonEmptyArray a)
replicate i x
  | i > 0     = Just $ NonEmptyArray $ A.replicate i x
  | otherwise = Nothing

some
  :: forall f a
   . Alternative f
  => Lazy (f (Array a))
  => f a -> f (NonEmptyArray a)
some = map NonEmptyArray <<< A.some

length :: forall a. NonEmptyArray a -> Int
length = adaptAny A.length

cons :: forall a. a -> NonEmptyArray a -> NonEmptyArray a
cons = unsafeAdapt' A.cons

infixr 6 cons as :

cons' :: forall a. a -> Array a -> NonEmptyArray a
cons' x xs = unsafeFromArray $ A.cons x xs

appendArray :: forall a. NonEmptyArray a -> Array a -> NonEmptyArray a
appendArray xs ys = unsafeFromArray $ toArray xs <> ys

insert :: forall a. Ord a => a -> NonEmptyArray a -> NonEmptyArray a
insert = unsafeAdapt' A.insert

insertBy :: forall a. (a -> a -> Ordering) -> a -> NonEmptyArray a -> NonEmptyArray a
insertBy = unsafeAdapt'' A.insertBy

head :: forall a. NonEmptyArray a -> a
head = adaptMaybe A.head

last :: forall a. NonEmptyArray a -> a
last = adaptMaybe A.last

tail :: forall a. NonEmptyArray a -> Array a
tail = adaptMaybe A.tail

init :: forall a. NonEmptyArray a -> Array a
init = adaptMaybe A.init

uncons :: forall a. NonEmptyArray a -> { head :: a, tail :: Array a }
uncons = adaptMaybe A.uncons

unsnoc :: forall a. NonEmptyArray a -> { init :: Array a, last :: a }
unsnoc = adaptMaybe A.unsnoc

index :: forall a. NonEmptyArray a -> Int -> Maybe a
index = adaptAny A.index

infixl 8 index as !!

elemIndex :: forall a. Eq a => a -> NonEmptyArray a -> Maybe Int
elemIndex = adaptAny' A.elemIndex

elemLastIndex :: forall a. Eq a => a -> NonEmptyArray a -> Maybe Int
elemLastIndex = adaptAny' A.elemLastIndex

findIndex :: forall a. (a -> Boolean) -> NonEmptyArray a -> Maybe Int
findIndex = adaptAny' A.findIndex

findLastIndex :: forall a. (a -> Boolean) -> NonEmptyArray a -> Maybe Int
findLastIndex = adaptAny' A.findLastIndex

insertAt :: forall a. Int -> a -> NonEmptyArray a -> Maybe (NonEmptyArray a)
insertAt i x = map NonEmptyArray <<< A.insertAt i x <<< toArray

deleteAt :: forall a. Int -> NonEmptyArray a -> Maybe (Array a)
deleteAt = adaptAny' A.deleteAt

updateAt :: forall a. Int -> a -> NonEmptyArray a -> Maybe (NonEmptyArray a)
updateAt i x = map NonEmptyArray <<< A.updateAt i x <<< toArray

modifyAt :: forall a. Int -> (a -> a) -> NonEmptyArray a -> Maybe (NonEmptyArray a)
modifyAt i f = map NonEmptyArray <<< A.modifyAt i f <<< toArray

alterAt :: forall a. Int -> (a -> Maybe a) -> NonEmptyArray a -> Maybe (Array a)
alterAt i f = A.alterAt i f <<< toArray

reverse :: forall a. NonEmptyArray a -> NonEmptyArray a
reverse = unsafeAdapt A.reverse

concat :: forall a. NonEmptyArray (NonEmptyArray a) -> NonEmptyArray a
concat = NonEmptyArray <<< A.concat <<< toArray <<< map toArray

concatMap :: forall a b. (a -> NonEmptyArray b) -> NonEmptyArray a -> NonEmptyArray b
concatMap = flip bind

filter :: forall a. (a -> Boolean) -> NonEmptyArray a -> Array a
filter = adaptAny' A.filter

partition
  :: forall a
   . (a -> Boolean)
  -> NonEmptyArray a
  -> { yes :: Array a, no :: Array a}
partition = adaptAny' A.partition

filterA
  :: forall a f
   . Applicative f
  => (a -> f Boolean)
  -> NonEmptyArray a
  -> f (Array a)
filterA = adaptAny' A.filterA

mapMaybe :: forall a b. (a -> Maybe b) -> NonEmptyArray a -> Array b
mapMaybe = adaptAny' A.mapMaybe

catMaybes :: forall a. NonEmptyArray (Maybe a) -> Array a
catMaybes = adaptAny A.catMaybes

updateAtIndices :: forall t a. Foldable t => t (Tuple Int a) -> NonEmptyArray a -> NonEmptyArray a
updateAtIndices = unsafeAdapt' A.updateAtIndices

modifyAtIndices :: forall t a. Foldable t => t Int -> (a -> a) -> NonEmptyArray a -> NonEmptyArray a
modifyAtIndices = unsafeAdapt'' A.modifyAtIndices

sort :: forall a. Ord a => NonEmptyArray a -> NonEmptyArray a
sort = unsafeAdapt A.sort

sortBy :: forall a. (a -> a -> Ordering) -> NonEmptyArray a -> NonEmptyArray a
sortBy = unsafeAdapt' A.sortBy

sortWith :: forall a b. Ord b => (a -> b) -> NonEmptyArray a -> NonEmptyArray a
sortWith = unsafeAdapt' A.sortWith

slice :: forall a. Int -> Int -> NonEmptyArray a -> Array a
slice = adaptAny'' A.slice

take :: forall a. Int -> NonEmptyArray a -> Array a
take = adaptAny' A.take

takeEnd :: forall a. Int -> NonEmptyArray a -> Array a
takeEnd = adaptAny' A.takeEnd

takeWhile :: forall a. (a -> Boolean) -> NonEmptyArray a -> Array a
takeWhile = adaptAny' A.takeWhile

drop :: forall a. Int -> NonEmptyArray a -> Array a
drop = adaptAny' A.drop

dropEnd :: forall a. Int -> NonEmptyArray a -> Array a
dropEnd = adaptAny' A.dropEnd

dropWhile :: forall a. (a -> Boolean) -> NonEmptyArray a -> Array a
dropWhile = adaptAny' A.dropWhile

span
  :: forall a
   . (a -> Boolean)
  -> NonEmptyArray a
  -> { init :: Array a, rest :: Array a }
span = adaptAny' A.span

--TODO
--group :: forall a. Eq a => NonEmptyArray a -> NonEmptyArray (NonEmptyArray a)

--TODO
--group' :: forall a. Ord a => NonEmptyArray a -> NonEmptyArray (NonEmptyArray a)

--TODO
--groupBy :: forall a. (a -> a -> Boolean) -> NonEmptyArray a -> NonEmptyArray (NonEmptyArray a)

nub :: forall a. Eq a => NonEmptyArray a -> NonEmptyArray a
nub = unsafeAdapt A.nub

nubBy :: forall a. (a -> a -> Boolean) -> NonEmptyArray a -> NonEmptyArray a
nubBy = unsafeAdapt' A.nubBy

delete :: forall a. Eq a => a -> NonEmptyArray a -> Array a
delete = adaptAny' A.delete

deleteBy :: forall a. (a -> a -> Boolean) -> a -> NonEmptyArray a -> Array a
deleteBy = adaptAny'' A.deleteBy

zipWith
  :: forall a b c
   . (a -> b -> c)
  -> NonEmptyArray a
  -> NonEmptyArray b
  -> NonEmptyArray c
zipWith f xs ys = NonEmptyArray $ A.zipWith f (toArray xs) (toArray ys)

zipWithA
  :: forall m a b c
   . Applicative m
  => (a -> b -> m c)
  -> NonEmptyArray a
  -> NonEmptyArray b
  -> m (NonEmptyArray c)
zipWithA f xs ys = NonEmptyArray <$> A.zipWithA f (toArray xs) (toArray ys)

zip :: forall a b. NonEmptyArray a -> NonEmptyArray b -> NonEmptyArray (Tuple a b)
zip xs ys = NonEmptyArray $ toArray xs `A.zip` toArray ys

unzip :: forall a b. NonEmptyArray (Tuple a b) -> Tuple (NonEmptyArray a) (NonEmptyArray b)
unzip = bimap NonEmptyArray NonEmptyArray <<< A.unzip <<< toArray

foldM :: forall m a b. Monad m => (a -> b -> m a) -> a -> NonEmptyArray b -> m a
foldM = adaptAny'' A.foldM

foldRecM :: forall m a b. MonadRec m => (a -> b -> m a) -> a -> NonEmptyArray b -> m a
foldRecM = adaptAny'' A.foldRecM

unsafeIndex :: forall a. Partial => NonEmptyArray a -> Int -> a
unsafeIndex = adaptAny A.unsafeIndex


Switch control to other player upon moving a piece

module Checkers.Main where

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

import Checkers.Constants
import Checkers.Types

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

module Checkers.Main where

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

import Checkers.Constants
import Checkers.Types

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid = grid { squares = newSquares }
    where
      fromIndex = fromJust (findIndex (hasCoordinate from) grid.squares)
      toIndex = fromJust (findIndex (hasCoordinate to) grid.squares)
      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 ->
                  Unit ->
                  Square ->
                  Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderSquare ctx _ square = do
  setFillStyle square.color ctx
  fillRect ctx { x: fst square.render,
                 y: snd square.render,
                 w: renderSize,
                 h: renderSize }
  return unit

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

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

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

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

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

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

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

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


[CSE-108] Update `mkEmptyCAddressSummary`

to latest changes.

module Explorer.Util.Factory where

import Prelude
import Data.Time.NominalDiffTime (mkTime)
import Pos.Core.Types (EpochIndex(..), LocalSlotIndex(..))
import Pos.Explorer.Web.ClientTypes (CAddress(..), CAddressSummary(..), CAddressType(..), CCoin(..), CHash(..), CTxEntry(..), CTxId(..))

mkCHash :: String -> CHash
mkCHash = CHash

mkCTxId :: String -> CTxId
mkCTxId =
    CTxId <<< mkCHash

mkCoin :: Int -> CCoin
mkCoin coin =
  CCoin {getCoin: show coin}

mkCAddress :: String -> CAddress
mkCAddress = CAddress

mkEpochIndex :: Int -> EpochIndex
mkEpochIndex index = EpochIndex {getEpochIndex: index}

mkLocalSlotIndex :: Int -> LocalSlotIndex
mkLocalSlotIndex index = LocalSlotIndex {getSlotIndex: index}

-- All the following helper function `mkEmpty**` are for debugging only
-- We do need these to mock live data
-- It can be removed if all endpoints are ready

mkEmptyCTxEntry :: CTxEntry
mkEmptyCTxEntry = CTxEntry
    { cteId: mkCTxId "--"
    , cteTimeIssued: mkTime 0.0
    , cteAmount: mkCoin 0
    }

mkEmptyCAddressSummary :: CAddressSummary
mkEmptyCAddressSummary = CAddressSummary
    { caAddress: mkCAddress "--"
    , caType: CUnknownAddress
    , caTxNum: 0
    , caBalance: mkCoin 0
    , caTxList: []
    }

module Explorer.Util.Factory where

import Prelude
import Data.Foldable (sum)
import Data.Lens ((^.))
import Data.Time.NominalDiffTime (mkTime)
import Data.Tuple (Tuple(..))
import Pos.Core.Types (EpochIndex(..), LocalSlotIndex(..))
import Pos.Explorer.Web.ClientTypes (CCoin(..), CAddress(..), CAddressSummary(..), CHash(..), CTxEntry(..), CTxId(..))
import Pos.Explorer.Web.Lenses.ClientTypes (_CCoin, getCoin)

mkCHash :: String -> CHash
mkCHash = CHash

mkCTxId :: String -> CTxId
mkCTxId =
    CTxId <<< mkCHash

mkCoin :: Int -> CCoin
mkCoin coin =
  CCoin {getCoin: show coin}

mkCAddress :: String -> CAddress
mkCAddress = CAddress

mkEpochIndex :: Int -> EpochIndex
mkEpochIndex index = EpochIndex {getEpochIndex: index}

mkLocalSlotIndex :: Int -> LocalSlotIndex
mkLocalSlotIndex index = LocalSlotIndex {getSlotIndex: index}

-- All the following helper function `mkEmpty**` are for debugging only
-- We do need these to mock live data
-- It can be removed if all endpoints are ready

mkEmptyCTxEntry :: CTxEntry
mkEmptyCTxEntry = CTxEntry
    { cteId: mkCTxId "--"
    , cteTimeIssued: mkTime 0.0
    , cteAmount: mkCoin 0
    }

mkEmptyCAddressSummary :: CAddressSummary
mkEmptyCAddressSummary = CAddressSummary
    { caAddress: mkCAddress "--"
    , caTxNum: 0
    , caBalance: mkCoin 0
    , caTxList: []
    }


setTextAlign

setTextAlign

module Graphics.Canvas.Free
  ( Graphics()
  , GraphicsF()

  , setLineWidth
  , setFillStyle
  , setStrokeStyle
  , setShadowColor
  , setShadowBlur
  , setShadowOffsetX
  , setShadowOffsetY
  , setLineCap
  , setComposite
  , setAlpha

  , beginPath
  , stroke
  , fill
  , clip
  , lineTo
  , moveTo
  , closePath

  , arc
  , rect
  , clearRect

  , scale
  , rotate
  , translate
  , transform

  , setTextAlign
  , setFont
  , fillText
  , strokeText
  , measureText

  , save
  , restore

  , getImageData
  , putImageData

  , runGraphics
  ) where

import Control.Monad.Eff
import Control.Monad.Free
import Data.Coyoneda

import qualified Graphics.Canvas as C

data GraphicsF more
  = SetLineWidth      Number      more
  | SetFillStyle      String      more
  | SetStrokeStyle    String      more
  | SetShadowColor    String      more
  | SetShadowBlur     Number      more
  | SetShadowOffsetX  Number      more
  | SetShadowOffsetY  Number      more
  | SetLineCap        C.LineCap   more
  | SetComposite      C.Composite more
  | SetAlpha          Number      more
  | BeginPath         more
  | Stroke            more
  | Fill              more
  | Clip              more
  | LineTo            Number      Number      more
  | MoveTo            Number      Number      more
  | ClosePath         more
  | Arc               C.Arc       more
  | Rect              C.Rectangle more
  | ClearRect         C.Rectangle more
  | Scale             Number      Number      more
  | Rotate            Number      more
  | Translate         Number      Number      more
  | Transform         C.Transform more
  | SetTextAlign      C.TextAlign more
  | SetFont           String      more
  | FillText          String      Number      Number    more
  | StrokeText        String      Number      Number    more
  | MeasureText       String      (C.TextMetrics -> more)
  | Save              more
  | Restore           more
  | GetImageData      Number      Number      Number    Number   (C.ImageData -> more)
  | PutImageData      C.ImageData Number      Number    more

type Graphics a = FreeC GraphicsF a

setLineWidth :: Number -> Graphics Unit
setLineWidth w = liftFC $ SetLineWidth w unit

setFillStyle :: String -> Graphics Unit
setFillStyle s = liftFC $ SetFillStyle s unit

setStrokeStyle :: String -> Graphics Unit
setStrokeStyle s = liftFC $ SetStrokeStyle s unit

setShadowColor :: String -> Graphics Unit
setShadowColor c = liftFC $ SetShadowColor c unit

setShadowBlur :: Number -> Graphics Unit
setShadowBlur n = liftFC $ SetShadowBlur n unit

setShadowOffsetX :: Number -> Graphics Unit
setShadowOffsetX n = liftFC $ SetShadowOffsetX n unit

setShadowOffsetY :: Number -> Graphics Unit
setShadowOffsetY n = liftFC $ SetShadowOffsetY n unit

setLineCap :: C.LineCap -> Graphics Unit
setLineCap lc = liftFC $ SetLineCap lc unit

setComposite :: C.Composite -> Graphics Unit
setComposite c = liftFC $ SetComposite c unit

setAlpha :: Number -> Graphics Unit
setAlpha a = liftFC $ SetAlpha a unit

beginPath :: Graphics Unit
beginPath = liftFC $ BeginPath unit

stroke :: Graphics Unit
stroke = liftFC $ Stroke unit

fill :: Graphics Unit
fill = liftFC $ Fill unit

clip :: Graphics Unit
clip = liftFC $ Clip unit

lineTo :: Number -> Number -> Graphics Unit
lineTo x y = liftFC $ LineTo x y unit

moveTo :: Number -> Number -> Graphics Unit
moveTo x y = liftFC $ MoveTo x y unit

closePath :: Graphics Unit
closePath = liftFC $ ClosePath unit

arc :: C.Arc -> Graphics Unit
arc a = liftFC $ Arc a unit

rect :: C.Rectangle -> Graphics Unit
rect r = liftFC $ Rect r unit

clearRect :: C.Rectangle -> Graphics Unit
clearRect r = liftFC $ ClearRect r unit

scale :: Number -> Number -> Graphics Unit
scale sx sy = liftFC $ Scale sx sy unit

rotate :: Number -> Graphics Unit
rotate th = liftFC $ Rotate th unit

translate :: Number -> Number -> Graphics Unit
translate tx ty = liftFC $ Translate tx ty unit

transform :: C.Transform -> Graphics Unit
transform tx = liftFC $ Transform tx unit

setTextAlign :: C.TextAlign -> Graphics Unit
setTextAlign ta = liftFC $ SetTextAlign ta unit

setFont :: String -> Graphics Unit
setFont f = liftFC $ SetFont f unit

fillText :: String -> Number -> Number -> Graphics Unit
fillText s x y = liftFC $ FillText s x y unit

strokeText :: String -> Number -> Number -> Graphics Unit
strokeText s x y = liftFC $ StrokeText s x y unit

measureText :: String -> Graphics C.TextMetrics
measureText s = liftFC $ MeasureText s id

save :: Graphics Unit
save = liftFC $ Save unit

restore :: Graphics Unit
restore = liftFC $ Restore unit

getImageData :: Number -> Number -> Number -> Number -> Graphics C.ImageData
getImageData x y w h = liftFC $ GetImageData x y w h id

putImageData :: C.ImageData -> Number -> Number -> Graphics Unit
putImageData d x y = liftFC $ PutImageData d x y unit

runGraphics :: forall a eff. C.Context2D -> Graphics a -> Eff (canvas :: C.Canvas | eff) a
runGraphics ctx = runFreeCM interp
  where
  interp :: forall eff. Natural GraphicsF (Eff (canvas :: C.Canvas | eff))
  interp (SetLineWidth w a)       = const a <$> C.setLineWidth w ctx
  interp (SetFillStyle s a)       = const a <$> C.setFillStyle s ctx
  interp (SetStrokeStyle s a)     = const a <$> C.setStrokeStyle s ctx
  interp (SetShadowColor c a)     = const a <$> C.setShadowColor c ctx
  interp (SetShadowBlur n a)      = const a <$> C.setShadowBlur n ctx
  interp (SetShadowOffsetX n a)   = const a <$> C.setShadowOffsetX n ctx
  interp (SetShadowOffsetY n a)   = const a <$> C.setShadowOffsetY n ctx
  interp (SetLineCap lc a)        = const a <$> C.setLineCap lc ctx
  interp (SetComposite c a)       = const a <$> C.setGlobalCompositeOperation ctx c
  interp (SetAlpha s a)           = const a <$> C.setGlobalAlpha ctx s
  interp (BeginPath a)            = const a <$> C.beginPath ctx
  interp (Stroke a)               = const a <$> C.stroke ctx
  interp (Fill a)                 = const a <$> C.fill ctx
  interp (Clip a)                 = const a <$> C.clip ctx
  interp (LineTo x y a)           = const a <$> C.lineTo ctx x y
  interp (MoveTo x y a)           = const a <$> C.moveTo ctx x y
  interp (ClosePath a)            = const a <$> C.closePath ctx
  interp (Arc arc a)              = const a <$> C.arc ctx arc
  interp (Rect r a)               = const a <$> C.rect ctx r
  interp (ClearRect r a)          = const a <$> C.clearRect ctx r
  interp (Scale sx sy a)          = const a <$> C.scale { scaleX: sx, scaleY: sy } ctx
  interp (Rotate th a)            = const a <$> C.rotate th ctx
  interp (Translate tx ty a)      = const a <$> C.translate { translateX: tx, translateY: ty } ctx
  interp (Transform tx a)         = const a <$> C.transform tx ctx
  interp (SetTextAlign ta a)      = const a <$> C.setTextAlign ctx ta
  interp (SetFont f a)            = const a <$> C.setFont f ctx
  interp (FillText s x y a)       = const a <$> C.fillText ctx s x y
  interp (StrokeText s x y a)     = const a <$> C.strokeText ctx s x y
  interp (MeasureText s k)        = k <$> C.measureText ctx s
  interp (Save a)                 = const a <$> C.save ctx
  interp (Restore a)              = const a <$> C.restore ctx
  interp (GetImageData x y w h k) = k <$> C.getImageData ctx x y w h
  interp (PutImageData d x y a)   = const a <$> C.putImageData ctx d x y

module Graphics.Canvas.Free
  ( Graphics()
  , GraphicsF()

  , setLineWidth
  , setFillStyle
  , setStrokeStyle
  , setShadowColor
  , setShadowBlur
  , setShadowOffsetX
  , setShadowOffsetY
  , setLineCap
  , setComposite
  , setAlpha

  , beginPath
  , stroke
  , fill
  , clip
  , lineTo
  , moveTo
  , closePath

  , arc
  , rect
  , clearRect

  , scale
  , rotate
  , translate
  , transform

  , setFont
  , fillText
  , strokeText
  , measureText

  , save
  , restore

  , getImageData
  , putImageData

  , runGraphics
  ) where

import Control.Monad.Eff
import Control.Monad.Free
import Data.Coyoneda

import qualified Graphics.Canvas as C

data GraphicsF more
  = SetLineWidth      Number      more
  | SetFillStyle      String      more
  | SetStrokeStyle    String      more
  | SetShadowColor    String      more
  | SetShadowBlur     Number      more
  | SetShadowOffsetX  Number      more
  | SetShadowOffsetY  Number      more
  | SetLineCap        C.LineCap   more
  | SetComposite      C.Composite more
  | SetAlpha          Number      more
  | BeginPath         more
  | Stroke            more
  | Fill              more
  | Clip              more
  | LineTo            Number      Number      more
  | MoveTo            Number      Number      more
  | ClosePath         more
  | Arc               C.Arc       more
  | Rect              C.Rectangle more
  | ClearRect         C.Rectangle more
  | Scale             Number      Number      more
  | Rotate            Number      more
  | Translate         Number      Number      more
  | Transform         C.Transform more
  | SetFont           String      more
  | FillText          String      Number      Number    more
  | StrokeText        String      Number      Number    more
  | MeasureText       String      (C.TextMetrics -> more)
  | Save              more
  | Restore           more
  | GetImageData      Number      Number      Number    Number   (C.ImageData -> more)
  | PutImageData      C.ImageData Number      Number    more

type Graphics a = FreeC GraphicsF a

setLineWidth :: Number -> Graphics Unit
setLineWidth w = liftFC $ SetLineWidth w unit

setFillStyle :: String -> Graphics Unit
setFillStyle s = liftFC $ SetFillStyle s unit

setStrokeStyle :: String -> Graphics Unit
setStrokeStyle s = liftFC $ SetStrokeStyle s unit

setShadowColor :: String -> Graphics Unit
setShadowColor c = liftFC $ SetShadowColor c unit

setShadowBlur :: Number -> Graphics Unit
setShadowBlur n = liftFC $ SetShadowBlur n unit

setShadowOffsetX :: Number -> Graphics Unit
setShadowOffsetX n = liftFC $ SetShadowOffsetX n unit

setShadowOffsetY :: Number -> Graphics Unit
setShadowOffsetY n = liftFC $ SetShadowOffsetY n unit

setLineCap :: C.LineCap -> Graphics Unit
setLineCap lc = liftFC $ SetLineCap lc unit

setComposite :: C.Composite -> Graphics Unit
setComposite c = liftFC $ SetComposite c unit

setAlpha :: Number -> Graphics Unit
setAlpha a = liftFC $ SetAlpha a unit

beginPath :: Graphics Unit
beginPath = liftFC $ BeginPath unit

stroke :: Graphics Unit
stroke = liftFC $ Stroke unit

fill :: Graphics Unit
fill = liftFC $ Fill unit

clip :: Graphics Unit
clip = liftFC $ Clip unit

lineTo :: Number -> Number -> Graphics Unit
lineTo x y = liftFC $ LineTo x y unit

moveTo :: Number -> Number -> Graphics Unit
moveTo x y = liftFC $ MoveTo x y unit

closePath :: Graphics Unit
closePath = liftFC $ ClosePath unit

arc :: C.Arc -> Graphics Unit
arc a = liftFC $ Arc a unit

rect :: C.Rectangle -> Graphics Unit
rect r = liftFC $ Rect r unit

clearRect :: C.Rectangle -> Graphics Unit
clearRect r = liftFC $ ClearRect r unit

scale :: Number -> Number -> Graphics Unit
scale sx sy = liftFC $ Scale sx sy unit

rotate :: Number -> Graphics Unit
rotate th = liftFC $ Rotate th unit

translate :: Number -> Number -> Graphics Unit
translate tx ty = liftFC $ Translate tx ty unit

transform :: C.Transform -> Graphics Unit
transform tx = liftFC $ Transform tx unit

setFont :: String -> Graphics Unit
setFont f = liftFC $ SetFont f unit

fillText :: String -> Number -> Number -> Graphics Unit
fillText s x y = liftFC $ FillText s x y unit

strokeText :: String -> Number -> Number -> Graphics Unit
strokeText s x y = liftFC $ StrokeText s x y unit

measureText :: String -> Graphics C.TextMetrics
measureText s = liftFC $ MeasureText s id

save :: Graphics Unit
save = liftFC $ Save unit

restore :: Graphics Unit
restore = liftFC $ Restore unit

getImageData :: Number -> Number -> Number -> Number -> Graphics C.ImageData
getImageData x y w h = liftFC $ GetImageData x y w h id

putImageData :: C.ImageData -> Number -> Number -> Graphics Unit
putImageData d x y = liftFC $ PutImageData d x y unit

runGraphics :: forall a eff. C.Context2D -> Graphics a -> Eff (canvas :: C.Canvas | eff) a
runGraphics ctx = runFreeCM interp
  where
  interp :: forall eff. Natural GraphicsF (Eff (canvas :: C.Canvas | eff))
  interp (SetLineWidth w a) = const a <$> C.setLineWidth w ctx
  interp (SetFillStyle s a) = const a <$> C.setFillStyle s ctx
  interp (SetStrokeStyle s a) = const a <$> C.setStrokeStyle s ctx
  interp (SetShadowColor c a) = const a <$> C.setShadowColor c ctx
  interp (SetShadowBlur n a) = const a <$> C.setShadowBlur n ctx
  interp (SetShadowOffsetX n a) = const a <$> C.setShadowOffsetX n ctx
  interp (SetShadowOffsetY n a) = const a <$> C.setShadowOffsetY n ctx
  interp (SetLineCap lc a) = const a <$> C.setLineCap lc ctx
  interp (SetComposite c a) = const a <$> C.setGlobalCompositeOperation ctx c
  interp (SetAlpha s a) = const a <$> C.setGlobalAlpha ctx s
  interp (BeginPath a) = const a <$> C.beginPath ctx
  interp (Stroke a) = const a <$> C.stroke ctx
  interp (Fill a) = const a <$> C.fill ctx
  interp (Clip a) = const a <$> C.clip ctx
  interp (LineTo x y a) = const a <$> C.lineTo ctx x y
  interp (MoveTo x y a) = const a <$> C.moveTo ctx x y
  interp (ClosePath a) = const a <$> C.closePath ctx
  interp (Arc arc a) = const a <$> C.arc ctx arc
  interp (Rect r a) = const a <$> C.rect ctx r
  interp (ClearRect r a) = const a <$> C.clearRect ctx r
  interp (Scale sx sy a) = const a <$> C.scale { scaleX: sx, scaleY: sy } ctx
  interp (Rotate th a) = const a <$> C.rotate th ctx
  interp (Translate tx ty a) = const a <$> C.translate { translateX: tx, translateY: ty } ctx
  interp (Transform tx a) = const a <$> C.transform tx ctx
  interp (SetFont f a) = const a <$> C.setFont f ctx
  interp (FillText s x y a) = const a <$> C.fillText ctx s x y
  interp (StrokeText s x y a) = const a <$> C.strokeText ctx s x y
  interp (MeasureText s k) = k <$> C.measureText ctx s
  interp (Save a) = const a <$> C.save ctx
  interp (Restore a) = const a <$> C.restore ctx
  interp (GetImageData x y w h k) = k <$> C.getImageData ctx x y w h
  interp (PutImageData d x y a) = const a <$> C.putImageData ctx d x y


Apathize known scenario after hooks

Apathize known scenario after hooks

module Test.Feature.Scenario where

import Prelude

import Control.Apply ((*>))
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (message, throw)
import Data.Either (Either(..))
import Data.String (joinWith)
import Test.Feature.Log (sectionMsg, warnMsg)
import Test.Feature (logCurrentScreen)
import Test.Feature.Monad (Feature)
import Selenium.Monad (attempt, apathize)

type EpicTitle = String
type Hook eff o = Feature eff o
type ScenarioTitle = String
type KnownIssueUrl = String

scenario
  ∷ forall eff o
  .  EpicTitle
  → Hook eff o Unit
  → Hook eff o Unit
  → ScenarioTitle
  → Array KnownIssueUrl
  → Feature eff o Unit
  → Feature eff o Unit
scenario epic before after title knownIssues actions =
  sectionMsg title' *> before *> actions'
  where
  title' ∷ String
  title' = epic ++ ": " ++ title

  knownIssuesString ∷ String
  knownIssuesString = separate $ indent <$> knownIssues

  knownIssuesWarning ∷ String
  knownIssuesWarning = "These known issues caused this scenario to fail:\n" ++ knownIssuesString

  separate ∷ Array String → String
  separate = joinWith "\n"

  indent ∷ String → String
  indent s = "  " ++ s

  warning ∷ String → String
  warning s = "Warning: " ++ s

  warn ∷ String → Feature eff o Unit
  warn = warnMsg <<< warning

  unexpectedSuccess ∷ Feature eff o Unit
  unexpectedSuccess =
    warn
      $ "Ok despite known issues, if these issues are resolved please remove them\n"
      ++ knownIssuesString

  actions' ∷ Feature eff o Unit
  actions' | knownIssues == [] = do
    e <- attempt actions
    case e of
      Left e' → logCurrentScreen *> (liftEff $ throw $ message e')
      Right _ → after
  actions' = do
    e <- attempt actions
    case e of
      Left e' → logCurrentScreen *> warn (message e') *> warn knownIssuesWarning *> apathize after
      Right _ → after *> unexpectedSuccess

module Test.Feature.Scenario where

import Prelude

import Control.Apply ((*>))
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (message, throw)
import Data.Either (Either(..))
import Data.String (joinWith)
import Test.Feature.Log (sectionMsg, warnMsg)
import Test.Feature (logCurrentScreen)
import Test.Feature.Monad (Feature)
import Selenium.Monad (attempt)

type EpicTitle = String
type Hook eff o = Feature eff o
type ScenarioTitle = String
type KnownIssueUrl = String

scenario
  ∷ forall eff o
  .  EpicTitle
  → Hook eff o Unit
  → Hook eff o Unit
  → ScenarioTitle
  → Array KnownIssueUrl
  → Feature eff o Unit
  → Feature eff o Unit
scenario epic before after title knownIssues actions =
  sectionMsg title' *> before *> actions'
  where
  title' ∷ String
  title' = epic ++ ": " ++ title

  knownIssuesString ∷ String
  knownIssuesString = separate $ indent <$> knownIssues

  knownIssuesWarning ∷ String
  knownIssuesWarning = "These known issues caused this scenario to fail:\n" ++ knownIssuesString

  separate ∷ Array String → String
  separate = joinWith "\n"

  indent ∷ String → String
  indent s = "  " ++ s

  warning ∷ String → String
  warning s = "Warning: " ++ s

  warn ∷ String → Feature eff o Unit
  warn = warnMsg <<< warning

  unexpectedSuccess ∷ Feature eff o Unit
  unexpectedSuccess =
    warn
      $ "Ok despite known issues, if these issues are resolved please remove them\n"
      ++ knownIssuesString

  actions' ∷ Feature eff o Unit
  actions' | knownIssues == [] = do
    e <- attempt actions
    case e of
      Left e' → logCurrentScreen *> (liftEff $ throw $ message e')
      Right _ → after
  actions' = do
    e <- attempt actions
    case e of
      Left e' → logCurrentScreen *> warn (message e') *> warn knownIssuesWarning *> after
      Right _ → after *> unexpectedSuccess