Coherent (enough) types for working with browser & local coords

module Genetics.Browser.Types
       ( Point
       , Pos
       , Range
       , Bp(..)
       , MBp(..)
       , class HCoordinate
       , bp
       , mbp
       , _Bp
       , _MBp
       , _BpMBp
       , ChrId(..)
       , _ChrId
       , toScreen
       , BpPerPixel(..)
       , bpToPixels
       , pixelsToBp
       , Chr
       , ChrInterval
       , BrowserPoint(..)
       , LocalPoint(..)
       , IntervalPoint
       , Interval(..)
       , CoordSys(..)
       , mkCoordSys
       , findInterval
       , intervalToGlobal
       , globalToInterval
       , canvasToView
       , globalToFrame
       , intervalToChr
       , frameToChr
       ) where

import Prelude

import Control.Alternative (empty)
import Control.MonadPlus (guard)
import Data.Array as Array
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Foldable (length, sum)
import Data.Foreign.Class (class Decode, class Encode)
import Data.Int as Int
import Data.Lens (Iso', Prism', APrism', iso, prism')
import Data.Lens.Iso.Newtype (_Newtype)
import Data.Lens.Types (Iso')
import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype, unwrap, wrap)
import Data.Ratio (Ratio, (%))
import Data.Ratio as Ratio
import Data.Tuple (Tuple(..), fst, snd)
import Unsafe.Coerce (unsafeCoerce)
-- import Genetics.Browser.Units (Bp(..), ChrId(..))

type Point = { x :: Number, y :: Number}

type Pos = { chrId :: ChrId, bp :: Bp }

type Chr = { chrId :: ChrId, size :: Bp }

type Range r = { lHand :: Pos, rHand :: Pos  | r}

-- | Newtype wrapper for a basepair location
newtype Bp = Bp Number
derive instance newtypeBp :: Newtype Bp _
derive newtype instance eqBp :: Eq Bp
derive newtype instance ordBp :: Ord Bp
derive newtype instance fieldBp :: Field Bp
derive newtype instance euclideanRingBp :: EuclideanRing Bp
derive newtype instance commutativeRingBp :: CommutativeRing Bp
derive newtype instance semiringBp :: Semiring Bp
derive newtype instance ringBp :: Ring Bp
derive newtype instance encodeBp :: Encode Bp
derive newtype instance decodeBp :: Decode Bp

instance showBp :: Show Bp where
  show (Bp n) = show n <> "Bp"

_Bp :: Iso' Bp Number
_Bp = _Newtype

_MBp :: Iso' MBp Number
_MBp = _Newtype

-- probably not actually an isomorphism due to floating point inaccuracies
_BpMBp :: Iso' Bp MBp
_BpMBp = iso mbp bp

-- | Newtype wrapper for a megabasepair location
newtype MBp = MBp Number
derive instance newtypeMBp :: Newtype MBp _
derive newtype instance eqMBp :: Eq MBp
derive newtype instance ordMBp :: Ord MBp
derive newtype instance fieldMBp :: Field MBp
derive newtype instance euclideanRingMBp :: EuclideanRing MBp
derive newtype instance commutativeRingMBp :: CommutativeRing MBp
derive newtype instance semiringMBp :: Semiring MBp
derive newtype instance ringMBp :: Ring MBp
derive newtype instance encodeMBp :: Encode MBp
derive newtype instance decodeMBp :: Decode MBp

instance showMBp :: Show MBp where
  show (MBp n) = show n <> "MBp"

class Field a <= HCoordinate a where
  bp :: a -> Bp
  mbp :: a -> MBp

toScreen :: ∀ c. HCoordinate c => c -> c -> c -> Number
toScreen offset scale x = unwrap ((x' - offset') * scale')
  where offset' = bp offset
        scale' = bp scale
        x' = bp x

instance hCoordBp :: HCoordinate Bp where
  bp = id
  mbp (Bp x) = MBp (x * 0.000001)

instance hCoordMBp :: HCoordinate MBp where
  bp (MBp x) = Bp (x * 1000000.0)
  mbp  = id

-- | Newtype wrapper for a chromosome identifier
newtype ChrId = ChrId String
derive instance newtypeChrId :: Newtype ChrId _
derive newtype instance eqChrId :: Eq ChrId
derive newtype instance ordChrId :: Ord ChrId
derive newtype instance encodeChrId :: Encode ChrId
derive newtype instance decodeChrId :: Decode ChrId
derive newtype instance showChrId :: Show ChrId

_ChrId :: Iso' ChrId String
_ChrId = _Newtype

-- TODO be *really cool* and represent it as a ratio of bp and pixels
-- i.e. just a tuple!
-- also it doesn't mean anything on its own;
-- or, rather, it's implicit that it only concerns a single chr at origin

newtype BpPerPixel = BpPerPixel Number
derive instance newtypeBpPerPixel :: Newtype BpPerPixel _

bpToPixels :: BpPerPixel -> Bp -> Number
bpToPixels (BpPerPixel s) (Bp p) = p / s

pixelsToBp :: BpPerPixel -> Number -> Bp
pixelsToBp (BpPerPixel s) p = Bp $ p * s

-- newtype BpScale = BpScale (Ratio BigInt BigInt)

-- Describes a number of `a`s per `b` -- `b` is a phantom type;
-- we always assume `b` is 1 in whatever unit it represents.
data UnitRatio a b = UnitRatio a

instance eqUnitRatio :: (Eq a) => Eq (UnitRatio a b) where
  eq (UnitRatio a) (UnitRatio b) = a == b

instance ordUnitRatio :: (Ord a) => Ord (UnitRatio a b) where
  compare (UnitRatio a) (UnitRatio b) = compare a b

type BpPerPixel' = UnitRatio Number Bp

-- pretty much all my problems appear to be solved by this type. nice
-- data Local f c = Local c c (Ratio c)
-- data BrowserWide c = BrowserWide

-- toGlobal :: forall f c.
--             Ord c
--          => EuclideanRing c
--          => Local f c
--          -> Maybe c
-- toGlobal (Local l r p) =
--   let p' = p * ((r - l) % one)
--   in if Ratio.denominator p' == one
--         then pure $ Ratio.numerator p'
--         else Nothing

-- toLocal :: forall f c.
--            Ord c
--         => EuclideanRing c
--         => c
--         -> Tuple c c
--         -> Local f c
-- toLocal c (Tuple l r) = Local l r $ (c - l) % (r - l)

-- The global coordinate system works by taking the sum of the chromosome sizes;
-- we represent it using a BigInt
newtype BrowserPoint = BPoint BigInt

derive instance eqBrowserPoint :: Eq BrowserPoint
derive instance ordBrowserPoint :: Ord BrowserPoint
derive instance newtypeBrowserPoint :: Newtype BrowserPoint _

-- Subsets of the global coordinate system are defined by some interval,
--

data Interval c = Interval c c

inInterval :: forall c.
              Ord c
           => c
           -> Interval c
           -> Boolean
inInterval p (Interval l r) = l <= p && p <= r

-- clunky but works for now
data LocalPoint c = Local (Interval c) (Ratio BigInt)

-- for now we just assume that the given point is in the interval...
globalToInterval :: forall a c.
                    Newtype c BigInt
                 => Interval c
                 -> c
                 -> LocalPoint c
globalToInterval iv@(Interval l r) p =
  let l' = unwrap l
      r' = unwrap r
      p' = ((unwrap p) - l') % (r' - l')
  in Local iv p'

intervalToGlobal :: forall c.
                    Newtype c BigInt
                 => LocalPoint c
                 -> c
intervalToGlobal (Local (Interval l r) p) =
  let r' = (unwrap r) % one
      l' = (unwrap l) % one
      p' = (p * (r' - l')) + l'
  in wrap $ (Ratio.numerator p') / (Ratio.denominator p')

type IntervalPoint = LocalPoint BrowserPoint

type ChrInterval c = { interval :: Interval c, chrSize :: Bp }

newtype CoordSys i c =
  CoordSys { size :: c
           , padding :: c
           -- , intervals :: Array (Tuple i (Interval c))
           , intervals :: Array (Tuple i (ChrInterval c))
           }

-- TODO need to make sure the padding is correctly applied/removed
mkCoordSys :: forall i c.
              Array (Tuple i BigInt)
           -> BigInt
           -> CoordSys i BrowserPoint
mkCoordSys chrs padding = CoordSys { size, padding: wrap padding, intervals }
  where (Tuple ids sizes) = Array.unzip chrs
        os = map BPoint $ Array.scanl (\x y -> padding + x + y) zero sizes
        ivals = Array.zipWith Interval (wrap zero `Array.cons` os) os
        intervals = Array.zip ids $
                    Array.zipWith (\i s -> {interval: i, chrSize:(Bp $ BigInt.toNumber s)}) ivals sizes
        size = wrap $ (sum sizes) + (length sizes * padding)

findInterval :: forall i c.
                Ord c
             => CoordSys i c
             -> c
             -> Maybe (Tuple i (ChrInterval c))
findInterval (CoordSys s) p =
  Array.find (\(Tuple i iv) -> p `inInterval` iv.interval) s.intervals

canvasToView :: forall r.
                { width :: Number | r }
             -> Number
             -> Ratio BigInt
canvasToView {width} x = x' % w'
  where w' = BigInt.fromInt $ Int.round width
        x' = BigInt.fromInt $ Int.round x

globalToFrame :: forall i c.
                 Eq i
              => CoordSys i BrowserPoint
              -> BrowserPoint
              -> Maybe (Tuple i IntervalPoint)
globalToFrame cs bp@(BPoint p) = do
  (Tuple i iv) <- findInterval cs bp
  pure $ Tuple i $ globalToInterval iv.interval bp

intervalToChr :: BrowserPoint
              -> IntervalPoint
              -> Bp
              -> Maybe Bp
intervalToChr padding (Local (Interval l r) p) chrSize = do
  let padR = (unwrap padding) % (unwrap r - unwrap l)
  -- guard $ p >= padR && p <= one - padR
  let p' = p - padR
      bp = Bp $ (BigInt.toNumber $ Ratio.numerator p') / (BigInt.toNumber $ Ratio.denominator p')

  -- TODO it's dumb that Bp is still a Number newtype
  pure $ bp * chrSize

frameToChr :: forall i c.
              Eq i
           => CoordSys i BrowserPoint
           -> Tuple i IntervalPoint
           -> Maybe Bp
frameToChr (CoordSys s) (Tuple i lp) = do
  iv <- snd <$> Array.find ((==) i <<< fst) s.intervals
  intervalToChr s.padding lp iv.chrSize

module Genetics.Browser.Types
       ( Point
       , Pos
       , Range
       , Bp(..)
       , MBp(..)
       , class HCoordinate
       , bp
       , mbp
       , _Bp
       , _MBp
       , _BpMBp
       , ChrId(..)
       , _ChrId
       , toScreen
       , BpPerPixel(..)
       , bpToPixels
       , pixelsToBp
       , Chr
       ) where

import Prelude

import Control.Alternative (empty)
import Data.Array as Array
import Data.BigInt (BigInt)
import Data.Foreign.Class (class Decode, class Encode)
import Data.Lens (Iso', Prism', APrism', iso, prism')
import Data.Lens.Iso.Newtype (_Newtype)
import Data.Lens.Types (Iso')
import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype, unwrap, wrap)
import Data.Ratio (Ratio, (%))
import Data.Ratio as Ratio
import Data.Tuple (Tuple(..))
-- import Genetics.Browser.Units (Bp(..), ChrId(..))

type Point = { x :: Number, y :: Number}

type Pos = { chrId :: ChrId, bp :: Bp }

type Chr = { chrId :: ChrId, size :: Bp }

type Range r = { lHand :: Pos, rHand :: Pos  | r}

-- | Newtype wrapper for a basepair location
newtype Bp = Bp Number
derive instance newtypeBp :: Newtype Bp _
derive newtype instance eqBp :: Eq Bp
derive newtype instance ordBp :: Ord Bp
derive newtype instance fieldBp :: Field Bp
derive newtype instance euclideanRingBp :: EuclideanRing Bp
derive newtype instance commutativeRingBp :: CommutativeRing Bp
derive newtype instance semiringBp :: Semiring Bp
derive newtype instance ringBp :: Ring Bp
derive newtype instance encodeBp :: Encode Bp
derive newtype instance decodeBp :: Decode Bp

instance showBp :: Show Bp where
  show (Bp n) = show n <> "Bp"

_Bp :: Iso' Bp Number
_Bp = _Newtype

_MBp :: Iso' MBp Number
_MBp = _Newtype

-- probably not actually an isomorphism due to floating point inaccuracies
_BpMBp :: Iso' Bp MBp
_BpMBp = iso mbp bp

-- | Newtype wrapper for a megabasepair location
newtype MBp = MBp Number
derive instance newtypeMBp :: Newtype MBp _
derive newtype instance eqMBp :: Eq MBp
derive newtype instance ordMBp :: Ord MBp
derive newtype instance fieldMBp :: Field MBp
derive newtype instance euclideanRingMBp :: EuclideanRing MBp
derive newtype instance commutativeRingMBp :: CommutativeRing MBp
derive newtype instance semiringMBp :: Semiring MBp
derive newtype instance ringMBp :: Ring MBp
derive newtype instance encodeMBp :: Encode MBp
derive newtype instance decodeMBp :: Decode MBp

instance showMBp :: Show MBp where
  show (MBp n) = show n <> "MBp"

class Field a <= HCoordinate a where
  bp :: a -> Bp
  mbp :: a -> MBp

toScreen :: ∀ c. HCoordinate c => c -> c -> c -> Number
toScreen offset scale x = unwrap ((x' - offset') * scale')
  where offset' = bp offset
        scale' = bp scale
        x' = bp x

instance hCoordBp :: HCoordinate Bp where
  bp = id
  mbp (Bp x) = MBp (x * 0.000001)

instance hCoordMBp :: HCoordinate MBp where
  bp (MBp x) = Bp (x * 1000000.0)
  mbp  = id

-- | Newtype wrapper for a chromosome identifier
newtype ChrId = ChrId String
derive instance newtypeChrId :: Newtype ChrId _
derive newtype instance eqChrId :: Eq ChrId
derive newtype instance ordChrId :: Ord ChrId
derive newtype instance encodeChrId :: Encode ChrId
derive newtype instance decodeChrId :: Decode ChrId
derive newtype instance showChrId :: Show ChrId

_ChrId :: Iso' ChrId String
_ChrId = _Newtype

-- TODO be *really cool* and represent it as a ratio of bp and pixels
-- i.e. just a tuple!
-- also it doesn't mean anything on its own;
-- or, rather, it's implicit that it only concerns a single chr at origin

newtype BpPerPixel = BpPerPixel Number
derive instance newtypeBpPerPixel :: Newtype BpPerPixel _

bpToPixels :: BpPerPixel -> Bp -> Number
bpToPixels (BpPerPixel s) (Bp p) = p / s

pixelsToBp :: BpPerPixel -> Number -> Bp
pixelsToBp (BpPerPixel s) p = Bp $ p * s

-- newtype BpScale = BpScale (Ratio BigInt BigInt)

-- Describes a number of `a`s per `b` -- `b` is a phantom type;
-- we always assume `b` is 1 in whatever unit it represents.
data UnitRatio a b = UnitRatio a

instance eqUnitRatio :: (Eq a) => Eq (UnitRatio a b) where
  eq (UnitRatio a) (UnitRatio b) = a == b

instance ordUnitRatio :: (Ord a) => Ord (UnitRatio a b) where
  compare (UnitRatio a) (UnitRatio b) = compare a b

type BpPerPixel' = UnitRatio Number Bp

-- pretty much all my problems appear to be solved by this type. nice
data Local f c = Local c c (Ratio c)
data BrowserWide c = BrowserWide

toGlobal :: forall f c.
            Ord c
         => EuclideanRing c
         => Local f c
         -> Maybe c
toGlobal (Local l r p) =
  let p' = p * ((r - l) % one)
  in if Ratio.denominator p' == one
        then pure $ Ratio.numerator p'
        else Nothing

toLocal :: forall f c.
           Ord c
        => EuclideanRing c
        => c
        -> Tuple c c
        -> Local f c
toLocal c (Tuple l r) = Local l r $ (c - l) % (r - l)

data InInterval
data InChr

type IntervalLocal = Local InInterval BigInt
type ChrLocal = Local InChr Bp

viewToFrame :: forall i.
               CoordinateSystem i BigInt
            -> IntervalLocal
            -> Maybe (Tuple i IntervalLocal)
viewToFrame cs@(CoordinateSystem s) (Local l r p) = do
  bp <- toGlobal (Local l r p)
  (Tuple i {start, end}) <- findInterval cs bp
  pure $ Tuple i $ toLocal bp (Tuple start end)

viewToChr :: forall i.
             CoordinateSystem i BigInt
          -> IntervalLocal
          -> Maybe (Tuple i ChrLocal)
viewToChr cs@(CoordinateSystem s) (Local l r p) = do
  bp <- toGlobal (Local l r p)

  (Tuple i {start, end}) <- findInterval cs bp

  pure $ Tuple i $ toLocal bp' (Tuple l' r')

  empty
  -- pure $ Tuple i $ toLocal bp (Tuple start end)

type Interval c = {start :: c, end :: c}

-- problem with this rep is padding.
-- becomes more difficult to go Interval <-> Chr then,
-- as they're not actually equal!
newtype CoordinateSystem i c =
  CoordinateSystem
    { intervals :: Array (Tuple i {start :: c, end :: c})
    , size :: c
    , padding :: c
    }

findInterval :: forall i c.
                Ord c
             => CoordinateSystem i c
             -> c
             -> Maybe (Tuple i {start :: c, end :: c})
findInterval (CoordinateSystem s) p =
  Array.find (\(Tuple i {start, end}) -> start <= p && p <= end) s.intervals

derive instance newtypeCoordinateSystem :: Newtype (CoordinateSystem i c) _
-- derive instance functorCoordinateSystem :: Functor (CoordinateSystem i)


Add Ord instance

Add Ord instance

module Data.Either where

import Prelude

data Either a b = Left a | Right b

either :: forall a b c. (a -> c) -> (b -> c) -> Either a b -> c
either f _ (Left a) = f a
either _ g (Right b) = g b

isLeft :: forall a b. Either a b -> Boolean
isLeft = either (const true) (const false)

isRight :: forall a b. Either a b -> Boolean
isRight = either (const false) (const true)

instance functorEither :: Functor (Either a) where
  (<$>) _ (Left x) = Left x
  (<$>) f (Right y) = Right (f y)

instance applyEither :: Apply (Either e) where
  (<*>) (Left e) _ = Left e
  (<*>) (Right f) r = f <$> r

instance applicativeEither :: Applicative (Either e) where
  pure = Right

instance bindEither :: Bind (Either e) where
  (>>=) = either (\e _ -> Left e) (\a f -> f a)

instance monadEither :: Monad (Either e)

instance showEither :: (Show a, Show b) => Show (Either a b) where
  show (Left x) = "Left " ++ (show x)
  show (Right y) = "Right " ++ (show y)

instance eqEither :: (Eq a, Eq b) => Eq (Either a b) where
  (==) (Left a1)  (Left a2)  = a1 == a2
  (==) (Right b1) (Right b2) = b1 == b2
  (==) _          _          = false
  (/=) a          b          = not (a == b)

instance ordEither :: (Ord a, Ord b) => Ord (Either a b) where
  compare (Left a1)  (Left a2)  = compare a1 a2
  compare (Right b1) (Right b2) = compare b1 b2
  compare (Left a)   _          = LT
  compare _          (Left b)   = GT


Isolate test db within a test

Isolate test db within a test

module Test.DataSnapshotSpec (dataSnapshotSpec) where

import Control.Monad (unless)
import Data.Maybe (Maybe(Just))
import Effect.Aff (Aff)
import Effect.Class (liftEffect)
import Foreign (unsafeToForeign)
import Prelude (Unit, bind, discard, pure, ($), (<>), (>=), (>>=))
import Test.Spec (Spec, before, describe, it)
import Test.Spec.Assertions (fail, shouldEqual)
import Web.Firebase as FB
import Web.Firebase.Aff (child, onceValue, set) as DBA
import Web.Firebase.DataSnapshot as D
import Web.Firebase.Testing (DatabaseName(..), adminApp)
import Web.Firebase.Types (DatabaseImpl, Firebase, Key)
import Web.Firebase.Types as FBT

dataSnapshotSpec ::  FBT.Firebase -> Spec Unit
dataSnapshotSpec _ =
  before addAnEntry  do
    describe "DataSnapshot" do
      it "can tell us the number of children" $ \ref -> do
        snapshot <- snapshotFor ref aPath
        let numChildren = D.numChildren snapshot
        expect (numChildren >= 1)

      it "can tell us a child does not exist" $ \ref -> do
        snapshot <- snapshotFor ref aPath
        (D.hasChild snapshot "doesnotexist")  `shouldEqual` false
      it "can tell us the location at the snapshot exists" $ \ref -> do
        snapshot <- snapshotFor ref aPath
        expect $ (D.exists snapshot)

      it "can tell us it has children" $ \ref -> do
        snapshot <- snapshotFor ref aPath
        expect $ D.hasChildren snapshot

      it "says the key of /entries is entries" $ \ref -> do
        snapshot <- snapshotFor ref aPath
        let key = D.key snapshot
        key `shouldEqual` (Just aPath)

      it "it can not tell us the location at the snapshot does not exist"$ \ref ->  do
        snapshot <- snapshotFor ref aPath
        let noChild = (D.child snapshot "doesnotexist")
        (D.exists noChild) `shouldEqual` false

addAnEntry :: Aff DatabaseImpl
addAnEntry = do
  app <- adminApp (DatabaseName "DataSnapshotApp")
  db <- liftEffect $ FB.database app
  ref <- liftEffect $ FB.rootRefFor db
  pathRef <- DBA.child (aPath <> "/firstchild") ref
  DBA.set (unsafeToForeign "something") pathRef
  pure ref

aPath :: String
aPath = "data_snapshot_spec_entries"

snapshotFor :: Firebase -> Key -> Aff FBT.DataSnapshot
snapshotFor ref location  = (liftEffect $ FB.child location ref) >>= DBA.onceValue

expect :: Boolean -> Aff Unit
expect condition = unless condition $ fail "false ≠ true"

module Test.DataSnapshotSpec (dataSnapshotSpec) where

import Control.Monad (unless)
import Data.Maybe (Maybe(Just))
import Effect.Aff (Aff)
import Effect.Class (liftEffect)
import Foreign (unsafeToForeign)
import Prelude (Unit, bind, discard, ($), (<>), (>>=), (>=))
import Test.Spec (Spec, before, describe, it)
import Test.Spec.Assertions (fail, shouldEqual)
import Web.Firebase as FB
import Web.Firebase.Aff (child, onceValue, set) as DBA
import Web.Firebase.DataSnapshot as D
import Web.Firebase.Types (DatabaseImpl, Firebase, Key)
import Web.Firebase.Types as FBT

dataSnapshotSpec ::  FBT.Firebase -> Spec Unit
dataSnapshotSpec ref =
  before (addAnEntry ref) do
    describe "DataSnapshot" do
      it "can tell us the number of children" do
        snapshot <- snapshotFor ref aPath
        let numChildren = D.numChildren snapshot
        expect (numChildren >= 1)

      it "can tell us a child does not exist" do
        snapshot <- snapshotFor ref aPath
        (D.hasChild snapshot "doesnotexist")  `shouldEqual` false
      it "can tell us the location at the snapshot exists" do
        snapshot <- snapshotFor ref aPath
        expect $ (D.exists snapshot)

      it "can tell us it has children" do
        snapshot <- snapshotFor ref aPath
        expect $ D.hasChildren snapshot

      it "says the key of /entries is entries" do
        snapshot <- snapshotFor ref aPath
        let key = D.key snapshot
        key `shouldEqual` (Just aPath)

      it "it can not tell us the location at the snapshot does not exist" do
        snapshot <- snapshotFor ref aPath
        let noChild = (D.child snapshot "doesnotexist")
        (D.exists noChild) `shouldEqual` false

addAnEntry :: DatabaseImpl -> Aff Unit
addAnEntry ref = do
  pathRef <- DBA.child (aPath <> "/firstchild") ref
  DBA.set (unsafeToForeign "something") pathRef

aPath :: String
aPath = "data_snapshot_spec_entries"

snapshotFor :: Firebase -> Key -> Aff FBT.DataSnapshot
snapshotFor ref location  = (liftEffect $ FB.child location ref) >>= DBA.onceValue

expect :: Boolean -> Aff Unit
expect condition = unless condition $ fail "false ≠ true"


Will work on recursive countEven function later.

module Data.Recursion where
import Data.Maybe
import Data.Array (null)
import Data.Array.Unsafe (head, tail)
import Debug.Trace

length :: forall a. [a] -> Number
length arr =
  if null arr
     then 0
     else 1 + length (tail arr)

fact :: Number -> Number
fact 0 = 1
fact n = n * fact (n - 1)

fib :: Number -> Number
fib 0 = 1
fib 1 = 1
fib n = fib (n - 1) + fib (n - 2)

(..) :: Number -> Number -> [Number]
(..) = Data.Array.range

isEven :: Number -> Boolean
-- -- with conditionals
--isEven n =
--  if n % 2 == 0
--     then true
--     else false
-- with pattern matching and recursion
isEven 0 = true
isEven 1 = false
isEven n = isEven (n % 2)

--countEven :: forall a. [a] -> Number
--countEven [] = 0
--countEven arr =
--  if isEven $ head [100]
--     then 1
--     else 2

--main = print (countEven [1,2,3,4,5,6,7,8,9,10])
--main = print (countEven [])
main = print "Hello World"

module Data.Recursion where
import Data.Maybe
import Data.Array (null)
import Data.Array.Unsafe (head, tail)
import Debug.Trace

length :: forall a. [a] -> Number
length arr =
  if null arr
     then 0
     else 1 + length (tail arr)

fact :: Number -> Number
fact 0 = 1
fact n = n * fact (n - 1)

fib :: Number -> Number
fib 0 = 1
fib 1 = 1
fib n = fib (n - 1) + fib (n - 2)

(..) :: Number -> Number -> [Number]
(..) = Data.Array.range

isEven :: Number -> Boolean
isEven n =
  if n % 2 == 0
     then true
     else false

countEven :: forall a. [a] -> Number
countEven [] = 0
countEven arr =
  --if 1 == head arr
  if 1 == head [100]
     then 1
     else 2

main = print (countEven [1,2,3,4,5,6,7,8,9,10])
--main = print (countEven [])


[CSE-193] Improve `key` handling

[CSE-193] Improve `key` handling

to avoid warn messages by React (https://fb.me/react-warning-keys)

-- | Detail page of a `genesis block` https://cardanodocs.com/technical/blocks/#genesis-block

module Explorer.View.GenesisBlock
    ( genesisBlockView
    , maxAddressInfoRows
    )
    where

import Prelude

import Data.Array (null)
import Data.Foldable (for_)
import Data.Lens ((^.))
import Data.Maybe (Maybe(..), isJust)
import Explorer.I18n.Lang (Language, translate)
import Explorer.I18n.Lenses (cGenesis, cAddress, cAddresses, cOf, common, cLoading, cNo, cSummary, cYes, gblAddressesError, gblAddressesNotFound, gblAddressRedeemAmount, gblAddressIsRedeemed, gblNonRedeemedAmountTotal, gblNotFound, gblNumberAddressesToRedeem, gblNumberRedeemedAddresses, gblNumberNotRedeemedAddresses, gblRedeemedAmountTotal, genesisBlock) as I18nL
import Explorer.Lenses.State (currentCGenesisAddressInfos, currentCGenesisSummary, gblLoadingAddressInfosPagination, gblAddressInfosPagination, gblAddressInfosPaginationEditable, gblMaxAddressInfosPagination, genesisBlockViewState, lang, viewStates)
import Explorer.Routes (Route(..), toUrl)
import Explorer.State (minPagination)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (CCurrency(..), CGenesisAddressInfos, PageNumber(..), State)
import Explorer.Util.String (formatADA)
import Explorer.View.Common (currencyCSSClass, paginationView)
import Network.RemoteData (RemoteData(..), withDefault)
import Pos.Explorer.Web.ClientTypes (CGenesisAddressInfo(..), CGenesisSummary(..))
import Pos.Explorer.Web.Lenses.ClientTypes (_CAddress, cgaiCardanoAddress, cgaiGenesisAmount, cgaiIsRedeemed, cgsNumRedeemed, cgsNumNotRedeemed, cgsNumTotal)
import Pux.DOM.Events (onClick) as P
import Pux.DOM.HTML (HTML) as P
import Pux.DOM.HTML.Attributes (key) as P
import Text.Smolder.HTML (a, div, h3, p, span) as S
import Text.Smolder.HTML.Attributes (className, href) as S
import Text.Smolder.Markup ((!), (#!))
import Text.Smolder.Markup (text) as S

genesisBlockView :: State -> P.HTML Action
genesisBlockView state =
    let lang' = state ^. lang
    in
    S.div ! S.className "explorer-genesis"$ do
        S.div ! S.className "explorer-genesis__wrapper"
              $ S.div ! S.className "explorer-genesis__container" $ do
                    S.h3  ! S.className "headline"
                        $ S.text (translate (I18nL.common <<< I18nL.cGenesis) lang')
                    case state ^. currentCGenesisSummary of
                        NotAsked  -> emptyView ""
                        Loading   -> emptyView $ translate (I18nL.common <<< I18nL.cLoading) lang'
                        Failure _ -> emptyView $ translate (I18nL.genesisBlock <<< I18nL.gblNotFound) lang'
                        Success summary -> summaryView summary lang'

        S.div ! S.className "explorer-genesis__wrapper" $ do
            S.div ! S.className "explorer-genesis__container" $ do
                S.h3  ! S.className "headline"
                      $ S.text (translate (I18nL.common <<< I18nL.cAddresses) lang')
                case state ^. currentCGenesisAddressInfos of
                    NotAsked  -> emptyView ""
                    Loading   -> emptyView $ translate (I18nL.common <<< I18nL.cLoading) lang'
                    Failure _ -> emptyView $ translate (I18nL.genesisBlock <<< I18nL.gblAddressesError) lang'
                    Success infos -> addressInfosView infos state

emptyView :: String -> P.HTML Action
emptyView message =
    S.div ! S.className "summary-empty__container"
          $ S.text message

type SummaryRowProps =
    { key :: Int
    , label :: String
    , amount :: String
    , mCurrency :: Maybe CCurrency
    }

mkPropsForSummaryRows :: Language -> CGenesisSummary -> Array SummaryRowProps
mkPropsForSummaryRows lang (CGenesisSummary summary) =
    [ { key: 0
      , label: translate (I18nL.genesisBlock <<< I18nL.gblNumberAddressesToRedeem) lang
      , amount: show $ summary ^. cgsNumTotal
      , mCurrency: Nothing
      }
    , { key: 1
      , label: translate (I18nL.genesisBlock <<< I18nL.gblNumberRedeemedAddresses) lang
      , amount: show $ summary ^. cgsNumRedeemed
      , mCurrency: Nothing
      }
    , { key: 2
      , label: translate (I18nL.genesisBlock <<< I18nL.gblNumberNotRedeemedAddresses) lang
      , amount: show $ summary ^. cgsNumNotRedeemed
      , mCurrency: Nothing
      }
    -- TODO (jk): Uncomment following lines if backend is ready
    -- , { key: 3
    --   , label: translate (I18nL.genesisBlock <<< I18nL.gblRedeemedAmountTotal) lang
    --   , amount: show $ summary ^. cgsRedeemedAmountTotal
    --   , mCurrency: Just ADA
    --   }
    -- , { key: 4
    --   , label: translate (I18nL.genesisBlock <<< I18nL.gblNonRedeemedAmountTotal) lang
    --   , amount: show $ summary ^. cgsNonRedeemedAmountTotal
    --   , mCurrency: Just ADA
    --   }
    ]

summaryRow :: SummaryRowProps -> P.HTML Action
summaryRow props =
    S.div
        ! S.className "row row__summary"
        ! P.key (show props.key)
        $ do
            S.div ! S.className "column column__label"
                  $ S.text props.label
            S.div ! S.className "column column__amount"
                  $ if isJust props.mCurrency
                        then S.span ! S.className (currencyCSSClass props.mCurrency)
                                    $ S.text props.amount
                        else S.text props.amount

summaryView :: CGenesisSummary -> Language -> P.HTML Action
summaryView summary lang =
    S.div ! S.className "summary-wrapper" $ do
        S.div ! S.className "summary-container" $ do
            S.h3  ! S.className "subheadline"
                  $ S.text (translate (I18nL.common <<< I18nL.cSummary) lang)
            S.div $ for_ (mkPropsForSummaryRows lang summary) summaryRow

type AddressInfosHeaderProps =
    { key :: Int
    , label :: String
    , clazz :: String
    }

mkPropsForAddressHeaderView :: Language -> Array AddressInfosHeaderProps
mkPropsForAddressHeaderView lang =
    [ { key: 0
      , label: translate (I18nL.common <<< I18nL.cAddress) lang
      , clazz: "hash"
      }
    , { key: 1
      , label: translate (I18nL.genesisBlock <<< I18nL.gblAddressRedeemAmount) lang
      , clazz: "amount"
      }
    , { key: 2
      , label: translate (I18nL.genesisBlock <<< I18nL.gblAddressIsRedeemed) lang
      , clazz: "redeemed"
      }
    ]

addressesHeaderView :: Language -> P.HTML Action
addressesHeaderView lang =
    S.div ! S.className "address-infos__header"
          $ for_ (mkPropsForAddressHeaderView lang) addressesHeaderItemView

addressesHeaderItemView :: AddressInfosHeaderProps -> P.HTML Action
addressesHeaderItemView props =
    S.div ! S.className props.clazz
          ! P.key (show props.key)
          $ S.text props.label

addressInfosBodyView :: Language -> CGenesisAddressInfo -> P.HTML Action
addressInfosBodyView lang (CGenesisAddressInfo info) =
    let addrLink = toUrl $ Address (info ^. cgaiCardanoAddress)
        addrString = info ^. (cgaiCardanoAddress <<< _CAddress)
    in
    S.div ! S.className "address-infos__body--row"
          ! P.key addrString
          $ do
          -- hash
          S.a ! S.className "address-infos__body--column hash"
              ! S.href addrLink
              #! P.onClick (Navigate addrLink)
              $ S.text addrString
          -- amount
          S.div ! S.className "address-infos__body--column amount"
                $ S.span ! S.className (currencyCSSClass $ Just ADA)
                          $ S.text (formatADA (info ^. cgaiGenesisAmount) lang)
          -- is redeemed
          S.div ! S.className "address-infos__body--column redeemed"
                $ S.text (if (info ^. cgaiIsRedeemed)
                              then translate (I18nL.common <<< I18nL.cYes) lang
                              else translate (I18nL.common <<< I18nL.cNo) lang)

maxAddressInfoRows :: Int
maxAddressInfoRows = 5

addressInfosView :: CGenesisAddressInfos -> State -> P.HTML Action
addressInfosView infos state =
    if null infos then
        emptyView $ translate (I18nL.genesisBlock <<< I18nL.gblAddressesNotFound) (state ^. lang)
    else
        let lang' = state ^. lang
            isLoading = state ^. (viewStates <<< genesisBlockViewState <<< gblLoadingAddressInfosPagination)
        in
        do
            S.div
                ! S.className "address-infos__wrapper"
                $ do
                    addressesHeaderView lang'
                    S.div ! S.className "address-infos__body--wrapper"
                          $ do
                          for_ infos (addressInfosBodyView lang')
                          S.div ! S.className ("address-infos__body--cover" <>  if isLoading then " show" else "")
                                $ S.p ! S.className "address-infos__body--cover-label"
                                      $ S.text (translate (I18nL.common <<< I18nL.cLoading) lang')
            S.div
                ! S.className "address-infos__footer"
                $  paginationView  { label: translate (I18nL.common <<< I18nL.cOf) $ lang'
                                    , currentPage: state ^. (viewStates <<< genesisBlockViewState <<< gblAddressInfosPagination)
                                    , minPage: PageNumber minPagination
                                    , maxPage: withDefault
                                                  (PageNumber minPagination)
                                                  (state ^. (viewStates <<< genesisBlockViewState <<< gblMaxAddressInfosPagination))
                                    , changePageAction: GenesisBlockPaginateAddresses
                                    , editable: state ^. (viewStates <<< genesisBlockViewState <<< gblAddressInfosPaginationEditable)
                                    , editableAction: GenesisBlockEditAddressesPageNumber
                                    , invalidPageAction: GenesisBlockInvalidAddressesPageNumber
                                    , disabled: isLoading
                                    }

-- | Detail page of a `genesis block` https://cardanodocs.com/technical/blocks/#genesis-block

module Explorer.View.GenesisBlock
    ( genesisBlockView
    , maxAddressInfoRows
    )
    where

import Prelude

import Data.Array (null)
import Data.Foldable (for_)
import Data.Lens ((^.))
import Data.Maybe (Maybe(..), isJust)
import Explorer.I18n.Lang (Language, translate)
import Explorer.I18n.Lenses (cGenesis, cAddress, cAddresses, cOf, common, cLoading, cNo, cSummary, cYes, gblAddressesError, gblAddressesNotFound, gblAddressRedeemAmount, gblAddressIsRedeemed, gblNonRedeemedAmountTotal, gblNotFound, gblNumberAddressesToRedeem, gblNumberRedeemedAddresses, gblNumberNotRedeemedAddresses, gblRedeemedAmountTotal, genesisBlock) as I18nL
import Explorer.Lenses.State (currentCGenesisAddressInfos, currentCGenesisSummary, gblLoadingAddressInfosPagination, gblAddressInfosPagination, gblAddressInfosPaginationEditable, gblMaxAddressInfosPagination, genesisBlockViewState, lang, viewStates)
import Explorer.Routes (Route(..), toUrl)
import Explorer.State (minPagination)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (CCurrency(..), CGenesisAddressInfos, PageNumber(..), State)
import Explorer.Util.String (formatADA)
import Explorer.View.Common (currencyCSSClass, paginationView)
import Network.RemoteData (RemoteData(..), withDefault)
import Pos.Explorer.Web.ClientTypes (CGenesisAddressInfo(..), CGenesisSummary(..))
import Pos.Explorer.Web.Lenses.ClientTypes (_CAddress, cgaiCardanoAddress, cgaiGenesisAmount, cgaiIsRedeemed, cgsNumRedeemed, cgsNumNotRedeemed, cgsNumTotal)
import Pux.DOM.Events (onClick) as P
import Pux.DOM.HTML (HTML) as P
import Pux.DOM.HTML.Attributes (key) as P
import Text.Smolder.HTML (a, div, h3, p, span) as S
import Text.Smolder.HTML.Attributes (className, href) as S
import Text.Smolder.Markup ((!), (#!))
import Text.Smolder.Markup (text) as S

genesisBlockView :: State -> P.HTML Action
genesisBlockView state =
    let lang' = state ^. lang
    in
    S.div ! S.className "explorer-genesis"$ do
        S.div ! S.className "explorer-genesis__wrapper"
              $ S.div ! S.className "explorer-genesis__container" $ do
                    S.h3  ! S.className "headline"
                        $ S.text (translate (I18nL.common <<< I18nL.cGenesis) lang')
                    case state ^. currentCGenesisSummary of
                        NotAsked  -> emptyView ""
                        Loading   -> emptyView $ translate (I18nL.common <<< I18nL.cLoading) lang'
                        Failure _ -> emptyView $ translate (I18nL.genesisBlock <<< I18nL.gblNotFound) lang'
                        Success summary -> summaryView summary lang'

        S.div ! S.className "explorer-genesis__wrapper" $ do
            S.div ! S.className "explorer-genesis__container" $ do
                S.h3  ! S.className "headline"
                      $ S.text (translate (I18nL.common <<< I18nL.cAddresses) lang')
                case state ^. currentCGenesisAddressInfos of
                    NotAsked  -> emptyView ""
                    Loading   -> emptyView $ translate (I18nL.common <<< I18nL.cLoading) lang'
                    Failure _ -> emptyView $ translate (I18nL.genesisBlock <<< I18nL.gblAddressesError) lang'
                    Success infos -> addressInfosView infos state

emptyView :: String -> P.HTML Action
emptyView message =
    S.div ! S.className "summary-empty__container"
          $ S.text message

type SummaryRowProps =
    { key :: String
    , label :: String
    , amount :: String
    , mCurrency :: Maybe CCurrency
    }

mkPropsForSummaryRows :: Language -> CGenesisSummary -> Array SummaryRowProps
mkPropsForSummaryRows lang (CGenesisSummary summary) =
    [ { key: "0"
      , label: translate (I18nL.genesisBlock <<< I18nL.gblNumberAddressesToRedeem) lang
      , amount: show $ summary ^. cgsNumTotal
      , mCurrency: Nothing
      }
    , { key: "1"
      , label: translate (I18nL.genesisBlock <<< I18nL.gblNumberRedeemedAddresses) lang
      , amount: show $ summary ^. cgsNumRedeemed
      , mCurrency: Nothing
      }
    , { key: "2"
      , label: translate (I18nL.genesisBlock <<< I18nL.gblNumberNotRedeemedAddresses) lang
      , amount: show $ summary ^. cgsNumNotRedeemed
      , mCurrency: Nothing
      }
    -- TODO (jk): Uncomment following lines if backend is ready
    -- , { key: "3"
    --   , label: translate (I18nL.genesisBlock <<< I18nL.gblRedeemedAmountTotal) lang
    --   , amount: show $ summary ^. cgsRedeemedAmountTotal
    --   , mCurrency: Just ADA
    --   }
    -- , { key: "4"
    --   , label: translate (I18nL.genesisBlock <<< I18nL.gblNonRedeemedAmountTotal) lang
    --   , amount: show $ summary ^. cgsNonRedeemedAmountTotal
    --   , mCurrency: Just ADA
    --   }
    ]

summaryRow :: SummaryRowProps -> P.HTML Action
summaryRow props =
    S.div
        ! S.className "row row__summary"
        ! P.key props.key
        $ do
            S.div ! S.className "column column__label"
                  $ S.text props.label
            S.div ! S.className "column column__amount"
                  $ if isJust props.mCurrency
                        then S.span ! S.className (currencyCSSClass props.mCurrency)
                                    $ S.text props.amount
                        else S.text props.amount

summaryView :: CGenesisSummary -> Language -> P.HTML Action
summaryView summary lang =
    S.div ! S.className "summary-wrapper" $ do
        S.div ! S.className "summary-container" $ do
            S.h3  ! S.className "subheadline"
                  $ S.text (translate (I18nL.common <<< I18nL.cSummary) lang)
            S.div $ for_ (mkPropsForSummaryRows lang summary) summaryRow

type AddressInfosHeaderProps =
    { label :: String
    , clazz :: String
    }

mkAddressInfosHeaderProps :: Language -> Array AddressInfosHeaderProps
mkAddressInfosHeaderProps lang =
    [ { label: translate (I18nL.common <<< I18nL.cAddress) lang
      , clazz: "hash"
      }
    , { label: translate (I18nL.genesisBlock <<< I18nL.gblAddressRedeemAmount) lang
      , clazz: "amount"
      }
    , { label: translate (I18nL.genesisBlock <<< I18nL.gblAddressIsRedeemed) lang
      , clazz: "redeemed"
      }
    ]

addressesHeaderView :: Language -> P.HTML Action
addressesHeaderView lang =
    S.div ! S.className "address-infos__header"
          $ for_ (mkAddressInfosHeaderProps lang) addressesHeaderItemView

addressesHeaderItemView :: AddressInfosHeaderProps -> P.HTML Action
addressesHeaderItemView props =
    S.div ! S.className props.clazz
          $ S.text props.label

addressInfosBodyView :: Language -> CGenesisAddressInfo -> P.HTML Action
addressInfosBodyView lang (CGenesisAddressInfo info) =
    let addrLink = toUrl $ Address (info ^. cgaiCardanoAddress) in
    S.div ! S.className "address-infos__body--row"
          $ do
          -- hash
          S.a ! S.className "address-infos__body--column hash"
              ! S.href addrLink
              #! P.onClick (Navigate addrLink)
              $ S.text (info ^. (cgaiCardanoAddress <<< _CAddress))
          -- amount
          S.div ! S.className "address-infos__body--column amount"
                $ S.span ! S.className (currencyCSSClass $ Just ADA)
                          $ S.text (formatADA (info ^. cgaiGenesisAmount) lang)
          -- is redeemed
          S.div ! S.className "address-infos__body--column redeemed"
                $ S.text (if (info ^. cgaiIsRedeemed)
                              then translate (I18nL.common <<< I18nL.cYes) lang
                              else translate (I18nL.common <<< I18nL.cNo) lang)

maxAddressInfoRows :: Int
maxAddressInfoRows = 5

addressInfosView :: CGenesisAddressInfos -> State -> P.HTML Action
addressInfosView infos state =
    if null infos then
        emptyView $ translate (I18nL.genesisBlock <<< I18nL.gblAddressesNotFound) (state ^. lang)
    else
        let lang' = state ^. lang
            isLoading = state ^. (viewStates <<< genesisBlockViewState <<< gblLoadingAddressInfosPagination)
        in
        do
            S.div
                ! S.className "address-infos__wrapper"
                $ do
                    addressesHeaderView lang'
                    S.div ! S.className "address-infos__body--wrapper"
                          $ do
                          for_ infos (addressInfosBodyView lang')
                          S.div ! S.className ("address-infos__body--cover" <>  if isLoading then " show" else "")
                                $ S.p ! S.className "address-infos__body--cover-label"
                                      $ S.text (translate (I18nL.common <<< I18nL.cLoading) lang')
            S.div
                ! S.className "address-infos__footer"
                $  paginationView  { label: translate (I18nL.common <<< I18nL.cOf) $ lang'
                                    , currentPage: state ^. (viewStates <<< genesisBlockViewState <<< gblAddressInfosPagination)
                                    , minPage: PageNumber minPagination
                                    , maxPage: withDefault
                                                  (PageNumber minPagination)
                                                  (state ^. (viewStates <<< genesisBlockViewState <<< gblMaxAddressInfosPagination))
                                    , changePageAction: GenesisBlockPaginateAddresses
                                    , editable: state ^. (viewStates <<< genesisBlockViewState <<< gblAddressInfosPaginationEditable)
                                    , editableAction: GenesisBlockEditAddressesPageNumber
                                    , invalidPageAction: GenesisBlockInvalidAddressesPageNumber
                                    , disabled: isLoading
                                    }


whoops

whoops

module Openspace.Types where

import           Data.Either
import           Data.Foreign
import           Data.Foreign.Class
import           Data.Foreign.Index
import qualified Data.Map as M
import           Data.Maybe
import           Data.Tuple

-----------------
--| TopicType |--
-----------------

data TopicType = Discussion
               | Presentation
               | Workshop

instance eqTopicType :: Eq TopicType where
(==) tt1 tt2 = show tt1 == show tt2
(/=) tt1 tt2 = show tt1 /= show tt2

instance showTopicType :: Show TopicType where
  show Discussion = "Discussion"
  show Presentation = "Presentation"
  show Workshop = "Workshop"

instance foreignTopicType :: IsForeign TopicType where
  read val = case readString val of
    Right "Discussion"   -> Right Discussion
    Right "Presentation" -> Right Presentation
    Right "Workshop"     -> Right Workshop
    _                    -> Left $ JSONError "Cant read TopicType"

-- Used to fill Dropdowns etc.
topicTypes = [Discussion, Presentation, Workshop]

--------------
--| Topics |--
--------------

newtype Topic = Topic { description :: String
                      , typ   :: TopicType }

instance eqTopic :: Eq Topic where
  (==) (Topic t1) (Topic t2) = t1.description == t2.description && t1.typ == t2.typ
  (/=) t1 t2 = not (t1 == t2)

instance foreignTopic :: IsForeign Topic where
  read val = Topic <$> (
    { description: _, typ: _ } <$>
    readProp "description" val <*>
    readProp "typ" val
    )

------------
--| Slot |--
------------

newtype Slot = Slot { room :: Room, block :: Block }

instance eqSlot :: Eq Slot where
  (==) (Slot s1) (Slot s2) = s1.room == s2.room && s1.block == s2.block
  (/=) (Slot s1) (Slot s2) = s1.room /= s2.room || s1.block /= s2.block

instance ordSlot :: Ord Slot where
  compare (Slot s1) (Slot s2) =
    (show s1.room ++ show s1.block) `compare` (show s2.room ++ show s2.block)

instance showSlot :: Show Slot where
  show (Slot s) = "{ room: " ++ show s.room ++" block: " ++ show s.block ++ "}"

instance foreignSlot :: IsForeign Slot where
  read val = Slot <$> (
    { room: _, block: _} <$>
    readProp "room" val  <*>
    readProp "block" val
    )

------------
--| Room |--
------------

newtype Room = Room { name :: String, capacity :: Number }

instance showRoom :: Show Room where
  show (Room r) = r.name

instance eqRoom :: Eq Room where
  (==) (Room r1) (Room r2) = r1.name == r2.name
  (/=) (Room r1) (Room r2) = r1.name /= r2.name

instance foreignRoom :: IsForeign Room where
  read val = Room <$> (
    { name: _, capacity: _} <$>
    readProp "name" val     <*>
    readProp "capacity" val
    )

-------------
--| Block |--
-------------

newtype Block = Block { description :: String
                      , startHours :: Number
                      , startMinutes :: Number
                      , endHours :: Number
                      , endMinutes :: Number}

instance showBlock :: Show Block where
  show (Block b) = b.description

instance eqBlock :: Eq Block where
  (==) (Block b1) (Block b2) = b1.description == b2.description
                               && b1.startHours == b2.startHours
                               && b1.startMinutes == b2.startMinutes
                               && b1.endHours == b2.endHours
                               && b1.endMinutes == b2.endMinutes

  (/=) b1 b2 = not (b1 == b2)

instance ordBlock :: Ord Block where
  compare (Block b1) (Block b2) = compare (hourDiff * 60 + minDiff) 0
    where hourDiff = b1.startHours - b2.startHours
          minDiff = b1.startMinutes - b2.startMinutes

instance foreignBlock :: IsForeign Block where
  read val = Block <$> (
    { description: _
    , startHours: _
    , startMinutes: _
    , endHours: _
    , endMinutes: _
    } <$>
    readProp "description" val <*>
    readProp "startHours" val <*>
    readProp "startMinutes" val <*>
    readProp "endHours" val <*>
    readProp "endMinutes" val
    )

---------------
--| Actions |--
---------------

data Action = AddTopic Topic
            | DeleteTopic Topic
            | AddRoom Room
            | DeleteRoom Room
            | AddBlock Block
            | DeleteBlock Block
            | AssignTopic Slot Topic
            | UnassignTopic Topic
            | ReplayActions [Action]
            | ShowError String
            | NOP

instance foreignAction :: IsForeign Action where
read val = case readProp "tag" val of
  Right "AddTopic" -> AddTopic <$> readProp "contents" val
  Right "DeleteTopic" -> DeleteTopic <$> readProp "contents" val
  Right "AddRoom" -> AddRoom <$> readProp "contents" val
  Right "DeleteRoom" -> DeleteRoom <$> readProp "contents" val
  Right "AddBlock" -> AddBlock <$> readProp "contents" val
  Right "DeleteBlock" -> DeleteBlock <$> readProp "contents" val
  Right "AssignTopic" -> let val' = parseAssignTopic val
                         in AssignTopic <$> readProp "slot" val <*> readProp "topic" val
  Right "UnassignTopic" -> UnassignTopic <$> readProp "contents" val
  Right "ReplayEvents" -> ReplayActions <$> readProp "contents" val
  Right "ShowError" -> ShowError <$> readProp "message" val
  Left e -> Right $ ShowError (show e)

class AsForeign a where
  serialize :: a -> Foreign

instance actionAsForeign :: AsForeign Action where
  serialize (AddTopic (Topic t)) =
    toForeign { tag: "AddTopic"
              , contents: { description: t.description
                          , typ: show t.typ
                          }
              }

  serialize (DeleteTopic (Topic t)) =
    toForeign { tag: "DeleteTopic"
              , contents: { description: t.description
                          , typ: show t.typ
                          }
              }
  serialize (AddRoom (Room r)) =
    toForeign { tag: "AddRoom"
              , contents: r }

  serialize (DeleteRoom (Room r)) =
    toForeign { tag: "DeleteRoom"
              , contents: r }

  serialize (AddBlock (Block b)) =
    toForeign { tag: "AddBlock"
              , contents: b }

  serialize (DeleteBlock (Block b)) =
    toForeign { tag: "DeleteBlock"
              , contents: b }

  serialize (AssignTopic s t) = serializeAssignTopic s t
  serialize (UnassignTopic (Topic t)) =
    toForeign { tag: "UnassignTopic"
              , contents: { description: t.description
                          , typ: show t.typ
                          }
              }

foreign import parseAssignTopic
"""
function parseAssignTopic(foreign) {
  return {
    topic : foreign.contents[1],
    slot : foreign.contents[0]
    }
  }
  """ :: Foreign -> Foreign

foreign import serializeAssignTopic
"""
function serializeAssignTopic(slot) {
  return function(topic){
    return { tag: "AssignTopic",
             contents:[
               slot,
               {
                 description: topic.description
                 , typ: Prelude.show(showTopicType)(topic.typ)
               }
             ]
           }
  }
}
""" :: Slot -> Topic -> Foreign

-------------------------
--| Entire AppState |--
-------------------------

type Timeslot = Tuple Slot Topic

type AppState = { topics :: [Topic]
                , rooms :: [Room]
                , blocks :: [Block]
                , timeslots :: M.Map Slot Topic
                }

 --------------------
 --| Dummy Values |--
 --------------------

emptyState = {topics: [], rooms:[], blocks:[], timeslots: (M.empty) :: M.Map Slot Topic }

myRoom = Room {name: "Berlin", capacity: 100}
myRoom1 = Room {name: "Hamburg", capacity: 80}
myRoom2 = Room {name: "Koeln", capacity: 30}

myBlock = Block {
  description:"First",
  startHours: 8,
  startMinutes: 0,
  endHours: 10,
  endMinutes: 0}
myBlock1 = Block {
  description:"Second",
  startHours: 8,
  startMinutes: 0,
  endHours: 10,
  endMinutes: 0}

mySlot = Slot {room:myRoom, block:myBlock}
mySlot1 = Slot {room:myRoom1, block:myBlock1}

myTopic = Topic  {description:"Purescript is great", typ:Workshop}
myTopic1 = Topic {description:"Reactive Design", typ:Presentation}
myTopic2 = Topic {description:"Functional Javascript", typ:Discussion}
myTopic3 = Topic {description:"Enemy of the State", typ:Presentation}
myTopic4 = Topic {description:"Wayyyyyyy too long name for a Topic.", typ:Workshop}
myTopic5 = Topic {description:"fix", typ:Discussion}

myState1 = { topics: [myTopic, myTopic1, myTopic2, myTopic3, myTopic4, myTopic5]
           , rooms : [myRoom, myRoom1, myRoom2]
           , blocks : [myBlock, myBlock1]
           , timeslots: M.fromList [Tuple mySlot myTopic, Tuple mySlot1 myTopic1]
           }

module Openspace.Types where

import           Data.Either
import           Data.Foreign
import           Data.Foreign.Class
import           Data.Foreign.Index
import qualified Data.Map as M
import           Data.Maybe
import           Data.Tuple

-----------------
--| TopicType |--
-----------------

data TopicType = Discussion
               | Presentation
               | Workshop

instance eqTopicType :: Eq TopicType where
(==) tt1 tt2 = show tt1 == show tt2
(/=) tt1 tt2 = show tt1 /= show tt2

instance showTopicType :: Show TopicType where
  show Discussion = "Discussion"
  show Presentation = "Presentation"
  show Workshop = "Workshop"

instance foreignTopicType :: IsForeign TopicType where
  read val = case readString val of
    Right "Discussion"   -> Right Discussion
    Right "Presentation" -> Right Presentation
    Right "Workshop"     -> Right Workshop
    _                    -> Left $ JSONError "Cant read TopicType"

-- Used to fill Dropdowns etc.
topicTypes = [Discussion, Presentation, Workshop]

--------------
--| Topics |--
--------------

newtype Topic = Topic { description :: String
                      , typ   :: TopicType }

instance eqTopic :: Eq Topic where
  (==) (Topic t1) (Topic t2) = t1.description == t2.description && t1.typ == t2.typ
  (/=) t1 t2 = not (t1 == t2)

instance foreignTopic :: IsForeign Topic where
  read val = Topic <$> (
    { description: _, typ: _ } <$>
    readProp "description" val <*>
    readProp "typ" val
    )

------------
--| Slot |--
------------

newtype Slot = Slot { room :: Room, block :: Block }

instance eqSlot :: Eq Slot where
  (==) (Slot s1) (Slot s2) = s1.room == s2.room && s1.block == s2.block
  (/=) (Slot s1) (Slot s2) = s1.room /= s2.room || s1.block /= s2.block

instance ordSlot :: Ord Slot where
  compare (Slot s1) (Slot s2) =
    (show s1.room ++ show s1.block) `compare` (show s2.room ++ show s2.block)

instance showSlot :: Show Slot where
  show (Slot s) = "{ room: " ++ show s.room ++" block: " ++ show s.block ++ "}"

instance foreignSlot :: IsForeign Slot where
  read val = Slot <$> (
    { room: _, block: _} <$>
    readProp "room" val  <*>
    readProp "block" val
    )

------------
--| Room |--
------------

newtype Room = Room { name :: String, capacity :: Number }

instance showRoom :: Show Room where
  show (Room r) = r.name

instance eqRoom :: Eq Room where
  (==) (Room r1) (Room r2) = r1.name == r2.name
  (/=) (Room r1) (Room r2) = r1.name /= r2.name

instance foreignRoom :: IsForeign Room where
  read val = Room <$> (
    { name: _, capacity: _} <$>
    readProp "name" val     <*>
    readProp "capacity" val
    )

-------------
--| Block |--
-------------

newtype Block = Block { description :: String
                      , startHours :: Number
                      , startMinutes :: Number
                      , endHours :: Number
                      , endMinutes :: Number}

instance showBlock :: Show Block where
  show (Block b) = b.description

instance eqBlock :: Eq Block where
  (==) (Block b1) (Block b2) = b1.description == b2.description
                               && b1.startHours == b2.startHours
                               && b1.startMinutes == b2.startMinutes
                               && b1.endHours == b2.endHours
                               && b1.endMinutes == b2.endMinutes

  (/=) b1 b2 = not (b1 == b2)

instance ordBlock :: Ord Block where
  compare (Block b1) (Block b2) = compare (hourDiff * 60 + minDiff) 0
    where hourDiff = b1.startHours - b2.startHours
          minDiff = b1.startMinutes - b2.startMinutes

instance foreignBlock :: IsForeign Block where
  read val = Block <$> (
    { description: _
    , startHours: _
    , startMinutes: _
    , endHours: _
    , endMinutes: _
    } <$>
    readProp "description" val <*>
    readProp "startHours" val <*>
    readProp "startMinutes" val <*>
    readProp "endHours" val <*>
    readProp "endMinutes" val
    )

---------------
--| Actions |--
---------------

data Action = AddTopic Topic
            | DeleteTopic Topic
            | AddRoom Room
            | DeleteRoom Room
            | AddBlock Block
            | DeleteBlock Block
            | AssignTopic Slot Topic
            | UnassignTopic Topic
            | ReplayActions [Action]
            | ShowError String
            | NOP

instance foreignAction :: IsForeign Action where
read val = case readProp "tag" val of
  Right "AddTopic" -> AddTopic <$> readProp "contents" val
  Right "DeleteTopic" -> DeleteTopic <$> readProp "contents" val
  Right "AddRoom" -> AddRoom <$> readProp "contents" val
  Right "DeleteRoom" -> DeletRoom <$> readProp "contents" val
  Right "AddBlock" -> AddBlock <$> readProp "contents" val
  Right "DeleteBlock" -> DeleteBlock <$> readProp "contents" val
  Right "AssignTopic" -> let val' = parseAssignTopic val
                         in AssignTopic <$> readProp "slot" val <*> readProp "topic" val
  Right "UnassignTopic" -> UnassignTopic <$> readProp "contents" val
  Right "ReplayEvents" -> ReplayActions <$> readProp "contents" val
  Right "ShowError" -> ShowError <$> readProp "message" val
  Left e -> Right $ ShowError (show e)

class AsForeign a where
  serialize :: a -> Foreign

instance actionAsForeign :: AsForeign Action where
  serialize (AddTopic (Topic t)) =
    toForeign { tag: "AddTopic"
              , contents: { description: t.description
                          , typ: show t.typ
                          }
              }

  serialize (DeleteTopic (Topic t)) =
    toForeign { tag: "DeleteTopic"
              , contents: { description: t.description
                          , typ: show t.typ
                          }
              }
  serialize (AddRoom (Room r)) =
    toForeign { tag: "AddRoom"
              , contents: r }

  serialize (DeleteRoom (Room r)) =
    toForeign { tag: "DeleteRoom"
              , contents: r }

  serialize (AddBlock (Block b)) =
    toForeign { tag: "AddBlock"
              , contents: b }

  serialize (DeleteBlock (Block b)) =
    toForeign { tag: "DeleteBlock"
              , contents: b }

  serialize (AssignTopic s t) = serializeAssignTopic s t
  serialize (UnassignTopic (Topic t)) =
    toForeign { tag: "UnassignTopic"
              , contents: { description: t.description
                          , typ: show t.typ
                          }
              }

foreign import parseAssignTopic
"""
function parseAssignTopic(foreign) {
  return {
    topic : foreign.contents[1],
    slot : foreign.contents[0]
    }
  }
  """ :: Foreign -> Foreign

foreign import serializeAssignTopic
"""
function serializeAssignTopic(slot) {
  return function(topic){
    return { tag: "AssignTopic",
             contents:[
               slot,
               {
                 description: topic.description
                 , typ: Prelude.show(showTopicType)(topic.typ)
               }
             ]
           }
  }
}
""" :: Slot -> Topic -> Foreign

-------------------------
--| Entire AppState |--
-------------------------

type Timeslot = Tuple Slot Topic

type AppState = { topics :: [Topic]
                , rooms :: [Room]
                , blocks :: [Block]
                , timeslots :: M.Map Slot Topic
                }

 --------------------
 --| Dummy Values |--
 --------------------

emptyState = {topics: [], rooms:[], blocks:[], timeslots: (M.empty) :: M.Map Slot Topic }

myRoom = Room {name: "Berlin", capacity: 100}
myRoom1 = Room {name: "Hamburg", capacity: 80}
myRoom2 = Room {name: "Koeln", capacity: 30}

myBlock = Block {
  description:"First",
  startHours: 8,
  startMinutes: 0,
  endHours: 10,
  endMinutes: 0}
myBlock1 = Block {
  description:"Second",
  startHours: 8,
  startMinutes: 0,
  endHours: 10,
  endMinutes: 0}

mySlot = Slot {room:myRoom, block:myBlock}
mySlot1 = Slot {room:myRoom1, block:myBlock1}

myTopic = Topic  {description:"Purescript is great", typ:Workshop}
myTopic1 = Topic {description:"Reactive Design", typ:Presentation}
myTopic2 = Topic {description:"Functional Javascript", typ:Discussion}
myTopic3 = Topic {description:"Enemy of the State", typ:Presentation}
myTopic4 = Topic {description:"Wayyyyyyy too long name for a Topic.", typ:Workshop}
myTopic5 = Topic {description:"fix", typ:Discussion}

myState1 = { topics: [myTopic, myTopic1, myTopic2, myTopic3, myTopic4, myTopic5]
           , rooms : [myRoom, myRoom1, myRoom2]
           , blocks : [myBlock, myBlock1]
           , timeslots: M.fromList [Tuple mySlot myTopic, Tuple mySlot1 myTopic1]
           }


Remove unused file `Specification.purs`

Remove unused file `Specification.purs`


needed a `$` 'cause PS thought it was a substract

{-
Copyright 2017 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.MillerColumns.Component
  ( MillerColumnsComponent
  , component
  , module SlamData.Workspace.MillerColumns.Component.Query
  , module Exports
  ) where

import SlamData.Prelude

import Control.Monad.Eff (Eff)
import Data.Array as A
import Data.List ((:))
import Data.List as L
import Data.Profunctor.Strong (second)
import DOM (DOM)
import DOM.Classy.Event (preventDefault) as DOM
import DOM.Classy.HTMLElement (offsetHeight, scrollHeight, setScrollTop) as DOM
import DOM.HTML.Types (HTMLElement)
import Halogen as H
import Halogen.Component.Proxy (queryQ)
import Halogen.Component.Utils.Drag as Drag
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.HTML.Properties.ARIA as ARIA
import SlamData.Monad (Slam)
import SlamData.Workspace.MillerColumns.Column.Component (ColumnOptions(..)) as Exports
import SlamData.Workspace.MillerColumns.Column.Component as Column
import SlamData.Workspace.MillerColumns.Column.Component.Request (LoadRequest, LoadResponse) as Exports
import SlamData.Workspace.MillerColumns.Component.Query (Query(..), Message(..), Message')
import SlamData.Workspace.MillerColumns.Component.State as S

type MillerColumnsComponent a i o = H.Component HH.HTML (Query a i o) (S.ColumnsData a i) (Message' a i o) Slam

type HTML a i o = H.ParentHTML (Query a i o) (Column.Query' a i o) (Int × i) Slam
type DSL a i o = H.ParentDSL (S.State a i) (Query a i o) (Column.Query' a i o) (Int × i) (Message' a i o) Slam

component
  ∷ ∀ a i o
  . Ord i
  ⇒ Column.ColumnOptions a i o
  → MillerColumnsComponent a i o
component opts@(Column.ColumnOptions colSpec) =
  H.parentComponent
    { initialState: { cycle: 0, widths: L.Nil, columns: _ }
    , render
    , eval
    , receiver: HE.input ChangeRoot
    }
  where

  render ∷ S.State a i → HTML a i o
  render state =
    HH.div
      [ HP.class_ (HH.ClassName "sd-miller-columns")
      , HP.ref containerRef
      ]
      $ join
      $ A.fromFoldable
      $ map (renderColumn state) (S.columnPaths opts state.columns)

  renderColumn ∷ S.State a i → Int × Maybe a × i → Array (HTML a i o)
  renderColumn st@{ cycle } (ix × sel × colPath) =
    [ HH.div
        [ HP.classes $ join
            [ pure $ HH.ClassName "sd-miller-column"
            , guard (ix == L.length (snd st.columns) - 1) $> HH.ClassName "sd-miller-column-last"
            ]
        , ARIA.label "Column"
        ]
        [ HH.slot
            (cycle × colPath)
            (colSpec.renderColumn opts colPath)
            (S.columnWidth st ix × sel)
            (HE.input (HandleMessage ix colPath))
        ]
    , HH.button
        [ HP.class_ (HH.ClassName "sd-miller-column-resizer")
        , HP.type_ HP.ButtonButton
        , HP.tabIndex $ -1  -- unless keyboard support is enabled
        , HE.onMouseDown (HE.input (DragStart ix))
        , ARIA.label "Resize column"
        ]
        []
    ]

  eval ∷ Query a i o ~> DSL a i o
  eval = case _ of
    Populate cols next → do
      H.modify (_ { columns = cols })
      pure next
    ChangeRoot cols@(newRoot × newSelections) next → do
      (root × selections) ← H.gets _.columns
      let
        prefix = L.drop (L.length selections - L.length newSelections) selections
        oldIds = colSpec.id <$> prefix
        newIds = colSpec.id <$> newSelections
      when (root /= newRoot || oldIds /= newIds) $ H.modify (_ { columns = cols })
      pure next
    HandleMessage colIndex colPath msg next → do
      case msg of
        Left Column.Initialized → do
          traverse_ (H.liftEff ∘ scrollToRight) =<< H.getHTMLElementRef containerRef
        Left Column.Deselected → do
          H.modify $ S.modifyColumns $ second \sels →
            L.drop (L.length sels - colIndex) sels
          state ← H.gets _.columns
          root × sel ← pure (second L.head state)
          H.raise $ Left (SelectionChanged state (maybe root colSpec.id sel) sel)
        Left (Column.Selected itemPath item) → do
          H.modify $ S.modifyColumns $ second \sels →
            item : L.drop (L.length sels - colIndex) sels
          state ← H.gets _.columns
          H.raise $ Left (SelectionChanged state itemPath (Just item))
        Left (Column.LoadRequest req) → do
          H.raise $ Left (LoadRequest (colPath × req))
        Right o →
          H.raise (Right o)
      pure next
    Reload next → do
      H.modify \st → st { cycle = st.cycle + 1 }
      pure next
    FulfilLoadRequest (colPath × response) next → do
      cycle ← H.gets _.cycle
      _ ← H.query (cycle × colPath) $ queryQ $ H.action $ Column.FulfilLoadRequest response
      pure next
    DragStart ix ev next → do
      H.liftEff $ DOM.preventDefault ev
      H.modify (S.fixColumnWidths opts)
      colWidth ← H.gets (flip S.columnWidth ix)
      H.subscribe $ Drag.dragEventSource ev \drag →
        Just (DragUpdate ix colWidth drag H.Listening)
      pure next
    DragUpdate ix (Column.ColumnWidth origWidth) de next → do
      case de of
        Drag.Move _ { offsetX } → do
          let newWidth = max Column.minColumnWidth $ Column.ColumnWidth (origWidth + offsetX)
          H.modify (\st → st { widths = fromMaybe st.widths $ L.modifyAt ix (const newWidth) st.widths })
        _ → pure unit
      pure next

scrollToRight ∷ ∀ eff. HTMLElement → Eff (dom ∷ DOM | eff) Unit
scrollToRight el = do
  maxScroll ← (-) <$> DOM.scrollHeight el <*> DOM.offsetHeight el
  DOM.setScrollTop maxScroll el

containerRef ∷ H.RefLabel
containerRef = H.RefLabel "container"

{-
Copyright 2017 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.MillerColumns.Component
  ( MillerColumnsComponent
  , component
  , module SlamData.Workspace.MillerColumns.Component.Query
  , module Exports
  ) where

import SlamData.Prelude

import Control.Monad.Eff (Eff)
import Data.Array as A
import Data.List ((:))
import Data.List as L
import Data.Profunctor.Strong (second)
import DOM (DOM)
import DOM.Classy.Event (preventDefault) as DOM
import DOM.Classy.HTMLElement (offsetHeight, scrollHeight, setScrollTop) as DOM
import DOM.HTML.Types (HTMLElement)
import Halogen as H
import Halogen.Component.Proxy (queryQ)
import Halogen.Component.Utils.Drag as Drag
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.HTML.Properties.ARIA as ARIA
import SlamData.Monad (Slam)
import SlamData.Workspace.MillerColumns.Column.Component (ColumnOptions(..)) as Exports
import SlamData.Workspace.MillerColumns.Column.Component as Column
import SlamData.Workspace.MillerColumns.Column.Component.Request (LoadRequest, LoadResponse) as Exports
import SlamData.Workspace.MillerColumns.Component.Query (Query(..), Message(..), Message')
import SlamData.Workspace.MillerColumns.Component.State as S

type MillerColumnsComponent a i o = H.Component HH.HTML (Query a i o) (S.ColumnsData a i) (Message' a i o) Slam

type HTML a i o = H.ParentHTML (Query a i o) (Column.Query' a i o) (Int × i) Slam
type DSL a i o = H.ParentDSL (S.State a i) (Query a i o) (Column.Query' a i o) (Int × i) (Message' a i o) Slam

component
  ∷ ∀ a i o
  . Ord i
  ⇒ Column.ColumnOptions a i o
  → MillerColumnsComponent a i o
component opts@(Column.ColumnOptions colSpec) =
  H.parentComponent
    { initialState: { cycle: 0, widths: L.Nil, columns: _ }
    , render
    , eval
    , receiver: HE.input ChangeRoot
    }
  where

  render ∷ S.State a i → HTML a i o
  render state =
    HH.div
      [ HP.class_ (HH.ClassName "sd-miller-columns")
      , HP.ref containerRef
      ]
      $ join
      $ A.fromFoldable
      $ map (renderColumn state) (S.columnPaths opts state.columns)

  renderColumn ∷ S.State a i → Int × Maybe a × i → Array (HTML a i o)
  renderColumn st@{ cycle } (ix × sel × colPath) =
    [ HH.div
        [ HP.classes $ join
            [ pure $ HH.ClassName "sd-miller-column"
            , guard (ix == L.length (snd st.columns) - 1) $> HH.ClassName "sd-miller-column-last"
            ]
        , ARIA.label "Column"
        ]
        [ HH.slot
            (cycle × colPath)
            (colSpec.renderColumn opts colPath)
            (S.columnWidth st ix × sel)
            (HE.input (HandleMessage ix colPath))
        ]
    , HH.button
        [ HP.class_ (HH.ClassName "sd-miller-column-resizer")
        , HP.type_ HP.ButtonButton
        , HP.tabIndex -1  -- unless keyboard support is enabled
        , HE.onMouseDown (HE.input (DragStart ix))
        , ARIA.label "Resize column"
        ]
        []
    ]

  eval ∷ Query a i o ~> DSL a i o
  eval = case _ of
    Populate cols next → do
      H.modify (_ { columns = cols })
      pure next
    ChangeRoot cols@(newRoot × newSelections) next → do
      (root × selections) ← H.gets _.columns
      let
        prefix = L.drop (L.length selections - L.length newSelections) selections
        oldIds = colSpec.id <$> prefix
        newIds = colSpec.id <$> newSelections
      when (root /= newRoot || oldIds /= newIds) $ H.modify (_ { columns = cols })
      pure next
    HandleMessage colIndex colPath msg next → do
      case msg of
        Left Column.Initialized → do
          traverse_ (H.liftEff ∘ scrollToRight) =<< H.getHTMLElementRef containerRef
        Left Column.Deselected → do
          H.modify $ S.modifyColumns $ second \sels →
            L.drop (L.length sels - colIndex) sels
          state ← H.gets _.columns
          root × sel ← pure (second L.head state)
          H.raise $ Left (SelectionChanged state (maybe root colSpec.id sel) sel)
        Left (Column.Selected itemPath item) → do
          H.modify $ S.modifyColumns $ second \sels →
            item : L.drop (L.length sels - colIndex) sels
          state ← H.gets _.columns
          H.raise $ Left (SelectionChanged state itemPath (Just item))
        Left (Column.LoadRequest req) → do
          H.raise $ Left (LoadRequest (colPath × req))
        Right o →
          H.raise (Right o)
      pure next
    Reload next → do
      H.modify \st → st { cycle = st.cycle + 1 }
      pure next
    FulfilLoadRequest (colPath × response) next → do
      cycle ← H.gets _.cycle
      _ ← H.query (cycle × colPath) $ queryQ $ H.action $ Column.FulfilLoadRequest response
      pure next
    DragStart ix ev next → do
      H.liftEff $ DOM.preventDefault ev
      H.modify (S.fixColumnWidths opts)
      colWidth ← H.gets (flip S.columnWidth ix)
      H.subscribe $ Drag.dragEventSource ev \drag →
        Just (DragUpdate ix colWidth drag H.Listening)
      pure next
    DragUpdate ix (Column.ColumnWidth origWidth) de next → do
      case de of
        Drag.Move _ { offsetX } → do
          let newWidth = max Column.minColumnWidth $ Column.ColumnWidth (origWidth + offsetX)
          H.modify (\st → st { widths = fromMaybe st.widths $ L.modifyAt ix (const newWidth) st.widths })
        _ → pure unit
      pure next

scrollToRight ∷ ∀ eff. HTMLElement → Eff (dom ∷ DOM | eff) Unit
scrollToRight el = do
  maxScroll ← (-) <$> DOM.scrollHeight el <*> DOM.offsetHeight el
  DOM.setScrollTop maxScroll el

containerRef ∷ H.RefLabel
containerRef = H.RefLabel "container"