blob: 976483f963011bc16a7f6214812e388eb2885c16 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
|
{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
-- 0 => use unsafeCoerce
-- 1 => use withDict
#define WITH_DICT 1
module Main (main) where
import Control.Monad (unless)
import qualified Data.Map as M
import Data.Map (Map)
#if WITH_DICT
import GHC.Exts (withDict)
#else
import Unsafe.Coerce (unsafeCoerce)
#endif
main :: IO ()
main = do
testCase (give Normal (toJSON (Foo Bar)))
(Object (M.fromList [("Foo",String "Bar")]))
testCase (give ViaShow (toJSON (Foo Bar)))
(Object (M.fromList [("Foo",String "SHOWBAR")]))
putStrLn "All tests passed!"
{-
toJSONBar :: Given Style => Bar -> Value
give Normal (\gd -> toJSONBar gd e)
--> withDict @Style @(Given Style) Normal (toJSON e)
--> toJSONBar ((Normal |> co) :: Given Style) e
give Normal (\gd -> toJSONBar gd e')
--> toJSONBar ((ViaShow |> co) :: Given Style) e'
--------- With new cast ------------
give Normal (\gd -> toJSONBar gd e)
--> withDict @Style @(Given Style) Normal (\gd -> toJSONBar gd e)
--> ((\gd -> toJSONBar gd e) |> co) Normal
--> (\gd' -> toJSonBar (gd' |> sym (co[1])) e) Normal
--> toJSONBar (Normal |> co') e -- Boo!
-}
testCase :: (Eq a, Show a) => a -> a -> IO ()
testCase expected actual =
unless (expected == actual) $
error $ unlines
[ ""
, "Expected: " ++ show expected
, "Actual: " ++ show actual
]
class Given a where
given :: a
give :: forall a r. a -> (Given a => r) -> r
#if WITH_DICT
give = withDict @a @(Given a)
#else
give a k = unsafeCoerce (Gift k :: Gift a r) a
newtype Gift a r = Gift (Given a => r)
#endif
data Foo = Foo Bar
instance Show Foo where
show _ = "SHOWFOO"
data Bar = Bar | BarBar
instance Show Bar where
show _ = "SHOWBAR"
----------------------------------------------------------------------------
-- ToJSON instances
----------------------------------------------------------------------------
instance Given Style => ToJSON Foo where
toJSON (Foo x) = Object $ M.singleton "Foo" (toJSON x)
instance Given Style => ToJSON Bar where
toJSON x = case given of
Normal -> String $ case x of
Bar -> "Bar"
BarBar -> "BarBar"
ViaShow -> String $ show x
data Style = Normal | ViaShow
----------------------------------------------------------------------------
-- Minimized aeson
----------------------------------------------------------------------------
class ToJSON a where
toJSON :: a -> Value
data Value
= Object !(Map String Value)
| String !String
deriving (Eq, Show)
|
