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
|
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module T22122_aux where
import Language.Haskell.TH.Syntax
( Name, Type(ConT), Lit(CharL, StringL)
, Dec(DataD, FunD), Con(RecC), Exp(LitE, VarE, RecUpdE), Pat(VarP)
, Clause(Clause), Body(NormalB)
, Bang(..), SourceUnpackedness(..), SourceStrictness(..)
, newNameIO )
import System.IO.Unsafe
( unsafePerformIO )
data Names a
= Names { d1_name, d2_name
, mkd1_name, mkd2a_name, mkd2b_name
, d1_fld1_name, d1_fld2_name, d2_fld1_name, d2_fld2_name
, upd_name, upd_var_name :: a }
deriving stock ( Functor, Foldable, Traversable )
string_names :: Names String
string_names =
Names
{ d1_name = "D1"
, d2_name = "D2"
, mkd1_name = "MkD1"
, mkd2a_name = "MkD2A"
, mkd2b_name = "MkD2B"
, d1_fld1_name = "fld" -- these are deliberately the same,
, d1_fld2_name = "fld" -- to check that we correctly use the exact Names
, d2_fld1_name = "fld" -- in a record update, and not simply the
, d2_fld2_name = "fld" -- field label strings
, upd_name = "upd"
, upd_var_name = "r"
}
names :: Names Name
names = unsafePerformIO $ traverse newNameIO string_names
noBang :: Bang
noBang = Bang NoSourceUnpackedness NoSourceStrictness
-- data D1 = MkD1 { fld1 :: Char, fld2 :: String }
-- data D2 = MkD2A { fld1 :: Char } | MkD2B { fld2 :: String }
data_decls :: [ Dec ]
data_decls = [ d1, d2 ]
where
Names { .. } = names
d1 = DataD [] d1_name [] Nothing [mkd1] []
d2 = DataD [] d2_name [] Nothing [mkd2_a, mkd2_b] []
mkd1 = RecC mkd1_name [(d1_fld1_name, noBang, ConT ''Char), (d1_fld2_name, noBang, ConT ''String)]
mkd2_a = RecC mkd2a_name [(d2_fld1_name, noBang, ConT ''Char)]
mkd2_b = RecC mkd2b_name [(d2_fld2_name, noBang, ConT ''String)]
-- upd r = r { fld1 = 'c', fld2 = "foo" }
record_upds :: [ Dec ]
record_upds = [ rec_upd ]
where
Names { .. } = names
rec_upd = FunD upd_name [upd_clause]
upd_clause = Clause [VarP upd_var_name] (NormalB rec_upd_body) []
rec_upd_body = RecUpdE (VarE upd_var_name)
[ (d1_fld1_name, LitE (CharL 'c'))
, (d1_fld2_name, LitE (StringL "foo")) ]
|
