Skip to content

Commit 47cbe47

Browse files
apkhandkarapkhandkar
authored
Move Only to Database.Oracle.Simple.Internal, add ToRow instance for the same (#27)
* move Only type to Database.Oracle.Simple.Internal, add ToRow instance for the same * run formatter
1 parent a797f63 commit 47cbe47

File tree

3 files changed

+84
-71
lines changed

3 files changed

+84
-71
lines changed

‎src/Database/Oracle/Simple/FromRow.hs

Lines changed: 16 additions & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -1,18 +1,18 @@
1-
{-# LANGUAGE DeriveGeneric #-}
2-
{-# LANGUAGE DeriveAnyClass #-}
3-
{-# LANGUAGE DataKinds #-}
4-
{-# LANGUAGE DefaultSignatures #-}
5-
{-# LANGUAGE DerivingStrategies #-}
6-
{-# LANGUAGE FlexibleContexts #-}
7-
{-# LANGUAGE FlexibleInstances #-}
1+
{-# LANGUAGE DataKinds #-}
2+
{-# LANGUAGE DefaultSignatures #-}
3+
{-# LANGUAGE DeriveAnyClass #-}
4+
{-# LANGUAGE DeriveGeneric #-}
5+
{-# LANGUAGE DerivingStrategies #-}
6+
{-# LANGUAGE FlexibleContexts #-}
7+
{-# LANGUAGE FlexibleInstances #-}
88
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
9-
{-# LANGUAGE RankNTypes #-}
10-
{-# LANGUAGE RecordWildCards #-}
11-
{-# LANGUAGE ScopedTypeVariables #-}
12-
{-# LANGUAGE TypeApplications #-}
13-
{-# LANGUAGE TypeOperators #-}
14-
{-# LANGUAGE TypeSynonymInstances #-}
15-
{-# LANGUAGE UndecidableInstances #-}
9+
{-# LANGUAGE RankNTypes #-}
10+
{-# LANGUAGE RecordWildCards #-}
11+
{-# LANGUAGE ScopedTypeVariables #-}
12+
{-# LANGUAGE TypeApplications #-}
13+
{-# LANGUAGE TypeOperators #-}
14+
{-# LANGUAGE TypeSynonymInstances #-}
15+
{-# LANGUAGE UndecidableInstances #-}
1616

1717
module Database.Oracle.Simple.FromRow where
1818

@@ -32,6 +32,8 @@ class FromRow a where
3232
default fromRow :: (GFromRow (Rep a), Generic a) => RowParser a
3333
fromRow = to <$> gFromRow
3434

35+
instance FromField a => FromRow (Only a)
36+
3537
instance FromField a => FromRow (Identity a)
3638

3739
instance (FromField a, FromField b) => FromRow (a, b)
@@ -70,10 +72,6 @@ instance
7072
)
7173
=> FromRow (a, b, c, d, e, f, g, h, i, j)
7274

73-
newtype Only a = Only { getOnly :: a }
74-
deriving stock (Show, Eq, Generic)
75-
deriving anyclass FromRow
76-
7775
class GFromRow f where
7876
gFromRow :: RowParser (f a)
7977

‎src/Database/Oracle/Simple/Internal.hs

Lines changed: 42 additions & 32 deletions
Original file line numberDiff line numberDiff line change
@@ -22,8 +22,6 @@
2222

2323
module Database.Oracle.Simple.Internal where
2424

25-
import Test.QuickCheck
26-
import Data.Time
2725
import Control.Exception
2826
import Control.Monad
2927
import Control.Monad.State.Strict
@@ -32,6 +30,7 @@ import Data.IORef
3230
import Data.Kind
3331
import Data.List as L
3432
import Data.Text
33+
import Data.Time
3534
import Data.Typeable
3635
import Data.Word
3736
import Foreign
@@ -44,6 +43,7 @@ import Foreign.Storable.Generic
4443
import GHC.Generics
4544
import GHC.TypeLits
4645
import System.IO.Unsafe
46+
import Test.QuickCheck
4747

4848
newtype DPIStmt = DPIStmt (Ptr DPIStmt)
4949
deriving (Show, Eq)
@@ -204,9 +204,9 @@ toDPIPurity :: DPIPurity -> CUInt
204204
toDPIPurity = fromIntegral . fromEnum
205205

206206
data DPIModeConnClose
207-
= DPI_MODE_CONN_CLOSE_DEFAULT -- 0x0000
208-
| DPI_MODE_CONN_CLOSE_DROP -- 0x0001
209-
| DPI_MODE_CONN_CLOSE_RETAG -- 0x0002
207+
= DPI_MODE_CONN_CLOSE_DEFAULT -- 0x0000
208+
| DPI_MODE_CONN_CLOSE_DROP -- 0x0001
209+
| DPI_MODE_CONN_CLOSE_RETAG -- 0x0002
210210
deriving (Show, Eq)
211211

212212
toDpiModeConnClose :: DPIModeConnClose -> CUInt
@@ -458,8 +458,12 @@ getServerVersion (Connection fptr) versionInfo = do
458458
alloca $ \releaseStringPtr -> do
459459
alloca $ \versionInfoPtr -> do
460460
poke versionInfoPtr versionInfo
461-
status <- dpiContext_getServerVersion
462-
conn releaseStringPtr (fromIntegral (10 :: Int)) versionInfoPtr
461+
status <-
462+
dpiContext_getServerVersion
463+
conn
464+
releaseStringPtr
465+
(fromIntegral (10 :: Int))
466+
versionInfoPtr
463467
if status == 0
464468
then (peekCString <=< peek) releaseStringPtr
465469
else error $ show status <> " oh no!"
@@ -547,21 +551,22 @@ data DPITimestamp = DPITimestamp
547551
-- to the year, month, day, hour, minutes and seconds
548552
dpiTimeStampToUTCDPITimeStamp :: DPITimestamp -> DPITimestamp
549553
dpiTimeStampToUTCDPITimeStamp dpi@DPITimestamp{..} = utcDpi
550-
where
551-
offsetInMinutes, currentMinutes :: Int
552-
offsetInMinutes = negate $ (fromIntegral tzHourOffset * 60) + fromIntegral tzMinuteOffset
553-
currentMinutes = (fromIntegral hour * 60) + fromIntegral minute
554-
(hours, minutes) = ((currentMinutes + offsetInMinutes) `mod` 1440) `quotRem` 60
555-
556-
gregorianDay = fromGregorian (fromIntegral year) (fromIntegral month) (fromIntegral day)
557-
updatedDay | fromIntegral currentMinutes + fromIntegral offsetInMinutes > 1440
558-
= addDays 1 gregorianDay
559-
| fromIntegral currentMinutes + fromIntegral offsetInMinutes < 0
560-
= addDays (-1) gregorianDay
561-
| otherwise = gregorianDay
562-
(year', month', day') = toGregorian updatedDay
563-
utcDpi
564-
= dpi
554+
where
555+
offsetInMinutes, currentMinutes :: Int
556+
offsetInMinutes = negate $ (fromIntegral tzHourOffset * 60) + fromIntegral tzMinuteOffset
557+
currentMinutes = (fromIntegral hour * 60) + fromIntegral minute
558+
(hours, minutes) = ((currentMinutes + offsetInMinutes) `mod` 1440) `quotRem` 60
559+
560+
gregorianDay = fromGregorian (fromIntegral year) (fromIntegral month) (fromIntegral day)
561+
updatedDay
562+
| fromIntegral currentMinutes + fromIntegral offsetInMinutes > 1440 =
563+
addDays 1 gregorianDay
564+
| fromIntegral currentMinutes + fromIntegral offsetInMinutes < 0 =
565+
addDays (-1) gregorianDay
566+
| otherwise = gregorianDay
567+
(year', month', day') = toGregorian updatedDay
568+
utcDpi =
569+
dpi
565570
{ tzHourOffset = 0
566571
, tzMinuteOffset = 0
567572
, year = fromIntegral year'
@@ -573,19 +578,19 @@ dpiTimeStampToUTCDPITimeStamp dpi@DPITimestamp{..} = utcDpi
573578

574579
instance Arbitrary DPITimestamp where
575580
arbitrary = do
576-
year <- choose (1000, 2023)
577-
month <- choose (1, 12)
578-
day <- choose (1, 28)
579-
hour <- choose (1, 23)
580-
minute <- choose (1, 59)
581-
second <- choose (1, 59)
582-
fsecond <- choose (0, 100000)
583-
tzHourOffset <- choose (-14, 14)
581+
year <- choose (1000, 2023)
582+
month <- choose (1, 12)
583+
day <- choose (1, 28)
584+
hour <- choose (1, 23)
585+
minute <- choose (1, 59)
586+
second <- choose (1, 59)
587+
fsecond <- choose (0, 100000)
588+
tzHourOffset <- choose (-14, 14)
584589
tzMinuteOffset <-
585590
if signum tzHourOffset < 0
586591
then choose (-59, 0)
587592
else choose (0, 59)
588-
pure DPITimestamp {..}
593+
pure DPITimestamp{..}
589594

590595
instance HasDPINativeType DPITimestamp where
591596
dpiNativeType Proxy = DPI_NATIVE_TYPE_TIMESTAMP
@@ -974,4 +979,9 @@ isHealthy (Connection fptr) =
974979
withForeignPtr fptr $ \conn -> do
975980
alloca $ \healthPtr -> do
976981
throwOracleError =<< dpiConn_getIsHealthy conn healthPtr
977-
(==1) <$> peek healthPtr
982+
(== 1) <$> peek healthPtr
983+
984+
-- | The 1-tuple type or single-value "collection".
985+
-- Structurally equivalent to 'Data.Functor.Identity.Identity'.
986+
newtype Only a = Only {fromOnly :: a}
987+
deriving stock (Eq, Ord, Read, Show, Generic)

‎src/Database/Oracle/Simple/ToRow.hs

Lines changed: 26 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -1,30 +1,30 @@
11
{-# LANGUAGE BangPatterns #-}
2-
{-# LANGUAGE UndecidableInstances #-}
32
{-# LANGUAGE DataKinds #-}
4-
{-# LANGUAGE FlexibleInstances #-}
5-
{-# LANGUAGE FlexibleContexts #-}
6-
{-# LANGUAGE TypeSynonymInstances #-}
7-
{-# LANGUAGE TypeOperators #-}
83
{-# LANGUAGE DefaultSignatures #-}
4+
{-# LANGUAGE FlexibleContexts #-}
5+
{-# LANGUAGE FlexibleInstances #-}
96
{-# LANGUAGE RankNTypes #-}
107
{-# LANGUAGE RecordWildCards #-}
118
{-# LANGUAGE ScopedTypeVariables #-}
129
{-# LANGUAGE TypeApplications #-}
10+
{-# LANGUAGE TypeOperators #-}
11+
{-# LANGUAGE TypeSynonymInstances #-}
12+
{-# LANGUAGE UndecidableInstances #-}
1313

1414
module Database.Oracle.Simple.ToRow where
1515

16-
import Control.Monad
17-
import Control.Monad.State.Strict
18-
import Data.Functor.Identity
19-
import qualified Data.List as L
20-
import Data.Proxy
21-
import Data.Traversable
22-
import Data.Word
23-
import Database.Oracle.Simple.Internal
24-
import Database.Oracle.Simple.ToField
25-
import Foreign.Ptr
26-
import GHC.Generics
27-
import GHC.TypeLits
16+
import Control.Monad
17+
import Control.Monad.State.Strict
18+
import Data.Functor.Identity
19+
import qualified Data.List as L
20+
import Data.Proxy
21+
import Data.Traversable
22+
import Data.Word
23+
import Database.Oracle.Simple.Internal
24+
import Database.Oracle.Simple.ToField
25+
import Foreign.Ptr
26+
import GHC.Generics
27+
import GHC.TypeLits
2828

2929
newtype RowWriter a = RowWriter {runRowWriter :: DPIStmt -> StateT Column IO a}
3030

@@ -48,6 +48,8 @@ class ToRow a where
4848
default toRow :: (GToRow (Rep a), Generic a) => a -> RowWriter ()
4949
toRow = gToRow . from
5050

51+
instance ToField a => ToRow (Only a)
52+
5153
instance ToField a => ToRow (Identity a)
5254

5355
instance (ToField a, ToField b) => ToRow (a, b)
@@ -62,13 +64,16 @@ instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f) => T
6264

6365
instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g) => ToRow (a, b, c, d, e, f, g)
6466

65-
instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h)
67+
instance
68+
(ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h)
6669
=> ToRow (a, b, c, d, e, f, g, h)
6770

68-
instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h, ToField i)
71+
instance
72+
(ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h, ToField i)
6973
=> ToRow (a, b, c, d, e, f, g, h, i)
7074

71-
instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h, ToField i, ToField j)
75+
instance
76+
(ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h, ToField i, ToField j)
7277
=> ToRow (a, b, c, d, e, f, g, h, i, j)
7378

7479
class GToRow f where
@@ -90,7 +95,7 @@ instance (TypeError ('Text "Sum types not supported")) => GToRow (l :+: r) where
9095
gToRow = error "Sum types not supported"
9196

9297
instance (ToField a) => GToRow (K1 i a) where
93-
gToRow (K1 x)= void (writeField x)
98+
gToRow (K1 x) = void (writeField x)
9499

95100
instance (ToField a) => ToField (Maybe a) where
96101
toField (Just val) = toField val

0 commit comments

Comments
 (0)