Merge pull request #14 from AnisimoffNikita/master

Schema generator

Author: dredozubov

schematic.cabal

@@ -15,6 +15,8 @@ cabal-version:       >=1.10
 library
   exposed-modules:     Data.Schematic
                      , Data.Schematic.DSL
+                     , Data.Schematic.Generator
+                     , Data.Schematic.Generator.Regex
                      , Data.Schematic.Instances
                      , Data.Schematic.JsonSchema
                      , Data.Schematic.Helpers
@@ -23,6 +25,11 @@ library
                      , Data.Schematic.Path
                      , Data.Schematic.Schema
                      , Data.Schematic.Validation
+                     , Data.Schematic.Verifier
+                     , Data.Schematic.Verifier.Array
+                     , Data.Schematic.Verifier.Common
+                     , Data.Schematic.Verifier.Number
+                     , Data.Schematic.Verifier.Text
   ghc-options:       -Wall
   default-extensions:  ConstraintKinds
                      , DataKinds

src/Data/Schematic/Generator.hs

@@ -0,0 +1,91 @@
+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
+
+maxHigh :: Int
+maxHigh = 30
+
+minLow :: Int
+minLow = 2
+
+textLengthSeries :: Monad m => [VerifiedTextConstraint] -> Series m Text
+textLengthSeries =
+  \case
+    [VTEq eq]        -> pure $ pack $ take (fromIntegral eq) $ cycle "sample"
+    [VTBounds ml mh] -> do
+      let
+        l = fromMaybe minLow (fromIntegral <$> ml) + 1
+        h = fromMaybe maxHigh (fromIntegral <$> mh) - 1
+      n <- generate $ \depth -> take depth [l .. h]
+      pure $ pack $ take (fromIntegral n) $ cycle "sample"
+    _                -> pure "error"
+
+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 => [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
+
+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 => VerifiedNumberConstraint -> Series m Scientific
+numberSeries' =
+  \case
+    VNEq eq -> pure $ fromIntegral eq
+    VNBounds ml mh -> do
+      let l = fromMaybe minLow (fromIntegral <$> ml) + 1
+          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/Generator/Regex.hs

@@ -0,0 +1,76 @@
+module Data.Schematic.Generator.Regex where
+
+import           Control.Monad
+import           Data.List
+import           Data.Maybe
+import qualified Data.Set as S
+import           Data.Text (Text, unpack)
+import           Data.Text.Lazy (toStrict)
+import           Data.Text.Lazy.Builder (Builder, singleton, toLazyText)
+import           Test.SmallCheck.Series
+import           Text.Regex.TDFA.Pattern
+import           Text.Regex.TDFA.ReadRegex (parseRegex)
+
+
+minRepeat :: Int
+minRepeat = 2
+
+maxRepeat :: Int
+maxRepeat = 10
+
+regexSeries :: (Monad m) => Text -> Series m Text
+regexSeries regexp =
+  case parseRegex . unpack $ regexp of
+    Right (p, _) -> toStrict . toLazyText <$> regexSeries' p
+    Left _       -> pure ""
+
+regexSeries' :: (Monad m) => Pattern -> Series m Builder
+regexSeries' pt =
+  case pt of
+    PEmpty -> pure mempty
+    PChar {..} -> pure $ singleton getPatternChar
+    PAny {getPatternSet = PatternSet (Just cset) _ _ _} -> do
+      x <- generate $ \depth -> take depth $ S.toList cset
+      pure $ singleton x
+    PAnyNot {getPatternSet = PatternSet (Just cset) _ _ _} -> do
+      x <-
+        generate $ \depth ->
+          take depth $ notChars $ concatMap expandEscape $ S.toList cset
+      pure $ singleton x
+    PQuest p -> regexSeries' p \/ pure mempty
+    PPlus p -> regexSeries' $ PBound 1 Nothing p
+    PStar _ p -> regexSeries' $ PBound 0 Nothing p
+    PBound low mhigh p -> do
+      let high = fromMaybe (low + maxRepeat) mhigh
+      n <- generate $ \depth -> take depth [low .. high]
+      decDepth $ do
+        ps <- replicateM n $ regexSeries' p
+        pure $ mconcat ps
+    PConcat ps -> mconcat <$> mapM regexSeries' ps
+    POr xs -> regexSeries' =<< (generate $ \depth -> take depth xs)
+    PDot _ -> do
+      x <- generate $ \depth -> take depth $ notChars []
+      pure $ singleton x
+    PEscape {..} -> do
+      x <- generate $ \depth -> take depth $ expandEscape getPatternChar
+      pure $ singleton x
+    PCarat _ -> pure mempty
+    PDollar _ -> pure mempty
+    _ -> pure mempty
+  where
+    notChars = ([' ' .. '~'] \\)
+    expandEscape ch =
+      case ch of
+        'n' -> "\n"
+        't' -> "\t"
+        'r' -> "\r"
+        'f' -> "\f"
+        'a' -> "\a"
+        'e' -> "\ESC"
+        'd' -> ['0' .. '9']
+        'w' -> ['0' .. '9'] ++ '_' : ['a' .. 'z'] ++ ['A' .. 'Z']
+        's' -> "\9\32"
+        'D' -> notChars $ ['0' .. '9']
+        'W' -> notChars $ ['0' .. '9'] ++ '_' : ['a' .. 'z'] ++ ['A' .. 'Z']
+        'S' -> notChars "\9\32"
+        ch' -> [ch']

src/Data/Schematic/Instances.hs

@@ -4,6 +4,7 @@
 module Data.Schematic.Instances where
 
 import Data.Scientific
+import Data.Text (Text, pack)
 import Data.Vector as V
 import Data.Vinyl
 import Test.SmallCheck.Series
@@ -21,3 +22,6 @@ instance Serial m a => Serial m (V.Vector a) where
 
 instance Monad m => Serial m Scientific where
   series = scientific <$> series <*> series
+
+instance Monad m => Serial m Text where
+  series = pack <$> series

src/Data/Schematic/Path.hs

@@ -1,7 +1,6 @@
 module Data.Schematic.Path where
 
 import Data.Foldable as F
-import Data.Monoid
 import Data.Singletons.Prelude
 import Data.Singletons.TypeLits
 import Data.Text as T