From 8b630b11568434452ad8798c43f8945361767a68 Mon Sep 17 00:00:00 2001 From: Shane O'Brien Date: Fri, 6 Oct 2023 15:46:07 +0100 Subject: [PATCH] Add `DBType` instance for `Fixed` This resolves issue #218. --- .../20231006_154448_shane.obrien_decimal.md | 40 +++++++ rel8.cabal | 1 + src/Rel8/Type.hs | 30 ++++- src/Rel8/Type/Decimal.hs | 103 ++++++++++++++++++ tests/Main.hs | 2 + 5 files changed, 173 insertions(+), 3 deletions(-) create mode 100644 changelog.d/20231006_154448_shane.obrien_decimal.md create mode 100644 src/Rel8/Type/Decimal.hs diff --git a/changelog.d/20231006_154448_shane.obrien_decimal.md b/changelog.d/20231006_154448_shane.obrien_decimal.md new file mode 100644 index 00000000..c2db704b --- /dev/null +++ b/changelog.d/20231006_154448_shane.obrien_decimal.md @@ -0,0 +1,40 @@ + + + +### Added + +- `DBType` instance for `Fixed` that would map (e.g.) `Micro` to `numeric(1000, 6)` and `Pico` to `numeric(1000, 12)`. + + + + + diff --git a/rel8.cabal b/rel8.cabal index 95a8663b..a0471d4f 100644 --- a/rel8.cabal +++ b/rel8.cabal @@ -209,6 +209,7 @@ library Rel8.Type Rel8.Type.Array Rel8.Type.Composite + Rel8.Type.Decimal Rel8.Type.Decoder Rel8.Type.Eq Rel8.Type.Enum diff --git a/src/Rel8/Type.hs b/src/Rel8/Type.hs index 7eaa7e07..c5b028d5 100644 --- a/src/Rel8/Type.hs +++ b/src/Rel8/Type.hs @@ -4,7 +4,9 @@ {-# language MonoLocalBinds #-} {-# language MultiWayIf #-} {-# language OverloadedStrings #-} +{-# language ScopedTypeVariables #-} {-# language StandaloneKindSignatures #-} +{-# language TypeApplications #-} {-# language UndecidableInstances #-} module Rel8.Type @@ -24,6 +26,7 @@ import qualified Data.Aeson.Parser as Aeson -- base import Control.Applicative ((<|>)) +import Data.Fixed (Fixed) import Data.Int ( Int16, Int32, Int64 ) import Data.List.NonEmpty ( NonEmpty ) import Data.Kind ( Constraint, Type ) @@ -55,6 +58,7 @@ import qualified Opaleye.Internal.HaskellDB.Sql.Default as Opaleye ( quote ) -- rel8 import Rel8.Schema.Null ( NotNull, Sql, nullable ) import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation ) +import Rel8.Type.Decimal (PowerOf10, resolution) import Rel8.Type.Decoder ( Decoder(..) ) import Rel8.Type.Information ( TypeInformation(..), mapTypeInformation ) import Rel8.Type.Name (TypeName (..)) @@ -191,7 +195,7 @@ instance DBType Float where if | x == (1 / 0) -> Opaleye.OtherLit "'Infinity'" | isNaN x -> Opaleye.OtherLit "'NaN'" | x == (-1 / 0) -> Opaleye.OtherLit "'-Infinity'" - | otherwise -> Opaleye.NumericLit $ realToFrac x + | otherwise -> Opaleye.DoubleLit $ realToFrac x , decode = Decoder { binary = Hasql.float4 @@ -209,7 +213,7 @@ instance DBType Double where if | x == (1 / 0) -> Opaleye.OtherLit "'Infinity'" | isNaN x -> Opaleye.OtherLit "'NaN'" | x == (-1 / 0) -> Opaleye.OtherLit "'-Infinity'" - | otherwise -> Opaleye.NumericLit $ realToFrac x + | otherwise -> Opaleye.DoubleLit x , decode = Decoder { binary = Hasql.float8 @@ -223,7 +227,7 @@ instance DBType Double where -- | Corresponds to @numeric@ instance DBType Scientific where typeInformation = TypeInformation - { encode = Opaleye.ConstExpr . Opaleye.NumericLit + { encode = Opaleye.ConstExpr . Opaleye.NumericLit , decode = Decoder { binary = Hasql.numeric @@ -234,6 +238,26 @@ instance DBType Scientific where } +-- | Corresponds to @numeric(1000, log₁₀ n)@ +instance PowerOf10 n => DBType (Fixed n) where + typeInformation = TypeInformation + { encode = Opaleye.ConstExpr . Opaleye.NumericLit . realToFrac + , decode = + realToFrac <$> + Decoder + { binary = Hasql.numeric + , parser = parse A.scientific + , delimiter = ',' + } + , typeName = + TypeName + { name = "numeric" + , modifiers = ["1000", show (resolution @n)] + , arrayDepth = 0 + } + } + + -- | Corresponds to @timestamptz@ instance DBType UTCTime where typeInformation = TypeInformation diff --git a/src/Rel8/Type/Decimal.hs b/src/Rel8/Type/Decimal.hs new file mode 100644 index 00000000..1c6f94ed --- /dev/null +++ b/src/Rel8/Type/Decimal.hs @@ -0,0 +1,103 @@ +{-# language AllowAmbiguousTypes #-} +{-# language ConstraintKinds #-} +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language NoStarIsType #-} +{-# language PolyKinds #-} +{-# language RankNTypes #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneKindSignatures #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} + +module Rel8.Type.Decimal + ( PowerOf10 + , resolution + ) +where + +-- base +import Data.Fixed (E0, E1, E2, E3, E6, E9, E12, HasResolution) +import Data.Proxy (Proxy (Proxy)) +import Data.Type.Equality (type (==)) +import Data.Type.Ord (type (:), ShowType, Text), TypeError) +import GHC.TypeNats (KnownNat, Nat, type (+), type (-), type (*), Div, natVal) +import Numeric.Natural (Natural) +import Prelude + + +type PowerOf10 :: a -> Constraint +class (HasResolution n, KnownNat (Log n)) => PowerOf10 n where + type Log n :: Nat + + +instance (KnownNat n, KnownNat (Log n), IsPowerOf10 n) => PowerOf10 n where + type Log n = Log10 n + + +instance PowerOf10 E0 where + type Log E0 = 0 + + +instance PowerOf10 E1 where + type Log E1 = 1 + + +instance PowerOf10 E2 where + type Log E2 = 2 + + +instance PowerOf10 E3 where + type Log E3 = 3 + + +instance PowerOf10 E6 where + type Log E6 = 6 + + +instance PowerOf10 E9 where + type Log E9 = 9 + + +instance PowerOf10 E12 where + type Log E12 = 12 + + +resolution :: forall n. PowerOf10 n => Natural +resolution = natVal (Proxy @(Log n)) + + +type Exp10 :: Nat -> Nat +type Exp10 n = Exp10' 1 n + + +type Exp10' :: Nat -> Nat -> Nat +type family Exp10' x n where + Exp10' x 0 = x + Exp10' x n = Exp10' (x * 10) (n - 1) + + +type Log10 :: Nat -> Nat +type Log10 n = Log10' (n Nat -> Nat +type family Log10' bool n where + Log10' 'True _n = 0 + Log10' 'False n = 1 + Log10 (Div n 10) + + +type IsPowerOf10 :: Nat -> Constraint +type IsPowerOf10 n = IsPowerOf10' (Exp10 (Log10 n) == n) n + + +type IsPowerOf10' :: Bool -> Nat -> Constraint +type family IsPowerOf10' bool n where + IsPowerOf10' 'True _n = () + IsPowerOf10' 'False n = + TypeError ('ShowType n ':<>: 'Text " is not a power of 10") \ No newline at end of file diff --git a/tests/Main.hs b/tests/Main.hs index 1dc6eafa..b91aa0a3 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -25,6 +25,7 @@ import Control.Monad ((>=>)) import Data.Bifunctor ( bimap ) import Data.Fixed (Fixed (MkFixed)) import Data.Foldable ( for_ ) +import Data.Fixed (Centi) import Data.Functor (void) import Data.Int ( Int32, Int64 ) import Data.List ( nub, sort ) @@ -438,6 +439,7 @@ testDBType getTestDatabase = testGroup "DBType instances" , dbTypeTest "Composite" genComposite , dbTypeTest "Day" genDay , dbTypeTest "Double" $ (/ 10) . fromIntegral @Int @Double <$> Gen.integral (Range.linear (-100) 100) + , dbTypeTest "Fixed" $ toEnum @Centi <$> Gen.integral (Range.linear (-10000) 10000) , dbTypeTest "Float" $ (/ 10) . fromIntegral @Int @Float <$> Gen.integral (Range.linear (-100) 100) , dbTypeTest "Int32" $ Gen.integral @_ @Int32 Range.linearBounded , dbTypeTest "Int64" $ Gen.integral @_ @Int64 Range.linearBounded