diff options
Diffstat (limited to 'frontend')
| -rw-r--r-- | frontend/app/Main.hs | 132 | ||||
| -rw-r--r-- | frontend/frontend.cabal | 3 |
2 files changed, 133 insertions, 2 deletions
diff --git a/frontend/app/Main.hs b/frontend/app/Main.hs index fc26e69..d995b95 100644 --- a/frontend/app/Main.hs +++ b/frontend/app/Main.hs @@ -1,6 +1,7 @@ module Main where #ifndef ghcjs_HOST_OS +import Data.Maybe import Data.String import Language.Javascript.JSaddle.Warp as JSaddle import Network.HTTP.Simple @@ -13,10 +14,14 @@ import Miso.String qualified as J #endif import Data.Aeson qualified as A +import Data.Aeson.Key qualified as AK +import Data.Aeson.KeyMap qualified as AM import Data.ByteString.Lazy.Char8 qualified as LB import Data.Default import Data.Function +import Data.List import Data.Map qualified as M +import Data.Text qualified as T import GHC.Generics (Generic) import Miso import Miso.String (toMisoString) @@ -66,6 +71,8 @@ data Action | SetSchema (Either String Schema) | FetchPosts | SetPosts (Either String [A.Value]) + | FormChanged A.Value + | FormSubmitted A.Value deriving (Show, Eq) #ifndef ghcjs_HOST_OS @@ -103,6 +110,8 @@ updateModel action m = let setPosts :: Either String [A.Value] -> Model -> Model setPosts posts m = m {posts = Just posts} in noEff (setPosts posts m) + FormChanged _ -> noEff m + FormSubmitted _ -> noEff m fetchSchema :: JSM (Either String Schema) fetchSchema = @@ -149,7 +158,17 @@ viewModel :: Model -> View Action viewModel model = div_ [] $ [ maybe (text "..") (either err viewSchema) model.schema, - maybe (text "..") (either err viewPosts) model.posts + maybe (text "..") (either err viewPosts) model.posts, + maybe + (text "..") + ( either + err + ( fmap (either FormChanged FormSubmitted) + . flip viewForm (A.Object AM.empty) + . schemaForm + ) + ) + model.schema ] err :: String -> View Action @@ -169,6 +188,117 @@ viewSchema schema = ) <$> (M.toList properties) +schemaForm :: Schema -> Form A.Value A.Value +schemaForm schema = + mapOutput mergeJson . sequence $ + case schema.type_ of + Object properties -> + ( \(AK.fromString -> k, "string") -> + mapOutput (A.Object . AM.singleton k) $ + mapValues (getO k) (setO k) $ + jsonString (AK.toString k) + ) + <$> (M.toList properties) + +mergeJson :: [A.Value] -> A.Value +mergeJson = foldl' mergeObject (A.Object AM.empty) + +mergeObject :: A.Value -> A.Value -> A.Value +mergeObject (A.Object kvs) (A.Object kvs') = A.Object (AM.union kvs kvs') + +fromJson :: A.Value -> T.Text +fromJson (A.String x) = x +fromJson _ = "" + +toJson :: T.Text -> A.Value -> A.Value +toJson x _ = A.String x + +getO :: AK.Key -> A.Value -> A.Value +getO k (A.Object kvs) = fromMaybe A.Null (AM.lookup k kvs) + +setO :: AK.Key -> A.Value -> A.Value -> A.Value +setO k v (A.Object kvs) = A.Object (AM.insert k v kvs) + +data Form i o = Form + { view :: i -> [View i], + fill :: i -> Either String o + } + +instance Functor (Form i) where + fmap f (Form {view, fill}) = + Form + { fill = fmap f . fill, + .. + } + +instance Applicative (Form i) where + pure x = + Form + { view = const [], + fill = const (Right x) + } + Form {view = viewF, fill = fillF} <*> Form {view = viewX, fill = fillX} = + Form + { view = \i -> + let f = viewF i + x = viewX i + in f <> x, + fill = \i -> + let f = fillF i + x = fillX i + in ($) <$> f <*> x + } + +instance Monad (Form i) where + (Form {view = viewM, fill = fillM}) >>= mkF = + Form + { view = \i -> + viewM i + <> case fillM i of + Right x -> (mkF x).view i + Left _ -> [], + fill = \i -> case fillM i of + Right x -> (mkF x).fill i + Left e -> Left e + } + +mapValues :: (i' -> i) -> (i -> i' -> i') -> Form i o -> Form i' o +mapValues get set (Form {view, fill}) = + Form + { view = \i -> fmap (flip set i) <$> view (get i), + fill = fill . get + } + +mapOutput :: (o -> o') -> Form i o -> Form i o' +mapOutput = fmap + +viewForm :: Form i o -> i -> View (Either i o) +viewForm (Form {view}) i = + div_ [] $ + (fmap Left <$> view i) + <> [ button_ [type_ "submit"] [text "submit"] + ] + +jsonString :: String -> Form A.Value A.Value +jsonString = mapOutput A.String . mapValues fromJson toJson . string + +string :: String -> Form T.Text T.Text +string label = + Form + { view = \i -> + [ div_ [] $ + [ label_ [] $ + [ text (toMisoString label), + input_ + [ type_ "text", + value_ (toMisoString i) + ] + ] + ] + ], + fill = \i -> Right i + } + viewPosts :: [A.Value] -> View Action viewPosts posts = ol_ [] (viewPost <$> posts) where diff --git a/frontend/frontend.cabal b/frontend/frontend.cabal index fc8ab23..aa46ded 100644 --- a/frontend/frontend.cabal +++ b/frontend/frontend.cabal @@ -15,11 +15,12 @@ executable frontend default-extensions: CPP OverloadedStrings RecordWildCards DeriveAnyClass DuplicateRecordFields LambdaCase OverloadedRecordDot - NoFieldSelectors + NoFieldSelectors ViewPatterns ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-ambiguous-fields -fno-warn-incomplete-patterns -fno-warn-orphans + -fno-warn-incomplete-uni-patterns build-depends: aeson, |