module Database.Selda.Types
( (:*:)(..), Head, Append (..), (:++:), ToDyn (..), Tup (..)
, first, second, third, fourth, fifth, sixth, seventh, eighth, ninth, tenth
, ColName, TableName
, mkColName, mkTableName, addColSuffix, addColPrefix
, fromColName, fromTableName
) where
import Data.Dynamic
import Data.String
import Data.Text (Text, replace, append)
import GHC.Generics (Generic)
import Unsafe.Coerce
#ifndef NO_LOCALCACHE
import Data.Hashable
instance Hashable TableName where
hashWithSalt s (TableName tn) = hashWithSalt s tn
#endif
newtype ColName = ColName Text
deriving (Ord, Eq, Show, IsString)
newtype TableName = TableName Text
deriving (Ord, Eq, Show, IsString)
addColPrefix :: ColName -> Text -> ColName
addColPrefix (ColName cn) s = ColName $ Data.Text.append s cn
addColSuffix :: ColName -> Text -> ColName
addColSuffix (ColName cn) s = ColName $ Data.Text.append cn s
fromColName :: ColName -> Text
fromColName (ColName cn) = mconcat ["\"", escapeQuotes cn, "\""]
fromTableName :: TableName -> Text
fromTableName (TableName tn) = mconcat ["\"", escapeQuotes tn, "\""]
mkColName :: Text -> ColName
mkColName = ColName
mkTableName :: Text -> TableName
mkTableName = TableName
escapeQuotes :: Text -> Text
escapeQuotes = Data.Text.replace "\"" "\"\""
data a :*: b where
(:*:) :: a -> b -> a :*: b
deriving (Typeable, Generic)
infixr 1 :*:
instance (Show a, Show b) => Show (a :*: b) where
show (a :*: b) = show a ++ " :*: " ++ show b
instance (Eq a, Eq b) => Eq (a :*: b) where
(a :*: b) == (a' :*: b') = a == a' && b == b'
instance (Ord a, Ord b) => Ord (a :*: b) where
(a :*: b) `compare` (a' :*: b') =
case a `compare` a' of
EQ -> b `compare` b'
o -> o
type family Head a where
Head (a :*: b) = a
Head a = a
class Tup a where
tupHead :: a -> Head a
instance Tup (a :*: b) where
tupHead (a :*: _) = a
instance Head a ~ a => Tup a where
tupHead a = a
first :: Tup a => a -> Head a
first = tupHead
second :: Tup b => (a :*: b) -> Head b
second (_ :*: b) = tupHead b
third :: Tup c => (a :*: b :*: c) -> Head c
third (_ :*: _ :*: c) = tupHead c
fourth :: Tup d => (a :*: b :*: c :*: d) -> Head d
fourth (_ :*: _ :*: _ :*: d) = tupHead d
fifth :: Tup e => (a :*: b :*: c :*: d :*: e) -> Head e
fifth (_ :*: _ :*: _ :*: _ :*: e) = tupHead e
sixth :: Tup f => (a :*: b :*: c :*: d :*: e :*: f) -> Head f
sixth (_ :*: _ :*: _ :*: _ :*: _ :*: f) = tupHead f
seventh :: Tup g => (a :*: b :*: c :*: d :*: e :*: f :*: g) -> Head g
seventh (_ :*: _ :*: _ :*: _ :*: _ :*: _ :*: g) = tupHead g
eighth :: Tup h => (a :*: b :*: c :*: d :*: e :*: f :*: g :*: h) -> Head h
eighth (_ :*: _ :*: _ :*: _ :*: _ :*: _ :*: _ :*: h) = tupHead h
ninth :: Tup i => (a :*: b :*: c :*: d :*: e :*: f :*: h :*: h :*: i) -> Head i
ninth (_ :*: _ :*: _ :*: _ :*: _ :*: _ :*: _ :*: _ :*: i) = tupHead i
tenth :: Tup j => (a :*: b :*: c :*: d :*: e :*: f :*: g :*: h :*: i :*: j)
-> Head j
tenth (_ :*: _ :*: _ :*: _ :*: _ :*: _ :*: _ :*: _ :*: _ :*: j) = tupHead j
type family a :++: b where
(a :*: b) :++: c = a :*: (b :++: c)
a :++: b = a :*: b
class Append a b where
app :: a -> b -> a :++: b
instance Append b c => Append (a :*: b) c where
app (a :*: b) c = a :*: app b c
instance ((a :*: b) ~ (a :++: b)) => Append a b where
app a b = a :*: b
data Unsafe = Unsafe Int
class Typeable a => ToDyn a where
toDyns :: a -> [Dynamic]
fromDyns :: [Dynamic] -> Maybe a
unsafeToList :: a -> [Unsafe]
unsafeFromList :: [Unsafe] -> a
instance (Typeable a, ToDyn b) => ToDyn (a :*: b) where
toDyns (a :*: b) = toDyn a : toDyns b
fromDyns (x:xs) = do
x' <- fromDynamic x
xs' <- fromDyns xs
return (x' :*: xs')
fromDyns _ = do
Nothing
unsafeToList (x :*: xs) = unsafeCoerce x : unsafeToList xs
unsafeFromList (x : xs) = unsafeCoerce x :*: unsafeFromList xs
unsafeFromList _ = error "too short list to unsafeFromList"
instance Typeable a => ToDyn a where
toDyns a = [toDyn a]
fromDyns [x] = fromDynamic x
fromDyns _ = Nothing
unsafeToList x = [unsafeCoerce x]
unsafeFromList [x] = unsafeCoerce x
unsafeFromList [] = error "too short list to unsafeFromList"
unsafeFromList _ = error "too long list to unsafeFromList"