Skip to content

Commit d8caa96

Browse files
ali-abrarali-abrar
authored
Merge branch 'develop' into utf8encoder
2 parents e0c3ce2 + 7e3f42c commit d8caa96

File tree

3 files changed

+360
-3
lines changed

3 files changed

+360
-3
lines changed

‎lib/route/obelisk-route.cabal‎

Lines changed: 30 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -37,7 +37,37 @@ library
3737
transformers,
3838
universe,
3939
universe-some
40+
4041
exposed-modules: Obelisk.Route
4142
Obelisk.Route.TH
4243
Obelisk.Route.Frontend
44+
4345
ghc-options: -Wall -Werror -fprint-potential-instances -Wredundant-constraints -Wincomplete-uni-patterns -Wincomplete-record-updates -O
46+
47+
test-suite roundtrips
48+
type: exitcode-stdio-1.0
49+
main-is: Main.hs
50+
hs-source-dirs: test
51+
default-language: Haskell2010
52+
ghc-options: -Wall -Werror -fprint-potential-instances -Wredundant-constraints -Wincomplete-uni-patterns -Wincomplete-record-updates -O
53+
54+
build-depends:
55+
QuickCheck,
56+
aeson,
57+
base,
58+
categories,
59+
containers,
60+
dependent-map,
61+
dependent-sum,
62+
dependent-sum-template,
63+
lens,
64+
some,
65+
obelisk-route,
66+
quickcheck-instances,
67+
tabulation,
68+
tasty,
69+
tasty-quickcheck,
70+
text,
71+
transformers,
72+
universe,
73+
universe-some

‎lib/route/src/Obelisk/Route.hs‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -193,7 +193,7 @@ import Data.Monoid (Ap(..))
193193
import Data.Set (Set)
194194
import qualified Data.Set as Set
195195
import Data.Semigroupoid
196-
import Data.Some (Some(Some), mapSome)
196+
import Data.Some (Some(Some), foldSome, mapSome)
197197
import Data.Tabulation
198198
import Data.Text (Text)
199199
import qualified Data.Text as T
@@ -1106,11 +1106,11 @@ data Void1 :: * -> * where {}
11061106

11071107
instance UniverseSome Void1 where
11081108
universeSome = []
1109+
instance FiniteSome Void1
11091110

11101111
void1Encoder :: (Applicative check, MonadError Text parse) => Encoder check parse (Some Void1) a
11111112
void1Encoder = Encoder $ pure $ EncoderImpl
1112-
{ _encoderImpl_encode = \case
1113-
Some f -> case f of {}
1113+
{ _encoderImpl_encode = foldSome $ \case
11141114
, _encoderImpl_decode = \_ -> throwError "void1Encoder: can't decode anything"
11151115
}
11161116

‎lib/route/test/Main.hs‎

Lines changed: 327 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,327 @@
1+
{-# LANGUAGE ConstraintKinds #-}
2+
{-# LANGUAGE DeriveAnyClass #-}
3+
{-# LANGUAGE DeriveGeneric #-}
4+
{-# LANGUAGE FlexibleContexts #-}
5+
{-# LANGUAGE FlexibleInstances #-}
6+
{-# LANGUAGE GADTs #-}
7+
{-# LANGUAGE LambdaCase #-}
8+
{-# LANGUAGE LiberalTypeSynonyms #-}
9+
{-# LANGUAGE MultiParamTypeClasses #-}
10+
{-# LANGUAGE NumDecimals #-}
11+
{-# LANGUAGE OverloadedStrings #-}
12+
{-# LANGUAGE QuantifiedConstraints #-}
13+
{-# LANGUAGE RankNTypes #-}
14+
{-# LANGUAGE ScopedTypeVariables #-}
15+
{-# LANGUAGE TemplateHaskell #-}
16+
{-# LANGUAGE TypeApplications #-}
17+
{-# LANGUAGE TypeFamilies #-}
18+
19+
module Main where
20+
21+
import Prelude hiding (id, (.))
22+
23+
import Control.Applicative (liftA2)
24+
import Control.Categorical.Bifunctor (bimap)
25+
import Control.Category (Category((.), id))
26+
import Control.Category.Associative (associate, Associative (disassociate))
27+
import Control.Category.Monoidal
28+
import Control.Lens (Iso', Prism', lazy, lens, reversed, _Just, _Left, _Right)
29+
import Data.Dependent.Map (DMap)
30+
import Data.Dependent.Sum (DSum((:=>)) )
31+
import Data.Either (isLeft, isRight)
32+
import Data.Foldable (Foldable(fold))
33+
import Data.Functor.Identity (Identity)
34+
import Data.Int (Int8)
35+
import Data.Map (Map)
36+
import Data.Some (Some)
37+
import Data.Tabulation (HasFields(Field, tabulateFieldsA, fieldLens))
38+
import Data.Text (Text)
39+
import Data.Universe (Finite(universeF), Universe)
40+
import Data.Word (Word8)
41+
import GHC.Generics (Generic)
42+
import qualified Control.Categorical.Functor as Cat
43+
import qualified Data.Aeson as Aeson
44+
import qualified Data.Dependent.Map as DMap
45+
import Test.QuickCheck
46+
import Test.QuickCheck.Instances ()
47+
import Test.Tasty (defaultMain, testGroup, TestName, TestTree)
48+
import Test.Tasty.QuickCheck (testProperty)
49+
50+
import Obelisk.Route
51+
import Obelisk.Route.TH
52+
53+
data Input
54+
= Input_Word Word
55+
| Input_Text Text
56+
| Input_Pair Input Input
57+
| Input_List [Input]
58+
deriving (Eq, Ord, Read, Show, Generic, Aeson.FromJSON, Aeson.ToJSON)
59+
60+
instance Arbitrary Input where
61+
arbitrary = oneof
62+
[ Input_Word <$> arbitrary
63+
, Input_Text <$> arbitrary
64+
, Input_Pair <$> arbitrary <*> arbitrary
65+
, Input_List <$> (vector =<< chooseInt (0,2))
66+
]
67+
shrink = \case
68+
Input_Word a -> Input_Word <$> shrink a
69+
Input_Text a -> Input_Text <$> shrink a
70+
Input_Pair a b -> Input_Pair <$> shrink a <*> shrink b
71+
Input_List a -> Input_List <$> shrink a
72+
73+
data XY = XY
74+
{ _x :: Int
75+
, _y :: Word
76+
} deriving (Eq, Ord, Show)
77+
78+
instance Arbitrary XY where
79+
arbitrary = XY <$> arbitrary <*> arbitrary
80+
81+
data XYField a where
82+
XYField_X :: XYField Int
83+
XYField_Y :: XYField Word
84+
85+
instance HasFields XY where
86+
type Field XY = XYField
87+
fieldLens = \case
88+
XYField_X -> lens _x $ \xy x -> xy { _x = x }
89+
XYField_Y -> lens _y $ \xy y -> xy { _y = y }
90+
tabulateFieldsA g = pure XY
91+
<*> g XYField_X
92+
<*> g XYField_Y
93+
94+
deriveRouteComponent ''XYField
95+
96+
97+
instance Arbitrary (R XYField) where
98+
arbitrary = oneof
99+
[ fmap (XYField_X :=>) arbitrary
100+
, fmap (XYField_Y :=>) arbitrary
101+
]
102+
instance Arbitrary (DMap XYField Identity) where
103+
arbitrary = fmap fold $ sequence
104+
[ opt XYField_X 1
105+
, opt XYField_Y 1
106+
] where opt k v = oneof $ fmap pure [ mempty, DMap.singleton k v ]
107+
108+
data A = A deriving (Bounded, Enum, Eq, Ord, Show, Universe)
109+
data B = B deriving (Bounded, Enum, Eq, Ord, Show, Universe)
110+
data C = C1 | C2 deriving (Bounded, Enum, Eq, Ord, Show, Universe)
111+
instance Arbitrary A where arbitrary = pure A
112+
instance Arbitrary B where arbitrary = pure B
113+
114+
ac :: Encoder' A C
115+
ac = generalizeIdentity $ handleEncoder (\_ -> A) $ enumEncoder $ \A -> C1
116+
117+
bc :: Encoder' B C
118+
bc = enumEncoder $ \B -> C2
119+
120+
type Encoder' a b = Encoder (Either Text) (Either Text) a b
121+
type Cont a = forall r. (a -> r) -> r
122+
type RoundtripConstraints a = (Arbitrary a, Eq a, Show a)
123+
data Ex where
124+
Ex :: RoundtripConstraints x => Encoder' x y -> Ex
125+
126+
127+
roundtripsProp :: Eq a => Encoder Identity (Either Text) a b -> a -> Bool
128+
roundtripsProp e a = tryDecode e (encode e a) == pure a
129+
130+
withCheckedEncoder
131+
:: Testable prop
132+
=> Encoder' a b
133+
-> (Encoder Identity (Either Text) a b -> prop)
134+
-> Property
135+
withCheckedEncoder e f = case checkEncoder e of
136+
Left _ -> property False
137+
Right e' -> property $ f e'
138+
139+
mkRoundtripTestTree :: (Arbitrary a, Show a, RoundtripConstraints x) => TestName -> (a -> Encoder' x y) -> TestTree
140+
mkRoundtripTestTree lbl f = testProperty lbl $ withMaxSuccess 1e3 $ \(a, x) -> withCheckedEncoder (f x) (flip roundtripsProp a)
141+
142+
arity0 :: Cont (forall a b. RoundtripConstraints a => TestName -> Encoder' a b -> TestTree)
143+
arity0 f = f $ \lbl e -> mkRoundtripTestTree lbl $ \() -> e
144+
145+
arity1 :: Cont (forall a b x. (RoundtripConstraints a, Arbitrary x, Show x) => TestName -> (x -> Encoder' a b) -> TestTree)
146+
arity1 f = f mkRoundtripTestTree
147+
148+
withEncoders
149+
:: [(TestName, Ex)]
150+
-> (forall x y. RoundtripConstraints x => TestName -> Encoder' x y -> t)
151+
-> [t]
152+
withEncoders es t = flip fmap es $ \(lbl, Ex e) -> t lbl e
153+
154+
withEncoders2
155+
:: [(TestName, Ex)]
156+
-> [(TestName, Ex)]
157+
-> (forall a0 a1 b0 b1. (RoundtripConstraints a0, RoundtripConstraints b0) => TestName -> Encoder' a0 a1 -> Encoder' b0 b1 -> t)
158+
-> [t]
159+
withEncoders2 xs ys f = liftA2 g xs ys
160+
where g (n1, Ex e1) (n2, Ex e2) = f (n1 <> "," <> n2) e1 e2
161+
162+
163+
unsafeShowShadowEncoder :: (Universe a, Read a, Read b, Show a, Show b) => Encoder' (Either a b) PageName
164+
unsafeShowShadowEncoder = shadowEncoder unsafeShowEncoder unsafeShowEncoder
165+
166+
xymapEncoder :: Encoder' (DMap XYField Identity) (Map Text Text)
167+
xymapEncoder = dmapEncoder k v
168+
where
169+
k :: Encoder' (Some XYField) Text
170+
k = enum1Encoder $ \case
171+
XYField_X -> "x"
172+
XYField_Y -> "y"
173+
v :: XYField a -> Encoder' a Text
174+
v = \case
175+
XYField_X -> unsafeTshowEncoder
176+
XYField_Y -> unsafeTshowEncoder
177+
178+
xypathFieldEncoder :: Encoder' (XY, [Text]) [Text]
179+
xypathFieldEncoder = pathFieldEncoder $ \case
180+
XYField_X -> unsafeTshowEncoder
181+
XYField_Y -> unsafeTshowEncoder
182+
183+
fragmentEncoder, overlappingFragmentEncoder :: Encoder' (R XYField) PageName
184+
(fragmentEncoder, overlappingFragmentEncoder) = (enc "int" "word", enc "tag" "tag")
185+
where
186+
enc :: Text -> Text -> Encoder' (R XYField) PageName
187+
enc i w = pathComponentEncoder $ \case
188+
XYField_X -> PathSegment i unsafeShowEncoder
189+
XYField_Y -> PathSegment w unsafeShowEncoder
190+
191+
-- No arguments
192+
atomicEncoders :: [(TestName, Ex)]
193+
atomicEncoders = let t n e = (n, Ex e) in
194+
[ t "addPathSegmentEncoder" addPathSegmentEncoder
195+
, t "fieldMapEncoder" $ fieldMapEncoder @_ @_ @XY
196+
, t "jsonEncoder" $ jsonEncoder @_ @_ @Input
197+
, t "maybeToEitherEncoder" $ maybeToEitherEncoder @_ @_ @Input
198+
, t "pathComponentEncoder" fragmentEncoder
199+
, t "pathSegmentsTextEncoder" pathSegmentsTextEncoder
200+
, t "singletonListEncoder" $ singletonListEncoder @_ @_ @Input
201+
, t "toListMapEncoder" $ toListMapEncoder @_ @_ @Input @Input
202+
, t "unsafeTshowEncoder" $ unsafeTshowEncoder @Input
203+
204+
--, t "consEncoder" $ consEncoder @_ @_ @Word -- failing/unexported
205+
--, t "listToNonEmptyEncoder" (listToNonEmptyEncoder @_ @_ @Text) -- failing
206+
--, t "pathOnlyEncoderIgnoringQuery" pathOnlyEncoderIgnoringQuery -- unexported
207+
--, t "pathQueryEncoder" pathQueryEncoder -- failing
208+
--, t "queryParametersTextEncoder" queryParametersTextEncoder -- failing
209+
210+
--, t "someConstEncoder" (someConstEncoder @_ @_ @Input) -- Eq (Some (Const a)) requires GEq (Const a)
211+
--, t "someSumEncoder" (someSumEncoder @_ @_ @(Const Input) @(Const Input)) -- Eq (Some (Const a)) requires GEq (Const a)
212+
213+
, t "associate" $ associate @_ @(,) @Bool @Text @Word
214+
, t "associate" $ associate @_ @Either @Bool @Text @Word
215+
, t "disassociate" $ disassociate @_ @(,) @Bool @Text @Word
216+
, t "disassociate" $ disassociate @_ @Either @Bool @Text @Word
217+
218+
, t "idl" $ idl @_ @(,) @Text
219+
, t "idr" $ idr @_ @(,) @Text
220+
, t "coidl" $ coidl @_ @(,) @Text
221+
, t "coidr" $ coidr @_ @(,) @Text
222+
]
223+
224+
-- No encoders as arguments
225+
primitiveEncoders :: [(TestName, Ex)]
226+
primitiveEncoders = fold
227+
[ atomicEncoders
228+
, reviews
229+
, views
230+
, [ t "enumEncoder" $ enumEncoder @_ @_ @Word8 (+1) ]
231+
]
232+
where
233+
t n e = (n, Ex e)
234+
235+
r :: (forall x y. RoundtripConstraints x => TestName -> Prism' y x -> (TestName, Ex))
236+
r n p = t ("reviewEncoder: " <> n) (reviewEncoder p)
237+
238+
v :: (forall x y. RoundtripConstraints x => TestName -> Iso' x y -> (TestName, Ex))
239+
v n p = t ("viewEncoder: " <> n) (viewEncoder p)
240+
241+
reviews =
242+
[ r @Input "_Just" _Just
243+
, r @Input "_Left" _Left
244+
, r @Input "_Right" _Right
245+
]
246+
247+
views =
248+
[ v @Input "id" id
249+
, v @Text "lazy" lazy
250+
, v @String "reversed" reversed
251+
]
252+
253+
exhaustive :: TestTree
254+
exhaustive =
255+
let
256+
prop :: Cont (forall a b. (Eq a, Finite a) => TestName -> Encoder' a b -> TestTree)
257+
prop f = f $ \lbl e -> testProperty lbl $ withCheckedEncoder e $ flip all universeF . roundtripsProp
258+
in
259+
testGroup "Roundtrip" $ prop $ \t ->
260+
[ t "void1Encoder" void1Encoder
261+
, t "id (Word8)" $ id @_ @Word8
262+
, t "enumEncoder" $ enumEncoder @_ @_ @Word8 (+1)
263+
]
264+
265+
overlaps :: TestTree
266+
overlaps =
267+
let
268+
prop :: (forall x y. Either x y -> Bool) -> Cont (forall a b. TestName -> Encoder' a b -> TestTree)
269+
prop is f = f $ \n -> testProperty n . is . checkEncoder @(Either Text)
270+
271+
in
272+
testGroup "Overlaps"
273+
[ testGroup "No false positives" $ prop isRight $ \_t ->
274+
[ -- t "shadowEncoder" $ shadowEncoder bc ac -- https://github.com/obsidiansystems/obelisk/pull/987
275+
]
276+
, testGroup "No false negatives" $ prop isLeft $ \t ->
277+
[ t "enumEncoder" $ enumEncoder @_ @_ @Word8 (*2)
278+
, t "pathComponentEncoder" overlappingFragmentEncoder
279+
, t "shadowEncoder" $ unsafeShowShadowEncoder @Word8 @Int8
280+
, t "shadowEncoder" $ unsafeShowShadowEncoder @Word8 @Word8
281+
]
282+
]
283+
284+
roundtrips :: TestTree
285+
roundtrips = testGroup "Roundtrip" $ fold
286+
[ arity0 $ withEncoders primitiveEncoders
287+
, arity0 $ \t ->
288+
[ t "dmapEncoder" xymapEncoder
289+
, t "pathFieldEncoder" xypathFieldEncoder
290+
, t "shadowEncoder" $ unsafeShowShadowEncoder @Word8 @Char
291+
--, t "shadowEncoder" $ shadowEncoder ac bc --https://github.com/obsidiansystems/obelisk/pull/987
292+
, t "handleEncoder" $ generalizeIdentity $ handleEncoder @_ @_ @Input (error "Must not be used") id
293+
]
294+
, arity1 $ \t ->
295+
[ t "unitEncoder" (unitEncoder @_ @_ @Input)
296+
--, t "joinPairTextEncoder" joinPairTextEncoder -- Failing
297+
, t "prefixTextEncoder" prefixTextEncoder
298+
, t "prefixNonemptyTextEncoder" prefixNonemptyTextEncoder
299+
]
300+
, arity0 $ \t ->
301+
[ testGroup "left identity" $ withEncoders primitiveEncoders $ \lbl e -> t lbl $ id . e
302+
, testGroup "right identity" $ withEncoders primitiveEncoders $ \lbl e -> t lbl $ e . id
303+
, testGroup "fmap"
304+
[ testGroup "Maybe" $ withEncoders primitiveEncoders $ \lbl -> t lbl . Cat.fmap @Maybe
305+
, testGroup "Either" $ withEncoders primitiveEncoders $ \lbl -> t lbl . Cat.fmap @(Either ())
306+
]
307+
, let
308+
sampleSize = ceiling @Double @Int . sqrt . fromIntegral . length
309+
smallSample = take (sampleSize primitiveEncoders) primitiveEncoders
310+
in
311+
testGroup "bimap"
312+
[ testGroup "(,)" $ withEncoders2 smallSample smallSample $ \lbl e1 e2 -> t lbl $ bimap @(,) e1 e2
313+
, testGroup "Either" $ withEncoders2 smallSample smallSample $ \lbl e1 e2 -> t lbl $ bimap @Either e1 e2
314+
]
315+
]
316+
]
317+
318+
tests :: IO ()
319+
tests = do
320+
defaultMain $ testGroup "Encoders"
321+
[ testGroup "Exhaustive search" [ exhaustive ]
322+
, testGroup "Unit testing" [ overlaps ]
323+
, testGroup "Property testing" [ roundtrips ]
324+
]
325+
326+
main :: IO ()
327+
main = tests

0 commit comments

Comments
 (0)