hasbolt-extras 0.0.2.1 → 0.0.2.2

raw patch · 8 files changed

+52/−37 lines, 8 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−1
• hasbolt-extras.cabal +3/−2
• src/Database/Bolt/Extras/Graph/Internal/Class.hs +2/−1
• src/Database/Bolt/Extras/Graph/Internal/Get.hs +10/−9
• src/Database/Bolt/Extras/Internal/Instances.hs +11/−6
• src/Database/Bolt/Extras/Internal/Persisted.hs +3/−2
• src/Database/Bolt/Extras/Template/Internal/Converters.hs +10/−9
• src/Database/Bolt/Extras/Utils.hs +7/−7

@@ -6,9 +6,14 @@  ## [Unreleased] +## [0.0.2.2] - 2023-05-05+### Changed+- Add `HasCallStack` to a lot of unpacking functions.+ ## [0.0.2.1] - 2023-01-24 ### Added-- Add newline for Cyper queries.+- Add newline for Cypher queries.+ ## [0.0.2.0] - 2023-01-24 ### Added - `BoltGeneric` wrapper for `DerivingVia` to derive `IsValue` and `RecordValue` for Haskell types.

@@ -1,5 +1,5 @@ name:           hasbolt-extras-version:        0.0.2.1+version:        0.0.2.2 synopsis:       Extras for hasbolt library description:    Extras for hasbolt library homepage:       https://github.com/biocad/hasbolt-extras#readme@@ -22,8 +22,9 @@    || ==8.8.4    || ==8.10.7    || ==9.0.2-   || ==9.2.5+   || ==9.2.7    || ==9.4.4+   || ==9.6.1  source-repository head   type: git

@@ -8,6 +8,7 @@ import           Control.Monad.IO.Class (MonadIO) import           Data.Text              (Text) import           Database.Bolt          (BoltActionT, Record)+import           GHC.Stack              (HasCallStack)  -- | Entity which can be requested from Neo4j in @MATCH@ operator. --@@ -27,4 +28,4 @@ -- | Entity which can be extracted from 'Record' by its name. -- class Extractable a where-  extract :: MonadIO m => Text -> [Record] -> BoltActionT m [a]+  extract :: (HasCallStack, MonadIO m) => Text -> [Record] -> BoltActionT m [a]

@@ -89,6 +89,7 @@                                                                     Requestable (..),                                                                     Returnable (..)) import           GHC.Generics                                      (Generic)+import           GHC.Stack                                         (HasCallStack) import           Language.Haskell.TH.Syntax                        (Name,                                                                     nameBase) import           NeatInterpolation                                 (text)@@ -301,7 +302,7 @@ instance Extractable RelResult where   extract = extractFromJSON -extractFromJSON :: (MonadIO m, FromJSON a) => Text -> [Record] -> BoltActionT m [a]+extractFromJSON :: (HasCallStack, MonadIO m, FromJSON a) => Text -> [Record] -> BoltActionT m [a] extractFromJSON var = pure . fmap (\r -> case fromJSON (toJSON (r ! var)) of                                         Success parsed -> parsed                                         Error   err    -> error err)@@ -333,38 +334,38 @@  -- | Extract a node by its name from 'GraphGetResponse' and convert it to user type -- with 'fromNode'.-extractNode :: NodeLike a => NodeName -> GraphGetResponse -> a+extractNode :: HasCallStack => NodeLike a => NodeName -> GraphGetResponse -> a extractNode var graph = graph ^. vertices . at var . non (errorForNode var) . to (fromNode . toNode)  -- | Extract a relation by name of it start and end nodes and convert to user type with 'fromURelation'.-extractRelation :: URelationLike a => NodeName -> NodeName -> GraphGetResponse -> a+extractRelation :: HasCallStack => URelationLike a => NodeName -> NodeName -> GraphGetResponse -> a extractRelation stVar enVar graph = graph ^. relations . at (stVar, enVar)                                   . non (errorForRelation stVar enVar)                                   . to (fromURelation . toURelation)  -- | Extract just node's 'BoltId'.-extractNodeId :: NodeName -> GraphGetResponse -> BoltId+extractNodeId :: HasCallStack => NodeName -> GraphGetResponse -> BoltId extractNodeId var graph = graph ^. vertices . at var . non (errorForNode var) . to nresId  -- | Extract just relation's 'BoltId'.-extractRelationId :: NodeName -> NodeName -> GraphGetResponse -> BoltId+extractRelationId :: HasCallStack => NodeName -> NodeName -> GraphGetResponse -> BoltId extractRelationId stVar enVar graph = graph ^. relations . at (stVar, enVar)                                     . non (errorForRelation stVar enVar)                                     . to rresId  -- | Extract 'NodeResult'.-extractNodeAeson :: NodeName -> GraphGetResponse -> NodeResult+extractNodeAeson :: HasCallStack => NodeName -> GraphGetResponse -> NodeResult extractNodeAeson var graph = graph ^. vertices . at var . non (errorForNode var)  -- | Extract 'RelResult'.-extractRelationAeson :: NodeName -> NodeName -> GraphGetResponse -> RelResult+extractRelationAeson :: HasCallStack => NodeName -> NodeName -> GraphGetResponse -> RelResult extractRelationAeson stVar enVar graph = graph ^. relations . at (stVar, enVar)                                        . non (errorForRelation stVar enVar) -errorForNode :: NodeName -> a+errorForNode :: HasCallStack => NodeName -> a errorForNode name = error . unpack $ "node with name " <> name <> " doesn't exist" -errorForRelation :: NodeName -> NodeName -> a+errorForRelation :: HasCallStack => NodeName -> NodeName -> a errorForRelation stName enName = error . unpack $ "relation between nodes " <>                                                   stName <> " and " <> enName <>                                                   " doesn't exist"

@@ -2,11 +2,13 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell   #-} {-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE InstanceSigs      #-}  module Database.Bolt.Extras.Internal.Instances () where  import           Control.Applicative                 ((<|>)) import           Data.Aeson                          (FromJSON (..), ToJSON (..))+import qualified Data.Aeson                          as A import           Data.Aeson.Types                    (Parser) import           Data.List.NonEmpty                  (NonEmpty (..), toList) import           Data.Map.Strict                     (Map)@@ -18,6 +20,7 @@                                                       ToValue (..)) import           Database.Bolt.Extras.Utils          (currentLoc) import           GHC.Float                           (double2Float, float2Double)+import           GHC.Stack                           (HasCallStack)   instance ToValue () where@@ -69,30 +72,30 @@  instance FromValue Bool where   fromValue (B boolV) = boolV-  fromValue v      = error $ $currentLoc ++ "could not unpack " ++ show v ++ " into Bool"+  fromValue v         = error $ $currentLoc ++ "could not unpack " ++ show v ++ " into Bool"  instance FromValue Int where   fromValue (I intV) = intV-  fromValue v      = error $ $currentLoc ++ "could not unpack " ++ show v ++ " into Int"+  fromValue v        = error $ $currentLoc ++ "could not unpack " ++ show v ++ " into Int"  instance FromValue Double where   fromValue (F doubleV) = doubleV-  fromValue v      = error $ $currentLoc ++ "could not unpack " ++ show v ++ " into Double"+  fromValue v           = error $ $currentLoc ++ "could not unpack " ++ show v ++ " into Double"  instance FromValue Float where   fromValue (F doubleV) = double2Float doubleV-  fromValue v      = error $ $currentLoc ++ "could not unpack " ++ show v ++ " into Float"+  fromValue v           = error $ $currentLoc ++ "could not unpack " ++ show v ++ " into Float"  instance FromValue Text where   fromValue (T textV) = textV-  fromValue v      = error $ $currentLoc ++ "could not unpack " ++ show v ++ " into Text"+  fromValue v         = error $ $currentLoc ++ "could not unpack " ++ show v ++ " into Text"  instance FromValue Value where   fromValue = id  instance FromValue a => FromValue [a] where   fromValue (L listV) = fmap fromValue listV-  fromValue v      = error $ $currentLoc ++ "could not unpack " ++ show v ++ " into [Value]"+  fromValue v         = error $ $currentLoc ++ "could not unpack " ++ show v ++ " into [Value]"  instance FromValue a => FromValue (NonEmpty a) where   fromValue v =@@ -113,6 +116,7 @@   fromValue v      = error $ $currentLoc ++ "could not unpack " ++ show v ++ " into Structure"  instance ToJSON Value where+  toJSON :: HasCallStack => Value -> A.Value   toJSON (N _) = toJSON ()   toJSON (B b) = toJSON b   toJSON (I i) = toJSON i@@ -123,6 +127,7 @@   toJSON _     = error "Database.Bolt.Extras.Internal.Instances: could not convert to json Database.Bolt.Value"  instance FromJSON Value where+  parseJSON :: HasCallStack => A.Value -> Parser Value   parseJSON v = B <$> (parseJSON v :: Parser Bool)             <|> I <$> (parseJSON v :: Parser Int)             <|> F <$> (parseJSON v :: Parser Double)

@@ -15,6 +15,7 @@ import           Database.Bolt     (Node (..), Relationship (..),                                     URelationship (..)) import           GHC.Generics      (Generic (..))+import           GHC.Stack         (HasCallStack)  -- | 'BoltId' is alias for Bolt 'Node', 'Relationship' and 'URelationship' identities. --@@ -28,14 +29,14 @@  -- | This is just check that your 'BoltId' is valid. ---fromInt :: Int -> BoltId+fromInt :: HasCallStack => Int -> BoltId fromInt i | i >= 0    = i           | otherwise = error "Database.Bolt.Extras.Internal.Persisted: could not create BoltId with identity less then zero."  -- | Common class to get 'BoltId' from the object. -- class GetBoltId a where-  getBoltId :: a -> BoltId+  getBoltId :: HasCallStack => a -> BoltId  instance GetBoltId Node where   getBoltId = fromInt . nodeIdentity

@@ -21,6 +21,7 @@ import           Instances.TH.Lift          () import           Language.Haskell.TH import           Language.Haskell.TH.Syntax+import           GHC.Stack                  (HasCallStack)  -- Starting with template-haskell-2.16.0.0, 'TupE' constructor accepts @Maybe Exp@, to support -- TupleSections. We use this alias for compatibility with both old and new versions.@@ -99,7 +100,7 @@ -- -- >>> fromNode barNode :: Foo -- Bar {baz = 42.0, quux = "Hello world", quuz = Nothing}-makeNodeLike :: Name -> Q [Dec]+makeNodeLike :: HasCallStack => Name -> Q [Dec] makeNodeLike name = makeBiClassInstance nodeLikeClass name id  -- | The same as 'makeNodeLike', but applies a function to all field names before storing them@@ -109,18 +110,18 @@ -- -- > makeNodeLikeWith ''Foo $ fieldLabelModifier $ aesonPrefix camelCase ---makeNodeLikeWith :: Name -> (String -> String) -> Q [Dec]+makeNodeLikeWith :: HasCallStack => Name -> (String -> String) -> Q [Dec] makeNodeLikeWith = makeBiClassInstance nodeLikeClass  -- | Make an instance of 'URelationLike' class. -- Transformations are the same as in 'NodeLike' instance declaration with the only one difference: -- 'URelationship' holds only one label (or type), but 'Node' holds list of labels. ---makeURelationLike :: Name -> Q [Dec]+makeURelationLike :: HasCallStack => Name -> Q [Dec] makeURelationLike name = makeBiClassInstance uRelationLikeClass name id  -- | As 'makeNodeLikeWith'.-makeURelationLikeWith :: Name -> (String -> String) -> Q [Dec]+makeURelationLikeWith :: HasCallStack => Name -> (String -> String) -> Q [Dec] makeURelationLikeWith = makeBiClassInstance uRelationLikeClass  -- | Declare an instance of `bijective` class using TemplateHaskell.@@ -152,7 +153,7 @@ -- >      , nodeProps = fromList [("specie", T "text value"), ("vgen", F %float_value), ("fr", F %float_value), ("sim", F %float_value), ("germline", T "text value")] -- >     } ---makeBiClassInstance :: BiClassInfo -> Name -> (String -> String) -> Q [Dec]+makeBiClassInstance :: HasCallStack => BiClassInfo -> Name -> (String -> String) -> Q [Dec] makeBiClassInstance BiClassInfo {..} typeCon fieldLabelModifier = do   -- reify function gives Info about Name such as constructor name and its fields. See: https://hackage.haskell.org/package/template-haskell-2.12.0.0/docs/Language-Haskell-TH.html#t:Info   TyConI declaration <- reify typeCon@@ -184,7 +185,7 @@  -- | Extract information about type: constructor name and field record names with corresponding types. ---getConsFields :: Con -> (Name, [(Name, Type)])+getConsFields :: HasCallStack => Con -> (Name, [(Name, Type)]) getConsFields (RecC cName decs)           = (cName, fmap (\(fname, _, ftype) -> (fname, ftype)) decs) getConsFields (ForallC _ _ cons)          = getConsFields cons getConsFields (RecGadtC (cName:_) decs _) = (cName, fmap (\(fname, _, ftype) -> (fname, ftype)) decs)@@ -194,7 +195,7 @@  -- | Parse a type declaration and retrieve its name and its constructors. ---getTypeCons :: Dec -> (Name, [Con])+getTypeCons :: HasCallStack => Dec -> (Name, [Con]) getTypeCons (DataD    _ typeName _ _ constructors _) = (typeName, constructors) getTypeCons (NewtypeD _ typeName _ _ constructor  _) = (typeName, [constructor]) getTypeCons otherDecl = error $ $currentLoc ++ "unsupported declaration: " ++ show otherDecl ++ "\nShould be either 'data' or 'newtype'."@@ -316,7 +317,7 @@ checkLabels :: Labels t => t -> [Text] -> Bool checkLabels container = all (`elem` getLabels container) -getProp :: (Properties t, RecordValue a) => t -> (Text, Bool) -> a+getProp :: (HasCallStack, Properties t, RecordValue a) => t -> (Text, Bool) -> a getProp container (fieldName, fieldMaybe) | fieldMaybe && fieldName `notMember` getProps container = exactE $ N ()                                           | otherwise = exactE (getProps container ! fieldName)   where@@ -324,7 +325,7 @@       Right res -> res       Left err -> error $ show err -unpackError :: Show c => c -> String -> a+unpackError :: HasCallStack => Show c => c -> String -> a unpackError container label = error $ $currentLoc ++ " could not unpack " ++ label ++ " from " ++ show container  {- $setup

@@ -15,10 +15,10 @@ import           Data.Map.Strict        as M ((!), (!?)) import qualified Data.Map.Strict        as M (union) import           Data.Text              (Text)-import           Database.Bolt          as B (BoltActionT, Node (..), Record,-                                              RecordValue (..), Value (..))-import           Language.Haskell.TH    (Exp (..), Lit (..), Loc (..), Q,-                                         location)+import           Database.Bolt          as B (BoltActionT, Node (..), Record, RecordValue (..),+                                              Value (..))+import           GHC.Stack              (HasCallStack)+import           Language.Haskell.TH    (Exp (..), Lit (..), Loc (..), Q, location) import           Text.Printf            (printf)  @@ -45,16 +45,16 @@  -- | Unpack a value, using 'fail' in 'IO` to report errors. {-# DEPRECATED exact "This function exists for compatibility, consider using pure exactEither or exactMaybe instead." #-}-exact :: (MonadIO m, RecordValue a) => Value -> m a+exact :: (MonadIO m, RecordValue a, HasCallStack) => Value -> m a exact = either (liftIO . fail . show) pure . exactEither  -- | Extract values ---exactValues :: (MonadIO m, RecordValue a) => Text -> [Record] -> m [a]+exactValues :: HasCallStack => (MonadIO m, RecordValue a) => Text -> [Record] -> m [a] exactValues var = mapM (exact . (! var))  -- | Extract values (maybe)-exactValuesM :: (MonadIO m, RecordValue a) => Text -> [Record] -> BoltActionT m [Maybe a]+exactValuesM :: (HasCallStack, MonadIO m, RecordValue a) => Text -> [Record] -> BoltActionT m [Maybe a] exactValuesM var = mapM (safeExact . (!? var))   where     safeExact :: (MonadIO m, RecordValue a) => Maybe B.Value -> BoltActionT m (Maybe a)