sq 0.0.2 → 0.1
raw patch · 11 files changed
+1179/−245 lines, 11 filesdep +adjunctionsdep +attoparsec-aesondep +attoparsec-iso8601
Dependencies added: adjunctions, attoparsec-aeson, attoparsec-iso8601, generics-sop, integer-logarithms, network-uri, scientific, sop-core, uuid-types
Files
- CHANGELOG.md +34/−0
- lib/Sq.hs +62/−6
- lib/Sq/Connection.hs +142/−96
- lib/Sq/Decoders.hs +306/−96
- lib/Sq/Encoders.hs +114/−21
- lib/Sq/Input.hs +182/−2
- lib/Sq/Names.hs +4/−9
- lib/Sq/Output.hs +163/−4
- lib/Sq/Support.hs +97/−0
- sq.cabal +17/−5
- test/Sq/Test/Codec.hs +58/−6
CHANGELOG.md view
@@ -1,3 +1,37 @@+# Version 0.1++* CHANGED the type of `encodeAeson` and `encodeBinary`.++* REMOVED `encodeSizedIntegral`. Go through `Int64` or `Scientific` instead.++* REMOVED `decodeSizedIntegral`. Use `decodeBoundedIntegral` instead.++* Added `encodeNS`, `decodeNS`, `encodeAeson'`, `ginputDefault`,+ `goutputDefault`, `RowId`.++* Added `Contravariant` `Rep` instance for `Encode` and `Input`.++* Added `InputDefault`, `OutputDefault` and related instances, using+ `ginputDefault` and `goutputDefault` when possible as default+ derivation records and sums of records deriving GHC's `Generic`.++* Added `EncodeDefault` instances for `aeson`'s `Encoding`, `Value` and `Key`,+ for `binary`'s `Put`, for `UUID`, for `Scientific`, for `Fixed`, for+ `network-uri`'s `URI`.++* Added `DecodeDefault` instances for `UUID`, for `aeson`'s `Value` and `Key`,+ for `Scientific`, for `Fixed`, for `network-uri`'s `URI`.++* Export `BindingName` constructor.++* Export `ErrTransaction`.++* Improved asynchronous exception handling.++* Faster `ZonedTime`, `UTCTime`, `LocalTime`, `TimeZone`, `Day` and `TimeOfDay`+ parsing via `attoparsec-iso8601`++ # Version 0.0.2 * Added `FromJSON`, `ToJSON` instances for `Name`.
lib/Sq.hs view
@@ -14,6 +14,10 @@ -- -- * Type-safe __decoding__ of SQL output rows and columns ('Decode', 'Output'). --+-- * Type-safe __automatic__ derivation of 'Input' and 'Output' codecs for+-- records and sums of records via 'GHC.Generic' ('ginputDefault',+-- 'goutputDefault').+-- -- * Type-safe __concurrent connections__ with read and write database access -- ('Pool'). --@@ -39,8 +43,7 @@ -- -- Things not supported yet: ----- * Type-safe 'SQL'.---+-- * Type-safe 'SQL' strings. -- -- * Probably other things. --@@ -62,6 +65,11 @@ , Input , encode , input+ -- , hintput Do we need to export this?+ -- , HIntput Do we need to export this?+ , InputDefault (..)+ , ginputDefault+ , GInputDefault -- *** Encode , Encode (..)@@ -69,8 +77,9 @@ , EncodeDefault (..) , encodeMaybe , encodeEither- , encodeSizedIntegral+ , encodeNS , encodeAeson+ , encodeAeson' , encodeBinary , encodeShow @@ -78,6 +87,11 @@ , Output , decode , output+ -- , houtput Do we need to export this?+ -- , HOutput Do we need to export this?+ , OutputDefault (..)+ , goutputDefault+ , GOutputDefault -- *** Decode , Decode (..)@@ -85,14 +99,18 @@ , DecodeDefault (..) , decodeMaybe , decodeEither- , decodeSizedIntegral+ , decodeNS+ , decodeBoundedIntegral , decodeAeson+ , decodeAeson' , decodeBinary+ , decodeBinary' , decodeRead -- ** Name , Name , name+ , BindingName (..) -- * Transactional , Transactional@@ -156,10 +174,10 @@ -- * Miscellaneuos , Retry (..)- , BindingName , Mode (..) , SubMode , Null (..)+ , RowId (..) -- * Errors , ErrEncode (..)@@ -168,6 +186,7 @@ , ErrOutput (..) , ErrStatement (..) , ErrRows (..)+ , ErrTransaction (..) -- * Re-exports , S.SQLData (..)@@ -181,11 +200,16 @@ import Control.Monad.Trans.Resource qualified as R import Control.Monad.Trans.Resource.Extra qualified as R import Data.Acquire qualified as A+import Data.Aeson qualified as Ae+import Data.Binary qualified as Bin import Data.Function+import Data.Int import Database.SQLite3 qualified as S import Di.Df1 qualified as Di+import GHC.Generics (Generic) import System.FilePath import Prelude hiding (Read, maybe, read)+import Prelude qualified import Sq.Connection import Sq.Decoders@@ -270,7 +294,10 @@ tempPool :: Di.Df1 -> A.Acquire (Pool Write) tempPool di0 = do d <- acquireTmpDir- pool SWrite (Di.push "sq" di0) $ settings (d </> "db.sqlite")+ let path = d </> "db.sqlite"+ di1 = Di.push "sq" di0+ Di.notice di1 $ "Using temporary database: " <> show path+ pool SWrite di1 $ settings path -- | Acquire a read-'Write' 'Pool' according to the given 'Settings'. --@@ -325,6 +352,35 @@ -> m a rollback p = transactionalRetry $ rollbackTransaction p {-# INLINE rollback #-}++--------------------------------------------------------------------------------++-- | Newtype wrapper for the typical @rowid@ column in SQLite.+--+-- See <https://sqlite.org/rowidtable.html>+newtype RowId = RowId Int64+ deriving newtype+ ( Eq+ , Ord+ , Show+ , Prelude.Read+ , EncodeDefault+ , DecodeDefault+ , Ae.ToJSON+ , Ae.FromJSON+ , Bin.Binary+ )+ deriving stock (Generic)++-- | Uses @rowid@ as 'Name'.+instance InputDefault RowId where+ inputDefault = encode "rowid" encodeDefault+ {-# INLINE inputDefault #-}++-- | Uses @rowid@ as 'Name'.+instance OutputDefault RowId where+ outputDefault = decode "rowid" decodeDefault+ {-# INLINE outputDefault #-} --------------------------------------------------------------------------------
lib/Sq/Connection.hs view
@@ -21,11 +21,11 @@ , savepointRelease , ErrRows (..) , ErrStatement (..)+ , ErrTransaction (..) ) where import Control.Applicative import Control.Concurrent-import Control.Concurrent.Async qualified as Async import Control.Concurrent.STM import Control.DeepSeq import Control.Exception.Safe qualified as Ex@@ -54,9 +54,8 @@ import Di.Df1 qualified as Di import Foreign.C.Types (CInt (..)) import Foreign.Marshal.Alloc (free, malloc)-import Foreign.Ptr (FunPtr, Ptr, freeHaskellFunPtr)+import Foreign.Ptr (FunPtr, Ptr, freeHaskellFunPtr, nullFunPtr, nullPtr) import Foreign.Storable-import GHC.IO (unsafeUnmask) import GHC.Records import GHC.Show import Streaming qualified as Z@@ -98,7 +97,7 @@ -- ^ Database file path. Not an URI. -- -- Note: To keep things simple, native @:memory:@ SQLite databases are not- -- supported. Maybe use 'Sq.poolTemp' or @tmpfs@ if you need that?+ -- supported. Maybe use 'Sq.tempPool' or @tmpfs@ if you need that. , vfs :: S.SQLVFS , timeout :: Word32 -- ^ SQLite busy Timeout in milliseconds.@@ -163,6 +162,9 @@ -- 'S.Database' connection handle at the moment. data ExclusiveConnection (mode :: Mode) = ExclusiveConnection { id :: ConnectionId+ , txint :: IORef (Maybe Bool)+ -- ^ 'Nothing' if no transaction has started,+ -- 'True' if the previously started transaction was interrupted. , run :: forall x. (S.Database -> IO x) -> IO x , statements :: IORef (Map SQL PreparedStatement) }@@ -192,13 +194,7 @@ Just xc -> pure xc Nothing -> Ex.throwString "Timeout" )- (atomically . void . tryPutTMVar c.xconn . Just)--data DatabaseMessage- = forall x.- DatabaseMessage- (S.Database -> IO x)- (Either Ex.SomeException x -> IO ())+ (atomically . putTMVar c.xconn . Just) warningOnException :: (MonadIO m, Ex.MonadMask m)@@ -216,63 +212,58 @@ exclusiveConnection smode di0 cs = do cId :: ConnectionId <- newConnectionId let di1 = Di.attr "connection-mode" smode $ Di.attr "connection" cId di0- dms :: MVar DatabaseMessage <-- R.mkAcquire1 newEmptyMVar (fmap (const ()) . tryTakeMVar)- abackground :: Async.Async () <-+ db :: S.Database <- R.mkAcquire1- (Async.async (background di1 (takeMVar dms)))- Async.uninterruptibleCancel- -- TODO: Async.link should be sufficient. Figure out what I'm doing wrong.- liftIO $ flip Async.linkOnly abackground \se ->- Just Async.AsyncCancelled == Ex.fromException se+ ( do+ let di2 = Di.push "connect" di1+ db <- warningOnException di2 do+ S.open2 (T.pack cs.file) (modeFlags (fromSMode smode)) cs.vfs+ Di.debug_ di2 "OK"+ pure db+ )+ ( \db -> do+ let di2 = Di.push "disconnect" di1+ warningOnException di1 $ S.close db+ Di.debug_ di2 "OK"+ )+ setBusyHandler db cs.timeout+ liftIO $+ traverse_+ (S.exec db)+ [ "PRAGMA synchronous=NORMAL"+ , "PRAGMA journal_size_limit=67108864" -- 64 MiB+ , "PRAGMA mmap_size=134217728" -- 128 MiB+ , "PRAGMA cache_size=-65536" -- ~64 MiB (negative = kibibytes)+ ] statements :: IORef (Map SQL PreparedStatement) <- R.mkAcquire1 (newIORef mempty) \r -> atomicModifyIORef' r (mempty,) >>= traverse_ \ps -> Ex.tryAny (S.finalize ps.handle)+ txint <- liftIO $ newIORef Nothing+ runlock <- R.mkAcquire1 (newMVar ()) takeMVar pure ( di1 , ExclusiveConnection { statements+ , txint , id = cId- , run = \ !act -> do- mv <- newEmptyMVar- putMVar dms $! DatabaseMessage act $ putMVar mv- takeMVar mv >>= either Ex.throwM pure+ , run = \act -> withMVar runlock \() -> Ex.mask \restore -> do+ mx <- newEmptyMVar+ th <- forkIO $ Ex.tryAsync (restore (act db)) >>= putMVar mx+ Ex.tryAsync (takeMVar mx) >>= \case+ Right (Right x) -> pure x+ Right (Left (se :: Ex.SomeException)) -> Ex.throwM se+ Left (se :: Ex.SomeException) -> Ex.uninterruptibleMask_ do+ when (Ex.isAsyncException se) do+ void $ Ex.tryAny do+ S.interrupt db >> killThread th >> takeMVar mx+ -- We deal with txint later during tx release+ atomicModifyIORef' txint \case+ Nothing -> (Nothing, ())+ Just _ -> (Just True, ())+ Ex.throwM se } )- where- background :: forall x. Di.Df1 -> IO DatabaseMessage -> IO x- background di1 next = R.runResourceT do- (_, db) <-- R.allocate- ( do- let di2 = Di.push "connect" di1- db <- warningOnException di2 do- S.open2 (T.pack cs.file) (modeFlags (fromSMode smode)) cs.vfs- Di.debug_ di2 "OK"- pure db- )- ( \db -> do- let di2 = Di.push "disconnect" di1- warningOnException di1 do- Ex.finally- (Ex.uninterruptibleMask_ (S.interrupt db))- (S.close db)- Di.debug_ di2 "OK"- )- warningOnException (Di.push "set-busy-handler" di1) do- setBusyHandler db cs.timeout- liftIO $- traverse_- (S.exec db)- [ "PRAGMA synchronous=NORMAL"- , "PRAGMA journal_size_limit=67108864" -- 64 MiB- , "PRAGMA mmap_size=134217728" -- 128 MiB- , "PRAGMA cache_size=2000" -- 2000 pages- ]- liftIO $ forever do- DatabaseMessage act res <- next- Ex.try (unsafeUnmask (act db)) >>= res -------------------------------------------------------------------------------- @@ -284,6 +275,16 @@ -> Ptr a -> IO CInt +c_sqlite3_busy_handler'+ :: Ptr S.CDatabase+ -> FunPtr (Ptr a -> CInt -> IO CInt)+ -> Ptr a+ -> IO ()+c_sqlite3_busy_handler' pDB pF pX = do+ n <- c_sqlite3_busy_handler pDB pF pX+ when (n /= 0) do+ Ex.throwString $ "sqlite3_busy_handler: return " <> show n+ -- | Returns same as input. foreign import ccall safe "sqlite3_sleep" c_sqlite3_sleep@@ -296,14 +297,13 @@ :: (Ptr Clock.TimeSpec -> CInt -> IO CInt) -> IO (FunPtr (Ptr Clock.TimeSpec -> CInt -> IO CInt)) -setBusyHandler :: (R.MonadResource m) => S.Database -> Word32 -> m ()+setBusyHandler :: S.Database -> Word32 -> A.Acquire () setBusyHandler (S.Database pDB) tmaxMS = do- (_, pHandler) <- R.allocate (createBusyHandlerPtr handler) freeHaskellFunPtr- (_, pTimeSpec) <- R.allocate malloc free- liftIO do- n <- c_sqlite3_busy_handler pDB pHandler pTimeSpec- when (n /= 0) do- Ex.throwString $ "sqlite3_busy_handler: return " <> show n+ pHandler <- R.mkAcquire1 (createBusyHandlerPtr handler) freeHaskellFunPtr+ pTimeSpec <- R.mkAcquire1 malloc free+ R.mkAcquire1+ (c_sqlite3_busy_handler' pDB pHandler pTimeSpec)+ (\_ -> c_sqlite3_busy_handler' pDB nullFunPtr nullPtr) where tmaxNS :: Integer !tmaxNS = fromIntegral tmaxMS * 1_000_000@@ -342,7 +342,8 @@ -- While the 'Transaction' is active, an exclusive lock is held on the -- underlying 'Connection'.-data Transaction (t :: Mode) = forall c.+data Transaction (t :: Mode)+ = forall c. (SubMode c t) => Transaction { _id :: TransactionId@@ -374,19 +375,9 @@ xc <- lockConnection c tId <- newTransactionId let di1 = Di.attr "transaction-mode" Read $ Di.attr "transaction" tId c.di- R.mkAcquireType1- ( do- let di2 = Di.push "begin" di1- warningOnException di2 $ run xc (flip S.exec "BEGIN DEFERRED")- Di.debug_ di2 "OK"- )- ( \_ rt -> do- let di2 = Di.push "rollback" di1- for_ (releaseTypeException rt) \e ->- Di.notice di2 $ "Will rollback due to: " <> show e- warningOnException di2 $ run xc (flip S.exec "ROLLBACK")- Di.debug_ di2 "OK"- )+ unsafeBegin di1 False xc+ R.mkAcquireType1 (pure ()) \_ rt ->+ unsafeRollback di1 (releaseTypeException rt) xc xconn <- R.mkAcquire1 (newTMVarIO (Just xc)) \t -> atomically $ tryTakeTMVar t >> putTMVar t Nothing pure $@@ -398,6 +389,63 @@ , smode = SRead } +-- | Internal. The handling of 'txint' between unsafeBegin,+-- unsafeCommit and unsafeRollback is awkard.+unsafeBegin+ :: Di.Df1+ -> Bool+ -- ^ @IMMEDIATE@?+ -> ExclusiveConnection c+ -> A.Acquire ()+unsafeBegin di0 im xc = do+ let di1 = Di.push "begin" di0+ R.mkAcquire1+ ( warningOnException di1 do+ readIORef xc.txint >>= \case+ Nothing -> pure ()+ _ -> Ex.throwString "Nested transaction. Should never happen."+ run xc \db -> do+ S.exec db $ "BEGIN " <> if im then "IMMEDIATE" else "DEFERRED"+ atomicWriteIORef xc.txint $ Just False+ Di.debug_ di1 "OK"+ )+ (\() -> atomicWriteIORef xc.txint Nothing)++-- | Internal+unsafeCommit+ :: Di.Df1+ -> ExclusiveConnection c+ -> IO ()+unsafeCommit di0 xc = do+ let di1 = Di.push "commit" di0+ warningOnException di1 do+ readIORef xc.txint >>= \case+ Just False -> do+ run xc (flip S.exec "COMMIT")+ Di.debug_ di1 "OK"+ Just True -> Ex.throwM ErrTransaction_Interrupted+ Nothing ->+ Ex.throwString "No transaction. Should never happen."++-- | Internal+unsafeRollback+ :: Di.Df1+ -> Maybe Ex.SomeException+ -> ExclusiveConnection c+ -> IO ()+unsafeRollback di0 ye xc = do+ let di1 = Di.push "rollback" di0+ warningOnException di1 do+ readIORef xc.txint >>= \case+ Just False -> do+ for_ ye \e -> Di.notice di1 $ "Will rollback due to: " <> show e+ run xc (flip S.exec "ROLLBACK")+ Di.debug_ di1 "OK"+ Just True ->+ Di.info_ di1 "Previously interrupted, no need to rollback"+ Nothing ->+ Ex.throwString "No transaction. Should never happen."+ connectionWriteTransaction :: Bool -- ^ Whether to finally @COMMIT@ the transaction.@@ -410,26 +458,13 @@ let di1 = Di.attr_ "transaction-mode" (if commit then "commit" else "rollback") $ Di.attr "transaction" tId c.di- rollback (ye :: Maybe Ex.SomeException) = do- let di2 = Di.push "rollback" di1- for_ ye \e -> Di.notice di2 $ "Will rollback due to: " <> show e- warningOnException di2 $ run xc (flip S.exec "ROLLBACK")- Di.debug_ di2 "OK"- R.mkAcquireType1- ( do- let di2 = Di.push "begin" di1- warningOnException di2 $ run xc (flip S.exec "BEGIN IMMEDIATE")- Di.debug_ di2 "OK"- )- ( \_ rt -> case releaseTypeException rt of+ unsafeBegin di1 True xc+ R.mkAcquireType1 (pure ()) \_ rt ->+ case releaseTypeException rt of Nothing- | commit -> do- let di2 = Di.push "commit" di1- warningOnException di2 $ run xc (flip S.exec "COMMIT")- Di.debug_ di2 "OK"- | otherwise -> rollback Nothing- Just e -> rollback (Just e)- )+ | commit -> unsafeCommit di1 xc+ | otherwise -> unsafeRollback di1 Nothing xc+ Just e -> unsafeRollback di1 (Just e) xc xconn <- R.mkAcquire1 (newTMVarIO (Just xc)) \t -> atomically $ tryTakeTMVar t >> putTMVar t Nothing pure $@@ -440,6 +475,17 @@ , commit , smode = SWrite }++data ErrTransaction+ = -- | A the database connection was 'S.interrupt'ed but a @COMMIT@ is still+ -- pending.+ --+ -- This exception happens if you swallowed an asynchronous exception+ -- before releasing a 'Write' 'Transaction'. Just don't do that. Make+ -- sure the 'Transaction' is released through 'A.ReleaseExceptionWith'.+ ErrTransaction_Interrupted+ deriving stock (Eq, Show)+ deriving anyclass (Ex.Exception) --------------------------------------------------------------------------------
lib/Sq/Decoders.hs view
@@ -5,10 +5,13 @@ , DecodeDefault (..) , decodeMaybe , decodeEither- , decodeSizedIntegral+ , decodeNS+ , decodeBoundedIntegral , decodeBinary+ , decodeBinary' , decodeRead , decodeAeson+ , decodeAeson' ) where import Control.Applicative@@ -17,28 +20,43 @@ import Control.Monad.Catch qualified as Ex (MonadThrow (..)) import Control.Monad.Trans.Reader import Data.Aeson qualified as Ae+import Data.Aeson.Key qualified as Aek+import Data.Aeson.Parser qualified as Aep import Data.Aeson.Types qualified as Ae+import Data.Attoparsec.ByteString qualified as AB+import Data.Attoparsec.Text qualified as AT+import Data.Attoparsec.Time qualified as AT8601 import Data.Bifunctor+import Data.Binary qualified as Bin import Data.Binary.Get qualified as Bin import Data.Bits import Data.ByteString qualified as B import Data.ByteString.Builder.Prim.Internal (caseWordSize_32_64) import Data.ByteString.Lazy qualified as BL+import Data.Fixed import Data.Int+import Data.Proxy+import Data.SOP qualified as SOP+import Data.Scientific qualified as Sci import Data.Text qualified as T+import Data.Text.Encoding qualified as T import Data.Text.Lazy qualified as TL import Data.Text.Unsafe qualified as T import Data.Time qualified as Time import Data.Time.Clock.POSIX qualified as Time+import Network.URI qualified as URI+ import Data.Time.Format.ISO8601 qualified as Time+import Data.UUID.Types qualified as UUID import Data.Word import Database.SQLite3 qualified as S import GHC.Float (double2Float, float2Double) import GHC.Stack import Numeric.Natural-import Text.Read (readEither, readMaybe)+import Text.Read (readEither) import Sq.Null (Null)+import Sq.Support -------------------------------------------------------------------------------- @@ -91,6 +109,11 @@ deriving stock (Show) deriving anyclass (Ex.Exception) +errDecodeFailString :: (HasCallStack) => String -> ErrDecode+errDecodeFailString s =+ ErrDecode_Fail $ Ex.toException $ Ex.StringException s ?callStack+{-# INLINE errDecodeFailString #-}+ -------------------------------------------------------------------------------- sqlDataColumnType :: S.SQLData -> S.ColumnType@@ -114,9 +137,7 @@ -> Decode b decodeRefine f (Decode g) = Decode \raw -> do a <- g raw- case f a of- Right b -> Right b- Left s -> first ErrDecode_Fail (Ex.throwString s)+ first errDecodeFailString (f a) -------------------------------------------------------------------------------- -- Core decodes@@ -136,30 +157,35 @@ -- | 'S.IntegerColumn'. instance DecodeDefault Int64 where+ {-# INLINE decodeDefault #-} decodeDefault = Decode \case S.SQLInteger x -> Right x x -> Left $ ErrDecode_Type (sqlDataColumnType x) [S.IntegerColumn] -- | 'S.FloatColumn'. instance DecodeDefault Double where+ {-# INLINE decodeDefault #-} decodeDefault = Decode \case S.SQLFloat x -> Right x x -> Left $ ErrDecode_Type (sqlDataColumnType x) [S.FloatColumn] -- | 'S.TextColumn'. instance DecodeDefault T.Text where+ {-# INLINE decodeDefault #-} decodeDefault = Decode \case S.SQLText x -> Right x x -> Left $ ErrDecode_Type (sqlDataColumnType x) [S.TextColumn] -- | 'S.BlobColumn'. instance DecodeDefault B.ByteString where+ {-# INLINE decodeDefault #-} decodeDefault = Decode \case S.SQLBlob x -> Right x x -> Left $ ErrDecode_Type (sqlDataColumnType x) [S.BlobColumn] -- | 'S.NullColumn'. instance DecodeDefault Null where+ {-# INLINE decodeDefault #-} decodeDefault = Decode \case S.SQLNull -> Right mempty x -> Left $ ErrDecode_Type (sqlDataColumnType x) [S.NullColumn]@@ -169,36 +195,47 @@ -- | 'S.TextColumn'. instance DecodeDefault TL.Text where- decodeDefault = TL.fromStrict <$> decodeDefault {-# INLINE decodeDefault #-}+ decodeDefault =+ {-# SCC "decodeDefault/TextLazy" #-}+ (TL.fromStrict <$> decodeDefault) -- | 'S.TextColumn'. instance DecodeDefault Char where- decodeDefault = flip decodeRefine decodeDefault \t ->- if T.length t == 1- then Right (T.unsafeHead t)- else Left "Expected single character string"+ decodeDefault =+ {-# SCC "decodeDefault/Char" #-}+ ( flip decodeRefine decodeDefault \t ->+ if T.length t == 1+ then Right (T.unsafeHead t)+ else Left "Expected single character string"+ ) -- | 'S.TextColumn'. instance DecodeDefault String where- decodeDefault = T.unpack <$> decodeDefault {-# INLINE decodeDefault #-}+ decodeDefault =+ {-# SCC "decodeDefault/String" #-}+ (T.unpack <$> decodeDefault) -- | 'S.BlobColumn'. instance DecodeDefault BL.ByteString where- decodeDefault = BL.fromStrict <$> decodeDefault {-# INLINE decodeDefault #-}+ decodeDefault =+ {-# SCC "decodeDefault/ByteStringLazy" #-}+ (BL.fromStrict <$> decodeDefault) -- | See 'decodeMaybe'. instance (DecodeDefault a) => DecodeDefault (Maybe a) where decodeDefault = decodeMaybe decodeDefault {-# INLINE decodeDefault #-} --- | Attempt to decode @a@ first, otherwise attempt decode--- a 'S.NullColumn' as 'Nothing'.+-- | Attempt to decode @a@ first, or a 'S.NullColumn' as 'Nothing' otherwise. decodeMaybe :: Decode a -> Decode (Maybe a)-decodeMaybe da = fmap Just da <|> fmap (\_ -> Nothing) (decodeDefault @Null)-{-# INLINE decodeMaybe #-}+decodeMaybe (Decode fa) = Decode \d -> case fa d of+ Right a -> Right (Just a)+ Left e -> case d of+ S.SQLNull -> Right Nothing+ _ -> Left e -- | See 'decodeEither'. instance@@ -211,106 +248,168 @@ -- | @ -- 'decodeEither' da db = fmap 'Left' da '<|>' fmap 'Right' db -- @+--+-- __WARNING__ This is probably not what you are looking for. The+-- underlying 'S.SQLData' doesn't carry any /tag/ for discriminating+-- between @a@ and @b@. decodeEither :: Decode a -> Decode b -> Decode (Either a b) decodeEither da db = fmap Left da <|> fmap Right db-{-# INLINE decodeEither #-} +-- | See 'decodeNS'.+instance+ (SOP.All DecodeDefault xs)+ => DecodeDefault (SOP.NS SOP.I xs)+ where+ {-# INLINE decodeDefault #-}+ decodeDefault =+ {-# SCC "decodeDefault/SOP.NS" #-}+ decodeNS (SOP.hcpure (Proxy @DecodeDefault) decodeDefault)++-- | Like 'decodeEither', but for arbitraryly large "Data.SOP".'NS' sums.+--+-- __WARNING__ This is probably not what you are looking for. The underlying+-- 'S.SQLData' doesn't carry any /tag/ for discriminating among @xs@.+decodeNS :: SOP.NP Decode xs -> Decode (SOP.NS SOP.I xs)+decodeNS = hasum+ -- | 'S.IntegerColumn', 'S.FloatColumn', 'S.TextColumn' -- depicting a literal integer. instance DecodeDefault Integer where- decodeDefault = Decode \case- S.SQLInteger i -> Right (fromIntegral i)- S.SQLFloat d- | not (isNaN d || isInfinite d)- , (i, 0) <- properFraction d ->- Right i- | otherwise -> first ErrDecode_Fail do- Ex.throwString "Not an integer"- S.SQLText t- | Just i <- readMaybe (T.unpack t) -> Right i- | otherwise -> first ErrDecode_Fail do- Ex.throwString "Not an integer"- x -> Left $ ErrDecode_Type (sqlDataColumnType x) do- [S.IntegerColumn, S.FloatColumn, S.TextColumn]+ decodeDefault =+ {-# SCC "decodeDefault/Integer" #-}+ ( Decode \case+ S.SQLInteger i -> Right (fromIntegral i)+ S.SQLText t -> case scientificFromText t of+ Just s -> case Sci.floatingOrInteger s of+ Right ~i+ | sciIntegerMin <= s && s <= sciIntegerMax -> Right i+ | otherwise -> Left $ errDecodeFailString "Integer too large"+ Left (_ :: Double) -> Left $ errDecodeFailString "Not an integer"+ Nothing -> Left $ errDecodeFailString "Malformed number"+ S.SQLFloat d+ | isNaN d -> Left $ errDecodeFailString "NaN"+ | isInfinite d -> Left $ errDecodeFailString "Infinity"+ | (i, 0) <- properFraction d, d == fromIntegral i -> Right i+ | otherwise -> Left $ errDecodeFailString "Lossy conversion"+ x -> Left $ ErrDecode_Type (sqlDataColumnType x) do+ [S.IntegerColumn, S.FloatColumn, S.TextColumn]+ ) --- | 'S.IntegerColumn'.-decodeSizedIntegral :: (Integral a, Bits a) => Decode a-decodeSizedIntegral = do- i <- decodeDefault @Integer- case toIntegralSized i of- Just a -> pure a- Nothing -> fail "Integral overflow or underflow"+-- | Some probably large enough numbers.+sciIntegerMax :: Sci.Scientific+sciIntegerMax = Sci.scientific 1 (fromIntegral (maxBound :: Int16)) +-- | Some probably large enough numbers.+sciIntegerMin :: Sci.Scientific+sciIntegerMin = Sci.scientific (-1) (fromIntegral (maxBound :: Int16))++-- | 'S.IntegerColumn', 'S.FloatColumn', 'S.TextColumn'.+decodeBoundedIntegral :: forall a. (Integral a, Bounded a, Bits a) => Decode a+decodeBoundedIntegral = Decode \case+ S.SQLInteger i -> f i+ S.SQLText t -> case scientificFromText t of+ Just s+ | Sci.isInteger s -> case Sci.toBoundedInteger s of+ Just a -> Right a+ Nothing -> Left $ errDecodeFailString "Overflow or underflow"+ | otherwise -> Left $ errDecodeFailString "Not an integer"+ Nothing -> Left $ errDecodeFailString "Malformed number"+ S.SQLFloat d+ | isNaN d -> Left $ errDecodeFailString "NaN"+ | isInfinite d -> Left $ errDecodeFailString "Infinity"+ | (i :: Integer, 0) <- properFraction d ->+ case f i of+ Right a+ | d == fromIntegral a -> Right a+ | otherwise -> Left $ errDecodeFailString "Lossy conversion"+ Left e -> Left e+ | otherwise -> Left $ errDecodeFailString "Not an integer"+ x -> Left $ ErrDecode_Type (sqlDataColumnType x) do+ [S.IntegerColumn, S.FloatColumn, S.TextColumn]+ where+ f :: (Bits i, Integral i) => i -> Either ErrDecode a+ f i = case toIntegralSized i of+ Just a -> Right a+ Nothing -> Left $ errDecodeFailString "Overflow or underflow"+ -- | 'S.IntegerColumn'. instance DecodeDefault Int8 where- decodeDefault = decodeSizedIntegral+ decodeDefault = decodeBoundedIntegral {-# INLINE decodeDefault #-} -- | 'S.IntegerColumn'. instance DecodeDefault Word8 where- decodeDefault = decodeSizedIntegral+ decodeDefault = decodeBoundedIntegral {-# INLINE decodeDefault #-} -- | 'S.IntegerColumn'. instance DecodeDefault Int16 where- decodeDefault = decodeSizedIntegral+ decodeDefault = decodeBoundedIntegral {-# INLINE decodeDefault #-} -- | 'S.IntegerColumn'. instance DecodeDefault Word16 where- decodeDefault = decodeSizedIntegral+ decodeDefault = decodeBoundedIntegral {-# INLINE decodeDefault #-} -- | 'S.IntegerColumn'. instance DecodeDefault Int32 where- decodeDefault = decodeSizedIntegral+ decodeDefault = decodeBoundedIntegral {-# INLINE decodeDefault #-} -- | 'S.IntegerColumn'. instance DecodeDefault Word32 where- decodeDefault = decodeSizedIntegral+ decodeDefault = decodeBoundedIntegral {-# INLINE decodeDefault #-} -- | 'S.IntegerColumn' if it fits in 'Int64', otherwise 'S.TextColumn'. instance DecodeDefault Word where- decodeDefault = decodeSizedIntegral+ decodeDefault = decodeBoundedIntegral {-# INLINE decodeDefault #-} -- | 'S.IntegerColumn' if it fits in 'Int64', otherwise 'S.TextColumn'. instance DecodeDefault Word64 where- decodeDefault = decodeSizedIntegral+ decodeDefault = decodeBoundedIntegral {-# INLINE decodeDefault #-} -- | 'S.IntegerColumn'. instance DecodeDefault Int where decodeDefault = caseWordSize_32_64- decodeSizedIntegral+ decodeBoundedIntegral (fromIntegral <$> decodeDefault @Int64) {-# INLINE decodeDefault #-} -- | 'S.IntegerColumn' if it fits in 'Int64', otherwise 'S.TextColumn'. instance DecodeDefault Natural where- decodeDefault = decodeSizedIntegral+ decodeDefault =+ decodeRefine+ (note "Underflow" . toIntegralSized)+ (decodeDefault @Integer) {-# INLINE decodeDefault #-} -- | 'S.IntegerColumn' and 'S.FloatColumn' only. -- -- @0@ is 'False', every other number is 'True'. instance DecodeDefault Bool where- decodeDefault = Decode \case- S.SQLInteger x -> Right (x /= 0)- S.SQLFloat x -> Right (x /= 0)- x ->- Left $- ErrDecode_Type- (sqlDataColumnType x)- [S.IntegerColumn, S.FloatColumn]+ decodeDefault =+ {-# SCC "decodeDefault/Bool" #-}+ ( Decode \case+ S.SQLInteger x -> Right (x /= 0)+ S.SQLFloat x -> Right (x /= 0)+ x ->+ Left $+ ErrDecode_Type+ (sqlDataColumnType x)+ [S.IntegerColumn, S.FloatColumn]+ ) -- | Like for 'Time.ZonedTime'. instance DecodeDefault Time.UTCTime where- decodeDefault = Time.zonedTimeToUTC <$> decodeDefault {-# INLINE decodeDefault #-}+ decodeDefault =+ {-# SCC "decodeDefault/UTCTime" #-}+ (Time.zonedTimeToUTC <$> decodeDefault) -- | 'S.TextColumn' ('Time.ISO8601', or seconds since Epoch with optional decimal -- part of up to picosecond precission), or 'S.Integer' (seconds since Epoch).@@ -318,78 +417,190 @@ -- TODO: Currently precission over picoseconds is successfully parsed but -- silently floored. This is an issue in "Data.Time.Format.ISO8601". Fix. instance DecodeDefault Time.ZonedTime where- decodeDefault = Decode \case- S.SQLText (T.unpack -> s)- | Just zt <- Time.iso8601ParseM s -> Right zt- | Just u <- Time.iso8601ParseM s ->- Right $ Time.utcToZonedTime Time.utc u- | Just u <- Time.parseTimeM False Time.defaultTimeLocale "%s%Q" s ->- Right $ Time.utcToZonedTime Time.utc u- | otherwise -> first ErrDecode_Fail do- Ex.throwString $ "Invalid timestamp: " <> show s- S.SQLInteger i ->- Right $- Time.utcToZonedTime Time.utc $- Time.posixSecondsToUTCTime $- fromIntegral i- x ->- Left $- ErrDecode_Type- (sqlDataColumnType x)- [S.IntegerColumn, S.TextColumn]+ decodeDefault =+ {-# SCC "decodeDefault/ZonedTime" #-}+ ( Decode \case+ S.SQLText t -> case AT.parseOnly pzt t of+ Right zt -> Right zt+ Left e -> first ErrDecode_Fail do+ Ex.throwString $ "Invalid timestamp: " <> show e+ S.SQLInteger i ->+ Right $+ Time.utcToZonedTime Time.utc $+ Time.posixSecondsToUTCTime $+ fromIntegral i+ x ->+ Left $+ ErrDecode_Type+ (sqlDataColumnType x)+ [S.IntegerColumn, S.TextColumn]+ )+ where+ pzt =+ mplus+ ({-# SCC zonedTime #-} AT8601.zonedTime <* AT.endOfInput)+ ({-# SCC psecs #-} psecs <* AT.endOfInput)+ psecs = do+ s <- AT.scientific+ let pico :: Pico = MkFixed $ floor (s * 1_000_000_000_000)+ ndt :: Time.NominalDiffTime = Time.secondsToNominalDiffTime pico+ pure $ Time.utcToZonedTime Time.utc $ Time.posixSecondsToUTCTime ndt -- | 'Time.ISO8601' in a @'S.TextColumn'. instance DecodeDefault Time.LocalTime where- decodeDefault = decodeDefault >>= Time.iso8601ParseM {-# INLINE decodeDefault #-}+ decodeDefault =+ {-# SCC "decodeDefault/LocalTime" #-}+ ( decodeRefine+ (AT.parseOnly (AT8601.localTime <* AT.endOfInput))+ decodeDefault+ ) -- | 'Time.ISO8601' in a @'S.TextColumn'. instance DecodeDefault Time.Day where- decodeDefault = decodeDefault >>= Time.iso8601ParseM {-# INLINE decodeDefault #-}+ decodeDefault =+ {-# SCC "decodeDefault/Day" #-}+ ( decodeRefine+ (AT.parseOnly (AT8601.day <* AT.endOfInput))+ decodeDefault+ ) -- | 'Time.ISO8601' in a @'S.TextColumn'. -- -- TODO: Currently precission over picoseconds is successfully parsed but -- silently floored. This is an issue in "Data.Time.Format.ISO8601". Fix. instance DecodeDefault Time.TimeOfDay where- decodeDefault = decodeDefault >>= Time.iso8601ParseM {-# INLINE decodeDefault #-}+ decodeDefault =+ {-# SCC "decodeDefault/TimeOfDay" #-}+ ( decodeRefine+ (AT.parseOnly (AT8601.timeOfDay <* AT.endOfInput))+ decodeDefault+ ) -- | 'Time.ISO8601' in a @'S.TextColumn'. -- -- TODO: Currently precission over picoseconds is successfully parsed but -- silently floored. This is an issue in "Data.Time.Format.ISO8601". Fix. instance DecodeDefault Time.CalendarDiffDays where- decodeDefault = decodeDefault >>= Time.iso8601ParseM {-# INLINE decodeDefault #-}+ decodeDefault =+ {-# SCC "decodeDefault/CalendarDiffDays" #-}+ (decodeDefault >>= Time.iso8601ParseM) -- | 'Time.ISO8601' in a @'S.TextColumn'. -- -- TODO: Currently precission over picoseconds is successfully parsed but -- silently floored. This is an issue in "Data.Time.Format.ISO8601". Fix. instance DecodeDefault Time.CalendarDiffTime where- decodeDefault = decodeDefault >>= Time.iso8601ParseM {-# INLINE decodeDefault #-}+ decodeDefault =+ {-# SCC "decodeDefault/CalendarDiffTime" #-}+ (decodeDefault >>= Time.iso8601ParseM) -- | 'Time.ISO8601' in a @'S.TextColumn'. instance DecodeDefault Time.TimeZone where- decodeDefault = decodeDefault >>= Time.iso8601ParseM {-# INLINE decodeDefault #-}+ decodeDefault =+ {-# SCC "decodeDefault/TimeZone" #-}+ ( flip decodeRefine decodeDefault \t ->+ case AT.parseOnly (AT8601.timeZone <* AT.endOfInput) t of+ Right (Just tz) -> Right tz+ Right Nothing -> Left "Not a valid time zone"+ Left s -> Left ("Not a valid time zone: " <> show s)+ ) -- | 'S.FloatColumn'. instance DecodeDefault Float where- decodeDefault = flip decodeRefine decodeDefault \d -> do- let f = double2Float d- if float2Double f == d- then Right f- else Left "Lossy conversion from Double to Float"+ decodeDefault =+ {-# SCC "decodeDefault/Float" #-}+ ( flip decodeRefine decodeDefault \d -> do+ let f = double2Float d+ if float2Double f == d+ then Right f+ else Left "Lossy conversion"+ ) +-- | 'S.TextColumn'.+instance DecodeDefault UUID.UUID where+ decodeDefault =+ {-# SCC "decodeDefault/UUID" #-}+ ( decodeRefine+ (note "Not valid UUID" . UUID.fromText)+ decodeDefault+ )++-- | 'S.TextColumn'.+instance DecodeDefault Ae.Value where+ decodeDefault =+ {-# SCC "decodeDefault/Ae.Value" #-}+ (decodeRefine Ae.eitherDecodeStrictText decodeDefault)++-- | 'S.TextColumn'.+instance DecodeDefault Aek.Key where+ decodeDefault = Aek.fromText <$> decodeDefault++-- | 'S.IntegerColumn', 'S.FloatColumn', 'S.TextColumn'.+instance forall e. (HasResolution e) => DecodeDefault (Fixed e) where+ decodeDefault =+ {-# SCC "decodeDefault/Fixed" #-}+ ( decodeRefine+ ( \s0 ->+ let s1 = s0 * smult+ in case Sci.floatingOrInteger s1 of+ Right ~i+ | sciIntegerMin <= s1 && s1 <= sciIntegerMax ->+ Right (MkFixed i)+ | otherwise -> Left "Integer too large"+ Left (_ :: Double) -> Left "Lossy conversion"+ )+ decodeDefault+ )+ where+ smult :: Sci.Scientific+ smult = fromInteger (resolution (Proxy @e))++-- | 'S.IntegerColumn', 'S.FloatColumn', 'S.TextColumn'.+instance DecodeDefault Sci.Scientific where+ decodeDefault =+ {-# SCC "decodeDefault/Scientific" #-}+ ( Decode \case+ S.SQLInteger i -> Right (fromIntegral i)+ S.SQLText t -> case scientificFromText t of+ Just x -> Right x+ Nothing -> Left $ errDecodeFailString "Malformed number"+ S.SQLFloat d+ | isNaN d -> Left $ errDecodeFailString "NaN"+ | isInfinite d -> Left $ errDecodeFailString "Infinity"+ | x <- Sci.fromFloatDigits d+ , d == Sci.toRealFloat x ->+ Right x+ | otherwise ->+ Left $ errDecodeFailString "Lossy conversion"+ c ->+ Left $ ErrDecode_Type (sqlDataColumnType c) do+ [S.IntegerColumn, S.FloatColumn, S.TextColumn]+ )++scientificFromText :: T.Text -> Maybe Sci.Scientific+scientificFromText = hush . AB.parseOnly Aep.scientific . T.encodeUtf8++-- | 'S.TextColumn'. Uses @'URI.parseURIReference', which supports both absolute+-- and relative 'URI.URI's with optional fragment identifiers.+instance DecodeDefault URI.URI where+ decodeDefault =+ decodeRefine (note "Invalid URI" . URI.parseURIReference) decodeDefault+ -------------------------------------------------------------------------------- +-- @'decodeBinary' = 'decodeBinary'' "Data.Binary".'Bin.get'@+decodeBinary :: (Bin.Binary a) => Decode a+decodeBinary = decodeBinary' Bin.get+ -- | 'S.BlobColumn'.-decodeBinary :: Bin.Get a -> Decode a-decodeBinary ga = flip decodeRefine (decodeDefault @BL.ByteString) \bl ->+decodeBinary' :: Bin.Get a -> Decode a+decodeBinary' ga = flip decodeRefine (decodeDefault @BL.ByteString) \bl -> case Bin.runGetOrFail ga bl of Right (_, _, a) -> Right a Left (_, _, s) -> Left s@@ -397,12 +608,11 @@ -- | 'S.TextColumn'. decodeRead :: (Prelude.Read a) => Decode a decodeRead = decodeRefine readEither (decodeDefault @String)-{-# INLINE decodeRead #-} +-- | @'decodeAeson' = 'decodeAeson'' "Data.Aeson".'Ae.parseJSON'@+decodeAeson :: (Ae.FromJSON a) => Decode a+decodeAeson = decodeAeson' Ae.parseJSON+ -- | 'S.TextColumn'.-decodeAeson :: forall a. (Ae.Value -> Ae.Parser a) -> Decode a-decodeAeson p =- decodeRefine- (Ae.eitherDecodeStrictText >=> Ae.parseEither p)- (decodeDefault @T.Text)-{-# INLINE decodeAeson #-}+decodeAeson' :: (Ae.Value -> Ae.Parser a) -> Decode a+decodeAeson' p = decodeRefine (Ae.parseEither p) (decodeDefault @Ae.Value)
lib/Sq/Encoders.hs view
@@ -5,38 +5,50 @@ , EncodeDefault (..) , encodeMaybe , encodeEither- , encodeSizedIntegral+ , encodeNS , encodeBinary , encodeShow , encodeAeson+ , encodeAeson' ) where import Control.Exception.Safe qualified as Ex import Data.Aeson qualified as Ae-import Data.Aeson.Text qualified as Ae+import Data.Aeson.Key qualified as Aek import Data.Bifunctor+import Data.Binary qualified as Bin import Data.Binary.Put qualified as Bin-import Data.Bits import Data.Bool import Data.ByteString qualified as B import Data.ByteString.Builder qualified as BB import Data.ByteString.Lazy qualified as BL import Data.ByteString.Short qualified as BS import Data.Coerce+import Data.Fixed import Data.Functor.Contravariant+import Data.Functor.Contravariant.Rep import Data.Int import Data.List qualified as List+import Data.Profunctor+import Data.Proxy+import Data.SOP qualified as SOP+import Data.Scientific qualified as Sci import Data.Text qualified as T import Data.Text.Lazy qualified as TL import Data.Text.Lazy.Builder qualified as TB+import Data.Text.Lazy.Builder.Scientific qualified as Sci+import Data.Text.Lazy.Encoding qualified as TL import Data.Time qualified as Time import Data.Time.Format.ISO8601 qualified as Time+import Data.UUID.Types qualified as UUID import Data.Void import Data.Word import Database.SQLite3 qualified as S import GHC.Float (float2Double) import GHC.Stack+import Math.NumberTheory.Logarithms+import Network.URI qualified as URI import Numeric.Natural import Sq.Null (Null)@@ -60,6 +72,13 @@ Encode (a -> Either ErrEncode S.SQLData) deriving (Contravariant) via Op (Either ErrEncode S.SQLData) +instance Representable Encode where+ type Rep Encode = Either ErrEncode S.SQLData+ tabulate = coerce+ {-# INLINE tabulate #-}+ index = coerce+ {-# INLINE index #-}+ unEncode :: Encode a -> a -> Either ErrEncode S.SQLData unEncode = coerce {-# INLINE unEncode #-}@@ -163,10 +182,35 @@ encodeDefault = encodeEither encodeDefault encodeDefault -- | @a@'s 'S.ColumnType' if 'Left', otherwise @b@'s 'S.ColumnType'.+--+-- __WARNING__ This is probably not what you are looking for. The+-- underlying 'S.SQLData' won't carry any /tag/ for discriminating+-- between @a@ and @b@. encodeEither :: Encode a -> Encode b -> Encode (Either a b) encodeEither (Encode fa) (Encode fb) = Encode $ either fa fb {-# INLINE encodeEither #-} +-- | See 'encodeNS'.+instance+ (SOP.All EncodeDefault xs)+ => EncodeDefault (SOP.NS SOP.I xs)+ where+ encodeDefault =+ encodeNS (SOP.hcpure (Proxy @EncodeDefault) encodeDefault)+ {-# INLINE encodeDefault #-}++-- | Like 'encodeEither', but for arbitraryly large "Data.SOP".'NS' sums.+--+-- __WARNING__ This is probably not what you are looking for. The underlying+-- 'S.SQLData' won't carry any /tag/ for discriminating among @xs@.+encodeNS :: (SOP.SListI xs) => SOP.NP Encode xs -> Encode (SOP.NS SOP.I xs)+encodeNS (nse :: SOP.NP Encode xs) = Encode (SOP.hcollapse . g)+ where+ g :: SOP.NS SOP.I xs -> SOP.NS (SOP.K (Rep Encode)) xs+ g = SOP.hap (SOP.hmap f nse)+ f :: Encode a -> (SOP.I SOP.-.-> SOP.K (Rep Encode)) a+ f = SOP.fn . dimap SOP.unI SOP.K . unEncode+ -- | 'S.IntegerColumn'. Encodes 'False' as @0@ and 'True' as @1@. instance EncodeDefault Bool where encodeDefault = bool 0 1 >$< encodeDefault @Int64@@ -214,31 +258,24 @@ -- | 'S.IntegerColumn' if it fits in 'Int64', otherwise 'S.TextColumn'. instance EncodeDefault Word where- encodeDefault = encodeSizedIntegral+ encodeDefault = fromIntegral >$< encodeDefault @Sci.Scientific {-# INLINE encodeDefault #-} -- | 'S.IntegerColumn' if it fits in 'Int64', otherwise 'S.TextColumn'. instance EncodeDefault Word64 where- encodeDefault = encodeSizedIntegral+ encodeDefault = fromIntegral >$< encodeDefault @Sci.Scientific {-# INLINE encodeDefault #-} -- | 'S.IntegerColumn' if it fits in 'Int64', otherwise 'S.TextColumn'. instance EncodeDefault Integer where- encodeDefault = encodeSizedIntegral+ encodeDefault = fromIntegral >$< encodeDefault @Sci.Scientific {-# INLINE encodeDefault #-} -- | 'S.IntegerColumn' if it fits in 'Int64', otherwise 'S.TextColumn'. instance EncodeDefault Natural where- encodeDefault = encodeSizedIntegral+ encodeDefault = fromIntegral >$< encodeDefault @Sci.Scientific {-# INLINE encodeDefault #-} --- | 'S.IntegerColumn' if it fits in 'Int64', otherwise 'S.TextColumn'.-encodeSizedIntegral :: (Integral a, Bits a, HasCallStack) => Encode a-encodeSizedIntegral = Encode \a ->- case toIntegralSized a of- Just i -> unEncode (encodeDefault @Int64) i- Nothing -> unEncode (encodeDefault @String) (show (toInteger a))- -- | 'S.TextColumn'. instance EncodeDefault TL.Text where encodeDefault = TL.toStrict >$< encodeDefault@@ -363,20 +400,76 @@ instance EncodeDefault Time.TimeZone where encodeDefault = Time.iso8601Show >$< encodeDefault +-- | 'S.TextColumn'.+instance EncodeDefault UUID.UUID where+ encodeDefault = UUID.toText >$< encodeDefault ---------------------------------------------------------------------------------+-- | See @'encodeAeson' 'Left'@.+instance EncodeDefault Ae.Encoding where+ encodeDefault = encodeAeson' Left+ {-# INLINE encodeDefault #-} +-- | See @'encodeAeson' 'Right'@.+instance EncodeDefault Ae.Value where+ encodeDefault = encodeAeson' Right+ {-# INLINE encodeDefault #-}++-- | 'S.TextColumn'.+instance EncodeDefault Aek.Key where+ encodeDefault = Aek.toText >$< encodeDefault+ -- | 'S.BlobColumn'.-encodeBinary :: (a -> Bin.Put) -> Encode a-encodeBinary f = contramap (Bin.runPut . f) (encodeDefault @BL.ByteString)+instance EncodeDefault Bin.Put where+ encodeDefault = contramap Bin.runPut encodeDefault+ {-# INLINE encodeDefault #-}++-- | 'S.IntegerColumn' if it fits in 'Int64', otherwise 'S.TextColumn'.+-- Uses 'Sci.Exponent' notation.+instance EncodeDefault Sci.Scientific where+ encodeDefault = Encode \x -> case Sci.toBoundedInteger x of+ Nothing ->+ unEncode+ encodeDefault+ (Sci.formatScientificBuilder Sci.Exponent Nothing x)+ Just i -> unEncode encodeDefault (i :: Int64)++-- | 'S.IntegerColumn' if it fits in 'Int64', otherwise 'S.TextColumn'.+-- Uses 'Sci.Exponent' notation.+instance forall e. (HasResolution e) => EncodeDefault (Fixed e) where+ encodeDefault =+ contramap+ (\(MkFixed i) -> Sci.normalize $ Sci.scientific i e10)+ encodeDefault+ where+ e10 :: Int+ e10 = negate $ integerLog10 $ resolution $ Proxy @e++-- | 'S.TextColumn'. Uses @'URI.uriToString' 'id'@.+instance EncodeDefault URI.URI where+ encodeDefault = flip (URI.uriToString id) "" >$< encodeDefault++--------------------------------------------------------------------------------++-- | 'S.BlobColumn'. See also the 'EncodeDefault' instance for 'Bin.Put'.+encodeBinary :: (Bin.Binary a) => Encode a+encodeBinary = Bin.put >$< encodeDefault {-# INLINE encodeBinary #-} -- | 'S.TextColumn'. encodeShow :: (Show a) => Encode a-encodeShow = show >$< (encodeDefault @String)+encodeShow = show >$< encodeDefault {-# INLINE encodeShow #-} --- | Encodes as 'S.TextColumn'.-encodeAeson :: (a -> Ae.Value) -> Encode a-encodeAeson f = contramap (Ae.encodeToLazyText . f) (encodeDefault @TL.Text)+-- | @'encodeAeson' = 'encodeAeson' ('Left' . "Data.Aeson".'Ae.toEncoding')@+encodeAeson :: (Ae.ToJSON a) => Encode a+encodeAeson = encodeAeson' (Left . Ae.toEncoding) {-# INLINE encodeAeson #-}++-- | Encodes as 'S.TextColumn'. See also the 'EncodeDefault' instance for+-- 'Ae.Value'.+encodeAeson' :: (a -> Either Ae.Encoding Ae.Value) -> Encode a+encodeAeson' f =+ contramap (either g (g . Ae.toEncoding) . f) encodeDefault+ where+ g :: Ae.Encoding -> TL.Text+ g = TL.decodeUtf8 . BB.toLazyByteString . Ae.fromEncoding
lib/Sq/Input.hs view
@@ -1,14 +1,20 @@ {-# LANGUAGE StrictData #-}+{-# LANGUAGE UndecidableInstances #-} module Sq.Input ( Input , runInput , encode , input+ , hinput+ , HInput , BoundInput , bindInput , ErrInput (..) , rawBoundInput+ , InputDefault (..)+ , ginputDefault+ , GInputDefault ) where import Control.DeepSeq@@ -17,13 +23,24 @@ import Data.Coerce import Data.Functor.Contravariant import Data.Functor.Contravariant.Divisible+import Data.Functor.Contravariant.Rep+import Data.Kind+import Data.List.NonEmpty qualified as NEL import Data.Map.Strict qualified as Map+import Data.Profunctor+import Data.Proxy+import Data.SOP qualified as SOP+import Data.SOP.Constraint qualified as SOP import Data.String import Data.Text qualified as T import Database.SQLite3 qualified as S+import GHC.Generics qualified as G+import Generics.SOP qualified as SOP+import Generics.SOP.GGP qualified as SOP import Sq.Encoders import Sq.Names+import Sq.Support (OnlyRecords) -------------------------------------------------------------------------------- @@ -49,6 +66,11 @@ ) via Op (Map.Map BindingName (Either ErrEncode S.SQLData)) +instance Representable Input where+ type Rep Input = Map.Map BindingName (Either ErrEncode S.SQLData)+ tabulate = Input+ index = runInput+ runInput :: Input i -> i -> Map.Map BindingName (Either ErrEncode S.SQLData) runInput = coerce {-# INLINE runInput #-}@@ -94,7 +116,7 @@ -- => 'Sq.Statement' 'Sq.Write' (x, y) () -- @ encode :: Name -> Encode i -> Input i-encode n (Encode f) = Input (Map.singleton (bindingName n) . f)+encode n (Encode f) = Input (Map.singleton (BindingName (pure n)) . f) {-# INLINE encode #-} -- | Add a prefix 'Name' to parameters names in the given 'Input',@@ -125,7 +147,7 @@ -- @ input :: Name -> Input i -> Input i input n ba = Input \s ->- Map.mapKeysMonotonic (bindingName n <>) (runInput ba s)+ Map.mapKeysMonotonic (coerce (NEL.cons n)) (runInput ba s) {-# INLINE input #-} -- |@@ -161,3 +183,161 @@ rawBoundInput :: BoundInput -> Map.Map T.Text S.SQLData rawBoundInput = coerce {-# INLINE rawBoundInput #-}++--------------------------------------------------------------------------------++-- | 'Constraint' to be satisfied for using 'hinput'.+type HInput :: ((Type -> Type) -> k -> Type) -> k -> Constraint+type HInput h xs =+ ( SOP.AllN h SOP.Top xs+ , SOP.HAp (SOP.Prod h)+ , SOP.HAp h+ , SOP.HTraverse_ h+ , SOP.SListIN (SOP.Prod h) xs+ )++-- | Given a "Data.SOP" 'SOP.Prod'uct containing the 'Input's for encoding each+-- of @xs@, obtain an 'Input' able to encode any of 'SOP.NS', 'SOP.NP',+-- 'SOP.SOP' or 'SOP.POP' for that same @xs@.+--+-- You can see 'hinput' as an alternative 'divide', 'choose' or a combination+-- of those for types other than '(,)' and 'Either'.+hinput+ :: forall h xs+ . (HInput h xs)+ => SOP.Prod h Input xs+ -> Input (h SOP.I xs)+hinput ph = Input (SOP.hcfoldMap (SOP.Proxy @SOP.Top) SOP.unK . g)+ where+ g :: h SOP.I xs -> h (SOP.K (Rep Input)) xs+ g = SOP.hap (SOP.hmap f ph)+ f :: Input a -> (SOP.I SOP.-.-> SOP.K (Rep Input)) a+ f = SOP.fn . dimap SOP.unI SOP.K . runInput++-- | We don't export this, because we export 'InputDefault' instances for+-- 'SOP.NS', 'SOP.NP', 'SOP.SOP' and 'SOP.POP'.+hinputDefault+ :: (HInput h xs, SOP.AllN (SOP.Prod h) InputDefault xs)+ => Input (h SOP.I xs)+hinputDefault = hinput (SOP.hcpure (Proxy @InputDefault) inputDefault)++--------------------------------------------------------------------------------++-- | 'Constraint' to be satisfied for using 'ginputDefault'.+type GInputDefault :: Type -> Constraint+type GInputDefault i =+ ( OnlyRecords (SOP.GDatatypeInfoOf i)+ , SOP.All2 EncodeDefault (SOP.GCode i)+ , G.Generic i+ , SOP.GFrom i+ , SOP.GDatatypeInfo i+ , HInput SOP.SOP (SOP.GCode i)+ )++-- | Generic 'Input' implementation for types with GHC 'G.Generic' instance+-- where all the constructors are records with named fields, to be used as+-- 'Name's, and each field type has a 'EncodeDefault' instance.+ginputDefault :: forall i. (GInputDefault i) => Input i+ginputDefault =+ contramap SOP.gfrom $ hinput $ SOP.POP do+ case SOP.gdatatypeInfo (Proxy @i) of+ SOP.Newtype _ _ ci -> f ci SOP.:* SOP.Nil+ SOP.ADT _ _ cis _ ->+ SOP.hcmap (Proxy @(SOP.All EncodeDefault)) f cis+ where+ f+ :: forall b+ . (SOP.All EncodeDefault b)+ => SOP.ConstructorInfo b+ -> SOP.NP Input b+ f (SOP.Record _ fis) =+ SOP.hcmap+ (Proxy @EncodeDefault)+ (\(SOP.FieldInfo s) -> encode (fromString s) encodeDefault)+ fis+ f _ = undefined -- impossible due to OnlyRecords++--------------------------------------------------------------------------------++-- | Default way to encode a Haskell value of type @i@ as the 'Input' to a+-- 'Sq.Statement'.+--+-- If there there exist also a 'Sq.OutputDefault' instance for @i@, then it+-- must roundtrip with the 'Sq.InputDefault' instance for @i@.+class InputDefault i where+ inputDefault :: Input i++ -- | 'ginputDefault' is used as default implementation.+ default inputDefault :: (GInputDefault i) => Input i+ inputDefault = ginputDefault++instance InputDefault (Map.Map Name S.SQLData) where+ inputDefault = Input $ Map.foldMapWithKey \n d ->+ Map.singleton (BindingName (pure n)) (Right d)++instance InputDefault (Map.Map BindingName S.SQLData) where+ inputDefault = Input $ Map.foldMapWithKey \bn d ->+ Map.singleton bn (Right d)++instance (InputDefault a, InputDefault b) => InputDefault (a, b) where+ inputDefault = divided inputDefault inputDefault+ {-# INLINE inputDefault #-}++instance+ (InputDefault a, InputDefault b, InputDefault c)+ => InputDefault (a, b, c)+ where+ inputDefault = divide (\(a, b, c) -> (a, (b, c))) inputDefault inputDefault+ {-# INLINE inputDefault #-}++instance+ (InputDefault a, InputDefault b, InputDefault c, InputDefault d)+ => InputDefault (a, b, c, d)+ where+ inputDefault =+ divide (\(a, b, c, d) -> (a, (b, c, d))) inputDefault inputDefault+ {-# INLINE inputDefault #-}++instance+ (InputDefault a, InputDefault b, InputDefault c, InputDefault d, InputDefault e)+ => InputDefault (a, b, c, d, e)+ where+ inputDefault =+ divide (\(a, b, c, d, e) -> (a, (b, c, d, e))) inputDefault inputDefault+ {-# INLINE inputDefault #-}++instance (InputDefault a, InputDefault b) => InputDefault (Either a b) where+ inputDefault = choose id inputDefault inputDefault+ {-# INLINE inputDefault #-}++-- | Read "Data.SOP".+instance+ (SOP.SListI2 xss, SOP.All2 InputDefault xss)+ => InputDefault (SOP.SOP SOP.I xss)+ where+ inputDefault = hinputDefault+ {-# INLINE inputDefault #-}++-- | Read "Data.SOP".+instance+ (SOP.SListI2 xss, SOP.All2 InputDefault xss)+ => InputDefault (SOP.POP SOP.I xss)+ where+ inputDefault = hinputDefault+ {-# INLINE inputDefault #-}++-- | Read "Data.SOP".+instance+ (SOP.SListI xs, SOP.All InputDefault xs)+ => InputDefault (SOP.NP SOP.I xs)+ where+ inputDefault = hinputDefault+ {-# INLINE inputDefault #-}++-- | Read "Data.SOP".+instance+ (SOP.SListI xs, SOP.All InputDefault xs)+ => InputDefault (SOP.NS SOP.I xs)+ where+ inputDefault = hinputDefault+ {-# INLINE inputDefault #-}
lib/Sq/Names.hs view
@@ -3,8 +3,7 @@ module Sq.Names ( Name , name- , BindingName- , bindingName+ , BindingName (..) , renderInputBindingName , parseInputBindingName , renderOutputBindingName@@ -66,15 +65,11 @@ -- | A non-empty list of 'Name's that can be rendered as 'Sq.Input' or -- 'Sq.Output' parameters in a 'Sq.Statement'. ----- As a user of "Sq", you never construct a 'BindingName' manually. Rather,--- uses of 'Sq.input' and 'Sq.output' build one for you from its 'Name'--- constituents. 'BindingName's are only exposed to you through 'Sq.ErrInput',--- 'Sq.ErrOutput' and 'Sq.ErrStatement'.+-- As a user of "Sq", you will rarely need to construct a 'BindingName'+-- manually. Rather, uses of 'Sq.input' and 'Sq.output' build one for you from+-- its 'Name' constituents. newtype BindingName = BindingName (NonEmpty Name) deriving newtype (Eq, Ord, Show, NFData, Semigroup)--bindingName :: Name -> BindingName-bindingName = BindingName . pure --------------------------------------------------------------------------------
lib/Sq/Output.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE StrictData #-}+{-# LANGUAGE UndecidableInstances #-} module Sq.Output ( Output@@ -6,17 +7,30 @@ , decode , runOutput , output+ , OutputDefault (..)+ , goutputDefault+ , GOutputDefault+ , houtput+ , HOutput ) where import Control.Applicative import Control.Exception.Safe qualified as Ex import Control.Monad import Control.Monad.Trans.Resource qualified as R hiding (runResourceT)+import Data.Coerce+import Data.Kind+import Data.List.NonEmpty qualified as NEL+import Data.Proxy import Data.String import Database.SQLite3 qualified as S+import GHC.Generics qualified as G+import Generics.SOP qualified as SOP+import Generics.SOP.GGP qualified as SOP import Sq.Decoders import Sq.Names+import Sq.Support -------------------------------------------------------------------------------- @@ -95,7 +109,7 @@ -- => 'Sq.Statement' 'Sq.Read' () (x, y) -- @ decode :: Name -> Decode o -> Output o-decode n vda = Output_Decode (bindingName n) (Output_Pure <$> vda)+decode n vda = Output_Decode (BindingName (pure n)) (Output_Pure <$> vda) {-# INLINE decode #-} -- | Add a prefix 'Name' to column names in the given 'Output',@@ -116,8 +130,8 @@ -- @ -- 'Sq.readStatement' -- 'mempty'--- ('liftA2' ('output' \"p1\" pointInput)--- ('output' \"p2\" pointInput))+-- ('liftA2' (,) ('output' \"p1\" pointOutput)+-- ('output' \"p2\" pointOutput)) -- ['Sq.sql'| -- SELECT ax AS p1\__x, ay AS p1\__y, -- bx AS p2\__x, by AS p2\__y@@ -127,7 +141,7 @@ output :: Name -> Output o -> Output o output n = \case Output_Decode bn d ->- Output_Decode (bindingName n <> bn) (output n <$> d)+ Output_Decode (coerce (NEL.cons n) bn) (output n <$> d) o -> o -- | TODO cache names after lookup. Important for Alternative.@@ -195,3 +209,148 @@ instance (DecodeDefault i) => IsString (Output i) where fromString s = decode (fromString s) decodeDefault {-# INLINE fromString #-}++--------------------------------------------------------------------------------++-- | 'Constraint' to be satisfied for using 'houtput'.+type HOutput :: ((Type -> Type) -> k -> Type) -> k -> Constraint+type HOutput = HAsum++-- | Given a "Data.SOP".'SOP.Prod' containing all the possible 'Output'+-- decoders, obtain an 'Output' for any 'SOP.NS', 'SOP.NP', 'SOP.SOP' or+-- 'SOP.POP' having that same @xs@.+--+-- Composes products 'SOP.NP' and 'SOP.POP' using 'Applicative',+-- and sums 'SOP.NS' and 'SOP.SOP' using 'Alternative'.+houtput :: (HOutput h xs) => SOP.Prod h Output xs -> Output (h SOP.I xs)+houtput = hasum+{-# INLINE houtput #-}++--------------------------------------------------------------------------------++-- | 'Constraint' to be satisfied for using 'goutputDefault'.+type GOutputDefault :: Type -> Constraint+type GOutputDefault o =+ ( OnlyRecords (SOP.GDatatypeInfoOf o)+ , SOP.All2 DecodeDefault (SOP.GCode o)+ , G.Generic o+ , SOP.GTo o+ , SOP.GDatatypeInfo o+ , HOutput SOP.SOP (SOP.GCode o)+ )++-- | Generic 'Output' implementation for types with GHC 'G.Generic' instance+-- where all the constructors are records with named fields, to be used as+-- 'Name's, and each field type has a 'DecodeDefault' instance.+--+-- If the datatype has more than one constructor, each one is tried in order+-- until one of them matches.+goutputDefault :: forall o. (GOutputDefault o) => Output o+goutputDefault =+ fmap SOP.gto $ houtput $ SOP.POP do+ case SOP.gdatatypeInfo (Proxy @o) of+ SOP.Newtype _ _ ci -> f ci SOP.:* SOP.Nil+ SOP.ADT _ _ cis _ ->+ SOP.hcmap (Proxy @(SOP.All DecodeDefault)) f cis+ where+ f+ :: forall b+ . (SOP.All DecodeDefault b)+ => SOP.ConstructorInfo b+ -> SOP.NP Output b+ f (SOP.Record _ fis) =+ SOP.hcmap+ (Proxy @DecodeDefault)+ (\(SOP.FieldInfo s) -> decode (fromString s) decodeDefault)+ fis+ f _ = undefined -- impossible due to OnlyRecords++--------------------------------------------------------------------------------++-- | Default way to decode the 'Output' from a 'Sq.Statement' as a Haskell+-- value of type @a@.+--+-- If there there exist also a 'Sq.InputDefault' instance for @o@, then it+-- must roundtrip with the 'Sq.OutputDefault' instance for @o@.+class OutputDefault o where+ outputDefault :: Output o++ -- | 'goutputDefault' is used as default implementation.+ default outputDefault :: (GOutputDefault o) => Output o+ outputDefault = goutputDefault++-- | We don't export this, because we export 'OutputDefault' instances for+-- 'SOP.NS', 'SOP.NP', 'SOP.SOP' and 'SOP.POP'.+houtputDefault+ :: ( HOutput h xs+ , SOP.AllN (SOP.Prod h) OutputDefault xs+ , SOP.HPure (SOP.Prod h)+ )+ => Output (h SOP.I xs)+houtputDefault = houtput (SOP.hcpure (Proxy @OutputDefault) outputDefault)++-- | Read "Data.SOP".+--+-- __WARNING__ This may lead to unexpected results if the underlying+-- 'OutputDefault's don't check for any /tag/ for discriminating between the+-- various @xss@.+instance+ (SOP.SListI2 xss, SOP.All2 OutputDefault xss)+ => OutputDefault (SOP.SOP SOP.I xss)+ where+ outputDefault = houtputDefault+ {-# INLINE outputDefault #-}++-- | Read "Data.SOP".+instance+ (SOP.SListI2 xss, SOP.All2 OutputDefault xss)+ => OutputDefault (SOP.POP SOP.I xss)+ where+ outputDefault = houtputDefault+ {-# INLINE outputDefault #-}++-- | Read "Data.SOP".+instance+ (SOP.SListI xs, SOP.All OutputDefault xs)+ => OutputDefault (SOP.NP SOP.I xs)+ where+ outputDefault = houtputDefault+ {-# INLINE outputDefault #-}++-- | Read "Data.SOP".+--+-- __WARNING__ This may lead to unexpected results if the underlying+-- 'OutputDefault's don't check for any /tag/ for discriminating between+-- the various @xs@.+instance+ (SOP.SListI xs, SOP.All OutputDefault xs)+ => OutputDefault (SOP.NS SOP.I xs)+ where+ outputDefault = houtputDefault+ {-# INLINE outputDefault #-}++instance (OutputDefault a, OutputDefault b) => OutputDefault (a, b) where+ outputDefault = (,) <$> outputDefault <*> outputDefault++instance+ (OutputDefault a, OutputDefault b, OutputDefault c)+ => OutputDefault (a, b, c)+ where+ outputDefault = (,,) <$> outputDefault <*> outputDefault <*> outputDefault++instance+ (OutputDefault a, OutputDefault b, OutputDefault c, OutputDefault d)+ => OutputDefault (a, b, c, d)+ where+ outputDefault =+ (,,,)+ <$> outputDefault+ <*> outputDefault+ <*> outputDefault+ <*> outputDefault++-- | __WARNING__ This may lead to unexpected results if the underlying+-- 'OutputDefault's don't check for any /tag/ for discriminating between @a@+-- and @b@.+instance (OutputDefault a, OutputDefault b) => OutputDefault (Either a b) where+ outputDefault = fmap Left outputDefault <|> fmap Right outputDefault
lib/Sq/Support.hs view
@@ -1,6 +1,7 @@ module Sq.Support ( resourceVanishedWithCallStack , note+ , hush , hushThrow , show' , newUnique@@ -13,6 +14,8 @@ , foldMaybeM , foldZeroM , foldOneM+ , HAsum (..)+ , OnlyRecords ) where import Control.Applicative@@ -26,10 +29,12 @@ import Data.IORef import Data.Int import Data.List.NonEmpty qualified as NEL+import Data.SOP qualified as SOP import Data.String import Data.Word import GHC.IO.Exception import GHC.Stack+import Generics.SOP.Type.Metadata qualified as SOPT import System.Directory import System.FilePath import System.IO.Error (isAlreadyExistsError)@@ -48,6 +53,10 @@ note a = maybe (Left a) Right {-# INLINE note #-} +hush :: Either a b -> Maybe b+hush = either (const Nothing) Just+{-# INLINE hush #-}+ hushThrow :: (Ex.Exception e, Ex.MonadThrow m) => Either e b -> m b hushThrow = either Ex.throwM pure {-# INLINE hushThrow #-}@@ -142,3 +151,91 @@ -- ^ More than one. -> F.FoldM m o o foldOneM e0 eN = foldPostmapM (maybe (Ex.throwM e0) pure) (foldMaybeM eN)++--------------------------------------------------------------------------------++class HAsum h xs where+ -- | Composes products 'SOP.NP' and 'SOP.POP' using 'Applicative', and+ -- sums 'SOP.NS' and 'SOP.SOP' using 'Alternative'.+ hasum :: (Alternative f) => SOP.Prod h f xs -> f (h SOP.I xs)++instance (SOP.All SOP.Top xs) => HAsum SOP.NP xs where+ hasum = asum_NP+ {-# INLINE hasum #-}++instance HAsum SOP.NS xs where+ hasum = asum_NS+ {-# INLINE hasum #-}++instance (SOP.All2 SOP.Top xss) => HAsum SOP.POP xss where+ hasum = asum_POP+ {-# INLINE hasum #-}++instance (SOP.All2 SOP.Top xss) => HAsum SOP.SOP xss where+ hasum = asum_SOP+ {-# INLINE hasum #-}++-- | Keeps the first 'Alternative' that succeeds among @xs@.+asum_NS :: (Alternative f) => SOP.NP f xs -> f (SOP.NS SOP.I xs)+asum_NS = \case+ this SOP.:* SOP.Nil ->+ -- We handle this case specially so we can preserve 'this''s error.+ fmap (SOP.Z . SOP.I) this+ this SOP.:* rest ->+ fmap (SOP.Z . SOP.I) this <|> fmap SOP.S (asum_NS rest)+ SOP.Nil ->+ -- We could use the type system to force @xs@ to be non-empty,+ -- but this approach probably has better ergonomics for users.+ empty++-- | Keeps the first 'Alternative' that succeeds among @xss@.+asum_SOP+ :: (Alternative f, SOP.All2 SOP.Top xss)+ => SOP.POP f xss+ -> f (SOP.SOP SOP.I xss)+asum_SOP = \(SOP.POP pp) -> fmap SOP.SOP $ case pp of+ this SOP.:* SOP.Nil ->+ -- We handle this case specially so we can preserve 'this''s error.+ fmap SOP.Z (asum_NP this)+ this SOP.:* rest ->+ fmap SOP.Z (asum_NP this)+ <|> fmap (SOP.S . SOP.unSOP) (asum_SOP (SOP.POP rest))+ SOP.Nil ->+ -- We could use the type system to force @xss@ to be non-empty,+ -- but this approach probably has better ergonomics for users.+ empty++-- | This is just 'SOP.sequence_NP'. It doesn't use any 'Alternative'+-- features. We write it down for completeness.+asum_NP+ :: (Applicative f, SOP.All SOP.Top xs)+ => SOP.NP f xs+ -> f (SOP.NP SOP.I xs)+asum_NP = SOP.hsequence+{-# INLINE asum_NP #-}++-- | This is just 'SOP.sequence_POP'. It doesn't use any 'Alternative'+-- features. We write it down for completeness.+asum_POP+ :: (Applicative f, SOP.All2 SOP.Top xss)+ => SOP.POP f xss+ -> f (SOP.POP SOP.I xss)+asum_POP = SOP.hsequence+{-# INLINE asum_POP #-}++--------------------------------------------------------------------------------++-- | Class so that it can be partially applied.+--+-- Not exported so people don't add instances.+class OnlyRecords (di :: SOPT.DatatypeInfo)++instance (IsRecord ci) => OnlyRecords ('SOPT.Newtype mn dn ci)+instance (SOP.All IsRecord cis) => OnlyRecords ('SOPT.ADT mn dn cis sis)++-- | Class so that it can be partially applied.+--+-- Not exported so people don't add instances.+class IsRecord (ci :: SOPT.ConstructorInfo)++instance IsRecord ('SOPT.Record cn fis)
sq.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: sq-version: 0.0.2+version: 0.1 license: Apache-2.0 license-file: LICENSE extra-source-files: README.md CHANGELOG.md@@ -13,7 +13,7 @@ description: High-level SQLite client. homepage: https://github.com/k0001/hs-sq bug-reports: https://github.com/k0001/hs-sq/issues-tested-with: GHC == 9.8.1+tested-with: GHC == 9.12.2 common basic default-language: GHC2021@@ -23,12 +23,13 @@ default-extensions: BlockArguments DataKinds+ DefaultSignatures DeriveAnyClass DerivingStrategies DerivingVia DuplicateRecordFields- LambdaCase ImplicitParams+ LambdaCase OverloadedRecordDot OverloadedStrings RecordWildCards@@ -55,34 +56,42 @@ Sq.Support Sq.Transactional build-depends:+ adjunctions, aeson,- async, attoparsec,+ attoparsec-aeson,+ attoparsec-iso8601, binary, bytestring, clock, containers, contravariant, deepseq,- di-df1, di-core,+ di-df1, direct-sqlite, directory, exceptions, filepath, foldl,+ generics-sop,+ integer-logarithms,+ network-uri, profunctors, ref-tf, resource-pool, resourcet, resourcet-extra, safe-exceptions,+ scientific,+ sop-core, stm, streaming, template-haskell, text, time, transformers,+ uuid-types, test-suite test import: basic@@ -106,12 +115,15 @@ resourcet, resourcet-extra, safe-exceptions,+ scientific,+ sop-core, sq, tasty, tasty-hedgehog, tasty-hunit, text, time,+ uuid-types, benchmark bench import: basic
test/Sq/Test/Codec.hs view
@@ -11,13 +11,16 @@ import Data.Functor.Contravariant import Data.Int import Data.Maybe+import Data.Scientific qualified as Sci import Data.Text qualified as T import Data.Text.Lazy qualified as TL import Data.Time qualified as Time import Data.Time.Clock.POSIX qualified as Time import Data.Time.Format.ISO8601 qualified as Time import Data.Typeable+import Data.UUID.Types qualified as UUID import Data.Word+import GHC.Generics qualified as G import Hedgehog qualified as H import Hedgehog.Gen qualified as H import Hedgehog.Range qualified as HR@@ -34,6 +37,7 @@ testGroup "decode . encode" [ t @Bool $ H.bool+ , t @UUID.UUID uuid4 , t @Int $ H.integral HR.constantBounded , t @Int8 $ H.integral HR.constantBounded , t @Int16 $ H.integral HR.constantBounded@@ -56,7 +60,12 @@ , t2 @Time.UTCTime $ genUTCTime (HR.constantFrom epochUTCTime minUTCTime maxUTCTime) , t @Double $ H.double (HR.constantFrom 0 (fromIntegral minInteger) (fromIntegral maxInteger)) , t @Float $ H.float (HR.constantFrom 0 (fromIntegral minInteger) (fromIntegral maxInteger))- -- TODO FAIL: , testProperty "Char" $ t @Char (pure '\55296')+ , t @Sci.Scientific $ genScientific (HR.constantFrom 0 (-10) 10) HR.constantBounded+ , t @(Fixed E0) $ genFixed (HR.constantFrom 0 minInteger maxInteger)+ , t @(Fixed E2) $ genFixed (HR.constantFrom 0 minInteger maxInteger)+ , t @(Fixed E9) $ genFixed (HR.constantFrom 0 minInteger maxInteger)+ , -- TODO FAIL: , testProperty "Char" $ t @Char (pure '\55296')+ tGeneric ] where t@@ -104,25 +113,41 @@ a1 <- Sq.read p $ Sq.one idStatement a0 a0 H.=== a1 ]+ tGeneric :: TestTree+ tGeneric =+ testGroup+ "Generic InputDefault/OutputDefault"+ [ testProperty "Foo" $ H.property do+ p <- liftIO iop+ a0 <- H.forAll genFoo+ a1 <- Sq.read p do+ Sq.one+ ( Sq.readStatement+ Sq.inputDefault+ Sq.outputDefault+ "SELECT $x AS x, $y AS y"+ )+ a0+ Foo0{x = a0.x, y = a0.y} H.=== a1+ ] newtype WrapBinary a = WrapBinary a deriving newtype (Eq, Show) instance (Bin.Binary a) => Sq.EncodeDefault (WrapBinary a) where- encodeDefault = contramap (\case WrapBinary a -> a) $ Sq.encodeBinary Bin.put+ encodeDefault = Sq.encodeBinary >$$< \(WrapBinary a) -> a instance (Bin.Binary a) => Sq.DecodeDefault (WrapBinary a) where- decodeDefault = WrapBinary <$> Sq.decodeBinary Bin.get+ decodeDefault = WrapBinary <$> Sq.decodeBinary newtype WrapAeson a = WrapAeson a deriving newtype (Eq, Show) instance (Ae.ToJSON a) => Sq.EncodeDefault (WrapAeson a) where- encodeDefault =- contramap (\case WrapAeson a -> a) $ Sq.encodeAeson Ae.toJSON+ encodeDefault = Sq.encodeAeson >$$< \(WrapAeson a) -> a instance (Ae.FromJSON a) => Sq.DecodeDefault (WrapAeson a) where- decodeDefault = WrapAeson <$> Sq.decodeAeson Ae.parseJSON+ decodeDefault = WrapAeson <$> Sq.decodeAeson idStatement :: (Sq.EncodeDefault x, Sq.DecodeDefault x)@@ -133,6 +158,12 @@ (Sq.output "x" (Sq.output "y" "z")) "SELECT $a__b__c AS x__y__z" +uuid4 :: (H.MonadGen m) => m UUID.UUID+uuid4 =+ UUID.fromWords64+ <$> H.integral HR.constantBounded+ <*> H.integral HR.constantBounded+ maxNatural :: Natural maxNatural = 2 ^ (256 :: Int) - 1 @@ -166,8 +197,29 @@ posixPicoSecondsToUTCTime = Time.posixSecondsToUTCTime . Time.secondsToNominalDiffTime . MkFixed +genScientific+ :: (H.MonadGen m)+ => H.Range Integer+ -> H.Range Int+ -> m Sci.Scientific+genScientific rc re = Sci.scientific <$> H.integral rc <*> H.integral re++genFixed :: (H.MonadGen m) => H.Range Integer -> m (Fixed e)+genFixed ri = MkFixed <$> H.integral ri+ -- genRational :: (H.MonadGen m) => m Rational -- genRational = do -- n <- genInteger -- d <- H.integral $ H.linear 1 (10 ^ (10 :: Int)) -- pure (n % d)++data Foo+ = Foo0 {x :: Int, y :: String}+ | Foo1 {x :: Int, y :: String}+ deriving (Eq, Show, G.Generic, Sq.InputDefault, Sq.OutputDefault)++genFoo :: (H.MonadGen m) => m Foo+genFoo = do+ x <- H.integral HR.constantBounded+ y <- H.string (HR.constant 0 50) H.unicode+ H.element [Foo0 x y, Foo1 x y]