Add a randomInt provider

mfussenegger · mfussenegger · commit abefc846b71c · 2018-11-30T15:00:19.000+01:00
diff --git a/app/Main.hs b/app/Main.hs
@@ -2,26 +2,30 @@
 
 module Main where
 
-import           Control.Monad              (forM_, forever)
+import           Control.Monad              (forever)
 import           Data.Aeson                 (Value (..), encode, object)
 import qualified Data.ByteString.Lazy.Char8 as BL
-import qualified Data.List                  as L
-import           Data.Maybe                 (mapMaybe)
+import           Data.Either                (isRight, lefts)
+import           Data.Maybe                 (fromJust, mapMaybe)
+import qualified Data.Scientific            as S
 import           Data.Text                  (Text)
 import qualified Data.Text                  as T
 import qualified Data.Text.Read             as T
 import qualified Data.UUID                  as UUID
-import qualified Data.UUID.V4               as UUID4
 import qualified Data.UUID.V1               as UUID1
-import           Lib
+import qualified Data.UUID.V4               as UUID4
+import           Expr                       (Expr (..), parseExpr)
 import           System.Environment         (getArgs)
+import           System.Random              (getStdGen, randomR, setStdGen)
 
+-- $setup
+-- >>> :set -XOverloadedStrings
 
 parseColumnDefinition :: String -> Maybe (Text, Text)
-parseColumnDefinition x = 
+parseColumnDefinition x =
   case parts of
-    [x, y]  -> Just (x, y)
-    _       -> Nothing
+    [columnName, providerName] -> Just (columnName, providerName)
+    _                          -> Nothing
   where
     text = T.pack x
     parts = T.splitOn "=" text
@@ -35,22 +39,63 @@ uuid1 = do
     Nothing  -> uuid1
 
 
-lookupProvider :: Text -> IO Value
-lookupProvider "uuid4" = String . UUID.toText <$> UUID4.nextRandom
-lookupProvider "uuid1" = String . UUID.toText <$> uuid1
-lookupProvider _       = pure $ String "foobar"
+-- | Try to extract an Int from Value
+--
+-- >>> asInt (Number 10)
+-- 10
+--
+-- >>> asInt (String "10")
+-- 10
+--
+-- >>> asInt (String "foo")
+-- *** Exception: Expected an integer, but received: foo
+-- ...
+asInt :: Value -> Int
+asInt (Number n) = fromJust $ S.toBoundedInteger n
+asInt (String s) =
+  case T.decimal s of
+    (Right (n, _)) -> n
+    (Left _)       -> error $ "Expected an integer, but received: " <> T.unpack s
+asInt o          = error $ "Expected an integer but received: " <> show o
+
+
+-- | Create a value getter for an expression
+--
+-- >>> eval $ FunctionCall "randomInt" [IntLiteral 1, IntLiteral 1]
+-- Number 1.0
+eval :: Expr -> IO Value
+eval (IntLiteral x)    = pure $ Number $ fromInteger x
+eval (StringLiteral x) = pure $ String x
+eval (FunctionCall "uuid4" []) = String . UUID.toText <$> UUID4.nextRandom
+eval (FunctionCall "uuid1" []) = String . UUID.toText <$> uuid1
+eval (FunctionCall "randomInt" [lower, upper]) = do
+  lower' <- asInt <$> eval lower
+  upper' <- asInt <$> eval upper
+  stdGen <- getStdGen
+  let
+    (rndNumber, newStdGen) = randomR (lower', upper') stdGen
+  setStdGen newStdGen
+  pure $ Number $ fromIntegral rndNumber
+eval (FunctionCall name _) = pure $ String $ "No random generator for " <> name
 
 
 main :: IO ()
 main = do
   args <- getArgs
   let 
     columns = mapMaybe parseColumnDefinition args
-    providers = fmap (\(x, y) -> (x, lookupProvider y)) columns
-  forever $ do
-    obj <- encode . object <$> mapM runProvider providers
-    BL.putStrLn obj
+    allExpressions = fmap (\(x, y) -> (x, parseExpr y)) columns
+    expressions = fmap unpackRight (filter (isRight . snd) allExpressions)
+    errored = lefts $ fmap snd allExpressions
+    providers = fmap (\(x, y) -> (x, eval y)) expressions
+  if null errored
+    then forever $ do
+      obj <- encode . object <$> mapM runProvider providers
+      BL.putStrLn obj
+    else mapM_ print errored
   where
+    unpackRight (x, Right y) = (x, y)
+    unpackRight _            = error "Tuple must only contain Right eithers"
     runProvider (column, provider) = do
       val <- provider
       pure (column, val)
diff --git a/package.yaml b/package.yaml
@@ -14,13 +14,20 @@ extra-source-files:
 description: |
   Please see the README on GitHub at <https://github.com/mfussenegger/fake-json#readme>
 
+ghc-options:
+  - -Wall
+  - -fno-warn-unused-do-bind
+
 dependencies:
   - base >= 4.7 && < 5
   - text
   - aeson
   - bytestring
   - scientific
   - uuid
+  - parsec
+  - random
+  - scientific
 
 library:
   source-dirs: src
@@ -36,11 +43,17 @@ executables:
 
 tests:
   fake-json-test:
-    main: Spec.hs
-    source-dirs: test
+    main: spec.hs
+    source-dirs: tests
     ghc-options:
       - -threaded
       - -rtsopts
       - -with-rtsopts=-N
     dependencies:
       - fake-json
+  fake-json-doctest:
+    main: doctests.hs
+    source-dirs: tests
+    dependencies:
+      - fake-json
+      - doctest
diff --git a/src/Expr.hs b/src/Expr.hs
@@ -0,0 +1,71 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Expr where
+
+import           Data.Maybe        (fromMaybe)
+import           Data.Text         (Text)
+import qualified Data.Text         as T
+import           Text.Parsec       (many, many1, optionMaybe, parse, sepBy,
+                                    (<|>))
+import           Text.Parsec.Char  (char, digit, letter, spaces)
+import           Text.Parsec.Error (ParseError)
+import           Text.Parsec.Text  (Parser)
+
+-- $setup
+-- >>> :set -XOverloadedStrings
+
+data Expr = IntLiteral Integer
+          | StringLiteral Text
+          | FunctionCall { fcName :: Text, fcArgs :: [Expr] }
+          deriving (Show, Eq)
+
+expr :: Parser Expr
+expr = literal <|> functionCall
+
+literal :: Parser Expr
+literal = number <|> stringLiteral
+
+number :: Parser Expr
+number = IntLiteral . read <$> many1 digit
+
+stringLiteral :: Parser Expr
+stringLiteral = do
+  _ <- char '\''
+  content <- many1 letter
+  _ <- char '\''
+  pure $ StringLiteral $ T.pack content
+
+
+functionCall :: Parser Expr
+functionCall = do
+  name <- ident
+  args <- fromMaybe [] <$> optionMaybe functionArgs
+  pure $ FunctionCall name args
+  where
+    functionArgs = do
+      _ <- char '('
+      args <- expr `sepBy` (char ',' >> spaces)
+      _ <- char ')'
+      pure args
+
+
+ident :: Parser Text
+ident = do
+  firstChar <- letter
+  next <- many (digit <|> letter)
+  pure $ T.pack (firstChar : next)
+
+
+
+-- | Parse an expression
+--
+-- >>> parseExpr "20"
+-- Right (IntLiteral 20)
+--
+-- >>> parseExpr "uuid4"
+-- Right (FunctionCall {fcName = "uuid4", fcArgs = []})
+--
+-- >>> parseExpr "randomInt(0, 10)"
+-- Right (FunctionCall {fcName = "randomInt", fcArgs = [IntLiteral 0,IntLiteral 10]})
+parseExpr :: Text -> Either ParseError Expr
+parseExpr = parse expr "(unknown)"
diff --git a/tests/doctests.hs b/tests/doctests.hs
@@ -0,0 +1,9 @@
+
+import Test.DocTest
+
+main :: IO ()
+main = doctest
+  [ "-isrc"
+  , "src/Expr.hs"
+  , "app/Main.hs"
+  ]
diff --git a/tests/spec.hs b/tests/spec.hs
