{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Glazier.React.Widgets.Collection
( HKD
, UKey
, zeroUKey
, smallerUKey
, largerUKey
, betweenUKey
, Collection
, HKCollection
, collectionWindow
, deleteCollectionItem
, insertCollectionItem
) where
import Control.Lens
import Data.Foldable
import qualified Data.Map.Strict as M
import qualified GHC.Generics as G
import Glazier.React
import qualified JavaScript.Extras as JE
type family HKD f a where
HKD Identity a = a
HKD f a = f a
newtype UKey = UKey { unUKey :: [Int] }
deriving (G.Generic, Show)
instance Ord UKey where
compare (UKey []) (UKey []) = EQ
compare (UKey xs) (UKey []) = compare (UKey xs) (UKey [0])
compare (UKey []) (UKey ys) = compare (UKey [0]) (UKey ys)
compare (UKey (x : xs)) (UKey (y : ys)) = case compare x y of
EQ -> compare (UKey xs) (UKey ys)
o -> o
instance Eq UKey where
(UKey []) == (UKey []) = True
(UKey xs) == (UKey []) = (UKey xs) == (UKey [0])
(UKey []) == (UKey ys) = (UKey [0]) == (UKey ys)
(UKey (x : xs)) == (UKey (y : ys)) = if x == y
then (UKey xs) == (UKey ys)
else False
zeroUKey :: UKey
zeroUKey = UKey []
ukeyStep :: Int
ukeyStep = 32
smallerUKey :: UKey -> UKey
smallerUKey (UKey []) = UKey [-ukeyStep]
smallerUKey (UKey (a : as)) = UKey $ case compare a (JE.minSafeInteger + ukeyStep) of
LT -> if JE.minSafeInteger == a
then JE.minSafeInteger : unUKey (smallerUKey (UKey as))
else [JE.minSafeInteger]
_ -> [a - ukeyStep]
largerUKey :: UKey -> UKey
largerUKey (UKey []) = UKey [ukeyStep]
largerUKey (UKey (a : as)) = UKey $ case compare a (JE.maxSafeInteger - ukeyStep) of
GT -> if JE.maxSafeInteger == a
then JE.maxSafeInteger : unUKey (largerUKey (UKey as))
else [JE.maxSafeInteger]
_ -> [a + ukeyStep]
betweenUKey :: UKey -> UKey -> UKey
betweenUKey (UKey []) (UKey []) = zeroUKey
betweenUKey (UKey xs) (UKey []) = betweenUKey (UKey xs) (UKey [0])
betweenUKey (UKey []) (UKey ys) = betweenUKey (UKey [0]) (UKey ys)
betweenUKey (UKey (x : xs)) (UKey (y : ys)) = UKey $ case compare x y of
LT -> if x + 1 == y
then x : unUKey (betweenUKey (UKey xs) (UKey $ repeat JE.maxSafeInteger))
else [betweenUncInt x y]
GT -> if y + 1 == x
then y : unUKey (betweenUKey (UKey ys) (UKey $ repeat JE.maxSafeInteger))
else [betweenUncInt x y]
EQ -> x : unUKey (betweenUKey (UKey xs) (UKey ys))
betweenUncInt :: Int -> Int -> Int
betweenUncInt x y =
let (xq, xr) = quotRem x 2
(yq, yr) = quotRem y 2
z = case (xr + yr) of
2 -> 1
_ -> 0
in xq + yq + z
type Collection t s f = t (HKD f s)
type HKCollection t s f = t (HKD f (s f))
collectionWindow :: (Functor t, Foldable t)
=> ReactId -> Window (t (Subject s)) ()
collectionWindow ri = do
ss <- view _model
let displayItem s = Als $ (displaySubject s)
bh "ul" [("key", JE.toJSR $ ri)] (getAls (fold $ displayItem <$> ss))
deleteCollectionItem :: (MonadReactor p allS cmd m, Ord k)
=> k -> ModelState (M.Map k (Subject s)) (m ())
deleteCollectionItem k = do
old <- use (id.at k)
(at k) .= Nothing
pure $ maybe (pure ()) bookSubjectCleanup old
insertCollectionItem :: (MonadReactor p allS cmd m, Ord k)
=> k -> Subject s -> ModelState (M.Map k (Subject s)) (m ())
insertCollectionItem k sbj = do
old <- use (at k)
(at k) .= Just sbj
pure $ maybe (pure ()) bookSubjectCleanup old