@@ -43,7 +43,8 @@ module SqlSquared.Signature
43
43
44
44
import Prelude
45
45
46
- import Control.Monad.Gen as MGen
46
+ import Control.Monad.Gen as Gen
47
+ import Control.Monad.Rec.Class (class MonadRec )
47
48
import Data.Argonaut as J
48
49
import Data.Array as A
49
50
import Data.Either as E
@@ -74,8 +75,6 @@ import SqlSquared.Signature.Projection as PR
74
75
import SqlSquared.Signature.Relation as RL
75
76
import SqlSquared.Signature.UnaryOperator as UO
76
77
import SqlSquared.Utils (type (×), (×), (∘), (⋙))
77
- import Test.QuickCheck.Arbitrary as QC
78
- import Test.QuickCheck.Gen as Gen
79
78
80
79
type BinopR a =
81
80
{ lhs ∷ a
@@ -736,9 +735,11 @@ decodeJsonSqlModuleF = J.decodeJson >=> \obj → do
736
735
_ → E.Left $ " Invalid top-level SQL^2 production: " <> tag
737
736
738
737
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
742
743
arbitrarySqlF genLiteral n
743
744
| n < 2 =
744
745
Gen .oneOf $ (Literal <$> genLiteral n) :|
@@ -761,103 +762,103 @@ arbitrarySqlF genLiteral n
761
762
, genSelect n
762
763
]
763
764
764
- arbitrarySqlDeclF ∷ CoalgebraM Gen. Gen SqlDeclF Int
765
+ arbitrarySqlDeclF ∷ ∀ m . Gen.MonadGen m ⇒ CoalgebraM m SqlDeclF Int
765
766
arbitrarySqlDeclF n =
766
767
Gen .oneOf $ genImport :|
767
768
[ genFunctionDecl n
768
769
]
769
770
770
- arbitrarySqlQueryF ∷ CoalgebraM Gen. Gen SqlQueryF Int
771
+ arbitrarySqlQueryF ∷ ∀ m . Gen.MonadGen m ⇒ CoalgebraM m SqlQueryF Int
771
772
arbitrarySqlQueryF n = Query <$> genDecls n <*> pure n
772
773
773
- arbitrarySqlModuleF ∷ CoalgebraM Gen. Gen SqlModuleF Int
774
+ arbitrarySqlModuleF ∷ ∀ m . Gen.MonadGen m ⇒ CoalgebraM m SqlModuleF Int
774
775
arbitrarySqlModuleF n = Module <$> genDecls n
775
776
776
- genSetLiteral ∷ ∀ l . CoalgebraM Gen.Gen (SqlF l ) Int
777
+ genSetLiteral ∷ ∀ m l . Gen.MonadGen m ⇒ CoalgebraM m (SqlF l ) Int
777
778
genSetLiteral n = do
778
779
len ← Gen .chooseInt 0 $ n - 1
779
780
pure $ SetLiteral $ map (const $ n - 1 ) $ L .range 0 len
780
781
781
- genBinop ∷ ∀ l . CoalgebraM Gen.Gen (SqlF l ) Int
782
+ genBinop ∷ ∀ m l . Gen.MonadGen m ⇒ CoalgebraM m (SqlF l ) Int
782
783
genBinop n = do
783
- op ← QC .arbitrary
784
+ op ← BO .genBinaryOperator
784
785
pure $ Binop { op, lhs: n - 1 , rhs: n - 1 }
785
786
786
- genUnop ∷ ∀ l . CoalgebraM Gen.Gen (SqlF l ) Int
787
+ genUnop ∷ ∀ m l . Gen.MonadGen m ⇒ CoalgebraM m (SqlF l ) Int
787
788
genUnop n = do
788
- op ← QC .arbitrary
789
+ op ← UO .genUnaryOperator
789
790
pure $ Unop { op, expr: n - 1 }
790
791
791
- genInvokeFunction ∷ ∀ l . CoalgebraM Gen.Gen (SqlF l ) Int
792
+ genInvokeFunction ∷ ∀ m l . Gen.MonadGen m ⇒ CoalgebraM m (SqlF l ) Int
792
793
genInvokeFunction n = do
793
794
name ← genIdent
794
795
len ← Gen .chooseInt 0 $ n - 1
795
796
pure $ InvokeFunction { name, args: map (const $ n - 1 ) $ L .range 0 len }
796
797
797
- genMatch ∷ ∀ l . CoalgebraM Gen.Gen (SqlF l ) Int
798
+ genMatch ∷ ∀ m l . Gen.MonadGen m ⇒ CoalgebraM m (SqlF l ) Int
798
799
genMatch n = do
799
- nothing ← QC .arbitrary
800
+ nothing ← Gen .chooseBool
800
801
len ← Gen .chooseInt 0 $ n - 1
801
802
let
802
803
foldFn acc _ = do
803
- cs ← CS .arbitraryCase $ n - 1
804
+ cs ← CS .genCase $ n - 1
804
805
pure $ cs L .: acc
805
806
cases ← L .foldM foldFn L.Nil $ L .range 0 len
806
807
pure $ Match { expr: n - 1
807
808
, cases
808
809
, else_: if nothing then Nothing else Just $ n - 1
809
810
}
810
- genSwitch ∷ ∀ l . CoalgebraM Gen.Gen (SqlF l ) Int
811
+ genSwitch ∷ ∀ m l . Gen.MonadGen m ⇒ CoalgebraM m (SqlF l ) Int
811
812
genSwitch n = do
812
- nothing ← QC .arbitrary
813
+ nothing ← Gen .chooseBool
813
814
len ← Gen .chooseInt 0 $ n - 1
814
815
let
815
816
foldFn acc _ = do
816
- cs ← CS .arbitraryCase $ n - 1
817
+ cs ← CS .genCase $ n - 1
817
818
pure $ cs L .: acc
818
819
cases ← L .foldM foldFn L.Nil $ L .range 0 len
819
820
pure $ Switch { cases
820
821
, else_: if nothing then Nothing else Just $ n - 1
821
822
}
822
823
823
- genLet ∷ ∀ l . CoalgebraM Gen.Gen (SqlF l ) Int
824
+ genLet ∷ ∀ m l . Gen.MonadGen m ⇒ CoalgebraM m (SqlF l ) Int
824
825
genLet n = do
825
826
ident ← genIdent
826
827
pure $ Let { ident
827
828
, bindTo: n - 1
828
829
, in_: n - 1
829
830
}
830
831
831
- genSelect ∷ ∀ l . CoalgebraM Gen.Gen (SqlF l ) Int
832
+ genSelect ∷ ∀ m l . Gen.MonadGen m ⇒ MonadRec m ⇒ CoalgebraM m (SqlF l ) Int
832
833
genSelect n = do
833
834
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
839
840
840
841
let
841
842
foldPrj acc _ = do
842
- prj ← PR .arbitraryProjection $ n - 1
843
+ prj ← PR .genProjection $ n - 1
843
844
pure $ prj L .:acc
844
845
projections ←
845
846
L .foldM foldPrj L.Nil $ L .range 0 prjLen
846
847
847
848
relations ←
848
849
if mbRelation
849
850
then pure Nothing
850
- else map Just $ RL .arbitraryRelation $ n - 1
851
+ else map Just $ RL .genRelation $ n - 1
851
852
852
853
groupBy ←
853
854
if mbGroupBy
854
855
then pure Nothing
855
- else map Just $ GB .arbitraryGroupBy $ n - 1
856
+ else map Just $ GB .genGroupBy $ n - 1
856
857
857
858
orderBy ←
858
859
if mbOrderBy
859
860
then pure Nothing
860
- else map Just $ OB .arbitraryOrderBy $ n - 1
861
+ else map Just $ OB .genOrderBy $ n - 1
861
862
862
863
pure $ Select { isDistinct
863
864
, projections
@@ -867,7 +868,7 @@ genSelect n = do
867
868
, orderBy
868
869
}
869
870
870
- genFunctionDecl ∷ CoalgebraM Gen. Gen SqlDeclF Int
871
+ genFunctionDecl ∷ ∀ m . Gen.MonadGen m ⇒ CoalgebraM m SqlDeclF Int
871
872
genFunctionDecl n = do
872
873
ident ← genIdent
873
874
len ← Gen .chooseInt 0 $ n - 1
@@ -878,16 +879,16 @@ genFunctionDecl n = do
878
879
args ← L .foldM foldFn L.Nil $ L .range 0 len
879
880
pure $ FunctionDecl { ident, args, body: n - 1 }
880
881
881
- genImport ∷ ∀ a . Gen.Gen (SqlDeclF a )
882
+ genImport ∷ ∀ m a . Gen.MonadGen m ⇒ m (SqlDeclF a )
882
883
genImport = Import <$> genIdent
883
884
884
- genIdent ∷ Gen. Gen String
885
+ genIdent ∷ ∀ m . Gen.MonadGen m ⇒ m String
885
886
genIdent = do
886
887
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 )
888
889
pure $ start <> body
889
890
890
- genDecls ∷ Int → Gen.Gen (L.List (SqlDeclF Int ))
891
+ genDecls ∷ ∀ m . Gen.MonadGen m ⇒ Int → m (L.List (SqlDeclF Int ))
891
892
genDecls n = do
892
893
let
893
894
foldFn acc _ = do
@@ -901,32 +902,32 @@ genDecls n = do
901
902
-- actually ported from quasar, this is very important
902
903
-- but annoying stuff :|
903
904
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
905
906
906
- genSql ∷ ∀ t . Int → GenSql t
907
+ genSql ∷ ∀ m t . Int → GenSql m t
907
908
genSql n
908
909
| n < 2 = genLeaf
909
910
| otherwise =
910
911
Gen .oneOf $ genLetP (n - 1 ) :| [ genQueryExprP (n - 1 ) ]
911
912
912
- genLeaf ∷ ∀ t . GenSql t
913
+ genLeaf ∷ ∀ m t . GenSql m t
913
914
genLeaf =
914
915
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
919
920
, EJ.String <$> GenS .genUnicodeString
920
921
]
921
922
922
- genLetP ∷ ∀ t . Int → GenSql t
923
+ genLetP ∷ ∀ m t . Int → GenSql m t
923
924
genLetP n = do
924
925
ident ← genIdent
925
926
bindTo ← genSql n
926
927
in_ ← genSql n
927
928
pure $ embed $ Let { ident, bindTo, in_ }
928
929
929
- genQueryExprP ∷ ∀ t . Int → GenSql t
930
+ genQueryExprP ∷ ∀ m t . Int → GenSql m t
930
931
genQueryExprP n
931
932
| n < 2 = Gen .oneOf $ genQueryP n :| [ genDefinedExprP n ]
932
933
| otherwise = do
@@ -940,12 +941,12 @@ genQueryExprP n
940
941
rhs ← Gen .oneOf $ genQueryP n :| [ genDefinedExprP n ]
941
942
pure $ embed $ Binop { op, lhs, rhs }
942
943
943
- genDefinedExprP ∷ ∀ t . Int → GenSql t
944
+ genDefinedExprP ∷ ∀ m t . Int → GenSql m t
944
945
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
947
948
start ← genPrimaryExprP n
948
- adds ← Gen .vectorOf n $ genPrimaryExprP n
949
+ adds ← Gen .resize (const n) $ Gen .unfoldable $ genPrimaryExprP n
949
950
pure $ F .foldl foldFn start $ A .zip binops $ A .zip unops adds
950
951
where
951
952
foldFn acc (binop × unop × rhs) =
@@ -957,7 +958,7 @@ genDefinedExprP n = do
957
958
, expr: embed $ Binop { lhs: acc, rhs, op:binop }
958
959
}
959
960
960
- genPrimaryExprP ∷ ∀ t . Int → GenSql t
961
+ genPrimaryExprP ∷ ∀ m t . Int → GenSql m t
961
962
genPrimaryExprP n =
962
963
Gen .oneOf $ genLeaf :|
963
964
[ genCaseP n
@@ -970,26 +971,26 @@ genPrimaryExprP n =
970
971
, map (embed ∘ Ident ) genIdent
971
972
]
972
973
973
- genCaseP ∷ ∀ t . Int → GenSql t
974
+ genCaseP ∷ ∀ m t . Int → GenSql m t
974
975
genCaseP n = genLeaf
975
976
976
- genUnaryP ∷ ∀ t . Int → GenSql t
977
+ genUnaryP ∷ ∀ m t . Int → GenSql m t
977
978
genUnaryP n = genLeaf
978
979
979
- genFunctionP ∷ ∀ t . Int → GenSql t
980
+ genFunctionP ∷ ∀ m t . Int → GenSql m t
980
981
genFunctionP n = genLeaf
981
982
982
- genSetP ∷ ∀ t . Int → GenSql t
983
+ genSetP ∷ ∀ m t . Int → GenSql m t
983
984
genSetP n = genLeaf
984
985
985
- genArrayP ∷ ∀ t . Int → GenSql t
986
+ genArrayP ∷ ∀ m t . Int → GenSql m t
986
987
genArrayP n = genLeaf
987
988
988
- genMapP ∷ ∀ t . Int → GenSql t
989
+ genMapP ∷ ∀ m t . Int → GenSql m t
989
990
genMapP n = genLeaf
990
991
991
- genSpliceP ∷ ∀ t . Int → GenSql t
992
+ genSpliceP ∷ ∀ m t . Int → GenSql m t
992
993
genSpliceP n = pure $ embed $ Splice Nothing
993
994
994
- genQueryP ∷ ∀ t . Int → GenSql t
995
+ genQueryP ∷ ∀ m t . Int → GenSql m t
995
996
genQueryP n = genLeaf
0 commit comments