Skip to content

Commit

Permalink
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Add wrapper newtype for automatically encoding meta-data
Browse files Browse the repository at this point in the history
considerate committed Apr 1, 2022
1 parent 6e83d51 commit d2c1923
Showing 3 changed files with 107 additions and 6 deletions.
2 changes: 2 additions & 0 deletions casper.cabal
Original file line number Diff line number Diff line change
@@ -24,6 +24,7 @@ library
ghc-options: -Wall
build-depends:
aeson
, aeson-lens
, base >=4.7 && <5
, base16-bytestring >=1.0.0.0
, base64-bytestring >=1.1.0.0
@@ -35,6 +36,7 @@ library
, exceptions
, filepath
, hashable
, lens
, memory
, mtl
, process
2 changes: 2 additions & 0 deletions src/Casper.hs
Original file line number Diff line number Diff line change
@@ -7,6 +7,7 @@
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -74,6 +75,7 @@ import Data.Hashable (Hashable)
import Data.Kind (Type)
import Data.Serialize (Serialize)
import qualified Data.Serialize as Serialize
import Data.String (fromString)
import qualified Data.Text.Encoding as Text
import Data.Typeable
import qualified Data.UUID as UUID
109 changes: 103 additions & 6 deletions src/Use.hs
Original file line number Diff line number Diff line change
@@ -1,20 +1,35 @@
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Use where

import Casper
import Control.Applicative ((<|>))
import Control.Lens (at, (.~), (?~))
import Control.Monad.IO.Class (liftIO)
import Data.Aeson
import qualified Data.Aeson as Aeson
import Data.Data (Proxy (Proxy))
import Data.Kind (Type)
import Data.List (stripPrefix)
import Data.Maybe (fromMaybe)
import Data.Serialize (Serialize)
import GHC.Generics (Generic)
import qualified Data.Serialize as Serialize
import Data.String (fromString)
import Data.Typeable (Proxy, Typeable, typeRep)
import GHC.Generics

data Root s = Root (Var s (Foo s)) (Var s (Foo s))
deriving stock (Generic)
@@ -23,24 +38,104 @@ data Root s = Root (Var s (Foo s)) (Var s (Foo s))

data Foo s = Foo
{ mi :: Var s Int,
mli :: Var s [Int],
_mli :: Var s [Int],
lmi :: [Var s Int],
rec :: Var s (Foo s),
recs :: Var s [Foo s],
val :: Int
}
deriving stock (Generic)
deriving anyclass (FromJSON, ToJSON)
deriving (Serialize) via WrapAeson (Foo s)
deriving (Serialize) via (MetaAeson (RemoveUnderscores (Foo s)))
deriving (Typeable)
deriving (JSONMeta)

deriving instance Content s (Foo s)
fooType :: String
fooType = show $ typeRep (Proxy :: Proxy (Foo ()))

-- | Modify the To/FromJSON instances to output a "meta" field that is embedded
-- in the object if the original thing serializes to an object and constructs
-- the object {"meta": metadata, "value": original} otherwise.
--
-- useful with 'deriving via (MetaAeson YourDataType)'
newtype MetaAeson a = MetaAeson {unMetaAeson :: a}

newtype RemoveUnderscores a = RemoveUnderscores {unRemoveUnderscores :: a}
deriving newtype (JSONMeta)

removeUndercores :: Options
removeUndercores =
Aeson.defaultOptions
{ Aeson.fieldLabelModifier = \s -> fromMaybe s (stripPrefix "_" s),
Aeson.constructorTagModifier = \s -> fromMaybe s (stripPrefix "_" s)
}

instance (GFromJSON Zero (Rep a), Generic a) => Aeson.FromJSON (RemoveUnderscores a) where
parseJSON = fmap RemoveUnderscores . Aeson.genericParseJSON removeUndercores

instance (GToJSON Zero (Rep a), Generic a) => Aeson.ToJSON (RemoveUnderscores a) where
toJSON (RemoveUnderscores a) = Aeson.genericToJSON removeUndercores a

instance (Aeson.FromJSON a, Aeson.ToJSON a, JSONMeta a) => Serialize (MetaAeson a) where
put = Serialize.put . Aeson.encode
get = Serialize.get >>= either fail pure . Aeson.eitherDecodeStrict'

class JSONMeta a where
jsonMeta :: a -> Aeson.Value
default jsonMeta :: (Generic a, GToJSONMeta (Rep a)) => a -> Aeson.Value
jsonMeta a = gjsonMeta (from a)

class GToJSONMeta a where
gjsonMeta :: a x -> Aeson.Value

instance (GToJSONMeta l, GToJSONMeta r) => GToJSONMeta (l :+: r) where
gjsonMeta (L1 a) = gjsonMeta a
gjsonMeta (R1 a) = gjsonMeta a

instance (GToJSONMeta l, GToJSONMeta r) => GToJSONMeta (l :*: r) where
gjsonMeta (a :*: b) = Aeson.toJSON [gjsonMeta a, gjsonMeta b]

instance (Constructor c, GToJSONMeta a) => GToJSONMeta (C1 c a) where
gjsonMeta c@(M1 a) = Aeson.object [("constructor", Aeson.String (fromString $ conName c)), ("meta", gjsonMeta a)]

instance (Selector c, GToJSONMeta a) => GToJSONMeta (S1 c a) where
gjsonMeta c@(M1 a) = Aeson.object [("field", Aeson.String (fromString $ selName c)), ("meta", gjsonMeta a)]

instance (Datatype c, GToJSONMeta a) => GToJSONMeta (D1 c a) where
gjsonMeta c@(M1 a) = Aeson.object [("type", Aeson.String (fromString $ datatypeName c)), ("meta", gjsonMeta a)]

instance {-# OVERLAPPABLE #-} GToJSONMeta a => GToJSONMeta (M1 i c a) where
gjsonMeta (M1 a) = gjsonMeta a

instance GToJSONMeta (K1 i a) where
gjsonMeta _ = Aeson.Null

instance GToJSONMeta U1 where
gjsonMeta _ = Aeson.Null

instance GToJSONMeta V1 where
gjsonMeta _ = Aeson.Null

instance (Aeson.ToJSON a, JSONMeta a) => Aeson.ToJSON (MetaAeson a) where
toJSON (MetaAeson a) = case Aeson.toJSON a of
Aeson.Object o -> Aeson.Object $ (at "meta" ?~ jsonMeta a) o
v -> Aeson.object [("value", v), ("meta", jsonMeta a)]

instance (Aeson.FromJSON a, JSONMeta a) => Aeson.FromJSON (MetaAeson a) where
parseJSON value =
MetaAeson <$> (parseJSON value >>= \o -> o .: "value" <|> parseJSON (Aeson.Object o))

-- >>> import qualified Data.Aeson as Aeson
-- >>> Aeson.encode exampleFoo
-- "{\"mi\":\"00000000-0000-0000-0000-000000000000\",\"val\":2,\"mli\":\"00000000-0000-0000-0000-000000000000\",\"recs\":\"00000000-0000-0000-0000-000000000000\",\"rec\":\"00000000-0000-0000-0000-000000000000\",\"lmi\":[\"00000000-0000-0000-0000-000000000000\",\"00000000-0000-0000-0000-000000000000\"]}"
-- >>> Serialize.runPut (Serialize.put exampleFoo)
-- "\NUL\NUL\NUL\NUL\NUL\NUL\STX\NUL{\"mi\":\"00000000-0000-0000-0000-000000000000\",\"val\":2,\"mli\":\"00000000-0000-0000-0000-000000000000\",\"meta\":{\"meta\":{\"constructor\":\"Foo\",\"meta\":[[{\"meta\":null,\"field\":\"mi\"},[{\"meta\":null,\"field\":\"_mli\"},{\"meta\":null,\"field\":\"lmi\"}]],[{\"meta\":null,\"field\":\"rec\"},[{\"meta\":null,\"field\":\"recs\"},{\"meta\":null,\"field\":\"val\"}]]]},\"type\":\"Foo\"},\"recs\":\"00000000-0000-0000-0000-000000000000\",\"rec\":\"00000000-0000-0000-0000-000000000000\",\"lmi\":[\"00000000-0000-0000-0000-000000000000\",\"00000000-0000-0000-0000-000000000000\"]}"
exampleFoo :: Foo s
exampleFoo = Foo fakeVar fakeVar [fakeVar, fakeVar] fakeVar fakeVar 2

-- >>> Aeson.encode (jsonMeta exampleFoo)
-- "{\"meta\":{\"constructor\":\"Foo\",\"meta\":[[{\"meta\":null,\"field\":\"mi\"},[{\"meta\":null,\"field\":\"mli\"},{\"meta\":null,\"field\":\"lmi\"}]],[{\"meta\":null,\"field\":\"rec\"},[{\"meta\":null,\"field\":\"recs\"},{\"meta\":null,\"field\":\"val\"}]]]},\"type\":\"Foo\"}"
--
--
--
-- data Dataset i = Dataset ([i (Datapoint i)])
-- deriving (Generic)

@@ -79,13 +174,15 @@ exampleFoo = Foo fakeVar fakeVar [fakeVar, fakeVar] fakeVar fakeVar 2

-- instance Content mut imm (Foo mut imm)

{-
someFunc :: IO Int
someFunc =
loadStore "/dev/null" $ do
transact $ \(Root l _) -> do
foo1 <- readVar l
foo2 <- readVar (rec foo1)
readVar (mi foo2)
-}

-- localRoot (\(Root l r) -> rec <$> readMut l) $ do
-- liftIO $ putStrLn "Changed root"

0 comments on commit d2c1923

Please sign in to comment.