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
142
143
144
145
146
147
148
|
{-# LANGUAGE
DataKinds,
DeriveGeneric,
FlexibleInstances,
LambdaCase,
MultiParamTypeClasses,
ScopedTypeVariables,
TypeApplications,
TypeFamilies,
TypeOperators #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
-- Example using one-liner and generic-lens
-- on a synthetic type obtained by surgery.
import Control.Applicative ((<|>))
import Data.Coerce (coerce)
import Data.Functor.Identity (Identity(..))
import Data.Kind (Type)
import GHC.Generics (Generic)
import Text.Read (readMaybe)
import Test.Tasty
import Test.Tasty.HUnit
import Data.Generics.Product (field_) -- generic-lens
import Generics.OneLiner (nullaryOp, binaryOp) -- one-liner
import Generics.OneLiner.Binary (gtraverse)
import Generic.Data.Microsurgery (DOnFields)
-- | Toy configuration record type.
data Config = C {
a :: Int,
b :: Int,
c :: String
} deriving (Eq, Generic, Show)
-- | Applying the 'DOnFields' surgery to get a type isomorphic to:
--
-- > data Config = C {
-- > a :: Maybe Int,
-- > b :: Maybe Int,
-- > c :: Maybe String
-- > }
--
-- See also "Functor functors" and "Higher-kinded data" for a more general pattern:
--
-- - https://www.benjamin.pizza/posts/2017-12-15-functor-functors.html
-- - https://reasonablypolymorphic.com/blog/higher-kinded-data/
--
type PartialConfig = DOnFields Maybe Config
-- | Example
file1 :: [String]
file1 = [
"a=11",
"b=33"
]
-- | Example
file2 :: [String]
file2 = [
"b=2",
"c=Hello"
]
-- | Helper for 'emptyOM' and 'mergeOM' below.
class (a ~ Maybe (UnMaybe a)) => IsMaybe a
instance (a ~ Maybe (UnMaybe a)) => IsMaybe a
-- | Helper for 'IsMaybe' above.
type family UnMaybe (a :: Type) :: Type where
UnMaybe (Maybe b) = b
-- |
-- > emptyOM = C {
-- > a = Nothing,
-- > b = Nothing,
-- > c = Nothing
-- > }
emptyOM :: PartialConfig
emptyOM = nullaryOp @IsMaybe Nothing
-- | Helper for 'parseOM' (actually a function from lens).
--
-- @(l .~ b) s@: set the field of record @s@ focused by lens @l@ to @b@.
--
-- > let f = (field_ @"a" .~ v) in
-- > f (C {a = x, b = y, c = z})
-- >
-- > -- equals --
-- >
-- > C {a = v, b = y, c = z}
--
(.~) :: forall s t a b. ((a -> Identity b) -> s -> Identity t) -> b -> s -> t
(.~) l b = coerce l (const b :: a -> b)
-- | Parse lines of a config file.
parseOM :: [String] -> PartialConfig
parseOM = foldr ($) emptyOM . map (\case
'a' : '=' : n -> field_ @"a" .~ readMaybe n
'b' : '=' : n -> field_ @"b" .~ readMaybe n
'c' : '=' : s -> field_ @"c" .~ Just s
_ -> id)
-- | Merge two records of 'Maybe' fields, keeping the leftmost 'Just' for each
-- field.
mergeOM :: PartialConfig -> PartialConfig -> PartialConfig
mergeOM = binaryOp @IsMaybe (<|>)
-- | Example
parsedOpts12 :: PartialConfig
parsedOpts12 = parseOM file1 `mergeOM` parseOM file2
-- | Helper for 'validateOM' below.
class (a ~ Maybe b) => FstIsMaybe a b
instance (a ~ Maybe b) => FstIsMaybe a b
-- | Check that all fields are populated with 'Just' and create a plain
-- 'Config' record. If any field is 'Nothing', returns 'Nothing'.
validateOM :: PartialConfig -> Maybe Config
validateOM = gtraverse @FstIsMaybe id
-- | Example
opts12 :: Maybe Config
opts12 = validateOM parsedOpts12
main :: IO ()
main = defaultMain test
test :: TestTree
test = testGroup "one-liner-surgery"
[ testCase "opts1" $
"C {a = Just 11, b = Just 33, c = Nothing}" @=? show (parseOM file1)
, testCase "opts2" $
"C {a = Nothing, b = Just 2, c = Just \"Hello\"}" @=? show (parseOM file2)
, testCase "opts12" $
Just C {a = 11, b = 33, c = "Hello"} @=? opts12
, testCase "opts1-incomplete" $
Nothing @=? validateOM (parseOM file1)
, testCase "empty" $
"C {a = Nothing, b = Nothing, c = Nothing}" @=? show emptyOM
]
|
