Add missing instances (Decode, Encode) (#479)

* feat: decode Set

* feat: non empty and refined list

* feat: encode instance + cleaner imports

* fix: issues with type order

* fix: issues with hlint

* feat: error on duplicate value in sets

* feat: update changelog

Author: theobat

changelog.md

@@ -13,6 +13,12 @@
   - runPubApp: generalized version of `httpPubApp`
   - runSubApp: generalized version of `webSocketsApp`
 
+- New encode and decode instances for `Set`, `NonEmpty`, `Seq` and `Vector`
+  `Set` and `NonEmpty` throw a graphql error when a duplicate is found (Set)
+  or when an empty list is sent (NonEmpty).
+  **Beware**: Right now, all these types are advertised as lists in the introspection query.
+    This is something we are trying to change by submitting a proposal to the graphql spec.
+
 ### Minor Changes
 
 - parser performance optimization

src/Data/Morpheus/Server/Deriving/Decode.hs

@@ -21,10 +21,12 @@ module Data.Morpheus.Server.Deriving.Decode
   )
 where
 
-import Control.Applicative ((<*>), pure)
+import Control.Applicative (pure, (<*>))
 import Control.Monad ((>>=))
-import Data.Functor ((<$>), Functor (..))
+import Data.Functor (Functor (..), (<$>))
 import Data.List (elem)
+import Data.List.NonEmpty (NonEmpty)
+import qualified Data.List.NonEmpty as NonEmpty
 import Data.Maybe (Maybe (..))
 import Data.Morpheus.Internal.Utils
   ( elems,
@@ -41,19 +43,12 @@ import Data.Morpheus.Server.Deriving.Utils
     datatypeNameProxy,
     selNameProxy,
   )
-import Data.Morpheus.Server.Internal.TH.Decode
-  ( decodeFieldWith,
-    withInputObject,
-    withInputUnion,
-    withList,
-    withMaybe,
-    withScalar,
-  )
+import Data.Morpheus.Server.Internal.TH.Decode (decodeFieldWith, withInputObject, withInputUnion, withList, withMaybe, withRefinedList, withScalar)
 import Data.Morpheus.Server.Types.GQLType
   ( GQLType
       ( KIND,
-        __type,
-        typeOptions
+        typeOptions,
+        __type
       ),
     GQLTypeOptions (..),
     TypeData (..),
@@ -79,14 +74,15 @@ import Data.Morpheus.Types.Internal.Resolving
   )
 import Data.Proxy (Proxy (..))
 import Data.Semigroup (Semigroup (..))
+import Data.Sequence (Seq)
+import qualified Data.Sequence as Seq
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.String (IsString (fromString))
+import Data.Vector (Vector)
+import qualified Data.Vector as Vector
 import GHC.Generics
-import Prelude
-  ( ($),
-    (.),
-    Eq (..),
-    Ord,
-    otherwise,
-  )
+import Prelude (Either (Left, Right), Eq (..), Foldable (length), Ord, maybe, otherwise, show, ($), (-), (.))
 
 type DecodeConstraint a =
   ( Generic a,
@@ -113,6 +109,26 @@ instance Decode a => Decode (Maybe a) where
 instance Decode a => Decode [a] where
   decode = withList decode
 
+instance Decode a => Decode (NonEmpty a) where
+  decode = withRefinedList (maybe (Left "Expected a NonEmpty list") Right . NonEmpty.nonEmpty) decode
+
+-- | Should this instance dedupe silently or fail on dupes ?
+instance (Ord a, Decode a) => Decode (Set a) where
+  decode val = do
+    listVal <- withList (decode @a) val
+    let setVal = Set.fromList listVal
+    let setLength = length setVal
+    let listLength = length setVal
+    if listLength == setLength
+      then pure setVal
+      else failure (fromString ("Expected a List without duplicates, found " <> show (setLength - listLength) <> " duplicates") :: InternalError)
+
+instance (Decode a) => Decode (Seq a) where
+  decode = fmap Seq.fromList . withList decode
+
+instance (Decode a) => Decode (Vector a) where
+  decode = fmap Vector.fromList . withList decode
+
 -- | Decode GraphQL type with Specific Kind
 class DecodeKind (kind :: GQL_KIND) a where
   decodeKind :: Proxy kind -> ValidValue -> ResolverState a

src/Data/Morpheus/Server/Deriving/Encode.hs

@@ -23,6 +23,8 @@ import Control.Applicative (Applicative (..))
 import Control.Monad (Monad ((>>=)))
 import Data.Functor (fmap)
 import Data.Functor.Identity (Identity (..))
+import Data.List.NonEmpty (NonEmpty)
+import qualified Data.List.NonEmpty as NonEmpty
 import Data.Map (Map)
 import qualified Data.Map as M
   ( toList,
@@ -91,14 +93,17 @@ import Data.Set (Set)
 import qualified Data.Set as S
   ( toList,
   )
+import Data.Text (pack)
 import Data.Traversable (traverse)
+import Data.Vector (Vector)
+import qualified Data.Vector as Vector
 import GHC.Generics
   ( Generic (..),
   )
 import Prelude
-  ( ($),
+  ( otherwise,
+    ($),
     (.),
-    otherwise,
   )
 
 newtype ContextValue (kind :: GQL_KIND) a = ContextValue
@@ -123,6 +128,14 @@ instance (Monad m, Encode o e m a, LiftOperation o) => Encode o e m [a] where
 instance Encode o e m (Pair k v) => Encode o e m (k, v) where
   encode (key, value) = encode (Pair key value)
 
+--  NonEmpty
+instance Encode o e m [a] => Encode o e m (NonEmpty a) where
+  encode = encode . NonEmpty.toList
+
+--  Vector
+instance Encode o e m [a] => Encode o e m (Vector a) where
+  encode = encode . Vector.toList
+
 --  Set
 instance Encode o e m [a] => Encode o e m (Set a) where
   encode = encode . S.toList
@@ -195,10 +208,10 @@ convertNode
       encodeUnion fields =
         ResUnion
           consName
-          $ pure
-          $ mkObject
-            consName
-            (fmap toFieldRes fields)
+          $ pure $
+            mkObject
+              consName
+              (fmap toFieldRes fields)
 
 -- Types & Constrains -------------------------------------------------------
 exploreResolvers ::

src/Data/Morpheus/Server/Internal/TH/Decode.hs

@@ -8,6 +8,7 @@ module Data.Morpheus.Server.Internal.TH.Decode
   ( withInputObject,
     withMaybe,
     withList,
+    withRefinedList,
     withEnum,
     withInputUnion,
     decodeFieldWith,
@@ -73,6 +74,20 @@ withList ::
 withList decode (List li) = traverse decode li
 withList _ isType = failure (typeMismatch "List" isType)
 
+-- | Useful for more restrictive instances of lists (non empty, size indexed etc)
+withRefinedList ::
+  (Failure InternalError m, Monad m) =>
+  ([a] -> Either Message (rList a)) ->
+  (ValidValue -> m a) ->
+  ValidValue ->
+  m (rList a)
+withRefinedList refiner decode (List li) = do
+  listRes <- traverse decode li
+  case refiner listRes of
+    Left err -> failure (typeMismatch err (List li))
+    Right value -> pure value
+withRefinedList _ _ isType = failure (typeMismatch "List" isType)
+
 withEnum :: Failure InternalError m => (TypeName -> m a) -> Value VALID -> m a
 withEnum decode (Enum value) = decode value
 withEnum _ isType = failure (typeMismatch "Enum" isType)