diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. 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.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 diff --git a/src/Database/Bolt/Extras/Graph/Internal/Class.hs b/src/Database/Bolt/Extras/Graph/Internal/Class.hs --- a/src/Database/Bolt/Extras/Graph/Internal/Class.hs +++ b/src/Database/Bolt/Extras/Graph/Internal/Class.hs @@ -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] diff --git a/src/Database/Bolt/Extras/Graph/Internal/Get.hs b/src/Database/Bolt/Extras/Graph/Internal/Get.hs --- a/src/Database/Bolt/Extras/Graph/Internal/Get.hs +++ b/src/Database/Bolt/Extras/Graph/Internal/Get.hs @@ -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" 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 @@ -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) diff --git a/src/Database/Bolt/Extras/Internal/Persisted.hs b/src/Database/Bolt/Extras/Internal/Persisted.hs --- a/src/Database/Bolt/Extras/Internal/Persisted.hs +++ b/src/Database/Bolt/Extras/Internal/Persisted.hs @@ -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 diff --git a/src/Database/Bolt/Extras/Template/Internal/Converters.hs b/src/Database/Bolt/Extras/Template/Internal/Converters.hs --- a/src/Database/Bolt/Extras/Template/Internal/Converters.hs +++ b/src/Database/Bolt/Extras/Template/Internal/Converters.hs @@ -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 diff --git a/src/Database/Bolt/Extras/Utils.hs b/src/Database/Bolt/Extras/Utils.hs --- a/src/Database/Bolt/Extras/Utils.hs +++ b/src/Database/Bolt/Extras/Utils.hs @@ -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)