Skip to content
This repository was archived by the owner on Jun 15, 2023. It is now read-only.

Commit 81da9ad

Browse files
authored
Merge pull request #36 from garyb/monadgen
Use MonadGen rather than QC Arbitrary
2 parents 91b762b + 565f2e4 commit 81da9ad

File tree

11 files changed

+121
-129
lines changed

11 files changed

+121
-129
lines changed

bower.json

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -21,13 +21,13 @@
2121
"purescript-profunctor": "^3.2.0",
2222
"purescript-profunctor-lenses": "^3.2.0",
2323
"purescript-ejson": "^10.0.1",
24-
"purescript-argonaut-codecs": "^3.1.0",
25-
"purescript-quickcheck": "^4.4.0"
24+
"purescript-argonaut-codecs": "^3.1.0"
2625
},
2726
"devDependencies": {
2827
"purescript-argonaut": "^3.0.0",
29-
"purescript-search": "^3.0.0",
3028
"purescript-debug": "^3.0.0",
29+
"purescript-quickcheck": "^4.4.0",
30+
"purescript-search": "^3.0.0",
3131
"purescript-test-unit": "^11.0.0"
3232
}
3333
}

src/SqlSquared/Signature.purs

Lines changed: 60 additions & 59 deletions
Original file line numberDiff line numberDiff line change
@@ -43,7 +43,8 @@ module SqlSquared.Signature
4343

4444
import Prelude
4545

46-
import Control.Monad.Gen as MGen
46+
import Control.Monad.Gen as Gen
47+
import Control.Monad.Rec.Class (class MonadRec)
4748
import Data.Argonaut as J
4849
import Data.Array as A
4950
import Data.Either as E
@@ -74,8 +75,6 @@ import SqlSquared.Signature.Projection as PR
7475
import SqlSquared.Signature.Relation as RL
7576
import SqlSquared.Signature.UnaryOperator as UO
7677
import SqlSquared.Utils (type (×), (×), (∘), (⋙))
77-
import Test.QuickCheck.Arbitrary as QC
78-
import Test.QuickCheck.Gen as Gen
7978

8079
type BinopR a =
8180
{ lhs a
@@ -736,9 +735,11 @@ decodeJsonSqlModuleF = J.decodeJson >=> \obj → do
736735
_ → E.Left $ "Invalid top-level SQL^2 production: " <> tag
737736

738737
arbitrarySqlF
739-
l
740-
. CoalgebraM Gen.Gen l Int
741-
CoalgebraM Gen.Gen (SqlF l) Int
738+
m l
739+
. Gen.MonadGen m
740+
MonadRec m
741+
CoalgebraM m l Int
742+
CoalgebraM m (SqlF l) Int
742743
arbitrarySqlF genLiteral n
743744
| n < 2 =
744745
Gen.oneOf $ (Literal <$> genLiteral n) :|
@@ -761,103 +762,103 @@ arbitrarySqlF genLiteral n
761762
, genSelect n
762763
]
763764

764-
arbitrarySqlDeclF CoalgebraM Gen.Gen SqlDeclF Int
765+
arbitrarySqlDeclF m. Gen.MonadGen m CoalgebraM m SqlDeclF Int
765766
arbitrarySqlDeclF n =
766767
Gen.oneOf $ genImport :|
767768
[ genFunctionDecl n
768769
]
769770

770-
arbitrarySqlQueryF CoalgebraM Gen.Gen SqlQueryF Int
771+
arbitrarySqlQueryF m. Gen.MonadGen m CoalgebraM m SqlQueryF Int
771772
arbitrarySqlQueryF n = Query <$> genDecls n <*> pure n
772773

773-
arbitrarySqlModuleF CoalgebraM Gen.Gen SqlModuleF Int
774+
arbitrarySqlModuleF m. Gen.MonadGen m CoalgebraM m SqlModuleF Int
774775
arbitrarySqlModuleF n = Module <$> genDecls n
775776

776-
genSetLiteral l. CoalgebraM Gen.Gen (SqlF l) Int
777+
genSetLiteral m l. Gen.MonadGen m CoalgebraM m (SqlF l) Int
777778
genSetLiteral n = do
778779
len ← Gen.chooseInt 0 $ n - 1
779780
pure $ SetLiteral $ map (const $ n - 1) $ L.range 0 len
780781

781-
genBinop l. CoalgebraM Gen.Gen (SqlF l) Int
782+
genBinop m l. Gen.MonadGen m CoalgebraM m (SqlF l) Int
782783
genBinop n = do
783-
op ← QC.arbitrary
784+
op ← BO.genBinaryOperator
784785
pure $ Binop { op, lhs: n - 1, rhs: n - 1 }
785786

786-
genUnop l. CoalgebraM Gen.Gen (SqlF l) Int
787+
genUnop m l. Gen.MonadGen m CoalgebraM m (SqlF l) Int
787788
genUnop n = do
788-
op ← QC.arbitrary
789+
op ← UO.genUnaryOperator
789790
pure $ Unop { op, expr: n - 1 }
790791

791-
genInvokeFunction l. CoalgebraM Gen.Gen (SqlF l) Int
792+
genInvokeFunction m l. Gen.MonadGen m CoalgebraM m (SqlF l) Int
792793
genInvokeFunction n = do
793794
name ← genIdent
794795
len ← Gen.chooseInt 0 $ n - 1
795796
pure $ InvokeFunction { name, args: map (const $ n - 1) $ L.range 0 len }
796797

797-
genMatch l. CoalgebraM Gen.Gen (SqlF l) Int
798+
genMatch m l. Gen.MonadGen m CoalgebraM m (SqlF l) Int
798799
genMatch n = do
799-
nothing ← QC.arbitrary
800+
nothing ← Gen.chooseBool
800801
len ← Gen.chooseInt 0 $ n - 1
801802
let
802803
foldFn acc _ = do
803-
cs ← CS.arbitraryCase $ n - 1
804+
cs ← CS.genCase $ n - 1
804805
pure $ cs L.: acc
805806
cases ← L.foldM foldFn L.Nil $ L.range 0 len
806807
pure $ Match { expr: n - 1
807808
, cases
808809
, else_: if nothing then Nothing else Just $ n - 1
809810
}
810-
genSwitch l. CoalgebraM Gen.Gen (SqlF l) Int
811+
genSwitch m l. Gen.MonadGen m CoalgebraM m (SqlF l) Int
811812
genSwitch n = do
812-
nothing ← QC.arbitrary
813+
nothing ← Gen.chooseBool
813814
len ← Gen.chooseInt 0 $ n - 1
814815
let
815816
foldFn acc _ = do
816-
cs ← CS.arbitraryCase $ n - 1
817+
cs ← CS.genCase $ n - 1
817818
pure $ cs L.: acc
818819
cases ← L.foldM foldFn L.Nil $ L.range 0 len
819820
pure $ Switch { cases
820821
, else_: if nothing then Nothing else Just $ n - 1
821822
}
822823

823-
genLet l. CoalgebraM Gen.Gen (SqlF l) Int
824+
genLet m l. Gen.MonadGen m CoalgebraM m (SqlF l) Int
824825
genLet n = do
825826
ident ← genIdent
826827
pure $ Let { ident
827828
, bindTo: n - 1
828829
, in_: n - 1
829830
}
830831

831-
genSelect l. CoalgebraM Gen.Gen (SqlF l) Int
832+
genSelect m l. Gen.MonadGen m MonadRec m CoalgebraM m (SqlF l) Int
832833
genSelect n = do
833834
prjLen ← Gen.chooseInt 0 $ n - 1
834-
mbRelation ← QC.arbitrary
835-
mbFilter ← QC.arbitrary
836-
mbGroupBy ← QC.arbitrary
837-
mbOrderBy ← QC.arbitrary
838-
isDistinct ← QC.arbitrary
835+
mbRelation ← Gen.chooseBool
836+
mbFilter ← Gen.chooseBool
837+
mbGroupBy ← Gen.chooseBool
838+
mbOrderBy ← Gen.chooseBool
839+
isDistinct ← Gen.chooseBool
839840

840841
let
841842
foldPrj acc _ = do
842-
prj ← PR.arbitraryProjection $ n - 1
843+
prj ← PR.genProjection $ n - 1
843844
pure $ prj L.:acc
844845
projections ←
845846
L.foldM foldPrj L.Nil $ L.range 0 prjLen
846847

847848
relations ←
848849
if mbRelation
849850
then pure Nothing
850-
else map Just $ RL.arbitraryRelation $ n - 1
851+
else map Just $ RL.genRelation $ n - 1
851852

852853
groupBy ←
853854
if mbGroupBy
854855
then pure Nothing
855-
else map Just $ GB.arbitraryGroupBy $ n - 1
856+
else map Just $ GB.genGroupBy $ n - 1
856857

857858
orderBy ←
858859
if mbOrderBy
859860
then pure Nothing
860-
else map Just $ OB.arbitraryOrderBy $ n - 1
861+
else map Just $ OB.genOrderBy $ n - 1
861862

862863
pure $ Select { isDistinct
863864
, projections
@@ -867,7 +868,7 @@ genSelect n = do
867868
, orderBy
868869
}
869870

870-
genFunctionDecl CoalgebraM Gen.Gen SqlDeclF Int
871+
genFunctionDecl m. Gen.MonadGen m CoalgebraM m SqlDeclF Int
871872
genFunctionDecl n = do
872873
ident ← genIdent
873874
len ← Gen.chooseInt 0 $ n - 1
@@ -878,16 +879,16 @@ genFunctionDecl n = do
878879
args ← L.foldM foldFn L.Nil $ L.range 0 len
879880
pure $ FunctionDecl { ident, args, body: n - 1 }
880881

881-
genImport a. Gen.Gen (SqlDeclF a)
882+
genImport m a. Gen.MonadGen m m (SqlDeclF a)
882883
genImport = Import <$> genIdent
883884

884-
genIdent Gen.Gen String
885+
genIdent m. Gen.MonadGen m m String
885886
genIdent = do
886887
start ← Gen.elements $ "a" :| S.split (S.Pattern "") "bcdefghijklmnopqrstuvwxyz"
887-
body ← map (Int.toStringAs Int.hexadecimal) QC.arbitrary
888+
body ← map (Int.toStringAs Int.hexadecimal) (Gen.chooseInt 0 100000)
888889
pure $ start <> body
889890

890-
genDecls Int Gen.Gen (L.List (SqlDeclF Int))
891+
genDecls m. Gen.MonadGen m Int m (L.List (SqlDeclF Int))
891892
genDecls n = do
892893
let
893894
foldFn acc _ = do
@@ -901,32 +902,32 @@ genDecls n = do
901902
-- actually ported from quasar, this is very important
902903
-- but annoying stuff :|
903904

904-
type GenSql t = Corecursive t (SqlF EJ.EJsonF) Gen.Gen t
905+
type GenSql m t = Gen.MonadGen m MonadRec m Corecursive t (SqlF EJ.EJsonF) m t
905906

906-
genSql t. Int GenSql t
907+
genSql m t. Int GenSql m t
907908
genSql n
908909
| n < 2 = genLeaf
909910
| otherwise =
910911
Gen.oneOf $ genLetP (n - 1) :| [ genQueryExprP (n - 1) ]
911912

912-
genLeaf t. GenSql t
913+
genLeaf m t. GenSql m t
913914
genLeaf =
914915
map (embed ∘ Literal)
915-
$ MGen.oneOf $ pure EJ.Null :|
916-
[ EJ.Boolean <$> MGen.chooseBool
917-
, EJ.Integer <<< HI.fromInt <$> MGen.chooseInt (-1000000) 1000000
918-
, EJ.Decimal <<< HN.fromNumber <$> MGen.chooseFloat (-1000000.0) 1000000.0
916+
$ Gen.oneOf $ pure EJ.Null :|
917+
[ EJ.Boolean <$> Gen.chooseBool
918+
, EJ.Integer <<< HI.fromInt <$> Gen.chooseInt (-1000000) 1000000
919+
, EJ.Decimal <<< HN.fromNumber <$> Gen.chooseFloat (-1000000.0) 1000000.0
919920
, EJ.String <$> GenS.genUnicodeString
920921
]
921922

922-
genLetP t. Int GenSql t
923+
genLetP m t. Int GenSql m t
923924
genLetP n = do
924925
ident ← genIdent
925926
bindTo ← genSql n
926927
in_ ← genSql n
927928
pure $ embed $ Let { ident, bindTo, in_ }
928929

929-
genQueryExprP t. Int GenSql t
930+
genQueryExprP m t. Int GenSql m t
930931
genQueryExprP n
931932
| n < 2 = Gen.oneOf $ genQueryP n :| [ genDefinedExprP n ]
932933
| otherwise = do
@@ -940,12 +941,12 @@ genQueryExprP n
940941
rhs ← Gen.oneOf $ genQueryP n :| [ genDefinedExprP n ]
941942
pure $ embed $ Binop { op, lhs, rhs }
942943

943-
genDefinedExprP t. Int GenSql t
944+
genDefinedExprP m t. Int GenSql m t
944945
genDefinedExprP n = do
945-
binops ← Gen.vectorOf n QC.arbitrary
946-
unops ← Gen.vectorOf n QC.arbitrary
946+
binops ← Gen.resize (const n) $ Gen.unfoldable BO.genBinaryOperator
947+
unops ← Gen.resize (const n) $ Gen.unfoldable UO.genUnaryOperator
947948
start ← genPrimaryExprP n
948-
adds ← Gen.vectorOf n $ genPrimaryExprP n
949+
adds ← Gen.resize (const n) $ Gen.unfoldable $ genPrimaryExprP n
949950
pure $ F.foldl foldFn start $ A.zip binops $ A.zip unops adds
950951
where
951952
foldFn acc (binop × unop × rhs) =
@@ -957,7 +958,7 @@ genDefinedExprP n = do
957958
, expr: embed $ Binop { lhs: acc, rhs, op:binop }
958959
}
959960

960-
genPrimaryExprP t. Int GenSql t
961+
genPrimaryExprP m t. Int GenSql m t
961962
genPrimaryExprP n =
962963
Gen.oneOf $ genLeaf :|
963964
[ genCaseP n
@@ -970,26 +971,26 @@ genPrimaryExprP n =
970971
, map (embed ∘ Ident) genIdent
971972
]
972973

973-
genCaseP t. Int GenSql t
974+
genCaseP m t. Int GenSql m t
974975
genCaseP n = genLeaf
975976

976-
genUnaryP t. Int GenSql t
977+
genUnaryP m t. Int GenSql m t
977978
genUnaryP n = genLeaf
978979

979-
genFunctionP t. Int GenSql t
980+
genFunctionP m t. Int GenSql m t
980981
genFunctionP n = genLeaf
981982

982-
genSetP t. Int GenSql t
983+
genSetP m t. Int GenSql m t
983984
genSetP n = genLeaf
984985

985-
genArrayP t. Int GenSql t
986+
genArrayP m t. Int GenSql m t
986987
genArrayP n = genLeaf
987988

988-
genMapP t. Int GenSql t
989+
genMapP m t. Int GenSql m t
989990
genMapP n = genLeaf
990991

991-
genSpliceP t. Int GenSql t
992+
genSpliceP m t. Int GenSql m t
992993
genSpliceP n = pure $ embed $ Splice Nothing
993994

994-
genQueryP t. Int GenSql t
995+
genQueryP m t. Int GenSql m t
995996
genQueryP n = genLeaf

src/SqlSquared/Signature/BinaryOperator.purs

Lines changed: 10 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -2,11 +2,10 @@ module SqlSquared.Signature.BinaryOperator where
22

33
import Prelude
44

5+
import Control.Monad.Gen as Gen
56
import Data.Argonaut as J
67
import Data.Either (Either(..))
78
import Data.NonEmpty ((:|))
8-
import Test.QuickCheck.Arbitrary as A
9-
import Test.QuickCheck.Gen as Gen
109

1110
data BinaryOperator
1211
= IfUndefined
@@ -121,15 +120,15 @@ instance decodeJsonBinaryOperator ∷ J.DecodeJson BinaryOperator where
121120
$ Left "This is not a binary operator"
122121
(obj J..? "value") >>= binopFromString
123122

124-
instance arbitraryBinaryOperatorA.Arbitrary BinaryOperator where
125-
arbitrary =
126-
Gen.elements $ IfUndefined :|
127-
[ Range, Or, And, Eq, Neq, Ge, Gt, Le, Lt
128-
, Concat, Plus, Minus, Mult, Div, Mod, Pow
129-
, In, FieldDeref, IndexDeref, Limit, Offset
130-
, Sample, Union, UnionAll, Intersect
131-
, IntersectAll, Except, UnshiftMap
132-
]
123+
genBinaryOperator m. Gen.MonadGen m m BinaryOperator
124+
genBinaryOperator =
125+
Gen.elements $ IfUndefined :|
126+
[ Range, Or, And, Eq, Neq, Ge, Gt, Le, Lt
127+
, Concat, Plus, Minus, Mult, Div, Mod, Pow
128+
, In, FieldDeref, IndexDeref, Limit, Offset
129+
, Sample, Union, UnionAll, Intersect
130+
, IntersectAll, Except, UnshiftMap
131+
]
133132

134133
printBinaryOperator String String BinaryOperator String
135134
printBinaryOperator lhs rhs = case _ of

src/SqlSquared/Signature/Case.purs

Lines changed: 5 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -2,16 +2,14 @@ module SqlSquared.Signature.Case where
22

33
import Prelude
44

5+
import Control.Monad.Gen as Gen
56
import Data.Argonaut as J
67
import Data.Either as E
7-
import Data.Newtype (class Newtype)
88
import Data.Foldable as F
9+
import Data.Newtype (class Newtype)
910
import Data.Traversable as T
10-
1111
import Matryoshka (Algebra, CoalgebraM)
1212

13-
import Test.QuickCheck.Gen as Gen
14-
1513
newtype Case a = Case { cond a, expr a }
1614

1715
derive instance functorCaseFunctor Case
@@ -23,6 +21,7 @@ instance foldableCase ∷ F.Foldable Case where
2321
foldMap f (Case { cond, expr }) = f expr
2422
foldl f a (Case { cond, expr }) = f (f a cond) expr
2523
foldr f a (Case { cond, expr }) = f cond $ f expr a
24+
2625
instance traversableCaseT.Traversable Case where
2726
traverse f (Case { cond, expr }) = map Case $ { cond: _, expr: _ } <$> f cond <*> f expr
2827
sequence = T.sequenceDefault
@@ -45,8 +44,7 @@ decodeJsonCase = J.decodeJson >=> \obj → do
4544
expr ← obj J..? "expr"
4645
pure $ Case { cond, expr }
4746

48-
49-
arbitraryCase CoalgebraM Gen.Gen Case Int
50-
arbitraryCase n
47+
genCase m. Gen.MonadGen m CoalgebraM m Case Int
48+
genCase n
5149
| n < 2 = pure $ Case { cond: 0, expr: 0 }
5250
| otherwise = pure $ Case { cond: n - 1, expr: n - 1 }

0 commit comments

Comments
 (0)