diff --git a/DB-record/DB-record.cabal b/DB-record/DB-record.cabal index e8fa5ac3..41ad9660 100644 --- a/DB-record/DB-record.cabal +++ b/DB-record/DB-record.cabal @@ -19,6 +19,7 @@ library Database.Record.ToSql Database.Record.Persistable Database.Record.KeyConstraint + Database.Record.Singleton Database.Record Database.Record.TH diff --git a/DB-record/src/Database/Record/FromSql.hs b/DB-record/src/Database/Record/FromSql.hs index 2ab0c01c..8912bc05 100644 --- a/DB-record/src/Database/Record/FromSql.hs +++ b/DB-record/src/Database/Record/FromSql.hs @@ -1,7 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -- | -- Module : Database.Record.FromSql @@ -26,7 +25,7 @@ module Database.Record.FromSql ( ) where import Database.Record.Persistable - (PersistableRecord, Singleton, + (PersistableRecord, Persistable(persistable), PersistableType) import qualified Database.Record.Persistable as Persistable import Database.Record.KeyConstraint @@ -86,9 +85,6 @@ class FromSql q a where recordFromSql' :: Persistable q a => RecordFromSql q a recordFromSql' = recordDeSerializer persistable -instance Persistable q (Singleton a) => FromSql q (Singleton a) where - recordFromSql = recordFromSql' - instance (FromSql q a, FromSql q b) => FromSql q (a, b) where recordFromSql = recordFromSql <&> recordFromSql diff --git a/DB-record/src/Database/Record/Persistable.hs b/DB-record/src/Database/Record/Persistable.hs index d497b157..2fc76f13 100644 --- a/DB-record/src/Database/Record/Persistable.hs +++ b/DB-record/src/Database/Record/Persistable.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -11,32 +10,25 @@ -- Stability : experimental -- Portability : unknown module Database.Record.Persistable ( - Singleton(runSingleton), singleton, - PersistableSqlType(runPersistableNullValue), persistableSqlTypeFromNull, PersistableRecordWidth(runPersistableRecordWidth), - valueWidth, singletonWidth, (<&>), maybeWidth, + valueWidth, (<&>), maybeWidth, PersistableSqlValue, persistableSqlValue, + toValue, fromValue, PersistableRecord, persistableRecord, toRecord, fromRecord, width, - persistableFromValue, persistableSingletonFromValue, + persistableFromValue, PersistableType(..), sqlNullValue, PersistableValue (..), fromSql, toSql, - derivedPersistableValueRecord, derivedPersistableSingleton, + derivedPersistableValueRecord, PersistableWidth (..), persistableRecordWidth, Persistable (..), takeRecord ) where --- | Singleton value record. -newtype Singleton a = Singleton { runSingleton :: a } - -singleton :: a -> Singleton a -singleton = Singleton - -- | Proof object to specify 'q' is SQL type newtype PersistableSqlType q = @@ -69,9 +61,6 @@ persistableRecordWidth = PersistableRecordWidth valueWidth :: PersistableRecordWidth a valueWidth = persistableRecordWidth 1 -singletonWidth :: PersistableRecordWidth (Singleton a) -singletonWidth = persistableRecordWidth 1 - (<&>) :: PersistableRecordWidth a -> PersistableRecordWidth b -> PersistableRecordWidth (a, b) a <&> b = PersistableRecordWidth $ runPersistableRecordWidth a + runPersistableRecordWidth b @@ -99,10 +88,6 @@ persistableFromValue :: PersistableRecordWidth a -> PersistableSqlValue q a -> P persistableFromValue pw pv = persistableRecord pw (toValue pv . head) ((:[]) . fromValue pv) -persistableSingletonFromValue :: PersistableRecordWidth (Singleton a) -> PersistableSqlValue q a -> PersistableRecord q (Singleton a) -persistableSingletonFromValue pw pv = - persistableRecord pw (singleton . toValue pv . head) ((:[]) . fromValue pv . runSingleton) - persistableVoid :: PersistableRecord q () persistableVoid = persistableRecord voidWidth (const ()) (const []) @@ -117,9 +102,6 @@ sqlNullValue = runPersistableNullValue persistableType class PersistableWidth a where persistableWidth :: PersistableRecordWidth a -instance PersistableWidth (Singleton a) where - persistableWidth = singletonWidth - instance (PersistableWidth a, PersistableWidth b) => PersistableWidth (a, b) where persistableWidth = persistableWidth <&> persistableWidth @@ -142,9 +124,6 @@ toSql = fromValue persistableValue derivedPersistableValueRecord :: (PersistableWidth a, PersistableValue q a) => PersistableRecord q a derivedPersistableValueRecord = persistableFromValue persistableWidth persistableValue -derivedPersistableSingleton :: (PersistableWidth (Singleton a), PersistableValue q a) => PersistableRecord q (Singleton a) -derivedPersistableSingleton = persistableSingletonFromValue persistableWidth persistableValue - class PersistableWidth a => Persistable q a where persistable :: PersistableRecord q a diff --git a/DB-record/src/Database/Record/Singleton.hs b/DB-record/src/Database/Record/Singleton.hs new file mode 100644 index 00000000..6e90b2c4 --- /dev/null +++ b/DB-record/src/Database/Record/Singleton.hs @@ -0,0 +1,50 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} + +module Database.Record.Singleton ( + Singleton, runSingleton, singleton, + + singletonWidth, + persistableSingletonFromValue, + derivedPersistableSingleton + ) where + +import Database.Record.Persistable + (PersistableRecordWidth, persistableRecordWidth, + PersistableSqlValue, toValue, fromValue, + PersistableRecord, persistableRecord, + PersistableWidth (persistableWidth), + PersistableValue (persistableValue), + Persistable) +import Database.Record.FromSql (FromSql(recordFromSql), recordFromSql') +import Database.Record.ToSql (ToSql(recordToSql), recordToSql') + + +-- | Singleton value record. +newtype Singleton a = Singleton { runSingleton :: a } + +singleton :: a -> Singleton a +singleton = Singleton + +singletonWidth :: PersistableRecordWidth (Singleton a) +singletonWidth = persistableRecordWidth 1 + +instance PersistableWidth (Singleton a) where + persistableWidth = singletonWidth + +persistableSingletonFromValue :: PersistableRecordWidth (Singleton a) -> PersistableSqlValue q a -> PersistableRecord q (Singleton a) +persistableSingletonFromValue pw pv = + persistableRecord pw (singleton . toValue pv . head) ((:[]) . fromValue pv . runSingleton) + +derivedPersistableSingleton :: (PersistableWidth (Singleton a), PersistableValue q a) => PersistableRecord q (Singleton a) +derivedPersistableSingleton = persistableSingletonFromValue persistableWidth persistableValue + + +instance Persistable q (Singleton a) => FromSql q (Singleton a) where + recordFromSql = recordFromSql' + +instance Persistable q (Singleton a) => ToSql q (Singleton a) where + recordToSql = recordToSql' diff --git a/DB-record/src/Database/Record/ToSql.hs b/DB-record/src/Database/Record/ToSql.hs index 107e02ba..9859e896 100644 --- a/DB-record/src/Database/Record/ToSql.hs +++ b/DB-record/src/Database/Record/ToSql.hs @@ -1,7 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -- | -- Module : Database.Record.ToSql @@ -26,7 +25,7 @@ module Database.Record.ToSql ( ) where import Database.Record.Persistable - (PersistableRecord, Persistable(persistable), Singleton) + (PersistableRecord, Persistable(persistable)) import Database.Record.KeyConstraint (HasKeyConstraint(constraintKey), KeyConstraint, Primary, Unique, unique, index) import qualified Database.Record.Persistable as Persistable @@ -46,9 +45,6 @@ class ToSql q a where recordSerializer :: PersistableRecord q a -> RecordToSql q a recordSerializer = createRecordToSql . Persistable.fromRecord -instance Persistable q (Singleton a) => ToSql q (Singleton a) where - recordToSql = recordSerializer persistable - (<&>) :: RecordToSql q a -> RecordToSql q b -> RecordToSql q (a, b) ra <&> rb = RecordToSql (\(a, b) -> runFromRecord ra a ++ runFromRecord rb b)