typeable/reflex-dom-extra
1
0
Fork 0
mirror of https://github.com/typeable/reflex-dom-extra.git synced 2024-09-11 18:57:48 +03:00
Code Issues Projects Releases Wiki Activity

improve inputMonth

Browse Source
This commit is contained in:
Dmitry Olshansky 2022-08-02 10:45:13 +02:00
parent 3d14611293
commit 67ce72a3f8
2 changed files with 15 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
reflex-dom-extra.cabal
View File

@ -33,3 +33,4 @@ library
, OverloadedStrings , OverloadedStrings
, RecordWildCards , RecordWildCards
, RecursiveDo , RecursiveDo
, ViewPatterns

21
src/Reflex/Dom/Extra.hs
View File

@ -3,6 +3,7 @@ module Reflex.Dom.Extra where
import Control.Lens import Control.Lens
import Control.Monad.Fix import Control.Monad.Fix
import Data.Char
import Data.Either import Data.Either
import Data.Map as M import Data.Map as M
import Data.Maybe import Data.Maybe
@ -252,12 +253,18 @@ inputMonth
:: (MonadFix m, DomBuilder t m, MonadHold t m) :: (MonadFix m, DomBuilder t m, MonadHold t m)
=> InputElementConfig er t (DomBuilderSpace m) => InputElementConfig er t (DomBuilderSpace m)
-> m (InputElement er (DomBuilderSpace m) t) -> m (InputElement er (DomBuilderSpace m) t)
inputMonth ec = inputCorrect correct $ ec inputMonth ec = inputCorrect correct2 $ ec
& initialAttributes %~ (<> "type" =: "text" <> "maxlength" =: "5") & initialAttributes %~ (<> "type" =: "text" <> "maxlength" =: "5")
where where
correct ov nv = case (T.length ov, T.length nv) of correct2 (T.length -> ol) (T.foldl' f "" -> nv)
(x,2) | x < 2 -> nv <> "/" | ol < 2 && nl == 2 = nv `T.snoc` '/'
(x,3) | x > 3 -> T.take 2 nv | ol > 3 && nl == 3 = T.init nv
(_, x) | x > 2 && T.head (T.drop 2 nv) /= '/' -> | otherwise = nv
T.take 5 $ T.take 2 nv <> "/" <> T.drop 2 nv where
_ -> nv nl = T.length nv
f r c
| (lr == 2 && isDigit c) = r `T.snoc` '/' `T.snoc` c
| (lr == 2 && c == '/') || (isDigit c && lr < 5) = T.snoc r c
| otherwise = r
where
lr = T.length r