Skip to content

Commit d59dfb5

Browse files
functorafunctora
committed
FieldTypeImage wip
1 parent 91354de commit d59dfb5

File tree

4 files changed

+113
-63
lines changed

4 files changed

+113
-63
lines changed

‎ghcjs/delivery-calculator/src/App/Types.hs‎

Lines changed: 16 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -163,7 +163,11 @@ newAsset = do
163163
newFieldPair "Link"
164164
$ DynamicFieldText "https://bitcoin.org/en/"
165165
photo <-
166-
newFieldPair "Photo"
166+
fmap
167+
( (#fieldPairValue . #fieldOpts . #fieldOptsTruncateLimit .~ Nothing)
168+
. (#fieldPairValue . #fieldType .~ FieldTypeImage)
169+
)
170+
. newFieldPair "Photo"
167171
$ DynamicFieldText "https://bitcoin.org/img/home/bitcoin-img.svg?1725887272"
168172
price <-
169173
newFieldPair "Price" $ DynamicFieldNumber 10
@@ -223,7 +227,17 @@ stUri st = do
223227
uri <- mkURI $ from @Unicode @Prelude.Text baseUri
224228
qxs <-
225229
stQuery
226-
. Syb.everywhere (Syb.mkT $ Field.truncateDynamicField Nothing)
230+
. Syb.everywhere
231+
( Syb.mkT $ \x ->
232+
if x ^. #fieldType /= FieldTypeImage
233+
then x :: Field DynamicField Identity
234+
else
235+
x
236+
& #fieldInput
237+
.~ mempty
238+
& #fieldOutput
239+
.~ DynamicFieldText mempty
240+
)
227241
. uniqueToIdentity
228242
$ st
229243
^. #modelState

‎ghcjs/miso-functora/lib/miso-functora/post-theme.css‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -68,6 +68,7 @@ dialog {
6868
margin: 0 auto !important;
6969
padding: 1rem !important;
7070
z-index: 9999 !important;
71+
border-radius: 0 !important;
7172
display: initial;
7273
position: initial;
7374
transform: initial;

‎ghcjs/miso-functora/src/Functora/Miso/Types.hs‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -273,6 +273,8 @@ data FieldType
273273
| FieldTypeQrCode
274274
| FieldTypeHtml
275275
| FieldTypePassword
276+
| -- Binary
277+
FieldTypeImage
276278
deriving stock (Eq, Ord, Show, Read, Enum, Bounded, Data, Generic)
277279
deriving (Binary) via GenericType FieldType
278280

@@ -285,6 +287,7 @@ htmlFieldType = \case
285287
FieldTypeQrCode -> "text"
286288
FieldTypeHtml -> "text"
287289
FieldTypePassword -> "password"
290+
FieldTypeImage -> "image"
288291

289292
userFieldType :: FieldType -> Unicode
290293
userFieldType = \case
@@ -295,6 +298,7 @@ userFieldType = \case
295298
FieldTypeQrCode -> "QR code"
296299
FieldTypeHtml -> "HTML"
297300
FieldTypePassword -> "Password"
301+
FieldTypeImage -> "Image"
298302

299303
data FieldPair a f = FieldPair
300304
{ fieldPairKey :: Field Unicode f,

‎ghcjs/miso-functora/src/Functora/Miso/Widgets/Field.hs‎

Lines changed: 92 additions & 61 deletions
Original file line numberDiff line numberDiff line change
@@ -7,7 +7,6 @@ module Functora.Miso.Widgets.Field
77
OptsWidgetPair (..),
88
ModalWidget' (..),
99
truncateUnicode,
10-
truncateDynamicField,
1110
expandDynamicField,
1211
field,
1312
ratioField,
@@ -152,33 +151,64 @@ field full@Full {fullArgs = args, fullParser = parser, fullViewer = viewer} opts
152151
. (br_ mempty :)
153152
)
154153
(optsLabel opts)
155-
( [ input_
156-
$ ( catMaybes
157-
[ fmap
158-
(type_ . htmlFieldType)
159-
(st ^? cloneTraversal optic . #fieldType),
160-
fmap
161-
(textProp "defaultValue")
162-
(st ^? cloneTraversal optic . #fieldInput . #uniqueValue),
163-
Just $ onInput onInputAction,
164-
Just . disabled_ $ opts ^. #optsDisabled,
165-
fmap placeholder_
166-
$ if null placeholder
167-
then optsLabel opts
168-
else Just placeholder,
169-
Just
170-
. id_
171-
. either impureThrow id
172-
. decodeUtf8Strict
173-
. unTagged
174-
$ htmlUid uid,
175-
Just . onKeyDown $ action . optsOnKeyDownAction opts uid,
176-
Just $ onBlur onBlurAction
177-
]
178-
)
179-
<> ( opts ^. #optsExtraAttributes
180-
)
181-
]
154+
( ( if typ == FieldTypeImage
155+
then
156+
join
157+
. maybeToList
158+
$ fmap
159+
( \src ->
160+
if null src
161+
then mempty
162+
else
163+
[ img_ (src_ src : optsExtraAttributes opts),
164+
br_ mempty
165+
]
166+
)
167+
$ st
168+
^? cloneTraversal
169+
optic
170+
. #fieldInput
171+
. #uniqueValue
172+
else
173+
singleton
174+
. input_
175+
$ ( catMaybes
176+
[ Just . type_ $ htmlFieldType typ,
177+
fmap
178+
(textProp "defaultValue")
179+
( st
180+
^? cloneTraversal
181+
optic
182+
. #fieldInput
183+
. #uniqueValue
184+
),
185+
Just
186+
$ onInput onInputAction,
187+
Just
188+
. disabled_
189+
$ opts
190+
^. #optsDisabled,
191+
fmap placeholder_
192+
$ if null placeholder
193+
then optsLabel opts
194+
else Just placeholder,
195+
Just
196+
. id_
197+
. either impureThrow id
198+
. decodeUtf8Strict
199+
. unTagged
200+
$ htmlUid uid,
201+
Just
202+
. onKeyDown
203+
$ action
204+
. optsOnKeyDownAction opts uid,
205+
Just
206+
$ onBlur onBlurAction
207+
]
208+
)
209+
<> ( opts ^. #optsExtraAttributes
210+
)
211+
)
182212
--
183213
-- TODO : with new semantic layout separate leading/trailing
184214
-- widgets do not make a lot of sense, should be a single option
@@ -187,26 +217,21 @@ field full@Full {fullArgs = args, fullParser = parser, fullViewer = viewer} opts
187217
<> catMaybes
188218
[ fmap
189219
(fieldIcon full opts)
190-
(opts ^? #optsLeadingWidget . _Just . cloneTraversal widgetOptic),
220+
( opts
221+
^? #optsLeadingWidget
222+
. _Just
223+
. cloneTraversal widgetOptic
224+
),
191225
fmap
192226
(fieldIcon full opts)
193-
(opts ^? #optsTrailingWidget . _Just . cloneTraversal widgetOptic)
227+
( opts
228+
^? #optsTrailingWidget
229+
. _Just
230+
. cloneTraversal widgetOptic
231+
)
194232
]
195233
)
196234
where
197-
--
198-
-- TODO : implement
199-
--
200-
-- & TextField.setLeadingIcon
201-
-- ( fmap
202-
-- (fieldIcon Leading full opts)
203-
-- (opts ^? #optsLeadingWidget . _Just . cloneTraversal widgetOptic)
204-
-- )
205-
-- & TextField.setTrailingIcon
206-
-- ( fmap
207-
-- (fieldIcon Trailing full opts)
208-
-- (opts ^? #optsTrailingWidget . _Just . cloneTraversal widgetOptic)
209-
-- )
210235
st = argsModel args
211236
optic = argsOptic args
212237
action = argsAction args
@@ -215,6 +240,11 @@ field full@Full {fullArgs = args, fullParser = parser, fullViewer = viewer} opts
215240
if null . fromMaybe mempty $ getInput st
216241
then #optsWidgetPairEmpty
217242
else #optsWidgetPairNonEmpty
243+
typ =
244+
fromMaybe FieldTypeText
245+
$ st
246+
^? cloneTraversal optic
247+
. #fieldType
218248
uid =
219249
fromMaybe nilUid
220250
$ st
@@ -567,6 +597,7 @@ fieldViewer opts args =
567597
FieldTypePercent -> genericFieldViewer opts args $ text . (<> "%")
568598
FieldTypeText -> genericFieldViewer opts args text
569599
FieldTypeTitle -> header val
600+
FieldTypeImage -> genericFieldViewer opts args text
570601
FieldTypeHtml ->
571602
genericFieldViewer
572603
opts
@@ -627,13 +658,19 @@ genericFieldViewer opts0 args widget =
627658
)
628659
<> ( optsLeftRightViewer
629660
opts0
630-
[ widget
631-
$ truncateFieldViewer
632-
allowTrunc
633-
stateTrunc
634-
(opts ^. #fieldOptsTruncateLimit)
635-
input
636-
]
661+
( if typ == FieldTypeImage
662+
then
663+
[ img_ [src_ input]
664+
]
665+
else
666+
[ widget
667+
$ truncateFieldViewer
668+
allowTrunc
669+
stateTrunc
670+
(opts ^. #fieldOptsTruncateLimit)
671+
input
672+
]
673+
)
637674
( if null extraWidgets
638675
then mempty
639676
else extraWidgets
@@ -643,6 +680,11 @@ genericFieldViewer opts0 args widget =
643680
st = argsModel args
644681
optic = argsOptic args
645682
action = argsAction args
683+
typ =
684+
fromMaybe FieldTypeText
685+
$ st
686+
^? cloneTraversal (argsOptic args)
687+
. #fieldType
646688
input =
647689
maybe mempty fold1 $ st ^? cloneTraversal optic . #fieldInput
648690
opts =
@@ -720,17 +762,6 @@ truncateFieldViewer True Closed limit full =
720762
truncateFieldViewer _ _ _ full =
721763
full
722764

723-
truncateDynamicField ::
724-
Maybe Int ->
725-
Field DynamicField Identity ->
726-
Field DynamicField Identity
727-
truncateDynamicField limit =
728-
(#fieldInput . #runIdentity %~ truncateUnicode limit)
729-
. ( #fieldOutput %~ \case
730-
DynamicFieldNumber {} -> DynamicFieldNumber 0
731-
DynamicFieldText {} -> DynamicFieldText mempty
732-
)
733-
734765
truncateUnicode :: Maybe Int -> Unicode -> Unicode
735766
truncateUnicode limit input =
736767
if length input <= full

0 commit comments

Comments
 (0)