{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE BangPatterns #-}
module Faker
(
Fake(..)
, FakerSettings
, FakerException(..)
, defaultFakerSettings
, setLocale
, setRandomGen
, setDeterministic
, setNonDeterministic
, setCacheField
, setCacheFile
, replaceCacheField
, replaceCacheFile
, getRandomGen
, getLocale
, getDeterministic
, getCacheField
, getCacheFile
, generate
, generateNonDeterministic
, generateWithSettings
) where
import Control.Exception (Exception)
import Control.Monad (ap)
import Control.Monad.IO.Class
import qualified Data.HashMap.Strict as HM
import Data.IORef
import Data.Semigroup (Semigroup, (<>))
import Data.Text (Text)
import Data.Typeable
import Data.Vector (Vector)
import Data.Word (Word64)
import Data.Yaml (Value)
import Faker.Internal.Types (CacheFieldKey, CacheFileKey)
import System.Random (StdGen, mkStdGen, newStdGen, split)
data FakerSettings = FakerSettings
{ fslocale :: !Text
, fsrandomGen :: !StdGen
, fsDeterministic :: !Bool
, fsCacheField :: (IORef (HM.HashMap CacheFieldKey (Vector Text)))
, fsCacheFile :: (IORef (HM.HashMap CacheFileKey Value))
}
newtype FakerGen = FakerGen
{ unFakerGen :: (Int, StdGen)
} deriving (Show)
instance Show FakerSettings where
show (FakerSettings {..}) =
show fslocale ++ show fsrandomGen ++ show fsDeterministic
data FakerException
= InvalidLocale String
| InvalidField String
Text
| NoDataFound FakerSettings
| ParseError String
deriving (Typeable, Show)
instance Exception FakerException
defaultFakerSettings :: FakerSettings
defaultFakerSettings =
FakerSettings
{ fslocale = "en"
, fsrandomGen = mkStdGen 10000
, fsDeterministic = True
, fsCacheField = error "defaultFakerSettings: fsCacheField not initialized"
, fsCacheFile = error "defaultFakerSettings: fsCacheFile not initialized"
}
setLocale :: Text -> FakerSettings -> FakerSettings
setLocale localeTxt fs = fs {fslocale = localeTxt}
setRandomGen :: StdGen -> FakerSettings -> FakerSettings
setRandomGen gen fs = fs {fsrandomGen = gen}
getRandomGen :: FakerSettings -> StdGen
getRandomGen settings = fsrandomGen settings
getLocale :: FakerSettings -> Text
getLocale FakerSettings {..} = fslocale
setDeterministic :: FakerSettings -> FakerSettings
setDeterministic fs = fs {fsDeterministic = True}
setNonDeterministic :: FakerSettings -> FakerSettings
setNonDeterministic fs = fs {fsDeterministic = False}
getDeterministic :: FakerSettings -> Bool
getDeterministic FakerSettings {..} = fsDeterministic
getCacheField :: FakerSettings -> IO (HM.HashMap CacheFieldKey (Vector Text))
getCacheField FakerSettings {..} = readIORef fsCacheField
setCacheField ::
HM.HashMap CacheFieldKey (Vector Text) -> FakerSettings -> IO ()
setCacheField cache fs = do
writeIORef (fsCacheField fs) cache
replaceCacheField ::
HM.HashMap CacheFieldKey (Vector Text) -> FakerSettings -> IO FakerSettings
replaceCacheField cache fs = do
ref <- newIORef cache
pure $ fs {fsCacheField = ref}
getCacheFile :: FakerSettings -> IO (HM.HashMap CacheFileKey Value)
getCacheFile FakerSettings {..} = readIORef fsCacheFile
setCacheFile :: HM.HashMap CacheFileKey Value -> FakerSettings -> IO ()
setCacheFile cache fs = writeIORef (fsCacheFile fs) cache
replaceCacheFile ::
HM.HashMap CacheFileKey Value -> FakerSettings -> IO FakerSettings
replaceCacheFile cache fs = do
ref <- newIORef cache
pure $ fs {fsCacheFile = ref}
newtype Fake a = Fake
{ unFake :: FakerSettings -> IO a
}
instance Functor Fake where
{-# INLINE fmap #-}
fmap :: (a -> b) -> Fake a -> Fake b
fmap f (Fake h) =
Fake
(\r -> do
a <- h r
let b = f a
pure b)
instance Applicative Fake where
{-# INLINE pure #-}
pure x = Fake (\_ -> pure x)
{-# INLINE (<*>) #-}
(<*>) = ap
instance Monad Fake where
{-# INLINE return #-}
return :: a -> Fake a
return x = Fake (\_ -> return x)
{-# INLINE (>>=) #-}
(>>=) :: Fake a -> (a -> Fake b) -> Fake b
f >>= k = generateNewFake f k
generateNewFake :: Fake a -> (a -> Fake b) -> Fake b
generateNewFake (Fake h) k = Fake (\settings -> do
let deterministic = getDeterministic settings
currentStdGen = getRandomGen settings
newStdGen = if deterministic
then currentStdGen
else fst $ split currentStdGen
item <- h settings
let (Fake k1) = k item
k1 (setRandomGen newStdGen settings))
{-# SPECIALIZE INLINE generateNewFake :: Fake Text -> (Text -> Fake Text) -> Fake Text #-}
instance MonadIO Fake where
liftIO :: IO a -> Fake a
liftIO xs = Fake (\_ -> xs >>= pure)
instance Semigroup a => Semigroup (Fake a) where
mx <> my = (<>) <$> mx <*> my
instance Monoid a => Monoid (Fake a) where
mempty = pure mempty
mappend mx my = mappend <$> mx <*> my
generate :: Fake a -> IO a
generate (Fake f) = do
cacheField <- newIORef HM.empty
cacheFile <- newIORef HM.empty
f $ defaultFakerSettings {fsCacheField = cacheField, fsCacheFile = cacheFile}
generateNonDeterministic :: Fake a -> IO a
generateNonDeterministic = generateWithSettings $ setNonDeterministic defaultFakerSettings
generateWithSettings :: FakerSettings -> Fake a -> IO a
generateWithSettings settings (Fake f) = do
let deterministic = getDeterministic settings
stdGen <-
if deterministic
then pure $ getRandomGen settings
else newStdGen
let newSettings = setRandomGen stdGen settings
cacheField <- newIORef HM.empty
cacheFile <- newIORef HM.empty
f $ newSettings {fsCacheField = cacheField, fsCacheFile = cacheFile}