e593abd · project-m36 · git.iko.soy

git.iko.soy/project-m36

Add support for deriving Tupleable instances with custom options.

e593abdSam Bickley6 years ago

docs/tupleable.markdown+19

@@ -23,6 +23,25 @@ instance Tupleable Person

24Now, ```Person``` values can be marshaled between the database and the client. The attribute names appearing in the Haskell data type will appear identically in the server with the same types.

26+### Changing Options

27+

28+If our field names don't exactly match attribute names, but follow a common pattern, we can derive Tupleable with custom options. Let's say each field on person has a prefix "person", but we still want to use the attribute names without the prefix. We can make use of the ProjectM36.Tupleable module to accomplish our goal like so:

29+

30+```haskell

31+import ProjectM36.Tupleable.Deriving

32+

33+data Person = Person {

34+ personName :: Text,

35+ personEmployeeNumber :: Int,

36+ personLikesHorses :: Bool

37+ }

38+ deriving stock Generic

39+ deriving Tupleable

40+ via Codec (Field (DropPrefix "person" >>> CamelCase)) Person

41+```

42+

43+The extensions DerivingGeneric, DerivingVia, TypeOperators, and DataKinds must be enabled for this code to compile. See the documentation on Hackage for all available options.

44+

26## Usage

45## Usage

28The ```Tupleable``` module includes the following functions:

47The ```Tupleable``` module includes the following functions:

examples/DerivingCustomTupleable.hsnew file+52

@@ -0,0 +1,52 @@

1+{-# LANGUAGE DeriveGeneric, DerivingVia, GeneralizedNewtypeDeriving, TypeOperators, DataKinds, OverloadedStrings #-}

3+import ProjectM36.Tupleable.Deriving

4+import ProjectM36.Atomable (Atomable)

5+import Control.DeepSeq (NFData)

6+import Data.Binary (Binary)

7+import Data.Text (Text)

8+import GHC.Generics (Generic)

10+newtype BlogId = BlogId { getBlogId :: Int }

11+ deriving stock (Eq, Ord, Show, Generic)

12+ deriving newtype (Num)

13+

14+instance NFData BlogId

15+instance Binary BlogId

16+instance Atomable BlogId

17+

18+data Blog = Blog

19+ { blogId :: BlogId

20+ , blogTitle :: Text

21+ , blogAuthorName :: Text

22+ }

23+ deriving stock (Show, Generic)

24+ deriving (Tupleable)

25+ via Codec (Field (DropPrefix "blog" >>> CamelCase)) Blog

26+

27+data Comment = Comment

28+ { commentAuthorName :: Text

29+ , commentComment :: Text

30+ , commentFor :: BlogId

31+ }

32+ deriving stock (Show, Generic)

33+ deriving (Tupleable)

34+ via Codec (Field (DropPrefix "comment" >>> CamelCase)) Comment

35+

36+main :: IO ()

37+main = do

38+ let exampleBlog = Blog

39+ { blogId = 0

40+ , blogTitle = "Cat Pics"

41+ , blogAuthorName = "Alice"

42+ }

43+ exampleComment = Comment

44+ { commentAuthorName = "Bob"

45+ , commentComment = "great"

46+ , commentFor = 0

47+ }

48+ print exampleBlog

49+ print (toTuple exampleBlog)

50+ putStrLn ""

51+ print exampleComment

52+ print (toTuple exampleComment)

project-m36.cabal+8−1

@@ -34,7 +34,7 @@ Flag haskell-scripting

34 Default: True

36Library

37− Build-Depends: base>=4.8 && < 4.14, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, binary, filepath, zlib, directory, vector-binary-instances, temporary, stm, time, hashable-time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, network-transport, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, distributed-process-client-server >= 0.2.3, distributed-process >= 0.7.4, distributed-process-extras >= 0.3.2, distributed-process-async >= 0.2.4.1, network-transport-tcp >= 0.6.0, network-transport, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256

37+ Build-Depends: base>=4.8 && < 4.14, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, binary, filepath, zlib, directory, vector-binary-instances, temporary, stm, time, hashable-time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, network-transport, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, distributed-process-client-server >= 0.2.3, distributed-process >= 0.7.4, distributed-process-extras >= 0.3.2, distributed-process-async >= 0.2.4.1, network-transport-tcp >= 0.6.0, network-transport, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256, text-manipulate >= 0.2.0.1 && < 0.3

38 if flag(haskell-scripting)

39 Build-Depends: ghc >= 8.2 && < 8.9

40 CPP-Options: -DPM36_HASKELL_SCRIPTING

@@ -89,6 +89,7 @@ Library

89 ProjectM36.AtomFunctions.Primitive,

90 ProjectM36.Atomable,

91 ProjectM36.Tupleable,

92+ ProjectM36.Tupleable.Deriving,

92 ProjectM36.DataConstructorDef,

93 ProjectM36.DataConstructorDef,

93 ProjectM36.DataTypes.Basic,

94 ProjectM36.DataTypes.Basic,

94 ProjectM36.DataTypes.Sorting,

95 ProjectM36.DataTypes.Sorting,

@@ -410,6 +411,12 @@ Executable Example-CustomTupleable

410 Main-Is: examples/CustomTupleable.hs

411 Main-Is: examples/CustomTupleable.hs

411 GHC-Options: -Wall -threaded

412 GHC-Options: -Wall -threaded

412

413

414+Executable Example-DerivingCustomTupleable

415+ Default-Language: Haskell2010

416+ Build-Depends: base, text, deepseq, binary, project-m36

417+ Main-Is: examples/DerivingCustomTupleable.hs

418+ GHC-Options: -Wall -threaded

419+

413Test-Suite test-scripts

420Test-Suite test-scripts

414 Default-Language: Haskell2010

421 Default-Language: Haskell2010

415 Default-Extensions: OverloadedStrings

422 Default-Extensions: OverloadedStrings

src/lib/ProjectM36/Tupleable.hs+102−26

@@ -6,7 +6,26 @@

6{-# LANGUAGE UndecidableInstances #-}

7{-# LANGUAGE CPP #-}

9−module ProjectM36.Tupleable where

9+module ProjectM36.Tupleable

10+ ( toInsertExpr

11+ , toDefineExpr

12+ , tupleAssocsEqualityPredicate

13+ , partitionByAttributes

14+ , toUpdateExpr

15+ , toDeleteExpr

16+ , validateAttributes

17+ , Tupleable(..)

18+

19+ -- * Generics

20+ , genericToTuple

21+ , genericFromTuple

22+ , genericToAttributes

23+ , TupleableG(..)

24+ -- ** Options

25+ , defaultTupleableOptions

26+ , TupleableOptions()

27+ , fieldModifier

28+ ) where

11import Data.Foldable

30import Data.Foldable

12import Data.List (partition)

31import Data.List (partition)

@@ -121,56 +140,109 @@ validateAttributes actualAttrs expectedAttrs val

121 where

140 where

122 nonMatchingAttrs = attributeNamesNotContained actualAttrs expectedAttrs

141 nonMatchingAttrs = attributeNamesNotContained actualAttrs expectedAttrs

123

142

124−

143+-- | Types that can be converted to and from 'RelationTuple'.

144+--

145+-- deriving without customization:

146+--

147+-- > data Example = Example

148+-- > { foo :: Integer

149+-- > , bar :: Text

150+-- > }

151+-- > deriving (Generic)

152+-- >

153+-- > instance Tupleable Example

154+--

155+-- deriving with customization using "ProjectM36.Tupleable.Deriving":

156+--

157+-- > data Example = Example

158+-- > { exampleFoo :: Integer

159+-- > , exampleBar :: Text

160+-- > }

161+-- > deriving stock (Generic)

162+-- > deriving (Tupleable)

163+-- > via Codec (Field (DropPrefix "example" >>> CamelCase)) Example

125class Tupleable a where

164class Tupleable a where

126 toTuple :: a -> RelationTuple

165 toTuple :: a -> RelationTuple

127

166

128 fromTuple :: RelationTuple -> Either RelationalError a

167 fromTuple :: RelationTuple -> Either RelationalError a

129

168

130− toAttributes :: proxy a -> Attributes

169+ toAttributes :: Proxy a -> Attributes

131

170

132 default toTuple :: (Generic a, TupleableG (Rep a)) => a -> RelationTuple

171 default toTuple :: (Generic a, TupleableG (Rep a)) => a -> RelationTuple

133− toTuple v = toTupleG (from v)

172+ toTuple = genericToTuple defaultTupleableOptions

134

173

135 default fromTuple :: (Generic a, TupleableG (Rep a)) => RelationTuple -> Either RelationalError a

174 default fromTuple :: (Generic a, TupleableG (Rep a)) => RelationTuple -> Either RelationalError a

175+ fromTuple = genericFromTuple defaultTupleableOptions

176+

177+ default toAttributes :: (Generic a, TupleableG (Rep a)) => Proxy a -> Attributes

178+ toAttributes = genericToAttributes defaultTupleableOptions

179+

180+-- | Options that influence deriving behavior.

181+data TupleableOptions = TupleableOptions {

182+ -- | A function that translates record field names into attribute names.

183+ fieldModifier :: T.Text -> T.Text

184+ }

185+

186+-- | The default options for deriving Tupleable instances.

187+--

188+-- These options can be customized by using record update syntax. For example,

189+--

190+-- > defaultTupleableOptions

191+-- > { fieldModifier = \fieldName ->

192+-- > case Data.Text.stripPrefix "example" fieldName of

193+-- > Nothing -> fieldName

194+-- > Just attributeName -> attributeName

195+-- > }

196+--

197+-- will result in record field names being translated into attribute names by

198+-- removing the prefix "example" from the field names.

199+defaultTupleableOptions :: TupleableOptions

200+defaultTupleableOptions = TupleableOptions {

201+ fieldModifier = id

202+ }

203+

204+genericToTuple :: (Generic a, TupleableG (Rep a)) => TupleableOptions -> a -> RelationTuple

205+genericToTuple opts v = toTupleG opts (from v)

206+

207+genericFromTuple :: (Generic a, TupleableG (Rep a)) => TupleableOptions -> RelationTuple -> Either RelationalError a

136− fromTuple tup = to <$> fromTupleG tup

208+genericFromTuple opts tup = to <$> fromTupleG opts tup

137

209

138− default toAttributes :: (Generic a, TupleableG (Rep a)) => proxy a -> Attributes

210+genericToAttributes :: forall a. (Generic a, TupleableG (Rep a)) => TupleableOptions -> Proxy a -> Attributes

139− toAttributes _ = toAttributesG (from (undefined :: a))

211+genericToAttributes opts _ = toAttributesG opts (from (undefined :: a))

140

212

141class TupleableG g where

213class TupleableG g where

142− toTupleG :: g a -> RelationTuple

214+ toTupleG :: TupleableOptions -> g a -> RelationTuple

143− toAttributesG :: g a -> Attributes

215+ toAttributesG :: TupleableOptions -> g a -> Attributes

144− fromTupleG :: RelationTuple -> Either RelationalError (g a)

216+ fromTupleG :: TupleableOptions -> RelationTuple -> Either RelationalError (g a)

145 isRecordTypeG :: g a -> Bool

217 isRecordTypeG :: g a -> Bool

146

218

147--data type metadata

219--data type metadata

148instance (Datatype c, TupleableG a) => TupleableG (M1 D c a) where

220instance (Datatype c, TupleableG a) => TupleableG (M1 D c a) where

149− toTupleG (M1 v) = toTupleG v

221+ toTupleG opts (M1 v) = toTupleG opts v

150− toAttributesG (M1 v) = toAttributesG v

222+ toAttributesG opts (M1 v) = toAttributesG opts v

151− fromTupleG v = M1 <$> fromTupleG v

223+ fromTupleG opts v = M1 <$> fromTupleG opts v

152 isRecordTypeG (M1 v) = isRecordTypeG v

224 isRecordTypeG (M1 v) = isRecordTypeG v

153

225

154--constructor metadata

226--constructor metadata

155instance (Constructor c, TupleableG a, AtomableG a) => TupleableG (M1 C c a) where

227instance (Constructor c, TupleableG a, AtomableG a) => TupleableG (M1 C c a) where

156− toTupleG (M1 v) = RelationTuple attrs atoms

228+ toTupleG opts (M1 v) = RelationTuple attrs atoms

157 where

229 where

158− attrsToCheck = toAttributesG v

230+ attrsToCheck = toAttributesG opts v

159 counter = V.generate (V.length attrsToCheck) id

231 counter = V.generate (V.length attrsToCheck) id

160 attrs = V.zipWith (\num attr@(Attribute name typ) -> if T.null name then

232 attrs = V.zipWith (\num attr@(Attribute name typ) -> if T.null name then

161 Attribute ("attr" <> T.pack (show (num + 1))) typ

233 Attribute ("attr" <> T.pack (show (num + 1))) typ

162 else

234 else

163 attr) counter attrsToCheck

235 attr) counter attrsToCheck

164 atoms = V.fromList (toAtomsG v)

236 atoms = V.fromList (toAtomsG v)

165− toAttributesG (M1 v) = toAttributesG v

237+ toAttributesG opts (M1 v) = toAttributesG opts v

166− fromTupleG tup = M1 <$> fromTupleG tup

238+ fromTupleG opts tup = M1 <$> fromTupleG opts tup

167 isRecordTypeG (M1 v) = isRecordTypeG v

239 isRecordTypeG (M1 v) = isRecordTypeG v

168

240

169-- product types

241-- product types

170instance (TupleableG a, TupleableG b) => TupleableG (a :*: b) where

242instance (TupleableG a, TupleableG b) => TupleableG (a :*: b) where

171 toTupleG = error "toTupleG"

243 toTupleG = error "toTupleG"

172− toAttributesG ~(x :*: y) = toAttributesG x V.++ toAttributesG y --a bit of extra laziness prevents whnf so that we can use toAttributes (undefined :: Test2T Int Int) without throwing an exception

244+ toAttributesG opts ~(x :*: y) = toAttributesG opts x V.++ toAttributesG opts y --a bit of extra laziness prevents whnf so that we can use toAttributes (undefined :: Test2T Int Int) without throwing an exception

173− fromTupleG tup = (:*:) <$> fromTupleG tup <*> fromTupleG processedTuple

245+ fromTupleG opts tup = (:*:) <$> fromTupleG opts tup <*> fromTupleG opts processedTuple

174 where

246 where

175 processedTuple = if isRecordTypeG (undefined :: a x) then

247 processedTuple = if isRecordTypeG (undefined :: a x) then

176 tup

248 tup

@@ -181,18 +253,22 @@ instance (TupleableG a, TupleableG b) => TupleableG (a :*: b) where

181--selector/record

253--selector/record

182instance (Selector c, AtomableG a) => TupleableG (M1 S c a) where

254instance (Selector c, AtomableG a) => TupleableG (M1 S c a) where

183 toTupleG = error "toTupleG"

255 toTupleG = error "toTupleG"

184− toAttributesG m@(M1 v) = V.singleton (Attribute name aType)

256+ toAttributesG opts m@(M1 v) = V.singleton (Attribute modifiedName aType)

185 where

257 where

186 name = T.pack (selName m)

258 name = T.pack (selName m)

259+ modifiedName = if T.null name then

260+ name

261+ else

262+ fieldModifier opts name

187 aType = toAtomTypeG v

263 aType = toAtomTypeG v

188− fromTupleG tup = if null name then -- non-record type, just pull off the first tuple item

264+ fromTupleG opts tup = if null name then -- non-record type, just pull off the first tuple item

189 M1 <$> atomv (V.head (tupleAtoms tup))

265 M1 <$> atomv (V.head (tupleAtoms tup))

190 else do

266 else do

191− atom <- atomForAttributeName (T.pack name) tup

267+ atom <- atomForAttributeName (fieldModifier opts (T.pack name)) tup

192 val <- atomv atom

268 val <- atomv atom

193 pure (M1 val)

269 pure (M1 val)

194 where

270 where

195− expectedAtomType = atomType (V.head (toAttributesG (undefined :: M1 S c a x)))

271+ expectedAtomType = atomType (V.head (toAttributesG opts (undefined :: M1 S c a x)))

196 atomv atom = maybe (Left (AtomTypeMismatchError

272 atomv atom = maybe (Left (AtomTypeMismatchError

197 expectedAtomType

273 expectedAtomType

198 (atomTypeForAtom atom)

274 (atomTypeForAtom atom)

@@ -203,8 +279,8 @@ instance (Selector c, AtomableG a) => TupleableG (M1 S c a) where

203--constructors with no arguments

279--constructors with no arguments

204--basically useless but orthoganal to relationTrue

280--basically useless but orthoganal to relationTrue

205instance TupleableG U1 where

281instance TupleableG U1 where

206− toTupleG _= emptyTuple

282+ toTupleG _ _ = emptyTuple

207− toAttributesG _ = emptyAttributes

283+ toAttributesG _ _ = emptyAttributes

208− fromTupleG _ = pure U1

284+ fromTupleG _ _ = pure U1

209 isRecordTypeG _ = False

285 isRecordTypeG _ = False

210

286

src/lib/ProjectM36/Tupleable/Deriving.hsnew file+228

@@ -0,0 +1,228 @@

1+{-# LANGUAGE ScopedTypeVariables #-}

2+{-# LANGUAGE TypeOperators #-}

3+{-# LANGUAGE KindSignatures #-}

4+{-# LANGUAGE DataKinds #-}

5+{-# LANGUAGE FlexibleContexts #-}

6+{-# LANGUAGE UndecidableInstances #-}

8+-- | Newtypes for deriving Tupleable instances with customization using

9+-- @DerivingVia@.

10+--

11+-- Inspired by

12+-- [Dhall.Deriving](https://hackage.haskell.org/package/dhall-1.33.1/docs/Dhall-Deriving.html)

13+-- which in turn was inspired by Matt Parson's blog post

14+-- [Mirror Mirror: Reflection and Encoding Via](https://www.parsonsmatt.org/2020/02/04/mirror_mirror.html).

15+--

16+-- required extensions:

17+--

18+-- * DerivingVia

19+-- * DeriveGenerics

20+-- * TypeOperators (for @('<<<')@ and @('>>>')@)

21+-- * DataKinds (for types that take a string argument)

22+

23+module ProjectM36.Tupleable.Deriving

24+ ( -- * DerivingVia Newtype

25+ Codec(..)

26+

27+ -- * Type-level Options

28+ , ModifyOptions(..)

29+ , Field

30+

31+ -- * Type-level 'T.Text' -> 'T.Text' Functions

32+ , ModifyText(..)

33+ , AddPrefix

34+ , DropPrefix

35+ , AddSuffix

36+ , DropSuffix

37+ , UpperCase

38+ , LowerCase

39+ , TitleCase

40+ , CamelCase

41+ , PascalCase

42+ , SnakeCase

43+ , SpinalCase

44+ , TrainCase

45+

46+ -- * Composition

47+ , AsIs

48+ , type (<<<)

49+ , type (>>>)

50+

51+ -- * Re-Exports

52+ , Generic

53+ , module ProjectM36.Tupleable

54+ ) where

55+

56+import Data.Proxy

57+import qualified Data.Text as T

58+import Data.Text.Manipulate

59+import GHC.TypeLits

60+import GHC.Generics (Generic, Rep)

61+import ProjectM36.Tupleable

62+

63+-- | A newtype wrapper to allow for easier deriving of 'Tupleable' instances

64+-- with customization.

65+--

66+-- The @tag@ type variable can be used to specify options for converting the

67+-- datatype to and from a 'RelationTuple'. For example,

68+--

69+-- > data Example = Example

70+-- > { exampleFoo :: Int

71+-- > , exampleBar :: Int

72+-- > }

73+-- > deriving stock (Generic)

74+-- > deriving (Tupleable)

75+-- > via Codec (Field (DropPrefix "example" >>> CamelCase)) Example

76+--

77+-- will derive an instance of 'Tupleable' where field names are translated into

78+-- attribute names by dropping the prefix @"example"@ and then converting the

79+-- result to camelCase. So @"exampleFoo"@ becomes @"foo"@ and @"exampleBar"@

80+-- becomes @"bar"@.

81+--

82+-- Requires the @DerivingGeneric@ and @DerivingVia@ extensions to be enabled.

83+newtype Codec tag a = Codec { unCodec :: a }

84+

85+instance (ModifyOptions tag, Generic a, TupleableG (Rep a)) => Tupleable (Codec tag a) where

86+ toTuple v = genericToTuple opts (unCodec v)

87+ where

88+ opts = modifyOptions (Proxy :: Proxy tag) defaultTupleableOptions

89+

90+ fromTuple tup = Codec <$> genericFromTuple opts tup

91+ where

92+ opts = modifyOptions (Proxy :: Proxy tag) defaultTupleableOptions

93+

94+ toAttributes _ = genericToAttributes opts (Proxy :: Proxy a)

95+ where

96+ opts = modifyOptions (Proxy :: Proxy tag) defaultTupleableOptions

97+

98+-- | Types that can be used as tags for 'Codec'.

99+class ModifyOptions a where

100+ modifyOptions :: proxy a -> TupleableOptions -> TupleableOptions

101+

102+-- | Change how record field names are translated into attribute names. For

103+-- example,

104+--

105+-- > Field SnakeCase

106+--

107+-- will translate the field name @fooBar@ into the attribute name @foo_bar@.

108+data Field a

109+

110+instance ModifyText a => ModifyOptions (Field a) where

111+ modifyOptions _ opts = opts { fieldModifier = newFieldModifier }

112+ where

113+ newFieldModifier = modifyText (Proxy :: Proxy a) . fieldModifier opts

114+

115+-- | Types that can be used in options that modify 'T.Text' such as in 'Field'.

116+class ModifyText a where

117+ modifyText :: proxy a -> T.Text -> T.Text

118+

119+-- | Add a prefix. @AddPrefix "foo"@ will transform @"bar"@ into @"foobar"@.

120+data AddPrefix (prefix :: Symbol)

121+

122+instance KnownSymbol prefix => ModifyText (AddPrefix prefix) where

123+ modifyText _ oldText = prefixText <> oldText

124+ where

125+ prefixText = T.pack (symbolVal (Proxy :: Proxy prefix))

126+

127+-- | Drop a prefix. @DropPrefix "bar"@ will transform @"foobar"@ into @"foo"@.

128+data DropPrefix (prefix :: Symbol)

129+

130+instance KnownSymbol prefix => ModifyText (DropPrefix prefix) where

131+ modifyText _ oldText = maybe oldText id (T.stripPrefix prefixText oldText)

132+ where

133+ prefixText = T.pack (symbolVal (Proxy :: Proxy prefix))

134+

135+-- | Add a suffix. @AddSuffix "bar"@ will transform @"foo"@ into @"foobar"@.

136+data AddSuffix (suffix :: Symbol)

137+

138+instance KnownSymbol suffix => ModifyText (AddSuffix suffix) where

139+ modifyText _ oldText = oldText <> suffixText

140+ where

141+ suffixText = T.pack (symbolVal (Proxy :: Proxy suffix))

142+

143+-- | Drop a suffix. @DropSuffix "bar"@ will transform @"foobar"@ into @"foo"@.

144+data DropSuffix (suffix :: Symbol)

145+

146+instance KnownSymbol suffix => ModifyText (DropSuffix suffix) where

147+ modifyText _ oldText = maybe oldText id (T.stripSuffix suffixText oldText)

148+ where

149+ suffixText = T.pack (symbolVal (Proxy :: Proxy suffix))

150+

151+-- | Convert to UPPERCASE. Will transform @"foobar"@ into @\"FOOBAR\"@.

152+data UpperCase

153+

154+instance ModifyText UpperCase where

155+ modifyText _ = T.toUpper

156+

157+-- | Convert to lowercase. Will transform @\"FOOBAR\"@ into @"foobar"@.

158+data LowerCase

159+

160+instance ModifyText LowerCase where

161+ modifyText _ = T.toLower

162+

163+-- | Convert to Title Case. Will transform @"fooBar"@ into @\"Foo Bar\"@.

164+data TitleCase

165+

166+instance ModifyText TitleCase where

167+ modifyText _ = toTitle

168+

169+-- | Convert to camelCase. Will transform @"foo_bar"@ into @"fooBar"@.

170+data CamelCase

171+

172+instance ModifyText CamelCase where

173+ modifyText _ = toCamel

174+

175+-- | Convert to PascalCase. Will transform @"foo_bar"@ into @\"FooBar\"@.

176+data PascalCase

177+

178+instance ModifyText PascalCase where

179+ modifyText _ = toPascal

180+

181+-- | Convert to snake_case. Will transform @"fooBar"@ into @"foo_bar"@.

182+data SnakeCase

183+

184+instance ModifyText SnakeCase where

185+ modifyText _ = toSnake

186+

187+-- | Convert to spinal-case. will transform @"fooBar"@ into @"foo-bar"@.

188+data SpinalCase

189+

190+instance ModifyText SpinalCase where

191+ modifyText _ = toSpinal

192+

193+-- | Convert to Train-Case. Will transform @"fooBar"@ into @\"Foo-Bar\"@.

194+data TrainCase

195+

196+instance ModifyText TrainCase where

197+ modifyText _ = toTrain

198+

199+-- | Identity option.

200+type AsIs = ()

201+

202+instance ModifyOptions () where

203+ modifyOptions _ = id

204+

205+instance ModifyText () where

206+ modifyText _ = id

207+

208+-- | Right to left composition.

209+--

210+-- Requires the @TypeOperators@ extension to be enabled.

211+data a <<< b

212+

213+instance (ModifyOptions a, ModifyOptions b) => ModifyOptions (a <<< b) where

214+ modifyOptions _ = modifyOptions (Proxy :: Proxy a) . modifyOptions (Proxy :: Proxy b)

215+

216+instance (ModifyText a, ModifyText b) => ModifyText (a <<< b) where

217+ modifyText _ = modifyText (Proxy :: Proxy a) . modifyText (Proxy :: Proxy b)

218+

219+-- | Left to right composition.

220+--

221+-- Requires the @TypeOperators@ extension to be enabled.

222+data a >>> b

223+

224+instance (ModifyOptions a, ModifyOptions b) => ModifyOptions (a >>> b) where

225+ modifyOptions _ = modifyOptions (Proxy :: Proxy b) . modifyOptions (Proxy :: Proxy a)

226+

227+instance (ModifyText a, ModifyText b) => ModifyText (a >>> b) where

228+ modifyText _ = modifyText (Proxy :: Proxy b) . modifyText (Proxy :: Proxy a)

test/Relation/Tupleable.hs+170−3

@@ -1,6 +1,16 @@

1+{-# LANGUAGE

2+ DeriveGeneric

1−{-# LANGUAGE DeriveGeneric, FlexibleInstances, FlexibleContexts, DeriveAnyClass #-}

3+ , FlexibleInstances

4+ , FlexibleContexts

5+ , DeriveAnyClass

6+ , ScopedTypeVariables

7+ , TypeApplications

8+ , DataKinds

9+ , TypeOperators

10+ , AllowAmbiguousTypes

11+ #-}

2import Test.HUnit

12import Test.HUnit

3−import ProjectM36.Tupleable

13+import ProjectM36.Tupleable.Deriving

4import ProjectM36.Atomable

14import ProjectM36.Atomable

5import ProjectM36.Attribute

15import ProjectM36.Attribute

6import ProjectM36.Error

16import ProjectM36.Error

@@ -58,6 +68,13 @@ data Test9T = Test9C

58 attr9C :: Double

68 attr9C :: Double

59 }

69 }

60 deriving (Generic, Show, Eq)

70 deriving (Generic, Show, Eq)

71+

72+data Test10T = Test10C {

73+ longAttrNameA10 :: Integer,

74+ long_attr_name_b10 :: Integer,

75+ longMixed_attr_NameC10 :: Integer

76+ }

77+ deriving (Generic, Show, Eq)

62instance Tupleable Test1T

79instance Tupleable Test1T

@@ -83,7 +100,7 @@ main = do

83 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

100 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

101

85testList :: Test

102testList :: Test

86−testList = TestList [testADT1, testADT2, testADT3, testADT4, testADT6, testADT7, testADT8, testInsertExpr, testDefineExpr, testUpdateExpr, testUpdateExprEmptyAttrs, testDeleteExpr, testUpdateExprWrongAttr, testReorderedTuple]

103+testList = TestList [testADT1, testADT2, testADT3, testADT4, testADT6, testADT7, testADT8, testInsertExpr, testDefineExpr, testUpdateExpr, testUpdateExprEmptyAttrs, testDeleteExpr, testUpdateExprWrongAttr, testReorderedTuple, testAddPrefixField, testDropPrefixField, testAddSuffixField, testDropSuffixField, testUpperCaseField, testLowerCaseField, testTitleCaseField, testCamelCaseField, testPascalCaseField, testSnakeCaseField, testSpinalCaseField, testTrainCaseField, testAsIsCodec, testAsIsField, testComposeRLCodec, testComposeRLField, testComposeLRCodec, testComposeLRField]

104

88testADT1 :: Test

105testADT1 :: Test

89testADT1 = TestCase $ assertEqual "one record constructor" (Right example) (fromTuple (toTuple example))

106testADT1 = TestCase $ assertEqual "one record constructor" (Right example) (fromTuple (toTuple example))

@@ -200,3 +217,153 @@ testReorderedTuple = TestCase $ do

200 attrC = 4}

217 attrC = 4}

201 actual = fromTuple . tupleRev . toTuple $ expected

218 actual = fromTuple . tupleRev . toTuple $ expected

202 assertEqual "reordered tuple" (Right expected) actual

219 assertEqual "reordered tuple" (Right expected) actual

220+

221+testCodec :: forall tag. ModifyOptions tag => String -> [AttributeName] -> Test

222+testCodec msg expected = TestCase $

223+ assertEqual msg (S.fromList expected) actual

224+ where

225+ actual = attributeNameSet $ toAttributes (Proxy :: Proxy (Codec tag Test10T))

226+

227+testAddPrefixField :: Test

228+testAddPrefixField = testCodec

229+ @(Field (AddPrefix "prefix_"))

230+ "codec field add prefix attributes"

231+ ["prefix_longAttrNameA10",

232+ "prefix_long_attr_name_b10",

233+ "prefix_longMixed_attr_NameC10"]

234+

235+testDropPrefixField :: Test

236+testDropPrefixField = testCodec

237+ @(Field (DropPrefix "long"))

238+ "codec field drop prefix"

239+ ["AttrNameA10",

240+ "_attr_name_b10",

241+ "Mixed_attr_NameC10"]

242+

243+testAddSuffixField :: Test

244+testAddSuffixField = testCodec

245+ @(Field (AddSuffix "_suffix"))

246+ "codec field add suffix"

247+ ["longAttrNameA10_suffix",

248+ "long_attr_name_b10_suffix",

249+ "longMixed_attr_NameC10_suffix"]

250+

251+testDropSuffixField :: Test

252+testDropSuffixField = testCodec

253+ @(Field (DropSuffix "10"))

254+ "codec field drop suffix"

255+ ["longAttrNameA",

256+ "long_attr_name_b",

257+ "longMixed_attr_NameC"]

258+

259+testUpperCaseField :: Test

260+testUpperCaseField = testCodec

261+ @(Field UpperCase)

262+ "codec field uppercase"

263+ ["LONGATTRNAMEA10",

264+ "LONG_ATTR_NAME_B10",

265+ "LONGMIXED_ATTR_NAMEC10"]

266+

267+testLowerCaseField :: Test

268+testLowerCaseField = testCodec

269+ @(Field LowerCase)

270+ "codec field lowercase"

271+ ["longattrnamea10",

272+ "long_attr_name_b10",

273+ "longmixed_attr_namec10"]

274+

275+testTitleCaseField :: Test

276+testTitleCaseField = testCodec

277+ @(Field TitleCase)

278+ "codec field title case"

279+ ["Long Attr Name A10",

280+ "Long Attr Name B10",

281+ "Long Mixed Attr Name C10"]

282+

283+testCamelCaseField :: Test

284+testCamelCaseField = testCodec

285+ @(Field CamelCase)

286+ "codec field camel case"

287+ ["longAttrNameA10",

288+ "longAttrNameB10",

289+ "longMixedAttrNameC10"]

290+

291+testPascalCaseField :: Test

292+testPascalCaseField = testCodec

293+ @(Field PascalCase)

294+ "codec field pascal case"

295+ ["LongAttrNameA10",

296+ "LongAttrNameB10",

297+ "LongMixedAttrNameC10"]

298+

299+testSnakeCaseField :: Test

300+testSnakeCaseField = testCodec

301+ @(Field SnakeCase)

302+ "codec field snake case"

303+ ["long_attr_name_a10",

304+ "long_attr_name_b10",

305+ "long_mixed_attr_name_c10"]

306+

307+testSpinalCaseField :: Test

308+testSpinalCaseField = testCodec

309+ @(Field SpinalCase)

310+ "codec field spinal case"

311+ ["long-attr-name-a10",

312+ "long-attr-name-b10",

313+ "long-mixed-attr-name-c10"]

314+

315+testTrainCaseField :: Test

316+testTrainCaseField = testCodec

317+ @(Field TrainCase)

318+ "codec field train case"

319+ ["Long-Attr-Name-A10",

320+ "Long-Attr-Name-B10",

321+ "Long-Mixed-Attr-Name-C10"]

322+

323+testAsIsCodec :: Test

324+testAsIsCodec = testCodec

325+ @AsIs

326+ "codec as is"

327+ ["longAttrNameA10",

328+ "long_attr_name_b10",

329+ "longMixed_attr_NameC10"]

330+

331+testAsIsField :: Test

332+testAsIsField = testCodec

333+ @(Field AsIs)

334+ "codec field as is"

335+ ["longAttrNameA10",

336+ "long_attr_name_b10",

337+ "longMixed_attr_NameC10"]

338+

339+testComposeRLCodec :: Test

340+testComposeRLCodec = testCodec

341+ @(Field UpperCase <<< Field (DropPrefix "long"))

342+ "codec (<<<)"

343+ ["ATTRNAMEA10",

344+ "_ATTR_NAME_B10",

345+ "MIXED_ATTR_NAMEC10"]

346+

347+testComposeRLField :: Test

348+testComposeRLField = testCodec

349+ @(Field (UpperCase <<< DropPrefix "long"))

350+ "codec field (<<<)"

351+ ["ATTRNAMEA10",

352+ "_ATTR_NAME_B10",

353+ "MIXED_ATTR_NAMEC10"]

354+

355+testComposeLRCodec :: Test

356+testComposeLRCodec = testCodec

357+ @(Field (DropPrefix "long") >>> Field UpperCase)

358+ "codec (>>>)"

359+ ["ATTRNAMEA10",

360+ "_ATTR_NAME_B10",

361+ "MIXED_ATTR_NAMEC10"]

362+

363+testComposeLRField :: Test

364+testComposeLRField = testCodec

365+ @(Field (DropPrefix "long" >>> UpperCase))

366+ "codec field (>>>)"

367+ ["ATTRNAMEA10",

368+ "_ATTR_NAME_B10",

369+ "MIXED_ATTR_NAMEC10"]