Skip to content

Instantly share code, notes, and snippets.

@jamesthompson
Last active August 31, 2016 11:37
Show Gist options
  • Save jamesthompson/d4fce33108ab8e501c8626efe2f2f00f to your computer and use it in GitHub Desktop.
Save jamesthompson/d4fce33108ab8e501c8626efe2f2f00f to your computer and use it in GitHub Desktop.
Gogol Datastore Generic Record Serializer
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module GenericDatastore where
import Control.Lens hiding (from)
import qualified Control.Lens as L
import qualified Data.HashMap.Lazy as HM
import Data.List.NonEmpty
import Data.Proxy
import Data.String
import Data.Text
import Data.Text1
import GHC.Generics
import Network.Google.Datastore
data EntityTransform
= Entity Text [(Text, Value)]
| EntityP [(Text, Value)]
| V Value
| None
deriving (Eq, Show)
class Datastore a where
entity' :: a -> EntityTransform
default entity' :: (Generic a, GDatastore (Rep a)) => a -> EntityTransform
entity' = gentity' . from
class GDatastore f where
gentity' :: f a -> EntityTransform
instance GDatastore U1 where
gentity' _ = None
-- | Sum - can't encode sum types easily - perhaps map to string rep?
instance (GDatastore a, GDatastore b) => GDatastore (a :+: b) where
gentity' (L1 x) = gentity' x
gentity' (R1 x) = gentity' x
-- | Product
instance (GDatastore a, GDatastore b) => GDatastore (a :*: b) where
gentity' (a :*: b) = case (gentity' a, gentity' b) of
(EntityP xs, EntityP ys) -> EntityP $ xs ++ ys
_ -> None
-- | Datatype
instance GDatastore f => GDatastore (M1 D d f) where
gentity' = gentity' . unM1
-- | Constructor Metadata - for entity key
instance (GDatastore f, Constructor c) => GDatastore (M1 C c f) where
gentity' x
| conIsRecord x = case gentity' $ unM1 x of
EntityP xs -> Entity (pack (conName x)) xs
_ -> None
| otherwise = gentity' $ unM1 x
-- | Selector Metadata
instance (GDatastore f, Selector c) => GDatastore (M1 S c f) where
gentity' s@(M1 x) = case gentity' x of
V v -> EntityP [(pack (selName s), v)]
EntityP xs -> EntityP $ (\(x, y) -> (pack (selName s), y)) <$> xs
x -> None
-- | Selector values
instance Datastore a => GDatastore (K1 i a) where
gentity' = entity' . unK1
-- | Value serializers
instance Datastore Text where
entity' x = V $ value & vStringValue ?~ x
instance Datastore Text1 where
entity' x = V $ value & vStringValue ?~ review _Text1 x
instance Datastore Bool where
entity' b = V $ value & vBooleanValue ?~ b
instance Datastore Int where
entity' i = V $ value & vIntegerValue ?~ fromIntegral i
data Colour = Red | Green | Blue deriving (Eq, Show)
instance Datastore Colour where
entity' b = V $ value & vStringValue ?~ pack (show b)
instance Datastore a => Datastore [a] where
entity' xs = V $ value & vArrayValue ?~ (arrayValue & avValues .~ (xs >>= indiv))
where indiv x = case entity' x of
V v -> [v]
_ -> []
instance Datastore a => Datastore (NonEmpty a) where
entity' xs = V $ value & vArrayValue ?~ (arrayValue & avValues .~ (toList xs >>= indiv))
where indiv x = case entity' x of
V v -> [v]
_ -> []
instance Datastore a => Datastore (Maybe a) where
entity' (Just x) = entity' x
entity' Nothing = V $ value & vNullValue ?~ NullValue
instance Datastore b => Datastore (Either a b) where
entity' (Right x) = entity' x
entity' (Left _) = V $ value & vNullValue ?~ NullValue
-- | This stuff should be in a separate module
_AsDatastore :: Datastore a => Getter a (Maybe Entity)
_AsDatastore = L.to (toEntity . entity')
where toEntity (Entity k params) =
pure $ entity & eKey ?~ (key & kPath .~ [pathElement & peKind ?~ k])
& eProperties ?~ entityProperties (HM.fromList params)
toEntity _ = Nothing
data RecordTest
= RecordTest
{ foo :: Text
, bar :: Bool
, baz :: Int
}
| SumTest
{ quux :: Text
, colours :: [Colour]
}
deriving (Eq, Show, Generic, Datastore)
@jamesthompson
Copy link
Author

This is a WIP - not yet handling nested record types!

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment