split/ValidDynamic.hs at main · tellary/split · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -Wno-missing-signatures -Wno-unused-top-binds #-}
{-# OPTIONS_GHC -Wno-name-shadowing -Wno-unused-do-bind #-}

module ValidDynamic where

import Control.Monad              (join)
import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT)
import Reflex.Dom

type ValidDynamic t err a = ExceptT err (Dynamic t) a

traceEnabled = False

traceEventIfEnabled :: (Show a, Reflex t) => String -> Event t a -> Event t a
traceEventIfEnabled = if traceEnabled then traceEvent else flip const

fromDynamic
  :: Reflex t
  => Dynamic t a -> (a -> Either err b) -> ValidDynamic t err b
fromDynamic d validation = ExceptT . fmap validation $ d

fromDynamicEither
  :: Reflex t
  => Dynamic t (Either err a) -> ValidDynamic t err a
fromDynamicEither d = ExceptT d

fromEvent
  :: (Reflex t, MonadHold t m)
  => a -> Event t a -> (a -> Either err b) -> m (ValidDynamic t err b)
fromEvent initVal ev validation = do
  d <- holdDyn initVal ev
  return $ fromDynamic d validation

fromValue :: Reflex t => a -> (a -> Either err b) -> ValidDynamic t err b
fromValue a validation = ExceptT . fmap validation . pure $ a

assumeValidDynamic :: Reflex t => Dynamic t a -> ValidDynamic t err a
assumeValidDynamic = ExceptT . fmap Right

assumeValidValue :: Reflex t => a -> ValidDynamic t err a
assumeValidValue = ExceptT . fmap Right . pure

maybeValidValue = either (const Nothing) Just

tagValid
  :: (Show a, Show err, Reflex t)
  => ValidDynamic t err a -> Event t b -> Event t a
tagValid (ExceptT validInput) submitEvent
  = mapMaybe maybeValidValue
  . traceEventIfEnabled "tagValid"
  . (tag . current) validInput
  $ submitEvent

tagPromptlyValid
  :: (Show a, Show err, Reflex t)
  => ValidDynamic t err a -> Event t b -> Event t a
tagPromptlyValid (ExceptT validInput) submitEvent
  = mapMaybe maybeValidValue
  . traceEventIfEnabled "tagValid"
  . tagPromptlyDyn validInput
  $ submitEvent

errorDyn
  :: (Reflex t, MonadHold t m)
  => err -> Event t a -> ValidDynamic t err b -> m (Dynamic t err)
errorDyn noErrorVal submitEvent (ExceptT validDynamic) = do
  let error = fmap (either id (const noErrorVal)) validDynamic
  holdDyn noErrorVal
    ( tagPromptlyDyn error
      ( leftmost [() <$ submitEvent, () <$ updated validDynamic] )
    )

errorWidget
  :: forall t m a b c err . (Reflex t, Adjustable t m, MonadHold t m)
  => Event t b -> ValidDynamic t err a -> m c -> (err -> m c) -> m (Dynamic t c)
errorWidget
    submitEvent
    (ExceptT validDynamic)
    noErrorWidget errorWidget = do
  let error :: Dynamic t (m c) = fmap (either errorWidget (const noErrorWidget)) validDynamic
  widgetHold
    noErrorWidget
    ( tagPromptlyDyn error
       ( leftmost [() <$ submitEvent, () <$ updated validDynamic] )
    )

unwrapValidDynamicWidget :: (DomBuilder t m, MonadHold t m, PostBuild t m)
  => a -> Dynamic t (m (ValidDynamic t err a)) -> m (ValidDynamic t err a)
unwrapValidDynamicWidget initVal dynWidget
  = fmap (ExceptT . join . fmap runExceptT)
    (holdDyn (assumeValidValue initVal) =<< dyn dynWidget)

dynamicValidDynamic
  :: (Reflex t, Applicative m)
  => ValidDynamic t err (m (Dynamic t a))
  -> Dynamic t (m (ValidDynamic t err a))
dynamicValidDynamic dynWidget
  = ffor (runExceptT dynWidget) $ \case
      Right dynWidget -> fmap (ExceptT . fmap Right) dynWidget
      Left err -> pure . ExceptT . pure . Left $ err

unwrapValidDynamicDynamicWidget
  :: (DomBuilder t m, MonadHold t m, PostBuild t m)
  => a -> ValidDynamic t err (m (Dynamic t a)) -> m (ValidDynamic t err a)
unwrapValidDynamicDynamicWidget initVal dynWidget
  = unwrapValidDynamicWidget initVal . dynamicValidDynamic $ dynWidget

dropE :: (Reflex t, MonadHold t m) => Int -> Event t a -> m (Event t a)
dropE 0     e = return e
dropE count e = do
  skipped <- tailE e
  dropE (count - 1) skipped

dropValidDynamic
  :: (Reflex t, MonadHold t m)
  => Event t b -> Either err a
  -> Int -> ValidDynamic t err a
  -> m (ValidDynamic t err a)
dropValidDynamic submitEvent initVal count validDyn
  = fmap
    ExceptT
    ( holdDyn initVal =<< (
        dropE count
        . leftmost
        $ [ updated d
          , tagPromptlyDyn d submitEvent
          ]
        )
    )
  where d = runExceptT validDyn