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
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
|
{-# LANGUAGE AllowAmbiguousTypes, FunctionalDependencies, ScopedTypeVariables, PolyKinds, TypeApplications, DataKinds #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedRecordDot, OverloadedRecordUpdate #-}
-- For "higher kinded data" test.
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RebindableSyntax #-}
import Prelude
-- Choice (C2a).
import Data.Function -- for &
import Data.Functor.Identity
class HasField x r a | x r -> a where
hasField :: r -> (a -> r, a)
getField :: forall x r a . HasField x r a => r -> a
getField = snd . hasField @x -- Note: a.x = is getField @"x" a.
setField :: forall x r a . HasField x r a => r -> a -> r
setField = fst . hasField @x -- Note : a{x = b} is setField @"x" a b.
-- 'Foo' has 'foo' field of type 'Bar'
data Foo = Foo { foo :: Bar } deriving (Show, Eq)
instance HasField "foo" Foo Bar where
hasField r = (\x -> case r of Foo { .. } -> Foo { foo = x, .. }, foo r)
-- 'Bar' has a 'bar' field of type 'Baz'
data Bar = Bar { bar :: Baz } deriving (Show, Eq)
instance HasField "bar" Bar Baz where
hasField r = (\x -> case r of Bar { .. } -> Bar { bar = x, .. }, bar r)
-- 'Baz' has a 'baz' field of type 'Quux'
data Baz = Baz { baz :: Quux } deriving (Show, Eq)
instance HasField "baz" Baz Quux where
hasField r = (\x -> case r of Baz { .. } -> Baz { baz = x, .. }, baz r)
-- 'Quux' has a 'quux' field of type 'Int'
data Quux = Quux { quux :: Int } deriving (Show, Eq)
instance HasField "quux" Quux Int where
hasField r = (\x -> case r of Quux { .. } -> Quux { quux = x, .. }, quux r)
-- 'Corge' has a '&&&' field of type 'Int'
data Corge = Corge { (&&&) :: Int } deriving (Show, Eq)
instance HasField "&&&" Corge Int where
hasField r = (\x -> case r of Corge { .. } -> Corge { (&&&) = x, .. }, (&&&) r)
-- Note : Dot notation is not available for fields with operator
-- names.
-- 'Grault' has two fields 'f' and 'g' of type 'Foo'.
data Grault = Grault {f :: Foo, g :: Foo} deriving (Show, Eq)
instance HasField "f" Grault Foo where
hasField r = (\x -> case r of Grault { .. } -> Grault { f = x, .. }, f r)
instance HasField "g" Grault Foo where
hasField r = (\x -> case r of Grault { .. } -> Grault { g = x, .. }, g r)
-- "Higher kinded data"
-- (see https://reasonablypolymorphic.com/blog/higher-kinded-data/)
type family H f a where
H Identity a = a
H f a = f a
data P f = P
{ n :: H f String
}
-- See https://github.com/ndmitchell/record-dot-preprocessor/pull/34.
instance (a ~ H f String) => HasField "n" (P f) a where
hasField r = (\x -> case r of P { .. } -> P { n = x, .. }, n r)
main = do
let a = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 42 } } } }
let b = Corge{ (&&&) = 12 };
let c = Grault {
f = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 1 } } } }
, g = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 1 } } } }
}
-- A "selector" is an expression like '(.a)' or '(.a.b)'.
putStrLn "-- selectors:"
print $ (.foo) a -- Bar { bar = Baz { baz = Quux { quux = 42 } } }
print $ (.foo.bar) a -- Baz { baz = Quux { quux = 42 } }
print $ (.foo.bar.baz) a -- Quux { quux = 42 }
print $ (.foo.bar.baz.quux) a -- 42
print $ ((&&&) b) -- 12
-- print $ (b.(&&&)) -- illegal : parse error on input ‘(’
print $ getField @"&&&" b -- 12
-- A "selection" is an expression like 'r.a' or '(f r).a.b'.
putStrLn "-- selections:"
print $ a.foo.bar.baz.quux -- 42
print $ a.foo.bar.baz -- Quux { quux = 42 }
print $ a.foo.bar -- Baz { baz = Quux { quux = 42 } }
print $ a.foo -- Bar { bar = Baz { baz = Quux { quux = 42 } } }
print $ (const "hello") a.foo -- f r.x means f (r.x)
-- print $ f a .foo -- f r .x is illegal
print $ (const "hello") (id a).foo -- f (g r).x means f ((g r).x)
-- print $ f (g a) .foo -- f (g r) .x is illegal
print $ a.foo
& (.bar.baz.quux) -- 42
print $ (a.foo
).bar.baz.quux -- 42
print $ (+) a.foo.bar.baz.quux 1 -- 43
print $ (+) (id a).foo.bar.baz.quux 1 -- 43
print $ (+) ((id a).foo.bar & (.baz.quux)) 1 -- 43
-- An "update" is an expression like 'r{ a.b = 12 }'.
putStrLn "-- updates:"
print $ (a.foo.bar.baz) { quux = 2 } -- Quux { quux = 2 }
print $ (\b -> b{ bar=Baz{ baz=Quux{ quux=1 } } }) a.foo -- Bar { bar = Baz { baz = Quux { quux = 1 } } }
let bar = Bar { bar = Baz { baz = Quux { quux = 44 } } }
print $ a{ foo.bar = Baz { baz = Quux { quux = 44 } } } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 44 } } } }
print $ a{ foo.bar.baz = Quux { quux = 45 } } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 45 } } } }
print $ a{ foo.bar.baz.quux = 46 } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 46 } } } }
print $ c{ f.foo.bar.baz.quux = 3, g.foo.bar.baz.quux = 4 } -- Grault { f = Foo { foo = Bar { bar = Baz { baz = Quux { quux = 3 } } } }, g = Foo { foo = Bar { bar = Baz { baz = Quux { quux = 4 } } } } }
-- A "punned update" is an expression like 'r{ a.b }' (where it is
-- understood that 'b' is a variable binding in the environment of
-- the field update - enabled only when the extension
-- 'NamedFieldPuns' is in effect).
putStrLn "-- punned updates:"
let quux = 102; baz = Quux { quux }; bar = Baz { baz }; foo = Bar { bar } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 102 } } } }
print $ a{ foo.bar.baz.quux } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 102 } } } }
print $ a{ foo.bar.baz } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 102 } } } }
print $ a{ foo.bar } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 102 } } } }
print $ a{ foo } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 102 } } } }
print $ a -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 42 } } } }
print $ c{ f.foo, g.foo.bar.baz.quux = 4 } -- Mix punned and explicit; 102, 4
f <- pure a
g <- pure a
print $ c{ f } -- 42, 1
print $ c{ f, g } -- 42, 42
print $ c{ f, g.foo.bar.baz.quux = 4 } -- Mix top-level and nested updates; 42, 4
putStrLn "-- misc:"
-- Higher kinded test.
let p = P { n = Just "me" } :: P Maybe
Just me <- pure p.n
putStrLn $ me
|
