Demote with parameter

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,7 @@ library
                      , regex-tdfa
                      , regex-tdfa-text
                      , scientific
-                     , singletons >= 2.4
+                     , singletons
                      , smallcheck
                      , tagged
                      , template-haskell
@@ -95,7 +97,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,6 +7,8 @@ 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
@@ -27,6 +29,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

src/Data/Schematic/Compat.hs

@@ -0,0 +1,28 @@
+{-# 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
+
+#if MIN_VERSION_singletons(2,4,0)
+type (:++) a b = (++) a b
+#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,9 +1,9 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE CPP                 #-}
 
 module Data.Schematic.DSL where
 
 import           Data.Kind
+import           Data.Schematic.Compat
 import           Data.Schematic.Lens
 import           Data.Schematic.Schema
 import           Data.Scientific
@@ -18,19 +18,12 @@ 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), RMapCompat 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
 

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/JsonSchema.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE OverloadedLabels #-}
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE OverloadedLabels    #-}
+{-# LANGUAGE RecordWildCards     #-}
+{-# LANGUAGE TemplateHaskell     #-}
 
 module Data.Schematic.JsonSchema
   ( toJsonSchema
@@ -14,6 +14,7 @@ import Data.Foldable as F
 import Data.HashMap.Strict as H
 import Data.List as L
 import Data.List.NonEmpty as NE
+import Data.Schematic.Constraints
 import Data.Schematic.Schema as S
 import Data.Set as Set
 import Data.Singletons
@@ -26,40 +27,40 @@ import JSONSchema.Validator.Draft4 as D4
 draft4 :: Text
 draft4 = "http://json-schema.org/draft-04/schema#"
 
-textConstraint :: DemotedTextConstraint -> State D4.Schema ()
-textConstraint (DTEq n) = modify $ \s -> s
+textConstraint :: TextConstraintT -> State D4.Schema ()
+textConstraint (TEq n) = modify $ \s -> s
   { _schemaMinLength = pure $ fromIntegral n
   , _schemaMaxLength = pure $ fromIntegral n }
-textConstraint (DTLt n) = modify $ \s -> s
+textConstraint (TLt n) = modify $ \s -> s
   { _schemaMaxLength = pure . fromIntegral $ n + 1 }
-textConstraint (DTLe n) = modify $ \s -> s
+textConstraint (TLe n) = modify $ \s -> s
   { _schemaMaxLength = pure . fromIntegral $ n }
-textConstraint (DTGt n) =
+textConstraint (TGt n) =
   let n' = if n == 0 then 0 else n - 1
   in modify $ \s -> s { _schemaMinLength = pure . fromIntegral $ n' }
-textConstraint (DTGe n) = modify $ \s -> s
+textConstraint (TGe n) = modify $ \s -> s
   { _schemaMinLength = pure . fromIntegral $ n }
-textConstraint (DTRegex r) = modify $ \s -> s { _schemaPattern = pure r }
-textConstraint (DTEnum ss) =
+textConstraint (TRegex r) = modify $ \s -> s { _schemaPattern = pure r }
+textConstraint (TEnum ss) =
   let ss' = if F.length ss == 0 then [] else NE.fromList $ J.String <$> ss
   in modify $ \s -> s { _schemaEnum = pure ss' }
 
-numberConstraint :: DemotedNumberConstraint -> State D4.Schema ()
-numberConstraint (DNLe n) = modify $ \s -> s
+numberConstraint :: NumberConstraintT -> State D4.Schema ()
+numberConstraint (NLe n) = modify $ \s -> s
   { _schemaMaximum = pure . fromIntegral $ n }
-numberConstraint (DNLt n) = modify $ \s -> s
+numberConstraint (NLt n) = modify $ \s -> s
   { _schemaMaximum = pure . fromIntegral $ n + 1 }
-numberConstraint (DNGt n) = modify $ \s -> s
+numberConstraint (NGt n) = modify $ \s -> s
   { _schemaMinimum = pure . fromIntegral $ n }
-numberConstraint (DNGe n) =
+numberConstraint (NGe n) =
   let n' = if n == 0 then 0 else n - 1
   in modify $ \s -> s { _schemaMinimum = pure . fromIntegral $ n' }
-numberConstraint (DNEq n) = modify $ \s -> s
+numberConstraint (NEq n) = modify $ \s -> s
   { _schemaMinimum = pure $ fromIntegral n
   , _schemaMaximum = pure $ fromIntegral n }
 
-arrayConstraint :: DemotedArrayConstraint -> State D4.Schema ()
-arrayConstraint (DAEq _) = pure ()
+arrayConstraint :: ArrayConstraintT -> State D4.Schema ()
+arrayConstraint (AEq _) = pure ()
 
 toJsonSchema
   :: forall proxy schema
@@ -71,41 +72,41 @@ toJsonSchema _ = do
   pure $ js { _schemaVersion = pure draft4 }
 
 toJsonSchema'
-  :: DemotedSchema
+  :: SchemaT
   -> Maybe D4.Schema
 toJsonSchema' = \case
-  DSchemaText tcs ->
+  SchemaText tcs ->
     pure $ execState (traverse_ textConstraint tcs) $ emptySchema
       { _schemaType = pure $ TypeValidatorString D4.SchemaString }
-  DSchemaNumber ncs ->
+  S.SchemaNumber ncs ->
     pure $ execState (traverse_ numberConstraint ncs) $ emptySchema
       { _schemaType = pure $ TypeValidatorString D4.SchemaNumber }
-  DSchemaBoolean -> pure $ emptySchema
+  S.SchemaBoolean -> pure $ emptySchema
     { _schemaType = pure $ TypeValidatorString D4.SchemaBoolean }
-  DSchemaObject objs -> do
+  S.SchemaObject objs -> do
     res <- for objs $ \(n,s) -> do
       s' <- toJsonSchema' s
       pure (n, s')
     let
       nonOpt = \case
-        (_, DSchemaOptional _) -> False
-        _                      -> True
+        (_, SchemaOptional _) -> False
+        _                     -> True
     pure $ emptySchema
       { _schemaType       = pure $ TypeValidatorString D4.SchemaObject
       , _schemaRequired   = pure $ Set.fromList $ fst <$> L.filter nonOpt objs
       , _schemaProperties = pure $ H.fromList res }
-  DSchemaArray acs sch -> do
+  S.SchemaArray acs sch -> do
     res <- toJsonSchema' sch
     pure $ execState (traverse_ arrayConstraint acs) $ emptySchema
       { _schemaType  = pure $ TypeValidatorString D4.SchemaArray
       , _schemaItems = pure $ ItemsObject res }
-  DSchemaNull -> pure $ emptySchema
+  S.SchemaNull -> pure $ emptySchema
     { _schemaType = pure $ TypeValidatorString D4.SchemaNull }
-  DSchemaOptional sch -> do
-    snull <- toJsonSchema' DSchemaNull
+  SchemaOptional sch -> do
+    snull <- toJsonSchema' S.SchemaNull
     sres <- toJsonSchema' sch
     pure $ emptySchema { _schemaOneOf = pure (snull :| [sres]) }
-  DSchemaUnion sch -> do
+  SchemaUnion sch -> do
     schemaUnion <- traverse toJsonSchema' sch >>= \case
       [] -> Nothing
       x  -> Just x