hasbolt-extras 0.0.1.7 → 0.0.1.8

raw patch · 6 files changed

+113/−9 lines, 6 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• hasbolt-extras.cabal +2/−1
• src/Database/Bolt/Extras/DSL/Typed/Parameters.hs +1/−1
• src/Database/Bolt/Extras/Generic.hs +91/−0
• src/Database/Bolt/Extras/Internal/Instances.hs +13/−7
• test/Doctest.hs +1/−0

@@ -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`.

@@ -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

@@ -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)

@@ -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 (..))+-}

@@ -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

@@ -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