Add DBType instance for Fixed

This resolves issue #218.

changelog.d/20231006_154448_shane.obrien_decimal.md

@@ -0,0 +1,40 @@
+<!--
+A new scriv changelog fragment.
+
+Uncomment the section that is right (remove the HTML comment wrapper).
+-->
+
+<!--
+### Removed
+
+- A bullet item for the Removed category.
+
+-->
+### Added
+
+- `DBType` instance for `Fixed` that would map (e.g.) `Micro` to `numeric(1000, 6)` and `Pico` to `numeric(1000, 12)`.
+
+<!--
+### Changed
+
+- A bullet item for the Changed category.
+
+-->
+<!--
+### Deprecated
+
+- A bullet item for the Deprecated category.
+
+-->
+<!--
+### Fixed
+
+- A bullet item for the Fixed category.
+
+-->
+<!--
+### Security
+
+- A bullet item for the Security category.
+
+-->

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

src/Rel8/Type.hs

@@ -4,6 +4,7 @@
 {-# language MonoLocalBinds #-}
 {-# language MultiWayIf #-}
 {-# language OverloadedStrings #-}
+{-# language ScopedTypeVariables #-}
 {-# language StandaloneKindSignatures #-}
 {-# language UndecidableInstances #-}
 
@@ -24,6 +25,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 +57,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 +194,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 +212,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 +226,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 +237,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

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 (<?))
+import Data.Kind (Constraint)
+import GHC.TypeLits (ErrorMessage ((:<>:), 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 <? 10) n
+
+
+type Log10' :: Bool -> 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")