From 39abdd9a02fd2bf917371b371f93f3e6ed491419 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Wed, 24 Mar 2021 10:24:12 +0300 Subject: [PATCH] Enforce Value decoder's result to have a representational role Fixes #137 --- .travis.yml | 1 - hasql.cabal | 14 +++++++------- library/Hasql/Private/Decoders.hs | 4 +++- library/Hasql/Private/Decoders/Value.hs | 10 ++++------ 4 files changed, 14 insertions(+), 15 deletions(-) diff --git a/.travis.yml b/.travis.yml index 0866e9a..6c4882d 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,7 +1,6 @@ if: tag IS blank env: - - ghc=8.4.2 - ghc=8.6.1 - ghc=8.8.1 - ghc=8.10.2 benchmarks=1 tests=1 diff --git a/hasql.cabal b/hasql.cabal index b2504e4..5246aa0 100644 --- a/hasql.cabal +++ b/hasql.cabal @@ -24,7 +24,7 @@ source-repository head library hs-source-dirs: library - default-extensions: Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples + default-extensions: Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, RoleAnnotations, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples default-language: Haskell2010 exposed-modules: Hasql.Decoders @@ -55,7 +55,7 @@ library Hasql.Private.Encoders.Params build-depends: attoparsec >=0.10 && <0.15, - base >=4.11 && <5, + base >=4.12 && <5, bytestring >=0.10 && <0.12, bytestring-strict-builder >=0.4.5.1 && <0.5, contravariant >=1.3 && <2, @@ -64,7 +64,7 @@ library hashable >=1.2 && <2, hashtables >=1.1 && <2, mtl >=2 && <3, - postgresql-binary >=0.12.3 && <0.13, + postgresql-binary >=0.12.4 && <0.13, postgresql-libpq ==0.9.*, profunctors >=5.1 && <6, text >=1 && <2, @@ -76,7 +76,7 @@ test-suite tasty type: exitcode-stdio-1.0 hs-source-dirs: tasty main-is: Main.hs - default-extensions: Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples + default-extensions: Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, RoleAnnotations, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples default-language: Haskell2010 other-modules: Main.DSL @@ -97,7 +97,7 @@ test-suite threads-test hs-source-dirs: threads-test main-is: Main.hs default-extensions: - Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples + Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, RoleAnnotations, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples default-language: Haskell2010 other-modules: @@ -114,7 +114,7 @@ benchmark benchmarks type: exitcode-stdio-1.0 hs-source-dirs: benchmarks main-is: Main.hs - default-extensions: Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples + default-extensions: Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, RoleAnnotations, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples default-language: Haskell2010 ghc-options: -O2 @@ -131,7 +131,7 @@ test-suite profiling type: exitcode-stdio-1.0 hs-source-dirs: profiling main-is: Main.hs - default-extensions: Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples + default-extensions: Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, RoleAnnotations, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples default-language: Haskell2010 ghc-options: -O2 diff --git a/library/Hasql/Private/Decoders.hs b/library/Hasql/Private/Decoders.hs index bd3daf2..ff88a25 100644 --- a/library/Hasql/Private/Decoders.hs +++ b/library/Hasql/Private/Decoders.hs @@ -157,6 +157,8 @@ Decoder of a value. newtype Value a = Value (Value.Value a) deriving (Functor) +type role Value representational + {-| Decoder of the @BOOL@ values. -} @@ -339,7 +341,7 @@ Refine a value decoder, lifting the possible error to the session level. -} {-# INLINABLE refine #-} refine :: (a -> Either Text b) -> Value a -> Value b -refine fn (Value v) = Value (Value.Value (ask >>= \b -> lift (A.refine fn (Value.run v b)))) +refine fn (Value v) = Value (Value.Value (\b -> A.refine fn (Value.run v b))) {-| A generic decoder of @HSTORE@ values. diff --git a/library/Hasql/Private/Decoders/Value.hs b/library/Hasql/Private/Decoders/Value.hs index 351d080..2b8e1f9 100644 --- a/library/Hasql/Private/Decoders/Value.hs +++ b/library/Hasql/Private/Decoders/Value.hs @@ -5,23 +5,21 @@ import qualified PostgreSQL.Binary.Decoding as A newtype Value a = - Value (ReaderT Bool A.Value a) + Value (Bool -> A.Value a) deriving (Functor) - {-# INLINE run #-} run :: Value a -> Bool -> A.Value a run (Value imp) integerDatetimes = - runReaderT imp integerDatetimes + imp integerDatetimes {-# INLINE decoder #-} decoder :: (Bool -> A.Value a) -> Value a decoder = {-# SCC "decoder" #-} - Value . ReaderT + Value {-# INLINE decoderFn #-} decoderFn :: (Bool -> ByteString -> Either Text a) -> Value a decoderFn fn = - Value $ ReaderT $ \integerDatetimes -> A.fn $ fn integerDatetimes - + Value $ \integerDatetimes -> A.fn $ fn integerDatetimes