Update example for extracted PathPiece class

module Main where

import Prelude
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log, CONSOLE)
import Control.Monad.Eff.Exception (EXCEPTION)
import Data.Array ((..))
import Data.Either (Either(..))
import Data.MediaType.Common (textHTML)
import Hyper.Core (Port(Port), closeHeaders, fallbackTo, statusNotFound, statusOK, writeStatus)
import Hyper.HTML (asString, element_, h1, li, linkTo, p, text, ul)
import Hyper.Node.Server (defaultOptions, runServer)
import Hyper.Response (respond, contentType)
import Hyper.Routing.PathPiece (class FromPathPiece, class ToPathPiece, fromPathPiece, toPathPiece)
import Hyper.Routing.TypeLevelRouter (type (:/), type (:<|>), type (:>), Capture, Get, linksTo, router, (:<|>))
import Node.Buffer (BUFFER)
import Node.HTTP (HTTP)
import Type.Proxy (Proxy(..))

newtype PostID = PostID Int

instance fromPathPiecePostID :: FromPathPiece PostID where
  fromPathPiece s = do
    n <- fromPathPiece s
    if n >= 1
      then Right (PostID n)
      else Left "Post ID must be equal to or greater than 1."

instance toPathPiecePostID :: ToPathPiece PostID where
  toPathPiece (PostID n) = toPathPiece n

type Site = Get :<|> "posts" :/ Capture "id" PostID :> Get

site :: Proxy Site
site = Proxy

main :: forall e. Eff (http :: HTTP, console :: CONSOLE, err :: EXCEPTION, avar :: AVAR, buffer :: BUFFER | e) Unit
main = app (linksTo site)
  where
    -- Automatic type-safe link functions!
    app (archiveURI :<|> postURI) =

      router (Proxy :: Proxy Site) (renderArchive :<|> renderPost)
      # fallbackTo notFound
      # runServer defaultOptions onListening onRequestError {}

      where
        renderArchive =
          htmlWithStatus statusOK $
          element_ "section" [ h1 [] [ text "Archive" ]
                             , ul [] (map postLink (1..10))
                             ]

        postLink n = li [] [linkTo (postURI (PostID n)) [ text ("Post #" <> show n) ]]

        renderPost (PostID pId) =
          htmlWithStatus statusOK $
          element_ "section" [ h1 [] [ text ("Post " <> show pId) ]
                             , p [] [ text "Lorem whatever..." ]
                             , p [] [ linkTo archiveURI [ text "Archive" ] ]
                             ]

        notFound =
          htmlWithStatus statusNotFound $
          element_ "section" [ h1 [] [ text "Not Found!" ]
                             , p [] [ text "The resource you requested does not exist." ]
                             ]

        onListening (Port port) = log ("Listening on http://localhost:" <> show port)
        onRequestError err = log ("Request failed: " <> show err)

        htmlWithStatus status doc =
          writeStatus status
          >=> contentType textHTML
          >=> closeHeaders
          >=> respond (asString doc)

module Main where

import Prelude
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log, CONSOLE)
import Control.Monad.Eff.Exception (EXCEPTION)
import Data.Array ((..))
import Data.Either (Either(..))
import Data.MediaType.Common (textHTML)
import Hyper.Core (Port(Port), closeHeaders, fallbackTo, statusNotFound, statusOK, writeStatus)
import Hyper.HTML (asString, element_, h1, li, linkTo, p, text, ul)
import Hyper.Node.Server (defaultOptions, runServer)
import Hyper.Response (respond, contentType)
import Hyper.Routing.TypeLevelRouter (class FromHttpData, class ToHttpData, type (:/), type (:<|>), type (:>), Capture, Get, fromPathPiece, linksTo, router, (:<|>))
import Node.Buffer (BUFFER)
import Node.HTTP (HTTP)
import Type.Proxy (Proxy(..))

newtype PostID = PostID Int

instance fromHttpDataPostID :: FromHttpData PostID where
  fromPathPiece s = do
    n <- fromPathPiece s
    if n >= 1
      then Right (PostID n)
      else Left "Post ID must be equal to or greater than 1."

instance toHttpDataPostID :: ToHttpData PostID where
  toPathPiece (PostID n) = show n

type Site = Get :<|> "posts" :/ Capture "id" PostID :> Get

site :: Proxy Site
site = Proxy

main :: forall e. Eff (http :: HTTP, console :: CONSOLE, err :: EXCEPTION, avar :: AVAR, buffer :: BUFFER | e) Unit
main = app (linksTo site)
  where
    -- Automatic type-safe link functions!
    app (archiveURI :<|> postURI) =

      router (Proxy :: Proxy Site) (renderArchive :<|> renderPost)
      # fallbackTo notFound
      # runServer defaultOptions onListening onRequestError {}

      where
        renderArchive =
          htmlWithStatus statusOK $
          element_ "section" [ h1 [] [ text "Archive" ]
                             , ul [] (map postLink (1..10))
                             ]

        postLink n = li [] [linkTo (postURI (PostID n)) [ text ("Post #" <> show n) ]]

        renderPost (PostID pId) =
          htmlWithStatus statusOK $
          element_ "section" [ h1 [] [ text ("Post " <> show pId) ]
                             , p [] [ text "Lorem whatever..." ]
                             , p [] [ linkTo archiveURI [ text "Archive" ] ]
                             ]

        notFound =
          htmlWithStatus statusNotFound $
          element_ "section" [ h1 [] [ text "Not Found!" ]
                             , p [] [ text "The resource you requested does not exist." ]
                             ]

        onListening (Port port) = log ("Listening on http://localhost:" <> show port)
        onRequestError err = log ("Request failed: " <> show err)

        htmlWithStatus status doc =
          writeStatus status
          >=> contentType textHTML
          >=> closeHeaders
          >=> respond (asString doc)


a bit clearer how the drag is attached

a bit clearer how the drag is attached

svg was actually a selection of circles, since that’s what is bound in the end of the chain
by breaking it and adding a new identifier bound to the entered circles it’s a little clearer what’s happening with the attachment of the drag

module Main where

import D3.Selection
import Control.Monad.Eff.Console (CONSOLE, log)
import D3.Base (Point, D3, Eff, Index, D3Element, Nodes, AttrSetter(AttrFn, SetAttr), ClassSetter(SetAll, SetSome), DataBind(Keyed, Data), PolyValue(SetByIndex, Value), theHorror, (...), (..))
import D3.Drag (dragUpdate, DragType(DragType), Typenames(TypeNames), addListener, d3Drag)
import D3.Interpolator (Time)
import D3.Transitions (Transition, AttrInterpolator(Target, TweenFn, TweenTarget), DelayValue(MilliSec), TransitionName(Name), tStyle, namedTransition, delay, addTransition, savedTransition, duration, d3Transition)
import DOM.HTML.Event.EventTypes (mouseenter, mouseleave, click)
import Data.Array (reverse)
import Data.Foldable (foldr)
import Data.Int (floor)
import Data.Maybe (Maybe(Just))
import Data.String (length, toCharArray, fromCharArray)
import Prelude (class Show, Unit, show, unit, pure, bind, max, (*), (<>), (<<<), (==), ($), (+))
import Unsafe.Coerce (unsafeCoerce)
{-
-- next target is to handle this case:
var matrix = [
  [11975,  5871, 8916, 2868],
  [ 1951, 10048, 2060, 6171],
  [ 8010, 16145, 8090, 8045],
  [ 1013,   990,  940, 6907]
];

var tr = d3.select("body")
  .append("table")
  .selectAll("tr")
  .data(matrix)
  .enter().append("tr");
-}

-- | mainline: simplest possible D3 demo
array :: Array Number
array = [4.0, 8.0, 15.0, 16.0, 23.0, 42.0]

array2 :: Array String
array2 = ["awn", "bel", "cep", "dof", "erg", "fub"]

circleData :: Array Point
circleData = [ {x: 100.0, y: 100.0}
             , {x: 200.0, y: 200.0}
             , {x: 100.0, y: 200.0}
             , {x: 200.0, y: 100.0}
             , {x: 150.0, y: 150.0}
             ]

arrayMax :: Number
arrayMax = foldr max 0.0 array

revString :: String -> String
revString = fromCharArray <<< reverse <<< toCharArray

awn :: ∀ eff. CallbackParam Number -> Eff (d3::D3, console::CONSOLE|eff) Unit
awn { datum: d, meta: m } = do
  log (show d)
  log (show m)
  pure unit

bel :: ∀ eff. CallbackParamP Number String -> Eff (d3::D3, console::CONSOLE|eff) Unit
bel { datum: d, prop: p } = do
  log (show d)
  log (show p)
  pure unit

cep :: ∀ eff. Number -> Index -> Nodes -> D3Element -> Eff (d3::D3|eff) Boolean
cep datum _ _ _ = pure $ if (datum == 16.0) then true else false

dof :: ∀ eff. String -> Index -> Nodes -> D3Element -> Eff (d3::D3|eff) String
dof datum _ _ _ = pure $ if (datum == "erg") then "ergo propter hoc" else theHorror

hoy :: ∀ eff. Eff (d3::D3|eff) (Transition String)
hoy = d3Transition (Name "hoy")

-- ist :: Number -> Index -> D3Element -> String
ist :: ∀ eff. Number -> Index -> D3Element -> Eff (d3::D3|eff) String
ist d _ _ = pure $ show val <> "px" where val = d * 10.0

-- || next two functions illustrate how you can do the following JS example in PS
-- selection.styleTween("fill", function() {          // equivalent of kef
--   return function(t) {                             // equivalent of jud
--     return "hsl(" + t * 360 + ",100%,50%)";
--   };
-- });
-- kef is given as param to transition.styleTween,
-- it is called by D3 to get a customized interpolator fn for this D3Element
-- since we need it to be callable from JS, the params need to be uncurried
kef :: ∀ d eff. d -> Index -> D3Element -> Eff (d3::D3|eff) (Time -> String)
kef d i e = pure jud

-- | jud is an interpolator function given to D3 by some other interpolator-making function,
-- which is given as param to transition.styleTween (in JS it's just anonymous)
jud :: Time -> String  -- this func duplicates the D3 documentation example shown in comment below
jud t = "hsl(" <> tval <> ",100%,50%)"
  where tval = show (t * 360.0)

roc :: ∀ eff. String -> Index -> Eff (d3::D3|eff) String
roc d i = pure $ show d <> " " <> show i

suq :: ∀ d eff. Show d => d -> Index -> Eff (d3::D3|eff) String
suq d _ = pure $ show d

tej :: ∀ eff. String -> Index -> Eff (d3::D3|eff) String
tej d i = pure $ show l <> "px" where
  l = (length d) * 30 * (floor (i + 1.0))

ure :: ∀ eff. String -> Index -> Eff (d3::D3|eff) String
ure d _ = pure $ show d

vis :: ∀ d eff. Selection d -> String -> String -> Eff (d3::D3|eff) (Selection d)
vis s first last =
  do
    s ... attr "first-name" (SetAttr first)
      .. attr "last-name"  (SetAttr last)
    pure s

-- an example of a drag listener written in Purescript
-- element will track pointer / finger, but other possibilities exist such as
-- faster or slower than dragging or adding acceleration or further side-effects
zek :: ∀ eff. Point -> Index -> Array D3Element -> D3Element ->  Eff (d3::D3|eff) Unit
zek d i els element = do
  selectElem element
    .. attr "cx" (SetAttr d.x) -- not changing the underlying datum here
    .. attr "cy" (SetAttr d.y) -- so nothing happens. Add further Attr options? TODO
  dragUpdate d element -- state mutating function from drag.purs that makes the change
  pure unit

main :: ∀ e. Eff (d3::D3,console::CONSOLE|e) Unit
main = do
  -- | set up a named / reusable transition
  erg <- d3Transition (Name "erg")
    .. duration 2000.0

  -- | a simple chart made of `div`s from a data array of Numbers
  chartN <- d3Select ".chart"
      .. selectAll "div"
        .. dataBind (Data array)
      .. enter .. append "div"
        .. style    "width"         (Value "30px")
        .. style    "font-size"     (Value "48pt")
        .. classed  "twice as nice" (SetSome (\d i nodes el -> pure (i == 2.0) ))
        .. classed  "16 candles"    (SetSome cep)
        .. attr     "name"          (SetAttr "zek")
        .. text                     (SetByIndex suq)
        .. on       mouseenter      awn
        .. on       mouseleave      awn
        -- next an arbitrary property {prop: "propval"} is cached in the D3Element and returned in callback
        .. on' click "prop" "propval" bel
        .. call2 vis "mickey" "mouse"
        -- .. makeTransition          -- this would be a non-reusable transition example
        -- .. duration 500.0
        -- .. tStyle "background-color" (SetAttr "#555")

  -- | applying our saved transition to the chart and adding a further transition
  chartN ... savedTransition erg
          .. tStyle "color"            (Target "black")
          .. tStyle "font-size"        (Target "24pt")
          .. tStyle "width"            (TweenTarget  ist)
          .. addTransition
          .. delay  (MilliSec 500.0)
          .. tStyle "background-color" (TweenFn      kef)

  -- | a simple chart made of `div`s from a data array of Strings
  chartS <- d3Select ".chart2"
    .. selectAll "div"
      .. dataBind (Keyed array2 (\d -> revString d))
    .. enter .. append "div"
      .. style "background-color"  (Value "red")
      .. style "width"             (SetByIndex tej)       -- 'tej' uses EffFn so it can't be presented as a lambda???
      .. classed "wis xis"         (SetAll true)
      .. attr "name"               (AttrFn dof)
      .. text                      (SetByIndex ure)
      .. text                      (SetByIndex roc)
      .. on' click "cep" "stringy" bel

  chartS ... namedTransition "erg"
          .. tStyle "background-color" (Target "blue")
          .. tStyle "color"            (Target "white")

  emptyChart <- d3Select "notfound"

  lev <- chartS ... node
  mim <- chartS ... nodes
  nim <- chartS ... empty

  obi <- emptyChart ... node
  pyx <- emptyChart ... nodes
  qat <- emptyChart ... empty

  -- | let's try some SVG stuff now so that we can work towards zooming and dragging

  svg <- d3Select ".svg"
    .. append "svg"
      .. style "width"  (Value "500px")
      .. style "height" (Value "500px")

  circles <- svg ... selectAll "circle"
      .. dataBind (Data circleData)
    .. enter .. append "circle"
      .. attr "cx" (AttrFn (\d i nodes el -> pure d.x)) -- thing to bear in mind here:
      .. attr "cy" (AttrFn (\d i nodes el -> pure d.y)) -- if you mod here doesn't change underlying value when you drag
      .. attr "r"  (SetAttr 20.0)
      .. style "stroke" (Value "red")
      .. style "fill"   (Value "black")

  let phantom = { x: 0.0, y: 0.0 }
  let tn = TypeNames [ { name: Just "foo", type: DragType} ]
  yag <- d3Drag phantom -- phantom type to ensure correct type for yag (but type only gets in the way here, potentially)
        .. addListener tn zek

  let foo = circles ... call (unsafeCoerce yag) -- adds the drag callbacks for drag (yag) on selection (svg)
  -- unsafeCoerce here is obviously undesirable, need to play with types and see if we can reformulate to lose it TODO

  pure unit

module Main where

import D3.Selection
import Control.Monad.Eff.Console (CONSOLE, log)
import D3.Base (Point, D3, Eff, Index, D3Element, Nodes, AttrSetter(AttrFn, SetAttr), ClassSetter(SetAll, SetSome), DataBind(Keyed, Data), PolyValue(SetByIndex, Value), theHorror, (...), (..))
import D3.Drag (dragUpdate, DragType(DragType), Typenames(TypeNames), addListener, d3Drag)
import D3.Interpolator (Time)
import D3.Transitions (Transition, AttrInterpolator(Target, TweenFn, TweenTarget), DelayValue(MilliSec), TransitionName(Name), tStyle, namedTransition, delay, addTransition, savedTransition, duration, d3Transition)
import DOM.HTML.Event.EventTypes (mouseenter, mouseleave, click)
import Data.Array (reverse)
import Data.Foldable (foldr)
import Data.Int (floor)
import Data.Maybe (Maybe(Just))
import Data.String (length, toCharArray, fromCharArray)
import Prelude (class Show, Unit, show, unit, pure, bind, max, (*), (<>), (<<<), (==), ($), (+))
import Unsafe.Coerce (unsafeCoerce)
{-
-- next target is to handle this case:
var matrix = [
  [11975,  5871, 8916, 2868],
  [ 1951, 10048, 2060, 6171],
  [ 8010, 16145, 8090, 8045],
  [ 1013,   990,  940, 6907]
];

var tr = d3.select("body")
  .append("table")
  .selectAll("tr")
  .data(matrix)
  .enter().append("tr");
-}

-- | mainline: simplest possible D3 demo
array :: Array Number
array = [4.0, 8.0, 15.0, 16.0, 23.0, 42.0]

array2 :: Array String
array2 = ["awn", "bel", "cep", "dof", "erg", "fub"]

circleData :: Array Point
circleData = [ {x: 100.0, y: 100.0}
             , {x: 200.0, y: 200.0}
             , {x: 100.0, y: 200.0}
             , {x: 200.0, y: 100.0}
             , {x: 150.0, y: 150.0}
             ]

arrayMax :: Number
arrayMax = foldr max 0.0 array

revString :: String -> String
revString = fromCharArray <<< reverse <<< toCharArray

awn :: ∀ eff. CallbackParam Number -> Eff (d3::D3, console::CONSOLE|eff) Unit
awn { datum: d, meta: m } = do
  log (show d)
  log (show m)
  pure unit

bel :: ∀ eff. CallbackParamP Number String -> Eff (d3::D3, console::CONSOLE|eff) Unit
bel { datum: d, prop: p } = do
  log (show d)
  log (show p)
  pure unit

cep :: ∀ eff. Number -> Index -> Nodes -> D3Element -> Eff (d3::D3|eff) Boolean
cep datum _ _ _ = pure $ if (datum == 16.0) then true else false

dof :: ∀ eff. String -> Index -> Nodes -> D3Element -> Eff (d3::D3|eff) String
dof datum _ _ _ = pure $ if (datum == "erg") then "ergo propter hoc" else theHorror

hoy :: ∀ eff. Eff (d3::D3|eff) (Transition String)
hoy = d3Transition (Name "hoy")

-- ist :: Number -> Index -> D3Element -> String
ist :: ∀ eff. Number -> Index -> D3Element -> Eff (d3::D3|eff) String
ist d _ _ = pure $ show val <> "px" where val = d * 10.0

-- || next two functions illustrate how you can do the following JS example in PS
-- selection.styleTween("fill", function() {          // equivalent of kef
--   return function(t) {                             // equivalent of jud
--     return "hsl(" + t * 360 + ",100%,50%)";
--   };
-- });
-- kef is given as param to transition.styleTween,
-- it is called by D3 to get a customized interpolator fn for this D3Element
-- since we need it to be callable from JS, the params need to be uncurried
kef :: ∀ d eff. d -> Index -> D3Element -> Eff (d3::D3|eff) (Time -> String)
kef d i e = pure jud

-- | jud is an interpolator function given to D3 by some other interpolator-making function,
-- which is given as param to transition.styleTween (in JS it's just anonymous)
jud :: Time -> String  -- this func duplicates the D3 documentation example shown in comment below
jud t = "hsl(" <> tval <> ",100%,50%)"
  where tval = show (t * 360.0)

roc :: ∀ eff. String -> Index -> Eff (d3::D3|eff) String
roc d i = pure $ show d <> " " <> show i

suq :: ∀ d eff. Show d => d -> Index -> Eff (d3::D3|eff) String
suq d _ = pure $ show d

tej :: ∀ eff. String -> Index -> Eff (d3::D3|eff) String
tej d i = pure $ show l <> "px" where
  l = (length d) * 30 * (floor (i + 1.0))

ure :: ∀ eff. String -> Index -> Eff (d3::D3|eff) String
ure d _ = pure $ show d

vis :: ∀ d eff. Selection d -> String -> String -> Eff (d3::D3|eff) (Selection d)
vis s first last =
  do
    s ... attr "first-name" (SetAttr first)
      .. attr "last-name"  (SetAttr last)
    pure s

-- an example of a drag listener written in Purescript
-- element will track pointer / finger, but other possibilities exist such as
-- faster or slower than dragging or adding acceleration or further side-effects
zek :: ∀ eff. Point -> Index -> Array D3Element -> D3Element ->  Eff (d3::D3|eff) Unit
zek d i els element = do
  selectElem element
    .. attr "cx" (SetAttr d.x) -- not changing the underlying datum here
    .. attr "cy" (SetAttr d.y) -- so nothing happens. Add further Attr options? TODO
  dragUpdate d element -- state mutating function from drag.purs that makes the change
  pure unit

main :: ∀ e. Eff (d3::D3,console::CONSOLE|e) Unit
main = do
  -- | set up a named / reusable transition
  erg <- d3Transition (Name "erg")
    .. duration 2000.0

  -- | a simple chart made of `div`s from a data array of Numbers
  chartN <- d3Select ".chart"
      .. selectAll "div"
        .. dataBind (Data array)
      .. enter .. append "div"
        .. style    "width"         (Value "30px")
        .. style    "font-size"     (Value "48pt")
        .. classed  "twice as nice" (SetSome (\d i nodes el -> pure (i == 2.0) ))
        .. classed  "16 candles"    (SetSome cep)
        .. attr     "name"          (SetAttr "zek")
        .. text                     (SetByIndex suq)
        .. on       mouseenter      awn
        .. on       mouseleave      awn
        -- next an arbitrary property {prop: "propval"} is cached in the D3Element and returned in callback
        .. on' click "prop" "propval" bel
        .. call2 vis "mickey" "mouse"
        -- .. makeTransition          -- this would be a non-reusable transition example
        -- .. duration 500.0
        -- .. tStyle "background-color" (SetAttr "#555")

  -- | applying our saved transition to the chart and adding a further transition
  chartN ... savedTransition erg
          .. tStyle "color"            (Target "black")
          .. tStyle "font-size"        (Target "24pt")
          .. tStyle "width"            (TweenTarget  ist)
          .. addTransition
          .. delay  (MilliSec 500.0)
          .. tStyle "background-color" (TweenFn      kef)

  -- | a simple chart made of `div`s from a data array of Strings
  chartS <- d3Select ".chart2"
    .. selectAll "div"
      .. dataBind (Keyed array2 (\d -> revString d))
    .. enter .. append "div"
      .. style "background-color"  (Value "red")
      .. style "width"             (SetByIndex tej)       -- 'tej' uses EffFn so it can't be presented as a lambda???
      .. classed "wis xis"         (SetAll true)
      .. attr "name"               (AttrFn dof)
      .. text                      (SetByIndex ure)
      .. text                      (SetByIndex roc)
      .. on' click "cep" "stringy" bel

  chartS ... namedTransition "erg"
          .. tStyle "background-color" (Target "blue")
          .. tStyle "color"            (Target "white")

  emptyChart <- d3Select "notfound"

  lev <- chartS ... node
  mim <- chartS ... nodes
  nim <- chartS ... empty

  obi <- emptyChart ... node
  pyx <- emptyChart ... nodes
  qat <- emptyChart ... empty

  -- | let's try some SVG stuff now so that we can work towards zooming and dragging

  svg <- d3Select ".svg"
    .. append "svg"
      .. style "width"  (Value "500px")
      .. style "height" (Value "500px")
    .. selectAll "circle"
      .. dataBind (Data circleData)
    .. enter .. append "circle"
      .. attr "cx" (AttrFn (\d i nodes el -> pure d.x)) -- thing to bear in mind here:
      .. attr "cy" (AttrFn (\d i nodes el -> pure d.y)) -- if you mod here doesn't change underlying value when you drag
      .. attr "r"  (SetAttr 20.0)
      .. style "stroke" (Value "red")
      .. style "fill"   (Value "black")

  let phantom = { x: 0.0, y: 0.0 }
  let tn = TypeNames [ { name: Just "foo", type: DragType} ]
  yag <- d3Drag phantom -- phantom type to ensure correct type for yag (but type only gets in the way here, potentially)
        .. addListener tn zek

  let foo = svg ... call (unsafeCoerce yag) -- adds the drag callbacks for drag (yag) on selection (svg)
  -- unsafeCoerce here is obviously undesirable, need to play with types and see if we can reformulate to lose it TODO

  pure unit


Fix example

Fix example

module Main where

data Maybe a = Nothing | Just a

--
-- In order to define an instance of Monad for the Maybe type,
-- we need to provide instaces for its superclasses:
-- Functor, Apply, Applicative and Bind.
--

instance functorMaybe :: Functor Maybe where
  (<$>) _ Nothing = Nothing
  (<$>) f (Just a) = Just (f a)

instance applyMaybe :: Apply Maybe where
  (<*>) = ap

instance applicativeMaybe :: Applicative Maybe where
  pure = Just

instance bindMaybe :: Bind Maybe where
  (>>=) Nothing _ = Nothing
  (>>=) (Just a) f = f a

instance monadMaybe :: Monad Maybe

--
-- In this example, we find the sum of two numbers, using the guard
-- function to make sure the sum is even.
--

guard :: Boolean -> Maybe {}
guard true = Just {}
guard false = Nothing

evenSum :: Maybe Number -> Maybe Number -> Maybe Number
evenSum a b = do
  n <- a
  m <- b
  let sum = n + m
  guard $ sum % 2 == 0
  return sum

module Main where

data Maybe a = Nothing | Just a

--
-- In order to define an instance of Monad for the Maybe type,
-- we need to provide instaces for its superclasses:
-- Functor, Apply, Applicative and Bind.
--

instance functorMaybe :: Functor Maybe where
  (<$>) _ Nothing = Nothing
  (<$>) f (Just a) = Just a

instance applyMaybe :: Apply Maybe where
  (<*>) = ap

instance applicativeMaybe :: Applicative Maybe where
  pure = Just

instance bindMaybe :: Bind Maybe where
  (>>=) Nothing _ = Nothing
  (>>=) (Just a) f = f a

instance monadMaybe :: Monad Maybe

--
-- In this example, we find the sum of two numbers, using the guard
-- function to make sure the sum is even.
--

guard :: Boolean -> Maybe {}
guard true = Just {}
guard false = Nothing

evenSum :: Maybe Number -> Maybe Number -> Maybe Number
evenSum a b = do
  n <- a
  m <- b
  let sum = n + m
  guard $ sum % 2 == 0
  return sum


Splitting the root cell is valid

Splitting the root cell is valid

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Card.Draftboard.Component where

import SlamData.Prelude
import Data.Array as Array
import Data.Foldable (and, all, find)
import Data.Lens ((.~), (?~))
import Data.List (List(..), (:))
import Data.List as List
import Data.Map as Map
import Data.Ord (abs)
import Data.Rational (Rational, (%))

import Halogen as H
import Halogen.Component.Utils (raise')
import Halogen.Component.Utils.Drag as Drag

import SlamData.Analytics as SA
import SlamData.Quasar.Error as QE
import SlamData.Workspace.Card.CardId as CID
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.Component as CC
import SlamData.Workspace.Card.Draftboard.Layout as Layout
import SlamData.Workspace.Card.Draftboard.Orientation as Orn
import SlamData.Workspace.Card.Draftboard.Pane as Pane
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.Card.Common (CardOptions)
import SlamData.Workspace.Card.Draftboard.Common (deleteGraph, clearDeckId)
import SlamData.Workspace.Card.Draftboard.Component.Common (DraftboardDSL)
import SlamData.Workspace.Card.Draftboard.Component.Query (Query(..))
import SlamData.Workspace.Card.Draftboard.Component.Render (render)
import SlamData.Workspace.Card.Draftboard.Component.State (initialState, modelFromState, childSlots, updateRect, updateLayout)
import SlamData.Workspace.Deck.Common (DeckOptions, wrappedDeck)
import SlamData.Workspace.Deck.Component.Nested.Query as DNQ
import SlamData.Workspace.Deck.Component.Query as DCQ
import SlamData.Workspace.Deck.Component.State as DCS
import SlamData.Workspace.Deck.DeckId (DeckId, freshDeckId)
import SlamData.Workspace.Deck.Model as DM
import SlamData.Workspace.Notification as Notify
import SlamData.Wiring as W

import Utils.DOM (getOffsetClientRect)
import Utils.Path (DirPath)

draftboardComponent ∷ CardOptions → CC.CardComponent
draftboardComponent opts = CC.makeCardComponent
  { cardType: CT.Draftboard
  , component: H.parentComponent
      { render: render opts
      , eval: coproduct evalCard (evalBoard opts)
      , peek: Just (peek opts)
      }
  , initialState: H.parentState initialState
  , _State: CC._DraftboardState
  , _Query: CC.makeQueryPrism' CC._DraftboardQuery
  }

evalCard ∷ CC.CardEvalQuery ~> DraftboardDSL
evalCard = case _ of
  CC.EvalCard _ _ next →
    pure next
  CC.Activate next →
    pure next
  CC.Deactivate next →
    pure next
  CC.SetDimensions _ next → do
    recalcRect
    H.queryAll (right (H.action DCQ.UpdateCardSize))
    pure next
  CC.Save k →
    map (k ∘ Card.Draftboard ∘ modelFromState) H.get
  CC.Load card next → do
    case card of
      Card.Draftboard model → do
        H.modify (updateLayout model.layout)
        loadDecks
      _ → pure unit
    pure next
  CC.ModelUpdated _ next →
    pure next
  CC.ZoomIn next →
    pure next

evalBoard ∷ CardOptions → Query ~> DraftboardDSL
evalBoard opts = case _ of
  SetRoot el next → do
    H.modify _ { root = el }
    pure next
  SplitStart orientation bias root ev next → do
    st ← H.get
    Drag.subscribe' ev (right ∘ H.action ∘ Splitting)
    H.modify _ { splitOpts = Just { orientation, bias, root } }
    pure next
  Splitting ev next → do
    st ← H.get
    case ev of
      Drag.Move _ d → do
        let
          x = d.x - st.rootRect.left
          y = d.y - st.rootRect.top
          result = do
            { orientation, bias, root } ← st.splitOpts
            { cursor } ← overlapping x y st.cellLayout
            let
              rectR = st.rootRect
              cursor' =
                if not root
                  then fromMaybe Nil (Layout.findSplit orientation cursor st.layout)
                  else Nil
            rs ←
              if List.null cursor'
                then pure Nil
                else getRatios =<< Pane.getAt cursor' st.layout
            rectT ← Layout.absoluteRect rectR <$> Layout.rectAt cursor' st.layout
            let
              relX = d.x - (rectR.left + rectT.left)
              relY = d.y - (rectR.top + rectT.top)
            pure case orientation of
              Orn.Horizontal →
                let
                  ratio = Layout.closestSnapRatio (relX / rectT.width)
                  valid = isSensibleSplit ratio rs && not (isEdge ratio)
                in
                  { orientation
                  , bias
                  , cursor: cursor'
                  , ratio
                  , valid
                  , x: d.x - rectR.left
                  , y: rectT.top
                  , z: rectT.height
                  }
              Orn.Vertical →
                let
                  ratio = Layout.closestSnapRatio (relY / rectT.height)
                  valid = isSensibleSplit ratio rs && not (isEdge ratio)
                in
                  { orientation
                  , bias
                  , cursor: cursor'
                  , ratio
                  , valid
                  , x: rectT.left
                  , y: d.y - rectR.top
                  , z: rectT.width
                  }
        H.modify _ { splitLocation = result }
      Drag.Done _ → do
        let
          result = do
            loc ← st.splitLocation
            guard loc.valid
            Layout.insertSplit (Pane.Cell Nothing) loc.orientation loc.ratio loc.bias loc.cursor st.layout
        H.modify
          $ updateLayout (fromMaybe st.layout result)
          ∘ _ { splitOpts = Nothing, splitLocation = Nothing }
        H.queryAll (right (H.action DCQ.UpdateCardSize))
        CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  ResizeStart edge ev next → do
    let
      loc =
        { edge
        , ratio: edge.ratio
        , valid: true
        , collapse: Nothing
        , offset: 0.0
        , initial: case edge.orientation of
            Orn.Horizontal → ev.pageX
            Orn.Vertical   → ev.pageY
        }
    Drag.subscribe' ev (right ∘ H.action ∘ Resizing)
    H.modify _ { resizeLocation = Just loc }
    pure next
  Resizing ev next → do
    st ← H.get
    case ev of
      Drag.Move _ d → do
        let
          rectR = st.rootRect
          result = do
            loc   ← st.resizeLocation
            rectT ← Layout.absoluteRect rectR <$> Layout.rectAt loc.edge.parent st.layout
            sibs  ← Pane.children <$> Pane.getAt loc.edge.parent st.layout
            let
              ix   = loc.edge.index + 1
              relX = d.x - (rectR.left + rectT.left)
              relY = d.y - (rectR.top + rectT.top)
              pre  = List.take ix sibs
              post = List.drop ix sibs
            pure case loc.edge.orientation of
              Orn.Horizontal →
                let
                  ratio = Layout.closestSnapRatio (relX / rectT.width)
                  collapse = isCollapsing ratio pre post
                  valid = not (isEdge ratio) || isJust collapse
                in loc
                  { offset = d.x - loc.initial
                  , ratio = ratio
                  , valid = valid
                  , collapse = collapse
                  }
              Orn.Vertical →
                let
                  ratio = Layout.closestSnapRatio (relY / rectT.height)
                  collapse = isCollapsing ratio pre post
                  valid = not (isEdge ratio) || isJust collapse
                in loc
                  { offset = d.y - loc.initial
                  , ratio = ratio
                  , valid = valid
                  , collapse = collapse
                  }
        H.modify _ { resizeLocation = result }
      Drag.Done _ → do
        let
          result = do
            loc ← st.resizeLocation
            guard loc.valid
            Layout.resizeEdge' loc.edge.index loc.ratio loc.edge.parent st.layout
        H.modify
          $ updateLayout (fromMaybe st.layout result)
          ∘ _ { resizeLocation = Nothing }
        H.queryAll (right (H.action DCQ.UpdateCardSize))
        CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  DeleteCell cursor next → do
    st ← H.get
    let
      result = Layout.deleteCell cursor st.layout
    H.modify (updateLayout (fromMaybe st.layout result))
    H.queryAll (right (H.action DCQ.UpdateCardSize))
    CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  Grabbing (deckId × cursor) ev next → do
    st ← H.get
    case ev of
      Drag.Move _ d → do
        let
          x = d.x - st.rootRect.left
          y = d.y - st.rootRect.top
        case overlapping x y st.cellLayout of
          Just cell@{ value: Nothing } →
            H.modify _ { movingLocation = Just (Right cell) }
          _ →
            H.modify _ { movingLocation = Just (Left (x × y)) }
      Drag.Done _ → do
        for_ st.movingLocation case _ of
          Left _ →
            H.modify _ { movingLocation = Nothing }
          Right cell → do
            let
              result =
                pure st.layout
                  >>= Pane.modifyAt (const (Pane.Cell Nothing)) cursor
                  >>= Pane.modifyAt (const (Pane.Cell (Just deckId))) cell.cursor
            H.modify
              $ updateLayout (fromMaybe st.layout result)
              ∘ _ { movingLocation = Nothing }
            H.queryAll (right (H.action DCQ.UpdateCardSize))
            CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  LoadDeck deckId next → do
    queryDeck deckId (H.action (DCQ.Load opts.deck.path deckId))
    pure next
  AddDeck cursor next → do
    addDeck opts DM.emptyDeck cursor
    CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  GetDecks k → do
    st ← H.get
    decks ←
      for st.layout case _ of
        Just deckId → do
          deck ← queryDeck deckId (H.request DCQ.GetModel)
          pure ((deckId × _) <$> deck)
        Nothing →
          pure Nothing
    pure (k decks)
  GetDecksSharingInput k → do
    decks ← H.gets _.cursors
    deckMbList ← for (Map.keys decks) \deckId → do
      mbInput ← queryDeck deckId $ H.request DCQ.GetSharingInput
      pure $ deckId × mbInput
    pure $ k
      $ foldMap (\(deckId × sharing) → foldMap (Map.singleton deckId) sharing) deckMbList

peek ∷ ∀ a. CardOptions → H.ChildF DeckId DNQ.QueryP a → DraftboardDSL Unit
peek opts (H.ChildF deckId q) = coproduct (const (pure unit)) peekDeck q
  where
  peekDeck ∷ DCQ.Query a → DraftboardDSL Unit
  peekDeck q = do
    st ← H.get
    for_ (Map.lookup deckId st.cursors) \cursor →
      case q of
        DCQ.GrabDeck ev _ → startDragging ev (Grabbing (deckId × cursor))
        DCQ.DoAction DCQ.DeleteDeck _ → do
          SA.track (SA.Delete deckId)
          deleteDeck opts deckId
          CC.raiseUpdatedP' CC.EvalModelUpdate
        DCQ.DoAction DCQ.Wrap _ → do
          SA.track (SA.Wrap deckId)
          wrapDeck opts deckId cursor
          CC.raiseUpdatedP' CC.EvalModelUpdate
        DCQ.DoAction (DCQ.Unwrap decks) _ → do
          SA.track (SA.Collapse deckId)
          unwrapDeck opts deckId cursor decks
          CC.raiseUpdatedP' CC.EvalModelUpdate
        DCQ.DoAction DCQ.Mirror _ → do
          SA.track (SA.Mirror deckId)
          mirrorDeck opts deckId cursor
          CC.raiseUpdatedP' CC.EvalModelUpdate
        _ → pure unit

  startDragging ev tag =
    void $ Drag.subscribe' ev $ right ∘ H.action ∘ tag

isCollapsing
  ∷ ∀ a
  . Rational
  → List (Pane.Pane (Maybe a))
  → List (Pane.Pane (Maybe a))
  → Maybe Layout.SplitBias
isCollapsing ratio pre post
  | ratio == zero && and (map (all isNothing) pre) = Just Layout.SideA
  | ratio == one && and (map (all isNothing) post) = Just Layout.SideB
  | otherwise = Nothing

isSensibleSplit ∷ Rational → List (Rational) → Boolean
isSensibleSplit ratio = go zero
  where
  go off Nil = true
  go off (r : xs) =
    if abs (ratio - off) < 1%16
      then false
      else go (off + r) xs

getRatios ∷ ∀ a . Pane.Pane a → Maybe (List Rational)
getRatios (Pane.Split _ ps) = Just (map fst ps)
getRatios _ = Nothing

isEdge ∷ Rational → Boolean
isEdge r = r == zero || r == one

overlapping
  ∷ ∀ a
  . Number
  → Number
  → List (Layout.Cell a Number)
  → Maybe (Layout.Cell a Number)
overlapping x y = find go
  where
  go { rect: { top, left, width, height } } =
    y >= top && x >= left && y < top + height && x < left + width

recalcRect ∷ DraftboardDSL Unit
recalcRect = do
  st ← H.get
  for_ st.root \root → do
    rect ← H.fromEff (getOffsetClientRect root)
    H.modify (updateRect rect)

saveChildDeck ∷ CardOptions → DM.Deck → DraftboardDSL (Maybe DeckId)
saveChildDeck { deck: opts, deckId: parentId, cardId } deck = do
  let deck' = deck { parent = Just (parentId × cardId) }
  H.modify _ { inserting = true }
  deckId ← H.fromEff freshDeckId
  putDeck opts.path deckId deck' >>= case _ of
    Left err → do
      H.modify _ { inserting = false }
      Notify.saveDeckFail err
      pure Nothing
    Right _ → do
      pure (Just deckId)

addDeck ∷ CardOptions → DM.Deck → Pane.Cursor → DraftboardDSL Unit
addDeck opts deck cursor = do
  saveChildDeck opts deck >>= traverse_ \deckId → do
    st ← H.get
    let
      layout = Pane.modifyAt (const (Pane.Cell (Just deckId))) cursor st.layout
    H.modify
      $ updateLayout (fromMaybe st.layout layout)
      ∘ _ { inserting = false }
    loadAndFocus opts.deck deckId

deleteDeck ∷ CardOptions → DeckId → DraftboardDSL Unit
deleteDeck { deck } deckId = do
  res ← H.liftH $ H.liftH $ deleteGraph deck.path deckId
  st ← H.get
  case res of
    Left err →
      H.liftH $ H.liftH $ Notify.deleteDeckFail err
    Right _ →
      H.modify (updateLayout (clearDeckId deckId st.layout))

wrapDeck ∷ CardOptions → DeckId → Pane.Cursor → DraftboardDSL Unit
wrapDeck { cardId, deckId: parentId, deck } oldId cursor = do
  let
    newDeck = (wrappedDeck oldId) { parent = Just (parentId × cardId) }
  newId ← H.fromEff freshDeckId
  putDeck deck.path newId newDeck >>= case _ of
    Left err →
      Notify.saveDeckFail err
    Right _ → void do
      traverse_ (queryDeck oldId ∘ H.action)
        [ DCQ.SetParent (newId × CID.CardId 0)
        , DCQ.Save Nothing
        ]
      st ← H.get
      let
        layout = Pane.modifyAt (const (Pane.Cell (Just newId))) cursor st.layout
      H.modify (updateLayout (fromMaybe st.layout layout))
      loadAndFocus deck newId

unwrapDeck
  ∷ CardOptions
  → DeckId
  → Pane.Cursor
  → Pane.Pane (Maybe (DeckId × DM.Deck))
  → DraftboardDSL Unit
unwrapDeck { deckId, cardId, deck: opts } oldId cursor decks = do
  let
    coord = deckId × cardId
  subLayout ←
    for decks case _ of
      Nothing → pure Nothing
      Just (deckId × deck) → do
        let
          deck' = deck { parent = Just coord }
        putDeck opts.path deckId deck'
        pure (Just deckId)
  st ← H.get
  let
    layout = Pane.modifyAt (const subLayout) cursor st.layout
  H.modify (updateLayout (fromMaybe st.layout layout))
  for_ subLayout $ traverse_ \deckId →
    raise' (right (H.action (LoadDeck deckId)))

mirrorDeck ∷ CardOptions → DeckId → Pane.Cursor → DraftboardDSL Unit
mirrorDeck opts oldId cursor = do
  queryDeck oldId (H.request DCQ.GetModelCards) >>= traverse_ \modelCards → do
    let modelCards' = Array.span (not ∘ eq oldId ∘ fst) modelCards
    if Array.null modelCards'.rest
      then insertNewDeck DM.emptyDeck { mirror = DCS.coordModelToCoord <$> modelCards'.init }
      else do
        let
          newDeck =
            { parent: Nothing
            , mirror: map _.cardId <$> modelCards'.init
            , cards: snd <$> modelCards'.rest
            , name: ""
            }
        newId ← H.fromEff freshDeckId
        putDeck opts.deck.path newId newDeck >>= case _ of
          Left err →
            Notify.saveDeckFail err
          Right _ → do
            let
              modelCards'' =
                modelCards'.init <> map (lmap (const newId)) modelCards'.rest
            queryDeck oldId $ H.action $ DCQ.SetModelCards modelCards''
            insertNewDeck DM.emptyDeck { mirror = DCS.coordModelToCoord <$> modelCards'' }
  where
  insertNewDeck deck = do
    st ← H.get
    let
      cursor' = case cursor of
        _ : cs → cs
        _ → Nil
      orn = case Pane.getAt cursor' st.layout of
        Just (Pane.Split o _) → o
        _ → Orn.Vertical
    saveChildDeck opts deck >>= traverse_ \deckId → do
      let
        layout = Layout.insertSplit (Pane.Cell (Just deckId)) orn (1%2) Layout.SideB cursor' st.layout
      H.modify (updateLayout (fromMaybe st.layout layout))
      loadAndFocus opts.deck deckId

loadDecks ∷ DraftboardDSL Unit
loadDecks =
  H.gets childSlots >>=
    traverse_ (raise' ∘ right ∘ H.action ∘ LoadDeck)

queryDeck ∷ ∀ a. DeckId → DCQ.Query a → DraftboardDSL (Maybe a)
queryDeck slot = H.query slot ∘ right

loadAndFocus ∷ DeckOptions → DeckId → DraftboardDSL Unit
loadAndFocus opts deckId =
  traverse_ (queryDeck deckId ∘ H.action)
    [ DCQ.Load opts.path deckId
    , DCQ.Focus
    ]

putDeck
  ∷ DirPath
  → DeckId
  → DM.Deck
  → DraftboardDSL (Either QE.QError Unit)
putDeck path deckId deck =
  H.liftH $ H.liftH $ W.putDeck path deckId deck

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Card.Draftboard.Component where

import SlamData.Prelude
import Data.Array as Array
import Data.Foldable (and, all, find)
import Data.Lens ((.~), (?~))
import Data.List (List(..), (:))
import Data.List as List
import Data.Map as Map
import Data.Ord (abs)
import Data.Rational (Rational, (%))

import Halogen as H
import Halogen.Component.Utils (raise')
import Halogen.Component.Utils.Drag as Drag

import SlamData.Analytics as SA
import SlamData.Quasar.Error as QE
import SlamData.Workspace.Card.CardId as CID
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.Component as CC
import SlamData.Workspace.Card.Draftboard.Layout as Layout
import SlamData.Workspace.Card.Draftboard.Orientation as Orn
import SlamData.Workspace.Card.Draftboard.Pane as Pane
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.Card.Common (CardOptions)
import SlamData.Workspace.Card.Draftboard.Common (deleteGraph, clearDeckId)
import SlamData.Workspace.Card.Draftboard.Component.Common (DraftboardDSL)
import SlamData.Workspace.Card.Draftboard.Component.Query (Query(..))
import SlamData.Workspace.Card.Draftboard.Component.Render (render)
import SlamData.Workspace.Card.Draftboard.Component.State (initialState, modelFromState, childSlots, updateRect, updateLayout)
import SlamData.Workspace.Deck.Common (DeckOptions, wrappedDeck)
import SlamData.Workspace.Deck.Component.Nested.Query as DNQ
import SlamData.Workspace.Deck.Component.Query as DCQ
import SlamData.Workspace.Deck.Component.State as DCS
import SlamData.Workspace.Deck.DeckId (DeckId, freshDeckId)
import SlamData.Workspace.Deck.Model as DM
import SlamData.Workspace.Notification as Notify
import SlamData.Wiring as W

import Utils.DOM (getOffsetClientRect)
import Utils.Path (DirPath)

draftboardComponent ∷ CardOptions → CC.CardComponent
draftboardComponent opts = CC.makeCardComponent
  { cardType: CT.Draftboard
  , component: H.parentComponent
      { render: render opts
      , eval: coproduct evalCard (evalBoard opts)
      , peek: Just (peek opts)
      }
  , initialState: H.parentState initialState
  , _State: CC._DraftboardState
  , _Query: CC.makeQueryPrism' CC._DraftboardQuery
  }

evalCard ∷ CC.CardEvalQuery ~> DraftboardDSL
evalCard = case _ of
  CC.EvalCard _ _ next →
    pure next
  CC.Activate next →
    pure next
  CC.Deactivate next →
    pure next
  CC.SetDimensions _ next → do
    recalcRect
    H.queryAll (right (H.action DCQ.UpdateCardSize))
    pure next
  CC.Save k →
    map (k ∘ Card.Draftboard ∘ modelFromState) H.get
  CC.Load card next → do
    case card of
      Card.Draftboard model → do
        H.modify (updateLayout model.layout)
        loadDecks
      _ → pure unit
    pure next
  CC.ModelUpdated _ next →
    pure next
  CC.ZoomIn next →
    pure next

evalBoard ∷ CardOptions → Query ~> DraftboardDSL
evalBoard opts = case _ of
  SetRoot el next → do
    H.modify _ { root = el }
    pure next
  SplitStart orientation bias root ev next → do
    st ← H.get
    Drag.subscribe' ev (right ∘ H.action ∘ Splitting)
    H.modify _ { splitOpts = Just { orientation, bias, root } }
    pure next
  Splitting ev next → do
    st ← H.get
    case ev of
      Drag.Move _ d → do
        let
          x = d.x - st.rootRect.left
          y = d.y - st.rootRect.top
          result = do
            { orientation, bias, root } ← st.splitOpts
            { cursor } ← overlapping x y st.cellLayout
            let
              rectR = st.rootRect
              cursor' =
                if not root
                  then fromMaybe Nil (Layout.findSplit orientation cursor st.layout)
                  else Nil
            rs ← getRatios =<< Pane.getAt cursor' st.layout
            rectT ← Layout.absoluteRect rectR <$> Layout.rectAt cursor' st.layout
            let
              relX = d.x - (rectR.left + rectT.left)
              relY = d.y - (rectR.top + rectT.top)
            pure case orientation of
              Orn.Horizontal →
                let
                  ratio = Layout.closestSnapRatio (relX / rectT.width)
                  valid = isSensibleSplit ratio rs && not (isEdge ratio)
                in
                  { orientation
                  , bias
                  , cursor: cursor'
                  , ratio
                  , valid
                  , x: d.x - rectR.left
                  , y: rectT.top
                  , z: rectT.height
                  }
              Orn.Vertical →
                let
                  ratio = Layout.closestSnapRatio (relY / rectT.height)
                  valid = isSensibleSplit ratio rs && not (isEdge ratio)
                in
                  { orientation
                  , bias
                  , cursor: cursor'
                  , ratio
                  , valid
                  , x: rectT.left
                  , y: d.y - rectR.top
                  , z: rectT.width
                  }
        H.modify _ { splitLocation = result }
      Drag.Done _ → do
        let
          result = do
            loc ← st.splitLocation
            guard loc.valid
            Layout.insertSplit (Pane.Cell Nothing) loc.orientation loc.ratio loc.bias loc.cursor st.layout
        H.modify
          $ updateLayout (fromMaybe st.layout result)
          ∘ _ { splitOpts = Nothing, splitLocation = Nothing }
        H.queryAll (right (H.action DCQ.UpdateCardSize))
        CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  ResizeStart edge ev next → do
    let
      loc =
        { edge
        , ratio: edge.ratio
        , valid: true
        , collapse: Nothing
        , offset: 0.0
        , initial: case edge.orientation of
            Orn.Horizontal → ev.pageX
            Orn.Vertical   → ev.pageY
        }
    Drag.subscribe' ev (right ∘ H.action ∘ Resizing)
    H.modify _ { resizeLocation = Just loc }
    pure next
  Resizing ev next → do
    st ← H.get
    case ev of
      Drag.Move _ d → do
        let
          rectR = st.rootRect
          result = do
            loc   ← st.resizeLocation
            rectT ← Layout.absoluteRect rectR <$> Layout.rectAt loc.edge.parent st.layout
            sibs  ← Pane.children <$> Pane.getAt loc.edge.parent st.layout
            let
              ix   = loc.edge.index + 1
              relX = d.x - (rectR.left + rectT.left)
              relY = d.y - (rectR.top + rectT.top)
              pre  = List.take ix sibs
              post = List.drop ix sibs
            pure case loc.edge.orientation of
              Orn.Horizontal →
                let
                  ratio = Layout.closestSnapRatio (relX / rectT.width)
                  collapse = isCollapsing ratio pre post
                  valid = not (isEdge ratio) || isJust collapse
                in loc
                  { offset = d.x - loc.initial
                  , ratio = ratio
                  , valid = valid
                  , collapse = collapse
                  }
              Orn.Vertical →
                let
                  ratio = Layout.closestSnapRatio (relY / rectT.height)
                  collapse = isCollapsing ratio pre post
                  valid = not (isEdge ratio) || isJust collapse
                in loc
                  { offset = d.y - loc.initial
                  , ratio = ratio
                  , valid = valid
                  , collapse = collapse
                  }
        H.modify _ { resizeLocation = result }
      Drag.Done _ → do
        let
          result = do
            loc ← st.resizeLocation
            guard loc.valid
            Layout.resizeEdge' loc.edge.index loc.ratio loc.edge.parent st.layout
        H.modify
          $ updateLayout (fromMaybe st.layout result)
          ∘ _ { resizeLocation = Nothing }
        H.queryAll (right (H.action DCQ.UpdateCardSize))
        CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  DeleteCell cursor next → do
    st ← H.get
    let
      result = Layout.deleteCell cursor st.layout
    H.modify (updateLayout (fromMaybe st.layout result))
    H.queryAll (right (H.action DCQ.UpdateCardSize))
    CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  Grabbing (deckId × cursor) ev next → do
    st ← H.get
    case ev of
      Drag.Move _ d → do
        let
          x = d.x - st.rootRect.left
          y = d.y - st.rootRect.top
        case overlapping x y st.cellLayout of
          Just cell@{ value: Nothing } →
            H.modify _ { movingLocation = Just (Right cell) }
          _ →
            H.modify _ { movingLocation = Just (Left (x × y)) }
      Drag.Done _ → do
        for_ st.movingLocation case _ of
          Left _ →
            H.modify _ { movingLocation = Nothing }
          Right cell → do
            let
              result =
                pure st.layout
                  >>= Pane.modifyAt (const (Pane.Cell Nothing)) cursor
                  >>= Pane.modifyAt (const (Pane.Cell (Just deckId))) cell.cursor
            H.modify
              $ updateLayout (fromMaybe st.layout result)
              ∘ _ { movingLocation = Nothing }
            H.queryAll (right (H.action DCQ.UpdateCardSize))
            CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  LoadDeck deckId next → do
    queryDeck deckId (H.action (DCQ.Load opts.deck.path deckId))
    pure next
  AddDeck cursor next → do
    addDeck opts DM.emptyDeck cursor
    CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  GetDecks k → do
    st ← H.get
    decks ←
      for st.layout case _ of
        Just deckId → do
          deck ← queryDeck deckId (H.request DCQ.GetModel)
          pure ((deckId × _) <$> deck)
        Nothing →
          pure Nothing
    pure (k decks)
  GetDecksSharingInput k → do
    decks ← H.gets _.cursors
    deckMbList ← for (Map.keys decks) \deckId → do
      mbInput ← queryDeck deckId $ H.request DCQ.GetSharingInput
      pure $ deckId × mbInput
    pure $ k
      $ foldMap (\(deckId × sharing) → foldMap (Map.singleton deckId) sharing) deckMbList

peek ∷ ∀ a. CardOptions → H.ChildF DeckId DNQ.QueryP a → DraftboardDSL Unit
peek opts (H.ChildF deckId q) = coproduct (const (pure unit)) peekDeck q
  where
  peekDeck ∷ DCQ.Query a → DraftboardDSL Unit
  peekDeck q = do
    st ← H.get
    for_ (Map.lookup deckId st.cursors) \cursor →
      case q of
        DCQ.GrabDeck ev _ → startDragging ev (Grabbing (deckId × cursor))
        DCQ.DoAction DCQ.DeleteDeck _ → do
          SA.track (SA.Delete deckId)
          deleteDeck opts deckId
          CC.raiseUpdatedP' CC.EvalModelUpdate
        DCQ.DoAction DCQ.Wrap _ → do
          SA.track (SA.Wrap deckId)
          wrapDeck opts deckId cursor
          CC.raiseUpdatedP' CC.EvalModelUpdate
        DCQ.DoAction (DCQ.Unwrap decks) _ → do
          SA.track (SA.Collapse deckId)
          unwrapDeck opts deckId cursor decks
          CC.raiseUpdatedP' CC.EvalModelUpdate
        DCQ.DoAction DCQ.Mirror _ → do
          SA.track (SA.Mirror deckId)
          mirrorDeck opts deckId cursor
          CC.raiseUpdatedP' CC.EvalModelUpdate
        _ → pure unit

  startDragging ev tag =
    void $ Drag.subscribe' ev $ right ∘ H.action ∘ tag

isCollapsing
  ∷ ∀ a
  . Rational
  → List (Pane.Pane (Maybe a))
  → List (Pane.Pane (Maybe a))
  → Maybe Layout.SplitBias
isCollapsing ratio pre post
  | ratio == zero && and (map (all isNothing) pre) = Just Layout.SideA
  | ratio == one && and (map (all isNothing) post) = Just Layout.SideB
  | otherwise = Nothing

isSensibleSplit ∷ Rational → List (Rational) → Boolean
isSensibleSplit ratio = go zero
  where
  go off Nil = true
  go off (r : xs) =
    if abs (ratio - off) < 1%16
      then false
      else go (off + r) xs

getRatios ∷ ∀ a . Pane.Pane a → Maybe (List Rational)
getRatios (Pane.Split _ ps) = Just (map fst ps)
getRatios _ = Nothing

isEdge ∷ Rational → Boolean
isEdge r = r == zero || r == one

overlapping
  ∷ ∀ a
  . Number
  → Number
  → List (Layout.Cell a Number)
  → Maybe (Layout.Cell a Number)
overlapping x y = find go
  where
  go { rect: { top, left, width, height } } =
    y >= top && x >= left && y < top + height && x < left + width

recalcRect ∷ DraftboardDSL Unit
recalcRect = do
  st ← H.get
  for_ st.root \root → do
    rect ← H.fromEff (getOffsetClientRect root)
    H.modify (updateRect rect)

saveChildDeck ∷ CardOptions → DM.Deck → DraftboardDSL (Maybe DeckId)
saveChildDeck { deck: opts, deckId: parentId, cardId } deck = do
  let deck' = deck { parent = Just (parentId × cardId) }
  H.modify _ { inserting = true }
  deckId ← H.fromEff freshDeckId
  putDeck opts.path deckId deck' >>= case _ of
    Left err → do
      H.modify _ { inserting = false }
      Notify.saveDeckFail err
      pure Nothing
    Right _ → do
      pure (Just deckId)

addDeck ∷ CardOptions → DM.Deck → Pane.Cursor → DraftboardDSL Unit
addDeck opts deck cursor = do
  saveChildDeck opts deck >>= traverse_ \deckId → do
    st ← H.get
    let
      layout = Pane.modifyAt (const (Pane.Cell (Just deckId))) cursor st.layout
    H.modify
      $ updateLayout (fromMaybe st.layout layout)
      ∘ _ { inserting = false }
    loadAndFocus opts.deck deckId

deleteDeck ∷ CardOptions → DeckId → DraftboardDSL Unit
deleteDeck { deck } deckId = do
  res ← H.liftH $ H.liftH $ deleteGraph deck.path deckId
  st ← H.get
  case res of
    Left err →
      H.liftH $ H.liftH $ Notify.deleteDeckFail err
    Right _ →
      H.modify (updateLayout (clearDeckId deckId st.layout))

wrapDeck ∷ CardOptions → DeckId → Pane.Cursor → DraftboardDSL Unit
wrapDeck { cardId, deckId: parentId, deck } oldId cursor = do
  let
    newDeck = (wrappedDeck oldId) { parent = Just (parentId × cardId) }
  newId ← H.fromEff freshDeckId
  putDeck deck.path newId newDeck >>= case _ of
    Left err →
      Notify.saveDeckFail err
    Right _ → void do
      traverse_ (queryDeck oldId ∘ H.action)
        [ DCQ.SetParent (newId × CID.CardId 0)
        , DCQ.Save Nothing
        ]
      st ← H.get
      let
        layout = Pane.modifyAt (const (Pane.Cell (Just newId))) cursor st.layout
      H.modify (updateLayout (fromMaybe st.layout layout))
      loadAndFocus deck newId

unwrapDeck
  ∷ CardOptions
  → DeckId
  → Pane.Cursor
  → Pane.Pane (Maybe (DeckId × DM.Deck))
  → DraftboardDSL Unit
unwrapDeck { deckId, cardId, deck: opts } oldId cursor decks = do
  let
    coord = deckId × cardId
  subLayout ←
    for decks case _ of
      Nothing → pure Nothing
      Just (deckId × deck) → do
        let
          deck' = deck { parent = Just coord }
        putDeck opts.path deckId deck'
        pure (Just deckId)
  st ← H.get
  let
    layout = Pane.modifyAt (const subLayout) cursor st.layout
  H.modify (updateLayout (fromMaybe st.layout layout))
  for_ subLayout $ traverse_ \deckId →
    raise' (right (H.action (LoadDeck deckId)))

mirrorDeck ∷ CardOptions → DeckId → Pane.Cursor → DraftboardDSL Unit
mirrorDeck opts oldId cursor = do
  queryDeck oldId (H.request DCQ.GetModelCards) >>= traverse_ \modelCards → do
    let modelCards' = Array.span (not ∘ eq oldId ∘ fst) modelCards
    if Array.null modelCards'.rest
      then insertNewDeck DM.emptyDeck { mirror = DCS.coordModelToCoord <$> modelCards'.init }
      else do
        let
          newDeck =
            { parent: Nothing
            , mirror: map _.cardId <$> modelCards'.init
            , cards: snd <$> modelCards'.rest
            , name: ""
            }
        newId ← H.fromEff freshDeckId
        putDeck opts.deck.path newId newDeck >>= case _ of
          Left err →
            Notify.saveDeckFail err
          Right _ → do
            let
              modelCards'' =
                modelCards'.init <> map (lmap (const newId)) modelCards'.rest
            queryDeck oldId $ H.action $ DCQ.SetModelCards modelCards''
            insertNewDeck DM.emptyDeck { mirror = DCS.coordModelToCoord <$> modelCards'' }
  where
  insertNewDeck deck = do
    st ← H.get
    let
      cursor' = case cursor of
        _ : cs → cs
        _ → Nil
      orn = case Pane.getAt cursor' st.layout of
        Just (Pane.Split o _) → o
        _ → Orn.Vertical
    saveChildDeck opts deck >>= traverse_ \deckId → do
      let
        layout = Layout.insertSplit (Pane.Cell (Just deckId)) orn (1%2) Layout.SideB cursor' st.layout
      H.modify (updateLayout (fromMaybe st.layout layout))
      loadAndFocus opts.deck deckId

loadDecks ∷ DraftboardDSL Unit
loadDecks =
  H.gets childSlots >>=
    traverse_ (raise' ∘ right ∘ H.action ∘ LoadDeck)

queryDeck ∷ ∀ a. DeckId → DCQ.Query a → DraftboardDSL (Maybe a)
queryDeck slot = H.query slot ∘ right

loadAndFocus ∷ DeckOptions → DeckId → DraftboardDSL Unit
loadAndFocus opts deckId =
  traverse_ (queryDeck deckId ∘ H.action)
    [ DCQ.Load opts.path deckId
    , DCQ.Focus
    ]

putDeck
  ∷ DirPath
  → DeckId
  → DM.Deck
  → DraftboardDSL (Either QE.QError Unit)
putDeck path deckId deck =
  H.liftH $ H.liftH $ W.putDeck path deckId deck


[CSM-237] Try to fix daedalus-bridge

[CSM-237] Try to fix daedalus-bridge

module Daedalus.Types
       ( module CT
       , module C
       , module E
       , module BP
       , module DT
       , _address
       , _ccoin
       , _passPhrase
       , mkCCoin
       , mkCId
       , mkCAccountMeta
       , mkCAccountInit
       , mkCAccountId
       , mkCTxMeta
       , mkCTxId
       , mkCProfile
       , _ctxIdValue
       , mkBackupPhrase
       , mkCWalletRedeem
       , mkCWalletMeta
       , mkCPaperVendWalletRedeem
       , mkCInitialized
       , mkCPassPhrase
       , emptyCPassPhrase
       , getProfileLocale
       , walletAddressToUrl
       , mkCWalletInit
       , mkCWalletAssurance
       , optionalString
       ) where

import Prelude
import Data.Types as DT
import Pos.Core.Types as C
import Pos.Util.BackupPhrase as BP
import Pos.Wallet.Web.ClientTypes.Types as CT
import Pos.Wallet.Web.Error.Types as E
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION, Error, error, throw)
import Control.Monad.Except (runExcept)
import Daedalus.Crypto (isValidMnemonic, blake2b, bytesToB16)
import Data.Argonaut.Core (fromString)
import Data.Argonaut.Generic.Aeson (decodeJson)
import Data.Array (length, filter)
import Data.Either (either, Either(..))
import Data.Foreign (F, Foreign, isNull, readString)
import Data.Foreign.Null (readNull, unNull, Null)
import Data.Int53 (fromInt)
import Data.Maybe (Maybe(Nothing))
import Data.String (split, null, trim, joinWith, Pattern(..))
import Data.Types (mkTime)
import Pos.Util.BackupPhrase (BackupPhrase(..))
import Pos.Wallet.Web.ClientTypes.Types (CId(..), CHash(..), CPassPhrase(..), CCoin(..), Wal(..), CAccountId(..), CWalletMeta(..))

space :: Pattern
space = Pattern " "

dot :: Pattern
dot = Pattern "."

backupMnemonicLen :: Int
backupMnemonicLen = 12

paperVendMnemonicLen :: Int
paperVendMnemonicLen = 9

-- NOTE: if you will be bumping bip39 to >=2.2.0 be aware of https://issues.serokell.io/issue/VD-95 . In this case you will have to modify how we validate paperVendMnemonics.
mkBackupPhrase :: Int -> String -> Either Error BackupPhrase
mkBackupPhrase len mnemonic = mkBackupPhraseIgnoreChecksum len mnemonic >>= const do
    if not $ isValidMnemonic mnemonicCleaned
        then Left $ error "Invalid mnemonic: checksum missmatch"
        else Right $ BackupPhrase { bpToList: split space mnemonicCleaned }
  where
    mnemonicCleaned = cleanMnemonic mnemonic

cleanMnemonic :: String -> String
cleanMnemonic = joinWith " " <<< filter (not <<< null) <<< split space <<< trim

mkBackupPhraseIgnoreChecksum :: Int -> String -> Either Error BackupPhrase
mkBackupPhraseIgnoreChecksum len mnemonic =
    if not $ hasExactlyNwords len mnemonicCleaned
        then Left $ error $ "Invalid mnemonic: mnemonic should have exactly " <> show len <> " words"
        else Right $ BackupPhrase { bpToList: split space mnemonicCleaned }
  where
    hasExactlyNwords len' = (==) len' <<< length <<< split space
    mnemonicCleaned = cleanMnemonic mnemonic

-- TODO: it would be useful to extend purescript-bridge
-- and generate lenses
walletAddressToUrl :: CAccountId -> String
walletAddressToUrl (CAccountId r) = r

_hash :: CHash -> String
_hash (CHash h) = h

_address :: forall a. CId a -> String
_address (CId a) = _hash a

_passPhrase :: CPassPhrase -> String
_passPhrase (CPassPhrase p) = p

emptyCPassPhrase :: CPassPhrase
emptyCPassPhrase = CPassPhrase ""

-- | Create/Make password from foreign javascript code. Return errors if you
-- find them.
mkCPassPhrase :: forall eff. Foreign -> Eff (err :: EXCEPTION | eff) (Maybe CPassPhrase)
mkCPassPhrase pass = do
  optionalPass <- optionalString pass "password"
  pure $ CPassPhrase <<< bytesToB16 <<< blake2b <$> optionalPass

-- | We take a @Foreign@ parameter and if it's null, we return it as @Nothing@,
-- and if it's not null, we try to parse it as a @String@, and return errors
-- associated with converting.
optionalString :: forall eff. Foreign -> String -> Eff (err :: EXCEPTION | eff) (Maybe String)
optionalString string paramName =
    if (isNull string)
    then pure Nothing
    else either (const raiseError) pure runForeignRead
  where
    runForeignRead = runExcept $ unNull <$> theReadString
    -- type F (Maybe String) = ExceptT (NonEmptyList ForeignError) Identity (Maybe String)
    theReadString :: F (Null String)
    theReadString = readNull readString string

    raiseError = throw ("Error with converting parameter '" <> paramName <> "' to string.")

mkCId :: forall a. String -> CId a
mkCId = CId <<< CHash

_ccoin :: CCoin -> String
_ccoin (CCoin c) = c.getCCoin

mkCCoin :: String -> CCoin
mkCCoin amount = CCoin { getCCoin: amount }

-- NOTE: use genericRead maybe https://github.com/paluh/purescript-generic-read-example
mkCWSetAssurance :: String -> CT.CWalletAssurance
mkCWSetAssurance = either (const CT.CWANormal) id <<< decodeJson <<< fromString

mkCAccountMeta :: String -> CT.CAccountMeta
mkCAccountMeta wName =
    CT.CAccountMeta { caName: wName
                   }

mkCAccountId :: String -> CT.CAccountId
mkCAccountId = CAccountId

mkCInitialized :: Int -> Int -> CT.CInitialized
mkCInitialized total preInit =
    CT.CInitialized { cTotalTime: fromInt total
                    , cPreInit: fromInt preInit
                    }

mkCAccountInit :: String -> CId Wal -> CT.CAccountInit
mkCAccountInit wName wSetId =
    CT.CAccountInit { caInitWId: wSetId
                    , caInitMeta: mkCAccountMeta wName
                    }

mkCWalletAssurance :: String -> CT.CWalletAssurance
mkCWalletAssurance = either (const CT.CWANormal) id <<< decodeJson <<< fromString

mkCWalletMeta :: String -> String -> Int -> CWalletMeta
mkCWalletMeta wName wAssurance wUnit =
  CWalletMeta { cwName: wName
                 , cwAssurance: mkCWalletAssurance wAssurance
                 , cwUnit: wUnit
                 }

mkCWalletInit :: String -> String -> Int -> String -> Either Error CT.CWalletInit
mkCWalletInit wSetName wsAssurance wsUnit mnemonic = do
    bp <- mkBackupPhrase backupMnemonicLen mnemonic
    pure $ CT.CWalletInit { cwInitMeta:
                                CWalletMeta
                                    { cwName: wSetName
                                    , cwAssurance: mkCWalletAssurance wsAssurance
                                    , cwUnit: wsUnit
                                    }
                             , cwBackupPhrase: bp
                             }

mkCWalletRedeem :: String -> CAccountId -> CT.CWalletRedeem
mkCWalletRedeem seed wAddress = do
    CT.CWalletRedeem { crWalletId: wAddress
                     , crSeed: seed
                     }

-- NOTE: if you will be bumping bip39 to >=2.2.0 be aware of https://issues.serokell.io/issue/VD-95 . In this case you will have to modify how we validate paperVendMnemonics.
mkCPaperVendWalletRedeem :: String -> String -> CAccountId -> Either Error CT.CPaperVendWalletRedeem
mkCPaperVendWalletRedeem seed mnemonic wAddress = do
    bp <- mkBackupPhrase paperVendMnemonicLen mnemonic
    pure $ CT.CPaperVendWalletRedeem { pvWalletId: wAddress
                                     , pvBackupPhrase: bp
                                     , pvSeed: seed
                                     }

_ctxIdValue :: CT.CTxId -> String
_ctxIdValue (CT.CTxId tx) = _hash tx

mkCTxId :: String -> CT.CTxId
mkCTxId = CT.CTxId <<< CHash

mkCTxMeta :: Number -> CT.CTxMeta
mkCTxMeta date =
    CT.CTxMeta { ctmDate: mkTime date
               }

mkCProfile :: String -> CT.CProfile
mkCProfile locale =
    CT.CProfile { cpLocale: locale
                }

getProfileLocale :: CT.CProfile -> String
getProfileLocale (CT.CProfile r) = r.cpLocale

module Daedalus.Types
       ( module CT
       , module C
       , module E
       , module BP
       , module DT
       , _address
       , _ccoin
       , _passPhrase
       , mkCCoin
       , mkCId
       , mkCAccountMeta
       , mkCAccountInit
       , mkCAccountId
       , mkCTxMeta
       , mkCTxId
       , mkCProfile
       , _ctxIdValue
       , mkBackupPhrase
       , mkCWalletRedeem
       , mkCWalletMeta
       , mkCPaperVendWalletRedeem
       , mkCInitialized
       , mkCPassPhrase
       , emptyCPassPhrase
       , getProfileLocale
       , walletAddressToUrl
       , mkCWalletInit
       , mkCWalletAssurance
       , optionalString
       ) where

import Prelude
import Data.Types as DT
import Pos.Core.Types as C
import Pos.Util.BackupPhrase as BP
import Pos.Wallet.Web.ClientTypes as CT
import Pos.Wallet.Web.Error.Types as E
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION, Error, error, throw)
import Control.Monad.Except (runExcept)
import Daedalus.Crypto (isValidMnemonic, blake2b, bytesToB16)
import Data.Argonaut.Core (fromString)
import Data.Argonaut.Generic.Aeson (decodeJson)
import Data.Array (length, filter)
import Data.Either (either, Either(..))
import Data.Foreign (F, Foreign, isNull, readString)
import Data.Foreign.Null (readNull, unNull, Null)
import Data.Int53 (fromInt)
import Data.Maybe (Maybe(Nothing))
import Data.String (split, null, trim, joinWith, Pattern(..))
import Data.Types (mkTime)
import Pos.Util.BackupPhrase (BackupPhrase(..))
import Pos.Wallet.Web.ClientTypes (CId(..), CHash(..), CPassPhrase(..), CCoin(..), Wal(..), CAccountId(..), CWalletMeta(..))

space :: Pattern
space = Pattern " "

dot :: Pattern
dot = Pattern "."

backupMnemonicLen :: Int
backupMnemonicLen = 12

paperVendMnemonicLen :: Int
paperVendMnemonicLen = 9

-- NOTE: if you will be bumping bip39 to >=2.2.0 be aware of https://issues.serokell.io/issue/VD-95 . In this case you will have to modify how we validate paperVendMnemonics.
mkBackupPhrase :: Int -> String -> Either Error BackupPhrase
mkBackupPhrase len mnemonic = mkBackupPhraseIgnoreChecksum len mnemonic >>= const do
    if not $ isValidMnemonic mnemonicCleaned
        then Left $ error "Invalid mnemonic: checksum missmatch"
        else Right $ BackupPhrase { bpToList: split space mnemonicCleaned }
  where
    mnemonicCleaned = cleanMnemonic mnemonic

cleanMnemonic :: String -> String
cleanMnemonic = joinWith " " <<< filter (not <<< null) <<< split space <<< trim

mkBackupPhraseIgnoreChecksum :: Int -> String -> Either Error BackupPhrase
mkBackupPhraseIgnoreChecksum len mnemonic =
    if not $ hasExactlyNwords len mnemonicCleaned
        then Left $ error $ "Invalid mnemonic: mnemonic should have exactly " <> show len <> " words"
        else Right $ BackupPhrase { bpToList: split space mnemonicCleaned }
  where
    hasExactlyNwords len' = (==) len' <<< length <<< split space
    mnemonicCleaned = cleanMnemonic mnemonic

-- TODO: it would be useful to extend purescript-bridge
-- and generate lenses
walletAddressToUrl :: CAccountId -> String
walletAddressToUrl (CAccountId r) = r

_hash :: CHash -> String
_hash (CHash h) = h

_address :: forall a. CId a -> String
_address (CId a) = _hash a

_passPhrase :: CPassPhrase -> String
_passPhrase (CPassPhrase p) = p

emptyCPassPhrase :: CPassPhrase
emptyCPassPhrase = CPassPhrase ""

-- | Create/Make password from foreign javascript code. Return errors if you
-- find them.
mkCPassPhrase :: forall eff. Foreign -> Eff (err :: EXCEPTION | eff) (Maybe CPassPhrase)
mkCPassPhrase pass = do
  optionalPass <- optionalString pass "password"
  pure $ CPassPhrase <<< bytesToB16 <<< blake2b <$> optionalPass

-- | We take a @Foreign@ parameter and if it's null, we return it as @Nothing@,
-- and if it's not null, we try to parse it as a @String@, and return errors
-- associated with converting.
optionalString :: forall eff. Foreign -> String -> Eff (err :: EXCEPTION | eff) (Maybe String)
optionalString string paramName =
    if (isNull string)
    then pure Nothing
    else either (const raiseError) pure runForeignRead
  where
    runForeignRead = runExcept $ unNull <$> theReadString
    -- type F (Maybe String) = ExceptT (NonEmptyList ForeignError) Identity (Maybe String)
    theReadString :: F (Null String)
    theReadString = readNull readString string

    raiseError = throw ("Error with converting parameter '" <> paramName <> "' to string.")

mkCId :: forall a. String -> CId a
mkCId = CId <<< CHash

_ccoin :: CCoin -> String
_ccoin (CCoin c) = c.getCCoin

mkCCoin :: String -> CCoin
mkCCoin amount = CCoin { getCCoin: amount }

-- NOTE: use genericRead maybe https://github.com/paluh/purescript-generic-read-example
mkCWSetAssurance :: String -> CT.CWalletAssurance
mkCWSetAssurance = either (const CT.CWANormal) id <<< decodeJson <<< fromString

mkCAccountMeta :: String -> CT.CAccountMeta
mkCAccountMeta wName =
    CT.CAccountMeta { caName: wName
                   }

mkCAccountId :: String -> CT.CAccountId
mkCAccountId = CAccountId

mkCInitialized :: Int -> Int -> CT.CInitialized
mkCInitialized total preInit =
    CT.CInitialized { cTotalTime: fromInt total
                    , cPreInit: fromInt preInit
                    }

mkCAccountInit :: String -> CId Wal -> CT.CAccountInit
mkCAccountInit wName wSetId =
    CT.CAccountInit { caInitWId: wSetId
                    , caInitMeta: mkCAccountMeta wName
                    }

mkCWalletAssurance :: String -> CT.CWalletAssurance
mkCWalletAssurance = either (const CT.CWANormal) id <<< decodeJson <<< fromString

mkCWalletMeta :: String -> String -> Int -> CWalletMeta
mkCWalletMeta wName wAssurance wUnit =
  CWalletMeta { cwName: wName
                 , cwAssurance: mkCWalletAssurance wAssurance
                 , cwUnit: wUnit
                 }

mkCWalletInit :: String -> String -> Int -> String -> Either Error CT.CWalletInit
mkCWalletInit wSetName wsAssurance wsUnit mnemonic = do
    bp <- mkBackupPhrase backupMnemonicLen mnemonic
    pure $ CT.CWalletInit { cwInitMeta:
                                CWalletMeta
                                    { cwName: wSetName
                                    , cwAssurance: mkCWalletAssurance wsAssurance
                                    , cwUnit: wsUnit
                                    }
                             , cwBackupPhrase: bp
                             }

mkCWalletRedeem :: String -> CAccountId -> CT.CWalletRedeem
mkCWalletRedeem seed wAddress = do
    CT.CWalletRedeem { crWalletId: wAddress
                     , crSeed: seed
                     }

-- NOTE: if you will be bumping bip39 to >=2.2.0 be aware of https://issues.serokell.io/issue/VD-95 . In this case you will have to modify how we validate paperVendMnemonics.
mkCPaperVendWalletRedeem :: String -> String -> CAccountId -> Either Error CT.CPaperVendWalletRedeem
mkCPaperVendWalletRedeem seed mnemonic wAddress = do
    bp <- mkBackupPhrase paperVendMnemonicLen mnemonic
    pure $ CT.CPaperVendWalletRedeem { pvWalletId: wAddress
                                     , pvBackupPhrase: bp
                                     , pvSeed: seed
                                     }

_ctxIdValue :: CT.CTxId -> String
_ctxIdValue (CT.CTxId tx) = _hash tx

mkCTxId :: String -> CT.CTxId
mkCTxId = CT.CTxId <<< CHash

mkCTxMeta :: Number -> CT.CTxMeta
mkCTxMeta date =
    CT.CTxMeta { ctmDate: mkTime date
               }

mkCProfile :: String -> CT.CProfile
mkCProfile locale =
    CT.CProfile { cpLocale: locale
                }

getProfileLocale :: CT.CProfile -> String
getProfileLocale (CT.CProfile r) = r.cpLocale


Rename bracket to withResource

Rename bracket to withResource

-- | This module defines the `MonadError` type class and its instances.

module Control.Monad.Error.Class where

import Prelude

import Data.Maybe (Maybe(..))
import Data.Either (Either(..), either)

-- | The `MonadError` type class represents those monads which support errors via
-- | `throwError` and `catchError`.
-- |
-- | - `throwError e` throws the error `e`
-- | - `catchError x f` calls the error handler `f` if an error is thrown during the
-- |   evaluation of `x`.
-- |
-- | An implementation is provided for `ErrorT`, and for other monad transformers
-- | defined in this library.
-- |
-- | Laws:
-- |
-- | - Left zero: `throwError e >>= f = throwError e`
-- | - Catch: `catchError (throwError e) f = f e`
-- | - Pure: `catchError (pure a) f = pure a`
-- |
class Monad m <= MonadError e m | m -> e where
  throwError :: forall a. e -> m a
  catchError :: forall a. m a -> (e -> m a) -> m a

-- | This function allows you to provide a predicate for selecting the
-- | exceptions that you're interested in, and handle only those exceptons.
-- | If the inner computation throws an exception, and the predicate returns
-- | Nothing, then the whole computation will still fail with that exception.
catchJust
  :: forall e m a b
   . MonadError e m
  => (e -> Maybe b) -- ^ Predicate to select exceptions
  -> m a            -- ^ Computation to run
  -> (b -> m a)     -- ^ Handler
  -> m a
catchJust p act handler = catchError act handle
  where
  handle e =
    case p e of
      Nothing -> throwError e
      Just b -> handler b

instance monadErrorEither :: MonadError e (Either e) where
  throwError = Left
  catchError (Left e) h = h e
  catchError (Right x) _ = Right x

instance monadErrorMaybe :: MonadError Unit Maybe where
  throwError = const Nothing
  catchError Nothing f  = f unit
  catchError (Just a) _ = Just a

-- | Make sure that a resource is cleaned up in the event of an exception. The
-- | release action is called regardless of whether the body action throws or
-- | returns.
withResource
  :: ∀ e m r a
   . (MonadError e m)
  => m r
  -> (r -> m Unit)
  -> (r -> m a)
  -> m a
withResource acquire release kleisli = do
  resource <- acquire
  result <- (Right <$> kleisli resource) `catchError` (pure <<< Left)
  release resource
  either throwError pure result

-- | This module defines the `MonadError` type class and its instances.

module Control.Monad.Error.Class where

import Prelude

import Data.Maybe (Maybe(..))
import Data.Either (Either(..), either)

-- | The `MonadError` type class represents those monads which support errors via
-- | `throwError` and `catchError`.
-- |
-- | - `throwError e` throws the error `e`
-- | - `catchError x f` calls the error handler `f` if an error is thrown during the
-- |   evaluation of `x`.
-- |
-- | An implementation is provided for `ErrorT`, and for other monad transformers
-- | defined in this library.
-- |
-- | Laws:
-- |
-- | - Left zero: `throwError e >>= f = throwError e`
-- | - Catch: `catchError (throwError e) f = f e`
-- | - Pure: `catchError (pure a) f = pure a`
-- |
class Monad m <= MonadError e m | m -> e where
  throwError :: forall a. e -> m a
  catchError :: forall a. m a -> (e -> m a) -> m a

-- | This function allows you to provide a predicate for selecting the
-- | exceptions that you're interested in, and handle only those exceptons.
-- | If the inner computation throws an exception, and the predicate returns
-- | Nothing, then the whole computation will still fail with that exception.
catchJust
  :: forall e m a b
   . MonadError e m
  => (e -> Maybe b) -- ^ Predicate to select exceptions
  -> m a            -- ^ Computation to run
  -> (b -> m a)     -- ^ Handler
  -> m a
catchJust p act handler = catchError act handle
  where
  handle e =
    case p e of
      Nothing -> throwError e
      Just b -> handler b

instance monadErrorEither :: MonadError e (Either e) where
  throwError = Left
  catchError (Left e) h = h e
  catchError (Right x) _ = Right x

instance monadErrorMaybe :: MonadError Unit Maybe where
  throwError = const Nothing
  catchError Nothing f  = f unit
  catchError (Just a) _ = Just a

-- | Make sure that a resource is cleaned up in the event of an exception. The
-- | release action is called regardless of whether the body action throws or
-- | returns.
bracket
  :: ∀ e m r a
   . (MonadError e m)
  => m r
  -> (r -> m Unit)
  -> (r -> m a)
  -> m a
bracket acquire release kleisli = do
  resource <- acquire
  result <- (Right <$> kleisli resource) `catchError` (pure <<< Left)
  release resource
  either throwError pure result


Leave some thoughts

Leave some thoughts

-- | Resolve ambiguities by combining the parsed usage section with any parsed
-- | Option sections, as well as some best effort guessing.
-- |
-- | ===
-- |
-- | Thoughts:
-- |    * It appears there is never a reason to fail hard. It would be nice if
-- |      we could produce warnings, however -> Write monad?

module Docopt.Spec.Solver where

import Prelude
import Debug.Trace
import Data.Either (Either(..))
import Data.Maybe.Unsafe (fromJust)
import Data.Maybe (Maybe(..), isJust, maybe, maybe', isNothing)
import Data.List (List(..), filter, head, foldM, concat, (:), singleton
                , catMaybes, toList, last, init, length)
import Data.Traversable (traverse)
import Data.Foldable (foldl)
import Control.Plus (empty)
import Data.Monoid (mempty)
import qualified Data.Array as A

import Docopt (Argument(..), Application(..), Branch(..), OptionArgument(..)
              , Value(..))
import qualified Docopt.Spec.Parser.Desc  as D
import qualified Docopt.Spec.Parser.Usage as U

data SolveError = SolveError
instance showSolveError :: Show SolveError where
  show _ = "SolveError"

solveArg :: U.Argument -> List D.Desc -> Either SolveError (List Argument)
solveArg (U.Command s) _       = singleton <$> return (Command s)
solveArg (U.Positional s r) _  = singleton <$> return (Positional s r)
solveArg o@(U.Option n a r) ds = singleton <$> do
  -- XXX: Is `head` the right thing to do here? What if there are more
  -- matches? That would indicate ambigiutiy and needs to be treated, possibly
  -- with an error?
  return $ maybe' (\_ -> Option Nothing (Just n) (toArg a) r)
                  id
                  (head $ catMaybes $ convert <$> ds)

  where
    toArg:: Maybe String -> Maybe OptionArgument
    toArg a = a >>= \an -> return $ OptionArgument an Nothing

    resolveArg :: Maybe String -> Maybe D.Argument -> Maybe OptionArgument
    resolveArg (Just an) Nothing = return $ OptionArgument an Nothing
    resolveArg Nothing (Just (D.Argument a))
      -- XXX: The conversion to `StringValue` should not be needed,
      -- `Desc.Argument` should be of type `Maybe Value`.
      = return $ OptionArgument a.name (StringValue <$> a.default)
    resolveArg (Just an) (Just (D.Argument a))
      -- XXX: Do we need to guard that `an == a.name` here?
      -- XXX: The conversion to `StringValue` should not be needed,
      -- `Desc.Argument` should be of type `Maybe Value`.
      = return $ OptionArgument a.name (StringValue <$> a.default)
    resolveArg _ _ = Nothing

    convert :: D.Desc -> Maybe Argument
    convert (D.OptionDesc (D.Option { name=D.Long n', arg=a' }))
      | n' == n
      = return $ Option Nothing (Just n) (resolveArg a a') r
    convert (D.OptionDesc (D.Option { name=D.Full f n', arg=a' }))
      | n' == n
      = return $ Option (Just f) (Just n) (resolveArg a a') r
    convert _ = Nothing

solveArg o@(U.OptionStack f fs a r) ds = do
  let fs' = f:toList fs

  -- Ensure that only the last stacked option is to be considered in
  -- "trailing" position and hence capable of expanding to take an argument.
  if length fs' > 1
    then do
      xs <- traverse (match false) (fromJust $ init fs')
      x  <- match true (fromJust $ last fs')
      return $ xs ++ singleton x
    else
      traverse (match true) fs'

  where
    match :: Boolean -> Char -> Either SolveError Argument
    match isTrailing f = do
      return $ maybe' (\_ -> Option (Just f) Nothing (toArg a) r)
                      id
                      (head $ catMaybes $ convert f isTrailing <$> ds)

    toArg:: Maybe String -> Maybe OptionArgument
    toArg a = a >>= \an -> return $ OptionArgument an Nothing

    resolveArg :: Maybe String -> Maybe D.Argument -> Maybe OptionArgument
    resolveArg (Just an) Nothing = return $ OptionArgument an Nothing
    resolveArg Nothing (Just (D.Argument a))
      -- XXX: The conversion to `StringValue` should not be needed,
      -- `Desc.Argument` should be of type `Maybe Value`.
      = return $ OptionArgument a.name (StringValue <$> a.default)
    resolveArg (Just an) (Just (D.Argument a))
      -- XXX: Do we need to guard that `an == a.name` here?
      -- XXX: The conversion to `StringValue` should not be needed,
      -- `Desc.Argument` should be of type `Maybe Value`.
      = return $ OptionArgument a.name (StringValue <$> a.default)

    convert :: Char -> Boolean -> D.Desc -> Maybe Argument
    convert f isTrailing (D.OptionDesc (D.Option { name=D.Flag f', arg=a' }))
      | (f == f')
        && (isTrailing || isNothing a')
      = return $ Option (Just f) Nothing (resolveArg a a') r
    convert f isTrailing (D.OptionDesc (D.Option { name=D.Full f' n, arg=a' }))
      | (f == f')
        && (isTrailing || isNothing a')
      = return $ Option (Just f) (Just n) (resolveArg a a') r
    convert _ _ _ = Nothing

solveArg (U.Group o bs r) ds  = singleton <$> do
  flip (Group o) r <$> do
    foldM go empty bs
      where go :: List Branch -> U.Branch -> Either SolveError (List Branch)
            go a b = do
              br <- solveBranch b ds
              return (br:a)

solveBranch :: U.Branch -> List D.Desc -> Either SolveError Branch
solveBranch as ds = Branch <<< concat <$> (foldM step Nil as)
  where
    step :: List (List Argument)
          -> U.Argument
          -> Either SolveError (List (List Argument))
    step ass a = do
      xs <- solveArg a ds
      return $ ass ++ (singleton xs)

solveUsage :: U.Usage -> List D.Desc -> Either SolveError Application
solveUsage (U.Usage _ bs) ds = Application <$> (foldM step Nil bs)
  where
    step :: List Branch -> U.Branch -> Either SolveError (List Branch)
    step bs b = do
      x <- solveBranch b ds
      return $ bs ++ (singleton x)

solve :: (List U.Usage)
      -> (List D.Desc)
      -> Either SolveError (List Application)
solve us ds = foldM step Nil us
  where
    step :: List Application -> U.Usage -> Either SolveError (List Application)
    step as u = do
      x <- solveUsage u ds
      return $ as ++ (singleton x)

-- | Resolve ambiguities by combining the parsed usage section with any parsed
-- | Option sections, as well as some best effort guessing.
-- |
-- | ===

module Docopt.Spec.Solver where

import Prelude
import Debug.Trace
import Data.Either (Either(..))
import Data.Maybe.Unsafe (fromJust)
import Data.Maybe (Maybe(..), isJust, maybe, maybe', isNothing)
import Data.List (List(..), filter, head, foldM, concat, (:), singleton
                , catMaybes, toList, last, init, length)
import Data.Traversable (traverse)
import Data.Foldable (foldl)
import Control.Plus (empty)
import Data.Monoid (mempty)
import qualified Data.Array as A

import Docopt (Argument(..), Application(..), Branch(..), OptionArgument(..)
              , Value(..))
import qualified Docopt.Spec.Parser.Desc  as D
import qualified Docopt.Spec.Parser.Usage as U

data SolveError = SolveError
instance showSolveError :: Show SolveError where
  show _ = "SolveError"

solveArg :: U.Argument -> List D.Desc -> Either SolveError (List Argument)
solveArg (U.Command s) _       = singleton <$> return (Command s)
solveArg (U.Positional s r) _  = singleton <$> return (Positional s r)
solveArg o@(U.Option n a r) ds = singleton <$> do
  -- XXX: Is `head` the right thing to do here? What if there are more
  -- matches? That would indicate ambigiutiy and needs to be treated, possibly
  -- with an error?
  return $ maybe' (\_ -> Option Nothing (Just n) (toArg a) r)
                  id
                  (head $ catMaybes $ convert <$> ds)

  where
    toArg:: Maybe String -> Maybe OptionArgument
    toArg a = a >>= \an -> return $ OptionArgument an Nothing

    resolveArg :: Maybe String -> Maybe D.Argument -> Maybe OptionArgument
    resolveArg (Just an) Nothing = return $ OptionArgument an Nothing
    resolveArg Nothing (Just (D.Argument a))
      -- XXX: The conversion to `StringValue` should not be needed,
      -- `Desc.Argument` should be of type `Maybe Value`.
      = return $ OptionArgument a.name (StringValue <$> a.default)
    resolveArg (Just an) (Just (D.Argument a))
      -- XXX: Do we need to guard that `an == a.name` here?
      -- XXX: The conversion to `StringValue` should not be needed,
      -- `Desc.Argument` should be of type `Maybe Value`.
      = return $ OptionArgument a.name (StringValue <$> a.default)
    resolveArg _ _ = Nothing

    convert :: D.Desc -> Maybe Argument
    convert (D.OptionDesc (D.Option { name=D.Long n', arg=a' }))
      | n' == n
      = return $ Option Nothing (Just n) (resolveArg a a') r
    convert (D.OptionDesc (D.Option { name=D.Full f n', arg=a' }))
      | n' == n
      = return $ Option (Just f) (Just n) (resolveArg a a') r
    convert _ = Nothing

solveArg o@(U.OptionStack f fs a r) ds = do
  let fs' = f:toList fs

  -- Ensure that only the last stacked option is to be considered in
  -- "trailing" position and hence capable of expanding to take an argument.
  if length fs' > 1
    then do
      xs <- traverse (match false) (fromJust $ init fs')
      x  <- match true (fromJust $ last fs')
      return $ xs ++ singleton x
    else
      traverse (match true) fs'

  where
    match :: Boolean -> Char -> Either SolveError Argument
    match isTrailing f = do
      return $ maybe' (\_ -> Option (Just f) Nothing (toArg a) r)
                      id
                      (head $ catMaybes $ convert f isTrailing <$> ds)

    toArg:: Maybe String -> Maybe OptionArgument
    toArg a = a >>= \an -> return $ OptionArgument an Nothing

    resolveArg :: Maybe String -> Maybe D.Argument -> Maybe OptionArgument
    resolveArg (Just an) Nothing = return $ OptionArgument an Nothing
    resolveArg Nothing (Just (D.Argument a))
      -- XXX: The conversion to `StringValue` should not be needed,
      -- `Desc.Argument` should be of type `Maybe Value`.
      = return $ OptionArgument a.name (StringValue <$> a.default)
    resolveArg (Just an) (Just (D.Argument a))
      -- XXX: Do we need to guard that `an == a.name` here?
      -- XXX: The conversion to `StringValue` should not be needed,
      -- `Desc.Argument` should be of type `Maybe Value`.
      = return $ OptionArgument a.name (StringValue <$> a.default)

    convert :: Char -> Boolean -> D.Desc -> Maybe Argument
    convert f isTrailing (D.OptionDesc (D.Option { name=D.Flag f', arg=a' }))
      | (f == f')
        && (isTrailing || isNothing a')
      = return $ Option (Just f) Nothing (resolveArg a a') r
    convert f isTrailing (D.OptionDesc (D.Option { name=D.Full f' n, arg=a' }))
      | (f == f')
        && (isTrailing || isNothing a')
      = return $ Option (Just f) (Just n) (resolveArg a a') r
    convert _ _ _ = Nothing

solveArg (U.Group o bs r) ds  = singleton <$> do
  flip (Group o) r <$> do
    foldM go empty bs
      where go :: List Branch -> U.Branch -> Either SolveError (List Branch)
            go a b = do
              br <- solveBranch b ds
              return (br:a)

solveBranch :: U.Branch -> List D.Desc -> Either SolveError Branch
solveBranch as ds = Branch <<< concat <$> (foldM step Nil as)
  where
    step :: List (List Argument)
          -> U.Argument
          -> Either SolveError (List (List Argument))
    step ass a = do
      xs <- solveArg a ds
      return $ ass ++ (singleton xs)

solveUsage :: U.Usage -> List D.Desc -> Either SolveError Application
solveUsage (U.Usage _ bs) ds = Application <$> (foldM step Nil bs)
  where
    step :: List Branch -> U.Branch -> Either SolveError (List Branch)
    step bs b = do
      x <- solveBranch b ds
      return $ bs ++ (singleton x)

solve :: (List U.Usage)
      -> (List D.Desc)
      -> Either SolveError (List Application)
solve us ds = foldM step Nil us
  where
    step :: List Application -> U.Usage -> Either SolveError (List Application)
    step as u = do
      x <- solveUsage u ds
      return $ as ++ (singleton x)