e593abd · project-m36 · git.iko.soy

git.iko.soy/project-m36

Add support for deriving Tupleable instances with custom options.

commite593abd2f8b9ec9fb1480e10b7ee944915152eaa authorSam Bickley <samb96@gmail.com> dateSat 4 Jul 2020, 15:39 (6 years ago) parentf65d06a

6 files changed+579−30

compare with master

unifiedsplit

docs/tupleable.markdown+19 examples/DerivingCustomTupleable.hs+52 project-m36.cabal+8−1 src/lib/ProjectM36/Tupleable.hs+102−26 src/lib/ProjectM36/Tupleable/Deriving.hs+228 test/Relation/Tupleable.hs+170−3

docs/tupleable.markdown+19

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

2323

2424Now, ```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.

2525

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+

2645## Usage

2746

2847The ```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

3434 Default: True

3535

3636Library

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

3838 if flag(haskell-scripting)

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

4040 CPP-Options: -DPM36_HASKELL_SCRIPTING

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

8989 ProjectM36.AtomFunctions.Primitive,

9090 ProjectM36.Atomable,

9191 ProjectM36.Tupleable,

92+ ProjectM36.Tupleable.Deriving,

9293 ProjectM36.DataConstructorDef,

9394 ProjectM36.DataTypes.Basic,

9495 ProjectM36.DataTypes.Sorting,

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

410411 Main-Is: examples/CustomTupleable.hs

411412 GHC-Options: -Wall -threaded

412413

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+

413420Test-Suite test-scripts

414421 Default-Language: Haskell2010

415422 Default-Extensions: OverloadedStrings

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

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

66{-# LANGUAGE UndecidableInstances #-}

77{-# 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

1029

1130import Data.Foldable

1231import Data.List (partition)

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

121140 where

122141 nonMatchingAttrs = attributeNamesNotContained actualAttrs expectedAttrs

123142

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

125164class Tupleable a where

126165 toTuple :: a -> RelationTuple

127166

128167 fromTuple :: RelationTuple -> Either RelationalError a

129168

130− toAttributes :: proxy a -> Attributes

169+ toAttributes :: Proxy a -> Attributes

131170

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

133− toTuple v = toTupleG (from v)

172+ toTuple = genericToTuple defaultTupleableOptions

134173

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

136− fromTuple tup = to <$> fromTupleG tup

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

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

137209

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

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

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

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

140212

141213class TupleableG g where

142− toTupleG :: g a -> RelationTuple

143− toAttributesG :: g a -> Attributes

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

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

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

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

145217 isRecordTypeG :: g a -> Bool

146218

147219--data type metadata

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

149− toTupleG (M1 v) = toTupleG v

150− toAttributesG (M1 v) = toAttributesG v

151− fromTupleG v = M1 <$> fromTupleG v

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

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

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

152224 isRecordTypeG (M1 v) = isRecordTypeG v

153225

154226--constructor metadata

155227instance (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

157229 where

158− attrsToCheck = toAttributesG v

230+ attrsToCheck = toAttributesG opts v

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

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

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

162234 else

163235 attr) counter attrsToCheck

164236 atoms = V.fromList (toAtomsG v)

165− toAttributesG (M1 v) = toAttributesG v

166− fromTupleG tup = M1 <$> fromTupleG tup

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

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

167239 isRecordTypeG (M1 v) = isRecordTypeG v

168240

169241-- product types

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

171243 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

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

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

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

174246 where

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

176248 tup

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

181253--selector/record

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

183255 toTupleG = error "toTupleG"

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

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

185257 where

186258 name = T.pack (selName m)

259+ modifiedName = if T.null name then

260+ name

261+ else

262+ fieldModifier opts name

187263 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

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

190266 else do

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

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

192268 val <- atomv atom

193269 pure (M1 val)

194270 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)))

196272 atomv atom = maybe (Left (AtomTypeMismatchError

197273 expectedAtomType

198274 (atomTypeForAtom atom)

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

203279--constructors with no arguments

204280--basically useless but orthoganal to relationTrue

205281instance TupleableG U1 where

206− toTupleG _= emptyTuple

207− toAttributesG _ = emptyAttributes

208− fromTupleG _ = pure U1

282+ toTupleG _ _ = emptyTuple

283+ toAttributesG _ _ = emptyAttributes

284+ fromTupleG _ _ = pure U1

209285 isRecordTypeG _ = False

210286

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 DeriveGeneric, FlexibleInstances, FlexibleContexts, DeriveAnyClass #-}

1+{-# LANGUAGE

2+ DeriveGeneric

3+ , FlexibleInstances

4+ , FlexibleContexts

5+ , DeriveAnyClass

6+ , ScopedTypeVariables

7+ , TypeApplications

8+ , DataKinds

9+ , TypeOperators

10+ , AllowAmbiguousTypes

11+ #-}

212import Test.HUnit

3−import ProjectM36.Tupleable

13+import ProjectM36.Tupleable.Deriving

414import ProjectM36.Atomable

515import ProjectM36.Attribute

616import ProjectM36.Error

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

5868 attr9C :: Double

5969 }

6070 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)

6178

6279instance Tupleable Test1T

6380

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

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

84101

85102testList :: 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]

87104

88105testADT1 :: Test

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

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

200217 attrC = 4}

201218 actual = fromTuple . tupleRev . toTuple $ expected

202219 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"]