379c6ea · typeable/octopod

git.iko.soy/typeable/octopod

on master help sign in

Quality of life frontend improvements (#169)

379c6eaiko4 years ago

.vscode/settings.json+2−1

compare with master

unifiedsplit

@@ -3,5 +3,6 @@

3 "haskell.formattingProvider": "fourmolu",

4 "haskell.plugin.hlint.diagnosticsOn": false,

5 "haskell.hlint.logLevel": "none",

6− "haskell.hlint.run": "never"

6+ "haskell.hlint.run": "never",

7+ "haskell.serverExecutablePath": "haskell-language-server"

dev/default.nix+2

@@ -116,6 +116,8 @@ in

116

117 sleep 4

118

119+ echo "foo.vat1.fjij.key1,"

120+

119 for i in {1..10}

121 for i in {1..10}

120 do

122 do

121 for j in {1..10}

123 for j in {1..10}

octopod-frontend/src/Data/WorkingOverrides.hs+13−3

@@ -1,6 +1,7 @@

1module Data.WorkingOverrides

2 ( WorkingOverrides,

3 WorkingOverrideKey' (..),

4+ getConfigValueText,

4 WorkingOverrideKey,

5 WorkingOverrideKey,

5 WorkingOverrideKeyType (..),

6 WorkingOverrideKeyType (..),

6 destructWorkingOverrides,

7 destructWorkingOverrides,

@@ -42,29 +43,38 @@ data ConfigValue te

43newtype CustomKey v = CustomKey v

44newtype CustomKey v = CustomKey v

44 deriving stock (Show, Generic, Eq, Ord)

45 deriving stock (Show, Generic, Eq, Ord)

46+

45data CustomConfigValue te

47data CustomConfigValue te

46 = CustomValue !te

48 = CustomValue !te

47 | DeletedValue !(Maybe te)

49 | DeletedValue !(Maybe te)

48 deriving stock (Show, Generic, Eq, Ord)

50 deriving stock (Show, Generic, Eq, Ord)

52+getConfigValueText :: ConfigValue te -> Maybe te

53+getConfigValueText (DefaultConfigValue t) = Just t

54+getConfigValueText (CustomConfigValue (Left (CustomKey t))) = Just t

55+getConfigValueText (CustomConfigValue (Right (CustomValue t))) = Just t

56+getConfigValueText (CustomConfigValue (Right (DeletedValue t))) = t

57+

50-- Super inefficient but i dont care

58-- Super inefficient but i dont care

51configTreeHasLeaf ::

59configTreeHasLeaf ::

52 forall m kv te.

60 forall m kv te.

53− ( MonadReader (Ref m (Map (ConfigTree kv te) Bool)) m

61+ ( MonadReader (Ref m (Map (Text, ConfigTree kv te) Bool)) m

54 , MonadRef m

62 , MonadRef m

55 , Ord kv

63 , Ord kv

56 , Ord te

64 , Ord te

57 ) =>

65 ) =>

66+ -- | The id of the predicate used for caching

67+ Text ->

58 (te -> Bool) ->

68 (te -> Bool) ->

59 ConfigTree kv te ->

69 ConfigTree kv te ->

60 m Bool

70 m Bool

61−configTreeHasLeaf f = memo $ \(CT.ConfigTree x) -> go $ toList x

71+configTreeHasLeaf name f = memo (\(_, CT.ConfigTree x) -> go $ toList x) . (name,)

62 where

72 where

63 go :: [(Maybe te, ConfigTree kv te)] -> m Bool

73 go :: [(Maybe te, ConfigTree kv te)] -> m Bool

64 go [] = pure False

74 go [] = pure False

65 go ((Just y, _) : _) | f y = pure True

75 go ((Just y, _) : _) | f y = pure True

66 go ((_, ct) : rest) =

76 go ((_, ct) : rest) =

67− configTreeHasLeaf f ct >>= \case

77+ configTreeHasLeaf name f ct >>= \case

68 True -> pure True

78 True -> pure True

69 False -> go rest

79 False -> go rest

octopod-frontend/src/Frontend/UIKit.hs+13−6

@@ -377,6 +377,7 @@ showNonEditableWorkingOverrideTree treeDyn = do

377 untilReady (lift nonEditableLoading) $

378 divClass "padded" $

379 showWorkingOverrideTree'

380+ (const False)

380 (is (_Ctor' @"CustomConfigValue"))

381 (is (_Ctor' @"CustomConfigValue"))

381 (\_ _ -> ())

382 (\_ _ -> ())

382 (\_ k v -> renderRow k v $> pure ())

383 (\_ k v -> renderRow k v $> pure ())

@@ -400,6 +401,8 @@ showOverrideTree ::

400 , Ord tk

401 , Ord tk

401 , Ord tv

402 , Ord tv

402 ) =>

403 ) =>

404+ -- | Value should be shown by default

405+ (tv -> Bool) ->

403 -- | Value is modified

406 -- | Value is modified

404 (tv -> Bool) ->

407 (tv -> Bool) ->

405 -- | Prepare the fixpoint data

408 -- | Prepare the fixpoint data

@@ -409,19 +412,21 @@ showOverrideTree ::

409 ConfigTree tk tv ->

412 ConfigTree tk tv ->

410 -- | Should we render anything

413 -- | Should we render anything

411 m [Dynamic t x]

414 m [Dynamic t x]

412−showOverrideTree isModified prepareData renderValue ct = do

415+showOverrideTree isShown isModified prepareData renderValue ct = do

413 memoRef <- newRef mempty

416 memoRef <- newRef mempty

414 flip runReaderT memoRef $

417 flip runReaderT memoRef $

415− showWorkingOverrideTree' isModified prepareData ((fmap . fmap . fmap) lift renderValue) ct (pure True) never

418+ showWorkingOverrideTree' isShown isModified prepareData ((fmap . fmap . fmap) lift renderValue) ct (pure True) never

416

419

417showWorkingOverrideTree' ::

420showWorkingOverrideTree' ::

418 ( MonadWidget t m

421 ( MonadWidget t m

419 , Renderable tk

422 , Renderable tk

420 , Show x

423 , Show x

421− , MonadReader (Ref m (Map (ConfigTree tk tv) Bool)) m

424+ , MonadReader (Ref m (Map (Text, ConfigTree tk tv) Bool)) m

422 , Ord tv

425 , Ord tv

423 , Ord tk

426 , Ord tk

424 ) =>

427 ) =>

428+ -- | Value should be shown by default

429+ (tv -> Bool) ->

425 -- | Value is modified

430 -- | Value is modified

426 (tv -> Bool) ->

431 (tv -> Bool) ->

427 -- | Prepare the fixpoint data

432 -- | Prepare the fixpoint data

@@ -434,7 +439,7 @@ showWorkingOverrideTree' ::

434 -- | Force open/close all subtrees

439 -- | Force open/close all subtrees

435 Event t Bool ->

440 Event t Bool ->

436 m [Dynamic t x]

441 m [Dynamic t x]

437−showWorkingOverrideTree' isModified prepareData renderValue (ConfigTree m) shouldRenderDyn' forceSubtreesEv = do

442+showWorkingOverrideTree' isShown isModified prepareData renderValue (ConfigTree m) shouldRenderDyn' forceSubtreesEv = do

438 shouldRenderDyn <- holdUniqDyn shouldRenderDyn'

443 shouldRenderDyn <- holdUniqDyn shouldRenderDyn'

439 (appEndo . fold -> f) <- for (OM.assocs m) $ \(k, (mv, _)) -> do

444 (appEndo . fold -> f) <- for (OM.assocs m) $ \(k, (mv, _)) -> do

440 xMaybe <- for mv $ \v -> mdo

445 xMaybe <- for mv $ \v -> mdo

@@ -462,7 +467,8 @@ showWorkingOverrideTree' isModified prepareData renderValue (ConfigTree m) shoul

462 then "collapse--expanded"

467 then "collapse--expanded"

463 else mempty

468 else mempty

464 (ovs, openDyn) <- elDynClass "div" wrapperClass $ do

469 (ovs, openDyn) <- elDynClass "div" wrapperClass $ do

465− modified <- configTreeHasLeaf isModified subtree

470+ modified <- configTreeHasLeaf "isModified" isModified subtree

471+ shown <- configTreeHasLeaf "isShown" isShown subtree

466 (traceEvent "clickEv" -> clickEv) <-

472 (traceEvent "clickEv" -> clickEv) <-

467 treeButton

473 treeButton

468 TreeButtonConfig

474 TreeButtonConfig

@@ -471,11 +477,12 @@ showWorkingOverrideTree' isModified prepareData renderValue (ConfigTree m) shoul

471 , visible = shouldRenderDyn

477 , visible = shouldRenderDyn

472 , forceState = forceSubtreesEv

478 , forceState = forceSubtreesEv

473 }

479 }

474− buttonIsOpen <- holdDyn False $ leftmost [forceSubtreesEv, fst <$> clickEv]

480+ buttonIsOpen <- holdDyn shown $ leftmost [forceSubtreesEv, fst <$> clickEv]

475 let selfForceSubtrees = fst <$> ffilter (isRight . snd) clickEv

481 let selfForceSubtrees = fst <$> ffilter (isRight . snd) clickEv

476 ovs' <-

482 ovs' <-

477 divClass "collapse__inner" $

483 divClass "collapse__inner" $

478 showWorkingOverrideTree'

484 showWorkingOverrideTree'

485+ isShown

479 isModified

486 isModified

480 prepareData

487 prepareData

481 renderValue

488 renderValue

octopod-frontend/src/Frontend/UIKit/Button/Common.hs+2−2

@@ -77,7 +77,7 @@ buttonEl cfg = do

77 ( const

78 EventFlags

79 { _eventFlags_propagation = Propagation_StopImmediate

80− , _eventFlags_preventDefault = True

80+ , _eventFlags_preventDefault = False

81 }

82 )

83 & elementConfig_eventSpec

@@ -87,7 +87,7 @@ buttonEl cfg = do

87 ( const

88 EventFlags

89 { _eventFlags_propagation = Propagation_StopImmediate

90− , _eventFlags_preventDefault = True

90+ , _eventFlags_preventDefault = False

91 }

92 )

93 (bEl, _) <- element t elCfg (unTextBuilder (cfg ^. #buttonText))

octopod-frontend/src/Frontend/Utils.hs+1−29

@@ -431,6 +431,7 @@ envVarsInput (traceDyn "values" -> values) lookupOverride ovs = divClass "padded

431 envVarInput lookupOverride values emptyItem

432 treeResCfg <-

433 showOverrideTree

434+ ((== Just True) . fmap (T.null . T.strip) . getConfigValueText . snd)

434 (isn't (_Ctor' @"DefaultConfigValue") . snd)

435 (isn't (_Ctor' @"DefaultConfigValue") . snd)

435 (\_ v -> v)

436 (\_ v -> v)

436 (\a _ _ -> envVarInput lookupOverride values (trace "a" a))

437 (\a _ _ -> envVarInput lookupOverride values (trace "a" a))

@@ -440,35 +441,6 @@ envVarsInput (traceDyn "values" -> values) lookupOverride ovs = divClass "padded

440 addingIsEnabled = join $ fmap and . sequenceA . (fmap . fmap) (not . T.null . fst) <$> resCfg

441 addingIsEnabled = join $ fmap and . sequenceA . (fmap . fmap) (not . T.null . fst) <$> resCfg

441 pure resCfg

442 pure resCfg

442

443

443−-- validateWorkingOverrides ::

444−-- forall f.

445−-- Traversable f =>

446−-- f WorkingOverride ->

447−-- f (WorkingOverride, OverrideErrors)

448−-- validateWorkingOverrides overrides =

449−-- let (result, keyOccurrences :: MonoidalMap Text (Sum Int)) =

450−-- flip runState mempty $ for overrides \override@(WorkingOverrideKey _ key, value') -> do

451−-- case value' of

452−-- WorkingDeletedValue _ -> pure ()

453−-- _ -> modify (<> MM.singleton key (Sum 1))

454−-- pure . (override,) . mconcat $

455−-- [ case MM.lookup key keyOccurrences of

456−-- Just (Sum n)

457−-- | n > 1 ->

458−-- overrideKeyErrors "You can not use the same key multiple times."

459−-- _ -> mempty

460−-- , if T.null key

461−-- then overrideKeyErrors "Keys can not be empty."

462−-- else mempty

463−-- , case value' of

464−-- WorkingCustomValue "" -> overrideValueErrors "Values can not be empty."

465−-- WorkingCustomValue _ -> mempty

466−-- WorkingDefaultValue "" -> overrideValueErrors "Values can not be empty."

467−-- WorkingDefaultValue _ -> mempty

468−-- WorkingDeletedValue _ -> mempty

469−-- ]

470−-- in result

471−

472-- | Widget for entering a key-value pair.

444-- | Widget for entering a key-value pair.

473envVarInput ::

445envVarInput ::

474 (MonadWidget t m) =>

446 (MonadWidget t m) =>