{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PolyKinds #-}
module Typson.Selda
( jsonPath
, Json(..)
) where
import qualified Data.Aeson as Aeson
import qualified Data.ByteString.Lazy as BSL
import Data.List (foldl')
import qualified Data.List.NonEmpty as NE
import Data.Maybe (fromMaybe)
import Data.String (fromString)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Typeable (Typeable)
import qualified Database.Selda as S
import qualified Database.Selda.Backend as S
import Database.Selda.JSON ()
import qualified Database.Selda.PostgreSQL as S
import qualified Database.Selda.Unsafe as S
import Typson
jsonPath :: ( TypeAtPath o tree path ~ target
, ReflectPath path
)
=> proxy (path :: k)
-> ObjectTree tree o
-> S.Col S.PG (Json o)
-> S.Col S.PG (Json target)
jsonPath :: proxy path
-> ObjectTree tree o -> Col PG (Json o) -> Col PG (Json target)
jsonPath path :: proxy path
path _ col :: Col PG (Json o)
col =
case proxy path -> NonEmpty PathComponent
forall k (path :: k) (proxy :: k -> *).
ReflectPath path =>
proxy path -> NonEmpty PathComponent
reflectPath proxy path
path of
p :: PathComponent
p NE.:| ps :: [PathComponent]
ps -> (Col PG (Json target) -> PathComponent -> Col PG (Json target))
-> Col PG (Json target) -> [PathComponent] -> Col PG (Json target)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Col PG (Json target) -> PathComponent -> Col PG (Json target)
forall a c. Col PG a -> PathComponent -> Col PG c
buildPath (Col PG (Json o) -> PathComponent -> Col PG (Json target)
forall a c. Col PG a -> PathComponent -> Col PG c
buildPath Col PG (Json o)
col PathComponent
p) [PathComponent]
ps
where
buildPath :: Col PG a -> PathComponent -> Col PG c
buildPath c :: Col PG a
c (Key k :: String
k) = Text -> Col PG a -> Col PG Text -> Col PG c
forall s a b c. Text -> Col s a -> Col s b -> Col s c
S.operator "->" Col PG a
c (String -> Col PG Text
forall a. IsString a => String -> a
fromString String
k :: S.Col S.PG T.Text)
buildPath c :: Col PG a
c (Idx i :: Integer
i) = Text -> Col PG a -> Col PG Int -> Col PG c
forall s a b c. Text -> Col s a -> Col s b -> Col s c
S.operator "->" Col PG a
c (Text -> Col PG Int
forall a s. SqlType a => Text -> Col s a
S.rawExp (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Integer -> String
forall a. Show a => a -> String
show Integer
i) :: S.Col S.PG Int)
newtype Json a =
Json
{ Json a -> a
unJson :: a
} deriving (Int -> Json a -> ShowS
[Json a] -> ShowS
Json a -> String
(Int -> Json a -> ShowS)
-> (Json a -> String) -> ([Json a] -> ShowS) -> Show (Json a)
forall a. Show a => Int -> Json a -> ShowS
forall a. Show a => [Json a] -> ShowS
forall a. Show a => Json a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Json a] -> ShowS
$cshowList :: forall a. Show a => [Json a] -> ShowS
show :: Json a -> String
$cshow :: forall a. Show a => Json a -> String
showsPrec :: Int -> Json a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Json a -> ShowS
Show, Json a -> Json a -> Bool
(Json a -> Json a -> Bool)
-> (Json a -> Json a -> Bool) -> Eq (Json a)
forall a. Eq a => Json a -> Json a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Json a -> Json a -> Bool
$c/= :: forall a. Eq a => Json a -> Json a -> Bool
== :: Json a -> Json a -> Bool
$c== :: forall a. Eq a => Json a -> Json a -> Bool
Eq, Eq (Json a)
Eq (Json a) =>
(Json a -> Json a -> Ordering)
-> (Json a -> Json a -> Bool)
-> (Json a -> Json a -> Bool)
-> (Json a -> Json a -> Bool)
-> (Json a -> Json a -> Bool)
-> (Json a -> Json a -> Json a)
-> (Json a -> Json a -> Json a)
-> Ord (Json a)
Json a -> Json a -> Bool
Json a -> Json a -> Ordering
Json a -> Json a -> Json a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (Json a)
forall a. Ord a => Json a -> Json a -> Bool
forall a. Ord a => Json a -> Json a -> Ordering
forall a. Ord a => Json a -> Json a -> Json a
min :: Json a -> Json a -> Json a
$cmin :: forall a. Ord a => Json a -> Json a -> Json a
max :: Json a -> Json a -> Json a
$cmax :: forall a. Ord a => Json a -> Json a -> Json a
>= :: Json a -> Json a -> Bool
$c>= :: forall a. Ord a => Json a -> Json a -> Bool
> :: Json a -> Json a -> Bool
$c> :: forall a. Ord a => Json a -> Json a -> Bool
<= :: Json a -> Json a -> Bool
$c<= :: forall a. Ord a => Json a -> Json a -> Bool
< :: Json a -> Json a -> Bool
$c< :: forall a. Ord a => Json a -> Json a -> Bool
compare :: Json a -> Json a -> Ordering
$ccompare :: forall a. Ord a => Json a -> Json a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (Json a)
Ord)
deriving newtype ([Json a] -> Encoding
[Json a] -> Value
Json a -> Encoding
Json a -> Value
(Json a -> Value)
-> (Json a -> Encoding)
-> ([Json a] -> Value)
-> ([Json a] -> Encoding)
-> ToJSON (Json a)
forall a. ToJSON a => [Json a] -> Encoding
forall a. ToJSON a => [Json a] -> Value
forall a. ToJSON a => Json a -> Encoding
forall a. ToJSON a => Json a -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Json a] -> Encoding
$ctoEncodingList :: forall a. ToJSON a => [Json a] -> Encoding
toJSONList :: [Json a] -> Value
$ctoJSONList :: forall a. ToJSON a => [Json a] -> Value
toEncoding :: Json a -> Encoding
$ctoEncoding :: forall a. ToJSON a => Json a -> Encoding
toJSON :: Json a -> Value
$ctoJSON :: forall a. ToJSON a => Json a -> Value
Aeson.ToJSON, Value -> Parser [Json a]
Value -> Parser (Json a)
(Value -> Parser (Json a))
-> (Value -> Parser [Json a]) -> FromJSON (Json a)
forall a. FromJSON a => Value -> Parser [Json a]
forall a. FromJSON a => Value -> Parser (Json a)
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Json a]
$cparseJSONList :: forall a. FromJSON a => Value -> Parser [Json a]
parseJSON :: Value -> Parser (Json a)
$cparseJSON :: forall a. FromJSON a => Value -> Parser (Json a)
Aeson.FromJSON)
decodeError :: Show a => a -> b
decodeError :: a -> b
decodeError x :: a
x = String -> b
forall a. HasCallStack => String -> a
error (String -> b) -> String -> b
forall a b. (a -> b) -> a -> b
$ "fromSql: json column with invalid json: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x
typeError :: Show a => a -> b
typeError :: a -> b
typeError x :: a
x = String -> b
forall a. HasCallStack => String -> a
error (String -> b) -> String -> b
forall a b. (a -> b) -> a -> b
$ "fromSql: json column with non-text value: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x
instance (Typeable a, Aeson.ToJSON a, Aeson.FromJSON a, Show a) => S.SqlType (Json a) where
mkLit :: Json a -> Lit (Json a)
mkLit j :: Json a
j =
case Value -> Lit Value
forall a. SqlType a => a -> Lit a
S.mkLit (Value -> Lit Value) -> Value -> Lit Value
forall a b. (a -> b) -> a -> b
$ Json a -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON Json a
j of
S.LCustom rep :: SqlTypeRep
rep l :: Lit a1
l -> SqlTypeRep -> Lit a1 -> Lit (Json a)
forall a1 a. SqlTypeRep -> Lit a1 -> Lit a
S.LCustom SqlTypeRep
rep Lit a1
l
sqlType :: Proxy (Json a) -> SqlTypeRep
sqlType _ = SqlTypeRep
S.TJSON
defaultValue :: Lit (Json a)
defaultValue =
case Value -> Lit Value
forall a. SqlType a => a -> Lit a
S.mkLit Value
Aeson.Null of
S.LCustom rep :: SqlTypeRep
rep l :: Lit a1
l -> SqlTypeRep -> Lit a1 -> Lit (Json a)
forall a1 a. SqlTypeRep -> Lit a1 -> Lit a
S.LCustom SqlTypeRep
rep Lit a1
l
fromSql :: SqlValue -> Json a
fromSql (S.SqlBlob t :: ByteString
t) =
Json a -> Maybe (Json a) -> Json a
forall a. a -> Maybe a -> a
fromMaybe (ByteString -> Json a
forall a b. Show a => a -> b
decodeError ByteString
t) (ByteString -> Maybe (Json a)
forall a. FromJSON a => ByteString -> Maybe a
Aeson.decode' (ByteString -> Maybe (Json a)) -> ByteString -> Maybe (Json a)
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSL.fromStrict ByteString
t)
fromSql (S.SqlString t :: Text
t) =
Json a -> Maybe (Json a) -> Json a
forall a. a -> Maybe a -> a
fromMaybe (Text -> Json a
forall a b. Show a => a -> b
decodeError Text
t) (ByteString -> Maybe (Json a)
forall a. FromJSON a => ByteString -> Maybe a
Aeson.decode' (ByteString -> Maybe (Json a))
-> (ByteString -> ByteString) -> ByteString -> Maybe (Json a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.fromStrict (ByteString -> Maybe (Json a)) -> ByteString -> Maybe (Json a)
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TE.encodeUtf8 Text
t)
fromSql S.SqlNull =
case Value -> Result (Json a)
forall a. FromJSON a => Value -> Result a
Aeson.fromJSON Value
Aeson.Null of
Aeson.Success a :: Json a
a -> Json a
a
_ -> SqlValue -> Json a
forall a b. Show a => a -> b
typeError SqlValue
S.SqlNull
fromSql x :: SqlValue
x = SqlValue -> Json a
forall a b. Show a => a -> b
typeError SqlValue
x