Skip to content

Commit 6f4acdc

Browse files
functorafunctora
committed
generic field viewer wip
1 parent 6dc3470 commit 6f4acdc

File tree

12 files changed

+315
-269
lines changed

12 files changed

+315
-269
lines changed

‎ghcjs/lightning-verifier/src/App/Widgets/Bolt11.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -157,7 +157,7 @@ pair x =
157157
newFieldPairId x
158158
. DynamicFieldText
159159

160-
pairs :: [FieldPair DynamicField f] -> [View Action]
160+
pairs :: (Foldable1 f) => [FieldPair DynamicField f] -> [View Action]
161161
pairs raw =
162162
FieldPairs.fieldPairsViewer
163163
FieldPairs.Args

‎ghcjs/miso-widgets/miso-widgets.cabal‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -104,6 +104,8 @@ library
104104
exposed-modules:
105105
Functora.Miso.Css
106106
Functora.Miso.Jsm
107+
Functora.Miso.Jsm.Generic
108+
Functora.Miso.Jsm.Specific
107109
Functora.Miso.Prelude
108110
Functora.Miso.Types
109111
Functora.Miso.Widgets.Assets
@@ -139,6 +141,8 @@ test-suite miso-widgets-test
139141
other-modules:
140142
Functora.Miso.Css
141143
Functora.Miso.Jsm
144+
Functora.Miso.Jsm.Generic
145+
Functora.Miso.Jsm.Specific
142146
Functora.Miso.Prelude
143147
Functora.Miso.Types
144148
Functora.Miso.Widgets.Assets

‎ghcjs/miso-widgets/src/Functora/Miso/Jsm.hs‎

Lines changed: 3 additions & 193 deletions
Original file line numberDiff line numberDiff line change
@@ -1,197 +1,7 @@
11
module Functora.Miso.Jsm
2-
( popupText,
3-
shareText,
4-
addFieldPair,
5-
addAsset,
6-
addPaymentMethod,
7-
moveUp,
8-
moveDown,
9-
removeAt,
10-
duplicateAt,
11-
openBrowserPage,
12-
enterOrEscapeBlur,
13-
insertStorage,
14-
selectStorage,
15-
selectClipboard,
2+
( module X,
163
)
174
where
185

19-
import qualified Data.Generics as Syb
20-
import qualified Data.Text as T
21-
import qualified Data.Text.Lazy.Encoding as TL
22-
import Functora.Miso.Prelude
23-
import Functora.Miso.Types
24-
import Functora.Money (CurrencyCode (..), CurrencyInfo (..))
25-
import qualified Functora.Prelude as Prelude
26-
import qualified Language.Javascript.JSaddle as JS
27-
import qualified Text.URI as URI
28-
import qualified Prelude ((!!))
29-
30-
popupText :: (Show a, Data a) => a -> JSM ()
31-
popupText x =
32-
void
33-
$ JS.global
34-
^. JS.js1 ("popupText" :: MisoString) (inspect x :: MisoString)
35-
36-
shareText :: (Show a, Data a) => a -> model -> JSM model
37-
shareText x st = do
38-
let txt = inspect x
39-
unless (txt == mempty) $ do
40-
prom <- JS.global ^. JS.js1 ("shareText" :: MisoString) txt
41-
success <- JS.function $ \_ _ _ -> popupText @MisoString "Copied!"
42-
failure <- JS.function $ \_ _ _ -> popupText @MisoString "Failed to copy!"
43-
void $ prom ^. JS.js2 ("then" :: MisoString) success failure
44-
pure st
45-
46-
addFieldPair ::
47-
ATraversal' model [FieldPair DynamicField Unique] -> model -> JSM model
48-
addFieldPair optic st = do
49-
item <- newFieldPair mempty $ DynamicFieldText mempty
50-
popupText @MisoString "Added note!"
51-
pure $ st & cloneTraversal optic %~ (<> [item])
52-
53-
addAsset :: ATraversal' model [Asset Unique] -> model -> JSM model
54-
addAsset optic st = do
55-
let cur = CurrencyInfo (CurrencyCode "usd") mempty
56-
item <- newAsset "Price" 0 cur
57-
popupText @MisoString "Added asset!"
58-
pure $ st & cloneTraversal optic %~ (<> [item])
59-
60-
addPaymentMethod ::
61-
ATraversal' model [PaymentMethod Unique] -> model -> JSM model
62-
addPaymentMethod optic st = do
63-
let cur = CurrencyInfo (CurrencyCode "btc") mempty
64-
item <- newPaymentMethod cur $ Just mempty
65-
popupText @MisoString "Added payment!"
66-
pure $ st & cloneTraversal optic %~ (<> [item])
67-
68-
moveUp :: ATraversal' model [item] -> Int -> model -> JSM model
69-
moveUp optic idx st = do
70-
popupText @MisoString $ "Moved #" <> inspect (idx + 1) <> " up!"
71-
pure $ st & cloneTraversal optic %~ swapAt (idx - 1) idx
72-
73-
moveDown :: ATraversal' model [item] -> Int -> model -> JSM model
74-
moveDown optic idx st = do
75-
popupText @MisoString $ "Moved #" <> inspect (idx + 1) <> " down!"
76-
pure $ st & cloneTraversal optic %~ swapAt idx (idx + 1)
77-
78-
removeAt :: ATraversal' model [a] -> Int -> model -> JSM model
79-
removeAt optic idx st = do
80-
popupText @MisoString $ "Removed #" <> inspect (idx + 1) <> "!"
81-
pure $ st & cloneTraversal optic %~ ((>>= uncurry updater) . zip [0 ..])
82-
where
83-
updater loc el =
84-
if loc == idx
85-
then mempty
86-
else [el]
87-
88-
duplicateAt ::
89-
forall model item.
90-
( Data item
91-
) =>
92-
ATraversal' model [item] ->
93-
Int ->
94-
model ->
95-
JSM model
96-
duplicateAt optic idx st = do
97-
duplicator <- newUniqueDuplicator @MisoString
98-
let updater loc el =
99-
if loc == idx
100-
then [el, closed $ duplicator el]
101-
else [el]
102-
popupText @MisoString $ "Duplicated #" <> inspect (idx + 1) <> "!"
103-
pure $ st & cloneTraversal optic %~ ((>>= uncurry updater) . zip [0 ..])
104-
where
105-
closed :: item -> item
106-
closed = Syb.everywhere $ Syb.mkT $ const Closed
107-
108-
swapAt :: Int -> Int -> [a] -> [a]
109-
swapAt i j xs
110-
| i == j = xs
111-
| i < 0 || i >= len = xs
112-
| j < 0 || j >= len = xs
113-
| otherwise = do
114-
(idx, val) <- zip [0 ..] xs
115-
pure
116-
$ if
117-
| idx == i -> jval
118-
| idx == j -> ival
119-
| otherwise -> val
120-
where
121-
len = length xs
122-
ival = xs Prelude.!! i
123-
jval = xs Prelude.!! j
124-
125-
openBrowserPage :: URI -> model -> JSM model
126-
openBrowserPage uri st = do
127-
void $ JS.global ^. JS.js1 @MisoString "openBrowserPage" (URI.render uri)
128-
pure st
129-
130-
enterOrEscapeBlur :: Uid -> KeyCode -> model -> JSM model
131-
enterOrEscapeBlur uid (KeyCode code) st = do
132-
let enterOrEscape = [13, 27] :: [Int]
133-
when (code `elem` enterOrEscape)
134-
. void
135-
. JS.eval @MisoString
136-
$ "document.getElementById('"
137-
<> htmlUid uid
138-
<> "').getElementsByTagName('input')[0].blur();"
139-
pure st
140-
141-
insertStorage :: (ToJSON a) => MisoString -> a -> JSM ()
142-
insertStorage key raw = do
143-
val <-
144-
either throw (pure . toMisoString)
145-
. TL.decodeUtf8'
146-
. unTagged
147-
$ encodeJson raw
148-
void
149-
$ JS.global
150-
^. JS.js2 @MisoString "insertStorage" key val
151-
152-
selectStorage :: (FromJSON a) => MisoString -> (Maybe a -> JSM ()) -> JSM ()
153-
selectStorage key after = do
154-
success <- JS.function $ \_ _ ->
155-
handleAny (\e -> consoleLog e >> after Nothing) . \case
156-
[val] -> do
157-
valExist <- ghcjsPure $ JS.isTruthy val
158-
if not valExist
159-
then after Nothing
160-
else do
161-
raw <- JS.fromJSVal @Prelude.Text val
162-
str <- maybe (throwString @MisoString "Storage bad type!") pure raw
163-
res <- either throwString pure $ decodeJson str
164-
after $ Just res
165-
_ ->
166-
throwString @MisoString "Storage bad argv!"
167-
failure <-
168-
JS.function $ \_ _ _ -> consoleLog @MisoString "Storage reader failure!"
169-
prom <-
170-
JS.global ^. JS.js1 @MisoString "selectStorage" key
171-
void
172-
$ prom
173-
^. JS.js2 @MisoString "then" success failure
174-
175-
selectClipboard :: (Maybe MisoString -> JSM ()) -> JSM ()
176-
selectClipboard after = do
177-
success <- JS.function $ \_ _ ->
178-
handleAny (\e -> consoleLog e >> after Nothing) . \case
179-
[val] -> do
180-
valExist <- ghcjsPure $ JS.isTruthy val
181-
if not valExist
182-
then after Nothing
183-
else do
184-
raw <- JS.fromJSVal @Prelude.Text val
185-
str <- maybe (throwString @MisoString "Clipboard bad type!") pure raw
186-
popupText @MisoString "Inserted!"
187-
after . Just . from @Prelude.Text @MisoString $ T.strip str
188-
_ ->
189-
throwString @MisoString "Clipboard bad argv!"
190-
failure <-
191-
JS.function $ \_ _ _ ->
192-
popupText @MisoString "Failed to paste!"
193-
prom <-
194-
JS.global ^. JS.js0 @MisoString "selectClipboard"
195-
void
196-
$ prom
197-
^. JS.js2 @MisoString "then" success failure
6+
import Functora.Miso.Jsm.Generic as X
7+
import Functora.Miso.Jsm.Specific as X

‎ghcjs/miso-widgets/src/Functora/Miso/Jsm/Generic.hs‎

Lines changed: 148 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,148 @@
1+
module Functora.Miso.Jsm.Generic
2+
( popupText,
3+
shareText,
4+
moveUp,
5+
moveDown,
6+
removeAt,
7+
openBrowserPage,
8+
enterOrEscapeBlur,
9+
insertStorage,
10+
selectStorage,
11+
selectClipboard,
12+
)
13+
where
14+
15+
import qualified Data.Text as T
16+
import qualified Data.Text.Lazy.Encoding as TL
17+
import Functora.Miso.Prelude
18+
import qualified Functora.Prelude as Prelude
19+
import qualified Language.Javascript.JSaddle as JS
20+
import qualified Text.URI as URI
21+
import qualified Prelude ((!!))
22+
23+
popupText :: (Show a, Data a) => a -> JSM ()
24+
popupText x =
25+
void
26+
$ JS.global
27+
^. JS.js1 ("popupText" :: MisoString) (inspect x :: MisoString)
28+
29+
shareText :: (Show a, Data a) => a -> model -> JSM model
30+
shareText x st = do
31+
let txt = inspect x
32+
unless (txt == mempty) $ do
33+
prom <- JS.global ^. JS.js1 ("shareText" :: MisoString) txt
34+
success <- JS.function $ \_ _ _ -> popupText @MisoString "Copied!"
35+
failure <- JS.function $ \_ _ _ -> popupText @MisoString "Failed to copy!"
36+
void $ prom ^. JS.js2 ("then" :: MisoString) success failure
37+
pure st
38+
39+
moveUp :: ATraversal' model [item] -> Int -> model -> JSM model
40+
moveUp optic idx st = do
41+
popupText @MisoString $ "Moved #" <> inspect (idx + 1) <> " up!"
42+
pure $ st & cloneTraversal optic %~ swapAt (idx - 1) idx
43+
44+
moveDown :: ATraversal' model [item] -> Int -> model -> JSM model
45+
moveDown optic idx st = do
46+
popupText @MisoString $ "Moved #" <> inspect (idx + 1) <> " down!"
47+
pure $ st & cloneTraversal optic %~ swapAt idx (idx + 1)
48+
49+
removeAt :: ATraversal' model [a] -> Int -> model -> JSM model
50+
removeAt optic idx st = do
51+
popupText @MisoString $ "Removed #" <> inspect (idx + 1) <> "!"
52+
pure $ st & cloneTraversal optic %~ ((>>= uncurry updater) . zip [0 ..])
53+
where
54+
updater loc el =
55+
if loc == idx
56+
then mempty
57+
else [el]
58+
59+
swapAt :: Int -> Int -> [a] -> [a]
60+
swapAt i j xs
61+
| i == j = xs
62+
| i < 0 || i >= len = xs
63+
| j < 0 || j >= len = xs
64+
| otherwise = do
65+
(idx, val) <- zip [0 ..] xs
66+
pure
67+
$ if
68+
| idx == i -> jval
69+
| idx == j -> ival
70+
| otherwise -> val
71+
where
72+
len = length xs
73+
ival = xs Prelude.!! i
74+
jval = xs Prelude.!! j
75+
76+
openBrowserPage :: URI -> model -> JSM model
77+
openBrowserPage uri st = do
78+
void $ JS.global ^. JS.js1 @MisoString "openBrowserPage" (URI.render uri)
79+
pure st
80+
81+
enterOrEscapeBlur :: Uid -> KeyCode -> model -> JSM model
82+
enterOrEscapeBlur uid (KeyCode code) st = do
83+
let enterOrEscape = [13, 27] :: [Int]
84+
when (code `elem` enterOrEscape)
85+
. void
86+
. JS.eval @MisoString
87+
$ "document.getElementById('"
88+
<> htmlUid uid
89+
<> "').getElementsByTagName('input')[0].blur();"
90+
pure st
91+
92+
insertStorage :: (ToJSON a) => MisoString -> a -> JSM ()
93+
insertStorage key raw = do
94+
val <-
95+
either throw (pure . toMisoString)
96+
. TL.decodeUtf8'
97+
. unTagged
98+
$ encodeJson raw
99+
void
100+
$ JS.global
101+
^. JS.js2 @MisoString "insertStorage" key val
102+
103+
selectStorage :: (FromJSON a) => MisoString -> (Maybe a -> JSM ()) -> JSM ()
104+
selectStorage key after = do
105+
success <- JS.function $ \_ _ ->
106+
handleAny (\e -> consoleLog e >> after Nothing) . \case
107+
[val] -> do
108+
valExist <- ghcjsPure $ JS.isTruthy val
109+
if not valExist
110+
then after Nothing
111+
else do
112+
raw <- JS.fromJSVal @Prelude.Text val
113+
str <- maybe (throwString @MisoString "Storage bad type!") pure raw
114+
res <- either throwString pure $ decodeJson str
115+
after $ Just res
116+
_ ->
117+
throwString @MisoString "Storage bad argv!"
118+
failure <-
119+
JS.function $ \_ _ _ -> consoleLog @MisoString "Storage reader failure!"
120+
prom <-
121+
JS.global ^. JS.js1 @MisoString "selectStorage" key
122+
void
123+
$ prom
124+
^. JS.js2 @MisoString "then" success failure
125+
126+
selectClipboard :: (Maybe MisoString -> JSM ()) -> JSM ()
127+
selectClipboard after = do
128+
success <- JS.function $ \_ _ ->
129+
handleAny (\e -> consoleLog e >> after Nothing) . \case
130+
[val] -> do
131+
valExist <- ghcjsPure $ JS.isTruthy val
132+
if not valExist
133+
then after Nothing
134+
else do
135+
raw <- JS.fromJSVal @Prelude.Text val
136+
str <- maybe (throwString @MisoString "Clipboard bad type!") pure raw
137+
popupText @MisoString "Inserted!"
138+
after . Just . from @Prelude.Text @MisoString $ T.strip str
139+
_ ->
140+
throwString @MisoString "Clipboard bad argv!"
141+
failure <-
142+
JS.function $ \_ _ _ ->
143+
popupText @MisoString "Failed to paste!"
144+
prom <-
145+
JS.global ^. JS.js0 @MisoString "selectClipboard"
146+
void
147+
$ prom
148+
^. JS.js2 @MisoString "then" success failure

0 commit comments

Comments
 (0)