Skip to content

Commit

Permalink
Merge pull request #55 from biocad/maksbotan/hascallstack
Browse files Browse the repository at this point in the history
version 0.0.2.2: add HasCallStack
  • Loading branch information
maksbotan authored May 5, 2023
2 parents 6652c6a + 3ffe623 commit d3f78a8
Show file tree
Hide file tree
Showing 9 changed files with 72 additions and 52 deletions.
35 changes: 20 additions & 15 deletions .github/workflows/haskell-ci.yml
Original file line number Diff line number Diff line change
Expand Up @@ -8,9 +8,9 @@
#
# For more information, see https://github.com/haskell-CI/haskell-ci
#
# version: 0.14.3
# version: 0.16
#
# REGENDATA ("0.14.3",["github","hasbolt-extras.cabal"])
# REGENDATA ("0.16",["github","hasbolt-extras.cabal"])
#
name: Haskell-CI
on:
Expand All @@ -23,7 +23,7 @@ on:
jobs:
linux:
name: Haskell-CI - Linux - ${{ matrix.compiler }}
runs-on: ubuntu-18.04
runs-on: ubuntu-20.04
timeout-minutes:
60
container:
Expand All @@ -32,14 +32,19 @@ jobs:
strategy:
matrix:
include:
- compiler: ghc-9.6.1
compilerKind: ghc
compilerVersion: 9.6.1
setup-method: ghcup
allow-failure: true
- compiler: ghc-9.4.4
compilerKind: ghc
compilerVersion: 9.4.4
setup-method: ghcup
allow-failure: true
- compiler: ghc-9.2.5
- compiler: ghc-9.2.7
compilerKind: ghc
compilerVersion: 9.2.5
compilerVersion: 9.2.7
setup-method: ghcup
allow-failure: true
- compiler: ghc-9.0.2
Expand Down Expand Up @@ -70,18 +75,18 @@ jobs:
apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5
if [ "${{ matrix.setup-method }}" = ghcup ]; then
mkdir -p "$HOME/.ghcup/bin"
curl -sL https://downloads.haskell.org/ghcup/0.1.17.5/x86_64-linux-ghcup-0.1.17.5 > "$HOME/.ghcup/bin/ghcup"
curl -sL https://downloads.haskell.org/ghcup/0.1.19.2/x86_64-linux-ghcup-0.1.19.2 > "$HOME/.ghcup/bin/ghcup"
chmod a+x "$HOME/.ghcup/bin/ghcup"
"$HOME/.ghcup/bin/ghcup" install ghc "$HCVER"
"$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0
"$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false)
"$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false)
else
apt-add-repository -y 'ppa:hvr/ghc'
apt-get update
apt-get install -y "$HCNAME"
mkdir -p "$HOME/.ghcup/bin"
curl -sL https://downloads.haskell.org/ghcup/0.1.17.5/x86_64-linux-ghcup-0.1.17.5 > "$HOME/.ghcup/bin/ghcup"
curl -sL https://downloads.haskell.org/ghcup/0.1.19.2/x86_64-linux-ghcup-0.1.19.2 > "$HOME/.ghcup/bin/ghcup"
chmod a+x "$HOME/.ghcup/bin/ghcup"
"$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0
"$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false)
fi
env:
HCKIND: ${{ matrix.compilerKind }}
Expand All @@ -99,13 +104,13 @@ jobs:
echo "HC=$HC" >> "$GITHUB_ENV"
echo "HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV"
echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$GITHUB_ENV"
echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.2.0 -vnormal+nowrap" >> "$GITHUB_ENV"
echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV"
else
HC=$HCDIR/bin/$HCKIND
echo "HC=$HC" >> "$GITHUB_ENV"
echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV"
echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV"
echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.2.0 -vnormal+nowrap" >> "$GITHUB_ENV"
echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV"
fi
HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')
Expand Down Expand Up @@ -157,8 +162,8 @@ jobs:
- name: install cabal-plan
run: |
mkdir -p $HOME/.cabal/bin
curl -sL https://github.com/haskell-hvr/cabal-plan/releases/download/v0.6.2.0/cabal-plan-0.6.2.0-x86_64-linux.xz > cabal-plan.xz
echo 'de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz' | sha256sum -c -
curl -sL https://github.com/haskell-hvr/cabal-plan/releases/download/v0.7.3.0/cabal-plan-0.7.3.0-x86_64-linux.xz > cabal-plan.xz
echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c -
xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan
rm -f cabal-plan.xz
chmod a+x $HOME/.cabal/bin/cabal-plan
Expand Down Expand Up @@ -220,7 +225,7 @@ jobs:
$CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct
- name: haddock
run: |
$CABAL v2-haddock $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all
$CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all
- name: unconstrained build
run: |
rm -f cabal.project.local
Expand Down
7 changes: 6 additions & 1 deletion CHANGELOG.md
Original file line number Diff line number Diff line change
Expand Up @@ -6,9 +6,14 @@ and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.

## [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.
Expand Down
5 changes: 3 additions & 2 deletions hasbolt-extras.cabal
Original file line number Diff line number Diff line change
@@ -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
Expand All @@ -22,8 +22,9 @@ tested-with:
|| ==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
Expand Down
3 changes: 2 additions & 1 deletion src/Database/Bolt/Extras/Graph/Internal/Class.hs
Original file line number Diff line number Diff line change
Expand Up @@ -8,6 +8,7 @@ module Database.Bolt.Extras.Graph.Internal.Class
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.
--
Expand All @@ -27,4 +28,4 @@ class Returnable a where
-- | 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]
19 changes: 10 additions & 9 deletions src/Database/Bolt/Extras/Graph/Internal/Get.hs
Original file line number Diff line number Diff line change
Expand Up @@ -89,6 +89,7 @@ import Database.Bolt.Extras.Graph.Internal.Class (Extractable
Requestable (..),
Returnable (..))
import GHC.Generics (Generic)
import GHC.Stack (HasCallStack)
import Language.Haskell.TH.Syntax (Name,
nameBase)
import NeatInterpolation (text)
Expand Down Expand Up @@ -301,7 +302,7 @@ instance Extractable NodeResult where
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)
Expand Down Expand Up @@ -333,38 +334,38 @@ type GraphGetResponse = Graph NodeName NodeResult RelResult

-- | 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"
17 changes: 11 additions & 6 deletions src/Database/Bolt/Extras/Internal/Instances.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand All @@ -18,6 +20,7 @@ import Database.Bolt.Extras.Internal.Types (FromValue (..), NodeLike (
ToValue (..))
import Database.Bolt.Extras.Utils (currentLoc)
import GHC.Float (double2Float, float2Double)
import GHC.Stack (HasCallStack)


instance ToValue () where
Expand Down Expand Up @@ -69,30 +72,30 @@ instance FromValue () where

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 =
Expand All @@ -113,6 +116,7 @@ instance FromValue DB.Structure where
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
Expand All @@ -123,6 +127,7 @@ instance ToJSON Value where
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)
Expand Down
5 changes: 3 additions & 2 deletions src/Database/Bolt/Extras/Internal/Persisted.hs
Original file line number Diff line number Diff line change
Expand Up @@ -15,6 +15,7 @@ import Data.Aeson.Casing (aesonPrefix, snakeCase)
import Database.Bolt (Node (..), Relationship (..),
URelationship (..))
import GHC.Generics (Generic (..))
import GHC.Stack (HasCallStack)

-- | 'BoltId' is alias for Bolt 'Node', 'Relationship' and 'URelationship' identities.
--
Expand All @@ -28,14 +29,14 @@ data Persisted a = Persisted { objectId :: BoltId

-- | 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
Expand Down
19 changes: 10 additions & 9 deletions src/Database/Bolt/Extras/Template/Internal/Converters.hs
Original file line number Diff line number Diff line change
Expand Up @@ -21,6 +21,7 @@ import Database.Bolt.Extras.Utils (currentLoc, dummyId)
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.
Expand Down Expand Up @@ -99,7 +100,7 @@ uRelationLikeClass = BiClassInfo { className = ''URelationLike
--
-- >>> 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
Expand All @@ -109,18 +110,18 @@ makeNodeLike name = makeBiClassInstance nodeLikeClass name id
--
-- > 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.
Expand Down Expand Up @@ -152,7 +153,7 @@ makeURelationLikeWith = makeBiClassInstance uRelationLikeClass
-- > , 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
Expand Down Expand Up @@ -184,7 +185,7 @@ makeBiClassInstance BiClassInfo {..} typeCon fieldLabelModifier = do

-- | 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)
Expand All @@ -194,7 +195,7 @@ getConsFields _ = error $ $currentLoc ++ "unsupported

-- | 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'."
Expand Down Expand Up @@ -316,15 +317,15 @@ checkProps container = all (\(fieldName, fieldMaybe) -> fieldMaybe || fieldName
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
exactE v = case exactEither v of
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
Expand Down
Loading

0 comments on commit d3f78a8

Please sign in to comment.