dev: web: clarify AddForm a bit (#1229)
This commit is contained in:
		
							parent
							
								
									581831b16d
								
							
						
					
					
						commit
						6503bfec6a
					
				| @ -61,42 +61,42 @@ addForm :: | |||||||
|   Journal -> Day -> Markup -> |   Journal -> Day -> Markup -> | ||||||
|   MForm m (FormResult Transaction, WidgetFor (HandlerSite m) ()) |   MForm m (FormResult Transaction, WidgetFor (HandlerSite m) ()) | ||||||
| addForm j today = identifyForm "add" $ \extra -> do | addForm j today = identifyForm "add" $ \extra -> do | ||||||
|   (dateRes, dateView) <- mreq dateField dateFS Nothing |   let  -- bindings used in add-form.hamlet | ||||||
|   (descRes, descView) <- mreq textField descFS Nothing |     descriptions = foldMap S.fromList [journalPayeesDeclaredOrUsed j, journalDescriptions j] | ||||||
|   (acctRes, _) <- mreq listField acctFS Nothing |     files = fst <$> jfiles j | ||||||
|   (amtRes, _) <- mreq listField amtFS Nothing |   (dateRes, dateView) <- mreq dateField dateSettings Nothing | ||||||
|  |   (descRes, descView) <- mreq textField descSettings Nothing | ||||||
|  |   (acctRes, _)        <- mreq listField "account" Nothing | ||||||
|  |   (amtRes , _)        <- mreq listField "amount" Nothing | ||||||
|   let (postRes, displayRows) = validatePostings acctRes amtRes |   let (postRes, displayRows) = validatePostings acctRes amtRes | ||||||
| 
 |  | ||||||
|   -- bindings used in add-form.hamlet |  | ||||||
|   let descriptions = foldMap S.fromList [journalPayeesDeclaredOrUsed j, journalDescriptions j] |  | ||||||
|       journals = fst <$> jfiles j |  | ||||||
| 
 |  | ||||||
|   pure (validateTransaction dateRes descRes postRes, $(widgetFile "add-form")) |   pure (validateTransaction dateRes descRes postRes, $(widgetFile "add-form")) | ||||||
| 
 | 
 | ||||||
|   where |   where | ||||||
|     dateFS = FieldSettings "date" Nothing Nothing (Just "date") |     -- field settings | ||||||
|  |     dateSettings = FieldSettings "date" Nothing Nothing (Just "date") | ||||||
|       [("class", "form-control input-lg"), ("placeholder", "Date")] |       [("class", "form-control input-lg"), ("placeholder", "Date")] | ||||||
|     descFS = FieldSettings "desc" Nothing Nothing (Just "description") |     descSettings = FieldSettings "desc" Nothing Nothing (Just "description") | ||||||
|       [("class", "form-control input-lg typeahead"), ("placeholder", "Description"), ("size", "40")] |       [("class", "form-control input-lg typeahead"), ("placeholder", "Description"), ("size", "40")] | ||||||
|     acctFS = FieldSettings "amount" Nothing Nothing (Just "account") [] | 
 | ||||||
|     amtFS = FieldSettings "amount" Nothing Nothing (Just "amount") [] |     -- custom field types | ||||||
|     dateField = checkMMap (pure . validateDate) (T.pack . show) textField |     dateField = checkMMap (pure . validateDate) (T.pack . show) textField | ||||||
|  |       where | ||||||
|         validateDate s = |         validateDate s = | ||||||
|           first (const ("Invalid date format" :: Text)) $ |           first (const ("Invalid date format" :: Text)) $ | ||||||
|           fixSmartDateStrEither' today (T.strip s) |           fixSmartDateStrEither' today (T.strip s) | ||||||
| 
 |  | ||||||
|     listField = Field |     listField = Field | ||||||
|       { fieldParse = const . pure . Right . Just . dropWhileEnd T.null |       { fieldParse = const . pure . Right . Just . dropWhileEnd T.null | ||||||
|       , fieldView = error "Don't render using this!"  -- PARTIAL: |       , fieldView = error "Don't render using this!"  -- PARTIAL: | ||||||
|       , fieldEnctype = UrlEncoded |       , fieldEnctype = UrlEncoded | ||||||
|       } |       } | ||||||
| 
 | 
 | ||||||
|     -- Used in add-form.hamlet |     -- helpers used in add-form.hamlet | ||||||
|     toBloodhoundJson :: [Text] -> Markup |     toBloodhoundJson :: [Text] -> Markup | ||||||
|     toBloodhoundJson ts = |     toBloodhoundJson ts = | ||||||
|       -- This used to work, but since 1.16, it seems like something changed. |       -- This used to work, but since 1.16, it seems like something changed. | ||||||
|       -- toJSON ("a"::Text) gives String "a" instead of "a", etc. |       -- toJSON ("a"::Text) gives String "a" instead of "a", etc. | ||||||
|       -- preEscapedString . escapeJSSpecialChars . show . toJSON |       -- preEscapedString . escapeJSSpecialChars . show . toJSON | ||||||
|  | 
 | ||||||
|       preEscapedText $ T.concat [ |       preEscapedText $ T.concat [ | ||||||
|         "[", |         "[", | ||||||
|         T.intercalate "," $ map ( |         T.intercalate "," $ map ( | ||||||
| @ -112,7 +112,7 @@ addForm j today = identifyForm "add" $ \extra -> do | |||||||
|           ) ts, |           ) ts, | ||||||
|         "]" |         "]" | ||||||
|         ] |         ] | ||||||
| b64wrap :: Text -> Text |       where | ||||||
|         b64wrap = ("atob(\""<>) . (<>"\")") . encodeBase64 |         b64wrap = ("atob(\""<>) . (<>"\")") . encodeBase64 | ||||||
| 
 | 
 | ||||||
| validateTransaction :: | validateTransaction :: | ||||||
| @ -128,8 +128,11 @@ validateTransaction dateRes descRes postingsRes = | |||||||
|     x -> x |     x -> x | ||||||
|   where |   where | ||||||
|     makeTransaction date desc postings = |     makeTransaction date desc postings = | ||||||
|       nulltransaction {tdate = date, tdescription = desc, tpostings = postings} |       nulltransaction { | ||||||
| 
 |          tdate        = date | ||||||
|  |         ,tdescription = desc | ||||||
|  |         ,tpostings    = postings | ||||||
|  |         } | ||||||
| 
 | 
 | ||||||
| -- | Parse a list of postings out of a list of accounts and a corresponding list | -- | Parse a list of postings out of a list of accounts and a corresponding list | ||||||
| -- of amounts | -- of amounts | ||||||
|  | |||||||
| @ -58,10 +58,10 @@ | |||||||
|   <div .col-md-4 .col-xs-4 .col-sm-4> |   <div .col-md-4 .col-xs-4 .col-sm-4> | ||||||
|     <button type=submit .btn .btn-default .btn-lg name=submit>add |     <button type=submit .btn .btn-default .btn-lg name=submit>add | ||||||
| 
 | 
 | ||||||
| $if length journals > 1 | $if length files > 1 | ||||||
|   <br> |   <br> | ||||||
|   <span .input-lg>to: |   <span .input-lg>to: | ||||||
|     <select #journalselect .form-control.input-lg name=journal style="width:auto; display:inline-block;"> |     <select #journalselect .form-control.input-lg name=file style="width:auto; display:inline-block;"> | ||||||
|       $forall p <- journals |       $forall f <- files | ||||||
|         <option value=#{p}>#{p} |         <option value=#{f}>#{f} | ||||||
| <span .small style="padding-left:2em;"> | <span .small style="padding-left:2em;"> | ||||||
|  | |||||||
		Loading…
	
		Reference in New Issue
	
	Block a user