acms/frontend/app/Schema.hs

{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}

module Schema
  ( Schema,
    viewSchema,
    schemaTable,
    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)

schemaTable :: Schema -> [A.Value] -> View action
schemaTable schema values =
  table_ [] [thead, tbody]
  where
    thead =
      thead_ [] $
        case schema.type_ of
          Object properties ->
            [ tr_ [] $
                [ th_ [] [text (toMisoString k)]
                  | k <- M.keys properties
                ]
            ]
    tbody = tbody_ [] $
      case schema.type_ of
        Object properties ->
          [ tr_
              []
              [ td_ [] $
                  [ text $
                      case getO (AK.fromString k) value of
                        A.String s -> toMisoString s
                        value -> toMisoString (A.encode value)
                  ]
                | k <- M.keys properties
              ]
            | value <- values
          ]

schemaForm :: Schema -> F.Form A.Value A.Value
schemaForm schema =
  fmap mergeJson . sequence $
    case schema.type_ of
      Object properties ->
        ( \(AK.fromString -> k, v) ->
            case v of
              "string" ->
                A.Object . AM.singleton k
                  <$> ( F.mapValues (getO k) (setO k) $
                          jsonString (AK.toString 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