Jrepr with constraints and validation for union

schematic.cabal

@@ -16,6 +16,7 @@ cabal-version:       >=1.10
 library
   exposed-modules:     Data.Schematic
                      , Data.Schematic.DSL
+                     , Data.Schematic.Compat
                      , Data.Schematic.Generator
                      , Data.Schematic.Generator.Regex
                      , Data.Schematic.Instances
@@ -25,6 +26,7 @@ library
                      , Data.Schematic.Migration
                      , Data.Schematic.Path
                      , Data.Schematic.Schema
+                     , Data.Schematic.Constraints
                      , Data.Schematic.Validation
                      , Data.Schematic.Verifier
                      , Data.Schematic.Verifier.Array
@@ -65,7 +67,7 @@ library
                      , TypeOperators
                      , TypeSynonymInstances
                      , UndecidableInstances
-  build-depends:       base >=4.11 && <4.13
+  build-depends:       base >=4.10 && <4.13
                      , bytestring
                      , aeson >= 1
                      , containers
@@ -75,7 +77,8 @@ library
                      , regex-tdfa
                      , regex-tdfa-text
                      , scientific
-                     , singletons >= 2.4
+                     , singletons
+                     -- >= 2.4
                      , smallcheck
                      , tagged
                      , template-haskell
@@ -95,7 +98,7 @@ test-suite spec
   default-language:   Haskell2010
   build-depends:       HUnit
                      , aeson >= 1
-                     , base >=4.11 && <4.13
+                     , base >=4.10 && <4.13
                      , bytestring
                      , containers
                      , hjsonschema

src/Data/Schematic.hs

@@ -7,9 +7,10 @@ module Data.Schematic
   , module Data.Schematic.Lens
   , module Data.Schematic.Migration
   , module Data.Schematic.Schema
+  , module Data.Schematic.Constraints
+  , module Data.Schematic.Compat
   , decodeAndValidateJson
   , parseAndValidateJson
-  , parseAndValidateJsonBy
   , parseAndValidateTopVersionJson
   , parseAndValidateWithMList
   , decodeAndValidateVersionedWithMList
@@ -27,6 +28,8 @@ import Data.Aeson as J
 import Data.Aeson.Types as J
 import Data.ByteString.Lazy as BL
 import Data.Functor.Identity as F
+import Data.Schematic.Compat
+import Data.Schematic.Constraints
 import Data.Schematic.DSL
 import Data.Schematic.Helpers
 import Data.Schematic.JsonSchema
@@ -41,7 +44,8 @@ import Data.Text as T
 
 parseAndValidateTopVersionJson
   :: forall proxy (v :: Versioned)
-  .  (SingI (TopVersion (AllVersions v)))
+  . ( SingI (TopVersion (AllVersions v))
+    , FromJSON (JsonRepr (TopVersion (AllVersions v))) )
   => proxy v
   -> J.Value
   -> ParseResult (JsonRepr (TopVersion (AllVersions v)))
@@ -64,13 +68,9 @@ parseAndValidateWithMList
   -> m (ParseResult (JsonRepr (Head revisions)))
 parseAndValidateWithMList MNil v = pure $ parseAndValidateJson v
 parseAndValidateWithMList (Tagged f :&& tl) v =
-  case parseAndValidateJsonBy Proxy v of
+  case parseAndValidateJson v of
     Valid a           -> pure $ Valid a
-    DecodingError _   -> do
-      pr <- parseAndValidateWithMList tl v
-      let pr' = f <$> pr
-      sequence pr'
-    ValidationError _ -> do
+    _   -> do
       pr <- parseAndValidateWithMList tl v
       let pr' = f <$> pr
       sequence pr'
@@ -95,7 +95,8 @@ decodeAndValidateVersionedWithMList _ mlist bs = case decode bs of
   Just x  -> parseAndValidateWithMList mlist x
 
 decodeAndValidateVersionedWithPureMList
-  :: proxy versioned
+  :: FromJSON (JsonRepr (Head (MapSnd (AllVersions versioned))))
+  => proxy versioned
   -> MList F.Identity (MapSnd (AllVersions versioned))
   -> BL.ByteString
   -> ParseResult (JsonRepr (Head (MapSnd (AllVersions versioned))))

src/Data/Schematic/Compat.hs

@@ -0,0 +1,34 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE CPP                 #-}
+module Data.Schematic.Compat where
+
+import Data.Singletons.Prelude
+import GHC.TypeLits
+#if MIN_VERSION_base(4,12,0)
+import Data.Vinyl
+#else
+import Data.Kind
+#endif
+
+
+type DeNat = Demote Nat
+-- ^ Demote Nat is depends on version of singletons
+
+demote' :: forall a. (SingI a, SingKind (KindOf a)) => Demote (KindOf a)
+#if MIN_VERSION_singletons(2,4,0)
+type (:+++) a b = (++) a b
+demote' = demote @a
+#else
+type (:+++) a b = (:++) a b
+demote' = fromSing (sing :: Sing a)
+#endif
+
+#if MIN_VERSION_vinyl(0,9,0)
+type RMapCompat fs = RMap fs
+type ReifyConstraintCompat c repr fs = ReifyConstraint c repr fs
+type RecordToListCompat fs = RecordToList fs
+#else
+type RMapCompat fs = (() :: Constraint)
+type ReifyConstraintCompat c fs repr = (() :: Constraint)
+type RecordToListCompat fs = (() :: Constraint)
+#endif

src/Data/Schematic/Constraints.hs

@@ -0,0 +1,41 @@
+{-# LANGUAGE EmptyCase #-}
+{-# OPTIONS_GHC -fprint-explicit-kinds #-}
+
+module Data.Schematic.Constraints where
+
+import Data.Schematic.Compat
+import Data.Singletons.Prelude
+import Data.Singletons.TH
+import Data.Singletons.TypeLits
+import Data.Text as T
+import GHC.Generics (Generic)
+
+
+singletons [d|
+  data TextConstraint' s n
+    = TEq n
+    | TLt n
+    | TLe n
+    | TGt n
+    | TGe n
+    | TRegex s
+    | TEnum [s]
+    deriving (Eq, Show, Generic)
+
+  data NumberConstraint' n
+    = NLe n
+    | NLt n
+    | NGt n
+    | NGe n
+    | NEq n
+    deriving (Eq, Show, Generic)
+
+  data ArrayConstraint' n = AEq n deriving (Eq, Show, Generic)
+  |]
+
+type TextConstraintT = TextConstraint' Text DeNat
+type TextConstraint = TextConstraint' Symbol Nat
+type NumberConstraintT = NumberConstraint' DeNat
+type NumberConstraint = NumberConstraint' Nat
+type ArrayConstraintT = ArrayConstraint' DeNat
+type ArrayConstraint = ArrayConstraint' Nat

src/Data/Schematic/DSL.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE CPP                 #-}
 
 module Data.Schematic.DSL where
 
@@ -18,26 +17,22 @@ import           Data.Vinyl
 import           Data.Vinyl.Functor
 
 
-#if MIN_VERSION_base(4,12,0)
 type Constructor a
   = forall fields b
-  . (fields ~ FieldsOf a, FSubset fields b (FImage fields b), RMap fields)
+  . ( fields ~ FieldsOf a, FSubset fields b (FImage fields b)
+    , ReprObjectConstr fields )
   => Rec (Tagged fields :. FieldRepr) b
   -> JsonRepr ('SchemaObject fields)
-#else
-type Constructor a
-  = forall fields b
-  . (fields ~ FieldsOf a, FSubset fields b (FImage fields b))
-  => Rec (Tagged fields :. FieldRepr) b
-  -> JsonRepr ('SchemaObject fields)
-#endif
+
 withRepr :: Constructor a
 withRepr = ReprObject . rmap (unTagged . getCompose) . fcast
 
 class Representable s where
   constructField :: Sing fn -> Proxy s -> Repr s -> FieldRepr '(fn, s)
 
-instance SingI so => Representable ('SchemaObject so) where
+instance
+  (SingI so, ReprObjectConstr so)
+  => Representable ('SchemaObject so) where
   constructField sfn _ o = withKnownSymbol sfn $ FieldRepr $ ReprObject o
 
 instance (SingI cs, SingI sa) => Representable ('SchemaArray cs sa) where
@@ -55,22 +50,10 @@ instance Representable 'SchemaBoolean where
 instance SingI so => Representable ('SchemaOptional so) where
   constructField sfn _ o = withKnownSymbol sfn $ FieldRepr $ ReprOptional o
 
-instance SingI (h ': tl) => Representable ('SchemaUnion (h ': tl)) where
+instance (SingI (h ': tl), ReprUnionConstr tl)
+  => Representable ('SchemaUnion (h ': tl)) where
   constructField sfn _ u = withKnownSymbol sfn $ FieldRepr $ ReprUnion u
 
-construct :: Sing s -> Repr s -> JsonRepr s
-construct s r = case s of
-  SSchemaObject _          -> ReprObject r
-  SSchemaArray _ _         -> ReprArray r
-  SSchemaText _            -> ReprText r
-  SSchemaNumber _          -> ReprNumber r
-  SSchemaBoolean           -> ReprBoolean r
-  SSchemaOptional _        -> ReprOptional r
-  SSchemaNull              -> ReprNull
-  SSchemaUnion ss          -> case ss of
-    SNil      -> error "unconstructable union"
-    SCons _ _ -> ReprUnion r
-
 type family FieldsOf (s :: Schema) :: [(Symbol, Schema)] where
   FieldsOf ('SchemaObject fs) = fs
 

src/Data/Schematic/Generator.hs

@@ -1,13 +1,14 @@
 module Data.Schematic.Generator where
 
-import           Data.Maybe
-import           Data.Schematic.Generator.Regex
-import {-# SOURCE #-} Data.Schematic.Schema
-import           Data.Schematic.Verifier
-import           Data.Scientific
-import           Data.Text (Text, pack)
-import qualified Data.Vector as V
-import           Test.SmallCheck.Series
+import Control.Applicative
+import Data.Maybe
+import Data.Schematic.Constraints
+import Data.Schematic.Generator.Regex
+import Data.Schematic.Verifier
+import Data.Scientific
+import Data.Text (Text, pack)
+import Test.SmallCheck.Series
+
 
 maxHigh :: Int
 maxHigh = 30
@@ -30,35 +31,18 @@ textLengthSeries =
 textEnumSeries :: Monad m => [Text] -> Series m Text
 textEnumSeries enum = generate $ \depth -> take depth enum
 
-textSeries :: Monad m => [DemotedTextConstraint] -> Series m Text
-textSeries cs = do
-  let mvcs = verifyTextConstraints cs
-  case mvcs of
-    Just vcs -> do
-      n <- textSeries' vcs
-      pure n
-    Nothing  -> pure "error"
+textSeries :: Monad m => [TextConstraintT] -> Series m Text
+textSeries cs = maybe (pure "error") textSeries' $ verifyTextConstraints cs
 
 textSeries' :: Monad m => [VerifiedTextConstraint] -> Series m Text
 textSeries' [] = pure "sample"
-textSeries' vcs = do
-  let enums = listToMaybe [x | VTEnum x <- vcs]
-  case enums of
-    Just e -> textEnumSeries e
-    Nothing -> do
-      let regexps = listToMaybe [x | VTRegex x _ _ <- vcs]
-      case regexps of
-        Just e  -> regexSeries e
-        Nothing -> textLengthSeries vcs
+textSeries' vcs
+  = fromMaybe (textLengthSeries vcs)
+  $ textEnumSeries <$> listToMaybe [x | VTEnum x <- vcs]
+  <|> regexSeries <$> listToMaybe [x | VTRegex x _ _ <- vcs]
 
-numberSeries :: Monad m => [DemotedNumberConstraint] -> Series m Scientific
-numberSeries cs = do
-  let mvcs = verifyNumberConstraints cs
-  case mvcs of
-    Just vcs -> do
-      n <- numberSeries' vcs
-      pure $ n
-    Nothing -> pure 0
+numberSeries :: Monad m => [NumberConstraintT] -> Series m Scientific
+numberSeries cs = maybe (pure 0) numberSeries' $ verifyNumberConstraints cs
 
 numberSeries' :: Monad m => VerifiedNumberConstraint -> Series m Scientific
 numberSeries' =
@@ -69,23 +53,3 @@ numberSeries' =
           h = fromMaybe maxHigh (fromIntegral <$> mh) - 1
       n <- generate $ \depth -> take depth [l .. h]
       pure $ fromIntegral n
-
-arraySeries
-  :: (Monad m, Serial m (JsonRepr s))
-  => [DemotedArrayConstraint]
-  -> Series m (V.Vector (JsonRepr s))
-arraySeries cs = do
-  let mvcs = verifyArrayConstraint cs
-  case mvcs of
-    Just vcs -> arraySeries' vcs
-    Nothing  -> pure V.empty
-
-arraySeries'
-  :: forall m s. (Monad m, Serial m (JsonRepr s))
-  => Maybe VerifiedArrayConstraint
-  -> Series m (V.Vector (JsonRepr s))
-arraySeries' ml = do
-  objs <- V.replicateM (maybe minRepeat f ml) (series :: Series m (JsonRepr s))
-  pure $ objs
-  where
-    f (VAEq l) = fromIntegral l

src/Data/Schematic/Helpers.hs

@@ -1,6 +1,6 @@
 module Data.Schematic.Helpers where
 
-import Data.Schematic.Schema
+import Data.Schematic.Constraints
 import GHC.TypeLits
 
 

src/Data/Schematic/Instances.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE AllowAmbiguousTypes #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Data.Schematic.Instances where