refactor styling code

refactor styling code

module App.View where

import Prelude

import App.Background.View (fillBackground)
import App.Background.View (view) as BackgroundView
import App.Cycle (Cycle(..))
import App.Events (Event(..))
import App.Geometry (Point(Point), Stroke(Arc, Line), distance, firstPoint, ptX, ptY, secondPoint, sweep)
import App.Graph (Graph, edges)
import App.State (State, Tool(..))
import App.Tool.View (view) as ToolView
import CSS.Color (Color, red, toHexString)
import CSS.Geometry (height, width)
import CSS.Size (px)
import Control.Monad.Except (runExcept)
import DOM.Event.MouseEvent (clientX, clientY, eventToMouseEvent)
import Data.Either (either)
import Data.Foldable (elem, for_)
import Data.Function.Uncurried (runFn2)
import Data.Int (toNumber)
import Data.List (List, foldl, (:))
import Data.Map (Map, toUnfoldable)
import Data.Maybe (Maybe(..))
import Data.Monoid (mempty)
import Data.Tuple (Tuple(..))
import Math (abs, pi)
import Pux.DOM.Events (DOMEvent, onClick, onMouseDown, onMouseMove, onMouseUp)
import Pux.DOM.HTML (HTML, memoize)
import Pux.DOM.HTML.Attributes (style)
import Text.Smolder.HTML (div)
import Text.Smolder.HTML.Attributes (className)
import Text.Smolder.Markup (Attribute, Markup, (!), (#!))
import Text.Smolder.SVG (circle, g, line, path, svg)
import Text.Smolder.SVG.Attributes (cx, cy, d, fill, r, stroke, strokeDasharray, x1, x2, y1, y2)

drawLine :: Attribute -> Point -> Point -> HTML Event
drawLine strokeStyle (Point px1 py1) (Point px2 py2) =
  line ! (x1 $ show px1)
       ! (y1 $ show py1)
       ! (x2 $ show px2)
       ! (y2 $ show py2)
       ! strokeStyle

drawStroke :: Stroke -> HTML Event
drawStroke s =
  let command = (mCmdString $ firstPoint s) <> (lCmdString s)
   in path ! (d command) $ pure unit

drawStrokes :: Graph -> HTML Event
drawStrokes = memoize \graph ->
  let
      strokeStyle :: Attribute
      strokeStyle = stroke "black" <> fill "transparent" <> className "stroke"
   in g ! className "strokes" $ for_ (edges graph) \stroke -> drawStroke stroke ! strokeStyle

pathAttrs :: List Stroke -> Attribute
pathAttrs strokes@(s1 : _) =
  let p = firstPoint s1
   in d (foldl append (mCmdString p) (lCmdString <$> strokes))

pathAttrs _ = mempty

mCmdString :: Point -> String
mCmdString (Point x y) = "M " <> (show $ x) <> " " <> (show $ y) <> " "

lCmdString :: Stroke -> String
lCmdString (Line _ (Point x2 y2)) = "L " <> show x2 <> " " <> show y2 <> " "
lCmdString arc@(Arc c p q ccw) =
  if p == q then let halfPoint = c + c - p
                  in arcCmdString (Arc c p halfPoint ccw) <> arcCmdString (Arc c halfPoint q ccw)
            else arcCmdString arc

arcCmdString :: Stroke -> String
arcCmdString arc@(Arc c p q ccw) =
  let endPoint = secondPoint arc
      r = runFn2 distance c p
      s = sweep arc
   in "A "
      <> show r <> " " -- rx
      <> show r -- ry
      <> " 0 " -- x-axis-rotation
      <> show (if abs s > pi then 1 else 0) -- large sweep flag (sweep > 180 degrees)
      <> " "
      <> show (if ccw then 1 else 0) -- sweep flag (sweep starts positive or negative)
      <> " "
      <> show (ptX endPoint) <> " "
      <> show (ptY endPoint) <> " "

arcCmdString _ = ""

drawCycle :: Cycle -> HTML Event
drawCycle cycle@(Cycle strokes) =
  path ! pathAttrs strokes $ pure unit

mapToList :: forall k v. Map k v -> List (Tuple k v)
mapToList = toUnfoldable

drawCycles :: Tool -> Map Cycle Color -> HTML Event
drawCycles tool cycles =
  let handler cycle = case tool of ColorTool newColor -> onClick $ \_ -> ApplyColor cycle newColor
                                   SelectTool -> onClick $ \_ -> SelectCycle cycle
                                   _ -> onClick (const $ NoOp)
      draw cycle color = (drawCycle cycle) ! stroke "black" ! (fill $ toHexString color)
   in g ! className "cycles" $ for_ (mapToList cycles) $ \(Tuple cycle color) -> (draw cycle color) #! handler cycle

drawPoint :: Point -> Number -> HTML Event
drawPoint (Point x y) size =
  circle ! (cx $ show x)
         ! (cy $ show y)
         ! (r $ show size)

drawSnapPoint :: Maybe Point -> HTML Event
drawSnapPoint Nothing = g $ pure unit
drawSnapPoint (Just p) = drawPoint p 3.0

drawCurrentStroke :: Maybe Stroke -> HTML Event
drawCurrentStroke Nothing = g $ pure unit
drawCurrentStroke (Just s) =
  drawStroke s ! stroke "gray" ! strokeDasharray "5 5" ! fill "transparent"

drawSelection :: List Cycle -> HTML Event
drawSelection cycles =
  g ! className "selected" $ for_ cycles \cycle -> drawCycle cycle ! stroke "red" ! fill "transparent"

readPageXY :: DOMEvent -> {clientX:: Number, clientY:: Number}
readPageXY ev =
  let readXY mouseEv = {clientX: toNumber $ clientX mouseEv, clientY: toNumber $ clientY mouseEv}
   in either (const {clientX: 0.0, clientY: 0.0}) readXY $ runExcept $ eventToMouseEvent ev

withListeners :: Tool -> HTML Event -> HTML Event
withListeners tool html =
  case tool of _ | elem tool [LineTool, ArcTool] -> html #! (onClick (readPageXY >>> \{clientX, clientY} -> Draw (Point clientX clientY)))
                                                         #! (onMouseMove (readPageXY >>> \{clientX, clientY} -> Move (Point clientX clientY)))
               EraserTool -> html #! (onMouseDown $ readPageXY >>> \{clientX, clientY} -> EraserDown (Point clientX clientY))
                                  #! (onMouseUp $ readPageXY >>> \{clientX, clientY} -> EraserUp (Point clientX clientY))
                                  #! (onMouseMove $ readPageXY >>> \{clientX, clientY} -> EraserMove (Point clientX clientY))
               _ -> html

drawing :: State -> HTML Event
drawing state =
  withListeners state.tool $
  svg ! style do
          width $ (toNumber state.windowWidth) # px
          height $ (toNumber state.windowHeight) # px
      $ do
        fillBackground state.background state.windowWidth state.windowHeight
        drawStrokes state.graph
        drawCycles state.tool state.cycles
        drawSnapPoint state.snapPoint
        drawCurrentStroke state.currentStroke
        drawSelection state.selection

view :: State -> HTML Event
view state =
  div $ do
    BackgroundView.view state.background
    ToolView.view state.tool
    drawing state

module App.View where

import Prelude

import App.Background.View (fillBackground)
import App.Background.View (view) as BackgroundView
import App.Cycle (Cycle(..))
import App.Events (Event(..))
import App.Geometry (Point(Point), Stroke(Arc, Line), distance, firstPoint, ptX, ptY, secondPoint, sweep)
import App.Graph (Graph, edges)
import App.State (State, Tool(..))
import App.Tool.View (view) as ToolView
import CSS.Color (Color, red, toHexString)
import CSS.Geometry (height, width)
import CSS.Size (px)
import Control.Monad.Except (runExcept)
import DOM.Event.MouseEvent (clientX, clientY, eventToMouseEvent)
import Data.Either (either)
import Data.Foldable (elem, for_)
import Data.Function.Uncurried (runFn2)
import Data.Int (toNumber)
import Data.List (List, foldl, (:))
import Data.Map (Map, toUnfoldable)
import Data.Maybe (Maybe(..))
import Data.Monoid (mempty)
import Data.Tuple (Tuple(..))
import Math (abs, pi)
import Pux.DOM.Events (DOMEvent, onClick, onMouseDown, onMouseMove, onMouseUp)
import Pux.DOM.HTML (HTML, memoize)
import Pux.DOM.HTML.Attributes (style)
import Text.Smolder.HTML (div)
import Text.Smolder.HTML.Attributes (className)
import Text.Smolder.Markup (Attribute, (!), (#!))
import Text.Smolder.SVG (circle, g, line, path, svg)
import Text.Smolder.SVG.Attributes (cx, cy, d, fill, r, stroke, strokeDasharray, x1, x2, y1, y2)

drawLine :: Attribute -> Point -> Point -> HTML Event
drawLine strokeStyle (Point px1 py1) (Point px2 py2) =
  line ! (x1 $ show px1)
       ! (y1 $ show py1)
       ! (x2 $ show px2)
       ! (y2 $ show py2)
       ! strokeStyle

drawStroke :: Attribute -> Stroke -> HTML Event
drawStroke strokeStyle s =
  let command = (mCmdString $ firstPoint s) <> (lCmdString s)
   in path ! strokeStyle ! (d command) $ pure unit

drawStrokes :: Graph -> HTML Event
drawStrokes = memoize \graph ->
  let
      strokeStyle :: Attribute
      strokeStyle = stroke "black" <> fill "transparent" <> className "stroke"
   in g ! className "strokes" $ for_ (edges graph) (drawStroke strokeStyle)

pathAttrs :: List Stroke -> Attribute
pathAttrs strokes@(s1 : _) =
  let p = firstPoint s1
   in d (foldl append (mCmdString p) (lCmdString <$> strokes))

pathAttrs _ = mempty

mCmdString :: Point -> String
mCmdString (Point x y) = "M " <> (show $ x) <> " " <> (show $ y) <> " "

lCmdString :: Stroke -> String
lCmdString (Line _ (Point x2 y2)) = "L " <> show x2 <> " " <> show y2 <> " "
lCmdString arc@(Arc c p q ccw) =
  if p == q then let halfPoint = c + c - p
                  in arcCmdString (Arc c p halfPoint ccw) <> arcCmdString (Arc c halfPoint q ccw)
            else arcCmdString arc

arcCmdString :: Stroke -> String
arcCmdString arc@(Arc c p q ccw) =
  let endPoint = secondPoint arc
      r = runFn2 distance c p
      s = sweep arc
   in "A "
      <> show r <> " " -- rx
      <> show r -- ry
      <> " 0 " -- x-axis-rotation
      <> show (if abs s > pi then 1 else 0) -- large sweep flag (sweep > 180 degrees)
      <> " "
      <> show (if ccw then 1 else 0) -- sweep flag (sweep starts positive or negative)
      <> " "
      <> show (ptX endPoint) <> " "
      <> show (ptY endPoint) <> " "

arcCmdString _ = ""

drawCycle :: Color -> Cycle -> HTML Event
drawCycle color cycle@(Cycle strokes) =
  path ! pathAttrs strokes ! stroke "black" ! (fill $ toHexString color) $ pure unit

mapToList :: forall k v. Map k v -> List (Tuple k v)
mapToList = toUnfoldable

drawCycles :: Tool -> Map Cycle Color -> HTML Event
drawCycles tool cycles =
  let handler cycle = case tool of ColorTool newColor -> onClick $ \_ -> ApplyColor cycle newColor
                                   SelectTool -> onClick $ \_ -> SelectCycle cycle
                                   _ -> onClick (const $ NoOp)
   in g ! className "cycles" $ for_ (mapToList cycles) $ \(Tuple cycle color) -> (drawCycle color cycle) #! handler cycle

drawPoint :: Point -> Number -> HTML Event
drawPoint (Point x y) size =
  circle ! (cx $ show x)
         ! (cy $ show y)
         ! (r $ show size)

drawSnapPoint :: Maybe Point -> HTML Event
drawSnapPoint Nothing = g $ pure unit
drawSnapPoint (Just p) = drawPoint p 3.0

currentStrokeAttrs:: Attribute
currentStrokeAttrs = stroke "black" <> strokeDasharray "5 5" <> fill "transparent"

drawCurrentStroke :: Maybe Stroke -> HTML Event
drawCurrentStroke Nothing = g $ pure unit
drawCurrentStroke (Just s) =
  drawStroke currentStrokeAttrs s

drawSelection :: List Cycle -> HTML Event
drawSelection cycles =
  g ! className "selected" $ for_ cycles $ drawCycle red

readPageXY :: DOMEvent -> {clientX:: Number, clientY:: Number}
readPageXY ev =
  let readXY mouseEv = {clientX: toNumber $ clientX mouseEv, clientY: toNumber $ clientY mouseEv}
   in either (const {clientX: 0.0, clientY: 0.0}) readXY $ runExcept $ eventToMouseEvent ev

withListeners :: Tool -> HTML Event -> HTML Event
withListeners tool html =
  case tool of _ | elem tool [LineTool, ArcTool] -> html #! (onClick (readPageXY >>> \{clientX, clientY} -> Draw (Point clientX clientY)))
                                                         #! (onMouseMove (readPageXY >>> \{clientX, clientY} -> Move (Point clientX clientY)))
               EraserTool -> html #! (onMouseDown $ readPageXY >>> \{clientX, clientY} -> EraserDown (Point clientX clientY))
                                  #! (onMouseUp $ readPageXY >>> \{clientX, clientY} -> EraserUp (Point clientX clientY))
                                  #! (onMouseMove $ readPageXY >>> \{clientX, clientY} -> EraserMove (Point clientX clientY))
               _ -> html

drawing :: State -> HTML Event
drawing state =
  withListeners state.tool $
  svg ! style do
          width $ (toNumber state.windowWidth) # px
          height $ (toNumber state.windowHeight) # px
      $ do
        fillBackground state.background state.windowWidth state.windowHeight
        drawStrokes state.graph
        drawCycles state.tool state.cycles
        drawSnapPoint state.snapPoint
        drawCurrentStroke state.currentStroke
        drawSelection state.selection

view :: State -> HTML Event
view state =
  div $ do
    BackgroundView.view state.background
    ToolView.view state.tool
    drawing state


Minor cleanup - remove unused imports

Minor cleanup - remove unused imports

module Test.HTTPure.UtilsSpec where

import Test.Spec as Spec
import HTTPure.Utils as Utils
import Test.HTTPure.TestHelpers as TestHelpers
import Test.HTTPure.TestHelpers ((?=))

utilsSpec :: TestHelpers.Test
utilsSpec =
  Spec.describe "replacePlus" do
    Spec.it "should replace all pluses" do
      Utils.replacePlus "HTTPPure+is+A+purescript+HTTP+server+framework"
        ?= "HTTPPure%20is%20A%20purescript%20HTTP%20server%20framework"

module Test.HTTPure.UtilsSpec where

import Prelude
import Data.Tuple as Tuple
import Foreign.Object as Object
import Test.Spec as Spec
import HTTPure.Query as Query
import HTTPure.Utils as Utils
import Test.HTTPure.TestHelpers as TestHelpers
import Test.HTTPure.TestHelpers ((?=))

utilsSpec :: TestHelpers.Test
utilsSpec =
  Spec.describe "replacePlus" do
    Spec.it "should replace all pluses" do
      Utils.replacePlus "HTTPPure+is+A+purescript+HTTP+server+framework"
        ?= "HTTPPure%20is%20A%20purescript%20HTTP%20server%20framework"


Switched Eq, Ord, and Show instances to use toAscList

-- | 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
  , toList
  , toAscList
  , toUnfoldable
  , delete
  , pop
  , member
  , alter
  , update
  , keys
  , values
  , union
  , unionWith
  , unions
  , size
  , mapWithKey
  ) where

import Prelude

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.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)

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

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

instance showMap :: (Show k, Show v) => Show (Map k v) where
  show m = "(fromList " <> show (toAscList 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 a key/value pair into 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 a list of key/value pairs
toList :: forall k v. Map k v -> List (Tuple k v)
toList Leaf = Nil
toList (Two left k v right) = toList left <> Tuple k v : toList right
toList (Three left k1 v1 mid k2 v2 right) = toList left <> Tuple k1 v1 : toList mid <> Tuple k2 v2 : toList right

-- | Convert a map to a list of key/value pairs where the keys are in ascending order
toAscList :: forall k v. Map k v -> List (Tuple k v)
toAscList = toList

-- | 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)

-- | 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 (toList m1)
  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
  , toList
  , toAscList
  , toUnfoldable
  , delete
  , pop
  , member
  , alter
  , update
  , keys
  , values
  , union
  , unionWith
  , unions
  , size
  , mapWithKey
  ) where

import Prelude

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.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)

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

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

instance showMap :: (Show k, Show v) => Show (Map k v) where
  show m = "(fromList " <> show (toList 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 a key/value pair into 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 a list of key/value pairs
toList :: forall k v. Map k v -> List (Tuple k v)
toList Leaf = Nil
toList (Two left k v right) = toList left <> Tuple k v : toList right
toList (Three left k1 v1 mid k2 v2 right) = toList left <> Tuple k1 v1 : toList mid <> Tuple k2 v2 : toList right

-- | Convert a map to a list of key/value pairs where the keys are in ascending order
toAscList :: forall k v. Map k v -> List (Tuple k v)
toAscList = toList

-- | 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)

-- | 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 (toList m1)
  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)


Fix missing headers and status code in file response

module Network.Wai.Handler.Swai.Response (makeResponseCallback) where

import Data.Function
import Control.Monad.Aff
import Network.HTTP
import Network.Wai.Internal
import Network.Wai
import Network.Wai.Handler.Swai.Types

foreign import fs "var fs = require('fs');" :: Unit

makeResponseCallback :: forall e. NodeResponse -> ResponseCallback e

makeResponseCallback response (ResponseString status headers body) = do
    liftEff' $ runFn4 respondString response (status2Number status) (headerToH <$> headers) body
    return ResponseReceived

makeResponseCallback response (ResponseFile status headers filename) = do
    liftEff' $ runFn4 respondFile response (status2Number status) (headerToH <$> headers) filename
    return ResponseReceived

data H = H String String

headerToH :: Header -> H
headerToH (Header head value) = H (show head) value

foreign import respondString """
function respondString(response, status, headers, body) {
    return function() {
        response.statusCode = status;
        headers.forEach(function(header) {
            response.setHeader(header.value0, header.value1);
        });
        response.end(body);
    };
}""" :: forall e. Fn4 NodeResponse Number [H] String (WaiEff e)

foreign import respondFile """
function respondFile(response, status, header, filepath) {
    return function() {
        fs.readFile(filepath, function(error, content) {
            if(error) {
                response.writeHead(404);
                response.end("404 - Not Found");
            } else {
                response.statusCode = status;
                headers.forEach(function(header) {
                    response.setHeader(header.value0, header.value1);
                });
                response.end(content);
            }
        });
    };
}""" :: forall e. Fn4 NodeResponse Number [H] String (WaiEff e)

module Network.Wai.Handler.Swai.Response (makeResponseCallback) where

import Data.Function
import Control.Monad.Aff
import Network.HTTP
import Network.Wai.Internal
import Network.Wai
import Network.Wai.Handler.Swai.Types

foreign import fs "var fs = require('fs');" :: Unit

makeResponseCallback :: forall e. NodeResponse -> ResponseCallback e

makeResponseCallback response (ResponseString status headers body) = do
    liftEff' $ runFn4 respondString response (status2Number status) (headerToH <$> headers) body
    return ResponseReceived

makeResponseCallback response (ResponseFile status headers filename) = do
    liftEff' $ runFn4 respondFile response (status2Number status) (headerToH <$> headers) filename
    return ResponseReceived

data H = H String String

headerToH :: Header -> H
headerToH (Header head value) = H (show head) value

foreign import respondString """
function respondString(response, status, headers, body) {
    return function() {
        response.statusCode = status;
        headers.forEach(function(header) {
            response.setHeader(header.value0, header.value1);
        });
        response.end(body);
    };
}""" :: forall e. Fn4 NodeResponse Number [H] String (WaiEff e)

foreign import respondFile """
function respondFile(response, status, header, filepath) {
    return function() {
        fs.readFile(filepath, function(error, content) {
            if(error) {
                response.writeHead(404);
                response.end("404 - Not Found");
            } else {
                response.end(content);
            }
        });
    };
}""" :: forall e. Fn4 NodeResponse Number [H] String (WaiEff e)


Restore DOM effect to both usages of effect row for EventListener

module DOM.Event.EventTarget where

import Prelude
import Control.Monad.Eff (kind Effect, Eff)
import Control.Monad.Eff.Exception (EXCEPTION)
import DOM (DOM)
import DOM.Event.Types (EventTarget, Event, EventType)

-- | A boxed function that can be used as an event listener. This is necessary
-- | due to the underling implementation of Eff functions.
foreign import data EventListener :: # Effect -> Type

-- | Creates an EventListener from a normal PureScript Eff function.
foreign import eventListener
  :: forall eff a
   . (Event -> Eff eff a)
  -> EventListener eff

-- | Adds a listener to an event target. The boolean argument indicates whether
-- | the listener should be added for the "capture" phase.
foreign import addEventListener
  :: forall eff
   . EventType
  -> EventListener (dom :: DOM | eff)
  -> Boolean
  -> EventTarget
  -> Eff (dom :: DOM | eff) Unit

-- | Removes a listener to an event target. The boolean argument indicates
-- | whether the listener should be removed for the "capture" phase.
foreign import removeEventListener
  :: forall eff
   . EventType
  -> EventListener (dom :: DOM | eff)
  -> Boolean
  -> EventTarget
  -> Eff (dom :: DOM | eff) Unit

-- | Dispatches an event from an event target.
foreign import dispatchEvent
  :: forall eff
   . Event
  -> EventTarget
  -> Eff (dom :: DOM, err :: EXCEPTION | eff) Boolean

module DOM.Event.EventTarget where

import Prelude
import Control.Monad.Eff (kind Effect, Eff)
import Control.Monad.Eff.Exception (EXCEPTION)
import DOM (DOM)
import DOM.Event.Types (EventTarget, Event, EventType)

-- | A boxed function that can be used as an event listener. This is necessary
-- | due to the underling implementation of Eff functions.
foreign import data EventListener :: # Effect -> Type

-- | Creates an EventListener from a normal PureScript Eff function.
foreign import eventListener
  :: forall eff a
   . (Event -> Eff eff a)
  -> EventListener eff

-- | Adds a listener to an event target. The boolean argument indicates whether
-- | the listener should be added for the "capture" phase.
foreign import addEventListener
  :: forall eff
   . EventType
  -> EventListener eff
  -> Boolean
  -> EventTarget
  -> Eff (dom :: DOM | eff) Unit

-- | Removes a listener to an event target. The boolean argument indicates
-- | whether the listener should be removed for the "capture" phase.
foreign import removeEventListener
  :: forall eff
   . EventType
  -> EventListener eff
  -> Boolean
  -> EventTarget
  -> Eff (dom :: DOM | eff) Unit

-- | Dispatches an event from an event target.
foreign import dispatchEvent
  :: forall eff
   . Event
  -> EventTarget
  -> Eff (dom :: DOM, err :: EXCEPTION | eff) Boolean


scheduler: Add KillMessage

scheduler: Add KillMessage

module Mesos.Scheduler where

import Prelude
import Control.Alt ((<|>))
import Control.Monad.Aff (Aff, makeAff, runAff)
import Control.Monad.Aff.AVar (AVAR, AVar, makeVar, putVar)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION, Error, throw, throwException)
import Control.Monad.Except (runExcept)
import Control.Monad.Error.Class (class MonadError, throwError, catchError)
import Control.Monad.State (execState, modify)
import Data.Either (either)
import Data.Foreign (Foreign, writeObject, toForeign, ForeignError(..))
import Data.Foreign.Class (class AsForeign, class IsForeign, readProp, write, (.=))
import Data.Foreign.Index (prop)
import Data.Foreign.Undefined (Undefined(..))
import Data.List.NonEmpty as NEL
import Data.Maybe (Maybe, maybe')
import Data.Newtype (class Newtype)
import Data.Options (Options, (:=))
import Data.StrMap (lookup)
import Data.StrMap as SM
import Data.Tuple (Tuple(..))
import Node.Encoding as Encoding
import Node.HTTP as HTTP
import Node.HTTP.Client (RequestHeaders(..), RequestOptions, Response, request, method, path, requestAsStream, responseHeaders, responseAsStream, statusCode, headers)
import Node.Process (stdout)
import Mesos.Raw (FrameworkID, FrameworkInfo, KillPolicy, Offer, OfferID, TaskID, TaskStatus, AgentID, ExecutorID, Filters, readPropNU, readPropNUM)
import Mesos.Raw.Offer (Operation)
import Mesos.RecordIO (onRecordIO)
import Mesos.Stream (readFullString)
import Mesos.Util (jsonStringify, fromJSON, throwErrorS)
import Node.Stream (end, writeString, pipe)

newtype Kill = Kill
    { taskId :: TaskID
    , slaveId :: Maybe AgentID
    , killPolicy :: Maybe KillPolicy
    }

instance killAsForeign :: AsForeign Kill where
    write (Kill obj) = writeObject $
        [ "task_id" .= write obj.taskId
        , "slave_id" .= (write $ Undefined obj.slaveId)
        , "kill_policy" .= (write $ Undefined obj.killPolicy)
        ]

instance killIsForeign :: IsForeign Kill where
    read obj = do
        taskId <- readProp "task_id" obj
        slaveId <- readPropNU "slave_id" obj
        killPolicy <- readPropNU "kill_policy" obj
        pure <<< Kill $
            { taskId: taskId
            , slaveId: slaveId
            , killPolicy: killPolicy
            }

derive instance killNewtype :: Newtype Kill _

newtype ReconcileTask = ReconcileTask
    { taskId :: TaskID
    , slaveId :: Maybe AgentID
    }

instance reconcileTaskAsForeign :: AsForeign ReconcileTask where
    write (ReconcileTask obj) = writeObject $
        [ "task_id" .= write obj.taskId
        , "slave_id" .= (write $ Undefined obj.slaveId)
        ]

instance reconcileTaskIsForeign :: IsForeign ReconcileTask where
    read obj = do
        taskId <- readProp "task_id" obj
        slaveId <- readPropNU "slave_id" obj
        pure <<< ReconcileTask $
            { taskId: taskId
            , slaveId: slaveId
            }

derive instance reconcileTaskNewtype :: Newtype ReconcileTask _

newtype Subscribed = Subscribed { frameworkId :: FrameworkID
                                , heartbeatIntervalSeconds :: Int
                                }

instance subscribedAsForeign :: AsForeign Subscribed where
    write (Subscribed obj) = writeObject props where
        props = [ "framework_id" .= write obj.frameworkId
                , "heartbeat_interval_seconds" .= write obj.heartbeatIntervalSeconds
                ]

instance subscribedIsForeign :: IsForeign Subscribed where
    read value = do
        frameworkId <- readProp "framework_id" value
        heartbeatIntervalSeconds <- readProp "heartbeat_interval_seconds" value
        pure $ Subscribed { frameworkId: frameworkId
                          , heartbeatIntervalSeconds: heartbeatIntervalSeconds
                          }

newtype Subscribe = Subscribe { frameworkInfo :: FrameworkInfo
                              }

instance subscribeAsForeign :: AsForeign Subscribe where
    write (Subscribe obj) = writeObject props where
        props = [ "framework_info" .= write obj.frameworkInfo
                ]

newtype ExecutorMessage = ExecutorMessage
    { agentId :: AgentID
    , executorId :: ExecutorID
    , data :: String
    }

instance executorMessageAsForeign :: AsForeign ExecutorMessage where
    write (ExecutorMessage obj) = writeObject props where
        props = [ "agent_id" .= write obj.agentId
                , "executor_id" .= write obj.executorId
                , "data" .= write obj.data
                ]

instance executorMessageIsForeign :: IsForeign ExecutorMessage where
    read obj = do
        agentId <- readProp "agent_id" obj
        executorId <- readProp "executor_id" obj
        d <- readProp "data" obj
        pure <<< ExecutorMessage $
            { agentId: agentId
            , executorId: executorId
            , data: d
            }

newtype Failure = Failure
    { slaveId :: Maybe AgentID
    , executorId :: Maybe ExecutorID
    , status :: Maybe Int
    }

instance failureAsForeign :: AsForeign Failure where
    write (Failure obj) = writeObject props where
        props = [ "agent_id" .= (write $ Undefined obj.slaveId)
                , "executor_id" .= (write $ Undefined obj.executorId)
                , "status" .= (write $ Undefined obj.status)
                ]

instance failureIsForeign :: IsForeign Failure where
    read obj = do
        slaveId <- catchError (readPropNU "agent_id" obj) \_ -> readPropNU "slave_id" obj
        executorId <- readPropNU "executor_id" obj
        status <- readPropNU "status" obj
        pure <<< Failure $
            { slaveId: slaveId
            , executorId: executorId
            , status: status
            }

newtype Decline = Decline
    { offerIds :: Array OfferID
    , filters :: Maybe Filters
    }

instance declineAsForeign :: AsForeign Decline where
    write (Decline obj) = writeObject props where
        props = [ "offer_ids" .= write obj.offerIds
                , "filters" .= (write $ Undefined obj.filters)
                ]

instance declineIsForeign :: IsForeign Decline where
    read obj = do
        offerIds <- readPropNUM "offer_ids" obj
        filters <- readPropNU "filters" obj
        pure <<< Decline $
            { offerIds: offerIds
            , filters: filters
            }

newtype Accept = Accept
    { offerIds :: Array OfferID
    , operations :: Array Operation
    , filters :: Maybe Filters
    }

instance acceptAsForeign :: AsForeign Accept where
    write (Accept obj) = writeObject props where
        props = [ "offer_ids" .= write obj.offerIds
                , "operations" .= write obj.operations
                , "filters" .= (write $ Undefined obj.filters)
                ]

instance acceptIsForeign :: IsForeign Accept where
    read obj = do
        offerIds <- readPropNUM "offer_ids" obj
        operations <- readPropNUM "operations" obj
        filters <- readPropNU "filters" obj
        pure <<< Accept $
            { offerIds: offerIds
            , operations: operations
            , filters: filters
            }

newtype Acknowlege = Acknowlege
    { slaveId :: AgentID
    , taskId :: TaskID
    , uuid :: String
    }

instance acknowlegeAsForeign :: AsForeign Acknowlege where
    write (Acknowlege obj) = writeObject props where
        props = [ "agent_id" .= write obj.slaveId
                , "task_id" .= write obj.taskId
                , "uuid" .= write obj.uuid
                ]

instance acknowlegeIsForeign :: IsForeign Acknowlege where
    read obj = do
        slaveId <- readProp "slave_id" obj <|> readProp "agent_id" obj
        taskId <- readProp "task_id" obj
        uuid <- readProp "uuid" obj
        pure <<< Acknowlege $
            { slaveId: slaveId
            , taskId: taskId
            , uuid: uuid
            }

-- | Represents a single RecordIO message
data Message = SubscribeMessage Subscribe
             | SubscribedMessage Subscribed
             | OffersMessage (Array Offer)
             | RescindMessage OfferID
             | UpdateMessage TaskStatus
             | MessageMessage ExecutorMessage
             | FailureMessage Failure
             | ErrorMessage String
             | HeartbeatMessage
             | CustomMessage (forall o. { type :: String | o })
             | DeclineMessage FrameworkID Decline
             | AcceptMessage FrameworkID Accept
             | AcknowlegeMessage FrameworkID Acknowlege
             | ReconcileMessage FrameworkID (Array ReconcileTask)
             | KillMessage FrameworkID Kill

instance messageShow :: Show Message where
    show = jsonStringify <<< write

-- | Utility for Writing a mesos subscribe-style recordio message
writeMessage :: forall a. (AsForeign a) => String -> String -> a -> Foreign
writeMessage t k d = writeObject props where
    props = [ "type" .= toForeign t
            , k .= write d
            ]

instance messageAsForeign :: AsForeign Message where
    write (SubscribeMessage subscribeInfo) = writeMessage "SUBSCRIBE" "subscribe" subscribeInfo
    write (SubscribedMessage subscribedInfo) = writeMessage "SUBSCRIBED" "subscribed" subscribedInfo
    write (OffersMessage offers) = writeMessage "OFFERS" "offers" offers
    write (RescindMessage offerId) = toForeign $
        { type: "RESCIND"
        , rescind: { offer_id: write offerId }
        }
    write (UpdateMessage taskStatus) = toForeign $
        { type: "UPDATE"
        , update: { status: write taskStatus }
        }
    write (MessageMessage msg) = writeMessage "MESSAGE" "message" msg
    write (FailureMessage failure) = writeMessage "FAILURE" "failure" failure
    write (ErrorMessage msg) = toForeign $
        { type: "ERROR"
        , message: msg
        }
    write HeartbeatMessage = toForeign $ { type: "HEARTBEAT" }
    write (CustomMessage obj) = toForeign obj
    write (DeclineMessage fwid decline) = toForeign $
        { type: "DECLINE"
        , framework_id: write fwid
        , decline: write decline
        }
    write (AcceptMessage fwid acceptInfo) = toForeign $
        { type: "ACCEPT"
        , framework_id: write fwid
        , accept: write acceptInfo
        }
    write (AcknowlegeMessage fwid acknowlegeInfo) = toForeign $
        { type: "ACKNOWLEDGE"
        , framework_id: write fwid
        , acknowledge: write acknowlegeInfo
        }
    write (ReconcileMessage fwid reconcileTasks) = toForeign $
        { type: "RECONCILE"
        , framework_id: write fwid
        , reconcile: { tasks: write reconcileTasks }
        }
    write (KillMessage fwid killInfo) = toForeign $
        { type: "KILL"
        , framework_id: write fwid
        , kill: write killInfo
        }

instance messageIsForeign :: IsForeign Message where
    read value = readProp "type" value >>= readMessageType where
        readMessageType "SUBSCRIBE" = throwError $ NEL.singleton $ ForeignError "Unimplemented!" -- TODO: implement
        readMessageType "SUBSCRIBED" = SubscribedMessage <$> readProp "subscribed" value
        readMessageType "OFFERS" = OffersMessage <$> (prop "offers" value >>= readProp "offers")
        readMessageType "RESCIND" = RescindMessage <$> (prop "rescind" value >>= readProp "offer_id")
        readMessageType "UPDATE" = UpdateMessage <$> (prop "update" value >>= readProp "status")
        readMessageType "MESSAGE" = MessageMessage <$> readProp "message" value
        readMessageType "FAILURE" = FailureMessage <$> readProp "failure" value
        readMessageType "ERRROR" = ErrorMessage <$> readProp "message" value
        readMessageType "HEARTBEAT" = pure HeartbeatMessage
        readMessageType "DECLINE" = DeclineMessage <$> readProp "framework_id" value <*> readProp "decline" value
        readMessageType "ACCEPT" = AcceptMessage <$> readProp "framework_id" value <*> readProp "accept" value
        readMessageType "ACKNOWLEDGE" = AcknowlegeMessage <$> readProp "framework_id" value <*> readProp "acknowlege" value
        readMessageType "RECONCILE" = ReconcileMessage <$> readProp "framework_id" value <*> (prop "reconcile" value >>= readProp "tasks")
        readMessageType "KILL" = KillMessage <$> readProp "framework_id" value <*> readProp "kill" value
        readMessageType _ = throwError $ NEL.singleton $ ErrorAtProperty "type" (ForeignError "Unknown message type")

-- | List of common headers to include in a call to the mesos scheduler subscribe api
subscribeHeaders :: RequestHeaders
subscribeHeaders =
    SM.insert "Content-Type" "application/json" >>>
    SM.insert "Accept" "application/json" >>>
    SM.insert "Connection" "close" >>>
    RequestHeaders $
    SM.empty

messageHeaders :: SM.StrMap String
messageHeaders =
    SM.insert "Content-Type" "application/json" $
    SM.empty

checkResponseStatus :: forall eff. Int -> Response -> Aff (http :: HTTP.HTTP, err :: EXCEPTION | eff) Response
checkResponseStatus expectedStatusCode res
    | statusCode res == expectedStatusCode = pure res
    | otherwise = do
        let resStream = responseAsStream res
        message <- readFullString resStream Encoding.UTF8
        throwErrorS $ "Bad response status code (" <> (show <<< statusCode) res <> "): " <> message

-- | Convenience wrapper for `scheduler` that sends accept messages
accept :: forall eff. Options RequestOptions
       -> String
       -> Message
       -> Aff (http :: HTTP.HTTP, err :: EXCEPTION | eff) Response
accept userReqOpts mesosStreamId message =
    scheduler userReqOpts mesosStreamId message >>= checkResponseStatus 202

scheduler :: forall eff. Options RequestOptions
          -> String
          -> Message
          -> Aff (http :: HTTP.HTTP, err :: EXCEPTION | eff) Response
scheduler userReqOpts mesosStreamId message =
    makeAff \_ onS -> do
        req <- request reqOpts onS
        let reqStream = requestAsStream req
            reqData = jsonStringify <<< write $ message
        writeString reqStream Encoding.UTF8 reqData $ end reqStream (pure unit)
        pure unit
    where
    reqOpts :: Options RequestOptions
    reqOpts = flip execState userReqOpts do
        overrideOption $ method := "POST"
        overrideOption $ path := "/api/v1/scheduler"
        overrideOption $ headers := (RequestHeaders $ SM.insert "Mesos-Stream-Id" mesosStreamId messageHeaders)
        where
            overrideOption o = modify $ flip (<>) o

-- | `AVar` version of `subscribe`
subscribe' :: forall eff. Options RequestOptions
           -> Subscribe
           -> Aff (avar :: AVAR, err :: EXCEPTION, http :: HTTP.HTTP, console :: CONSOLE | eff) (Tuple String (AVar Message))
subscribe' userReqOpts subscribeInfo = do
    v <- makeVar
    streamId <- subscribe userReqOpts subscribeInfo \str -> do
        runAff throwException (\_ -> pure unit) $ putVar v str
        pure unit
    pure $ Tuple streamId v

-- | Make a call to `/api/v1/subscribe`, taking an action for each message
subscribe :: forall eff. Options RequestOptions
          -> Subscribe
          -> (Message -> Eff (avar :: AVAR, err :: EXCEPTION, http :: HTTP.HTTP, console :: CONSOLE | eff) Unit)
          -> Aff (avar :: AVAR, err :: EXCEPTION, http :: HTTP.HTTP, console :: CONSOLE | eff) String
subscribe userReqOpts subscribeInfo callback = do
    res <- makeAff \_ onS -> do
        req <- request reqOpts onS
        let reqStream = requestAsStream req
            reqData = jsonStringify <<< write $ SubscribeMessage subscribeInfo
        writeString reqStream Encoding.UTF8 reqData $ end reqStream (pure unit)
        pure unit
    handleRes res
    where
        handleRes :: Response -> Aff (avar :: AVAR, err :: EXCEPTION, http :: HTTP.HTTP, console :: CONSOLE | eff) String
        handleRes res
          | statusCode res == 200 = do
              mesosStreamId <- requiredHeader "mesos-stream-id"
              liftEff <<< log $ "mesos-stream-id: " <> mesosStreamId
              liftEff $ onRecordIO resStream throwException handleRecord
              pure mesosStreamId
              where
                  handleRecord =
                      either (throw <<< show) callback <<<
                      runExcept <<<
                      fromJSON
                  headers = responseHeaders res
                  resStream = responseAsStream res
                  requiredHeader :: forall m. (MonadError Error m) => String -> m String
                  requiredHeader key =
                      maybe' (throwErrorS <<< e) pure $ lookup key headers where
                          e _ = "Header \"" <> key <> "\" not found"
          | otherwise = do
              liftEff do
                  log $ "Reponse status error (" <> (show <<< statusCode) res <> "):"
                  pipe (responseAsStream res) stdout
                  log ""
              throwErrorS $ "Response status error " <> (show <<< statusCode) res <> ")"
        reqOpts :: Options RequestOptions
        reqOpts = flip execState userReqOpts do
            overrideOption $ method := "POST"
            overrideOption $ path := "/api/v1/scheduler"
            overrideOption $ headers := subscribeHeaders
            where
                overrideOption o = modify $ flip (<>) o

module Mesos.Scheduler where

import Prelude
import Control.Alt ((<|>))
import Control.Monad.Aff (Aff, makeAff, runAff)
import Control.Monad.Aff.AVar (AVAR, AVar, makeVar, putVar)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION, Error, throw, throwException)
import Control.Monad.Except (runExcept)
import Control.Monad.Error.Class (class MonadError, throwError, catchError)
import Control.Monad.State (execState, modify)
import Data.Either (either)
import Data.Foreign (Foreign, writeObject, toForeign, ForeignError(..))
import Data.Foreign.Class (class AsForeign, class IsForeign, readProp, write, (.=))
import Data.Foreign.Index (prop)
import Data.Foreign.Undefined (Undefined(..))
import Data.List.NonEmpty as NEL
import Data.Maybe (Maybe, maybe')
import Data.Newtype (class Newtype)
import Data.Options (Options, (:=))
import Data.StrMap (lookup)
import Data.StrMap as SM
import Data.Tuple (Tuple(..))
import Node.Encoding as Encoding
import Node.HTTP as HTTP
import Node.HTTP.Client (RequestHeaders(..), RequestOptions, Response, request, method, path, requestAsStream, responseHeaders, responseAsStream, statusCode, headers)
import Node.Process (stdout)
import Mesos.Raw (FrameworkID, FrameworkInfo, Offer, OfferID, TaskID, TaskStatus, AgentID, ExecutorID, Filters, readPropNU, readPropNUM)
import Mesos.Raw.Offer (Operation)
import Mesos.RecordIO (onRecordIO)
import Mesos.Stream (readFullString)
import Mesos.Util (jsonStringify, fromJSON, throwErrorS)
import Node.Stream (end, writeString, pipe)

newtype ReconcileTask = ReconcileTask
    { taskId :: TaskID
    , slaveId :: Maybe AgentID
    }

instance reconcileTaskAsForeign :: AsForeign ReconcileTask where
    write (ReconcileTask obj) = writeObject $
        [ "task_id" .= write obj.taskId
        , "slave_id" .= (write $ Undefined obj.slaveId)
        ]

instance reconcileTaskIsForeign :: IsForeign ReconcileTask where
    read obj = do
        taskId <- readProp "task_id" obj
        slaveId <- readPropNU "slave_id" obj
        pure <<< ReconcileTask $
            { taskId: taskId
            , slaveId: slaveId
            }

derive instance reconcileTaskNewtype :: Newtype ReconcileTask _

newtype Subscribed = Subscribed { frameworkId :: FrameworkID
                                , heartbeatIntervalSeconds :: Int
                                }

instance subscribedAsForeign :: AsForeign Subscribed where
    write (Subscribed obj) = writeObject props where
        props = [ "framework_id" .= write obj.frameworkId
                , "heartbeat_interval_seconds" .= write obj.heartbeatIntervalSeconds
                ]

instance subscribedIsForeign :: IsForeign Subscribed where
    read value = do
        frameworkId <- readProp "framework_id" value
        heartbeatIntervalSeconds <- readProp "heartbeat_interval_seconds" value
        pure $ Subscribed { frameworkId: frameworkId
                          , heartbeatIntervalSeconds: heartbeatIntervalSeconds
                          }

newtype Subscribe = Subscribe { frameworkInfo :: FrameworkInfo
                              }

instance subscribeAsForeign :: AsForeign Subscribe where
    write (Subscribe obj) = writeObject props where
        props = [ "framework_info" .= write obj.frameworkInfo
                ]

newtype ExecutorMessage = ExecutorMessage
    { agentId :: AgentID
    , executorId :: ExecutorID
    , data :: String
    }

instance executorMessageAsForeign :: AsForeign ExecutorMessage where
    write (ExecutorMessage obj) = writeObject props where
        props = [ "agent_id" .= write obj.agentId
                , "executor_id" .= write obj.executorId
                , "data" .= write obj.data
                ]

instance executorMessageIsForeign :: IsForeign ExecutorMessage where
    read obj = do
        agentId <- readProp "agent_id" obj
        executorId <- readProp "executor_id" obj
        d <- readProp "data" obj
        pure <<< ExecutorMessage $
            { agentId: agentId
            , executorId: executorId
            , data: d
            }

newtype Failure = Failure
    { slaveId :: Maybe AgentID
    , executorId :: Maybe ExecutorID
    , status :: Maybe Int
    }

instance failureAsForeign :: AsForeign Failure where
    write (Failure obj) = writeObject props where
        props = [ "agent_id" .= (write $ Undefined obj.slaveId)
                , "executor_id" .= (write $ Undefined obj.executorId)
                , "status" .= (write $ Undefined obj.status)
                ]

instance failureIsForeign :: IsForeign Failure where
    read obj = do
        slaveId <- catchError (readPropNU "agent_id" obj) \_ -> readPropNU "slave_id" obj
        executorId <- readPropNU "executor_id" obj
        status <- readPropNU "status" obj
        pure <<< Failure $
            { slaveId: slaveId
            , executorId: executorId
            , status: status
            }

newtype Decline = Decline
    { offerIds :: Array OfferID
    , filters :: Maybe Filters
    }

instance declineAsForeign :: AsForeign Decline where
    write (Decline obj) = writeObject props where
        props = [ "offer_ids" .= write obj.offerIds
                , "filters" .= (write $ Undefined obj.filters)
                ]

instance declineIsForeign :: IsForeign Decline where
    read obj = do
        offerIds <- readPropNUM "offer_ids" obj
        filters <- readPropNU "filters" obj
        pure <<< Decline $
            { offerIds: offerIds
            , filters: filters
            }

newtype Accept = Accept
    { offerIds :: Array OfferID
    , operations :: Array Operation
    , filters :: Maybe Filters
    }

instance acceptAsForeign :: AsForeign Accept where
    write (Accept obj) = writeObject props where
        props = [ "offer_ids" .= write obj.offerIds
                , "operations" .= write obj.operations
                , "filters" .= (write $ Undefined obj.filters)
                ]

instance acceptIsForeign :: IsForeign Accept where
    read obj = do
        offerIds <- readPropNUM "offer_ids" obj
        operations <- readPropNUM "operations" obj
        filters <- readPropNU "filters" obj
        pure <<< Accept $
            { offerIds: offerIds
            , operations: operations
            , filters: filters
            }

newtype Acknowlege = Acknowlege
    { slaveId :: AgentID
    , taskId :: TaskID
    , uuid :: String
    }

instance acknowlegeAsForeign :: AsForeign Acknowlege where
    write (Acknowlege obj) = writeObject props where
        props = [ "agent_id" .= write obj.slaveId
                , "task_id" .= write obj.taskId
                , "uuid" .= write obj.uuid
                ]

instance acknowlegeIsForeign :: IsForeign Acknowlege where
    read obj = do
        slaveId <- readProp "slave_id" obj <|> readProp "agent_id" obj
        taskId <- readProp "task_id" obj
        uuid <- readProp "uuid" obj
        pure <<< Acknowlege $
            { slaveId: slaveId
            , taskId: taskId
            , uuid: uuid
            }

-- | Represents a single RecordIO message
data Message = SubscribeMessage Subscribe
             | SubscribedMessage Subscribed
             | OffersMessage (Array Offer)
             | RescindMessage OfferID
             | UpdateMessage TaskStatus
             | MessageMessage ExecutorMessage
             | FailureMessage Failure
             | ErrorMessage String
             | HeartbeatMessage
             | CustomMessage (forall o. { type :: String | o })
             | DeclineMessage FrameworkID Decline
             | AcceptMessage FrameworkID Accept
             | AcknowlegeMessage FrameworkID Acknowlege
             | ReconcileMessage FrameworkID (Array ReconcileTask)

instance messageShow :: Show Message where
    show = jsonStringify <<< write

-- | Utility for Writing a mesos subscribe-style recordio message
writeMessage :: forall a. (AsForeign a) => String -> String -> a -> Foreign
writeMessage t k d = writeObject props where
    props = [ "type" .= toForeign t
            , k .= write d
            ]

instance messageAsForeign :: AsForeign Message where
    write (SubscribeMessage subscribeInfo) = writeMessage "SUBSCRIBE" "subscribe" subscribeInfo
    write (SubscribedMessage subscribedInfo) = writeMessage "SUBSCRIBED" "subscribed" subscribedInfo
    write (OffersMessage offers) = writeMessage "OFFERS" "offers" offers
    write (RescindMessage offerId) = toForeign $
        { type: "RESCIND"
        , rescind: { offer_id: write offerId }
        }
    write (UpdateMessage taskStatus) = toForeign $
        { type: "UPDATE"
        , update: { status: write taskStatus }
        }
    write (MessageMessage msg) = writeMessage "MESSAGE" "message" msg
    write (FailureMessage failure) = writeMessage "FAILURE" "failure" failure
    write (ErrorMessage msg) = toForeign $
        { type: "ERROR"
        , message: msg
        }
    write HeartbeatMessage = toForeign $ { type: "HEARTBEAT" }
    write (CustomMessage obj) = toForeign obj
    write (DeclineMessage fwid decline) = toForeign $
        { type: "DECLINE"
        , framework_id: write fwid
        , decline: write decline
        }
    write (AcceptMessage fwid acceptInfo) = toForeign $
        { type: "ACCEPT"
        , framework_id: write fwid
        , accept: write acceptInfo
        }
    write (AcknowlegeMessage fwid acknowlegeInfo) = toForeign $
        { type: "ACKNOWLEDGE"
        , framework_id: write fwid
        , acknowledge: write acknowlegeInfo
        }
    write (ReconcileMessage fwid reconcileTasks) = toForeign $
        { type: "RECONCILE"
        , framework_id: write fwid
        , reconcile: { tasks: write reconcileTasks }
        }

instance messageIsForeign :: IsForeign Message where
    read value = readProp "type" value >>= readMessageType where
        readMessageType "SUBSCRIBE" = throwError $ NEL.singleton $ ForeignError "Unimplemented!" -- TODO: implement
        readMessageType "SUBSCRIBED" = SubscribedMessage <$> readProp "subscribed" value
        readMessageType "OFFERS" = OffersMessage <$> (prop "offers" value >>= readProp "offers")
        readMessageType "RESCIND" = RescindMessage <$> (prop "rescind" value >>= readProp "offer_id")
        readMessageType "UPDATE" = UpdateMessage <$> (prop "update" value >>= readProp "status")
        readMessageType "MESSAGE" = MessageMessage <$> readProp "message" value
        readMessageType "FAILURE" = FailureMessage <$> readProp "failure" value
        readMessageType "ERRROR" = ErrorMessage <$> readProp "message" value
        readMessageType "HEARTBEAT" = pure HeartbeatMessage
        readMessageType "DECLINE" = DeclineMessage <$> readProp "framework_id" value <*> readProp "decline" value
        readMessageType "ACCEPT" = AcceptMessage <$> readProp "framework_id" value <*> readProp "accept" value
        readMessageType "ACKNOWLEDGE" = AcknowlegeMessage <$> readProp "framework_id" value <*> readProp "acknowlege" value
        readMessageType "RECONCILE" = ReconcileMessage <$> readProp "framework_id" value <*> (prop "reconcile" value >>= readProp "tasks")
        readMessageType _ = throwError $ NEL.singleton $ ErrorAtProperty "type" (ForeignError "Unknown message type")

-- | List of common headers to include in a call to the mesos scheduler subscribe api
subscribeHeaders :: RequestHeaders
subscribeHeaders =
    SM.insert "Content-Type" "application/json" >>>
    SM.insert "Accept" "application/json" >>>
    SM.insert "Connection" "close" >>>
    RequestHeaders $
    SM.empty

messageHeaders :: SM.StrMap String
messageHeaders =
    SM.insert "Content-Type" "application/json" $
    SM.empty

checkResponseStatus :: forall eff. Int -> Response -> Aff (http :: HTTP.HTTP, err :: EXCEPTION | eff) Response
checkResponseStatus expectedStatusCode res
    | statusCode res == expectedStatusCode = pure res
    | otherwise = do
        let resStream = responseAsStream res
        message <- readFullString resStream Encoding.UTF8
        throwErrorS $ "Bad response status code (" <> (show <<< statusCode) res <> "): " <> message

-- | Convenience wrapper for `scheduler` that sends accept messages
accept :: forall eff. Options RequestOptions
       -> String
       -> Message
       -> Aff (http :: HTTP.HTTP, err :: EXCEPTION | eff) Response
accept userReqOpts mesosStreamId message =
    scheduler userReqOpts mesosStreamId message >>= checkResponseStatus 202

scheduler :: forall eff. Options RequestOptions
          -> String
          -> Message
          -> Aff (http :: HTTP.HTTP, err :: EXCEPTION | eff) Response
scheduler userReqOpts mesosStreamId message =
    makeAff \_ onS -> do
        req <- request reqOpts onS
        let reqStream = requestAsStream req
            reqData = jsonStringify <<< write $ message
        writeString reqStream Encoding.UTF8 reqData $ end reqStream (pure unit)
        pure unit
    where
    reqOpts :: Options RequestOptions
    reqOpts = flip execState userReqOpts do
        overrideOption $ method := "POST"
        overrideOption $ path := "/api/v1/scheduler"
        overrideOption $ headers := (RequestHeaders $ SM.insert "Mesos-Stream-Id" mesosStreamId messageHeaders)
        where
            overrideOption o = modify $ flip (<>) o

-- | `AVar` version of `subscribe`
subscribe' :: forall eff. Options RequestOptions
           -> Subscribe
           -> Aff (avar :: AVAR, err :: EXCEPTION, http :: HTTP.HTTP, console :: CONSOLE | eff) (Tuple String (AVar Message))
subscribe' userReqOpts subscribeInfo = do
    v <- makeVar
    streamId <- subscribe userReqOpts subscribeInfo \str -> do
        runAff throwException (\_ -> pure unit) $ putVar v str
        pure unit
    pure $ Tuple streamId v

-- | Make a call to `/api/v1/subscribe`, taking an action for each message
subscribe :: forall eff. Options RequestOptions
          -> Subscribe
          -> (Message -> Eff (avar :: AVAR, err :: EXCEPTION, http :: HTTP.HTTP, console :: CONSOLE | eff) Unit)
          -> Aff (avar :: AVAR, err :: EXCEPTION, http :: HTTP.HTTP, console :: CONSOLE | eff) String
subscribe userReqOpts subscribeInfo callback = do
    res <- makeAff \_ onS -> do
        req <- request reqOpts onS
        let reqStream = requestAsStream req
            reqData = jsonStringify <<< write $ SubscribeMessage subscribeInfo
        writeString reqStream Encoding.UTF8 reqData $ end reqStream (pure unit)
        pure unit
    handleRes res
    where
        handleRes :: Response -> Aff (avar :: AVAR, err :: EXCEPTION, http :: HTTP.HTTP, console :: CONSOLE | eff) String
        handleRes res
          | statusCode res == 200 = do
              mesosStreamId <- requiredHeader "mesos-stream-id"
              liftEff <<< log $ "mesos-stream-id: " <> mesosStreamId
              liftEff $ onRecordIO resStream throwException handleRecord
              pure mesosStreamId
              where
                  handleRecord =
                      either (throw <<< show) callback <<<
                      runExcept <<<
                      fromJSON
                  headers = responseHeaders res
                  resStream = responseAsStream res
                  requiredHeader :: forall m. (MonadError Error m) => String -> m String
                  requiredHeader key =
                      maybe' (throwErrorS <<< e) pure $ lookup key headers where
                          e _ = "Header \"" <> key <> "\" not found"
          | otherwise = do
              liftEff do
                  log $ "Reponse status error (" <> (show <<< statusCode) res <> "):"
                  pipe (responseAsStream res) stdout
                  log ""
              throwErrorS $ "Response status error " <> (show <<< statusCode) res <> ")"
        reqOpts :: Options RequestOptions
        reqOpts = flip execState userReqOpts do
            overrideOption $ method := "POST"
            overrideOption $ path := "/api/v1/scheduler"
            overrideOption $ headers := subscribeHeaders
            where
                overrideOption o = modify $ flip (<>) o


Use `Data.Function.on`

Use `Data.Function.on`

module Data.String.Ext (
  (^=)
  ) where

import Prelude
import Data.String as Str
import Data.Function (on)

(^=) :: String -> String -> Boolean
(^=) = eq `on` Str.toUpper

module Data.String.Ext (
  (^=)
  ) where

import Prelude
import Data.String as Str

(^=) :: String -> String -> Boolean
(^=) a b = Str.toUpper a == Str.toUpper b


renaming

renaming

module KanColle.Expedition.New.Config
  ( Config
  , mkConfig
  , defConfig
  , getCompositionWithConfig
  ) where

import Prelude
import Data.Maybe
import KanColle.Expedition.New.SType
import KanColle.Expedition.New.MinCompo
import Data.Array as A
import Data.Unfoldable

type FleetCompo = Array SType

-- configuration for a single expedition.
data Config = Conf
  { greatSuccess :: Boolean
  , normDaihatsuCount :: Int -- normalized, should be one of [0..4]
  , wildcardSType :: SType
  }

mkConfig :: Boolean -> Int -> SType -> Config
mkConfig gs dCount wt = Conf
    { greatSuccess: gs
    , normDaihatsuCount: if dCount > 4 then 4 else dCount
    , wildcardSType: wt
    }

defConfig :: Config
defConfig = mkConfig false 0 DD

getCompositionWithConfig :: Config -> Int -> FleetCompo
getCompositionWithConfig (Conf c) n = if c.greatSuccess
    then compo <> replicate (6 - l) c.wildcardSType
    else compo
  where
    minCompo = getMinimumComposition n
    compo = map (fromMaybe c.wildcardSType) minCompo
    l = A.length compo

module KanColle.Expedition.New.Config
  ( Config
  , mkConfig
  , defConfig
  ) where

import Prelude
import Data.Maybe
import KanColle.Expedition.New.SType
import KanColle.Expedition.New.MinCompo
import Data.Array as A
import Data.Unfoldable

type FleetCompo = Array SType

-- configuration for a single expedition.
data Config = Conf
  { greatSuccess :: Boolean
  , normDaihatsuCount :: Int -- normalized, should be one of [0..4]
  , wildcardSType :: SType
  }

mkConfig :: Boolean -> Int -> SType -> Config
mkConfig gs dCount wt = Conf
    { greatSuccess: gs
    , normDaihatsuCount: if dCount > 4 then 4 else dCount
    , wildcardSType: wt
    }

defConfig :: Config
defConfig = mkConfig false 0 DD

getComposition :: Config -> Int -> FleetCompo
getComposition (Conf c) n = if c.greatSuccess
    then compo <> replicate (6 - l) c.wildcardSType
    else compo
  where
    minCompo = getMinimumComposition n
    compo = map (fromMaybe c.wildcardSType) minCompo
    l = A.length compo