simplify pop code

simplify pop code

-- | This module defines a type of maps as balanced 2-3 trees, based on
-- | <http://www.cs.princeton.edu/~dpw/courses/cos326-12/ass/2-3-trees.pdf>

module Data.Map
  ( Map
  , showTree
  , empty
  , isEmpty
  , singleton
  , checkValid
  , insert
  , lookup
  , lookupLE
  , lookupLT
  , lookupGE
  , lookupGT
  , findMin
  , findMax
  , fromFoldable
  , fromFoldableWith
  , toUnfoldable
  , toAscUnfoldable
  , delete
  , pop
  , member
  , alter
  , update
  , keys
  , values
  , union
  , unionWith
  , unions
  , size
  , mapWithKey
  ) where

import Prelude
import Data.Eq (class Eq1)
import Data.Foldable (foldl, foldMap, foldr, class Foldable)
import Data.List (List(..), (:), length, nub)
import Data.Maybe (Maybe(..), maybe, isJust, fromMaybe)
import Data.Monoid (class Monoid)
import Data.Ord (class Ord1)
import Data.Traversable (traverse, class Traversable)
import Data.Tuple (Tuple(Tuple), snd)
import Data.Unfoldable (class Unfoldable, unfoldr)
import Partial.Unsafe (unsafePartial)

-- | `Map k v` represents maps from keys of type `k` to values of type `v`.
data Map k v
  = Leaf
  | Two (Map k v) k v (Map k v)
  | Three (Map k v) k v (Map k v) k v (Map k v)

-- Internal use
toAscArray :: forall k v. Map k v -> Array (Tuple k v)
toAscArray = toAscUnfoldable

instance eq1Map :: Eq k => Eq1 (Map k) where
  eq1 = eq

instance eqMap :: (Eq k, Eq v) => Eq (Map k v) where
  eq m1 m2 = toAscArray m1 == toAscArray m2

instance ord1Map :: Ord k => Ord1 (Map k) where
  compare1 = compare

instance ordMap :: (Ord k, Ord v) => Ord (Map k v) where
  compare m1 m2 = compare (toAscArray m1) (toAscArray m2)

instance showMap :: (Show k, Show v) => Show (Map k v) where
  show m = "(fromFoldable " <> show (toAscArray m) <> ")"

instance semigroupMap :: Ord k => Semigroup (Map k v) where
  append = union

instance monoidMap :: Ord k => Monoid (Map k v) where
  mempty = empty

instance functorMap :: Functor (Map k) where
  map _ Leaf = Leaf
  map f (Two left k v right) = Two (map f left) k (f v) (map f right)
  map f (Three left k1 v1 mid k2 v2 right) = Three (map f left) k1 (f v1) (map f mid) k2 (f v2) (map f right)

instance foldableMap :: Foldable (Map k) where
  foldl   f z m = foldl   f z (values m)
  foldr   f z m = foldr   f z (values m)
  foldMap f   m = foldMap f   (values m)

instance traversableMap :: Traversable (Map k) where
  traverse f Leaf = pure Leaf
  traverse f (Two left k v right) =
    Two <$> traverse f left
        <*> pure k
        <*> f v
        <*> traverse f right
  traverse f (Three left k1 v1 mid k2 v2 right) =
    Three <$> traverse f left
          <*> pure k1
          <*> f v1
          <*> traverse f mid
          <*> pure k2
          <*> f v2
          <*> traverse f right
  sequence = traverse id

-- | Render a `Map` as a `String`
showTree :: forall k v. Show k => Show v => Map k v -> String
showTree Leaf = "Leaf"
showTree (Two left k v right) =
  "Two (" <> showTree left <>
  ") (" <> show k <>
  ") (" <> show v <>
  ") (" <> showTree right <> ")"
showTree (Three left k1 v1 mid k2 v2 right) =
  "Three (" <> showTree left <>
  ") (" <> show k1 <>
  ") (" <> show v1 <>
  ") (" <> showTree mid <>
  ") (" <> show k2 <>
  ") (" <> show v2 <>
  ") (" <> showTree right <> ")"

-- | An empty map
empty :: forall k v. Map k v
empty = Leaf

-- | Test if a map is empty
isEmpty :: forall k v. Map k v -> Boolean
isEmpty Leaf = true
isEmpty _ = false

-- | Create a map with one key/value pair
singleton :: forall k v. k -> v -> Map k v
singleton k v = Two Leaf k v Leaf

-- | Check whether the underlying tree satisfies the 2-3 invariant
-- |
-- | This function is provided for internal use.
checkValid :: forall k v. Map k v -> Boolean
checkValid tree = length (nub (allHeights tree)) == one
  where
  allHeights :: Map k v -> List Int
  allHeights Leaf = pure zero
  allHeights (Two left _ _ right) = map (\n -> n + one) (allHeights left <> allHeights right)
  allHeights (Three left _ _ mid _ _ right) = map (\n -> n + one) (allHeights left <> allHeights mid <> allHeights right)

-- | Lookup a value for the specified key
lookup :: forall k v. Ord k => k -> Map k v -> Maybe v
lookup = unsafePartial \k tree ->
  case tree of
    Leaf -> Nothing
    _ ->
      let comp :: k -> k -> Ordering
          comp = compare
      in case tree of
        Two left k1 v right ->
          case comp k k1 of
            EQ -> Just v
            LT -> lookup k left
            _  -> lookup k right
        Three left k1 v1 mid k2 v2 right ->
          case comp k k1 of
            EQ -> Just v1
            c1 ->
              case c1, comp k k2 of
                _ , EQ -> Just v2
                LT, _  -> lookup k left
                _ , GT -> lookup k right
                _ , _  -> lookup k mid

-- | Lookup a value for the specified key, or the greatest one less than it
lookupLE :: forall k v. Ord k => k -> Map k v -> Maybe { key :: k, value :: v }
lookupLE _ Leaf = Nothing
lookupLE k (Two left k1 v1 right) = case compare k k1 of
  EQ -> Just { key: k1, value: v1 }
  GT -> Just $ fromMaybe { key: k1, value: v1 } $ lookupLE k right
  LT -> lookupLE k left
lookupLE k (Three left k1 v1 mid k2 v2 right) = case compare k k2 of
  EQ -> Just { key: k2, value: v2 }
  GT -> Just $ fromMaybe { key: k2, value: v2 } $ lookupLE k right
  LT -> lookupLE k $ Two left k1 v1 mid

-- | Lookup a value for the greatest key less than the specified key
lookupLT :: forall k v. Ord k => k -> Map k v -> Maybe { key :: k, value :: v }
lookupLT _ Leaf = Nothing
lookupLT k (Two left k1 v1 right) = case compare k k1 of
  EQ -> findMax left
  GT -> Just $ fromMaybe { key: k1, value: v1 } $ lookupLT k right
  LT -> lookupLT k left
lookupLT k (Three left k1 v1 mid k2 v2 right) = case compare k k2 of
  EQ -> findMax $ Two left k1 v1 mid
  GT -> Just $ fromMaybe { key: k2, value: v2 } $ lookupLT k right
  LT -> lookupLT k $ Two left k1 v1 mid

-- | Lookup a value for the specified key, or the least one greater than it
lookupGE :: forall k v. Ord k => k -> Map k v -> Maybe { key :: k, value :: v }
lookupGE _ Leaf = Nothing
lookupGE k (Two left k1 v1 right) = case compare k k1 of
  EQ -> Just { key: k1, value: v1 }
  LT -> Just $ fromMaybe { key: k1, value: v1 } $ lookupGE k left
  GT -> lookupGE k right
lookupGE k (Three left k1 v1 mid k2 v2 right) = case compare k k1 of
  EQ -> Just { key: k1, value: v1 }
  LT -> Just $ fromMaybe { key: k1, value: v1 } $ lookupGE k left
  GT -> lookupGE k $ Two mid k2 v2 right

-- | Lookup a value for the least key greater than the specified key
lookupGT :: forall k v. Ord k => k -> Map k v -> Maybe { key :: k, value :: v }
lookupGT _ Leaf = Nothing
lookupGT k (Two left k1 v1 right) = case compare k k1 of
  EQ -> findMin right
  LT -> Just $ fromMaybe { key: k1, value: v1 } $ lookupGT k left
  GT -> lookupGT k right
lookupGT k (Three left k1 v1 mid k2 v2 right) = case compare k k1 of
  EQ -> findMin $ Two mid k2 v2 right
  LT -> Just $ fromMaybe { key: k1, value: v1 } $ lookupGT k left
  GT -> lookupGT k $ Two mid k2 v2 right

-- | Returns the pair with the greatest key
findMax :: forall k v. Map k v -> Maybe { key :: k, value :: v }
findMax Leaf = Nothing
findMax (Two _ k1 v1 right) = Just $ fromMaybe { key: k1, value: v1 } $ findMax right
findMax (Three _ _ _ _ k2 v2 right) = Just $ fromMaybe { key: k2, value: v2 } $ findMax right

-- | Returns the pair with the least key
findMin :: forall k v. Map k v -> Maybe { key :: k, value :: v }
findMin Leaf = Nothing
findMin (Two left k1 v1 _) = Just $ fromMaybe { key: k1, value: v1 } $ findMin left
findMin (Three left k1 v1 _ _ _ _) = Just $ fromMaybe { key: k1, value: v1 } $ findMin left

-- | Test if a key is a member of a map
member :: forall k v. Ord k => k -> Map k v -> Boolean
member k m = isJust (k `lookup` m)

data TreeContext k v
  = TwoLeft k v (Map k v)
  | TwoRight (Map k v) k v
  | ThreeLeft k v (Map k v) k v (Map k v)
  | ThreeMiddle (Map k v) k v k v (Map k v)
  | ThreeRight (Map k v) k v (Map k v) k v

fromZipper :: forall k v. Ord k => List (TreeContext k v) -> Map k v -> Map k v
fromZipper Nil tree = tree
fromZipper (Cons x ctx) tree =
  case x of
    TwoLeft k1 v1 right -> fromZipper ctx (Two tree k1 v1 right)
    TwoRight left k1 v1 -> fromZipper ctx (Two left k1 v1 tree)
    ThreeLeft k1 v1 mid k2 v2 right -> fromZipper ctx (Three tree k1 v1 mid k2 v2 right)
    ThreeMiddle left k1 v1 k2 v2 right -> fromZipper ctx (Three left k1 v1 tree k2 v2 right)
    ThreeRight left k1 v1 mid k2 v2 -> fromZipper ctx (Three left k1 v1 mid k2 v2 tree)

data KickUp k v = KickUp (Map k v) k v (Map k v)

-- | Insert or replace a key/value pair in a map
insert :: forall k v. Ord k => k -> v -> Map k v -> Map k v
insert = down Nil
  where
  comp :: k -> k -> Ordering
  comp = compare

  down :: List (TreeContext k v) -> k -> v -> Map k v -> Map k v
  down ctx k v Leaf = up ctx (KickUp Leaf k v Leaf)
  down ctx k v (Two left k1 v1 right) =
    case comp k k1 of
      EQ -> fromZipper ctx (Two left k v right)
      LT -> down (Cons (TwoLeft k1 v1 right) ctx) k v left
      _  -> down (Cons (TwoRight left k1 v1) ctx) k v right
  down ctx k v (Three left k1 v1 mid k2 v2 right) =
    case comp k k1 of
      EQ -> fromZipper ctx (Three left k v mid k2 v2 right)
      c1 ->
        case c1, comp k k2 of
          _ , EQ -> fromZipper ctx (Three left k1 v1 mid k v right)
          LT, _  -> down (Cons (ThreeLeft k1 v1 mid k2 v2 right) ctx) k v left
          GT, LT -> down (Cons (ThreeMiddle left k1 v1 k2 v2 right) ctx) k v mid
          _ , _  -> down (Cons (ThreeRight left k1 v1 mid k2 v2) ctx) k v right

  up :: List (TreeContext k v) -> KickUp k v -> Map k v
  up Nil (KickUp left k v right) = Two left k v right
  up (Cons x ctx) kup =
    case x, kup of
      TwoLeft k1 v1 right, KickUp left k v mid -> fromZipper ctx (Three left k v mid k1 v1 right)
      TwoRight left k1 v1, KickUp mid k v right -> fromZipper ctx (Three left k1 v1 mid k v right)
      ThreeLeft k1 v1 c k2 v2 d, KickUp a k v b -> up ctx (KickUp (Two a k v b) k1 v1 (Two c k2 v2 d))
      ThreeMiddle a k1 v1 k2 v2 d, KickUp b k v c -> up ctx (KickUp (Two a k1 v1 b) k v (Two c k2 v2 d))
      ThreeRight a k1 v1 b k2 v2, KickUp c k v d -> up ctx (KickUp (Two a k1 v1 b) k2 v2 (Two c k v d))

-- | Delete a key and its corresponding value from a map.
delete :: forall k v. Ord k => k -> Map k v -> Map k v
delete k m = maybe m snd (pop k m)

-- | Delete a key and its corresponding value from a map, returning the value
-- | as well as the subsequent map.
pop :: forall k v. Ord k => k -> Map k v -> Maybe (Tuple v (Map k v))
pop k = down Nil
  where
  comp :: k -> k -> Ordering
  comp = compare

  down :: List (TreeContext k v) -> Map k v -> Maybe (Tuple v (Map k v))
  down = unsafePartial \ctx m -> case m of
    Leaf -> Nothing
    Two left k1 v1 right ->
      case right, comp k k1 of
        Leaf, EQ -> Just (Tuple v1 (up ctx Leaf))
        _   , EQ -> let max = maxNode left
                     in Just (Tuple v1 (removeMaxNode (Cons (TwoLeft max.key max.value right) ctx) left))
        _   , LT -> down (Cons (TwoLeft k1 v1 right) ctx) left
        _   , _  -> down (Cons (TwoRight left k1 v1) ctx) right
    Three left k1 v1 mid k2 v2 right ->
      let leaves =
            case left, mid, right of
              Leaf, Leaf, Leaf -> true
              _   , _   , _    -> false
      in case leaves, comp k k1, comp k k2 of
        true, EQ, _  -> Just (Tuple v1 (fromZipper ctx (Two Leaf k2 v2 Leaf)))
        true, _ , EQ -> Just (Tuple v2 (fromZipper ctx (Two Leaf k1 v1 Leaf)))
        _   , EQ, _  -> let max = maxNode left
                         in Just (Tuple v1 (removeMaxNode (Cons (ThreeLeft max.key max.value mid k2 v2 right) ctx) left))
        _   , _ , EQ -> let max = maxNode mid
                         in Just (Tuple v2 (removeMaxNode (Cons (ThreeMiddle left k1 v1 max.key max.value right) ctx) mid))
        _   , LT, _  -> down (Cons (ThreeLeft k1 v1 mid k2 v2 right) ctx) left
        _   , GT, LT -> down (Cons (ThreeMiddle left k1 v1 k2 v2 right) ctx) mid
        _   , _ , _  -> down (Cons (ThreeRight left k1 v1 mid k2 v2) ctx) right

  up :: List (TreeContext k v) -> Map k v -> Map k v
  up = unsafePartial \ctxs tree ->
    case ctxs of
      Nil -> tree
      Cons x ctx ->
        case x, tree of
          TwoLeft k1 v1 Leaf, Leaf -> fromZipper ctx (Two Leaf k1 v1 Leaf)
          TwoRight Leaf k1 v1, Leaf -> fromZipper ctx (Two Leaf k1 v1 Leaf)
          TwoLeft k1 v1 (Two m k2 v2 r), l -> up ctx (Three l k1 v1 m k2 v2 r)
          TwoRight (Two l k1 v1 m) k2 v2, r -> up ctx (Three l k1 v1 m k2 v2 r)
          TwoLeft k1 v1 (Three b k2 v2 c k3 v3 d), a -> fromZipper ctx (Two (Two a k1 v1 b) k2 v2 (Two c k3 v3 d))
          TwoRight (Three a k1 v1 b k2 v2 c) k3 v3, d -> fromZipper ctx (Two (Two a k1 v1 b) k2 v2 (Two c k3 v3 d))
          ThreeLeft k1 v1 Leaf k2 v2 Leaf, Leaf -> fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf)
          ThreeMiddle Leaf k1 v1 k2 v2 Leaf, Leaf -> fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf)
          ThreeRight Leaf k1 v1 Leaf k2 v2, Leaf -> fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf)
          ThreeLeft k1 v1 (Two b k2 v2 c) k3 v3 d, a -> fromZipper ctx (Two (Three a k1 v1 b k2 v2 c) k3 v3 d)
          ThreeMiddle (Two a k1 v1 b) k2 v2 k3 v3 d, c -> fromZipper ctx (Two (Three a k1 v1 b k2 v2 c) k3 v3 d)
          ThreeMiddle a k1 v1 k2 v2 (Two c k3 v3 d), b -> fromZipper ctx (Two a k1 v1 (Three b k2 v2 c k3 v3 d))
          ThreeRight a k1 v1 (Two b k2 v2 c) k3 v3, d -> fromZipper ctx (Two a k1 v1 (Three b k2 v2 c k3 v3 d))
          ThreeLeft k1 v1 (Three b k2 v2 c k3 v3 d) k4 v4 e, a -> fromZipper ctx (Three (Two a k1 v1 b) k2 v2 (Two c k3 v3 d) k4 v4 e)
          ThreeMiddle (Three a k1 v1 b k2 v2 c) k3 v3 k4 v4 e, d -> fromZipper ctx (Three (Two a k1 v1 b) k2 v2 (Two c k3 v3 d) k4 v4 e)
          ThreeMiddle a k1 v1 k2 v2 (Three c k3 v3 d k4 v4 e), b -> fromZipper ctx (Three a k1 v1 (Two b k2 v2 c) k3 v3 (Two d k4 v4 e))
          ThreeRight a k1 v1 (Three b k2 v2 c k3 v3 d) k4 v4, e -> fromZipper ctx (Three a k1 v1 (Two b k2 v2 c) k3 v3 (Two d k4 v4 e))

  maxNode :: Map k v -> { key :: k, value :: v }
  maxNode = unsafePartial \m -> case m of
    Two _ k' v Leaf -> { key: k', value: v }
    Two _ _ _ right -> maxNode right
    Three _ _ _ _ k' v Leaf -> { key: k', value: v }
    Three _ _ _ _ _ _ right -> maxNode right

  removeMaxNode :: List (TreeContext k v) -> Map k v -> Map k v
  removeMaxNode = unsafePartial \ctx m ->
    case m of
      Two Leaf _ _ Leaf -> up ctx Leaf
      Two left k' v right -> removeMaxNode (Cons (TwoRight left k' v) ctx) right
      Three Leaf k1 v1 Leaf _ _ Leaf -> up (Cons (TwoRight Leaf k1 v1) ctx) Leaf
      Three left k1 v1 mid k2 v2 right -> removeMaxNode (Cons (ThreeRight left k1 v1 mid k2 v2) ctx) right

-- | Insert the value, delete a value, or update a value for a key in a map
alter :: forall k v. Ord k => (Maybe v -> Maybe v) -> k -> Map k v -> Map k v
alter f k m = case f (k `lookup` m) of
  Nothing -> delete k m
  Just v -> insert k v m

-- | Update or delete the value for a key in a map
update :: forall k v. Ord k => (v -> Maybe v) -> k -> Map k v -> Map k v
update f k m = alter (maybe Nothing f) k m

-- | Convert any foldable collection of key/value pairs to a map.
-- | On key collision, later values take precedence over earlier ones.
fromFoldable :: forall f k v. Ord k => Foldable f => f (Tuple k v) -> Map k v
fromFoldable = foldl (\m (Tuple k v) -> insert k v m) empty

-- | Convert any foldable collection of key/value pairs to a map.
-- | On key collision, the values are configurably combined.
fromFoldableWith :: forall f k v. Ord k => Foldable f => (v -> v -> v) -> f (Tuple k v) -> Map k v
fromFoldableWith f = foldl (\m (Tuple k v) -> alter (combine v) k m) empty where
  combine v (Just v') = Just $ f v v'
  combine v Nothing = Just v

-- | Convert a map to an unfoldable structure of key/value pairs
toUnfoldable :: forall f k v. Unfoldable f => Map k v -> f (Tuple k v)
toUnfoldable m = unfoldr go (m : Nil) where
  go Nil = Nothing
  go (hd : tl) = case hd of
    Leaf -> go tl
    Two left k v right ->
      Just $ Tuple (Tuple k v) (left : right : tl)
    Three left k1 v1 mid k2 v2 right ->
      Just $ Tuple (Tuple k1 v1) (singleton k2 v2 : left : mid : right : tl)

-- | Convert a map to an unfoldable structure of key/value pairs where the keys are in ascending order
toAscUnfoldable :: forall f k v. Unfoldable f => Map k v -> f (Tuple k v)
toAscUnfoldable m = unfoldr go (m : Nil) where
  go Nil = Nothing
  go (hd : tl) = case hd of
    Leaf -> go tl
    Two Leaf k v Leaf ->
      Just $ Tuple (Tuple k v) tl
    Two Leaf k v right ->
      Just $ Tuple (Tuple k v) (right : tl)
    Two left k v right ->
      go $ left : singleton k v : right : tl
    Three left k1 v1 mid k2 v2 right ->
      go $ left : singleton k1 v1 : mid : singleton k2 v2 : right : tl

-- | Get a list of the keys contained in a map
keys :: forall k v. Map k v -> List k
keys Leaf = Nil
keys (Two left k _ right) = keys left <> pure k <> keys right
keys (Three left k1 _ mid k2 _ right) = keys left <> pure k1 <> keys mid <> pure k2 <> keys right

-- | Get a list of the values contained in a map
values :: forall k v. Map k v -> List v
values Leaf = Nil
values (Two left _ v right) = values left <> pure v <> values right
values (Three left _ v1 mid _ v2 right) = values left <> pure v1 <> values mid <> pure v2 <> values right

-- | Compute the union of two maps, using the specified function
-- | to combine values for duplicate keys.
unionWith :: forall k v. Ord k => (v -> v -> v) -> Map k v -> Map k v -> Map k v
unionWith f m1 m2 = foldl go m2 (toUnfoldable m1 :: List (Tuple k v))
  where
  go m (Tuple k v) = alter (Just <<< maybe v (f v)) k m

-- | Compute the union of two maps, preferring values from the first map in the case
-- | of duplicate keys
union :: forall k v. Ord k => Map k v -> Map k v -> Map k v
union = unionWith const

-- | Compute the union of a collection of maps
unions :: forall k v f. Ord k => Foldable f => f (Map k v) -> Map k v
unions = foldl union empty

-- | Calculate the number of key/value pairs in a map
size :: forall k v. Map k v -> Int
size = length <<< values

-- | Apply a function of two arguments to each key/value pair, producing a new map
mapWithKey :: forall k v v'. (k -> v -> v') -> Map k v -> Map k v'
mapWithKey _ Leaf = Leaf
mapWithKey f (Two left k v right) = Two (mapWithKey f left) k (f k v) (mapWithKey f right)
mapWithKey f (Three left k1 v1 mid k2 v2 right) = Three (mapWithKey f left) k1 (f k1 v1) (mapWithKey f mid) k2 (f k2 v2) (mapWithKey f right)

-- | This module defines a type of maps as balanced 2-3 trees, based on
-- | <http://www.cs.princeton.edu/~dpw/courses/cos326-12/ass/2-3-trees.pdf>

module Data.Map
  ( Map
  , showTree
  , empty
  , isEmpty
  , singleton
  , checkValid
  , insert
  , lookup
  , lookupLE
  , lookupLT
  , lookupGE
  , lookupGT
  , findMin
  , findMax
  , fromFoldable
  , fromFoldableWith
  , toUnfoldable
  , toAscUnfoldable
  , delete
  , pop
  , member
  , alter
  , update
  , keys
  , values
  , union
  , unionWith
  , unions
  , size
  , mapWithKey
  ) where

import Prelude
import Data.Eq (class Eq1)
import Data.Foldable (foldl, foldMap, foldr, class Foldable)
import Data.List (List(..), (:), length, nub)
import Data.Maybe (Maybe(..), maybe, isJust, fromMaybe)
import Data.Monoid (class Monoid)
import Data.Ord (class Ord1)
import Data.Traversable (traverse, class Traversable)
import Data.Tuple (Tuple(Tuple), snd)
import Data.Unfoldable (class Unfoldable, unfoldr)
import Partial.Unsafe (unsafePartial)

-- | `Map k v` represents maps from keys of type `k` to values of type `v`.
data Map k v
  = Leaf
  | Two (Map k v) k v (Map k v)
  | Three (Map k v) k v (Map k v) k v (Map k v)

-- Internal use
toAscArray :: forall k v. Map k v -> Array (Tuple k v)
toAscArray = toAscUnfoldable

instance eq1Map :: Eq k => Eq1 (Map k) where
  eq1 = eq

instance eqMap :: (Eq k, Eq v) => Eq (Map k v) where
  eq m1 m2 = toAscArray m1 == toAscArray m2

instance ord1Map :: Ord k => Ord1 (Map k) where
  compare1 = compare

instance ordMap :: (Ord k, Ord v) => Ord (Map k v) where
  compare m1 m2 = compare (toAscArray m1) (toAscArray m2)

instance showMap :: (Show k, Show v) => Show (Map k v) where
  show m = "(fromFoldable " <> show (toAscArray m) <> ")"

instance semigroupMap :: Ord k => Semigroup (Map k v) where
  append = union

instance monoidMap :: Ord k => Monoid (Map k v) where
  mempty = empty

instance functorMap :: Functor (Map k) where
  map _ Leaf = Leaf
  map f (Two left k v right) = Two (map f left) k (f v) (map f right)
  map f (Three left k1 v1 mid k2 v2 right) = Three (map f left) k1 (f v1) (map f mid) k2 (f v2) (map f right)

instance foldableMap :: Foldable (Map k) where
  foldl   f z m = foldl   f z (values m)
  foldr   f z m = foldr   f z (values m)
  foldMap f   m = foldMap f   (values m)

instance traversableMap :: Traversable (Map k) where
  traverse f Leaf = pure Leaf
  traverse f (Two left k v right) =
    Two <$> traverse f left
        <*> pure k
        <*> f v
        <*> traverse f right
  traverse f (Three left k1 v1 mid k2 v2 right) =
    Three <$> traverse f left
          <*> pure k1
          <*> f v1
          <*> traverse f mid
          <*> pure k2
          <*> f v2
          <*> traverse f right
  sequence = traverse id

-- | Render a `Map` as a `String`
showTree :: forall k v. Show k => Show v => Map k v -> String
showTree Leaf = "Leaf"
showTree (Two left k v right) =
  "Two (" <> showTree left <>
  ") (" <> show k <>
  ") (" <> show v <>
  ") (" <> showTree right <> ")"
showTree (Three left k1 v1 mid k2 v2 right) =
  "Three (" <> showTree left <>
  ") (" <> show k1 <>
  ") (" <> show v1 <>
  ") (" <> showTree mid <>
  ") (" <> show k2 <>
  ") (" <> show v2 <>
  ") (" <> showTree right <> ")"

-- | An empty map
empty :: forall k v. Map k v
empty = Leaf

-- | Test if a map is empty
isEmpty :: forall k v. Map k v -> Boolean
isEmpty Leaf = true
isEmpty _ = false

-- | Create a map with one key/value pair
singleton :: forall k v. k -> v -> Map k v
singleton k v = Two Leaf k v Leaf

-- | Check whether the underlying tree satisfies the 2-3 invariant
-- |
-- | This function is provided for internal use.
checkValid :: forall k v. Map k v -> Boolean
checkValid tree = length (nub (allHeights tree)) == one
  where
  allHeights :: Map k v -> List Int
  allHeights Leaf = pure zero
  allHeights (Two left _ _ right) = map (\n -> n + one) (allHeights left <> allHeights right)
  allHeights (Three left _ _ mid _ _ right) = map (\n -> n + one) (allHeights left <> allHeights mid <> allHeights right)

-- | Lookup a value for the specified key
lookup :: forall k v. Ord k => k -> Map k v -> Maybe v
lookup = unsafePartial \k tree ->
  case tree of
    Leaf -> Nothing
    _ ->
      let comp :: k -> k -> Ordering
          comp = compare
      in case tree of
        Two left k1 v right ->
          case comp k k1 of
            EQ -> Just v
            LT -> lookup k left
            _  -> lookup k right
        Three left k1 v1 mid k2 v2 right ->
          case comp k k1 of
            EQ -> Just v1
            c1 ->
              case c1, comp k k2 of
                _ , EQ -> Just v2
                LT, _  -> lookup k left
                _ , GT -> lookup k right
                _ , _  -> lookup k mid

-- | Lookup a value for the specified key, or the greatest one less than it
lookupLE :: forall k v. Ord k => k -> Map k v -> Maybe { key :: k, value :: v }
lookupLE _ Leaf = Nothing
lookupLE k (Two left k1 v1 right) = case compare k k1 of
  EQ -> Just { key: k1, value: v1 }
  GT -> Just $ fromMaybe { key: k1, value: v1 } $ lookupLE k right
  LT -> lookupLE k left
lookupLE k (Three left k1 v1 mid k2 v2 right) = case compare k k2 of
  EQ -> Just { key: k2, value: v2 }
  GT -> Just $ fromMaybe { key: k2, value: v2 } $ lookupLE k right
  LT -> lookupLE k $ Two left k1 v1 mid

-- | Lookup a value for the greatest key less than the specified key
lookupLT :: forall k v. Ord k => k -> Map k v -> Maybe { key :: k, value :: v }
lookupLT _ Leaf = Nothing
lookupLT k (Two left k1 v1 right) = case compare k k1 of
  EQ -> findMax left
  GT -> Just $ fromMaybe { key: k1, value: v1 } $ lookupLT k right
  LT -> lookupLT k left
lookupLT k (Three left k1 v1 mid k2 v2 right) = case compare k k2 of
  EQ -> findMax $ Two left k1 v1 mid
  GT -> Just $ fromMaybe { key: k2, value: v2 } $ lookupLT k right
  LT -> lookupLT k $ Two left k1 v1 mid

-- | Lookup a value for the specified key, or the least one greater than it
lookupGE :: forall k v. Ord k => k -> Map k v -> Maybe { key :: k, value :: v }
lookupGE _ Leaf = Nothing
lookupGE k (Two left k1 v1 right) = case compare k k1 of
  EQ -> Just { key: k1, value: v1 }
  LT -> Just $ fromMaybe { key: k1, value: v1 } $ lookupGE k left
  GT -> lookupGE k right
lookupGE k (Three left k1 v1 mid k2 v2 right) = case compare k k1 of
  EQ -> Just { key: k1, value: v1 }
  LT -> Just $ fromMaybe { key: k1, value: v1 } $ lookupGE k left
  GT -> lookupGE k $ Two mid k2 v2 right

-- | Lookup a value for the least key greater than the specified key
lookupGT :: forall k v. Ord k => k -> Map k v -> Maybe { key :: k, value :: v }
lookupGT _ Leaf = Nothing
lookupGT k (Two left k1 v1 right) = case compare k k1 of
  EQ -> findMin right
  LT -> Just $ fromMaybe { key: k1, value: v1 } $ lookupGT k left
  GT -> lookupGT k right
lookupGT k (Three left k1 v1 mid k2 v2 right) = case compare k k1 of
  EQ -> findMin $ Two mid k2 v2 right
  LT -> Just $ fromMaybe { key: k1, value: v1 } $ lookupGT k left
  GT -> lookupGT k $ Two mid k2 v2 right

-- | Returns the pair with the greatest key
findMax :: forall k v. Map k v -> Maybe { key :: k, value :: v }
findMax Leaf = Nothing
findMax (Two _ k1 v1 right) = Just $ fromMaybe { key: k1, value: v1 } $ findMax right
findMax (Three _ _ _ _ k2 v2 right) = Just $ fromMaybe { key: k2, value: v2 } $ findMax right

-- | Returns the pair with the least key
findMin :: forall k v. Map k v -> Maybe { key :: k, value :: v }
findMin Leaf = Nothing
findMin (Two left k1 v1 _) = Just $ fromMaybe { key: k1, value: v1 } $ findMin left
findMin (Three left k1 v1 _ _ _ _) = Just $ fromMaybe { key: k1, value: v1 } $ findMin left

-- | Test if a key is a member of a map
member :: forall k v. Ord k => k -> Map k v -> Boolean
member k m = isJust (k `lookup` m)

data TreeContext k v
  = TwoLeft k v (Map k v)
  | TwoRight (Map k v) k v
  | ThreeLeft k v (Map k v) k v (Map k v)
  | ThreeMiddle (Map k v) k v k v (Map k v)
  | ThreeRight (Map k v) k v (Map k v) k v

fromZipper :: forall k v. Ord k => List (TreeContext k v) -> Map k v -> Map k v
fromZipper Nil tree = tree
fromZipper (Cons x ctx) tree =
  case x of
    TwoLeft k1 v1 right -> fromZipper ctx (Two tree k1 v1 right)
    TwoRight left k1 v1 -> fromZipper ctx (Two left k1 v1 tree)
    ThreeLeft k1 v1 mid k2 v2 right -> fromZipper ctx (Three tree k1 v1 mid k2 v2 right)
    ThreeMiddle left k1 v1 k2 v2 right -> fromZipper ctx (Three left k1 v1 tree k2 v2 right)
    ThreeRight left k1 v1 mid k2 v2 -> fromZipper ctx (Three left k1 v1 mid k2 v2 tree)

data KickUp k v = KickUp (Map k v) k v (Map k v)

-- | Insert or replace a key/value pair in a map
insert :: forall k v. Ord k => k -> v -> Map k v -> Map k v
insert = down Nil
  where
  comp :: k -> k -> Ordering
  comp = compare

  down :: List (TreeContext k v) -> k -> v -> Map k v -> Map k v
  down ctx k v Leaf = up ctx (KickUp Leaf k v Leaf)
  down ctx k v (Two left k1 v1 right) =
    case comp k k1 of
      EQ -> fromZipper ctx (Two left k v right)
      LT -> down (Cons (TwoLeft k1 v1 right) ctx) k v left
      _  -> down (Cons (TwoRight left k1 v1) ctx) k v right
  down ctx k v (Three left k1 v1 mid k2 v2 right) =
    case comp k k1 of
      EQ -> fromZipper ctx (Three left k v mid k2 v2 right)
      c1 ->
        case c1, comp k k2 of
          _ , EQ -> fromZipper ctx (Three left k1 v1 mid k v right)
          LT, _  -> down (Cons (ThreeLeft k1 v1 mid k2 v2 right) ctx) k v left
          GT, LT -> down (Cons (ThreeMiddle left k1 v1 k2 v2 right) ctx) k v mid
          _ , _  -> down (Cons (ThreeRight left k1 v1 mid k2 v2) ctx) k v right

  up :: List (TreeContext k v) -> KickUp k v -> Map k v
  up Nil (KickUp left k v right) = Two left k v right
  up (Cons x ctx) kup =
    case x, kup of
      TwoLeft k1 v1 right, KickUp left k v mid -> fromZipper ctx (Three left k v mid k1 v1 right)
      TwoRight left k1 v1, KickUp mid k v right -> fromZipper ctx (Three left k1 v1 mid k v right)
      ThreeLeft k1 v1 c k2 v2 d, KickUp a k v b -> up ctx (KickUp (Two a k v b) k1 v1 (Two c k2 v2 d))
      ThreeMiddle a k1 v1 k2 v2 d, KickUp b k v c -> up ctx (KickUp (Two a k1 v1 b) k v (Two c k2 v2 d))
      ThreeRight a k1 v1 b k2 v2, KickUp c k v d -> up ctx (KickUp (Two a k1 v1 b) k2 v2 (Two c k v d))

-- | Delete a key and its corresponding value from a map.
delete :: forall k v. Ord k => k -> Map k v -> Map k v
delete k m = maybe m snd (pop k m)

-- | Delete a key and its corresponding value from a map, returning the value
-- | as well as the subsequent map.
pop :: forall k v. Ord k => k -> Map k v -> Maybe (Tuple v (Map k v))
pop = down Nil
  where
  comp :: k -> k -> Ordering
  comp = compare

  down :: List (TreeContext k v) -> k -> Map k v -> Maybe (Tuple v (Map k v))
  down = unsafePartial \ctx k m -> case m of
    Leaf -> Nothing
    Two left k1 v1 right ->
      case right, comp k k1 of
        Leaf, EQ -> Just (Tuple v1 (up ctx Leaf))
        _   , EQ -> let max = maxNode left
                     in Just (Tuple v1 (removeMaxNode (Cons (TwoLeft max.key max.value right) ctx) left))
        _   , LT -> down (Cons (TwoLeft k1 v1 right) ctx) k left
        _   , _  -> down (Cons (TwoRight left k1 v1) ctx) k right
    Three left k1 v1 mid k2 v2 right ->
      let leaves =
            case left, mid, right of
              Leaf, Leaf, Leaf -> true
              _   , _   , _    -> false
      in case leaves, comp k k1, comp k k2 of
        true, EQ, _  -> Just (Tuple v1 (fromZipper ctx (Two Leaf k2 v2 Leaf)))
        true, _ , EQ -> Just (Tuple v2 (fromZipper ctx (Two Leaf k1 v1 Leaf)))
        _   , EQ, _  -> let max = maxNode left
                         in Just (Tuple v1 (removeMaxNode (Cons (ThreeLeft max.key max.value mid k2 v2 right) ctx) left))
        _   , _ , EQ -> let max = maxNode mid
                         in Just (Tuple v2 (removeMaxNode (Cons (ThreeMiddle left k1 v1 max.key max.value right) ctx) mid))
        _   , LT, _  -> down (Cons (ThreeLeft k1 v1 mid k2 v2 right) ctx) k left
        _   , GT, LT -> down (Cons (ThreeMiddle left k1 v1 k2 v2 right) ctx) k mid
        _   , _ , _  -> down (Cons (ThreeRight left k1 v1 mid k2 v2) ctx) k right

  up :: List (TreeContext k v) -> Map k v -> Map k v
  up = unsafePartial \ctxs tree ->
    case ctxs of
      Nil -> tree
      Cons x ctx ->
        case x, tree of
          TwoLeft k1 v1 Leaf, Leaf -> fromZipper ctx (Two Leaf k1 v1 Leaf)
          TwoRight Leaf k1 v1, Leaf -> fromZipper ctx (Two Leaf k1 v1 Leaf)
          TwoLeft k1 v1 (Two m k2 v2 r), l -> up ctx (Three l k1 v1 m k2 v2 r)
          TwoRight (Two l k1 v1 m) k2 v2, r -> up ctx (Three l k1 v1 m k2 v2 r)
          TwoLeft k1 v1 (Three b k2 v2 c k3 v3 d), a -> fromZipper ctx (Two (Two a k1 v1 b) k2 v2 (Two c k3 v3 d))
          TwoRight (Three a k1 v1 b k2 v2 c) k3 v3, d -> fromZipper ctx (Two (Two a k1 v1 b) k2 v2 (Two c k3 v3 d))
          ThreeLeft k1 v1 Leaf k2 v2 Leaf, Leaf -> fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf)
          ThreeMiddle Leaf k1 v1 k2 v2 Leaf, Leaf -> fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf)
          ThreeRight Leaf k1 v1 Leaf k2 v2, Leaf -> fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf)
          ThreeLeft k1 v1 (Two b k2 v2 c) k3 v3 d, a -> fromZipper ctx (Two (Three a k1 v1 b k2 v2 c) k3 v3 d)
          ThreeMiddle (Two a k1 v1 b) k2 v2 k3 v3 d, c -> fromZipper ctx (Two (Three a k1 v1 b k2 v2 c) k3 v3 d)
          ThreeMiddle a k1 v1 k2 v2 (Two c k3 v3 d), b -> fromZipper ctx (Two a k1 v1 (Three b k2 v2 c k3 v3 d))
          ThreeRight a k1 v1 (Two b k2 v2 c) k3 v3, d -> fromZipper ctx (Two a k1 v1 (Three b k2 v2 c k3 v3 d))
          ThreeLeft k1 v1 (Three b k2 v2 c k3 v3 d) k4 v4 e, a -> fromZipper ctx (Three (Two a k1 v1 b) k2 v2 (Two c k3 v3 d) k4 v4 e)
          ThreeMiddle (Three a k1 v1 b k2 v2 c) k3 v3 k4 v4 e, d -> fromZipper ctx (Three (Two a k1 v1 b) k2 v2 (Two c k3 v3 d) k4 v4 e)
          ThreeMiddle a k1 v1 k2 v2 (Three c k3 v3 d k4 v4 e), b -> fromZipper ctx (Three a k1 v1 (Two b k2 v2 c) k3 v3 (Two d k4 v4 e))
          ThreeRight a k1 v1 (Three b k2 v2 c k3 v3 d) k4 v4, e -> fromZipper ctx (Three a k1 v1 (Two b k2 v2 c) k3 v3 (Two d k4 v4 e))

  maxNode :: Map k v -> { key :: k, value :: v }
  maxNode = unsafePartial \m -> case m of
    Two _ k v Leaf -> { key: k, value: v }
    Two _ _ _ right -> maxNode right
    Three _ _ _ _ k v Leaf -> { key: k, value: v }
    Three _ _ _ _ _ _ right -> maxNode right

  removeMaxNode :: List (TreeContext k v) -> Map k v -> Map k v
  removeMaxNode = unsafePartial \ctx m ->
    case m of
      Two Leaf _ _ Leaf -> up ctx Leaf
      Two left k v right -> removeMaxNode (Cons (TwoRight left k v) ctx) right
      Three Leaf k1 v1 Leaf _ _ Leaf -> up (Cons (TwoRight Leaf k1 v1) ctx) Leaf
      Three left k1 v1 mid k2 v2 right -> removeMaxNode (Cons (ThreeRight left k1 v1 mid k2 v2) ctx) right

-- | Insert the value, delete a value, or update a value for a key in a map
alter :: forall k v. Ord k => (Maybe v -> Maybe v) -> k -> Map k v -> Map k v
alter f k m = case f (k `lookup` m) of
  Nothing -> delete k m
  Just v -> insert k v m

-- | Update or delete the value for a key in a map
update :: forall k v. Ord k => (v -> Maybe v) -> k -> Map k v -> Map k v
update f k m = alter (maybe Nothing f) k m

-- | Convert any foldable collection of key/value pairs to a map.
-- | On key collision, later values take precedence over earlier ones.
fromFoldable :: forall f k v. Ord k => Foldable f => f (Tuple k v) -> Map k v
fromFoldable = foldl (\m (Tuple k v) -> insert k v m) empty

-- | Convert any foldable collection of key/value pairs to a map.
-- | On key collision, the values are configurably combined.
fromFoldableWith :: forall f k v. Ord k => Foldable f => (v -> v -> v) -> f (Tuple k v) -> Map k v
fromFoldableWith f = foldl (\m (Tuple k v) -> alter (combine v) k m) empty where
  combine v (Just v') = Just $ f v v'
  combine v Nothing = Just v

-- | Convert a map to an unfoldable structure of key/value pairs
toUnfoldable :: forall f k v. Unfoldable f => Map k v -> f (Tuple k v)
toUnfoldable m = unfoldr go (m : Nil) where
  go Nil = Nothing
  go (hd : tl) = case hd of
    Leaf -> go tl
    Two left k v right ->
      Just $ Tuple (Tuple k v) (left : right : tl)
    Three left k1 v1 mid k2 v2 right ->
      Just $ Tuple (Tuple k1 v1) (singleton k2 v2 : left : mid : right : tl)

-- | Convert a map to an unfoldable structure of key/value pairs where the keys are in ascending order
toAscUnfoldable :: forall f k v. Unfoldable f => Map k v -> f (Tuple k v)
toAscUnfoldable m = unfoldr go (m : Nil) where
  go Nil = Nothing
  go (hd : tl) = case hd of
    Leaf -> go tl
    Two Leaf k v Leaf ->
      Just $ Tuple (Tuple k v) tl
    Two Leaf k v right ->
      Just $ Tuple (Tuple k v) (right : tl)
    Two left k v right ->
      go $ left : singleton k v : right : tl
    Three left k1 v1 mid k2 v2 right ->
      go $ left : singleton k1 v1 : mid : singleton k2 v2 : right : tl

-- | Get a list of the keys contained in a map
keys :: forall k v. Map k v -> List k
keys Leaf = Nil
keys (Two left k _ right) = keys left <> pure k <> keys right
keys (Three left k1 _ mid k2 _ right) = keys left <> pure k1 <> keys mid <> pure k2 <> keys right

-- | Get a list of the values contained in a map
values :: forall k v. Map k v -> List v
values Leaf = Nil
values (Two left _ v right) = values left <> pure v <> values right
values (Three left _ v1 mid _ v2 right) = values left <> pure v1 <> values mid <> pure v2 <> values right

-- | Compute the union of two maps, using the specified function
-- | to combine values for duplicate keys.
unionWith :: forall k v. Ord k => (v -> v -> v) -> Map k v -> Map k v -> Map k v
unionWith f m1 m2 = foldl go m2 (toUnfoldable m1 :: List (Tuple k v))
  where
  go m (Tuple k v) = alter (Just <<< maybe v (f v)) k m

-- | Compute the union of two maps, preferring values from the first map in the case
-- | of duplicate keys
union :: forall k v. Ord k => Map k v -> Map k v -> Map k v
union = unionWith const

-- | Compute the union of a collection of maps
unions :: forall k v f. Ord k => Foldable f => f (Map k v) -> Map k v
unions = foldl union empty

-- | Calculate the number of key/value pairs in a map
size :: forall k v. Map k v -> Int
size = length <<< values

-- | Apply a function of two arguments to each key/value pair, producing a new map
mapWithKey :: forall k v v'. (k -> v -> v') -> Map k v -> Map k v'
mapWithKey _ Leaf = Leaf
mapWithKey f (Two left k v right) = Two (mapWithKey f left) k (f k v) (mapWithKey f right)
mapWithKey f (Three left k1 v1 mid k2 v2 right) = Three (mapWithKey f left) k1 (f k1 v1) (mapWithKey f mid) k2 (f k2 v2) (mapWithKey f right)


Add structure to sketchpalette JSON

Add structure to sketchpalette JSON

module Util.DOM where

import Color (toHexString, darken)
import Control.Monad.Eff (Eff)
import Data.Array (length)
import DOM (DOM)
import DOM.Classy.Element (toElement)
import DOM.HTML (window)
import DOM.HTML.Types (htmlDocumentToDocument, HTMLAnchorElement, HTMLUListElement)
import DOM.HTML.Window (document)
import DOM.Node.Document (createDocumentFragment, createElement)
import DOM.Node.Element (setAttribute, removeAttribute, setClassName)
import DOM.Node.Node (firstChild, removeChild, appendChild, setTextContent)
import DOM.Node.Types (Document, elementToNode, Node, documentFragmentToNode)
import Data.Maybe (Maybe(..))
import Data.Traversable (for)
import Data.Argonaut (encodeJson)
import Prelude (Unit, unit, show, (<$>), bind, pure, discard, (<<<), (<>), (>>=), ($), (==))
import Global (encodeURIComponent)
import Util.Color (isLight)
import Util.Types (Colors'(..), Color'(..))

--------------------------------------------------------------------------------

isEmpty :: forall a. Array a -> Boolean
isEmpty xs = length xs == 0

--------------------------------------------------------------------------------

removeChildren :: forall eff. Node -> Eff (dom :: DOM | eff) Node
removeChildren parentNode = do
  maybeFirstChild <- firstChild parentNode
  case maybeFirstChild of
    Nothing        -> pure parentNode
    Just childNode -> do
      _ <- removeChild childNode parentNode
      removeChildren parentNode

--------------------------------------------------------------------------------

updatePalette :: forall eff. HTMLUListElement
                          -> Array Color'
                          -> Eff (dom :: DOM | eff) Unit
updatePalette ul colors = do
  _ <- removeChildren ulNode

  if isEmpty colors then do
      doc <- htmlDocumentToDocument <$> (window >>= document)
      li  <- createElement "li" doc

      let liNode = elementToNode li

      setClassName "preview__item preview__item--empty" li
      setTextContent "Maybe try one hexcode per line?" liNode

      _ <- appendChild liNode ulNode

      pure unit

    else do
      colorListFragNode <- createColorListFragNode colors
      _ <- appendChild colorListFragNode ulNode
      pure unit

  where
    ulNode = (elementToNode <<< toElement) ul

--------------------------------------------------------------------------------

updateDownloadLink :: forall eff. HTMLAnchorElement
                               -> Array Color'
                               -> Eff (dom :: DOM | eff) Unit
updateDownloadLink a colors = if isEmpty colors
  then do
    setAttribute "disabled" "disabled" aElement
    pure unit
  else do
    removeAttribute "disabled" aElement
    setAttribute "href" href aElement
    setAttribute "download" "custom.sketchpalette" aElement
    pure unit
  where
    href     = "data:text/json;charset=utf-8," <> encodeURIComponent sketchPalette
    aElement = toElement a
    sketchPalette = (show <<< encodeJson) (Colors' colors)

--------------------------------------------------------------------------------

appendPreviewSwatchItem :: forall eff. Document
                                    -> Node
                                    -> Color'
                                    -> Eff (dom :: DOM | eff) Node
appendPreviewSwatchItem doc fragNode (Color' c) = do

  li <- createElement "li" doc

  let liNode    = elementToNode li
      bgHex     = toHexString c
      bdrHex    = (toHexString <<< darken 0.1) c
      style     = "background-color:" <> bgHex <> ";" <> "border-color:" <> bdrHex <> ";"
      className = if isLight c
                  then "preview__item preview__item--light"
                  else "preview__item preview__item--dark"

  setAttribute "style" style li
  setAttribute "title" bgHex li
  setClassName className li

  _ <- appendChild liNode fragNode

  pure fragNode

--------------------------------------------------------------------------------

createColorListFragNode :: forall eff. Array Color'
                        -> Eff (dom :: DOM | eff) Node
createColorListFragNode colors = do

  doc      <- htmlDocumentToDocument <$> (window >>= document)
  fragNode <- documentFragmentToNode <$> createDocumentFragment doc
  _        <- for colors $ appendPreviewSwatchItem doc fragNode

  pure fragNode

--------------------------------------------------------------------------------

module Util.DOM where

import Color (toHexString, darken)
import Control.Monad.Eff (Eff)
import Data.Array (length)
import DOM (DOM)
import DOM.Classy.Element (toElement)
import DOM.HTML (window)
import DOM.HTML.Types (htmlDocumentToDocument, HTMLAnchorElement, HTMLUListElement)
import DOM.HTML.Window (document)
import DOM.Node.Document (createDocumentFragment, createElement)
import DOM.Node.Element (setAttribute, removeAttribute, setClassName)
import DOM.Node.Node (firstChild, removeChild, appendChild, setTextContent)
import DOM.Node.Types (Document, elementToNode, Node, documentFragmentToNode)
import Data.Maybe (Maybe(..))
import Data.Traversable (for)
import Data.Argonaut (encodeJson)
import Prelude (Unit, unit, show, (<$>), bind, pure, discard, (<<<), (<>), (>>=), ($), (==))
import Global (encodeURIComponent)
import Util.Color (isLight)
import Util.Types (Color'(..))

--------------------------------------------------------------------------------

isEmpty :: forall a. Array a -> Boolean
isEmpty xs = length xs == 0

--------------------------------------------------------------------------------

removeChildren :: forall eff. Node -> Eff (dom :: DOM | eff) Node
removeChildren parentNode = do
  maybeFirstChild <- firstChild parentNode
  case maybeFirstChild of
    Nothing        -> pure parentNode
    Just childNode -> do
      _ <- removeChild childNode parentNode
      removeChildren parentNode

--------------------------------------------------------------------------------

updatePalette :: forall eff. HTMLUListElement
                          -> Array Color'
                          -> Eff (dom :: DOM | eff) Unit
updatePalette ul colors = do
  _ <- removeChildren ulNode

  if isEmpty colors then do
      doc <- htmlDocumentToDocument <$> (window >>= document)
      li  <- createElement "li" doc

      let liNode = elementToNode li

      setClassName "preview__item preview__item--empty" li
      setTextContent "Maybe try one hexcode per line?" liNode

      _ <- appendChild liNode ulNode

      pure unit

    else do
      colorListFragNode <- createColorListFragNode colors
      _ <- appendChild colorListFragNode ulNode
      pure unit

  where
    ulNode = (elementToNode <<< toElement) ul

--------------------------------------------------------------------------------

updateDownloadLink :: forall eff. HTMLAnchorElement
                               -> Array Color'
                               -> Eff (dom :: DOM | eff) Unit
updateDownloadLink a colors = if isEmpty colors
  then do
    setAttribute "disabled" "disabled" aElement
    pure unit
  else do
    removeAttribute "disabled" aElement
    setAttribute "href" href aElement
    setAttribute "download" "custom.sketchpalette" aElement
    pure unit
  where
    href     = "data:text/json;charset=utf-8," <> encodeURIComponent sketchPalette
    aElement = toElement a
    sketchPalette = (show <<< encodeJson) colors

--------------------------------------------------------------------------------

appendPreviewSwatchItem :: forall eff. Document
                                    -> Node
                                    -> Color'
                                    -> Eff (dom :: DOM | eff) Node
appendPreviewSwatchItem doc fragNode (Color' c) = do

  li <- createElement "li" doc

  let liNode    = elementToNode li
      bgHex     = toHexString c
      bdrHex    = (toHexString <<< darken 0.1) c
      style     = "background-color:" <> bgHex <> ";" <> "border-color:" <> bdrHex <> ";"
      className = if isLight c
                  then "preview__item preview__item--light"
                  else "preview__item preview__item--dark"

  setAttribute "style" style li
  setAttribute "title" bgHex li
  setClassName className li

  _ <- appendChild liNode fragNode

  pure fragNode

--------------------------------------------------------------------------------

createColorListFragNode :: forall eff. Array Color'
                        -> Eff (dom :: DOM | eff) Node
createColorListFragNode colors = do

  doc      <- htmlDocumentToDocument <$> (window >>= document)
  fragNode <- documentFragmentToNode <$> createDocumentFragment doc
  _        <- for colors $ appendPreviewSwatchItem doc fragNode

  pure fragNode

--------------------------------------------------------------------------------


Remove unnessessary syntax

Remove unnessessary syntax

module App.Game where

import Prelude (const, show, (<>), ($), (<$>), (<*>), pure, bind, negate, (+), (<<<))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Random (RANDOM, randomInt)
import Data.Maybe (Maybe(Just, Nothing), maybe)
import Data.Tuple (snd, fst, Tuple(Tuple))
import Data.Tuple.Nested ((/\))
import Data.String (toLower)
import Pux (EffModel, noEffects)
import Pux.Html (Html, text, button, div, hr)
import Pux.Html.Attributes (className)
import Pux.Html.Events (onClick)

data GameChoice
  = Rock
  | Paper
  | Scissors
  | Lizard
  | Spock

data GameResult
  = PlayerWins String
  | ComputerWins String
  | Tie

data Action
  = PlayerMove GameChoice
  | ComputerMove GameChoice
  | UpdateScore
  | Reset

type State =
  { playerChoice :: (Maybe GameChoice)
  , computerChoice :: (Maybe GameChoice)
  , gameResult :: Tuple Int String
  , score :: Int
  }

init :: State
init =
  { playerChoice: Nothing
  , computerChoice: Nothing
  , gameResult: Tuple 0 "choose..!"
  , score: 0
  }

update :: forall e. Action -> State -> EffModel State Action (random :: RANDOM | e)
update Reset state = noEffects init
update UpdateScore state = noEffects $ updateScore state
update (PlayerMove choice) state =
  { state: state { playerChoice = Just choice }
  , effects: [ do
      computerChoice <- liftEff getRandomChoice
      pure $ ComputerMove computerChoice
    ]
  }
update (ComputerMove choice) state =
  { state: state { computerChoice = Just choice }
  , effects: [ pure UpdateScore ]
  }

updateScore :: State -> State
updateScore state =
  let newState = setGameResult state
  in newState { score = newState.score + fst newState.gameResult }

setGameResult :: State -> State
setGameResult state =
  case determineWinner <$> state.playerChoice <*> state.computerChoice of
    Just (PlayerWins reason) -> state { gameResult = 1 /\ ("Player wins!  " <> reason <> "!") }
    Just (ComputerWins reason) -> state { gameResult = -1 /\ ("Computer wins!  " <> reason <> "!") }
    Just Tie -> state { gameResult = 0 /\ "It's a tie!" }
    _ -> state
  where
    determineWinner player computer =
      let
        didPlayerWin = didLeftWin player computer
        didComputerWin = didLeftWin computer player
      in
        if fst didPlayerWin
          then PlayerWins (snd didPlayerWin)
          else if fst (didLeftWin computer player)
            then ComputerWins (snd didComputerWin)
            else Tie

    didLeftWin left right =
      case left, right of
        Rock, Scissors -> true /\ "Rock crushes Scissors"
        Rock, Lizard -> true /\ "Rock smashes Lizard"
        Paper, Rock -> true /\ "Paper covers Rock"
        Paper, Spock -> true /\ "Paper disproves Spock"
        Scissors, Paper -> true /\ "Scissors cuts Paper"
        Scissors, Lizard -> true /\ "Scissors decapitates Lizard"
        Lizard, Paper -> true /\ "Lizard eats Paper"
        Lizard, Spock -> true /\ "Lizard poisons Spock"
        Spock, Rock -> true /\ "Spock vaporizes Rock"
        Spock, Scissors -> true /\ "Spock disassembles Scissors"
        _, _ -> false /\ "loss"

getRandomChoice :: forall e. Eff (random :: RANDOM | e) GameChoice
getRandomChoice = do
  i <- randomInt 1 5
  pure case i of
    1 -> Rock
    2 -> Paper
    3 -> Scissors
    4 -> Lizard
    _ -> Spock

printMaybeChoice :: Maybe GameChoice -> String
printMaybeChoice = maybe "-- choosing --" printChoice

printChoice :: GameChoice -> String
printChoice Rock = "Rock"
printChoice Paper = "Paper"
printChoice Scissors = "Scissors"
printChoice Lizard = "Lizard"
printChoice Spock = "Spock"

choiceToClassName :: GameChoice -> String
choiceToClassName = toLower <<< printChoice

view :: State -> Html Action
view state =
  div
    []
    [ choiceButton Rock
    , choiceButton Paper
    , choiceButton Scissors
    , choiceButton Lizard
    , choiceButton Spock
    , divider
    , showChoice state.playerChoice
    , showChoice state.computerChoice
    , showGameResult state.gameResult
    , showPlayerScore state.score
    , divider
    , resetButton
    ]
  where
    choiceButton gameChoice =
      button
        [ onClick (const $ PlayerMove gameChoice), className ("choice " <> choiceToClassName gameChoice) ]
        [ text $ printChoice gameChoice ]

    resetButton = button [ onClick (const Reset), className "reset" ] [ text "Reset!" ]

    showChoice maybeGameChoice = div [ className ("card " <> gameChoice) ] []
      where
        gameChoice = maybe "" choiceToClassName maybeGameChoice

    showGameResult gameResult = div [] [ text $ "Game result: " <> snd gameResult ]

    showPlayerScore playerScore = div [] [ text $ "Score: " <> show playerScore ]

    divider = hr [] []

module App.Game where

import Prelude (const, show, (<>), ($), (<$>), (<*>), pure, bind, negate, (+), (<<<))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Random (RANDOM, randomInt)
import Data.Maybe (Maybe(Just, Nothing), maybe)
import Data.Tuple (snd, fst, Tuple(Tuple))
import Data.Tuple.Nested ((/\))
import Data.String (toLower)
import Pux (EffModel, noEffects)
import Pux.Html (Html, text, button, div, hr)
import Pux.Html.Attributes (className)
import Pux.Html.Events (onClick)

data GameChoice
  = Rock
  | Paper
  | Scissors
  | Lizard
  | Spock

data GameResult
  = PlayerWins String
  | ComputerWins String
  | Tie

data Action
  = PlayerMove GameChoice
  | ComputerMove GameChoice
  | UpdateScore
  | Reset

type State =
  { playerChoice :: (Maybe GameChoice)
  , computerChoice :: (Maybe GameChoice)
  , gameResult :: Tuple Int String
  , score :: Int
  }

init :: State
init =
  { playerChoice: Nothing
  , computerChoice: Nothing
  , gameResult: Tuple 0 "choose..!"
  , score: 0
  }

update :: forall e. Action -> State -> EffModel State Action (random :: RANDOM | e)
update Reset state = noEffects init
update UpdateScore state = noEffects $ updateScore state
update (PlayerMove choice) state =
  { state: state { playerChoice = Just choice }
  , effects: [ do
      computerChoice <- liftEff getRandomChoice
      pure $ ComputerMove computerChoice
    ]
  }
update (ComputerMove choice) state =
  { state: state { computerChoice = Just choice }
  , effects: [ pure $ UpdateScore ]
  }

updateScore :: State -> State
updateScore state =
  let newState = setGameResult state
  in newState { score = newState.score + fst newState.gameResult }

setGameResult :: State -> State
setGameResult state =
  case determineWinner <$> state.playerChoice <*> state.computerChoice of
    Just (PlayerWins reason) -> state { gameResult = 1 /\ ("Player wins!  " <> reason <> "!") }
    Just (ComputerWins reason) -> state { gameResult = -1 /\ ("Computer wins!  " <> reason <> "!") }
    Just Tie -> state { gameResult = 0 /\ "It's a tie!" }
    _ -> state
  where
    determineWinner player computer =
      let
        didPlayerWin = didLeftWin player computer
        didComputerWin = didLeftWin computer player
      in
        if fst didPlayerWin
          then PlayerWins (snd didPlayerWin)
          else if fst (didLeftWin computer player)
            then ComputerWins (snd didComputerWin)
            else Tie

    didLeftWin left right =
      case left, right of
        Rock, Scissors -> true /\ "Rock crushes Scissors"
        Rock, Lizard -> true /\ "Rock smashes Lizard"
        Paper, Rock -> true /\ "Paper covers Rock"
        Paper, Spock -> true /\ "Paper disproves Spock"
        Scissors, Paper -> true /\ "Scissors cuts Paper"
        Scissors, Lizard -> true /\ "Scissors decapitates Lizard"
        Lizard, Paper -> true /\ "Lizard eats Paper"
        Lizard, Spock -> true /\ "Lizard poisons Spock"
        Spock, Rock -> true /\ "Spock vaporizes Rock"
        Spock, Scissors -> true /\ "Spock disassembles Scissors"
        _, _ -> false /\ "loss"

getRandomChoice :: forall e. Eff (random :: RANDOM | e) GameChoice
getRandomChoice = do
  i <- randomInt 1 5
  pure case i of
    1 -> Rock
    2 -> Paper
    3 -> Scissors
    4 -> Lizard
    _ -> Spock

printMaybeChoice :: Maybe GameChoice -> String
printMaybeChoice = maybe "-- choosing --" printChoice

printChoice :: GameChoice -> String
printChoice Rock = "Rock"
printChoice Paper = "Paper"
printChoice Scissors = "Scissors"
printChoice Lizard = "Lizard"
printChoice Spock = "Spock"

choiceToClassName :: GameChoice -> String
choiceToClassName = toLower <<< printChoice

view :: State -> Html Action
view state =
  div
    []
    [ choiceButton Rock
    , choiceButton Paper
    , choiceButton Scissors
    , choiceButton Lizard
    , choiceButton Spock
    , divider
    , showChoice state.playerChoice
    , showChoice state.computerChoice
    , showGameResult state.gameResult
    , showPlayerScore state.score
    , divider
    , resetButton
    ]
  where
    choiceButton gameChoice =
      button
        [ onClick (const $ PlayerMove gameChoice), className ("choice " <> choiceToClassName gameChoice) ]
        [ text $ printChoice gameChoice ]

    resetButton = button [ onClick (const Reset), className "reset" ] [ text "Reset!" ]

    showChoice maybeGameChoice = div [ className ("card " <> gameChoice) ] []
      where
        gameChoice = maybe "" choiceToClassName maybeGameChoice

    showGameResult gameResult = div [] [ text $ "Game result: " <> snd gameResult ]

    showPlayerScore playerScore = div [] [ text $ "Score: " <> show playerScore ]

    divider = hr [] []


Minor indentation change

Minor indentation change

module Main where

import Control.Monad.Eff
import Control.Monad.ST
import Data.Array
import Data.Int (even, odd, toNumber)
import Data.Maybe
import Graphics.Canvas
import Math
import Prelude

type Player = String

type Piece = { color :: String }

type Square = { x :: Int, y :: Int, rx :: Number, ry :: Number, color :: String, piece :: Maybe Piece }

type Grid = { width :: Int, height :: Int, squares :: Array Square }

type State = { grid :: Grid }

renderSize = 60.0
colorSquareOne = "#d18b47"
colorSquareTwo = "#ffce9e"
colorPlayerOne = "red"
colorPlayerTwo = "white"

createGrid :: Int -> Int -> Int -> Grid
createGrid 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
        color = if disj (conj (even x) (odd y)) (conj (even y) (odd x))
                then colorSquareOne
                else colorSquareTwo
        hasPlayerOne = conj (y < layers) (disj (conj (even y) (odd x)) (conj (even x) (odd y)))
        hasPlayerTwo = conj (y >= height - layers) (disj (conj (even y) (odd x)) (conj (even x) (odd y)))
        piece = if hasPlayerOne
                then Just { color: colorPlayerOne }
                else
                  if hasPlayerTwo
                  then Just { color: colorPlayerTwo }
                  else Nothing
    return { x: x, y: y, rx: rx, ry: ry, color: color, piece: piece }

renderSquare :: forall e. Context2D -> Unit -> Square -> Eff (canvas :: Canvas | e) Unit
renderSquare ctx _ square = do
  withContext ctx $ do
    setFillStyle square.color ctx
    fillRect ctx { x: square.rx, y: square.ry, w: renderSize, h: renderSize }
  case square.piece of
    Just piece -> do
      withContext ctx $ do
        setFillStyle piece.color ctx
        fillPath ctx $ arc ctx { x: square.rx + 0.5 * renderSize,
                                 y: square.ry + 0.5 * renderSize,
                                 r: (renderSize / 2.0) * 0.8,
                                 start: 0.0,
                                 end: 2.0 * pi }
        return unit
    _ -> return unit

render :: forall s e. Context2D -> STRef s State -> Eff (st :: ST s, canvas :: Canvas | e) Unit
render ctx st = do
  state <- readSTRef st
  withContext ctx $ do
    foldM (renderSquare ctx) unit state.grid.squares
  withContext ctx $ do
    setStrokeStyle "black" ctx
    strokeRect ctx { x: 0.5,
                     y: 0.5,
                     w: (toNumber state.grid.width) * renderSize,
                     h: (toNumber state.grid.height) * renderSize }
  return unit

main :: forall s e. (Eff (st :: ST s, canvas :: Canvas | e) Unit)
main = do
  st <- newSTRef { grid: (createGrid 8 8 3) }
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      ctx <- getContext2D canvas
      render ctx st
      return unit
    _ -> return unit


Refactored getCoordinate away to use the short notation

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 }

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 == (_.coordinate square)

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 :: Square -> Pixel -> Boolean
isOnSquare square (Tuple x y) =
  let px = square.render + square.offset
      vx = fst px
      vy = snd px
  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)

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

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
  guard $ hasPlayerPiece grid.squares coordinate player
  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 (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 ->
                  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 -> renderHighlight ctx state.grid.squares (Just square.coordinate)
            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 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 ->
            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
  withContext ctx $ do
    renderHighlight ctx state.grid.squares state.selectedCoordinate
  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

moveListener :: forall s e.
                  STRef s State ->
                  DOMEvent ->
                  Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
moveListener st e = renderPage st (Just e)

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)
          activeCoordinate = getActiveCoordinate state.grid state.currentPlayer pixel
      writeSTRef st $ state { selectedCoordinate = activeCoordinate }
      renderPage st (Just e)
      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 Nothing
      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 }

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 == getCoordinate square

getCoordinate :: Square -> Coordinate
getCoordinate square = 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 :: Square -> Pixel -> Boolean
isOnSquare square (Tuple x y) =
  let px = square.render + square.offset
      vx = fst px
      vy = snd px
  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)

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

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
  guard $ hasPlayerPiece grid.squares coordinate player
  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 (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 ->
                  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 -> renderHighlight ctx state.grid.squares (Just square.coordinate)
            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 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 ->
            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
  withContext ctx $ do
    renderHighlight ctx state.grid.squares state.selectedCoordinate
  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

moveListener :: forall s e.
                  STRef s State ->
                  DOMEvent ->
                  Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
moveListener st e = renderPage st (Just e)

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)
          activeCoordinate = getActiveCoordinate state.grid state.currentPlayer pixel
      writeSTRef st $ state { selectedCoordinate = activeCoordinate }
      renderPage st (Just e)
      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 Nothing
      return unit
    _ -> return unit


const example review feedback

const example review feedback

module Data.Function
  ( flip
  , const
  , apply, ($)
  , applyFlipped, (#)
  , applyN
  , on
  , module Control.Category
  ) where

import Control.Category (identity, compose, (<<<), (>>>))
import Data.Boolean (otherwise)
import Data.Ord ((<=))
import Data.Ring ((-))

-- | Flips the order of the arguments to a function of two arguments.
-- |
-- | ```purescript
-- | flip const 1 2 = const 2 1 = 2
-- | ```
flip :: forall a b c. (a -> b -> c) -> b -> a -> c
flip f b a = f a b

-- | Returns its first argument and ignores its second.
-- |
-- | ```purescript
-- | const 1 "hello" = 1
-- | ```
-- |
-- | It can also be thought of as creating a function that ignores its argument:
-- |
-- | ```purescript
-- | const 1 = \_ -> 1
-- | ```
const :: forall a b. a -> b -> a
const a _ = a

-- | Applies a function to an argument. This is primarily used as the operator
-- | `($)` which allows parentheses to be omitted in some cases, or as a
-- | natural way to apply a chain of composed functions to a value.
apply :: forall a b. (a -> b) -> a -> b
apply f x = f x

-- | Applies a function to an argument: the reverse of `(#)`.
-- |
-- | ```purescript
-- | length $ groupBy productCategory $ filter isInStock $ products
-- | ```
-- |
-- | is equivalent to:
-- |
-- | ```purescript
-- | length (groupBy productCategory (filter isInStock products))
-- | ```
-- |
-- | Or another alternative equivalent, applying chain of composed functions to
-- | a value:
-- |
-- | ```purescript
-- | length <<< groupBy productCategory <<< filter isInStock $ products
-- | ```
infixr 0 apply as $

-- | Applies an argument to a function. This is primarily used as the `(#)`
-- | operator, which allows parentheses to be ommitted in some cases, or as a
-- | natural way to apply a value to a chain of composed functions.
applyFlipped :: forall a b. a -> (a -> b) -> b
applyFlipped x f = f x

-- | Applies an argument to a function: the reverse of `($)`.
-- |
-- | ```purescript
-- | products # filter isInStock # groupBy productCategory # length
-- | ```
-- |
-- | is equivalent to:
-- |
-- | ```purescript
-- | length (groupBy productCategory (filter isInStock products))
-- | ```
-- |
-- | Or another alternative equivalent, applying a value to a chain of composed
-- | functions:
-- |
-- | ```purescript
-- | products # filter isInStock >>> groupBy productCategory >>> length
-- | ```
infixl 1 applyFlipped as #

-- | `applyN f n` applies the function `f` to its argument `n` times.
-- |
-- | If n is less than or equal to 0, the function is not applied.
-- |
-- | ```purescript
-- | applyN (_ + 1) 10 0 == 10
-- | ```
applyN :: forall a. (a -> a) -> Int -> a -> a
applyN f = go
  where
  go n acc
    | n <= 0   = acc
    | otherwise = go (n - 1) (f acc)

-- | The `on` function is used to change the domain of a binary operator.
-- |
-- | For example, we can create a function which compares two records based on the values of their `x` properties:
-- |
-- | ```purescript
-- | compareX :: forall r. { x :: Number | r } -> { x :: Number | r } -> Ordering
-- | compareX = compare `on` _.x
-- | ```
on :: forall a b c. (b -> b -> c) -> (a -> b) -> a -> a -> c
on f g x y = g x `f` g y

module Data.Function
  ( flip
  , const
  , apply, ($)
  , applyFlipped, (#)
  , applyN
  , on
  , module Control.Category
  ) where

import Control.Category (identity, compose, (<<<), (>>>))
import Data.Boolean (otherwise)
import Data.Ord ((<=))
import Data.Ring ((-))

-- | Flips the order of the arguments to a function of two arguments.
-- |
-- | ```purescript
-- | flip const 1 2 = const 2 1 = 2
-- | ```
flip :: forall a b c. (a -> b -> c) -> b -> a -> c
flip f b a = f a b

-- | Returns its first argument and ignores its second.
-- |
-- | ```purescript
-- | const 1 "hello" = 1
-- | ```
-- |
-- | Can also be thought of as creating a function that ignores its argument:
-- |
-- | ```purescript
-- | const 1 == \_ -> 1
-- | ```
const :: forall a b. a -> b -> a
const a _ = a

-- | Applies a function to an argument. This is primarily used as the operator
-- | `($)` which allows parentheses to be omitted in some cases, or as a
-- | natural way to apply a chain of composed functions to a value.
apply :: forall a b. (a -> b) -> a -> b
apply f x = f x

-- | Applies a function to an argument: the reverse of `(#)`.
-- |
-- | ```purescript
-- | length $ groupBy productCategory $ filter isInStock $ products
-- | ```
-- |
-- | is equivalent to:
-- |
-- | ```purescript
-- | length (groupBy productCategory (filter isInStock products))
-- | ```
-- |
-- | Or another alternative equivalent, applying chain of composed functions to
-- | a value:
-- |
-- | ```purescript
-- | length <<< groupBy productCategory <<< filter isInStock $ products
-- | ```
infixr 0 apply as $

-- | Applies an argument to a function. This is primarily used as the `(#)`
-- | operator, which allows parentheses to be ommitted in some cases, or as a
-- | natural way to apply a value to a chain of composed functions.
applyFlipped :: forall a b. a -> (a -> b) -> b
applyFlipped x f = f x

-- | Applies an argument to a function: the reverse of `($)`.
-- |
-- | ```purescript
-- | products # filter isInStock # groupBy productCategory # length
-- | ```
-- |
-- | is equivalent to:
-- |
-- | ```purescript
-- | length (groupBy productCategory (filter isInStock products))
-- | ```
-- |
-- | Or another alternative equivalent, applying a value to a chain of composed
-- | functions:
-- |
-- | ```purescript
-- | products # filter isInStock >>> groupBy productCategory >>> length
-- | ```
infixl 1 applyFlipped as #

-- | `applyN f n` applies the function `f` to its argument `n` times.
-- |
-- | If n is less than or equal to 0, the function is not applied.
-- |
-- | ```purescript
-- | applyN (_ + 1) 10 0 == 10
-- | ```
applyN :: forall a. (a -> a) -> Int -> a -> a
applyN f = go
  where
  go n acc
    | n <= 0   = acc
    | otherwise = go (n - 1) (f acc)

-- | The `on` function is used to change the domain of a binary operator.
-- |
-- | For example, we can create a function which compares two records based on the values of their `x` properties:
-- |
-- | ```purescript
-- | compareX :: forall r. { x :: Number | r } -> { x :: Number | r } -> Ordering
-- | compareX = compare `on` _.x
-- | ```
on :: forall a b c. (b -> b -> c) -> (a -> b) -> a -> a -> c
on f g x y = g x `f` g y


Add some commentary

Add some commentary

-- |
-- | Docopt utiltiy surface.
-- |
-- | Extract docopt sources from a README, parse and run it.
-- |

module Docopt (
    fromREADME
  , fromREADME_
  ) where

import Prelude
import Debug.Trace
import Control.Monad.Aff (Aff(), launchAff, liftEff')
import Control.Monad.Eff.Exception (error, throwException, EXCEPTION())
import Data.Either (either)
import Node.Path (FilePath())
import Control.Monad.Eff (Eff())
import Node.FS.Aff (readTextFile)
import Data.String (fromCharArray)
import Node.Encoding (Encoding(..))
import Data.List (fromList)
import Data.Maybe (Maybe(..))
import Node.FS (FS())
import Node.Process (PROCESS())
import Node.Process as Process
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Error.Class (throwError)
import Language.Docopt.Parser.Base (sof)
import Control.Alt ((<|>))
import Control.Apply ((*>))
import Control.Monad.Eff.Console (log, CONSOLE)

import Text.Parsing.Parser             as P
import Text.Parsing.Parser.Combinators as P
import Text.Parsing.Parser.Pos         as P
import Text.Parsing.Parser.String      as P

import Language.Docopt (runDocopt)

type DocoptEff = ( process :: PROCESS
                 , err     :: EXCEPTION
                 , fs      :: FS
                 )

liftEffA :: forall a. Eff DocoptEff a -> Aff DocoptEff a
liftEffA = liftEff

type Options = {
  argv :: Maybe (Array String) -- ^ override argv
}

defaultOptions :: Options
defaultOptions = {
  argv: Nothing
}

-- |
-- | Run docopt on the given docopt text.
-- |
run :: forall e . Options -> String -> Eff DocoptEff Unit
run o d = do
  Process.argv
  pure unit

-- |
-- | Extract the docopt text from a README, then run it.
-- |
fromREADME :: forall e . Options -> FilePath -> Aff DocoptEff Unit
fromREADME o f = do
  c <- readTextFile UTF8 f
  d <- either (throwError <<< error <<< show)
              return
              (P.runParser c parser)
  u <- liftEffA $ run o d
  pure unit

  where
    parser :: P.Parser String String
    parser = do
      P.manyTill P.anyChar do
        (sof <|> (void $ P.char '\n'))
        P.string "```docopt"
        P.char '\n'
      fromCharArray <<< fromList <$> do
        P.manyTill P.anyChar do
          P.char '\n'
          P.string "```"

-- |
-- | Extract the docopt text from a README, then run it
-- | with the default options.
-- |
fromREADME_ :: forall e . FilePath -> Aff DocoptEff Unit
fromREADME_ = fromREADME defaultOptions

-- |
-- | Docopt utiltiy surface.
-- |
-- | Extract docopt sources from a README, parse and run it.
-- |

module Docopt (
    fromREADME
  , fromREADME_
  ) where

import Prelude
import Debug.Trace
import Control.Monad.Aff (Aff(), launchAff, liftEff')
import Control.Monad.Eff.Exception (error, throwException, EXCEPTION())
import Data.Either (either)
import Node.Path (FilePath())
import Control.Monad.Eff (Eff())
import Node.FS.Aff (readTextFile)
import Data.String (fromCharArray)
import Node.Encoding (Encoding(..))
import Data.List (fromList)
import Data.Maybe (Maybe(..))
import Node.FS (FS())
import Node.Process (PROCESS())
import Node.Process as Process
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Error.Class (throwError)
import Language.Docopt.Parser.Base (sof)
import Control.Alt ((<|>))
import Control.Apply ((*>))
import Control.Monad.Eff.Console (log, CONSOLE)

import Text.Parsing.Parser             as P
import Text.Parsing.Parser.Combinators as P
import Text.Parsing.Parser.Pos         as P
import Text.Parsing.Parser.String      as P

import Language.Docopt (runDocopt)

type DocoptEff = ( process :: PROCESS
                 , err     :: EXCEPTION
                 , fs      :: FS
                 )

liftEffA :: forall a. Eff DocoptEff a -> Aff DocoptEff a
liftEffA = liftEff

type Options = {
  argv :: Maybe (Array String) -- ^ override argv
}

defaultOptions :: Options
defaultOptions = {
  argv: Nothing
}

run :: forall e . Options -> String -> Eff DocoptEff Unit
run o d = do
  Process.argv
  pure unit

fromREADME :: forall e . Options -> FilePath -> Aff DocoptEff Unit
fromREADME o f = do
  c <- readTextFile UTF8 f
  d <- either (throwError <<< error <<< show)
              return
              (P.runParser c parser)
  u <- liftEffA $ run o d
  pure unit

  where
    parser :: P.Parser String String
    parser = do
      P.manyTill P.anyChar do
        (sof <|> (void $ P.char '\n'))
        P.string "```docopt"
        P.char '\n'
      fromCharArray <<< fromList <$> do
        P.manyTill P.anyChar do
          P.char '\n'
          P.string "```"

fromREADME_ :: forall e . FilePath -> Aff DocoptEff Unit
fromREADME_ = fromREADME defaultOptions