{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE CPP #-}
module ProjectM36.Tupleable
( toInsertExpr
, toDefineExpr
, tupleAssocsEqualityPredicate
, partitionByAttributes
, toUpdateExpr
, toDeleteExpr
, validateAttributes
, Tupleable(..)
, genericToTuple
, genericFromTuple
, genericToAttributes
, TupleableG(..)
, defaultTupleableOptions
, TupleableOptions()
, fieldModifier
) where
import Data.Foldable
import Data.List (partition)
import qualified Data.Map as Map
#if __GLASGOW_HASKELL__ < 804
import Data.Monoid
#endif
import Data.Proxy
import qualified Data.Text as T
import qualified Data.Vector as V
import GHC.Generics
import ProjectM36.Atomable
import ProjectM36.Attribute hiding (null)
import ProjectM36.Base
import ProjectM36.DataTypes.Primitive
import ProjectM36.Error
import ProjectM36.Tuple
import ProjectM36.TupleSet
import qualified Data.Set as S
toInsertExpr :: forall a t. (Tupleable a, Traversable t) => t a -> RelVarName -> Either RelationalError DatabaseContextExpr
toInsertExpr vals rvName = do
let attrs = toAttributes (Proxy :: Proxy a)
tuples <- mkTupleSet attrs $ toList (fmap toTuple vals)
let rel = MakeStaticRelation attrs tuples
pure (Insert rvName rel)
toDefineExpr :: forall a proxy. Tupleable a => proxy a -> RelVarName -> DatabaseContextExpr
toDefineExpr _ rvName = Define rvName (map NakedAttributeExpr (V.toList attrs))
where
attrs = toAttributes (Proxy :: Proxy a)
tupleAssocsEqualityPredicate :: [(AttributeName, Atom)] -> RestrictionPredicateExpr
tupleAssocsEqualityPredicate [] = TruePredicate
tupleAssocsEqualityPredicate pairs =
foldr1 AndPredicate $
map
(\(name, atom) -> AttributeEqualityPredicate name (NakedAtomExpr atom))
pairs
partitionByAttributes ::
Tupleable a
=> [AttributeName]
-> a
-> ([(AttributeName, Atom)], [(AttributeName, Atom)])
partitionByAttributes attrs =
partition ((`elem` attrs) . fst) . tupleAssocs . toTuple
toUpdateExpr ::
forall a. Tupleable a => RelVarName -> [AttributeName] -> a -> Either RelationalError DatabaseContextExpr
toUpdateExpr rvName keyAttrs a = validateAttributes (S.fromList keyAttrs) expectedAttrSet (Update rvName updateMap keyRestriction)
where
(keyPairs, updatePairs) = partitionByAttributes keyAttrs a
updateMap = Map.fromList $ fmap NakedAtomExpr <$> updatePairs
keyRestriction = tupleAssocsEqualityPredicate keyPairs
expectedAttrSet = attributeNameSet (toAttributes (Proxy :: Proxy a))
toDeleteExpr ::
forall a. Tupleable a => RelVarName -> [AttributeName] -> a -> Either RelationalError DatabaseContextExpr
toDeleteExpr rvName keyAttrs val = validateAttributes (S.fromList keyAttrs) expectedAttrSet (Delete rvName keyRestriction)
where
keyPairs = fst $ partitionByAttributes keyAttrs val
keyRestriction = tupleAssocsEqualityPredicate keyPairs
expectedAttrSet = attributeNameSet (toAttributes (Proxy :: Proxy a))
validateAttributes :: S.Set AttributeName -> S.Set AttributeName -> a -> Either RelationalError a
validateAttributes actualAttrs expectedAttrs val
| S.null actualAttrs = Left EmptyAttributesError
| not (S.null nonMatchingAttrs) = Left (NoSuchAttributeNamesError nonMatchingAttrs)
| otherwise = Right val
where
nonMatchingAttrs = attributeNamesNotContained actualAttrs expectedAttrs
class Tupleable a where
toTuple :: a -> RelationTuple
fromTuple :: RelationTuple -> Either RelationalError a
toAttributes :: Proxy a -> Attributes
default toTuple :: (Generic a, TupleableG (Rep a)) => a -> RelationTuple
toTuple = genericToTuple defaultTupleableOptions
default fromTuple :: (Generic a, TupleableG (Rep a)) => RelationTuple -> Either RelationalError a
fromTuple = genericFromTuple defaultTupleableOptions
default toAttributes :: (Generic a, TupleableG (Rep a)) => Proxy a -> Attributes
toAttributes = genericToAttributes defaultTupleableOptions
newtype TupleableOptions = TupleableOptions {
fieldModifier :: T.Text -> T.Text
}
defaultTupleableOptions :: TupleableOptions
defaultTupleableOptions = TupleableOptions {
fieldModifier = id
}
genericToTuple :: (Generic a, TupleableG (Rep a)) => TupleableOptions -> a -> RelationTuple
genericToTuple opts v = toTupleG opts (from v)
genericFromTuple :: (Generic a, TupleableG (Rep a)) => TupleableOptions -> RelationTuple -> Either RelationalError a
genericFromTuple opts tup = to <$> fromTupleG opts tup
genericToAttributes :: forall a. (Generic a, TupleableG (Rep a)) => TupleableOptions -> Proxy a -> Attributes
genericToAttributes opts _ = toAttributesG opts (from (undefined :: a))
class TupleableG g where
toTupleG :: TupleableOptions -> g a -> RelationTuple
toAttributesG :: TupleableOptions -> g a -> Attributes
fromTupleG :: TupleableOptions -> RelationTuple -> Either RelationalError (g a)
isRecordTypeG :: g a -> Bool
instance (Datatype c, TupleableG a) => TupleableG (M1 D c a) where
toTupleG opts (M1 v) = toTupleG opts v
toAttributesG opts (M1 v) = toAttributesG opts v
fromTupleG opts v = M1 <$> fromTupleG opts v
isRecordTypeG (M1 v) = isRecordTypeG v
instance (Constructor c, TupleableG a, AtomableG a) => TupleableG (M1 C c a) where
toTupleG opts (M1 v) = RelationTuple attrs atoms
where
attrsToCheck = toAttributesG opts v
counter = V.generate (V.length attrsToCheck) id
attrs = V.zipWith (\num attr@(Attribute name typ) -> if T.null name then
Attribute ("attr" <> T.pack (show (num + 1))) typ
else
attr) counter attrsToCheck
atoms = V.fromList (toAtomsG v)
toAttributesG opts (M1 v) = toAttributesG opts v
fromTupleG opts tup = M1 <$> fromTupleG opts tup
isRecordTypeG (M1 v) = isRecordTypeG v
instance (TupleableG a, TupleableG b) => TupleableG (a :*: b) where
toTupleG = error "toTupleG"
toAttributesG opts ~(x :*: y) = toAttributesG opts x V.++ toAttributesG opts y
fromTupleG opts tup = (:*:) <$> fromTupleG opts tup <*> fromTupleG opts processedTuple
where
processedTuple = if isRecordTypeG (undefined :: a x) then
tup
else
trimTuple 1 tup
isRecordTypeG ~(x :*: y) = isRecordTypeG x || isRecordTypeG y
instance (Selector c, AtomableG a) => TupleableG (M1 S c a) where
toTupleG = error "toTupleG"
toAttributesG opts m@(M1 v) = V.singleton (Attribute modifiedName aType)
where
name = T.pack (selName m)
modifiedName = if T.null name then
name
else
fieldModifier opts name
aType = toAtomTypeG v
fromTupleG opts tup = if null name then
M1 <$> atomv (V.head (tupleAtoms tup))
else do
atom <- atomForAttributeName (fieldModifier opts (T.pack name)) tup
val <- atomv atom
pure (M1 val)
where
expectedAtomType = atomType (V.head (toAttributesG opts (undefined :: M1 S c a x)))
atomv atom = maybe (Left (AtomTypeMismatchError
expectedAtomType
(atomTypeForAtom atom)
)) Right (fromAtomG atom [atom])
name = selName (undefined :: M1 S c a x)
isRecordTypeG _ = not (null (selName (undefined :: M1 S c a x)))
instance TupleableG U1 where
toTupleG _ _ = emptyTuple
toAttributesG _ _ = emptyAttributes
fromTupleG _ _ = pure U1
isRecordTypeG _ = False