851dc76 · project-m36 · git.iko.soy

git.iko.soy/project-m36

Merge branch 'master' into dockerci

commit851dc7623edb5ea07efd0b3c15d5fc9d47db6e97 authorAgentM <agentm@themactionfaction.com> dateWed 5 Aug 2020, 20:39 (6 years ago) parentbaa4728 b6e6cda

7 files changed+587−31

compare with master

unifiedsplit

docs/tupleable.markdown+19 examples/DerivingCustomTupleable.hs+52 project-m36.cabal+12−1 src/lib/ProjectM36/Tupleable.hs+102−26 src/lib/ProjectM36/Tupleable/Deriving.hs+229 stack.ghc8.8.yaml+3−1 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+12−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,16 @@ Executable Example-CustomTupleable

410411 Main-Is: examples/CustomTupleable.hs

411412 GHC-Options: -Wall -threaded

412413

414+Executable Example-DerivingCustomTupleable

415+ if impl(ghc>=8.6)

416+ Buildable: True

417+ else

418+ Buildable: False

419+ Default-Language: Haskell2010

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

421+ Main-Is: examples/DerivingCustomTupleable.hs

422+ GHC-Options: -Wall -threaded

423+

413424Test-Suite test-scripts

414425 Default-Language: Haskell2010

415426 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+newtype 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+229

@@ -0,0 +1,229 @@

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+import Data.Maybe (fromMaybe)

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+

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

65+-- with customization.

66+--

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

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

69+--

70+-- > data Example = Example

71+-- > { exampleFoo :: Int

72+-- > , exampleBar :: Int

73+-- > }

74+-- > deriving stock (Generic)

75+-- > deriving (Tupleable)

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

77+--

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

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

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

81+-- becomes @"bar"@.

82+--

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

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

85+

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

87+ toTuple v = genericToTuple opts (unCodec v)

88+ where

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

90+

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

92+ where

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

94+

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

96+ where

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

98+

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

100+class ModifyOptions a where

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

102+

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

104+-- example,

105+--

106+-- > Field SnakeCase

107+--

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

109+data Field a

110+

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

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

113+ where

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

115+

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

117+class ModifyText a where

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

119+

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

121+data AddPrefix (prefix :: Symbol)

122+

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

124+ modifyText _ oldText = prefixText <> oldText

125+ where

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

127+

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

129+data DropPrefix (prefix :: Symbol)

130+

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

132+ modifyText _ oldText = fromMaybe oldText (T.stripPrefix prefixText oldText)

133+ where

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

135+

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

137+data AddSuffix (suffix :: Symbol)

138+

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

140+ modifyText _ oldText = oldText <> suffixText

141+ where

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

143+

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

145+data DropSuffix (suffix :: Symbol)

146+

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

148+ modifyText _ oldText = fromMaybe oldText (T.stripSuffix suffixText oldText)

149+ where

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

151+

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

153+data UpperCase

154+

155+instance ModifyText UpperCase where

156+ modifyText _ = T.toUpper

157+

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

159+data LowerCase

160+

161+instance ModifyText LowerCase where

162+ modifyText _ = T.toLower

163+

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

165+data TitleCase

166+

167+instance ModifyText TitleCase where

168+ modifyText _ = toTitle

169+

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

171+data CamelCase

172+

173+instance ModifyText CamelCase where

174+ modifyText _ = toCamel

175+

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

177+data PascalCase

178+

179+instance ModifyText PascalCase where

180+ modifyText _ = toPascal

181+

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

183+data SnakeCase

184+

185+instance ModifyText SnakeCase where

186+ modifyText _ = toSnake

187+

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

189+data SpinalCase

190+

191+instance ModifyText SpinalCase where

192+ modifyText _ = toSpinal

193+

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

195+data TrainCase

196+

197+instance ModifyText TrainCase where

198+ modifyText _ = toTrain

199+

200+-- | Identity option.

201+type AsIs = ()

202+

203+instance ModifyOptions () where

204+ modifyOptions _ = id

205+

206+instance ModifyText () where

207+ modifyText _ = id

208+

209+-- | Right to left composition.

210+--

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

212+data a <<< b

213+

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

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

216+

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

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

219+

220+-- | Left to right composition.

221+--

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

223+data a >>> b

224+

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

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

227+

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

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

stack.ghc8.8.yaml+3−1

@@ -2,7 +2,7 @@

22# For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration/

44# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)

5−resolver: lts-15.11

5+resolver: lts-16.4

77# Local packages, usually specified by relative directory name

88packages:

@@ -24,6 +24,8 @@ extra-deps:

2424- network-transport-tcp-0.7.0

2525- megaparsec-7.0.5

2626- network-2.8.0.1

27+- primitive-extras-0.8

28+- primitive-unlifted-0.1.3.0

2729

2830# Override default flag values for local packages and extra-deps

2931flags:

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