Skip to content

Commit

Permalink
version 0.0.1.8: NonEmpty instances, BoltEnum (#45)
Browse files Browse the repository at this point in the history
* Add ToValue / FromValue instances for NonEmpty

* Add BoltEnum DerivingVia wrapper
  • Loading branch information
maksbotan authored Sep 7, 2021
1 parent bc5988a commit a7d7ef6
Show file tree
Hide file tree
Showing 6 changed files with 113 additions and 9 deletions.
5 changes: 5 additions & 0 deletions CHANGELOG.md
Original file line number Diff line number Diff line change
Expand Up @@ -6,6 +6,11 @@ and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.

## [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`.
Expand Down
3 changes: 2 additions & 1 deletion hasbolt-extras.cabal
Original file line number Diff line number Diff line change
@@ -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
Expand Down Expand Up @@ -28,6 +28,7 @@ library
, 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
Expand Down
2 changes: 1 addition & 1 deletion src/Database/Bolt/Extras/DSL/Typed/Parameters.hs
Original file line number Diff line number Diff line change
Expand Up @@ -17,7 +17,7 @@ import qualified Data.Map.Strict as Map
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)
Expand Down
91 changes: 91 additions & 0 deletions src/Database/Bolt/Extras/Generic.hs
Original file line number Diff line number Diff line change
@@ -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 (..))
-}
20 changes: 13 additions & 7 deletions src/Database/Bolt/Extras/Internal/Instances.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -45,6 +42,9 @@ instance ToValue Value where
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 ()
Expand Down Expand Up @@ -86,6 +86,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
fromValue a = Just $ fromValue a
Expand Down
1 change: 1 addition & 0 deletions test/Doctest.hs
Original file line number Diff line number Diff line change
Expand Up @@ -11,6 +11,7 @@ main = do
, "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
Expand Down

0 comments on commit a7d7ef6

Please sign in to comment.