1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
|
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
module Schema
( Schema,
viewSchema,
schemaForm,
)
where
import Data.Aeson qualified as A
import Data.Aeson.Key qualified as AK
import Data.Aeson.KeyMap qualified as AM
import Data.List
import Data.Map qualified as M
import Data.Maybe
import Data.Text qualified as T
import Form qualified as F
import Miso
import Miso.String (toMisoString)
data Schema = Schema
{ id :: String,
schema :: String,
title :: String,
type_ :: SchemaType
}
deriving (Show, Eq)
instance A.FromJSON Schema where
parseJSON =
A.withObject
"Schema"
( \v ->
Schema
<$> v A..: "$id"
<*> v A..: "$schema"
<*> v A..: "title"
<*> A.parseJSON (A.Object v)
)
data SchemaType = Object (M.Map String String)
deriving (Show, Eq)
instance A.FromJSON SchemaType where
parseJSON =
A.withObject
"SchemaType"
( \v ->
v A..: "type" >>= \case
("object" :: String) -> Object <$> v A..: "properties"
)
viewSchema :: Schema -> View action
viewSchema schema =
case schema.type_ of
Object properties ->
ol_ [] $
( \(k, v) ->
li_ [] $
[ text (toMisoString k),
text ":",
text (toMisoString v)
]
)
<$> (M.toList properties)
schemaForm :: Schema -> F.Form A.Value A.Value
schemaForm schema =
fmap mergeJson . sequence $
case schema.type_ of
Object properties ->
( \(AK.fromString -> k, "string") ->
A.Object . AM.singleton k
<$> ( F.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)
jsonString :: String -> F.Form A.Value A.Value
jsonString = fmap A.String . F.mapValues fromJson toJson . F.string
|
