diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,11 @@ ## [Unreleased] +## [0.0.1.8] - 2021-09-07 +### Added +- `FromValue` / `ToValue` instances for `NonEmpty`; +- `BoltEnum` wrapper to provide `FromValue` / `ToValue` for enum-like types. + ## [0.0.1.7] - 2021-04-28 ### Changed - Add more `HasCallStack`. diff --git a/hasbolt-extras.cabal b/hasbolt-extras.cabal --- a/hasbolt-extras.cabal +++ b/hasbolt-extras.cabal @@ -1,5 +1,5 @@ name: hasbolt-extras -version: 0.0.1.7 +version: 0.0.1.8 synopsis: Extras for hasbolt library description: Extras for hasbolt library homepage: https://github.com/biocad/hasbolt-extras#readme @@ -28,6 +28,7 @@ , Database.Bolt.Extras.Template , Database.Bolt.Extras.DSL , Database.Bolt.Extras.DSL.Typed + , Database.Bolt.Extras.Generic , Database.Bolt.Extras.Utils other-modules: Database.Bolt.Extras.Internal.Cypher , Database.Bolt.Extras.Internal.Condition diff --git a/src/Database/Bolt/Extras/DSL/Typed/Parameters.hs b/src/Database/Bolt/Extras/DSL/Typed/Parameters.hs --- a/src/Database/Bolt/Extras/DSL/Typed/Parameters.hs +++ b/src/Database/Bolt/Extras/DSL/Typed/Parameters.hs @@ -17,7 +17,7 @@ import Data.Text (Text, pack) import Database.Bolt (BoltActionT, IsValue (..), Record, Value, queryP) -import GHC.Stack (HasCallStack, withFrozenCallStack) +import GHC.Stack (HasCallStack) import GHC.TypeLits (Symbol) import Database.Bolt.Extras.DSL.Internal.Executer (formQuery) diff --git a/src/Database/Bolt/Extras/Generic.hs b/src/Database/Bolt/Extras/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolt/Extras/Generic.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +module Database.Bolt.Extras.Generic where + +import Data.Proxy (Proxy (..)) +import Data.Text (pack, unpack) +import Database.Bolt (Value (..)) +import GHC.Generics (C1, D1, Generic (..), M1 (..), Meta (..), U1 (..), type (:+:) (..)) +import GHC.TypeLits (KnownSymbol, symbolVal) + +import Control.Applicative ((<|>)) +import Database.Bolt.Extras.Internal.Types (FromValue (..), ToValue (..)) +import Type.Reflection (Typeable, typeRep) + +-- | Wrapper to encode enum-like types as strings in the DB. +-- +-- Intended usage is with @DerivingVia@: +-- +-- >>> :{ +-- data Color = Red | Green | Blue +-- deriving (Show, Generic) +-- deriving (ToValue, FromValue) via BoltEnum Color +-- :} +-- +-- >>> toValue Red +-- T "Red" +-- >>> fromValue (T "Blue") :: Color +-- Blue +-- >>> fromValue (T "Brown") :: Color +-- *** Exception: Could not unpack unknown value Brown of Color +-- ... +-- ... +newtype BoltEnum a + = BoltEnum a + deriving (Eq, Show, Generic) + +instance (Generic a, GToValue (Rep a)) => ToValue (BoltEnum a) where + toValue (BoltEnum a) = T $ pack $ gToValue $ from a + +instance (Typeable a, Generic a, GFromValue (Rep a)) => FromValue (BoltEnum a) where + fromValue (T str) = + case gFromValue $ unpack str of + Nothing -> error $ "Could not unpack unknown value " <> unpack str <> " of " <> show (typeRep @a) + Just rep -> BoltEnum $ to rep + fromValue v = error $ "Could not unpack " <> show v <> " as " <> show (typeRep @a) + +class GToValue rep where + gToValue :: rep a -> String + +instance GToValue cs => GToValue (D1 meta cs) where + gToValue (M1 cs) = gToValue cs + +instance KnownSymbol name => GToValue (C1 ('MetaCons name fixity rec) U1) where + gToValue _ = symbolVal @name Proxy + +instance (GToValue l, GToValue r) => GToValue (l :+: r) where + gToValue (L1 l) = gToValue l + gToValue (R1 r) = gToValue r + +class GFromValue rep where + gFromValue :: String -> Maybe (rep a) + +instance GFromValue cs => GFromValue (D1 meta cs) where + gFromValue = fmap M1 . gFromValue @cs + +instance KnownSymbol name => GFromValue (C1 ('MetaCons name fixity rec) U1) where + gFromValue str = + if str == symbolVal @name Proxy + then Just $ M1 U1 + else Nothing + +instance (GFromValue l, GFromValue r) => GFromValue (l :+: r) where + gFromValue str = L1 <$> gFromValue @l str <|> R1 <$> gFromValue @r str + +{- $setup +>>> :set -XDerivingStrategies -XDerivingVia +>>> :load Database.Bolt.Extras Database.Bolt.Extras.Generic +>>> import GHC.Generics +>>> import Database.Bolt.Extras.Generic +>>> import Database.Bolt (Value (..)) +-} diff --git a/src/Database/Bolt/Extras/Internal/Instances.hs b/src/Database/Bolt/Extras/Internal/Instances.hs --- a/src/Database/Bolt/Extras/Internal/Instances.hs +++ b/src/Database/Bolt/Extras/Internal/Instances.hs @@ -6,19 +6,16 @@ module Database.Bolt.Extras.Internal.Instances () where import Control.Applicative ((<|>)) -import Data.Aeson (FromJSON (..), - ToJSON (..)) +import Data.Aeson (FromJSON (..), ToJSON (..)) import Data.Aeson.Types (Parser) +import Data.List.NonEmpty (NonEmpty (..), toList) import Data.Map.Strict (Map) import Data.Text (Text) import Database.Bolt (Node, Value (..)) import qualified Database.Bolt as DB (Structure) -import Database.Bolt.Extras.Internal.Types (FromValue (..), - NodeLike (..), - ToValue (..)) +import Database.Bolt.Extras.Internal.Types (FromValue (..), NodeLike (..), ToValue (..)) import Database.Bolt.Extras.Utils (currentLoc) -import GHC.Float (double2Float, - float2Double) +import GHC.Float (double2Float, float2Double) instance ToValue () where @@ -45,6 +42,9 @@ instance ToValue a => ToValue [a] where toValue = L . fmap toValue +instance ToValue a => ToValue (NonEmpty a) where + toValue = toValue . toList + instance ToValue a => ToValue (Maybe a) where toValue (Just a) = toValue a toValue _ = toValue () @@ -85,6 +85,12 @@ instance FromValue a => FromValue [a] where fromValue (L listV) = fmap fromValue listV fromValue v = error $ $currentLoc ++ "could not unpack " ++ show v ++ " into [Value]" + +instance FromValue a => FromValue (NonEmpty a) where + fromValue v = + case fromValue v of + [] -> error $ $currentLoc ++ "could not unpack empty list into NonEmpty Value" + (x:xs) -> x :| xs instance FromValue a => FromValue (Maybe a) where fromValue (N ()) = Nothing diff --git a/test/Doctest.hs b/test/Doctest.hs --- a/test/Doctest.hs +++ b/test/Doctest.hs @@ -11,6 +11,7 @@ , "src/Database/Bolt/Extras/DSL/Typed.hs" , "src/Database/Bolt/Extras/DSL/Typed/Types.hs" , "src/Database/Bolt/Extras/DSL/Typed/Parameters.hs" + , "src/Database/Bolt/Extras/Generic.hs" ] -- This has to be run separately due to some complications with TH and/or internal modules -- See here: https://github.com/sol/doctest/issues/160