Skip to content
This repository was archived by the owner on Jul 19, 2025. It is now read-only.

Commit 2bdbb84

Browse files
mfusseneggermfussenegger
committed
Add a pattern synonym for (FunctionCall (Function ..))
1 parent 12a30af commit 2bdbb84

3 files changed

Lines changed: 62 additions & 46 deletions

File tree

‎azure-pipelines.yml‎

Lines changed: 9 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -6,7 +6,9 @@ jobs:
66
steps:
77
- task: CacheBeta@0
88
inputs:
9-
key: $(Agent.OS)
9+
key: |
10+
$(Agent.OS)
11+
$(Build.SourcesDirectory)/stack.yaml.lock
1012
path: $(HOME)/.stack
1113
displayName: Cache stack
1214

@@ -37,7 +39,9 @@ jobs:
3739
steps:
3840
- task: CacheBeta@0
3941
inputs:
40-
key: $(Agent.OS)
42+
key: |
43+
$(Agent.OS)
44+
$(Build.SourcesDirectory)/stack.yaml.lock
4145
path: $(HOME)/.stack
4246
displayName: Cache stack
4347

@@ -67,7 +71,9 @@ jobs:
6771
steps:
6872
- task: CacheBeta@0
6973
inputs:
70-
key: $(Agent.OS)
74+
key: |
75+
$(Agent.OS)
76+
$(Build.SourcesDirectory)/stack.yaml.lock
7177
path: $(AppData)/stack
7278
displayName: Cache stack
7379

‎src/Expr.hs‎

Lines changed: 11 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,12 @@
1+
{-# LANGUAGE PatternSynonyms #-}
12
{-# LANGUAGE OverloadedStrings #-}
23

3-
module Expr where
4+
module Expr
5+
( parseExpr
6+
, Expr (..)
7+
, Function (..)
8+
, pattern Fn
9+
) where
410

511
import Data.Aeson (Value (..), decode', encode)
612
import Data.Maybe (fromMaybe)
@@ -33,6 +39,10 @@ data Function = Function
3339
deriving (Show, Eq)
3440

3541

42+
pattern Fn :: T.Text -> [Expr] -> Expr
43+
pattern Fn name args = FunctionCall (Function name args)
44+
45+
3646
instance IsString Expr where
3747
fromString s =
3848
case parseExpr (T.pack s) of

‎src/Fake.hs‎

Lines changed: 42 additions & 42 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,7 @@
22
{-# LANGUAGE OverloadedStrings #-}
33
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
44
{-# LANGUAGE FlexibleContexts #-}
5+
{-# LANGUAGE PatternSynonyms #-}
56

67
module Fake (
78
State,
@@ -37,7 +38,7 @@ import Data.ULID.TimeStamp (getULIDTimeStamp)
3738
import qualified Data.UUID as UUID
3839
import qualified Data.UUID.V1 as UUID1
3940
import qualified Data.Vector as V
40-
import Expr (Expr (..), Function (..))
41+
import Expr (Expr (..), pattern Fn, Function (..))
4142
import Prelude hiding (lines, replicate)
4243
import System.Random (Random (..), RandomGen (..),
4344
StdGen, mkStdGen, newStdGen)
@@ -84,7 +85,7 @@ instance RandomGen Env where
8485

8586
newEnv :: Maybe Int -> IO Env
8687
newEnv (Just seed) = pure $ Env (mkStdGen seed) M.empty
87-
newEnv Nothing = (flip Env) M.empty <$> newStdGen
88+
newEnv Nothing = flip Env M.empty <$> newStdGen
8889

8990

9091
uuid1 :: IO UUID.UUID
@@ -172,7 +173,7 @@ objectFromArgs :: [Expr] -> Fake Value
172173
objectFromArgs args = do
173174
let
174175
pairs = fmap (fmap mkKeyValuePair) (mkPairs args)
175-
Except.liftEither pairs >>= mapM id <&> object
176+
Except.liftEither pairs >>= sequence <&> object
176177
where
177178
mkPairs [] = Right []
178179
mkPairs [_] = Left "Arguments to object must be a multiple of 2 (key + value pairs)"
@@ -223,35 +224,34 @@ fromRegex :: (RandomGen g, MonadState g m, MonadError String m)
223224
-> m T.Text
224225
fromRegex input =
225226
case R.parseRegex input' of
226-
Right (pattern, _) -> generateText pattern
227+
Right (pattern', _) -> generateText pattern'
227228
Left err -> Except.throwError $ show err
228229
where
229230
input' = T.unpack input
230231
defaultUpper = 10
231-
replicatePattern lower upper pattern = do
232+
replicatePattern lower upper pattern' = do
232233
numChars <- State.state $ randomR (lower, upper)
233-
T.concat <$> replicateM numChars (generateText pattern)
234+
T.concat <$> replicateM numChars (generateText pattern')
234235
generateText p = case p of
235236
(R.POr patterns) -> do
236-
pattern <- rndListItem patterns
237-
case pattern of
238-
Nothing -> pure $ ""
239-
Just pattern' -> generateText pattern'
237+
pattern' <- rndListItem patterns
238+
case pattern' of
239+
Nothing -> pure ""
240+
Just pattern'' -> generateText pattern''
240241
(R.PConcat patterns) -> T.concat <$> mapM generateText patterns
241-
(R.PPlus pattern) -> replicatePattern 1 defaultUpper pattern
242-
(R.PStar _ pattern) -> replicatePattern 0 defaultUpper pattern
243-
(R.PBound lower mUpper pattern) -> do
244-
replicatePattern lower (fromMaybe defaultUpper mUpper) pattern
242+
(R.PPlus pattern') -> replicatePattern 1 defaultUpper pattern'
243+
(R.PStar _ pattern') -> replicatePattern 0 defaultUpper pattern'
244+
(R.PBound lower mUpper pattern') ->
245+
replicatePattern lower (fromMaybe defaultUpper mUpper) pattern'
245246
(R.PAny _ patternSet) -> fromPatternSet patternSet
246-
(R.PAnyNot _ ps@(R.PatternSet mChars _ _ _)) -> do
247+
(R.PAnyNot _ ps@(R.PatternSet mChars _ _ _)) ->
247248
rndSetItem (maybe Set.empty (Set.difference allPossibleChars) mChars)
248249
>>= maybeMErr ("Can't generate data from regex pattern" <> show ps)
249250
<&> charToText
250-
(R.PEscape _ 'd') -> do
251-
T.pack . show <$> (State.state $ randomR (0, 9 :: Int))
251+
(R.PEscape _ 'd') -> T.pack . show <$> State.state (randomR (0, 9 :: Int))
252252
(R.PChar _ char) -> pure $ charToText char
253253
_ -> Except.throwError $ "Can't generate data from regex pattern" <> show p
254-
fromPatternSet ps@(R.PatternSet mCharSet _ _ _) = do
254+
fromPatternSet ps@(R.PatternSet mCharSet _ _ _) =
255255
rndSetItem (fromMaybe Set.empty mCharSet)
256256
>>= maybeMErr ("Can't generate data from regex pattern" <> show ps)
257257
<&> charToText
@@ -354,33 +354,33 @@ eval :: Expr -> Fake Value
354354
eval (IntLiteral x) = pure $ Number $ fromInteger x
355355
eval (StringLiteral x) = pure $ String x
356356
eval (DoubleLiteral x) = pure $ Number x
357-
eval (JsonLiteral s) = pure $ s
358-
eval (FunctionCall (Function "uuid4" [])) = String . UUID.toText <$> State.state random
359-
eval (FunctionCall (Function "uuid1" [])) = String . UUID.toText <$> liftIO uuid1
360-
eval (FunctionCall (Function "ulid" [])) = getUlid
361-
eval (FunctionCall (Function "null" [])) = pure Null
362-
eval (FunctionCall (Function "randomBool" [])) = randomBool
363-
eval (FunctionCall (Function "randomChar" [])) = randomChar
364-
eval (FunctionCall (Function "randomInt" [])) = randomInt (IntLiteral 0) (IntLiteral 2147483647)
365-
eval (FunctionCall (Function "randomInt" [upper])) = randomInt (IntLiteral 0) upper
366-
eval (FunctionCall (Function "randomInt" [lower, upper])) = randomInt lower upper
367-
eval (FunctionCall (Function "randomDouble" [])) = randomDouble (DoubleLiteral 0) (DoubleLiteral 1.7976931348623157E308)
368-
eval (FunctionCall (Function "randomDouble" [upper])) = randomDouble (DoubleLiteral 0) upper
369-
eval (FunctionCall (Function "randomDouble" [lower, upper])) = randomDouble lower upper
370-
eval (FunctionCall (Function "randomDate" [])) = dayAsValue <$> randomDate Nothing Nothing
371-
eval (FunctionCall (Function "randomDate" [lower, upper])) = do
357+
eval (JsonLiteral s) = pure s
358+
eval (Fn "uuid4" []) = String . UUID.toText <$> State.state random
359+
eval (Fn "uuid1" []) = String . UUID.toText <$> liftIO uuid1
360+
eval (Fn "ulid" []) = getUlid
361+
eval (Fn "null" []) = pure Null
362+
eval (Fn "randomBool" []) = randomBool
363+
eval (Fn "randomChar" []) = randomChar
364+
eval (Fn "randomInt" []) = randomInt (IntLiteral 0) (IntLiteral 2147483647)
365+
eval (Fn "randomInt" [upper]) = randomInt (IntLiteral 0) upper
366+
eval (Fn "randomInt" [lower, upper]) = randomInt lower upper
367+
eval (Fn "randomDouble" []) = randomDouble (DoubleLiteral 0) (DoubleLiteral 1.7976931348623157E308)
368+
eval (Fn "randomDouble" [upper]) = randomDouble (DoubleLiteral 0) upper
369+
eval (Fn "randomDouble" [lower, upper]) = randomDouble lower upper
370+
eval (Fn "randomDate" []) = dayAsValue <$> randomDate Nothing Nothing
371+
eval (Fn "randomDate" [lower, upper]) = do
372372
lo <- A.asText <$> eval lower
373373
hi <- A.asText <$> eval upper
374374
dayAsValue <$> randomDate (rightToMaybe lo) (rightToMaybe hi)
375-
eval (FunctionCall (Function "randomDateTime" [])) = randomDateTime
376-
eval (FunctionCall (Function "array" args)) = Array . V.fromList <$> mapM eval args
377-
eval (FunctionCall (Function "oneOf" [arg])) = oneOfArray arg
378-
eval (FunctionCall (Function "oneOf" args)) = oneOfArgs args
379-
eval (FunctionCall (Function "replicate" [num, expr])) = replicate num expr
380-
eval (FunctionCall (Function "object" args)) = objectFromArgs args
381-
eval (FunctionCall (Function "fromFile" [fileName])) = fromFile fileName
382-
eval (FunctionCall (Function "fromRegex" [pattern])) =
383-
eval pattern
375+
eval (Fn "randomDateTime" []) = randomDateTime
376+
eval (Fn "array" args) = Array . V.fromList <$> mapM eval args
377+
eval (Fn "oneOf" [arg]) = oneOfArray arg
378+
eval (Fn "oneOf" args) = oneOfArgs args
379+
eval (Fn "replicate" [num, expr]) = replicate num expr
380+
eval (Fn "object" args) = objectFromArgs args
381+
eval (Fn "fromFile" [fileName]) = fromFile fileName
382+
eval (Fn "fromRegex" [pattern']) =
383+
eval pattern'
384384
<&> A.asText
385385
>>= Except.liftEither
386386
>>= Fake . fromRegex

0 commit comments

Comments
 (0)