Merge pull request #26 from haskell-works/newhoggy/simplify-code

Simplify code with record dot syntax
haskell-works · Nov 9, 2024 · 6b22ac9 · 6b22ac9
2 parents 0a9486b + c643968
commit 6b22ac9
Show file tree

Hide file tree

Showing 9 changed files with 106 additions and 79 deletions.
diff --git a/cabal.project b/cabal.project
@@ -8,3 +8,6 @@ package amazonka-sso
 
 package amazonka-sts
   ghc-options: -XDuplicateRecordFields
+
+constraints:
+  text < 2.1.2
diff --git a/rds-data.cabal b/rds-data.cabal
@@ -1,7 +1,7 @@
 cabal-version: 3.6
 
 name:                   rds-data
-version:                0.1.0.0
+version:                0.1.1.0
 synopsis:               Codecs for use with AWS rds-data
 description:            Codecs for use with AWS rds-data.
 category:               Data
@@ -39,11 +39,11 @@ common generic-lens                             { build-depends: generic-lens
 common hedgehog                                 { build-depends: hedgehog                                 >= 1.4        && < 2      }
 common hedgehog-extras                          { build-depends: hedgehog-extras                          >= 0.6.0.2    && < 0.7    }
 common http-client                              { build-depends: http-client                              >= 0.5.14     && < 0.8    }
-common hw-polysemy-amazonka                     { build-depends: hw-polysemy:amazonka                     >= 0.3        && < 0.4    }
-common hw-polysemy-core                         { build-depends: hw-polysemy:core                         >= 0.3        && < 0.4    }
-common hw-polysemy-hedgehog                     { build-depends: hw-polysemy:hedgehog                     >= 0.3        && < 0.4    }
-common hw-polysemy-testcontainers-localstack    { build-depends: hw-polysemy:testcontainers-localstack    >= 0.3        && < 0.4    }
-common hw-prelude                               { build-depends: hw-prelude                               >= 0.0.0.1    && < 0.1    }
+common hw-polysemy-amazonka                     { build-depends: hw-polysemy:amazonka                     >= 0.3.1      && < 0.4    }
+common hw-polysemy-core                         { build-depends: hw-polysemy:core                         >= 0.3.1      && < 0.4    }
+common hw-polysemy-hedgehog                     { build-depends: hw-polysemy:hedgehog                     >= 0.3.1      && < 0.4    }
+common hw-polysemy-testcontainers-localstack    { build-depends: hw-polysemy:testcontainers-localstack    >= 0.3.1      && < 0.4    }
+common hw-prelude                               { build-depends: hw-prelude                               >= 0.0.1.0    && < 0.1    }
 common microlens                                { build-depends: microlens                                >= 0.4.13     && < 0.5    }
 common mtl                                      { build-depends: mtl                                      >= 2          && < 3      }
 common optparse-applicative                     { build-depends: optparse-applicative                     >= 0.18.1.0   && < 0.19   }
@@ -70,7 +70,21 @@ common rds-data-testlib                         { build-depends: rds-data:testli
 common project-config
   default-language:     Haskell2010
   default-extensions:   BlockArguments
+                        DataKinds
+                        DeriveGeneric
+                        DuplicateRecordFields
+                        FlexibleContexts
+                        FlexibleInstances
                         ImportQualifiedPost
+                        LambdaCase
+                        NoFieldSelectors
+                        OverloadedRecordDot
+                        OverloadedStrings
+                        RankNTypes
+                        ScopedTypeVariables
+                        TypeApplications
+                        TypeOperators
+                        TypeSynonymInstances
 
   ghc-options:          -Wall
                         -Wcompat

diff --git a/src/Data/RdsData/Decode/Array.hs b/src/Data/RdsData/Decode/Array.hs
@@ -1,8 +1,8 @@
-{-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE BlockArguments    #-}
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE DeriveFunctor     #-}
+{-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE LambdaCase #-}
 
 {- HLINT ignore "Use <&>" -}
 
@@ -37,16 +37,16 @@ module Data.RdsData.Decode.Array
   , words
   ) where
 
-import Control.Applicative
-import Data.Int
-import Data.RdsData.Internal.Aeson
-import Data.RdsData.Types.Array
-import Data.Text (Text)
-import Data.Time
-import Data.ULID (ULID)
-import Data.UUID (UUID)
-import Data.Word
-import Prelude hiding (maybe, null, words)
+import           Control.Applicative
+import           Data.Int
+import           Data.RdsData.Internal.Aeson
+import           Data.RdsData.Types.Array
+import           Data.Text                     (Text)
+import           Data.Time
+import           Data.ULID                     (ULID)
+import           Data.UUID                     (UUID)
+import           Data.Word
+import           Prelude                       hiding (maybe, null, words)
 
 import qualified Data.Aeson                    as J
 import qualified Data.RdsData.Internal.Convert as CONV
@@ -72,7 +72,7 @@ instance Alternative DecodeArray where
 instance Monad DecodeArray where
   DecodeArray a >>= f = DecodeArray \v -> do
     a' <- a v
-    decodeArray (f a') v
+    (.decodeArray) (f a') v
 
 --------------------------------------------------------------------------------
 
@@ -175,27 +175,27 @@ jsons = do
   ts <- texts
   case traverse (J.eitherDecodeStrict' . T.encodeUtf8) ts of
     Right js -> pure js
-    Left e -> DecodeArray \_ -> Left $ "Failed to decode JSON: " <> T.pack e
+    Left e   -> DecodeArray \_ -> Left $ "Failed to decode JSON: " <> T.pack e
 
 timesOfDay :: DecodeArray [TimeOfDay]
 timesOfDay = do
   ts <- texts
   case traverse (parseTimeM True defaultTimeLocale "%H:%M:%S". T.unpack) ts of
     Just tod -> pure tod
-    Nothing -> DecodeArray \_ -> Left "Failed to decode TimeOfDay"
+    Nothing  -> DecodeArray \_ -> Left "Failed to decode TimeOfDay"
 
 utcTimes :: DecodeArray [UTCTime]
 utcTimes = do
   ts <- texts
   case traverse (parseTimeM True defaultTimeLocale "%Y-%m-%d %H:%M:%S" . T.unpack) ts of
     Just utct -> pure utct
-    Nothing -> DecodeArray \_ -> Left "Failed to decode UTCTime"
+    Nothing   -> DecodeArray \_ -> Left "Failed to decode UTCTime"
 
 days :: DecodeArray [Day]
 days = do
   ts <- texts
   case traverse (parseTimeM True defaultTimeLocale "%Y-%m-%d" . T.unpack) ts of
-    Just d -> pure d
+    Just d  -> pure d
     Nothing -> DecodeArray \_ -> Left "Failed to decode Day"
 
 -- | Decode an array of ULIDs
@@ -205,12 +205,12 @@ ulids :: DecodeArray [ULID]
 ulids = do
   ts <- texts
   case traverse CONV.textToUlid ts of
-    Right u -> pure u
+    Right u  -> pure u
     Left msg -> DecodeArray \_ -> Left $ "Failed to decode UUID: " <> msg
 
 uuids :: DecodeArray [UUID]
 uuids = do
   ts <- texts
   case traverse (UUID.fromString . T.unpack) ts of
-    Just u -> pure u
+    Just u  -> pure u
     Nothing -> DecodeArray \_ -> Left "Failed to decode UUID"
diff --git a/src/Data/RdsData/Decode/Row.hs b/src/Data/RdsData/Decode/Row.hs
@@ -84,7 +84,7 @@ decodeRowValue :: ()
   -> Value
   -> m a
 decodeRowValue decoder v =
-  case DV.decodeValue decoder v of
+  case decoder.decodeValue v of
     Right a -> pure a
     Left e  -> throwError $ "Failed to decode Value: " <> e
 
@@ -225,7 +225,7 @@ ignore =
   void $ column DV.rdsValue
 
 decodeRow :: DecodeRow a -> [Value] -> Either Text a
-decodeRow r = evalState (runExceptT (unDecodeRow r))
+decodeRow r = evalState (runExceptT r.unDecodeRow)
 
 decodeRows :: DecodeRow a ->  [[Value]] -> Either Text [a]
 decodeRows r = traverse (decodeRow r)
diff --git a/src/Data/RdsData/Decode/Value.hs b/src/Data/RdsData/Decode/Value.hs
@@ -87,7 +87,7 @@ instance Alternative DecodeValue where
 instance Monad DecodeValue where
   DecodeValue a >>= f = DecodeValue \v -> do
     a' <- a v
-    decodeValue (f a') v
+    (.decodeValue) (f a') v
 
 fail :: Text -> DecodeValue a
 fail =
@@ -125,7 +125,7 @@ array :: DecodeArray a -> DecodeValue a
 array decoder =
   DecodeValue \v ->
     case v of
-      ValueOfArray a -> decodeArray decoder a
+      ValueOfArray a -> decoder.decodeArray a
       _ -> Left $ decodeValueFailedMessage "array" "Array" Nothing v
 
 base64 :: DecodeValue Base64

diff --git a/src/Data/RdsData/Encode/Param.hs b/src/Data/RdsData/Encode/Param.hs
@@ -99,13 +99,13 @@ rdsParam =
 
 maybe :: EncodeParam a -> EncodeParam (Maybe a)
 maybe =
-  EncodeParam . P.maybe (Param Nothing Nothing ValueOfNull) . encodeParam
+  EncodeParam . P.maybe (Param Nothing Nothing ValueOfNull) . (.encodeParam)
 
 --------------------------------------------------------------------------------
 
 array :: EncodeArray a -> EncodeParam a
 array enc =
-  Param Nothing Nothing . ValueOfArray . encodeArray enc >$< rdsParam
+  Param Nothing Nothing . ValueOfArray . enc.encodeArray >$< rdsParam
 
 base64 :: EncodeParam AWS.Base64
 base64 =

diff --git a/src/Data/RdsData/Encode/Params.hs b/src/Data/RdsData/Encode/Params.hs
@@ -3,6 +3,7 @@
 module Data.RdsData.Encode.Params
   ( EncodeParams(..)
   , EncodedParams(..)
+  , encodeParams
   , encode
 
   , rdsValue
@@ -66,7 +67,7 @@ import qualified Data.Text.Lazy                       as LT
 import qualified Prelude                              as P
 
 newtype EncodedParams = EncodedParams
-  { unEncodedParams :: [Param] -> [Param]
+  { run :: [Param] -> [Param]
   }
 
 instance Semigroup EncodedParams where
@@ -78,9 +79,13 @@ instance Monoid EncodedParams where
     EncodedParams id
 
 newtype EncodeParams a = EncodeParams
-  { encodeParams :: a -> [Param] -> [Param]
+  { run :: a -> [Param] -> [Param]
   }
 
+encodeParams :: EncodeParams a -> a -> [Param] -> [Param]
+encodeParams =
+  (.run)
+
 encode :: EncodeParams a -> a -> EncodedParams
 encode (EncodeParams f) a =
   EncodedParams (f a)
@@ -121,7 +126,7 @@ column (EncodeParam f) =
 named :: Text -> EncodeParam a -> EncodeParams a
 named n ep =
   EncodeParams \a ->
-    (EP.encodeParam (EP.named n ep) a:)
+    ((.encodeParam) (EP.named n ep) a:)
 
 --------------------------------------------------------------------------------
 

diff --git a/src/Data/RdsData/Encode/Row.hs b/src/Data/RdsData/Encode/Row.hs
@@ -3,6 +3,7 @@
 module Data.RdsData.Encode.Row
   ( EncodeRow(..)
 
+  , encodeRow
   , rdsValue
 
   , column
@@ -38,27 +39,27 @@ module Data.RdsData.Encode.Row
   , word64
   ) where
 
-import Data.ByteString (ByteString)
-import Data.Functor.Contravariant
-import Data.Functor.Contravariant.Divisible
-import Data.Int
-import Data.RdsData.Encode.Array (EncodeArray(..))
-import Data.RdsData.Encode.Value (EncodeValue(..))
-import Data.RdsData.Types.Value
-import Data.Text (Text)
-import Data.Time
-import Data.ULID (ULID)
-import Data.UUID (UUID)
-import Data.Void
-import Data.Word
-import Prelude hiding (maybe, null)
-
-import qualified Amazonka.Data.Base64       as AWS
-import qualified Data.Aeson                 as J
-import qualified Data.ByteString.Lazy       as LBS
-import qualified Data.RdsData.Encode.Value  as EV
-import qualified Data.Text.Lazy             as LT
-import qualified Prelude                    as P
+import           Data.ByteString                      (ByteString)
+import           Data.Functor.Contravariant
+import           Data.Functor.Contravariant.Divisible
+import           Data.Int
+import           Data.RdsData.Encode.Array            (EncodeArray (..))
+import           Data.RdsData.Encode.Value            (EncodeValue (..))
+import           Data.RdsData.Types.Value
+import           Data.Text                            (Text)
+import           Data.Time
+import           Data.ULID                            (ULID)
+import           Data.UUID                            (UUID)
+import           Data.Void
+import           Data.Word
+import           Prelude                              hiding (maybe, null)
+
+import qualified Amazonka.Data.Base64                 as AWS
+import qualified Data.Aeson                           as J
+import qualified Data.ByteString.Lazy                 as LBS
+import qualified Data.RdsData.Encode.Value            as EV
+import qualified Data.Text.Lazy                       as LT
+import qualified Prelude                              as P
 
 newtype EncodeRow a = EncodeRow
   { encodeRow :: a -> [Value] -> [Value]
@@ -80,11 +81,15 @@ instance Decidable EncodeRow where
   choose f (EncodeRow g) (EncodeRow h) =
     EncodeRow \a ->
       case f a of
-        Left b -> g b
+        Left b  -> g b
         Right c -> h c
   lose f =
     EncodeRow $ absurd . f
 
+encodeRow :: EncodeRow a -> a -> [Value] -> [Value]
+encodeRow =
+  (.encodeRow)
+
 --------------------------------------------------------------------------------
 
 rdsValue :: EncodeRow Value

diff --git a/src/Data/RdsData/Encode/Value.hs b/src/Data/RdsData/Encode/Value.hs
@@ -36,25 +36,25 @@ module Data.RdsData.Encode.Value
   , word64
   ) where
 
-import Data.ByteString (ByteString)
-import Data.Functor.Contravariant
-import Data.Int
-import Data.RdsData.Encode.Array
-import Data.RdsData.Types.Value
-import Data.Text (Text)
-import Data.Time
-import Data.ULID (ULID)
-import Data.UUID (UUID)
-import Data.Word
-import Prelude hiding (maybe, null)
-
-import qualified Amazonka.Bytes                 as AWS
-import qualified Amazonka.Data.Base64           as AWS
-import qualified Data.Aeson                     as J
-import qualified Data.ByteString.Lazy           as LBS
-import qualified Data.RdsData.Internal.Convert  as CONV
-import qualified Data.Text.Lazy                 as LT
-import qualified Prelude                        as P
+import           Data.ByteString               (ByteString)
+import           Data.Functor.Contravariant
+import           Data.Int
+import           Data.RdsData.Encode.Array
+import           Data.RdsData.Types.Value
+import           Data.Text                     (Text)
+import           Data.Time
+import           Data.ULID                     (ULID)
+import           Data.UUID                     (UUID)
+import           Data.Word
+import           Prelude                       hiding (maybe, null)
+
+import qualified Amazonka.Bytes                as AWS
+import qualified Amazonka.Data.Base64          as AWS
+import qualified Data.Aeson                    as J
+import qualified Data.ByteString.Lazy          as LBS
+import qualified Data.RdsData.Internal.Convert as CONV
+import qualified Data.Text.Lazy                as LT
+import qualified Prelude                       as P
 
 newtype EncodeValue a = EncodeValue
   { encodeValue :: a -> Value
@@ -74,13 +74,13 @@ rdsValue =
 
 maybe :: EncodeValue a -> EncodeValue (Maybe a)
 maybe =
-  EncodeValue . P.maybe ValueOfNull . encodeValue
+  EncodeValue . P.maybe ValueOfNull . (.encodeValue)
 
 --------------------------------------------------------------------------------
 
 array :: EncodeArray a -> EncodeValue a
 array enc =
-  ValueOfArray . encodeArray enc >$< rdsValue
+  ValueOfArray . enc.encodeArray >$< rdsValue
 
 base64 :: EncodeValue AWS.Base64
 base64 =