├── .github └── workflows │ └── ci.yml ├── .gitignore ├── LICENSE ├── README.md ├── bower.json ├── example ├── index.html └── src │ └── Main.purs ├── package.json └── src └── Halogen └── DatePicker ├── Component ├── Date.purs ├── DateTime.purs ├── Duration.purs ├── Interval.purs ├── Time.purs └── Types.purs ├── Config.purs ├── Format ├── Date.purs ├── DateTime.purs ├── Duration.purs ├── Interval.purs └── Time.purs └── Internal ├── Choice.purs ├── Constraint.purs ├── Elements.purs ├── Enums.purs ├── Num.purs ├── Range.purs └── Utils.purs /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: 4 | - push 5 | - pull_request 6 | 7 | jobs: 8 | build: 9 | runs-on: ubuntu-latest 10 | steps: 11 | - uses: actions/checkout@v2 12 | 13 | - uses: purescript-contrib/setup-purescript@main 14 | 15 | - uses: actions/setup-node@v1 16 | with: 17 | node-version: "12" 18 | 19 | - name: Install dependencies 20 | run: | 21 | npm install -g bower 22 | npm install 23 | bower install --production 24 | 25 | - name: Build source 26 | run: npm run-script build 27 | 28 | - name: Run tests 29 | run: | 30 | bower install 31 | npm run-script test --if-present 32 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /.* 2 | !/.gitignore 3 | !/.github 4 | /bower_components/ 5 | /node_modules/ 6 | /output/ 7 | package-lock.json 8 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Apache License 2 | Version 2.0, January 2004 3 | http://www.apache.org/licenses/ 4 | 5 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 6 | 7 | 1. Definitions. 8 | 9 | "License" shall mean the terms and conditions for use, reproduction, 10 | and distribution as defined by Sections 1 through 9 of this document. 11 | 12 | "Licensor" shall mean the copyright owner or entity authorized by 13 | the copyright owner that is granting the License. 14 | 15 | "Legal Entity" shall mean the union of the acting entity and all 16 | other entities that control, are controlled by, or are under common 17 | control with that entity. For the purposes of this definition, 18 | "control" means (i) the power, direct or indirect, to cause the 19 | direction or management of such entity, whether by contract or 20 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 21 | outstanding shares, or (iii) beneficial ownership of such entity. 22 | 23 | "You" (or "Your") shall mean an individual or Legal Entity 24 | exercising permissions granted by this License. 25 | 26 | "Source" form shall mean the preferred form for making modifications, 27 | including but not limited to software source code, documentation 28 | source, and configuration files. 29 | 30 | "Object" form shall mean any form resulting from mechanical 31 | transformation or translation of a Source form, including but 32 | not limited to compiled object code, generated documentation, 33 | and conversions to other media types. 34 | 35 | "Work" shall mean the work of authorship, whether in Source or 36 | Object form, made available under the License, as indicated by a 37 | copyright notice that is included in or attached to the work 38 | (an example is provided in the Appendix below). 39 | 40 | "Derivative Works" shall mean any work, whether in Source or Object 41 | form, that is based on (or derived from) the Work and for which the 42 | editorial revisions, annotations, elaborations, or other modifications 43 | represent, as a whole, an original work of authorship. For the purposes 44 | of this License, Derivative Works shall not include works that remain 45 | separable from, or merely link (or bind by name) to the interfaces of, 46 | the Work and Derivative Works thereof. 47 | 48 | "Contribution" shall mean any work of authorship, including 49 | the original version of the Work and any modifications or additions 50 | to that Work or Derivative Works thereof, that is intentionally 51 | submitted to Licensor for inclusion in the Work by the copyright owner 52 | or by an individual or Legal Entity authorized to submit on behalf of 53 | the copyright owner. For the purposes of this definition, "submitted" 54 | means any form of electronic, verbal, or written communication sent 55 | to the Licensor or its representatives, including but not limited to 56 | communication on electronic mailing lists, source code control systems, 57 | and issue tracking systems that are managed by, or on behalf of, the 58 | Licensor for the purpose of discussing and improving the Work, but 59 | excluding communication that is conspicuously marked or otherwise 60 | designated in writing by the copyright owner as "Not a Contribution." 61 | 62 | "Contributor" shall mean Licensor and any individual or Legal Entity 63 | on behalf of whom a Contribution has been received by Licensor and 64 | subsequently incorporated within the Work. 65 | 66 | 2. Grant of Copyright License. Subject to the terms and conditions of 67 | this License, each Contributor hereby grants to You a perpetual, 68 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 69 | copyright license to reproduce, prepare Derivative Works of, 70 | publicly display, publicly perform, sublicense, and distribute the 71 | Work and such Derivative Works in Source or Object form. 72 | 73 | 3. Grant of Patent License. Subject to the terms and conditions of 74 | this License, each Contributor hereby grants to You a perpetual, 75 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 76 | (except as stated in this section) patent license to make, have made, 77 | use, offer to sell, sell, import, and otherwise transfer the Work, 78 | where such license applies only to those patent claims licensable 79 | by such Contributor that are necessarily infringed by their 80 | Contribution(s) alone or by combination of their Contribution(s) 81 | with the Work to which such Contribution(s) was submitted. If You 82 | institute patent litigation against any entity (including a 83 | cross-claim or counterclaim in a lawsuit) alleging that the Work 84 | or a Contribution incorporated within the Work constitutes direct 85 | or contributory patent infringement, then any patent licenses 86 | granted to You under this License for that Work shall terminate 87 | as of the date such litigation is filed. 88 | 89 | 4. Redistribution. You may reproduce and distribute copies of the 90 | Work or Derivative Works thereof in any medium, with or without 91 | modifications, and in Source or Object form, provided that You 92 | meet the following conditions: 93 | 94 | (a) You must give any other recipients of the Work or 95 | Derivative Works a copy of this License; and 96 | 97 | (b) You must cause any modified files to carry prominent notices 98 | stating that You changed the files; and 99 | 100 | (c) You must retain, in the Source form of any Derivative Works 101 | that You distribute, all copyright, patent, trademark, and 102 | attribution notices from the Source form of the Work, 103 | excluding those notices that do not pertain to any part of 104 | the Derivative Works; and 105 | 106 | (d) If the Work includes a "NOTICE" text file as part of its 107 | distribution, then any Derivative Works that You distribute must 108 | include a readable copy of the attribution notices contained 109 | within such NOTICE file, excluding those notices that do not 110 | pertain to any part of the Derivative Works, in at least one 111 | of the following places: within a NOTICE text file distributed 112 | as part of the Derivative Works; within the Source form or 113 | documentation, if provided along with the Derivative Works; or, 114 | within a display generated by the Derivative Works, if and 115 | wherever such third-party notices normally appear. The contents 116 | of the NOTICE file are for informational purposes only and 117 | do not modify the License. You may add Your own attribution 118 | notices within Derivative Works that You distribute, alongside 119 | or as an addendum to the NOTICE text from the Work, provided 120 | that such additional attribution notices cannot be construed 121 | as modifying the License. 122 | 123 | You may add Your own copyright statement to Your modifications and 124 | may provide additional or different license terms and conditions 125 | for use, reproduction, or distribution of Your modifications, or 126 | for any such Derivative Works as a whole, provided Your use, 127 | reproduction, and distribution of the Work otherwise complies with 128 | the conditions stated in this License. 129 | 130 | 5. Submission of Contributions. Unless You explicitly state otherwise, 131 | any Contribution intentionally submitted for inclusion in the Work 132 | by You to the Licensor shall be under the terms and conditions of 133 | this License, without any additional terms or conditions. 134 | Notwithstanding the above, nothing herein shall supersede or modify 135 | the terms of any separate license agreement you may have executed 136 | with Licensor regarding such Contributions. 137 | 138 | 6. Trademarks. This License does not grant permission to use the trade 139 | names, trademarks, service marks, or product names of the Licensor, 140 | except as required for reasonable and customary use in describing the 141 | origin of the Work and reproducing the content of the NOTICE file. 142 | 143 | 7. Disclaimer of Warranty. Unless required by applicable law or 144 | agreed to in writing, Licensor provides the Work (and each 145 | Contributor provides its Contributions) on an "AS IS" BASIS, 146 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 147 | implied, including, without limitation, any warranties or conditions 148 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 149 | PARTICULAR PURPOSE. You are solely responsible for determining the 150 | appropriateness of using or redistributing the Work and assume any 151 | risks associated with Your exercise of permissions under this License. 152 | 153 | 8. Limitation of Liability. In no event and under no legal theory, 154 | whether in tort (including negligence), contract, or otherwise, 155 | unless required by applicable law (such as deliberate and grossly 156 | negligent acts) or agreed to in writing, shall any Contributor be 157 | liable to You for damages, including any direct, indirect, special, 158 | incidental, or consequential damages of any character arising as a 159 | result of this License or out of the use or inability to use the 160 | Work (including but not limited to damages for loss of goodwill, 161 | work stoppage, computer failure or malfunction, or any and all 162 | other commercial damages or losses), even if such Contributor 163 | has been advised of the possibility of such damages. 164 | 165 | 9. Accepting Warranty or Additional Liability. While redistributing 166 | the Work or Derivative Works thereof, You may choose to offer, 167 | and charge a fee for, acceptance of support, warranty, indemnity, 168 | or other liability obligations and/or rights consistent with this 169 | License. However, in accepting such obligations, You may act only 170 | on Your own behalf and on Your sole responsibility, not on behalf 171 | of any other Contributor, and only if You agree to indemnify, 172 | defend, and hold each Contributor harmless for any liability 173 | incurred by, or claims asserted against, such Contributor by reason 174 | of your accepting any such warranty or additional liability. 175 | 176 | END OF TERMS AND CONDITIONS 177 | 178 | APPENDIX: How to apply the Apache License to your work. 179 | 180 | To apply the Apache License to your work, attach the following 181 | boilerplate notice, with the fields enclosed by brackets "{}" 182 | replaced with your own identifying information. (Don't include 183 | the brackets!) The text should be enclosed in the appropriate 184 | comment syntax for the file format. We also recommend that a 185 | file or class name and description of purpose be included on the 186 | same "printed page" as the copyright notice for easier 187 | identification within third-party archives. 188 | 189 | Copyright {yyyy} {name of copyright owner} 190 | 191 | Licensed under the Apache License, Version 2.0 (the "License"); 192 | you may not use this file except in compliance with the License. 193 | You may obtain a copy of the License at 194 | 195 | http://www.apache.org/licenses/LICENSE-2.0 196 | 197 | Unless required by applicable law or agreed to in writing, software 198 | distributed under the License is distributed on an "AS IS" BASIS, 199 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 200 | See the License for the specific language governing permissions and 201 | limitations under the License. 202 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # purescript-halogen-datepicker 2 | 3 | [![Latest release](http://img.shields.io/github/release/slamdata/purescript-halogen-datepicker.svg)](https://github.com/slamdata/purescript-halogen-datepicker/releases) 4 | ![Build Status](https://github.com/slamdata/purescript-halogen-datepicker/actions/workflows/ci.yml/badge.svg) 5 | 6 | ## Pickers included: 7 | 8 | - Date 9 | - Time 10 | - DateTime 11 | - Duration 12 | - Interval 13 | 14 | ## Examples 15 | 16 | To run examples 17 | 18 | ```bash 19 | npm run build 20 | http-server example 21 | ``` 22 | 23 | you can install [http-server using npm](https://www.npmjs.com/package/http-server) 24 | -------------------------------------------------------------------------------- /bower.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "purescript-halogen-datepicker", 3 | "license": "Apache-2.0", 4 | "repository": { 5 | "type": "git", 6 | "url": "https://github.com/slamdata/purescript-halogen-datepicker.git" 7 | }, 8 | "authors": [ 9 | "Irakli Safareli " 10 | ], 11 | "ignore": [ 12 | "**/.*", 13 | "bower_components", 14 | "node_modules", 15 | "output", 16 | "tests", 17 | "tmp", 18 | "bower.json", 19 | "package.json", 20 | "example" 21 | ], 22 | "dependencies": { 23 | "purescript-enums": "^5.0.0", 24 | "purescript-formatters": "^5.0.0", 25 | "purescript-datetime": "^5.0.2", 26 | "purescript-halogen": "^6.1.1", 27 | "purescript-halogen-css": "^9.0.0", 28 | "purescript-validation": "^5.0.0", 29 | "purescript-profunctor": "^5.0.0", 30 | "purescript-numbers": "^8.0.0", 31 | "purescript-these": "^5.0.0" 32 | } 33 | } 34 | -------------------------------------------------------------------------------- /example/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Halogen Datepicker Example 5 | 60 | 61 | 62 | 63 | 64 | 65 | -------------------------------------------------------------------------------- /example/src/Main.purs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Prelude 4 | 5 | import Control.Monad.Error.Class (class MonadError) 6 | import Data.Bitraversable (bitraverse) 7 | import Data.Date (Date, canonicalDate) 8 | import Data.DateTime (DateTime(..)) 9 | import Data.Either (Either(..), either, fromRight') 10 | import Data.Enum (class BoundedEnum, toEnum) 11 | import Data.Foldable (fold) 12 | import Data.Formatter.Interval (unformatInterval) 13 | import Data.Interval (Interval(..)) 14 | import Data.Interval as I 15 | import Data.Interval.Duration.Iso (IsoDuration, mkIsoDuration) 16 | import Data.Map (Map, lookup, insert) 17 | import Data.Map as Map 18 | import Data.Maybe (Maybe(..), fromJust) 19 | import Data.Maybe.Last (Last(..)) 20 | import Data.Symbol (class IsSymbol) 21 | import Data.Time (Time, setHour, setMinute) 22 | import Effect (Effect) 23 | import Effect.Exception as Ex 24 | import Halogen as H 25 | import Halogen.Aff as HA 26 | import Halogen.Datepicker.Component.Date as Date 27 | import Halogen.Datepicker.Component.DateTime as DateTime 28 | import Halogen.Datepicker.Component.Duration as Duration 29 | import Halogen.Datepicker.Component.Interval as Interval 30 | import Halogen.Datepicker.Component.Time as Time 31 | import Halogen.Datepicker.Component.Types (setValue) 32 | import Halogen.Datepicker.Config (Config(..), defaultConfig) 33 | import Halogen.Datepicker.Format.Date as DateF 34 | import Halogen.Datepicker.Format.DateTime as DateTimeF 35 | import Halogen.Datepicker.Format.Duration as DurationF 36 | import Halogen.Datepicker.Format.Interval as IntervalF 37 | import Halogen.Datepicker.Format.Time as TimeF 38 | import Halogen.Datepicker.Internal.Utils (mustBeMounted) 39 | import Halogen.HTML as HH 40 | import Halogen.HTML.Events as HE 41 | import Halogen.VDom.Driver (runUI) 42 | import Partial.Unsafe (unsafeCrashWith, unsafePartial) 43 | import Prim.Row as Row 44 | import Type.Proxy (Proxy(..)) 45 | 46 | type TimeIdx = Int 47 | type DateIdx = Int 48 | type DateTimeIdx = Int 49 | type DurationIdx = Int 50 | type IntervalIdx = Int 51 | 52 | data Action 53 | = Set SetPayload 54 | | HandleMessage MessagePayload 55 | 56 | data SetPayload 57 | = SetTime TimeIdx (Maybe Time) 58 | | SetDate DateIdx (Maybe Date) 59 | | SetDateTime DateTimeIdx (Maybe DateTime) 60 | | SetDuration DurationIdx (Maybe IsoDuration) 61 | | SetInterval IntervalIdx (Maybe (Interval IsoDuration DateTime)) 62 | 63 | data MessagePayload 64 | = MsgTime TimeIdx Time.Message 65 | | MsgDate DateIdx Date.Message 66 | | MsgDateTime DateTimeIdx DateTime.Message 67 | | MsgDuration DurationIdx Duration.Message 68 | | MsgInterval IntervalIdx Interval.Message 69 | 70 | type State = 71 | { times ∷ Map TimeIdx String 72 | , dates ∷ Map DateIdx String 73 | , dateTimes ∷ Map DateTimeIdx String 74 | , durations ∷ Map DurationIdx String 75 | , intervals ∷ Map IntervalIdx String 76 | } 77 | 78 | type Slots = 79 | ( time ∷ Time.Slot TimeIdx 80 | , date ∷ Date.Slot DateIdx 81 | , dateTime ∷ DateTime.Slot DateTimeIdx 82 | , duration ∷ Duration.Slot DurationIdx 83 | , interval ∷ Interval.Slot IntervalIdx 84 | ) 85 | 86 | _time = Proxy ∷ Proxy "time" 87 | _date = Proxy ∷ Proxy "date" 88 | _dateTime = Proxy ∷ Proxy "dateTime" 89 | _duration = Proxy ∷ Proxy "duration" 90 | _interval = Proxy ∷ Proxy "interval" 91 | 92 | type HTML m = H.ComponentHTML Action Slots m 93 | type DSL m = H.HalogenM State Action Slots Void m 94 | 95 | main ∷ Effect Unit 96 | main = HA.runHalogenAff do 97 | body ← HA.awaitBody 98 | runUI example unit body 99 | 100 | type StrOr = Either String 101 | 102 | example 103 | ∷ ∀ f m 104 | . MonadError Ex.Error m 105 | ⇒ Applicative m 106 | ⇒ H.Component f Unit Void m 107 | example = 108 | H.mkComponent 109 | { initialState: const initialState 110 | , render 111 | , eval: H.mkEval (H.defaultEval { handleAction = handleAction }) 112 | } 113 | where 114 | initialState = 115 | { times: Map.empty 116 | , dates: Map.empty 117 | , dateTimes: Map.empty 118 | , durations: Map.empty 119 | , intervals: Map.empty 120 | } 121 | render ∷ State → HTML m 122 | render s = HH.div_ 123 | $ [HH.h1_ [ HH.text "Time" ]] 124 | <> renderTime s 0 "HH:mm" (Left "13:45") 125 | <> renderTime s 1 "HH:mm:ss,SSS" (Left "13:45:49,119") 126 | <> renderTime s 2 "mm:ss,SSS" (Left "45:49,119") 127 | <> renderTime s 3 "mm:ss,SSS" (Left "45:49,119") 128 | <> renderTime s 4 "mm:ss,SS" (Left "45:49,11") 129 | <> renderTime s 5 "mm:ss,S" (Left "45:49,1") 130 | <> renderTime s 6 "a hh:mm:ss,SSS" (Left "PM 02:45:49,119") 131 | <> renderTime s (-1) "HH:mm:m:ss:SS,Sa" (Left "---") 132 | 133 | <> [HH.h1_ [ HH.text "Date" ]] 134 | <> renderDate s 0 "YYYY:MM:DD" (Left "2017:12:27") 135 | <> renderDate s 1 "YYYY:MM" (Left "2017:12") 136 | <> renderDate s 2 "YYYY" (Left "2017") 137 | <> renderDate s 3 "YYYY:MMM" (Left "2017:May") 138 | <> renderDate s 4 "YYYY:MMMM" (Left "2017:May") 139 | <> renderDate s 5 "Y:MM" (Left "39017:12") 140 | <> renderDate s 6 "YY:MM" (Left "17:12") 141 | <> renderDate s 7 "YY:MM" (Right $ testDate) 142 | <> renderDate s (-1) "YY:MM:MMM:YYYY mm:ss" (Left "---") 143 | 144 | <> [HH.h1_ [ HH.text "DateTime" ]] 145 | <> renderDateTime s 0 "YYYY:MM:DD HH:mm" (Left "2017:12:27 12:34") 146 | <> renderDateTime s 1 "HH:mm:ss,SSS-YYYY:MMM" (Left "13:45:49,119-2017:May") 147 | <> renderDateTime s (-1) "HH:mm:m:ss:SS,SaYY:MM:MMM:YYYY mm:ss" (Left "---") 148 | 149 | <> [HH.h1_ [ HH.text "Duration" ]] 150 | <> renderDuration s 0 151 | [ DurationF.Year 152 | , DurationF.Month 153 | , DurationF.Day 154 | ] 155 | (Right testDuration) 156 | <> renderDuration s 1 157 | [ DurationF.Year 158 | , DurationF.Month 159 | , DurationF.Day 160 | , DurationF.Hour 161 | , DurationF.Minute 162 | , DurationF.Second 163 | ] 164 | (Right testDuration) 165 | <> [HH.h1_ [ HH.text "Interval" ]] 166 | <> renderInterval s 0 167 | (DurationOnly 168 | [ DurationF.Year 169 | , DurationF.Month 170 | , DurationF.Day 171 | ] 172 | ) 173 | (Right $ DurationOnly testDuration) 174 | <> renderInterval s 1 175 | (StartDuration 176 | "YYYY:MM:DD" 177 | [ DurationF.Year 178 | , DurationF.Month 179 | , DurationF.Day 180 | ] 181 | ) 182 | (Right $ StartDuration testDateTime testDuration) 183 | <> renderInterval s 2 184 | (DurationEnd 185 | [ DurationF.Year 186 | , DurationF.Month 187 | , DurationF.Day 188 | , DurationF.Hour 189 | , DurationF.Minute 190 | , DurationF.Second 191 | ] 192 | "YYYY:MMM:DD-HH:mm" 193 | ) 194 | (Right $ DurationEnd testDuration testDateTime) 195 | <> renderInterval s 3 196 | (StartEnd "YYYY:MM:DD" "YYYY:MM:DD") 197 | (Right $ StartEnd testDateTime testDateTime) 198 | 199 | testDate ∷ Date 200 | testDate = canonicalDate (enum 2017) (enum 1) (enum 1) 201 | 202 | testDateTime ∷ DateTime 203 | testDateTime = DateTime testDate (bottom # setHour (enum 2) # setMinute (enum 2)) 204 | 205 | testDuration ∷ IsoDuration 206 | testDuration = fromRight' (unsafeCrashWith "testDuration is an invalid IsoDuration") 207 | $ mkIsoDuration 208 | $ fold 209 | [ I.year 100.0 210 | , I.month 25.0 211 | , I.day 245.0 212 | , I.hour 0.0 213 | , I.minute 100.0 214 | , I.second 124.0 215 | ] 216 | 217 | enum ∷ ∀ a. BoundedEnum a ⇒ Int → a 218 | enum = unsafePartial fromJust <<< toEnum -- Ints passed to this func must be in range 219 | 220 | renderTime ∷ State → Int → String → StrOr Time → Array (HTML m) 221 | renderTime s = renderExample timeConfig _time s.times 222 | 223 | renderDate ∷ State → Int → String → StrOr Date → Array (HTML m) 224 | renderDate s = renderExample dateConfig _date s.dates 225 | 226 | renderDuration 227 | ∷ State 228 | → Int 229 | → Array DurationF.Command 230 | → StrOr IsoDuration 231 | → Array (HTML m) 232 | renderDuration s = renderExample durationConfig _duration s.durations 233 | 234 | renderInterval 235 | ∷ State 236 | → Int 237 | → Interval (Array DurationF.Command) String 238 | → StrOr (Interval IsoDuration DateTime) 239 | → Array (HTML m) 240 | renderInterval s = renderExample intervalConfig _interval s.intervals 241 | 242 | renderDateTime 243 | ∷ State 244 | → Int 245 | → String 246 | → StrOr DateTime 247 | → Array (HTML m) 248 | renderDateTime s = renderExample dateTimeConfig _dateTime s.dateTimes 249 | 250 | handleAction ∷ Action → DSL m Unit 251 | handleAction (Set payload) = do 252 | mustBeMounted =<< case payload of 253 | SetTime idx val → 254 | H.query _time idx $ setValue $ map Right val 255 | SetDate idx val → 256 | H.query _date idx $ setValue $ map Right val 257 | SetDateTime idx val → 258 | H.query _dateTime idx $ setValue $ map Right val 259 | SetDuration idx val → 260 | H.query _duration idx $ setValue $ map Right val 261 | SetInterval idx val → 262 | map void $ H.query _interval idx $ setValue $ map Right val 263 | handleAction (HandleMessage payload) = do 264 | case payload of 265 | MsgTime idx val → 266 | H.modify_ \s → s{ times = insert idx (show val) s.times } 267 | MsgDate idx val → 268 | H.modify_ \s → s{ dates = insert idx (show val) s.dates } 269 | MsgDateTime idx val → 270 | H.modify_ \s → s{ dateTimes = insert idx (show val) s.dateTimes } 271 | MsgDuration idx val → 272 | H.modify_ \s → s{ durations = insert idx (show val) s.durations } 273 | MsgInterval idx val → 274 | H.modify_ \s → s{ intervals = insert idx (show val) s.intervals } 275 | 276 | type ExampleConfig fmtInput input fmt query out m = 277 | { mkFormat ∷ fmtInput → StrOr fmt 278 | , unformat ∷ fmt → String → StrOr input 279 | , picker ∷ fmt → H.Component query Unit out m 280 | , handler ∷ Int → out → Action 281 | , setter ∷ Int → Maybe input → Action 282 | } 283 | 284 | renderExample 285 | ∷ ∀ fmtInput input fmt sym query out px m 286 | . Row.Cons sym (H.Slot query out Int) px Slots 287 | ⇒ IsSymbol sym 288 | ⇒ ExampleConfig fmtInput input fmt query out m 289 | → Proxy sym 290 | → Map Int String 291 | → Int 292 | → fmtInput 293 | → StrOr input 294 | → Array (HTML m) 295 | renderExample c sp items idx fmt' value'= unEither $ do 296 | fmt ← c.mkFormat fmt' 297 | value ← either (c.unformat fmt) Right value' 298 | let cmp = c.picker fmt 299 | pure 300 | [ HH.slot sp idx cmp unit (c.handler idx) 301 | , btn (Just value) "reset" 302 | , btn Nothing "clear" 303 | , case lookup idx items of 304 | Nothing → HH.div_ [HH.text "no value is set"] 305 | Just val → HH.div_ [HH.text $ "value: " <> val] 306 | ] 307 | where 308 | btn ∷ Maybe input → String → HTML m 309 | btn val txt = HH.button 310 | [ HE.onClick \_ → c.setter idx val ] 311 | [ HH.text txt] 312 | unEither ∷ StrOr (Array (HTML m)) → Array (HTML m) 313 | unEither = either (HH.text >>> pure >>> HH.div_ >>> pure) identity 314 | 315 | timeConfig 316 | ∷ ∀ m 317 | . MonadError Ex.Error m 318 | ⇒ ExampleConfig String Time TimeF.Format Time.Query Time.Message m 319 | timeConfig = 320 | { mkFormat: TimeF.fromString 321 | , unformat: TimeF.unformat 322 | , picker: Time.picker 323 | , handler: \idx msg → HandleMessage (MsgTime idx msg) 324 | , setter: \idx val → Set (SetTime idx val) 325 | } 326 | 327 | dateConfig 328 | ∷ ∀ m 329 | . MonadError Ex.Error m 330 | ⇒ ExampleConfig String Date DateF.Format Date.Query Date.Message m 331 | dateConfig = 332 | { mkFormat: DateF.fromString 333 | , unformat: DateF.unformat 334 | , picker: Date.picker 335 | , handler: \idx msg → HandleMessage (MsgDate idx msg) 336 | , setter: \idx val → Set (SetDate idx val) 337 | } 338 | 339 | dateTimeConfig 340 | ∷ ∀ m 341 | . MonadError Ex.Error m 342 | ⇒ ExampleConfig String DateTime DateTimeF.Format DateTime.Query DateTime.Message m 343 | dateTimeConfig = 344 | { mkFormat: DateTimeF.fromString 345 | , unformat: DateTimeF.unformat 346 | , picker: DateTime.picker 347 | , handler: \idx msg → HandleMessage (MsgDateTime idx msg) 348 | , setter: \idx val → Set (SetDateTime idx val) 349 | } 350 | 351 | durationConfig 352 | ∷ ∀ m 353 | . MonadError Ex.Error m 354 | ⇒ ExampleConfig (Array DurationF.Command) IsoDuration DurationF.Format Duration.Query Duration.Message m 355 | durationConfig = 356 | { mkFormat: DurationF.mkFormat 357 | , unformat: const DurationF.unformat 358 | , picker: Duration.picker 359 | , handler: \idx msg → HandleMessage (MsgDuration idx msg) 360 | , setter: \idx val → Set (SetDuration idx val) 361 | } 362 | 363 | intervalConfig 364 | ∷ ∀ m 365 | . MonadError Ex.Error m 366 | ⇒ ExampleConfig (Interval (Array DurationF.Command) String) (Interval IsoDuration DateTime) IntervalF.Format Interval.Query Interval.Message m 367 | intervalConfig = 368 | { mkFormat: bitraverse DurationF.mkFormat DateTimeF.fromString 369 | , unformat: const unformatInterval 370 | , picker: Interval.pickerWithConfig (defaultConfig <> myConfig) 371 | , handler: \idx msg → HandleMessage (MsgInterval idx msg) 372 | , setter: \idx val → Set (SetInterval idx val) 373 | } 374 | 375 | myConfig ∷ Config 376 | myConfig = Config 377 | { root: [HH.ClassName "MyPicker"] 378 | , rootInvalid: [HH.ClassName "MyPicker--invalid"] 379 | , component: [HH.ClassName "MyPicker-component"] 380 | , placeholder: [HH.ClassName "MyPicker-placeholder"] 381 | , choice: [HH.ClassName "MyPicker-input"] 382 | , choiceEmptyTitle: Last $ Just "==" 383 | , input: [HH.ClassName "MyPicker-input"] 384 | , inputInvalid: [HH.ClassName "MyPicker-input--invalid"] 385 | , inputLength: \n → [ HH.ClassName $ "MyPicker-input--length-" <> show n] 386 | } 387 | -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "private": true, 3 | "scripts": { 4 | "refresh": "rimraf bower_components && rimraf output && bower i && npm run build", 5 | "watch": "pulp --watch build --include example/src --to example/example.js", 6 | "build": "pulp build --include example/src --to example/example.js" 7 | }, 8 | "devDependencies": { 9 | "pulp": "^15.0.0", 10 | "purescript": "^0.14.1", 11 | "purescript-psa": "^0.8.2" 12 | } 13 | } 14 | -------------------------------------------------------------------------------- /src/Halogen/DatePicker/Component/Date.purs: -------------------------------------------------------------------------------- 1 | module Halogen.Datepicker.Component.Date where 2 | 3 | import Prelude 4 | 5 | import Control.Monad.Error.Class (class MonadError) 6 | import Data.Array (sort) 7 | import Data.Date (Date, Day, Month, Year) 8 | import Data.Either (Either(..)) 9 | import Data.Enum (class BoundedEnum, fromEnum, toEnum, upFromIncluding) 10 | import Data.Foldable (for_) 11 | import Data.Generic.Rep (class Generic) 12 | import Data.Maybe (Maybe(..), maybe) 13 | import Data.Newtype (unwrap) 14 | import Data.Profunctor.Join (Join(..)) 15 | import Data.Profunctor.Star (Star(..)) 16 | import Data.Show.Generic (genericShow) 17 | import Data.Traversable (for) 18 | import Effect.Exception as Ex 19 | import Halogen as H 20 | import Halogen.Datepicker.Component.Types (BasePickerQuery(..), PickerQuery, PickerValue, value) 21 | import Halogen.Datepicker.Config (Config, defaultConfig) 22 | import Halogen.Datepicker.Format.Date as F 23 | import Halogen.Datepicker.Internal.Choice as Choice 24 | import Halogen.Datepicker.Internal.Elements (PreChoiceConfig, PreNumConfig, renderChoice, renderNum, textElement) 25 | import Halogen.Datepicker.Internal.Enums (MonthShort, Year2, Year4, setYear) 26 | import Halogen.Datepicker.Internal.Num as Num 27 | import Halogen.Datepicker.Internal.Range (Range, bottomTop) 28 | import Halogen.Datepicker.Internal.Utils (componentProps, foldSteps, handlePickerQuery, mustBeMounted, pickerProps, transitionState') 29 | import Halogen.HTML as HH 30 | import Type.Proxy (Proxy(..)) 31 | 32 | type State = PickerValue DateError Date 33 | 34 | type Message = PickerValue DateError Date 35 | 36 | type Query = PickerQuery Unit State 37 | type Action = Date → Maybe Date 38 | 39 | data DateError = InvalidDate 40 | derive instance dateErrorEq ∷ Eq DateError 41 | derive instance dateErrorOrd ∷ Ord DateError 42 | derive instance dateErrorGeneric ∷ Generic DateError _ 43 | instance dateErrorShow ∷ Show DateError where show = genericShow 44 | 45 | type Slots = 46 | ( num ∷ Num.Slot Int F.Command 47 | , choice ∷ Choice.Slot (Maybe Int) F.Command 48 | ) 49 | 50 | _num = Proxy ∷ Proxy "num" 51 | _choice = Proxy ∷ Proxy "choice" 52 | 53 | type Slot = H.Slot Query Message 54 | 55 | type HTML m = H.ComponentHTML Action Slots m 56 | type DSL = H.HalogenM State Action Slots Message 57 | 58 | picker 59 | ∷ ∀ m 60 | . MonadError Ex.Error m 61 | ⇒ F.Format → H.Component Query Unit Message m 62 | picker = pickerWithConfig defaultConfig 63 | 64 | pickerWithConfig 65 | ∷ ∀ m 66 | . MonadError Ex.Error m 67 | ⇒ Config 68 | → F.Format 69 | → H.Component Query Unit Message m 70 | pickerWithConfig config format = 71 | H.mkComponent 72 | { initialState: const Nothing 73 | , render: render config format 74 | , eval: H.mkEval $ H.defaultEval 75 | { handleAction = handleAction format 76 | , handleQuery = handlePickerQuery (propagateChange format) 77 | } 78 | } 79 | 80 | render ∷ ∀ m. Config → F.Format → State → HTML m 81 | render config format date = HH.ul 82 | (pickerProps config date) 83 | (unwrap format <#> renderCommand config) 84 | 85 | renderCommand ∷ ∀ m. Config → F.Command → HTML m 86 | renderCommand config cmd = HH.li (componentProps config) $ pure case cmd of 87 | F.Placeholder str → 88 | textElement config { text: str} 89 | F.YearFull → renderNum' 90 | { title: "Year", placeholder: "YYYY", range: (bottomTop ∷ Range Year4) <#> fromEnum } 91 | F.YearTwoDigits → renderNum' 92 | { title: "Year", placeholder: "YY", range: (bottomTop ∷ Range Year2) <#> fromEnum } 93 | F.YearAbsolute → renderNum' 94 | { title: "Year", placeholder: "Y", range: (bottomTop ∷ Range Year) <#> fromEnum } 95 | F.MonthFull → renderChoice' 96 | { title: "Month", values: upFromIncluding (bottom ∷ Maybe Month) } 97 | F.MonthShort → renderChoice' 98 | { title: "Month", values: upFromIncluding (bottom ∷ Maybe MonthShort) } 99 | F.MonthTwoDigits → renderNum' 100 | { title: "Month", placeholder: "MM", range: (bottomTop ∷ Range Month) <#> fromEnum } 101 | F.DayOfMonthTwoDigits → renderNum' 102 | { title: "Day", placeholder: "DD", range: (bottomTop ∷ Range Day) <#> fromEnum } 103 | F.DayOfMonth → renderNum' 104 | { title: "Day", placeholder: "D", range: (bottomTop ∷ Range Day) <#> fromEnum } 105 | where 106 | renderNum' ∷ PreNumConfig Int → HTML m 107 | renderNum' = renderNum _num F.toSetter cmd config 108 | renderChoice' ∷ ∀ a. BoundedEnum a ⇒ Show a ⇒ PreChoiceConfig (Maybe a) → HTML m 109 | renderChoice' = renderChoice _choice F.toSetter cmd config 110 | 111 | handleAction ∷ ∀ m. MonadError Ex.Error m ⇒ F.Format → Action → DSL m Unit 112 | handleAction format update = do 113 | transitionState' InvalidDate case _ of 114 | Just (Right prevDate) → pure $ maybe (Left false) Right $ update prevDate 115 | _ → buildDate format 116 | 117 | type BuildStep = Maybe (Join (Star Maybe) Date) 118 | 119 | buildDate ∷ ∀ m. MonadError Ex.Error m ⇒ F.Format → DSL m (Either Boolean Date) 120 | buildDate format = do 121 | buildSteps ← for (sort $ unwrap format) $ mkBuildStep 122 | pure case runStep $ foldSteps buildSteps of 123 | Just (Just x) → Right x 124 | Just Nothing → Left true 125 | Nothing → Left false 126 | where 127 | mkBuildStep ∷ F.Command → DSL m BuildStep 128 | mkBuildStep = commandCata 129 | { text: \_ → pure $ Just mempty 130 | , enum: \cmd → do 131 | num ← queryNum cmd $ H.mkRequest GetValue 132 | pure $ num <#> \n → Join $ Star $ \t → F.toSetter cmd n t 133 | , choice: \cmd → do 134 | num ← queryChoice cmd $ H.mkRequest GetValue 135 | pure $ num <#> \n → Join $ Star $ \t → F.toSetter cmd n t 136 | } 137 | runStep ∷ BuildStep → Maybe (Maybe Date) 138 | runStep step = step <#> \(Join (Star f)) → 139 | (toEnum 0) >>= (_ `setYear` bottom) >>= f 140 | 141 | propagateChange 142 | ∷ ∀ m 143 | . MonadError Ex.Error m 144 | ⇒ F.Format 145 | → State 146 | → DSL m Unit 147 | propagateChange format date = for_ (unwrap format) $ commandCata 148 | { text: \_ → pure unit 149 | , enum: \cmd → do 150 | let val = value date >>= F.toGetter cmd 151 | queryNum cmd $ H.mkRequest (SetValue val) 152 | , choice: \cmd → do 153 | let val = value date >>= F.toGetter cmd 154 | res ← queryChoice cmd $ H.mkRequest (SetValue val) 155 | Choice.valueMustBeInValues res 156 | } 157 | 158 | commandCata 159 | ∷ ∀ a 160 | . { text ∷ F.Command → a 161 | , enum ∷ F.Command → a 162 | , choice ∷ F.Command → a 163 | } 164 | → F.Command 165 | → a 166 | commandCata p cmd = case cmd of 167 | F.Placeholder _ → p.text cmd 168 | F.YearFull → p.enum cmd 169 | F.YearTwoDigits → p.enum cmd 170 | F.YearAbsolute → p.enum cmd 171 | F.MonthFull → p.choice cmd 172 | F.MonthShort → p.choice cmd 173 | F.MonthTwoDigits → p.enum cmd 174 | F.DayOfMonthTwoDigits → p.enum cmd 175 | F.DayOfMonth → p.enum cmd 176 | 177 | queryChoice 178 | ∷ ∀ m 179 | . MonadError Ex.Error m 180 | ⇒ F.Command 181 | → Choice.Query (Maybe Int) 182 | ~> DSL m 183 | queryChoice s q = H.query _choice s q >>= mustBeMounted 184 | 185 | queryNum 186 | ∷ ∀ m 187 | . MonadError Ex.Error m 188 | ⇒ F.Command 189 | → Num.Query Int 190 | ~> DSL m 191 | queryNum s q = H.query _num s q >>= mustBeMounted 192 | -------------------------------------------------------------------------------- /src/Halogen/DatePicker/Component/DateTime.purs: -------------------------------------------------------------------------------- 1 | module Halogen.Datepicker.Component.DateTime where 2 | 3 | import Prelude 4 | 5 | import Control.Monad.Error.Class (class MonadError) 6 | import Control.Monad.Writer (Writer, runWriter, tell) 7 | import Data.Array (sort) 8 | import Data.Bifunctor (bimap, lmap) 9 | import Data.Date (Date) 10 | import Data.DateTime (DateTime, date, modifyDate, modifyTime, time) 11 | import Data.Either (Either(..)) 12 | import Data.Foldable (length) 13 | import Data.Maybe (Maybe(..), fromMaybe) 14 | import Data.Maybe.Last (Last(..)) 15 | import Data.Monoid.Additive (Additive(..)) 16 | import Data.Newtype (unwrap) 17 | import Data.Profunctor.Join (Join(..)) 18 | import Data.Profunctor.Star (Star(..)) 19 | import Data.Time (Time) 20 | import Data.Traversable (for, for_) 21 | import Data.Tuple (Tuple(..)) 22 | import Effect.Exception as Ex 23 | import Halogen as H 24 | import Halogen.Datepicker.Component.Date (DateError) 25 | import Halogen.Datepicker.Component.Date as Date 26 | import Halogen.Datepicker.Component.Time (TimeError) 27 | import Halogen.Datepicker.Component.Time as Time 28 | import Halogen.Datepicker.Component.Types (BasePickerQuery(..), PickerQuery(..), PickerValue, value, getValue, setValue, resetError) 29 | import Halogen.Datepicker.Config (Config, defaultConfig) 30 | import Halogen.Datepicker.Format.DateTime as F 31 | import Halogen.Datepicker.Internal.Utils (componentProps, foldSteps, mustBeMounted, pickerProps, transitionState) 32 | import Halogen.HTML as HH 33 | import Type.Proxy (Proxy(..)) 34 | 35 | type State = PickerValue DateTimeError DateTime 36 | type DateTimeError = DateTimeErrorF Maybe 37 | type DateTimeErrorF f = Tuple (f DateError) (f TimeError) 38 | type DateTimeErrorLast = DateTimeErrorF Last 39 | 40 | type Message = PickerValue DateTimeError DateTime 41 | 42 | type Query = PickerQuery Unit State 43 | type Action = Either Date.Message Time.Message 44 | 45 | type Slots = 46 | ( date ∷ Date.Slot Unit 47 | , time ∷ Time.Slot Unit 48 | ) 49 | 50 | _date = Proxy ∷ Proxy "date" 51 | _time = Proxy ∷ Proxy "time" 52 | 53 | type Slot = H.Slot Query Message 54 | 55 | type HTML m = H.ComponentHTML Action Slots m 56 | type DSL = H.HalogenM State Action Slots Message 57 | 58 | picker ∷ ∀ m. MonadError Ex.Error m ⇒ F.Format → H.Component Query Unit Message m 59 | picker = pickerWithConfig defaultConfig 60 | 61 | pickerWithConfig 62 | ∷ ∀ m 63 | . MonadError Ex.Error m 64 | ⇒ Config 65 | → F.Format 66 | → H.Component Query Unit Message m 67 | pickerWithConfig config format = 68 | H.mkComponent 69 | { initialState: const Nothing 70 | , render: render config format 71 | , eval: H.mkEval $ H.defaultEval 72 | { handleAction = handleAction format 73 | , handleQuery = handleQuery format 74 | } 75 | } 76 | 77 | render ∷ ∀ m. MonadError Ex.Error m ⇒ Config → F.Format → State → HTML m 78 | render config format dateTime = HH.div 79 | (pickerProps config dateTime) 80 | (unwrap format <#> renderCommand config) 81 | 82 | renderCommand ∷ ∀ m. MonadError Ex.Error m ⇒ Config → F.Command → HTML m 83 | renderCommand config cmd = HH.div (componentProps config) $ pure case cmd of 84 | F.Time fmt → 85 | HH.slot 86 | _time 87 | unit 88 | (Time.pickerWithConfig config fmt) 89 | unit 90 | Right 91 | F.Date fmt → 92 | HH.slot 93 | _date 94 | unit 95 | (Date.pickerWithConfig config fmt) 96 | unit 97 | Left 98 | 99 | handleAction ∷ ∀ m. MonadError Ex.Error m ⇒ F.Format → Action → DSL m Unit 100 | handleAction format msg = do 101 | transitionState case _ of 102 | Nothing → do 103 | dt ← buildDateTime format 104 | case dt of 105 | Left (Tuple false _) → resetChildErrorBasedOnMessage msg 106 | _ → pure unit 107 | pure dt 108 | Just (Left _) → buildDateTime format 109 | Just (Right dt) → pure $ lmap (Tuple false) case msg of 110 | Left newDate → case newDate of 111 | Just (Right date) → Right $ setDateDt date dt 112 | Just (Left x) → Left $ dateError x 113 | Nothing → Left $ emptyError 114 | Right newTime → case newTime of 115 | Just (Right time) → Right $ setTimeDt time dt 116 | Just (Left x) → Left $ timeError x 117 | Nothing → Left $ emptyError 118 | 119 | resetChildErrorBasedOnMessage ∷ ∀ m. MonadError Ex.Error m ⇒ Action → DSL m Unit 120 | resetChildErrorBasedOnMessage (Left (Just (Left _))) = resetDate 121 | resetChildErrorBasedOnMessage (Right (Just (Left _))) = resetTime 122 | resetChildErrorBasedOnMessage _ = pure unit 123 | 124 | resetChildError ∷ ∀ m. MonadError Ex.Error m ⇒ F.Format → DSL m Unit 125 | resetChildError format = do 126 | for_ (unwrap format) case _ of 127 | F.Time _ → resetTime 128 | F.Date _ → resetDate 129 | 130 | timeError ∷ TimeError → DateTimeError 131 | timeError x = Tuple Nothing (Just x) 132 | 133 | dateError ∷ DateError → DateTimeError 134 | dateError x = Tuple (Just x) Nothing 135 | 136 | setTimeDt ∷ Time → DateTime → DateTime 137 | setTimeDt x dt = modifyTime (const x) dt 138 | 139 | setDateDt ∷ Date → DateTime → DateTime 140 | setDateDt x dt = modifyDate (const x) dt 141 | 142 | type BuildStep 143 | = Maybe 144 | (Join 145 | (Star (Writer (Maybe (Tuple (Additive Int) DateTimeErrorLast)))) 146 | DateTime) 147 | 148 | buildDateTime 149 | ∷ ∀ m 150 | . MonadError Ex.Error m 151 | ⇒ F.Format 152 | → DSL m (Either (Tuple Boolean DateTimeError) DateTime) 153 | buildDateTime format = do 154 | buildSteps ← for (sort $ unwrap format) mkBuildStep 155 | pure $ 156 | fromMaybe (Left (Tuple false emptyError)) $ 157 | runStep (length buildSteps) (foldSteps buildSteps) 158 | where 159 | runStep 160 | ∷ Int 161 | → BuildStep 162 | → Maybe (Either (Tuple Boolean DateTimeError) DateTime) 163 | runStep childCount step = step <#> \(Join (Star f)) → case runWriter $ f bottom of 164 | Tuple res Nothing → Right res 165 | Tuple _ (Just (Tuple (Additive errCount) err)) → Left $ Tuple 166 | -- if we hit errCount == 0 or errCount == childCount we shuoldn't force 167 | (errCount > 0 && errCount < childCount) 168 | (bimap unwrap unwrap err) 169 | mkBuildStep ∷ F.Command → DSL m BuildStep 170 | mkBuildStep = case _ of 171 | F.Time _ → do 172 | val ← queryTime $ getValue 173 | pure $ applyValue setTimeDt timeError val 174 | F.Date _ → do 175 | val ← queryDate $ getValue 176 | pure $ applyValue setDateDt dateError val 177 | applyValue ∷ ∀ val err 178 | . (val → DateTime → DateTime) 179 | → (err → DateTimeError) 180 | → PickerValue err val 181 | → BuildStep 182 | applyValue f err val = Just $ Join $ Star $ \dt → case val of 183 | Just (Right x) → pure $ f x dt 184 | Just (Left x) → writeErr dt (Additive 1) (biLast $ err x) 185 | Nothing → writeErr dt (Additive 0) mempty 186 | writeErr dt a b = tell (Just $ Tuple a b) *> pure dt 187 | biLast = bimap Last Last 188 | 189 | handleQuery ∷ ∀ m a. MonadError Ex.Error m ⇒ F.Format → Query a → DSL m (Maybe a) 190 | handleQuery format = case _ of 191 | ResetError a → do 192 | H.put Nothing 193 | resetChildError format 194 | pure $ Just a 195 | Base (SetValue dateTime k) → do 196 | propagateChange format dateTime 197 | H.put dateTime 198 | pure $ Just $ k unit 199 | Base (GetValue k) → 200 | Just <<< k <$> H.get 201 | 202 | propagateChange ∷ ∀ m. MonadError Ex.Error m ⇒ F.Format → State → DSL m Unit 203 | propagateChange format dateTime = for_ (unwrap format) case _ of 204 | F.Time _ → setTime $ value dateTime <#> (time >>> Right) 205 | F.Date _ → setDate $ value dateTime <#> (date >>> Right) 206 | 207 | emptyError ∷ DateTimeError 208 | emptyError = Tuple Nothing Nothing 209 | 210 | setTime ∷ ∀ m. MonadError Ex.Error m ⇒ PickerValue TimeError Time → DSL m Unit 211 | setTime val = queryTime $ setValue val 212 | 213 | setDate ∷ ∀ m. MonadError Ex.Error m ⇒ PickerValue DateError Date → DSL m Unit 214 | setDate val = queryDate $ setValue val 215 | 216 | resetTime ∷ ∀ m. MonadError Ex.Error m ⇒ DSL m Unit 217 | resetTime = queryTime resetError 218 | 219 | resetDate ∷ ∀ m. MonadError Ex.Error m ⇒ DSL m Unit 220 | resetDate = queryDate resetError 221 | 222 | queryTime ∷ ∀ m. MonadError Ex.Error m ⇒ Time.Query ~> DSL m 223 | queryTime q = H.query _time unit q >>= mustBeMounted 224 | 225 | queryDate ∷ ∀ m. MonadError Ex.Error m ⇒ Date.Query ~> DSL m 226 | queryDate q = H.query _date unit q >>= mustBeMounted 227 | -------------------------------------------------------------------------------- /src/Halogen/DatePicker/Component/Duration.purs: -------------------------------------------------------------------------------- 1 | module Halogen.Datepicker.Component.Duration where 2 | 3 | import Prelude 4 | 5 | import Control.Monad.Error.Class (class MonadError) 6 | import Data.Array (fold) 7 | import Data.Bifunctor (lmap) 8 | import Data.Either (Either(..)) 9 | import Data.Generic.Rep (class Generic) 10 | import Data.Interval (Duration) 11 | import Data.Interval.Duration.Iso (IsoDuration, mkIsoDuration, unIsoDuration, Errors) 12 | import Data.Maybe (Maybe(..), fromMaybe) 13 | import Data.Monoid.Endo (Endo(..)) 14 | import Data.Newtype (unwrap) 15 | import Data.Show.Generic (genericShow) 16 | import Data.String (take) 17 | import Data.Traversable (for) 18 | import Data.Tuple (Tuple(..)) 19 | import Effect.Exception as Ex 20 | import Halogen as H 21 | import Halogen.Datepicker.Component.Types (BasePickerQuery(..), PickerQuery, PickerValue) 22 | import Halogen.Datepicker.Config (Config, defaultConfig) 23 | import Halogen.Datepicker.Format.Duration as F 24 | import Halogen.Datepicker.Internal.Elements (toNumConf) 25 | import Halogen.Datepicker.Internal.Num as Num 26 | import Halogen.Datepicker.Internal.Range (minRange) 27 | import Halogen.Datepicker.Internal.Utils (asRight, componentProps, foldSteps, handlePickerQuery, mustBeMounted, pickerProps, transitionState) 28 | import Halogen.HTML as HH 29 | import Type.Proxy (Proxy(..)) 30 | 31 | type State = PickerValue DurationError IsoDuration 32 | 33 | type Message = PickerValue DurationError IsoDuration 34 | 35 | type Query = PickerQuery Unit State 36 | type Action = Tuple F.Command (Maybe Number) 37 | 38 | data DurationError = InvalidIsoDuration (Maybe Errors) 39 | derive instance durationErrorEq ∷ Eq DurationError 40 | derive instance durationErrorOrd ∷ Ord DurationError 41 | derive instance durationErrorGeneric ∷ Generic DurationError _ 42 | instance durationErrorShow ∷ Show DurationError where show = genericShow 43 | 44 | type Slots = (num ∷ Num.Slot Number F.Command) 45 | 46 | _num = Proxy ∷ Proxy "num" 47 | 48 | type Slot = H.Slot Query Message 49 | 50 | type HTML m = H.ComponentHTML Action Slots m 51 | type DSL = H.HalogenM State Action Slots Message 52 | 53 | picker ∷ ∀ m. MonadError Ex.Error m ⇒ F.Format → H.Component Query Unit Message m 54 | picker = pickerWithConfig defaultConfig 55 | 56 | pickerWithConfig 57 | ∷ ∀ m 58 | . MonadError Ex.Error m 59 | ⇒ Config 60 | → F.Format 61 | → H.Component Query Unit Message m 62 | pickerWithConfig config format = 63 | H.mkComponent 64 | { initialState: const Nothing 65 | , render: render config format 66 | , eval: H.mkEval $ H.defaultEval 67 | { handleAction = handleAction format 68 | , handleQuery = handlePickerQuery (propagateChange format) 69 | } 70 | } 71 | 72 | render ∷ ∀ m. Config → F.Format → State → HTML m 73 | render config format duration = HH.ul (pickerProps config duration) (unwrap format <#> renderCommand config) 74 | 75 | renderCommand ∷ ∀ m. Config → F.Command → HTML m 76 | renderCommand config cmd = 77 | HH.li (componentProps config) 78 | [ HH.slot 79 | _num 80 | cmd 81 | (Num.picker Num.numberHasNumberInputVal $ toNumConf config { title: show cmd, placeholder: take 1 (show cmd), range: minRange 0.0 }) 82 | unit 83 | (Tuple cmd) 84 | ] 85 | 86 | getComponent ∷ F.Command → IsoDuration → Number 87 | getComponent cmd d = fromMaybe 0.0 $ F.toGetter cmd (unIsoDuration d) 88 | 89 | overIsoDuration ∷ (Duration → Duration) → IsoDuration → Either Errors IsoDuration 90 | overIsoDuration f d = mkIsoDuration $ f $ unIsoDuration d 91 | 92 | handleAction ∷ ∀ m. MonadError Ex.Error m ⇒ F.Format → Action → DSL m Unit 93 | handleAction format (Tuple cmd val) = do 94 | transitionState case _ of 95 | Just (Right prevDuration) → pure case val of 96 | Just n → overIsoDuration (F.toSetter cmd n) prevDuration # lmap \err -> 97 | Tuple false (InvalidIsoDuration (Just err)) 98 | Nothing → Left (Tuple false (InvalidIsoDuration Nothing)) 99 | _ → buildDuration format 100 | 101 | type BuildStep = Maybe (Endo (->) Duration) 102 | buildDuration 103 | ∷ ∀ m 104 | . MonadError Ex.Error m 105 | ⇒ F.Format 106 | → DSL m (Either (Tuple Boolean DurationError) IsoDuration) 107 | buildDuration format = do 108 | steps ← for (unwrap format) mkBuildStep 109 | pure case runStep $ foldSteps steps of 110 | Just (Right x) → Right x 111 | Just (Left err) → Left (Tuple false (InvalidIsoDuration (Just err))) 112 | Nothing → Left (Tuple false (InvalidIsoDuration Nothing)) 113 | where 114 | mkBuildStep ∷ F.Command → DSL m BuildStep 115 | mkBuildStep cmd = do 116 | num ← query cmd $ H.mkRequest GetValue 117 | pure $ num <#> F.toSetter cmd >>> Endo 118 | runStep ∷ BuildStep → Maybe (Either Errors IsoDuration) 119 | runStep step = step <#> \(Endo f) → mkIsoDuration $ f mempty 120 | 121 | propagateChange ∷ ∀ m. MonadError Ex.Error m ⇒ F.Format → State → DSL m Unit 122 | propagateChange format duration = do 123 | map fold $ for (unwrap format) \cmd → do 124 | let n = duration >>= asRight >>= unIsoDuration >>> F.toGetter cmd 125 | query cmd $ H.mkRequest (SetValue n) 126 | 127 | query ∷ ∀ m. MonadError Ex.Error m ⇒ F.Command → Num.Query Number ~> DSL m 128 | query cmd q = H.query _num cmd q >>= mustBeMounted 129 | -------------------------------------------------------------------------------- /src/Halogen/DatePicker/Component/Interval.purs: -------------------------------------------------------------------------------- 1 | module Halogen.Datepicker.Component.Interval where 2 | 3 | import Prelude 4 | 5 | import Control.Monad.Error.Class (class MonadError) 6 | import Data.Bifunctor (bimap, lmap) 7 | import Data.DateTime (DateTime) 8 | import Data.Either (Either(..), either) 9 | import Data.Foldable (for_) 10 | import Data.Interval (Interval(..)) 11 | import Data.Interval.Duration.Iso (IsoDuration) 12 | import Data.Maybe (Maybe(..), isNothing) 13 | import Data.Tuple (Tuple(..)) 14 | import Effect.Exception as Ex 15 | import Halogen as H 16 | import Halogen.Datepicker.Component.DateTime as DateTime 17 | import Halogen.Datepicker.Component.Duration (DurationError) 18 | import Halogen.Datepicker.Component.Duration as Duration 19 | import Halogen.Datepicker.Component.Types (BasePickerQuery(..), PickerQuery(..), PickerValue, getValue, setValue, resetError) 20 | import Halogen.Datepicker.Config (Config, defaultConfig) 21 | import Halogen.Datepicker.Format.DateTime as DateTimeF 22 | import Halogen.Datepicker.Format.Duration as DurationF 23 | import Halogen.Datepicker.Format.Interval as F 24 | import Halogen.Datepicker.Internal.Elements (textElement) 25 | import Halogen.Datepicker.Internal.Utils (asLeft, componentProps, mustBeMounted, pickerProps, transitionState) 26 | import Halogen.HTML as HH 27 | import Type.Proxy (Proxy(..)) 28 | 29 | type State = PickerValue IntervalError IsoInterval 30 | type IntervalError = Interval (Maybe DurationError) (Maybe DateTime.DateTimeError) 31 | type IsoInterval = Interval IsoDuration DateTime 32 | 33 | type Message = PickerValue IntervalError IsoInterval 34 | 35 | type Query = PickerQuery (Maybe SetIntervalError) State 36 | data SetIntervalError = IntervalIsNotInShapeOfFormat 37 | type MessageIn = Either Duration.Message (Tuple Boolean DateTime.Message) 38 | 39 | type Slots = 40 | ( dateTime ∷ DateTime.Slot Boolean 41 | , duration ∷ Duration.Slot Unit 42 | ) 43 | 44 | _dateTime = Proxy ∷ Proxy "dateTime" 45 | _duration = Proxy ∷ Proxy "duration" 46 | 47 | type Slot = H.Slot Query Message 48 | 49 | type HTML m = H.ComponentHTML MessageIn Slots m 50 | type DSL = H.HalogenM State MessageIn Slots Message 51 | 52 | picker ∷ ∀ m. MonadError Ex.Error m ⇒ F.Format → H.Component Query Unit Message m 53 | picker = pickerWithConfig defaultConfig 54 | 55 | pickerWithConfig 56 | ∷ ∀ m 57 | . MonadError Ex.Error m 58 | ⇒ Config 59 | → F.Format 60 | → H.Component Query Unit Message m 61 | pickerWithConfig config format = 62 | H.mkComponent 63 | { initialState: const Nothing 64 | , render: render config format 65 | , eval: H.mkEval $ H.defaultEval 66 | { handleAction = handleAction format 67 | , handleQuery = handleQuery format 68 | } 69 | } 70 | 71 | render ∷ ∀ m. MonadError Ex.Error m ⇒ Config → F.Format → State → HTML m 72 | render config format interval = HH.div (pickerProps config interval) (renderCommand config format) 73 | 74 | renderCommand ∷ ∀ m. MonadError Ex.Error m ⇒ Config → F.Format → Array (HTML m) 75 | renderCommand config format = map (HH.div (componentProps config) <<< pure) case format of 76 | StartEnd fmtStart fmtEnd → 77 | [ renderDateTime config fmtStart false 78 | , textElement config { text: "/" } 79 | , renderDateTime config fmtEnd true ] 80 | DurationEnd fmtDuration fmtEnd → 81 | [ renderDuration config fmtDuration 82 | , textElement config { text: "/" } 83 | , renderDateTime config fmtEnd false ] 84 | StartDuration fmtStart fmtDuration → 85 | [ renderDateTime config fmtStart false 86 | , textElement config { text: "/" } 87 | , renderDuration config fmtDuration ] 88 | DurationOnly fmtDuration → 89 | [ renderDuration config fmtDuration ] 90 | 91 | renderDuration ∷ ∀ m. MonadError Ex.Error m ⇒ Config → DurationF.Format → HTML m 92 | renderDuration config fmt = 93 | HH.slot 94 | _duration 95 | unit 96 | (Duration.pickerWithConfig config fmt) 97 | unit 98 | Left 99 | 100 | renderDateTime ∷ ∀ m. MonadError Ex.Error m ⇒ Config → DateTimeF.Format → Boolean → HTML m 101 | renderDateTime config fmt idx = 102 | HH.slot 103 | _dateTime 104 | idx 105 | (DateTime.pickerWithConfig config fmt) 106 | unit 107 | (\val → Right (Tuple idx val)) 108 | 109 | -- [1] - this case will not happen as interval will not be `Just Right` 110 | -- if any of it's child is `Nothing` so return nonsence value 111 | handleAction ∷ ∀ m. MonadError Ex.Error m ⇒ F.Format → MessageIn → DSL m Unit 112 | handleAction format msg = do 113 | transitionState case _ of 114 | Nothing → do 115 | newInterval ← buildInterval format 116 | case newInterval of 117 | Left (Tuple false _) → resetChildErrorBasedOnMessage msg 118 | _ → pure unit 119 | pure newInterval 120 | Just (Left _) → buildInterval format 121 | Just (Right prevInterval) → pure $ lmap (Tuple false) case msg of 122 | Left newDuration → case newDuration of 123 | Just (Left x) → Left $ bimap (const $ Just x) (const Nothing) format 124 | Nothing → Left $ bimap (const Nothing) (const Nothing) format -- [1] 125 | Just (Right duration) → Right $ lmap (const duration) prevInterval 126 | Right (Tuple idx newDateTime) → case newDateTime of 127 | Just (Left x) → Left $ bimap (const Nothing) (const $ Just x) format 128 | Nothing → Left $ bimap (const Nothing) (const Nothing) format -- [1] 129 | Just (Right dateTime) → Right case prevInterval of 130 | StartEnd a b → case idx of 131 | true → StartEnd dateTime b 132 | false → StartEnd a dateTime 133 | DurationEnd d _ → DurationEnd d dateTime 134 | StartDuration _ d → StartDuration dateTime d 135 | DurationOnly d → DurationOnly d 136 | 137 | buildInterval ∷ ∀ m. MonadError Ex.Error m ⇒ F.Format → DSL m (Either (Tuple Boolean IntervalError) IsoInterval) 138 | buildInterval format = do 139 | vals ← collectValues format 140 | pure $ lmap addForce $ unVals vals 141 | 142 | addForce ∷ IntervalError → Tuple Boolean IntervalError 143 | addForce err = case err of 144 | StartEnd Nothing Nothing → Tuple false err 145 | DurationEnd Nothing Nothing → Tuple false err 146 | StartDuration Nothing Nothing → Tuple false err 147 | DurationOnly Nothing → Tuple false err 148 | _ → Tuple true err 149 | 150 | unVals ∷ Interval Duration.State DateTime.State → Either IntervalError IsoInterval 151 | unVals vals = case bimap maybeLeft maybeLeft vals of 152 | StartEnd (Right dtStart) (Right dtEnd) → Right $ StartEnd dtStart dtEnd 153 | DurationEnd (Right dur) (Right dt) → Right $ DurationEnd dur dt 154 | StartDuration (Right dt) (Right dur) → Right $ StartDuration dt dur 155 | DurationOnly (Right dur) → Right $ DurationOnly dur 156 | interval → Left $ bimap toError toError interval 157 | 158 | toError ∷ ∀ e a. Either (Maybe e) a → Maybe e 159 | toError = asLeft >>> join 160 | 161 | maybeLeft ∷ ∀ e a. Maybe (Either e a) → Either (Maybe e) a 162 | maybeLeft (Just (Right a)) = Right a 163 | maybeLeft (Just (Left a)) = Left $ Just a 164 | maybeLeft Nothing = Left $ Nothing 165 | 166 | collectValues 167 | ∷ ∀ d a m 168 | . MonadError Ex.Error m 169 | ⇒ Interval d a 170 | → DSL m (Interval Duration.State DateTime.State) 171 | collectValues format = case format of 172 | StartEnd _ _ → StartEnd <$> getDateTime false <*> getDateTime true 173 | DurationEnd _ _ → DurationEnd <$> getDuration <*> getDateTime false 174 | StartDuration _ _ → StartDuration <$> getDateTime false <*> getDuration 175 | DurationOnly _ → DurationOnly <$> getDuration 176 | 177 | resetChildErrorBasedOnMessage ∷ ∀ m. MonadError Ex.Error m ⇒ MessageIn → DSL m Unit 178 | resetChildErrorBasedOnMessage (Left (Just (Left _))) = resetDuration 179 | resetChildErrorBasedOnMessage (Right (Tuple idx (Just (Left _)))) = resetDateTime idx 180 | resetChildErrorBasedOnMessage _ = pure unit 181 | 182 | resetChildError ∷ ∀ m. MonadError Ex.Error m ⇒ F.Format → DSL m Unit 183 | resetChildError format = do 184 | onFormat resetDateTime resetDuration format 185 | 186 | onFormat 187 | ∷ ∀ m a d 188 | . Apply m 189 | ⇒ (Boolean → m Unit) 190 | → m Unit 191 | → Interval d a 192 | → m Unit 193 | onFormat onDateTime onDuration format = case format of 194 | StartEnd _ _ → onDateTime false *> onDateTime true 195 | DurationEnd _ _ → onDuration *> onDateTime false 196 | StartDuration _ _ → onDateTime false *> onDuration 197 | DurationOnly _ → onDuration 198 | 199 | handleQuery ∷ ∀ m a. MonadError Ex.Error m ⇒ F.Format → Query a → DSL m (Maybe a) 200 | handleQuery format = case _ of 201 | ResetError a → do 202 | H.put Nothing 203 | resetChildError format 204 | pure $ Just a 205 | Base (SetValue interval k) → do 206 | res ← case viewInterval format interval <#> setInterval of 207 | Just x → x $> Nothing 208 | Nothing → pure $ Just IntervalIsNotInShapeOfFormat 209 | when (isNothing res) $ H.put interval 210 | pure $ Just $ k res 211 | Base (GetValue k) → 212 | Just <<< k <$> H.get 213 | 214 | type ChildStates 215 | = Interval (Maybe Duration.State) (Maybe DateTime.State) 216 | 217 | setInterval ∷ ∀ m. MonadError Ex.Error m ⇒ ChildStates → DSL m Unit 218 | setInterval = case _ of 219 | StartEnd a b → do 220 | for_ a $ setDateTime false 221 | for_ b $ setDateTime true 222 | DurationEnd d a → do 223 | for_ d setDuration 224 | for_ a $ setDateTime false 225 | StartDuration a d → do 226 | for_ a $ setDateTime false 227 | for_ d setDuration 228 | DurationOnly d → do 229 | for_ d setDuration 230 | 231 | viewInterval ∷ F.Format → State → Maybe ChildStates 232 | viewInterval format input = case format, mappedState input of 233 | StartEnd _ _ , Just interval@(StartEnd _ _) → Just interval 234 | DurationEnd _ _ , Just interval@(DurationEnd _ _) → Just interval 235 | StartDuration _ _ , Just interval@(StartDuration _ _) → Just interval 236 | DurationOnly _ , Just interval@(DurationOnly _) → Just interval 237 | _, Nothing → Just $ bimap (const $ Just Nothing) (const $ Just Nothing) format 238 | _ , _ → Nothing 239 | where 240 | mappedState ∷ State → Maybe ChildStates 241 | mappedState = map $ either (bimap mkErr mkErr) (bimap mkVal mkVal) 242 | mkVal ∷ ∀ e a. a → Maybe (PickerValue e a) 243 | mkVal = Just <<< Just <<< Right 244 | mkErr ∷ ∀ e a. Maybe e → Maybe (PickerValue e a) 245 | mkErr = map (Just <<< Left) 246 | 247 | getDuration ∷ ∀ m. MonadError Ex.Error m ⇒ DSL m Duration.State 248 | getDuration = queryDuration $ getValue 249 | 250 | getDateTime ∷ ∀ m. MonadError Ex.Error m ⇒ Boolean → DSL m DateTime.State 251 | getDateTime idx = queryDateTime idx getValue 252 | 253 | setDuration ∷ ∀ m. MonadError Ex.Error m ⇒ Duration.State → DSL m Unit 254 | setDuration val = queryDuration $ setValue val 255 | 256 | setDateTime ∷ ∀ m. MonadError Ex.Error m ⇒ Boolean → DateTime.State → DSL m Unit 257 | setDateTime idx val = queryDateTime idx $ setValue val 258 | 259 | resetDuration ∷ ∀ m. MonadError Ex.Error m ⇒ DSL m Unit 260 | resetDuration = queryDuration $ resetError 261 | 262 | resetDateTime ∷ ∀ m. MonadError Ex.Error m ⇒ Boolean → DSL m Unit 263 | resetDateTime idx = queryDateTime idx resetError 264 | 265 | queryDuration ∷ ∀ m a. MonadError Ex.Error m ⇒ Duration.Query a → DSL m a 266 | queryDuration q = H.query _duration unit q >>= mustBeMounted 267 | 268 | queryDateTime ∷ ∀ m a. MonadError Ex.Error m ⇒ Boolean → DateTime.Query a → DSL m a 269 | queryDateTime idx q = H.query _dateTime idx q >>= mustBeMounted 270 | -------------------------------------------------------------------------------- /src/Halogen/DatePicker/Component/Time.purs: -------------------------------------------------------------------------------- 1 | module Halogen.Datepicker.Component.Time where 2 | 3 | import Prelude 4 | 5 | import Control.Monad.Error.Class (class MonadError) 6 | import Data.Array (sort) 7 | import Data.DateTime (Hour, Millisecond, Minute, Second) 8 | import Data.Either (Either(..)) 9 | import Data.Enum (class BoundedEnum, fromEnum, upFromIncluding) 10 | import Data.Foldable (for_) 11 | import Data.Generic.Rep (class Generic) 12 | import Data.Maybe (Maybe(Nothing, Just), maybe) 13 | import Data.Newtype (unwrap) 14 | import Data.Profunctor.Join (Join(..)) 15 | import Data.Profunctor.Star (Star(..)) 16 | import Data.Show.Generic (genericShow) 17 | import Data.Time (Time) 18 | import Data.Traversable (for) 19 | import Effect.Exception as Ex 20 | import Halogen as H 21 | import Halogen.Datepicker.Component.Types (BasePickerQuery(..), PickerQuery, PickerValue, value) 22 | import Halogen.Datepicker.Config (Config, defaultConfig) 23 | import Halogen.Datepicker.Format.Time as F 24 | import Halogen.Datepicker.Internal.Choice as Choice 25 | import Halogen.Datepicker.Internal.Elements (PreChoiceConfig, PreNumConfig, renderChoice, renderNum, textElement) 26 | import Halogen.Datepicker.Internal.Enums (Hour12, Meridiem, Millisecond1, Millisecond2) 27 | import Halogen.Datepicker.Internal.Num as Num 28 | import Halogen.Datepicker.Internal.Range (Range, bottomTop) 29 | import Halogen.Datepicker.Internal.Utils (componentProps, foldSteps, handlePickerQuery, mustBeMounted, pickerProps, transitionState') 30 | import Halogen.HTML as HH 31 | import Type.Proxy (Proxy(..)) 32 | 33 | type State = PickerValue TimeError Time 34 | 35 | type Message = PickerValue TimeError Time 36 | 37 | type Query = PickerQuery Unit State 38 | type Action = Time → Maybe Time 39 | 40 | data TimeError = InvalidTime 41 | derive instance timeErrorEq ∷ Eq TimeError 42 | derive instance timeErrorOrd ∷ Ord TimeError 43 | derive instance timeErrorGeneric ∷ Generic TimeError _ 44 | instance timeErrorShow ∷ Show TimeError where show = genericShow 45 | 46 | type Slots = 47 | ( num ∷ Num.Slot Int F.Command 48 | , choice ∷ Choice.Slot (Maybe Int) F.Command 49 | ) 50 | 51 | _num = Proxy ∷ Proxy "num" 52 | _choice = Proxy ∷ Proxy "choice" 53 | 54 | type Slot = H.Slot Query Message 55 | 56 | type HTML m = H.ComponentHTML Action Slots m 57 | type DSL = H.HalogenM State Action Slots Message 58 | 59 | picker ∷ ∀ m. MonadError Ex.Error m ⇒ F.Format → H.Component Query Unit Message m 60 | picker = pickerWithConfig defaultConfig 61 | 62 | pickerWithConfig 63 | ∷ ∀ m 64 | . MonadError Ex.Error m 65 | ⇒ Config 66 | → F.Format 67 | → H.Component Query Unit Message m 68 | pickerWithConfig config format = 69 | H.mkComponent 70 | { initialState: const Nothing 71 | , render: render config format 72 | , eval: H.mkEval $ H.defaultEval 73 | { handleAction = handleAction format 74 | , handleQuery = handlePickerQuery (propagateChange format) 75 | } 76 | } 77 | 78 | render ∷ ∀ m. Config → F.Format → State → HTML m 79 | render config format time = HH.ul 80 | (pickerProps config time) 81 | (unwrap format <#> renderCommand config) 82 | 83 | renderCommand ∷ ∀ m. Config → F.Command → HTML m 84 | renderCommand config cmd = HH.li (componentProps config) $ pure case cmd of 85 | F.Placeholder str → 86 | textElement config { text: str} 87 | F.Meridiem → renderChoice' 88 | { title: "Meridiem", values: upFromIncluding (bottom ∷ Maybe Meridiem) } 89 | F.Hours24 → renderNum' 90 | { title: "Hours", placeholder: "HH", range: (bottomTop ∷ Range Hour) <#> fromEnum } 91 | F.Hours12 → renderNum' 92 | { title: "Hours", placeholder: "hh", range: (bottomTop ∷ Range Hour12) <#> fromEnum } 93 | F.MinutesTwoDigits → renderNum' 94 | { title: "Minutes", placeholder: "MM", range: (bottomTop ∷ Range Minute) <#> fromEnum } 95 | F.Minutes → renderNum' 96 | { title: "Minutes", placeholder: "MM", range: (bottomTop ∷ Range Minute) <#> fromEnum } 97 | F.SecondsTwoDigits → renderNum' 98 | { title: "Seconds", placeholder: "SS", range: (bottomTop ∷ Range Second) <#> fromEnum } 99 | F.Seconds → renderNum' 100 | { title: "Seconds", placeholder: "SS", range: (bottomTop ∷ Range Second) <#> fromEnum } 101 | F.Milliseconds → renderNum' 102 | { title: "Milliseconds", placeholder: "MMM", range: (bottomTop ∷ Range Millisecond) <#> fromEnum } 103 | F.MillisecondsTwoDigits → renderNum' 104 | { title: "Milliseconds", placeholder: "MM", range: (bottomTop ∷ Range Millisecond2) <#> fromEnum } 105 | F.MillisecondsShort → renderNum' 106 | { title: "Milliseconds", placeholder: "M", range: (bottomTop ∷ Range Millisecond1) <#> fromEnum } 107 | where 108 | renderNum' ∷ PreNumConfig Int → HTML m 109 | renderNum' = renderNum _num F.toSetter cmd config 110 | renderChoice' ∷ ∀ a. BoundedEnum a ⇒ Show a ⇒ PreChoiceConfig (Maybe a) → HTML m 111 | renderChoice' = renderChoice _choice F.toSetter cmd config 112 | 113 | handleAction ∷ ∀ m. MonadError Ex.Error m ⇒ F.Format → Action → DSL m Unit 114 | handleAction format update = do 115 | transitionState' InvalidTime \time → map (maybe (Left false) Right) $ 116 | case time of 117 | Just (Right prevTime) → pure $ update prevTime 118 | _ → buildTime format 119 | 120 | type BuildStep = Maybe (Join (Star Maybe) Time) 121 | 122 | buildTime ∷ ∀ m. MonadError Ex.Error m ⇒ F.Format → DSL m (Maybe Time) 123 | buildTime format = do 124 | buildSteps ← for (sort $ unwrap format) mkBuildStep 125 | pure $ runStep $ foldSteps buildSteps 126 | where 127 | runStep ∷ BuildStep → Maybe Time 128 | runStep step = step >>= \(Join (Star f)) → f bottom 129 | mkBuildStep ∷ F.Command → DSL m BuildStep 130 | mkBuildStep cmd = case cmd of 131 | F.Placeholder _ → do 132 | pure $ Just $ mempty 133 | F.Meridiem → do 134 | num ← queryChoice cmd $ H.mkRequest GetValue 135 | pure $ num <#> \n → Join $ Star $ \t → F.toSetter cmd n t 136 | _ → do 137 | num ← queryNum cmd $ H.mkRequest GetValue 138 | pure $ num <#> \n → Join $ Star $ \t → F.toSetter cmd n t 139 | 140 | propagateChange ∷ ∀ m. MonadError Ex.Error m ⇒ F.Format → State → DSL m Unit 141 | propagateChange format time = for_ (unwrap format) \cmd → case cmd of 142 | F.Placeholder _ → pure unit 143 | F.Meridiem → do 144 | let val = value time >>= F.toGetter F.Meridiem 145 | res ← queryChoice cmd $ H.mkRequest (SetValue val) 146 | Choice.valueMustBeInValues res 147 | _ → do 148 | let val = value time >>= F.toGetter cmd 149 | queryNum cmd $ H.mkRequest (SetValue val) 150 | 151 | queryChoice ∷ ∀ m. MonadError Ex.Error m ⇒ F.Command → Choice.Query (Maybe Int) ~> DSL m 152 | queryChoice s q = H.query _choice s q >>= mustBeMounted 153 | 154 | queryNum ∷ ∀ m. MonadError Ex.Error m ⇒ F.Command → Num.Query Int ~> DSL m 155 | queryNum s q = H.query _num s q >>= mustBeMounted 156 | -------------------------------------------------------------------------------- /src/Halogen/DatePicker/Component/Types.purs: -------------------------------------------------------------------------------- 1 | module Halogen.Datepicker.Component.Types where 2 | 3 | import Prelude 4 | 5 | import Data.Either (Either(..)) 6 | import Data.Maybe (Maybe(..), isJust) 7 | import Halogen (mkRequest, mkTell) 8 | 9 | data PickerQuery err val next 10 | = ResetError next 11 | | Base (BasePickerQuery err val next) 12 | 13 | data BasePickerQuery err val next 14 | = GetValue (val → next) 15 | | SetValue val (err → next) 16 | 17 | type PickerValue e a = Maybe (Either e a) 18 | 19 | getValue ∷ ∀ val err. PickerQuery err val val 20 | getValue = mkRequest (Base <<< GetValue) 21 | 22 | setValue ∷ ∀ val err. val -> PickerQuery err val err 23 | setValue val = mkRequest (Base <<< SetValue val) 24 | 25 | resetError ∷ ∀ val err. PickerQuery err val Unit 26 | resetError = mkTell ResetError 27 | 28 | value ∷ ∀ e a. PickerValue e a → Maybe a 29 | value (Just (Right x)) = Just x 30 | value _ = Nothing 31 | 32 | error ∷ ∀ e a. PickerValue e a → Maybe e 33 | error (Just (Left x)) = Just x 34 | error _ = Nothing 35 | 36 | isInvalid ∷ ∀ e a. PickerValue e a → Boolean 37 | isInvalid = error >>> isJust 38 | 39 | isValid ∷ ∀ e a. PickerValue e a → Boolean 40 | isValid = value >>> isJust 41 | -------------------------------------------------------------------------------- /src/Halogen/DatePicker/Config.purs: -------------------------------------------------------------------------------- 1 | module Halogen.Datepicker.Config where 2 | 3 | import Prelude 4 | 5 | import Data.Generic.Rep (class Generic) 6 | import Data.Maybe (Maybe(..)) 7 | import Data.Maybe.Last (Last(..)) 8 | import Data.Monoid.Generic (genericMempty) 9 | import Data.Newtype (class Newtype) 10 | import Data.Semigroup.Generic (genericAppend) 11 | import Halogen.HTML (ClassName(..)) 12 | 13 | newtype Config = Config 14 | { root ∷ Array ClassName 15 | , rootInvalid ∷ Array ClassName 16 | , component ∷ Array ClassName 17 | , placeholder ∷ Array ClassName 18 | , choice ∷ Array ClassName 19 | , choiceEmptyTitle ∷ Last String 20 | , input ∷ Array ClassName 21 | , inputInvalid ∷ Array ClassName 22 | , inputLength ∷ Int → Array ClassName 23 | } 24 | 25 | defaultConfig ∷ Config 26 | defaultConfig = Config 27 | { root: [ClassName "Picker"] 28 | , rootInvalid: [ClassName "Picker--invalid"] 29 | , component: [ClassName "Picker-component"] 30 | , placeholder: [ClassName "Picker-placeholder"] 31 | , choice: [ClassName "Picker-input"] 32 | , choiceEmptyTitle: Last $ Just "--" 33 | , input: [ClassName "Picker-input"] 34 | , inputInvalid: [ClassName "Picker-input--invalid"] 35 | , inputLength: \n → [ ClassName $ "Picker-input--length-" <> show n] 36 | } 37 | 38 | derive instance configGeneric :: Generic Config _ 39 | derive instance configNewtype :: Newtype Config _ 40 | 41 | instance configSemigroup :: Semigroup Config where 42 | append = genericAppend 43 | 44 | instance configMonoid :: Monoid Config where 45 | mempty = genericMempty 46 | -------------------------------------------------------------------------------- /src/Halogen/DatePicker/Format/Date.purs: -------------------------------------------------------------------------------- 1 | module Halogen.Datepicker.Format.Date where 2 | 3 | import Prelude 4 | 5 | import Data.Array (fromFoldable) 6 | import Data.Date (Date, day, month, year) 7 | import Data.DateTime (DateTime(..), date) 8 | import Data.Either (Either(..)) 9 | import Data.Enum (fromEnum, toEnum) 10 | import Data.Foldable (class Foldable, foldMap) 11 | import Data.Formatter.DateTime as FDT 12 | import Data.Generic.Rep (class Generic) 13 | import Data.Maybe (Maybe(..)) 14 | import Data.Newtype (class Newtype) 15 | import Data.Show.Generic (genericShow) 16 | import Data.String (joinWith) 17 | import Data.Traversable (traverse) 18 | import Halogen.Datepicker.Internal.Constraint as C 19 | import Halogen.Datepicker.Internal.Enums (monthShort, setDay, setMonth, setYear, setYear2, setYear4, year2, year4) 20 | 21 | data Command 22 | = YearFull 23 | | YearTwoDigits 24 | | YearAbsolute 25 | | MonthFull 26 | | MonthShort 27 | | MonthTwoDigits 28 | | DayOfMonthTwoDigits 29 | | DayOfMonth 30 | | Placeholder String 31 | -- NOTE `DayOfWeek` value is not fully supported in ps-formatters itself 32 | -- as it it only has point to use when we have `week number` in date format. 33 | 34 | 35 | derive instance commandGeneric ∷ Generic Command _ 36 | derive instance commandEq ∷ Eq Command 37 | derive instance commandOrd ∷ Ord Command 38 | instance commandShow ∷ Show Command where 39 | show = genericShow 40 | 41 | toSetter ∷ Command → Int → Date → Maybe Date 42 | toSetter cmd n d = case cmd of 43 | YearFull → toEnum n >>= (_ `setYear4` d) 44 | YearTwoDigits → toEnum n >>= (_ `setYear2` d) 45 | YearAbsolute → toEnum n >>= (_ `setYear` d) 46 | MonthFull → toEnum n >>= (_ `setMonth` d) 47 | MonthShort → toEnum n >>= (_ `setMonth` d) 48 | MonthTwoDigits → toEnum n >>= (_ `setMonth` d) 49 | DayOfMonthTwoDigits → toEnum n >>= (_ `setDay` d) 50 | DayOfMonth → toEnum n >>= (_ `setDay` d) 51 | Placeholder _ → pure d 52 | 53 | 54 | toGetter ∷ Command → Date → Maybe Int 55 | toGetter cmd d = case cmd of 56 | YearFull → Just $ fromEnum $ year4 d 57 | YearTwoDigits → Just $ fromEnum $ year2 d 58 | YearAbsolute → Just $ fromEnum $ year d 59 | MonthFull → Just $ fromEnum $ month d 60 | MonthShort → Just $ fromEnum $ monthShort d 61 | MonthTwoDigits → Just $ fromEnum $ month d 62 | DayOfMonthTwoDigits → Just $ fromEnum $ day d 63 | DayOfMonth → Just $ fromEnum $ day d 64 | Placeholder _ → Nothing 65 | 66 | 67 | newtype Format = Format (Array Command) 68 | derive instance formatNewtype ∷ Newtype Format _ 69 | derive instance formatGeneric ∷ Generic Format _ 70 | instance formatShow ∷ Show Format where 71 | show = genericShow 72 | derive instance formatEq ∷ Eq Format 73 | derive instance formatOrd ∷ Ord Format 74 | 75 | fromString ∷ String → Either String Format 76 | fromString s = FDT.parseFormatString s >>= fromDateTimeFormatter 77 | 78 | fromDateTimeFormatter ∷ FDT.Formatter → Either String Format 79 | fromDateTimeFormatter fmt = do 80 | let errs = C.runConstraint formatConstraint fmt 81 | when (errs /= []) $ Left $ joinWith "; " errs 82 | case traverse toCommand fmt of 83 | Just fmt' → pure $ Format $ fromFoldable fmt' 84 | Nothing → Left "(unreachable) invalid FormatterCommand has leaked while checking constraints" 85 | 86 | toCommand ∷ FDT.FormatterCommand → Maybe Command 87 | toCommand = case _ of 88 | FDT.YearFull → Just YearFull 89 | FDT.YearTwoDigits → Just YearTwoDigits 90 | FDT.YearAbsolute → Just YearAbsolute 91 | FDT.MonthFull → Just MonthFull 92 | FDT.MonthShort → Just MonthShort 93 | FDT.MonthTwoDigits → Just MonthTwoDigits 94 | FDT.DayOfMonthTwoDigits → Just DayOfMonthTwoDigits 95 | FDT.DayOfMonth → Just DayOfMonth 96 | FDT.Placeholder str → Just $ Placeholder str 97 | _ → Nothing 98 | 99 | toDateTimeFormatter ∷ Format → FDT.Formatter 100 | toDateTimeFormatter (Format fmt) = foldMap (pure <<< toDTCommand) fmt 101 | 102 | toDTCommand ∷ Command → FDT.FormatterCommand 103 | toDTCommand = case _ of 104 | YearFull → FDT.YearFull 105 | YearTwoDigits → FDT.YearTwoDigits 106 | YearAbsolute → FDT.YearAbsolute 107 | MonthFull → FDT.MonthFull 108 | MonthShort → FDT.MonthShort 109 | MonthTwoDigits → FDT.MonthTwoDigits 110 | DayOfMonthTwoDigits → FDT.DayOfMonthTwoDigits 111 | DayOfMonth → FDT.DayOfMonth 112 | Placeholder str → FDT.Placeholder str 113 | 114 | unformat ∷ Format → String → Either String Date 115 | unformat fmt str = FDT.unformat (toDateTimeFormatter fmt) str <#> date 116 | 117 | format ∷ Format → Date → String 118 | format fmt = FDT.format (toDateTimeFormatter fmt) <<< toDateTime 119 | where 120 | toDateTime ∷ Date → DateTime 121 | toDateTime d = DateTime d bottom 122 | 123 | 124 | formatConstraint ∷ ∀ g. Foldable g ⇒ C.Constraint (g FDT.FormatterCommand) 125 | formatConstraint 126 | = C.notEmpty 127 | <> C.allowedValues FDT.printFormatterCommand allowedCommands 128 | <> C.allowNoneOrOne (C.reShow FDT.printFormatterCommand <$> [FDT.YearFull, FDT.YearTwoDigits, FDT.YearAbsolute]) 129 | <> C.allowNoneOrOne (C.reShow FDT.printFormatterCommand <$> [FDT.MonthFull, FDT.MonthShort, FDT.MonthTwoDigits]) 130 | <> C.allowNoneOrOne (C.reShow FDT.printFormatterCommand <$> [FDT.DayOfMonthTwoDigits, FDT.DayOfMonth]) 131 | where 132 | allowedCommands = (C.reShow FDT.printFormatterCommand <$> 133 | [ FDT.YearFull 134 | , FDT.YearTwoDigits 135 | , FDT.YearAbsolute 136 | , FDT.MonthFull 137 | , FDT.MonthShort 138 | , FDT.MonthTwoDigits 139 | , FDT.DayOfMonthTwoDigits 140 | , FDT.DayOfMonth 141 | ]) <> 142 | [ C.EqPred 143 | "'Placeholder'" 144 | case _ of 145 | FDT.Placeholder _ → true 146 | _ → false 147 | ] 148 | -------------------------------------------------------------------------------- /src/Halogen/DatePicker/Format/DateTime.purs: -------------------------------------------------------------------------------- 1 | module Halogen.Datepicker.Format.DateTime where 2 | 3 | import Prelude 4 | 5 | import Control.Alt ((<|>)) 6 | import Control.Monad.State.Trans (StateT, put, get, evalStateT, lift) 7 | import Data.Array (fromFoldable) 8 | import Data.Bifunctor (bimap) 9 | import Data.DateTime (DateTime) 10 | import Data.Either (Either(..)) 11 | import Data.Foldable (foldMap) 12 | import Data.Formatter.DateTime as FDT 13 | import Data.Generic.Rep (class Generic) 14 | import Data.List (List(..), null, span) 15 | import Data.Maybe (Maybe(..), isJust) 16 | import Data.Newtype (class Newtype) 17 | import Data.Show.Generic (genericShow) 18 | import Data.String (joinWith) 19 | import Data.Tuple (Tuple(..)) 20 | import Halogen.Datepicker.Format.Date as DateF 21 | import Halogen.Datepicker.Format.Time as TimeF 22 | import Halogen.Datepicker.Internal.Constraint as C 23 | 24 | data Command 25 | = Date DateF.Format 26 | | Time TimeF.Format 27 | 28 | -- NOTE: placeholder can be as part of Date or Time. in future we can add 29 | -- `Placeholder` node here, and when we construct Format, we should take a look 30 | -- at first and last commands of date and time and if thay contain Placeholder 31 | -- extract them into DateTime format level whis way we can merge last placeholder 32 | -- of first element with the first of the second. 33 | 34 | derive instance commandGeneric ∷ Generic Command _ 35 | derive instance commandEq ∷ Eq Command 36 | derive instance commandOrd ∷ Ord Command 37 | instance commandShow ∷ Show Command where 38 | show = genericShow 39 | 40 | newtype Format = Format (Array Command) 41 | 42 | derive instance formatNewtype ∷ Newtype Format _ 43 | derive instance formatGeneric ∷ Generic Format _ 44 | derive instance formatEq ∷ Eq Format 45 | derive instance formatOrd ∷ Ord Format 46 | instance formatShow ∷ Show Format where 47 | show = genericShow 48 | 49 | fromString ∷ String → Either String Format 50 | fromString s = FDT.parseFormatString s >>= fromDateTimeFormatter 51 | 52 | fromDateTimeFormatter ∷ FDT.Formatter → Either String Format 53 | fromDateTimeFormatter fmt = run $ go Nil 54 | where 55 | run 56 | ∷ StateT FDT.Formatter (Either String) (List Command) 57 | → Either String Format 58 | run s = do 59 | resFmt ← evalStateT s fmt 60 | let errs = C.runConstraint formatConstraint resFmt 61 | when (errs /= []) $ Left $ joinWith "; " errs 62 | pure $ Format $ fromFoldable resFmt 63 | 64 | go 65 | ∷ List Command 66 | → StateT FDT.Formatter (Either String) (List Command) 67 | go currFmt = get >>= \a → case (takeDate a <|> takeTime a) of 68 | Just (Left err) → 69 | lift $ Left err 70 | Just (Right (Tuple restRes restFmt)) → 71 | let 72 | res = do 73 | put restFmt 74 | pure $ currFmt <> restRes 75 | in 76 | if null restFmt 77 | then res 78 | else res >>= go 79 | Nothing → 80 | get >>= \restFmt → 81 | lift $ Left $ "left unconsumed format: " <> show restFmt 82 | 83 | takeDate 84 | ∷ FDT.Formatter 85 | → Maybe (Either String (Tuple (List Command) FDT.Formatter)) 86 | takeDate = consumeWhile 87 | (DateF.toCommand >>> isJust) 88 | (DateF.fromDateTimeFormatter >>> bimap 89 | ("Date Format error: " <> _ ) 90 | (Date >>> pure)) 91 | 92 | takeTime 93 | ∷ FDT.Formatter 94 | → Maybe (Either String (Tuple (List Command) FDT.Formatter)) 95 | takeTime = consumeWhile 96 | (TimeF.toCommand >>> isJust) 97 | (TimeF.fromDateTimeFormatter >>> bimap 98 | ("Time Format error: " <> _ ) 99 | (Time >>> pure)) 100 | 101 | consumeWhile ∷ ∀ a 102 | . (FDT.FormatterCommand → Boolean) 103 | → (List FDT.FormatterCommand → Either String a) 104 | → List FDT.FormatterCommand 105 | → Maybe (Either String (Tuple a FDT.Formatter)) 106 | consumeWhile whileFn consumer fmt = span whileFn fmt # 107 | \({init, rest}) → if null init then Nothing 108 | else Just $ consumer init <#> (\a → Tuple a rest) 109 | 110 | toDateTimeFormatter ∷ Format → FDT.Formatter 111 | toDateTimeFormatter (Format fmt) = foldMap toDTCommand fmt 112 | where 113 | toDTCommand (Date inFmt) = DateF.toDateTimeFormatter inFmt 114 | toDTCommand (Time inFmt) = TimeF.toDateTimeFormatter inFmt 115 | 116 | unformat ∷ Format → String → Either String DateTime 117 | unformat fmt str = FDT.unformat (toDateTimeFormatter fmt) str 118 | 119 | format ∷ Format → DateTime → String 120 | format fmt = FDT.format (toDateTimeFormatter fmt) 121 | 122 | 123 | formatConstraint ∷ C.Constraint (List Command) 124 | formatConstraint 125 | = C.notEmpty 126 | <> C.allowNoneOrOne [ C.EqPred "Date" isDate ] 127 | <> C.allowNoneOrOne [ C.EqPred "Time" isTime ] 128 | where 129 | isDate ∷ Command → Boolean 130 | isDate (Date _) = true 131 | isDate _ = false 132 | 133 | isTime ∷ Command → Boolean 134 | isTime (Time _) = true 135 | isTime _ = false 136 | -------------------------------------------------------------------------------- /src/Halogen/DatePicker/Format/Duration.purs: -------------------------------------------------------------------------------- 1 | module Halogen.Datepicker.Format.Duration 2 | ( module Halogen.Datepicker.Format.Duration 3 | , module ReExport 4 | ) where 5 | 6 | import Prelude 7 | 8 | import Data.Array (fromFoldable, null) 9 | import Data.Either (Either(..)) 10 | import Data.Foldable (class Foldable) 11 | import Data.Formatter.Interval (unformatInterval, formatInterval) 12 | import Data.Generic.Rep (class Generic) 13 | import Data.Interval (DurationComponent(..)) as ReExport 14 | import Data.Interval as I 15 | import Data.Interval.Duration.Iso (IsoDuration) 16 | import Data.Map (insert, lookup) 17 | import Data.Maybe (Maybe) 18 | import Data.Newtype (class Newtype, over, unwrap) 19 | import Data.Show.Generic (genericShow) 20 | import Data.String (joinWith) 21 | import Halogen.Datepicker.Internal.Constraint as C 22 | 23 | 24 | type Command = I.DurationComponent 25 | 26 | newtype Format = Format (Array Command) 27 | derive instance formatNewtype ∷ Newtype Format _ 28 | derive instance formatGeneric ∷ Generic Format _ 29 | derive instance formatEq ∷ Eq Format 30 | derive instance formatOrd ∷ Ord Format 31 | instance formatShow ∷ Show Format where 32 | show = genericShow 33 | 34 | 35 | toSetter ∷ Command → Number → I.Duration → I.Duration 36 | toSetter cmd n d = over I.Duration (insert cmd n) d 37 | 38 | toGetter ∷ Command → I.Duration → Maybe Number 39 | toGetter cmd = unwrap >>> lookup cmd 40 | 41 | mkFormat ∷ ∀ f. Foldable f ⇒ f Command → Either String Format 42 | mkFormat cmds = if (not $ null errs) 43 | then Left $ joinWith "; " errs 44 | else pure $ Format fmt 45 | where 46 | fmt ∷ Array Command 47 | fmt = fromFoldable cmds 48 | errs = C.runConstraint formatConstraint fmt 49 | 50 | unformat ∷ String → Either String IsoDuration 51 | unformat str = unformatInterval str >>= case _ of 52 | I.DurationOnly d → pure d 53 | x → Left $ "unformating of duration string returned wrong result: " <> show x 54 | 55 | format ∷ IsoDuration → String 56 | format = formatInterval <<< I.DurationOnly 57 | 58 | 59 | formatConstraint ∷ ∀ g. Foldable g ⇒ C.Constraint (g Command) 60 | formatConstraint = C.notEmpty <> C.sorted C.Decreasing 61 | -------------------------------------------------------------------------------- /src/Halogen/DatePicker/Format/Interval.purs: -------------------------------------------------------------------------------- 1 | module Halogen.Datepicker.Format.Interval where 2 | 3 | import Data.Interval (Interval) 4 | import Halogen.Datepicker.Format.DateTime as DateTimeF 5 | import Halogen.Datepicker.Format.Duration as DurationF 6 | 7 | type Format = Interval DurationF.Format DateTimeF.Format 8 | -------------------------------------------------------------------------------- /src/Halogen/DatePicker/Format/Time.purs: -------------------------------------------------------------------------------- 1 | module Halogen.Datepicker.Format.Time where 2 | 3 | import Prelude 4 | 5 | import Data.Array (fromFoldable, null) 6 | import Data.DateTime (DateTime(..), time) 7 | import Data.Either (Either(..)) 8 | import Data.Enum (fromEnum, toEnum) 9 | import Data.Foldable (class Foldable, foldMap) 10 | import Data.Formatter.DateTime as FDT 11 | import Data.Generic.Rep (class Generic) 12 | import Data.Maybe (Maybe(..)) 13 | import Data.Newtype (class Newtype) 14 | import Data.Show.Generic (genericShow) 15 | import Data.String (joinWith) 16 | import Data.Time (Time, hour, millisecond, minute, second, setHour, setMillisecond, setMinute, setSecond) 17 | import Data.Traversable (traverse) 18 | import Halogen.Datepicker.Internal.Constraint as C 19 | import Halogen.Datepicker.Internal.Enums (hour12, meridiem, millisecond1, millisecond2, setHour12, setMeridiem, setMillisecond1, setMillisecond2) 20 | 21 | data Command 22 | = Hours24 23 | | Hours12 24 | | Meridiem 25 | | MinutesTwoDigits 26 | | Minutes 27 | | SecondsTwoDigits 28 | | Seconds 29 | | Milliseconds 30 | | MillisecondsTwoDigits 31 | | MillisecondsShort 32 | | Placeholder String 33 | 34 | 35 | derive instance commandGeneric ∷ Generic Command _ 36 | derive instance commandEq ∷ Eq Command 37 | derive instance commandOrd ∷ Ord Command 38 | instance commandShow ∷ Show Command where 39 | show = genericShow 40 | 41 | 42 | newtype Format = Format (Array Command) 43 | derive instance formatNewtype ∷ Newtype Format _ 44 | derive instance formatGeneric ∷ Generic Format _ 45 | instance formatShow ∷ Show Format where 46 | show = genericShow 47 | derive instance formatEq ∷ Eq Format 48 | derive instance formatOrd ∷ Ord Format 49 | 50 | 51 | toSetter ∷ Command → Int → Time → Maybe Time 52 | toSetter cmd n t = case cmd of 53 | Hours24 → toEnum n <#> ( _ `setHour` t) 54 | Hours12 → toEnum n >>= (_ `setHour12` t) 55 | Meridiem → toEnum n >>= (_ `setMeridiem` t) 56 | MinutesTwoDigits → toEnum n <#> ( _ `setMinute` t) 57 | Minutes → toEnum n <#> ( _ `setMinute` t) 58 | SecondsTwoDigits → toEnum n <#> ( _ `setSecond` t) 59 | Seconds → toEnum n <#> ( _ `setSecond` t) 60 | Milliseconds →toEnum n <#> (_ `setMillisecond` t) 61 | MillisecondsTwoDigits → toEnum n >>= (_ `setMillisecond2` t) 62 | MillisecondsShort → toEnum n >>= (_ `setMillisecond1` t) 63 | Placeholder _ → pure t 64 | 65 | toGetter ∷ Command → Time → Maybe Int 66 | toGetter cmd t = case cmd of 67 | Hours24 → Just $ fromEnum $ hour t 68 | Hours12 → Just $ fromEnum $ hour12 t 69 | Meridiem → Just $ fromEnum $ meridiem t 70 | MinutesTwoDigits → Just $ fromEnum $ minute t 71 | Minutes → Just $ fromEnum $ minute t 72 | SecondsTwoDigits → Just $ fromEnum $ second t 73 | Seconds → Just $ fromEnum $ second t 74 | Milliseconds → Just $ fromEnum $ millisecond t 75 | MillisecondsTwoDigits → Just $ fromEnum $ millisecond2 t 76 | MillisecondsShort → Just $ fromEnum $ millisecond1 t 77 | Placeholder _ → Nothing 78 | 79 | 80 | fromString ∷ String → Either String Format 81 | fromString s = FDT.parseFormatString s >>= fromDateTimeFormatter 82 | 83 | fromDateTimeFormatter ∷ FDT.Formatter → Either String Format 84 | fromDateTimeFormatter fmt = do 85 | let errs = C.runConstraint formatConstraint fmt 86 | unless (null errs) $ Left $ joinWith "; " errs 87 | case traverse toCommand fmt of 88 | Just fmt' → pure $ Format $ fromFoldable fmt' 89 | Nothing → Left "(unreachable) invalid FormatterCommand has leaked while checking constraints" 90 | 91 | toCommand ∷ FDT.FormatterCommand → Maybe Command 92 | toCommand = case _ of 93 | FDT.Hours24 → Just Hours24 94 | FDT.Hours12 → Just Hours12 95 | FDT.Meridiem → Just Meridiem 96 | FDT.MinutesTwoDigits → Just MinutesTwoDigits 97 | FDT.Minutes → Just Minutes 98 | FDT.SecondsTwoDigits → Just SecondsTwoDigits 99 | FDT.Seconds → Just Seconds 100 | FDT.Milliseconds → Just Milliseconds 101 | FDT.MillisecondsTwoDigits → Just MillisecondsTwoDigits 102 | FDT.MillisecondsShort → Just MillisecondsShort 103 | FDT.Placeholder str → Just $ Placeholder str 104 | _ → Nothing 105 | 106 | toDateTimeFormatter ∷ Format → FDT.Formatter 107 | toDateTimeFormatter (Format fmt) = foldMap (pure <<< toDTCommand) fmt 108 | 109 | toDTCommand ∷ Command → FDT.FormatterCommand 110 | toDTCommand = case _ of 111 | Hours24 → FDT.Hours24 112 | Hours12 → FDT.Hours12 113 | Meridiem → FDT.Meridiem 114 | MinutesTwoDigits → FDT.MinutesTwoDigits 115 | Minutes → FDT.Minutes 116 | SecondsTwoDigits → FDT.SecondsTwoDigits 117 | Seconds → FDT.Seconds 118 | Milliseconds → FDT.Milliseconds 119 | MillisecondsTwoDigits → FDT.MillisecondsTwoDigits 120 | MillisecondsShort → FDT.MillisecondsShort 121 | Placeholder str → FDT.Placeholder str 122 | 123 | unformat ∷ Format → String → Either String Time 124 | unformat fmt str = FDT.unformat (toDateTimeFormatter fmt) str <#> time 125 | 126 | format ∷ Format → Time → String 127 | format fmt = FDT.format (toDateTimeFormatter fmt) <<< toDateTime 128 | where 129 | toDateTime ∷ Time → DateTime 130 | toDateTime = DateTime bottom 131 | 132 | 133 | formatConstraint ∷ ∀ g. Foldable g ⇒ C.Constraint (g FDT.FormatterCommand) 134 | formatConstraint 135 | = C.notEmpty 136 | <> C.allowedValues FDT.printFormatterCommand allowedCommands 137 | <> C.allowNoneOrOne (C.reShow FDT.printFormatterCommand <$> [FDT.Milliseconds, FDT.MillisecondsTwoDigits, FDT.MillisecondsShort]) 138 | <> C.allowNoneOrOne (C.reShow FDT.printFormatterCommand <$> [FDT.SecondsTwoDigits, FDT.Seconds]) 139 | <> C.allowNoneOrOne (C.reShow FDT.printFormatterCommand <$> [FDT.MinutesTwoDigits, FDT.Minutes]) 140 | <> C.allowNoneOrOne (C.reShow FDT.printFormatterCommand <$> [FDT.Hours24, FDT.Hours12]) 141 | <> C.allowNoneOrOne (C.reShow FDT.printFormatterCommand <$> [FDT.Hours24, FDT.Meridiem]) 142 | <> C.allowNoneOrAll (C.reShow FDT.printFormatterCommand <$> [FDT.Hours12, FDT.Meridiem]) 143 | where 144 | allowedCommands = (C.reShow FDT.printFormatterCommand <$> 145 | [ FDT.Hours24 146 | , FDT.Hours12 147 | , FDT.Meridiem 148 | , FDT.MinutesTwoDigits 149 | , FDT.Minutes 150 | , FDT.SecondsTwoDigits 151 | , FDT.Seconds 152 | , FDT.Milliseconds 153 | , FDT.MillisecondsTwoDigits 154 | , FDT.MillisecondsShort 155 | ]) <> 156 | [ C.EqPred 157 | "'Placeholder'" 158 | case _ of 159 | FDT.Placeholder _ → true 160 | _ → false 161 | ] 162 | -------------------------------------------------------------------------------- /src/Halogen/DatePicker/Internal/Choice.purs: -------------------------------------------------------------------------------- 1 | module Halogen.Datepicker.Internal.Choice where 2 | 3 | import Prelude 4 | 5 | import Control.Monad.Error.Class (class MonadError, throwError) 6 | import Data.Array (cons) 7 | import Data.Enum (class BoundedEnum, fromEnum, toEnum) 8 | import Data.Foldable (elem, for_) 9 | import Data.Int as Int 10 | import Data.Maybe (Maybe(..), maybe) 11 | import Data.NonEmpty (NonEmpty, fromNonEmpty, head, tail) 12 | import Data.Number as N 13 | import Effect.Exception as Ex 14 | import Halogen as H 15 | import Halogen.Datepicker.Component.Types (BasePickerQuery(..)) 16 | import Halogen.HTML as HH 17 | import Halogen.HTML.Events as HE 18 | import Halogen.HTML.Properties as HP 19 | import Halogen.Query.HalogenM (HalogenM) 20 | 21 | type State val = {value ∷ val} 22 | 23 | type Query val = BasePickerQuery (Maybe ChoiceError) val 24 | data ChoiceError = ValueIsNotInValues 25 | 26 | type Slots ∷ ∀ k. Row k 27 | type Slots = () 28 | 29 | type Slot val = H.Slot (Query val) val 30 | 31 | type DSL val = H.HalogenM (State val) (Maybe val) Slots val 32 | type HTML val m = H.ComponentHTML (Maybe val) Slots m 33 | 34 | type Config val = 35 | { title ∷ String 36 | , values ∷ NonEmpty Array val 37 | , root ∷ Array HH.ClassName 38 | } 39 | 40 | picker 41 | ∷ ∀ val m 42 | . Ord val 43 | ⇒ HasChoiceInputVal val 44 | → Config val 45 | → H.Component (Query val) Unit val m 46 | picker hasChoiceInputVal config = 47 | H.mkComponent 48 | { initialState: const { value: head config.values } 49 | , render: render config hasChoiceInputVal 50 | , eval: H.mkEval $ H.defaultEval 51 | { handleAction = handleAction 52 | , handleQuery = handleQuery config.values 53 | } 54 | } 55 | 56 | render 57 | ∷ ∀ val m 58 | . Eq val 59 | ⇒ Config val 60 | → HasChoiceInputVal val 61 | → State val 62 | → HTML val m 63 | render config hasChoiceInputVal {value} = 64 | HH.select 65 | [ HP.title config.title 66 | , HP.classes config.root 67 | , HE.onValueChange hasChoiceInputVal.fromString 68 | ] (fromNonEmpty cons config.values <#> renderValue) 69 | where 70 | renderValue value' = HH.option 71 | [ HP.value $ hasChoiceInputVal.toValue value' 72 | , HP.selected (value' == value) 73 | ] 74 | [ HH.text $ hasChoiceInputVal.toTitle value' ] 75 | 76 | handleAction ∷ ∀ val m. Eq val ⇒ Maybe val → DSL val m Unit 77 | handleAction value = do 78 | s ← H.get 79 | -- there wouldn't be case when value is Nothing so it's fine to do `for_` 80 | for_ value \value' → do 81 | H.modify_ _{value = value'} 82 | when (value' /= s.value) $ H.raise value' 83 | 84 | handleQuery 85 | ∷ ∀ val m a 86 | . Eq val 87 | ⇒ NonEmpty Array val 88 | → Query val a 89 | → DSL val m (Maybe a) 90 | handleQuery values = case _ of 91 | SetValue value k 92 | | value == head values || elem value (tail values) → do 93 | H.modify_ _{value = value} 94 | pure $ Just $ k Nothing 95 | | otherwise → 96 | pure $ Just $ k (Just ValueIsNotInValues) 97 | GetValue k → 98 | Just <<< k <$> H.gets _.value 99 | 100 | type HasChoiceInputVal a = 101 | { fromString ∷ String → Maybe a 102 | , toValue ∷ a → String 103 | , toTitle ∷ a → String 104 | } 105 | 106 | stringHasChoiceInputVal ∷ HasChoiceInputVal String 107 | stringHasChoiceInputVal = 108 | { fromString: pure 109 | , toValue: identity 110 | , toTitle: identity 111 | } 112 | 113 | numberHasChoiceInputVal ∷ HasChoiceInputVal Number 114 | numberHasChoiceInputVal = 115 | { fromString: N.fromString 116 | , toValue: show 117 | , toTitle: show 118 | } 119 | 120 | intHasChoiceInputVal ∷ HasChoiceInputVal Int 121 | intHasChoiceInputVal = 122 | { fromString: Int.fromString 123 | , toValue: show 124 | , toTitle: show 125 | } 126 | 127 | boundedEnumHasChoiceInputVal 128 | ∷ ∀ a 129 | . BoundedEnum a 130 | ⇒ (a → String) 131 | → HasChoiceInputVal a 132 | boundedEnumHasChoiceInputVal showTitle = 133 | { fromString: intHasChoiceInputVal.fromString >=> toEnum 134 | , toValue: fromEnum >>> intHasChoiceInputVal.toValue 135 | , toTitle: showTitle 136 | } 137 | 138 | maybeIntHasChoiceInputVal 139 | ∷ (Maybe Int → String) 140 | → HasChoiceInputVal (Maybe Int) 141 | maybeIntHasChoiceInputVal showTitle = 142 | { fromString: \str → if str == "" 143 | then pure Nothing 144 | else intHasChoiceInputVal.fromString str <#> pure 145 | , toValue: maybe "" show 146 | , toTitle: showTitle 147 | } 148 | 149 | maybeBoundedEnumHasChoiceInputVal 150 | ∷ ∀ a 151 | . BoundedEnum a 152 | ⇒ (a → String) 153 | → HasChoiceInputVal (Maybe a) 154 | maybeBoundedEnumHasChoiceInputVal showTitle = 155 | { fromString: \str → if str == "" 156 | then pure Nothing 157 | else intHasChoiceInputVal.fromString str <#> toEnum 158 | , toValue: maybe "" (show <<< fromEnum) 159 | , toTitle: maybe "" showTitle 160 | } 161 | 162 | valueMustBeInValues 163 | ∷ ∀ s f ps o m 164 | . MonadError Ex.Error m 165 | ⇒ Maybe ChoiceError 166 | → HalogenM s f ps o m Unit 167 | valueMustBeInValues = case _ of 168 | Just ValueIsNotInValues → 169 | throwError $ Ex.error "Value being set in Choice is not in values" 170 | Nothing → 171 | pure unit 172 | -------------------------------------------------------------------------------- /src/Halogen/DatePicker/Internal/Constraint.purs: -------------------------------------------------------------------------------- 1 | module Halogen.Datepicker.Internal.Constraint where 2 | 3 | import Prim hiding (Constraint) 4 | 5 | import Prelude 6 | 7 | import Control.Monad.State (State, get, put, execState) 8 | import Data.Foldable (class Foldable, any, null, length, for_) 9 | import Data.List as List 10 | import Data.Validation.Semigroup (V, invalid, validation) 11 | 12 | 13 | data Error 14 | = ContainsInvalidValue String 15 | | ShouldBeNonEmpty 16 | | ShouldBeSorted 17 | | UsageCountShouldBeNoneOrOne { count ∷ Int, alowed∷ String } 18 | | UsageCountShouldBeNoneOrAll { count ∷ Int, alowed∷ String } 19 | 20 | showError ∷ Error → String 21 | showError = case _ of 22 | ContainsInvalidValue val → 23 | "Contains value: " <> val <> " which is not allowed" 24 | ShouldBeNonEmpty → 25 | "Input must contain values" 26 | ShouldBeSorted → 27 | "Input Must be sorted" 28 | UsageCountShouldBeNoneOrOne { count, alowed } → 29 | "Usage count (" <> show count <> ") for allowed elements (" <> alowed <> ") must be 0 or 1" 30 | UsageCountShouldBeNoneOrAll { count, alowed } → 31 | "Usage count (" <> show count <> ") for allowed elements (" <> alowed <> ") must be 0 or all" 32 | 33 | type Constraint a = a → V (Array Error) Unit 34 | 35 | runConstraint ∷ ∀ a g. Constraint (g a) → g a → Array String 36 | runConstraint f a = validation (map showError) (const []) $ f a 37 | 38 | allowedValues ∷ ∀ g a. Foldable g ⇒ (a → String) → Array (EqPred a) → Constraint (g a) 39 | allowedValues showVal as as' = for_ as' \a → unless 40 | (matchesAny a as) 41 | (invalid [ContainsInvalidValue $ showVal a]) 42 | 43 | notEmpty ∷ ∀ f a. Foldable f ⇒ Constraint (f a) 44 | notEmpty as = when (null as) (invalid [ShouldBeNonEmpty]) 45 | 46 | data Sorting = Increasing | Decreasing 47 | 48 | sorted ∷ ∀ f a. Ord a ⇒ Foldable f ⇒ Sorting → Constraint (f a) 49 | sorted sorting as = unless isSorted (invalid [ShouldBeSorted]) 50 | where 51 | isSorted = case sorting of 52 | Increasing → asList == List.sort asList 53 | Decreasing → List.reverse asList == List.sort asList 54 | asList = List.fromFoldable as 55 | 56 | 57 | allowNoneOrOne ∷ ∀ g a. Foldable g ⇒ Array (EqPred a) → Constraint (g a) 58 | allowNoneOrOne as = usageCount as >>> \c → when 59 | (c > 1) 60 | (invalid [UsageCountShouldBeNoneOrOne { count: c, alowed: show as }]) 61 | 62 | allowNoneOrAll ∷ ∀ f a. Foldable f ⇒ Array (EqPred a) → Constraint (f a) 63 | allowNoneOrAll as = usageCount as >>> \c → when 64 | (c /= 0 && c /= length as) 65 | (invalid [UsageCountShouldBeNoneOrOne { count: c, alowed: show as }]) 66 | 67 | matchesAny ∷ ∀ a . a → Array (EqPred a) → Boolean 68 | matchesAny = any <<< equals 69 | 70 | usageCount ∷ ∀ f a. Foldable f ⇒ Array (EqPred a) → f a → Int 71 | usageCount as as' = for_ as' incState `execState` 0 72 | where 73 | incState ∷ a → State Int Unit 74 | incState a = get >>= \count → when (matchesAny a as) (put $ count + 1) 75 | 76 | 77 | data EqPred a = EqPred String (a → Boolean) 78 | 79 | instance predShow ∷ Show (EqPred a) where 80 | show (EqPred str _)= str 81 | 82 | equals ∷ ∀ a . a → EqPred a → Boolean 83 | equals a (EqPred _ p) = p a 84 | 85 | reShow ∷ ∀ a . Eq a ⇒ (a → String) → a → EqPred a 86 | reShow f a = EqPred (f a) (_ == a) 87 | 88 | pred ∷ ∀ a . Eq a ⇒ Show a ⇒ a → EqPred a 89 | pred = reShow show 90 | -------------------------------------------------------------------------------- /src/Halogen/DatePicker/Internal/Elements.purs: -------------------------------------------------------------------------------- 1 | module Halogen.Datepicker.Internal.Elements where 2 | 3 | import Prelude 4 | 5 | import Data.Enum (class BoundedEnum, fromEnum, toEnum) 6 | import Data.Maybe (Maybe, fromMaybe, maybe) 7 | import Data.Newtype (unwrap) 8 | import Data.NonEmpty (NonEmpty) 9 | import Data.Symbol (class IsSymbol) 10 | import Halogen as H 11 | import Halogen.Datepicker.Config (Config(..)) 12 | import Halogen.Datepicker.Internal.Choice as Choice 13 | import Halogen.Datepicker.Internal.Num as Num 14 | import Halogen.Datepicker.Internal.Range (Range) 15 | import Halogen.HTML as HH 16 | import Halogen.HTML.Properties as HP 17 | import Prim.Row as Row 18 | import Type.Proxy (Proxy) 19 | 20 | textElement ∷ ∀ p i. Config → {text ∷ String} → HH.HTML p i 21 | textElement (Config {placeholder}) {text} = HH.span [HP.classes placeholder] [HH.text text] 22 | 23 | type PreNumConfig a = {title ∷ String, placeholder ∷ String, range ∷ Range a} 24 | type PreChoiceConfig a = {title ∷ String, values ∷ NonEmpty Array a} 25 | 26 | toNumConf 27 | ∷ ∀ a 28 | . Config 29 | → PreNumConfig a 30 | → Num.Config a 31 | toNumConf (Config {input, inputInvalid, inputLength}) ({title, placeholder, range}) = 32 | {title, placeholder, range, root: input, rootInvalid: inputInvalid, rootLength: inputLength } 33 | 34 | type OptionalUpdate a = a → Maybe a 35 | 36 | renderNum 37 | ∷ ∀ m sym cmd px ps queryVal 38 | . Row.Cons sym ((Num.Slot Int) cmd) px ps 39 | ⇒ IsSymbol sym 40 | ⇒ Ord cmd 41 | ⇒ Proxy sym 42 | → (cmd → Int → OptionalUpdate queryVal) 43 | → cmd 44 | → Config 45 | → PreNumConfig Int 46 | → H.ComponentHTML (OptionalUpdate queryVal) ps m 47 | renderNum sym toSetter cmd mainConf preConf = 48 | let 49 | conf = toNumConf mainConf preConf 50 | in 51 | HH.slot sym cmd 52 | (Num.picker Num.intHasNumberInputVal conf) unit 53 | (\n t → n >>= (_ `toSetter cmd` t)) 54 | 55 | toChoiceConf 56 | ∷ ∀ a 57 | . Config 58 | → PreChoiceConfig a 59 | → Choice.Config a 60 | toChoiceConf (Config {choice}) ({title, values}) = 61 | {title, values, root: choice } 62 | 63 | renderChoice 64 | ∷ ∀ a m sym cmd px ps queryVal 65 | . BoundedEnum a 66 | ⇒ Show a 67 | ⇒ Row.Cons sym ((Choice.Slot (Maybe Int)) cmd) px ps 68 | ⇒ IsSymbol sym 69 | ⇒ Ord cmd 70 | ⇒ Proxy sym 71 | → (cmd → Int → OptionalUpdate queryVal) 72 | → cmd 73 | → Config 74 | → PreChoiceConfig (Maybe a) 75 | → H.ComponentHTML (OptionalUpdate queryVal) ps m 76 | renderChoice cpChoice toSetter cmd mainConf preConf = 77 | let 78 | conf = toChoiceConf mainConf preConf 79 | emptyVal = case mainConf of 80 | Config {choiceEmptyTitle} → fromMaybe "" $ unwrap choiceEmptyTitle 81 | in 82 | HH.slot cpChoice cmd 83 | ( Choice.picker 84 | (Choice.maybeIntHasChoiceInputVal \n → ((n >>= toEnum) ∷ Maybe a) # maybe emptyVal show) 85 | (conf{values = conf.values <#> map fromEnum}) 86 | ) 87 | unit 88 | (\n t → n >>= (_ `toSetter cmd` t)) 89 | -------------------------------------------------------------------------------- /src/Halogen/DatePicker/Internal/Enums.purs: -------------------------------------------------------------------------------- 1 | module Halogen.Datepicker.Internal.Enums where 2 | 3 | import Prelude 4 | 5 | import Data.Date (Date, Year, Month, Day, year, month, day, exactDate) 6 | import Data.Enum (class Enum, class BoundedEnum, Cardinality(..), cardinality, toEnum, fromEnum, defaultSucc, defaultPred) 7 | import Data.Generic.Rep (class Generic) 8 | import Data.Maybe (Maybe(..)) 9 | import Data.Newtype (class Newtype, unwrap) 10 | import Data.Show.Generic (genericShow) 11 | import Data.String as Str 12 | import Data.Time (Time, hour, millisecond, setHour, setMillisecond) 13 | 14 | 15 | meridiem ∷ Time → Meridiem 16 | meridiem = hour >>> fromEnum >>> \h → if h >= 12 then PM else AM 17 | 18 | setMeridiem ∷ Meridiem → Time → Maybe Time 19 | setMeridiem m t = newHour <#> (_ `setHour` t) 20 | where 21 | h = fromEnum (hour t) 22 | newHour = toEnum case m of 23 | AM → if h > 12 then h - 12 else h 24 | PM → if h < 12 then h + 12 else h 25 | 26 | data Meridiem = AM | PM 27 | derive instance meridiemEq ∷ Eq Meridiem 28 | derive instance meridiemOrd ∷ Ord Meridiem 29 | instance meridiemShow ∷ Show Meridiem where 30 | show AM = "AM" 31 | show PM = "PM" 32 | 33 | instance meridiemBounded ∷ Bounded Meridiem where 34 | bottom = AM 35 | top = PM 36 | 37 | instance meridiemEnum ∷ Enum Meridiem where 38 | pred PM = Just AM 39 | pred _ = Nothing 40 | succ AM = Just PM 41 | succ _ = Nothing 42 | 43 | instance meridiemBoundedEnum ∷ BoundedEnum Meridiem where 44 | cardinality = Cardinality 2 45 | toEnum 1 = Just AM 46 | toEnum 2 = Just PM 47 | toEnum _ = Nothing 48 | fromEnum AM = 1 49 | fromEnum PM = 2 50 | 51 | 52 | hour12 ∷ Time → Hour12 53 | hour12 = hour >>> fromEnum >>> (\h → if h >= 12 then h - 12 else h) >>> Hour12 54 | 55 | setHour12 ∷ Hour12 → Time → Maybe Time 56 | setHour12 (Hour12 h) t = (_ `setHour` t) <$> 57 | toEnum (if (fromEnum $ hour t) < 12 then h else h + 12) 58 | 59 | 60 | newtype Hour12 = Hour12 Int 61 | 62 | derive instance hour12Newtype ∷ Newtype Hour12 _ 63 | derive instance hour12Generic ∷ Generic Hour12 _ 64 | derive instance hour12Eq ∷ Eq Hour12 65 | derive instance hour12Ord ∷ Ord Hour12 66 | 67 | instance hour12Bounded ∷ Bounded Hour12 where 68 | bottom = Hour12 0 69 | top = Hour12 11 70 | 71 | instance hour12Enum ∷ Enum Hour12 where 72 | succ = defaultSucc toEnum fromEnum 73 | pred = defaultPred toEnum fromEnum 74 | 75 | instance hour12BoundedEnum ∷ BoundedEnum Hour12 where 76 | cardinality = Cardinality 12 77 | toEnum n | n >= 0 && n <= 11 = Just $ Hour12 n 78 | toEnum _ = Nothing 79 | fromEnum = unwrap 80 | 81 | instance hour12Show ∷ Show Hour12 where 82 | show = genericShow 83 | 84 | millisecond2 ∷ Time → Millisecond2 85 | millisecond2 = millisecond >>> fromEnum >>> (_ / 10) >>> Millisecond2 86 | 87 | setMillisecond2 ∷ Millisecond2 → Time → Maybe Time 88 | setMillisecond2 (Millisecond2 ms) t = toEnum (ms * 10) <#> (_ `setMillisecond` t) 89 | 90 | 91 | newtype Millisecond2 = Millisecond2 Int 92 | derive instance millisecond2Newtype ∷ Newtype Millisecond2 _ 93 | derive instance millisecond2Generic ∷ Generic Millisecond2 _ 94 | derive instance millisecond2Eq ∷ Eq Millisecond2 95 | derive instance millisecond2Ord ∷ Ord Millisecond2 96 | 97 | instance millisecond2Bounded ∷ Bounded Millisecond2 where 98 | bottom = Millisecond2 0 99 | top = Millisecond2 99 100 | 101 | instance millisecond2Enum ∷ Enum Millisecond2 where 102 | succ = defaultSucc toEnum fromEnum 103 | pred = defaultPred toEnum fromEnum 104 | 105 | instance millisecond2BoundedEnum ∷ BoundedEnum Millisecond2 where 106 | cardinality = Cardinality 100 107 | toEnum n | n >= 0 && n <= 99 = Just $ Millisecond2 n 108 | toEnum _ = Nothing 109 | fromEnum = unwrap 110 | 111 | instance millisecond2Show ∷ Show Millisecond2 where 112 | show = genericShow 113 | 114 | 115 | millisecond1 ∷ Time → Millisecond1 116 | millisecond1 = millisecond >>> fromEnum >>> (_ / 100) >>> Millisecond1 117 | 118 | setMillisecond1 ∷ Millisecond1 → Time → Maybe Time 119 | setMillisecond1 (Millisecond1 ms) t = toEnum (ms * 100) <#> (_ `setMillisecond` t) 120 | 121 | 122 | newtype Millisecond1 = Millisecond1 Int 123 | derive instance millisecond1Newtype ∷ Newtype Millisecond1 _ 124 | derive instance millisecond1Generic ∷ Generic Millisecond1 _ 125 | derive instance millisecond1Eq ∷ Eq Millisecond1 126 | derive instance millisecond1Ord ∷ Ord Millisecond1 127 | 128 | instance millisecond1Bounded ∷ Bounded Millisecond1 where 129 | bottom = Millisecond1 0 130 | top = Millisecond1 9 131 | 132 | instance millisecond1Enum ∷ Enum Millisecond1 where 133 | succ = defaultSucc toEnum fromEnum 134 | pred = defaultPred toEnum fromEnum 135 | 136 | instance millisecond1BoundedEnum ∷ BoundedEnum Millisecond1 where 137 | cardinality = Cardinality 10 138 | toEnum n | n >= 0 && n <= 9 = Just $ Millisecond1 n 139 | toEnum _ = Nothing 140 | fromEnum = unwrap 141 | 142 | instance millisecond1Show ∷ Show Millisecond1 where 143 | show = genericShow 144 | 145 | 146 | monthShort ∷ Date → MonthShort 147 | monthShort = month >>> MonthShort 148 | 149 | 150 | newtype MonthShort = MonthShort Month 151 | derive instance monthShortNewtype ∷ Newtype MonthShort _ 152 | derive instance monthShortGeneric ∷ Generic MonthShort _ 153 | derive instance monthShortEq ∷ Eq MonthShort 154 | derive instance monthShortOrd ∷ Ord MonthShort 155 | 156 | instance monthShortBounded ∷ Bounded MonthShort where 157 | bottom = MonthShort bottom 158 | top = MonthShort top 159 | 160 | instance monthShortEnum ∷ Enum MonthShort where 161 | succ = defaultSucc toEnum fromEnum 162 | pred = defaultPred toEnum fromEnum 163 | 164 | instance monthShortBoundedEnum ∷ BoundedEnum MonthShort where 165 | cardinality = Cardinality $ unwrap (cardinality ∷ Cardinality Month) 166 | toEnum n = toEnum n <#> MonthShort 167 | fromEnum (MonthShort m) = fromEnum m 168 | 169 | instance monthShortShow ∷ Show MonthShort where 170 | show (MonthShort m) = Str.take 3 $ show m 171 | 172 | year2 ∷ Date → Year2 173 | year2 = year >>> fromEnum >>> \y → Year2 $ y - (y `unPrecise` 100) 174 | 175 | setYear2 ∷ Year2 → Date → Maybe Date 176 | setYear2 (Year2 n) d = toEnum (((fromEnum $ year d) `unPrecise` 100) + n) >>= (_ `setYear` d) 177 | 178 | newtype Year2 = Year2 Int 179 | derive instance year2Newtype ∷ Newtype Year2 _ 180 | derive instance year2Generic ∷ Generic Year2 _ 181 | derive instance year2Eq ∷ Eq Year2 182 | derive instance year2Ord ∷ Ord Year2 183 | 184 | instance year2Bounded ∷ Bounded Year2 where 185 | bottom = Year2 0 186 | top = Year2 99 187 | 188 | instance year2Enum ∷ Enum Year2 where 189 | succ = defaultSucc toEnum fromEnum 190 | pred = defaultPred toEnum fromEnum 191 | 192 | instance year2BoundedEnum ∷ BoundedEnum Year2 where 193 | cardinality = Cardinality 100 194 | toEnum n | n >= 0 && n <= 99 = Just $ Year2 n 195 | toEnum _ = Nothing 196 | fromEnum = unwrap 197 | 198 | instance year2Show ∷ Show Year2 where 199 | show = genericShow 200 | 201 | 202 | year4 ∷ Date → Year4 203 | year4 = year >>> fromEnum >>> \y → Year4 $ y - (y `unPrecise` 10000) 204 | 205 | setYear4 ∷ Year4 → Date → Maybe Date 206 | setYear4 (Year4 n) d = toEnum n >>= (_ `setYear` d) 207 | 208 | 209 | newtype Year4 = Year4 Int 210 | derive instance year4Newtype ∷ Newtype Year4 _ 211 | derive instance year4Generic ∷ Generic Year4 _ 212 | derive instance year4Eq ∷ Eq Year4 213 | derive instance year4Ord ∷ Ord Year4 214 | 215 | instance year4Bounded ∷ Bounded Year4 where 216 | bottom = Year4 0 217 | top = Year4 9999 218 | 219 | instance year4Enum ∷ Enum Year4 where 220 | succ = defaultSucc toEnum fromEnum 221 | pred = defaultPred toEnum fromEnum 222 | 223 | instance year4BoundedEnum ∷ BoundedEnum Year4 where 224 | cardinality = Cardinality 10000 225 | toEnum n | n >= 0 && n <= 9999 = Just $ Year4 n 226 | toEnum _ = Nothing 227 | fromEnum = unwrap 228 | 229 | instance year4Show ∷ Show Year4 where 230 | show = genericShow 231 | 232 | 233 | setYear ∷ Year → Date → Maybe Date 234 | setYear a d = exactDate a (month d) (day d) 235 | 236 | setMonth ∷ Month → Date → Maybe Date 237 | setMonth a d = exactDate (year d) a (day d) 238 | 239 | setDay ∷ Day → Date → Maybe Date 240 | setDay a d = exactDate (year d) (month d) a 241 | 242 | -- > (123456789 `unPrecise` 1000) == 123456000 243 | unPrecise ∷ Int → Int → Int 244 | unPrecise n by = n / by * by 245 | -------------------------------------------------------------------------------- /src/Halogen/DatePicker/Internal/Num.purs: -------------------------------------------------------------------------------- 1 | module Halogen.Datepicker.Internal.Num where 2 | 3 | import Prelude 4 | 5 | import CSS as CSS 6 | import Control.Alternative (class Alternative, empty) 7 | import Control.Monad.Except (runExcept) 8 | import Control.MonadPlus (guard) 9 | import Data.Bifunctor (lmap) 10 | import Data.Enum (class BoundedEnum, fromEnum, toEnum) 11 | import Data.Int as Int 12 | import Data.Maybe (Maybe(..), fromMaybe, maybe) 13 | import Data.Number as N 14 | import Data.String (Pattern(..), length, stripSuffix) 15 | import Data.Tuple (Tuple(..), fst) 16 | import Foreign (readBoolean, readString, unsafeToForeign) 17 | import Foreign.Index (readProp) 18 | import Halogen as H 19 | import Halogen.Datepicker.Component.Types (BasePickerQuery(..)) 20 | import Halogen.Datepicker.Internal.Range (Range(..), isInRange, rangeMax, rangeMin) 21 | import Halogen.Datepicker.Internal.Utils (asRight) 22 | import Halogen.HTML as HH 23 | import Halogen.HTML.CSS as HCSS 24 | import Halogen.HTML.Core (ClassName) 25 | import Halogen.HTML.Events as HE 26 | import Halogen.HTML.Properties as HP 27 | import Web.Event.Event (Event) 28 | 29 | type State val = InputValue val 30 | 31 | type Message val = Maybe val 32 | type Input val = Maybe val 33 | 34 | type Query val = BasePickerQuery Unit (Input val) 35 | type InputValue val = Tuple (Maybe val) (Maybe String) 36 | 37 | type Slots ∷ ∀ k. Row k 38 | type Slots = () 39 | 40 | type Slot val = H.Slot (Query val) (Message val) 41 | 42 | type DSL val = H.HalogenM (State val) (InputValue val) Slots (Message val) 43 | type HTML val m = H.ComponentHTML (InputValue val) Slots m 44 | 45 | type Config val = 46 | { title ∷ String 47 | , placeholder ∷ String 48 | , range ∷ Range val 49 | , root ∷ Array ClassName 50 | , rootInvalid ∷ Array ClassName 51 | , rootLength ∷ Int → Array ClassName 52 | } 53 | 54 | picker 55 | ∷ ∀ val m 56 | . Ord val 57 | ⇒ HasNumberInputVal val 58 | → Config val 59 | → H.Component (Query val) Unit (Message val) m 60 | picker hasNumberInputVal conf = 61 | H.mkComponent 62 | { initialState: const emptyNumberInputValue 63 | , render: render hasNumberInputVal conf 64 | , eval: H.mkEval $ H.defaultEval 65 | { handleAction = handleAction 66 | , handleQuery = handleQuery hasNumberInputVal 67 | } 68 | } 69 | 70 | render 71 | ∷ ∀ val m 72 | . Ord val 73 | ⇒ HasNumberInputVal val 74 | → Config val 75 | → State val 76 | → HTML val m 77 | render hasNumberInputVal conf num = numberElement hasNumberInputVal conf num 78 | 79 | handleAction ∷ ∀ val m. Eq val ⇒ InputValue val → DSL val m Unit 80 | handleAction number = do 81 | prevNumber ← H.get 82 | H.put number 83 | unless (number == prevNumber) $ H.raise (fst number) 84 | 85 | toMbString 86 | ∷ ∀ a 87 | . HasNumberInputVal a 88 | → Maybe a 89 | → Maybe String 90 | toMbString hasNumberInputVal number = (Just $ maybe "" hasNumberInputVal.toValue number) 91 | 92 | handleQuery ∷ ∀ val m a. HasNumberInputVal val → Query val a → DSL val m (Maybe a) 93 | handleQuery hasNumberInputVal = case _ of 94 | SetValue number k → do 95 | H.put $ Tuple number (toMbString hasNumberInputVal number) 96 | pure $ Just (k unit) 97 | GetValue k → 98 | Just <<< k <<< fst <$> H.get 99 | 100 | toString ∷ ∀ a. InputValue a → String 101 | toString (Tuple _ mbStr) = fromMaybe "" mbStr 102 | 103 | mkInputValue ∷ ∀ a. HasNumberInputVal a → a → InputValue a 104 | mkInputValue hasNumberInputVal n = 105 | Tuple (Just n) (Just $ hasNumberInputVal.toValue n) 106 | 107 | emptyNumberInputValue ∷ ∀ a. InputValue a 108 | emptyNumberInputValue = Tuple Nothing (Just "") 109 | 110 | isInvalid ∷ ∀ a. InputValue a → Boolean 111 | isInvalid (Tuple Nothing (Just "")) = false 112 | isInvalid (Tuple Nothing (Just _)) = true 113 | isInvalid (Tuple _ Nothing) = true 114 | isInvalid _ = false 115 | 116 | isEmpty ∷ ∀ a. InputValue a → Boolean 117 | isEmpty (Tuple _ (Just "")) = true 118 | isEmpty _ = false 119 | 120 | showNum ∷ Number → String 121 | showNum 0.0 = "0" 122 | showNum n = let str = show n 123 | in fromMaybe str (stripSuffix (Pattern ".0") str) 124 | 125 | numberElement 126 | ∷ ∀ val m 127 | . Ord val 128 | ⇒ HasNumberInputVal val 129 | → Config val 130 | → InputValue val 131 | → HTML val m 132 | numberElement hasNumberInputVal conf value = HH.input $ 133 | [ HP.type_ HP.InputNumber 134 | , HP.classes classes 135 | , HP.title conf.title 136 | , HP.placeholder conf.placeholder 137 | , HP.value valueStr 138 | , HE.onInput \val → isInputInRange conf.range (parseValidInput (inputValueFromEvent val)) 139 | ] 140 | <> (toArray (rangeMin conf.range) <#> hasNumberInputVal.toNumber >>> HP.min) 141 | <> (toArray (rangeMax conf.range) <#> hasNumberInputVal.toNumber >>> HP.max) 142 | <> [styles] 143 | where 144 | toArray = maybe [] pure 145 | -- Number and String value must comute (`map toValue (fromString x) == Just x`) 146 | -- to avoid this issues: 147 | -- * if user types `-0` we will parse it as `0` or 148 | -- * if user types `001` we will parse it as `1` or 149 | -- * if user types `0.1111111111111111111111` we will parse it as `0.1111111111111111` or 150 | -- * if user types `1e1` we will parse it as `10` 151 | parseValidInput ∷ InputValue String → InputValue val 152 | parseValidInput = lmap $ (=<<) \str → do 153 | val ← hasNumberInputVal.fromString str 154 | guard (hasNumberInputVal.toValue val == str) 155 | pure val 156 | 157 | valueStr = toString value 158 | sizeClass = case conf.range of 159 | MinMax minVal maxVal → 160 | conf.rootLength (max 161 | (length $ hasNumberInputVal.toValue minVal) 162 | (length $ hasNumberInputVal.toValue maxVal) 163 | ) 164 | _ → [] 165 | classes = conf.root 166 | <> sizeClass 167 | <> (guard (isInvalid value) *> conf.rootInvalid) 168 | controlWidth = 0.75 169 | styles = HCSS.style do 170 | case conf.range of 171 | MinMax _ _ → pure unit 172 | _ | isInvalid value → pure unit 173 | _ | isEmpty value → CSS.width $ CSS.em 2.25 174 | _ → CSS.width $ CSS.em (Int.toNumber (length valueStr) * 0.5 + 1.0 + controlWidth) 175 | 176 | 177 | -- We need to validate if value is in range manually as for example, 178 | -- if `min = 0`, user still can enter `-1` in chrome. 179 | isInputInRange ∷ ∀ a. Ord a ⇒ Range a → InputValue a → InputValue a 180 | isInputInRange range val = lmap (_ >>= boolToAltPredicate (isInRange range)) val 181 | 182 | boolToAltPredicate ∷ ∀ a f. Alternative f ⇒ (a → Boolean) → a → f a 183 | boolToAltPredicate f a = if f a then pure a else empty 184 | 185 | inputValueFromEvent ∷ Event → InputValue String 186 | inputValueFromEvent event = let val = validValueFromEvent event 187 | in Tuple val val 188 | 189 | validValueFromEvent ∷ Event → Maybe String 190 | validValueFromEvent event = join $ asRight $ runExcept $ do 191 | target ← readProp "target" $ unsafeToForeign event 192 | validity ← readProp "validity" target 193 | badInput ← readProp "badInput" validity >>= readBoolean 194 | value ← readProp "value" target >>= readString 195 | pure (if badInput then Nothing else Just value) 196 | 197 | type HasNumberInputVal a = 198 | { fromString ∷ String → Maybe a 199 | , toValue ∷ a → String 200 | , toNumber ∷ a → Number 201 | } 202 | 203 | numberHasNumberInputVal ∷ HasNumberInputVal Number 204 | numberHasNumberInputVal = 205 | { fromString: N.fromString 206 | , toValue: showNum 207 | , toNumber: identity 208 | } 209 | 210 | intHasNumberInputVal ∷ HasNumberInputVal Int 211 | intHasNumberInputVal = 212 | { fromString: numberHasNumberInputVal.fromString >=> Int.fromNumber 213 | , toValue: show 214 | , toNumber: Int.toNumber 215 | } 216 | 217 | boundedEnumHasNumberInputVal ∷ ∀ a. BoundedEnum a ⇒ HasNumberInputVal a 218 | boundedEnumHasNumberInputVal = 219 | { fromString: intHasNumberInputVal.fromString >=> toEnum 220 | , toValue: fromEnum >>> intHasNumberInputVal.toValue 221 | , toNumber: fromEnum >>> intHasNumberInputVal.toNumber 222 | } 223 | -------------------------------------------------------------------------------- /src/Halogen/DatePicker/Internal/Range.purs: -------------------------------------------------------------------------------- 1 | module Halogen.Datepicker.Internal.Range where 2 | 3 | import Prelude 4 | 5 | import Data.Enum (class BoundedEnum) 6 | import Data.Maybe (Maybe(..)) 7 | 8 | data Range a = MinMax a a | Min a | Max a 9 | 10 | instance rangeFunctor ∷ Functor Range where 11 | map f (MinMax a b) = MinMax (f a) (f b) 12 | map f (Min a) = Min (f a) 13 | map f (Max a) = Max (f a) 14 | 15 | minmaxRange ∷ ∀ a. a → a → Range a 16 | minmaxRange = MinMax 17 | 18 | minRange ∷ ∀ a. a → Range a 19 | minRange = Min 20 | 21 | maxRange ∷ ∀ a. a → Range a 22 | maxRange = Max 23 | 24 | rangeMin ∷ Range ~> Maybe 25 | rangeMin (MinMax m _) = Just m 26 | rangeMin (Min m) = Just m 27 | rangeMin _ = Nothing 28 | 29 | rangeMax ∷ Range ~> Maybe 30 | rangeMax (MinMax _ m) = Just m 31 | rangeMax (Max m) = Just m 32 | rangeMax _ = Nothing 33 | 34 | isInRange ∷ ∀ a. Ord a ⇒ Range a → a → Boolean 35 | isInRange range n = case range of 36 | (Min min) → min <= n 37 | (Max max) → max >= n 38 | (MinMax min max) → min <= n && n <= max 39 | 40 | 41 | bottomTop ∷ ∀ a. BoundedEnum a ⇒ Range a 42 | bottomTop = minmaxRange bottom top 43 | -------------------------------------------------------------------------------- /src/Halogen/DatePicker/Internal/Utils.purs: -------------------------------------------------------------------------------- 1 | module Halogen.Datepicker.Internal.Utils where 2 | 3 | import Prelude 4 | 5 | import Control.Alternative (class Alternative, empty) 6 | import Control.Monad.Error.Class (class MonadError, throwError) 7 | import Control.MonadPlus (guard) 8 | import Data.Bifunctor (lmap) 9 | import Data.Either (Either(..), either) 10 | import Data.Foldable (fold) 11 | import Data.Maybe (Maybe(..)) 12 | import Data.Traversable (sequence) 13 | import Data.Tuple (Tuple(..)) 14 | import Effect.Exception as Ex 15 | import Halogen as H 16 | import Halogen.Datepicker.Component.Types (BasePickerQuery(..), PickerQuery(..), PickerValue, isInvalid) 17 | import Halogen.Datepicker.Config (Config(..)) 18 | import Halogen.HTML.Properties as HP 19 | import Halogen.Query.HalogenM (HalogenM) 20 | 21 | handlePickerQuery 22 | ∷ ∀ action slots output m a b 23 | . (Maybe a → H.HalogenM (Maybe a) action slots output m Unit) 24 | → PickerQuery Unit (Maybe a) b 25 | → H.HalogenM (Maybe a) action slots output m (Maybe b) 26 | handlePickerQuery f = case _ of 27 | ResetError a → do 28 | H.put Nothing 29 | pure $ Just a 30 | Base (SetValue value k) → do 31 | f value 32 | H.put value 33 | pure $ Just $ k unit 34 | Base (GetValue k) → 35 | Just <<< k <$> H.get 36 | 37 | mustBeMounted 38 | ∷ ∀ s f ps o m a 39 | . MonadError Ex.Error m 40 | ⇒ Maybe a 41 | → HalogenM s f ps o m a 42 | mustBeMounted (Just x) = pure x 43 | mustBeMounted _ = throwError $ Ex.error "children must be mounted" 44 | 45 | pickerProps 46 | ∷ ∀ e a r z 47 | . Config 48 | → PickerValue e a 49 | → Array (HP.IProp ( "class" ∷ String | z ) r ) 50 | pickerProps (Config {root, rootInvalid}) val = [HP.classes classes] 51 | where 52 | classes = root <> (guard (isInvalid val) *> rootInvalid) 53 | 54 | componentProps 55 | ∷ ∀ r z 56 | . Config 57 | → Array (HP.IProp ( "class" ∷ String | z ) r ) 58 | componentProps (Config {component})= [HP.classes component] 59 | 60 | asRight ∷ ∀ e a f. Alternative f ⇒ Either e a → f a 61 | asRight = either (const empty) pure 62 | 63 | asLeft ∷ ∀ e a f. Alternative f ⇒ Either e a → f e 64 | asLeft = either pure (const empty) 65 | 66 | transitionState' 67 | ∷ ∀ f ps m val err 68 | . Eq err 69 | ⇒ Eq val 70 | ⇒ err 71 | → ( PickerValue err val 72 | → TransitionM f ps m err val (Either Boolean val) 73 | ) 74 | → TransitionM f ps m err val Unit 75 | transitionState' err f = transitionState (f >>> (map $ lmap (_ `Tuple` err))) 76 | 77 | type TransitionM f ps m err val = 78 | HalogenM (PickerValue err val) f ps (PickerValue err val) m 79 | 80 | transitionState 81 | ∷ ∀ f ps m val err 82 | . Eq err 83 | ⇒ Eq val 84 | ⇒ ( PickerValue err val 85 | → TransitionM f ps m err val (Either (Tuple Boolean err) val) 86 | ) 87 | → TransitionM f ps m err val Unit 88 | transitionState f = do 89 | val ← H.get 90 | nextVal ← map (steper val) (f val) 91 | val `moveStateTo` nextVal 92 | where 93 | moveStateTo ∷ ∀ a. Eq a ⇒ a → a → HalogenM a f ps a m Unit 94 | moveStateTo old new = H.put new *> unless (new == old) (H.raise new) 95 | steper ∷ ∀ e a. PickerValue e a → Either (Tuple Boolean e) a → PickerValue e a 96 | steper old new = case old, new of 97 | _, Right x → Just (Right x) 98 | Just _, Left (Tuple _ err) → Just (Left err) 99 | -- `true` indicates if we want to force state change to "invalid" 100 | Nothing, Left (Tuple true err) → Just (Left err) 101 | Nothing, Left _ → Nothing 102 | 103 | foldSteps ∷ ∀ a. Monoid a ⇒ Array (Maybe a) → Maybe a 104 | foldSteps steps = map fold $ sequence steps 105 | --------------------------------------------------------------------------------