version 0.0.1.3: fix bug in GetTypeFromRecord (#38)

biocad · Mar 4, 2020 · 2ce56b3 · 2ce56b3
1 parent cdc3368
commit 2ce56b3
Show file tree

Hide file tree

Showing 5 changed files with 30 additions and 5 deletions.
diff --git a/CHANGELOG.md b/CHANGELOG.md
@@ -6,6 +6,12 @@ and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.
 
 ## [Unreleased]
 
+## [0.0.1.3] - 2020-03-04
+### Fixed
+- https://www.wrike.com/open.htm?id=472936296: fix recursion in `GetTypeFromRecord` type family.
+### Added
+- Export of `LabelConstraint` to allow users to define wrappers around `lbl`.
+
 ## [0.0.1.2] - 2020-01-17
 ### Added
 - `=:` type synonym to avoid ticks in type-level tuples.

diff --git a/hasbolt-extras.cabal b/hasbolt-extras.cabal
@@ -1,5 +1,5 @@
 name:           hasbolt-extras
-version:        0.0.1.2
+version:        0.0.1.3
 synopsis:       Extras for hasbolt library
 description:    Extras for hasbolt library
 homepage:       https://github.com/biocad/hasbolt-extras#readme

diff --git a/src/Database/Bolt/Extras/DSL/Typed.hs b/src/Database/Bolt/Extras/DSL/Typed.hs
@@ -22,6 +22,7 @@ module Database.Bolt.Extras.DSL.Typed
   -- $safety
 
     SelectorLike(..)
+  , LabelConstraint
   , lbl
   , prop
   , propMaybe
@@ -286,3 +287,16 @@ To make sure that all parameters are filled, use 'queryWithParams' function:
 
 See below for more examples.
 -}
+
+{- $tests
+
+These should not generate compile errors.
+
+>>> data TestRecord = TestRecord { first :: Text, second :: Int, third :: Bool, fourth :: Maybe String, fifth :: Text } deriving (Eq, Show, Generic)
+>>> defN .& lbl @TestRecord .& prop (#first =: "foo")
+... NodeSelector ...
+>>> defN .& lbl @TestRecord .& prop (#third =: True) .& prop (#fifth =: "lalala")
+... NodeSelector ...
+>>> defN .& lbl @TestRecord .& prop (#fourth =: "123") .& prop (#first =: "noes")
+... NodeSelector ...
+-}
diff --git a/src/Database/Bolt/Extras/DSL/Typed/Families.hs b/src/Database/Bolt/Extras/DSL/Typed/Families.hs
@@ -28,10 +28,11 @@ type family GetTypeFromRecord (field :: Symbol) (record :: k -> Type) :: Type wh
   GetTypeFromRecord field (D1 _ (C1 _ sels)) = GetTypeFromRecord field sels
   GetTypeFromRecord field (S1 ('MetaSel ('Just field) _ _ _) (Rec0 (Maybe typ))) = typ
   GetTypeFromRecord field (S1 ('MetaSel ('Just field) _ _ _) (Rec0 typ)) = typ
-  GetTypeFromRecord field (S1 ('MetaSel ('Just field) _ _ _) (Rec0 (Maybe typ) ) :*: _) = typ
-  GetTypeFromRecord field (S1 ('MetaSel ('Just field) _ _ _) (Rec0 typ ) :*: _) = typ
-  GetTypeFromRecord field (S1 ('MetaSel ('Just _) _ _ _) (Rec0 typ ) :*: r) =
-    GetTypeFromRecord field r
+  GetTypeFromRecord field (l :*: r)
+    = If
+        (RecordHasField field l)
+        (GetTypeFromRecord field l)
+        (GetTypeFromRecord field r)
 
 -- | This family extracts a type of the field with given name from the first type in the list
 -- that has it.

diff --git a/src/Database/Bolt/Extras/DSL/Typed/Types.hs b/src/Database/Bolt/Extras/DSL/Typed/Types.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE ConstraintKinds        #-}
 {-# LANGUAGE DataKinds              #-}
 {-# LANGUAGE FlexibleContexts       #-}
 {-# LANGUAGE PolyKinds              #-}
@@ -77,6 +78,9 @@ class SelectorLike (a :: k -> Type) where
     -> a types
     -> a types
 
+-- | Constraint for types that may be used with 'lbl'.
+type LabelConstraint (typ :: Type) = KnownSymbol (GetTypeName (Rep typ))
+
 -- | Synonym for 'withLabel' with label type variable as first one, enabling @lbl \@Foo@ type
 -- application syntax.
 lbl