{-# LANGUAGE GADTs,ExistentialQuantification #-}
module ProjectM36.Relation where
import qualified Data.Set as S
import qualified Data.HashSet as HS
import Control.Monad
import qualified Data.Vector as V
import ProjectM36.Base
import ProjectM36.Tuple
import qualified ProjectM36.Attribute as A
import ProjectM36.TupleSet
import ProjectM36.Error
--import qualified Control.Parallel.Strategies as P
import qualified ProjectM36.TypeConstructorDef as TCD
import qualified ProjectM36.DataConstructorDef as DCD
import qualified Data.Text as T
import Data.Either (isRight)
import System.Random.Shuffle
import Control.Monad.Random

attributes :: Relation -> Attributes
attributes :: Relation -> Attributes
attributes (Relation Attributes
attrs RelationTupleSet
_ ) = Attributes
attrs

attributeNames :: Relation -> S.Set AttributeName
attributeNames :: Relation -> Set AttributeName
attributeNames (Relation Attributes
attrs RelationTupleSet
_) = Attributes -> Set AttributeName
A.attributeNameSet Attributes
attrs

attributeForName :: AttributeName -> Relation -> Either RelationalError Attribute
attributeForName :: AttributeName -> Relation -> Either RelationalError Attribute
attributeForName AttributeName
attrName (Relation Attributes
attrs RelationTupleSet
_) = AttributeName -> Attributes -> Either RelationalError Attribute
A.attributeForName AttributeName
attrName Attributes
attrs

attributesForNames :: S.Set AttributeName -> Relation -> Attributes
attributesForNames :: Set AttributeName -> Relation -> Attributes
attributesForNames Set AttributeName
attrNameSet (Relation Attributes
attrs RelationTupleSet
_) = Set AttributeName -> Attributes -> Attributes
A.attributesForNames Set AttributeName
attrNameSet Attributes
attrs

atomTypeForName :: AttributeName -> Relation -> Either RelationalError AtomType
atomTypeForName :: AttributeName -> Relation -> Either RelationalError AtomType
atomTypeForName AttributeName
attrName (Relation Attributes
attrs RelationTupleSet
_) = AttributeName -> Attributes -> Either RelationalError AtomType
A.atomTypeForAttributeName AttributeName
attrName Attributes
attrs

mkRelationFromList :: Attributes -> [[Atom]] -> Either RelationalError Relation
mkRelationFromList :: Attributes -> [[Atom]] -> Either RelationalError Relation
mkRelationFromList Attributes
attrs [[Atom]]
atomMatrix = do
  Attributes -> RelationTupleSet -> Relation
Relation Attributes
attrs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Attributes -> [[Atom]] -> Either RelationalError RelationTupleSet
mkTupleSetFromList Attributes
attrs [[Atom]]
atomMatrix
  
emptyRelationWithAttrs :: Attributes -> Relation  
emptyRelationWithAttrs :: Attributes -> Relation
emptyRelationWithAttrs Attributes
attrs = Attributes -> RelationTupleSet -> Relation
Relation Attributes
attrs RelationTupleSet
emptyTupleSet

mkRelation :: Attributes -> RelationTupleSet -> Either RelationalError Relation
mkRelation :: Attributes -> RelationTupleSet -> Either RelationalError Relation
mkRelation Attributes
attrs RelationTupleSet
tupleSet =
    --check that all tuples have the same keys
    --check that all tuples have keys (1-N) where N is the attribute count
    case Attributes
-> RelationTupleSet -> Either RelationalError RelationTupleSet
verifyTupleSet Attributes
attrs RelationTupleSet
tupleSet of
      Left RelationalError
err -> forall a b. a -> Either a b
Left RelationalError
err
      Right RelationTupleSet
verifiedTupleSet -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Attributes -> RelationTupleSet -> Relation
Relation Attributes
attrs RelationTupleSet
verifiedTupleSet
    
--less safe version of mkRelation skips verifyTupleSet
--useful for infinite or thunked tuple sets
--instead of returning a Left RelationalError, if a tuple does not match the relation's attributes, the tuple is simply removed
--duplicate tuples are NOT filtered by this creation method
mkRelationDeferVerify :: Attributes -> RelationTupleSet -> Either RelationalError Relation
mkRelationDeferVerify :: Attributes -> RelationTupleSet -> Either RelationalError Relation
mkRelationDeferVerify Attributes
attrs RelationTupleSet
tupleSet = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Attributes -> RelationTupleSet -> Relation
Relation Attributes
attrs ([RelationTuple] -> RelationTupleSet
RelationTupleSet (forall a. (a -> Bool) -> [a] -> [a]
filter RelationTuple -> Bool
tupleFilter (RelationTupleSet -> [RelationTuple]
asList RelationTupleSet
tupleSet)))
  where
    tupleFilter :: RelationTuple -> Bool
tupleFilter RelationTuple
tuple = forall a b. Either a b -> Bool
isRight (Attributes -> RelationTuple -> Either RelationalError RelationTuple
verifyTuple Attributes
attrs RelationTuple
tuple)
    
--return a relation of the same type except without any tuples
relationWithEmptyTupleSet :: Relation -> Relation    
relationWithEmptyTupleSet :: Relation -> Relation
relationWithEmptyTupleSet (Relation Attributes
attrs RelationTupleSet
_) = Attributes -> Relation
emptyRelationWithAttrs Attributes
attrs

mkRelationFromTuples :: Attributes -> [RelationTuple] -> Either RelationalError Relation
mkRelationFromTuples :: Attributes -> [RelationTuple] -> Either RelationalError Relation
mkRelationFromTuples Attributes
attrs [RelationTuple]
tupleSetList = do
   RelationTupleSet
tupSet <- Attributes
-> [RelationTuple] -> Either RelationalError RelationTupleSet
mkTupleSet Attributes
attrs [RelationTuple]
tupleSetList
   Attributes -> RelationTupleSet -> Either RelationalError Relation
mkRelation Attributes
attrs RelationTupleSet
tupSet

relationTrue :: Relation
relationTrue :: Relation
relationTrue = Attributes -> RelationTupleSet -> Relation
Relation Attributes
A.emptyAttributes RelationTupleSet
singletonTupleSet

relationFalse :: Relation
relationFalse :: Relation
relationFalse = Attributes -> RelationTupleSet -> Relation
Relation Attributes
A.emptyAttributes RelationTupleSet
emptyTupleSet

--if the relation contains one tuple, return it, otherwise Nothing
singletonTuple :: Relation -> Maybe RelationTuple
singletonTuple :: Relation -> Maybe RelationTuple
singletonTuple rel :: Relation
rel@(Relation Attributes
_ RelationTupleSet
tupleSet) =
  case Relation -> RelationCardinality
cardinality Relation
rel of
    RelationCardinality
Countable -> forall a. Maybe a
Nothing
    RelationCardinality
_ -> case RelationTupleSet -> [RelationTuple]
asList RelationTupleSet
tupleSet of
      [] -> forall a. Maybe a
Nothing
      RelationTuple
x : [RelationTuple]
_ -> forall a. a -> Maybe a
Just RelationTuple
x

-- this is still unncessarily expensive for (bigx union bigx) because each tuple is hashed and compared for equality (when the hashes match), but the major expense is attributesEqual, but we already know that all tuple attributes are equal (it's a precondition)
union :: Relation -> Relation -> Either RelationalError Relation
union :: Relation -> Relation -> Either RelationalError Relation
union (Relation Attributes
attrs1 RelationTupleSet
tupSet1) (Relation Attributes
attrs2 RelationTupleSet
tupSet2) 
  | Attributes -> Set AttributeName
A.attributeNameSet Attributes
attrs1 forall a. Eq a => a -> a -> Bool
/= Attributes -> Set AttributeName
A.attributeNameSet Attributes
attrs2 =
    forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Set AttributeName -> RelationalError
AttributeNamesMismatchError (Attributes -> Set AttributeName
A.attributeNameSet (Attributes -> Attributes -> Attributes
A.attributesDifference Attributes
attrs1 Attributes
attrs2))
  | Bool -> Bool
not (Attributes -> Attributes -> Bool
A.attributesEqual Attributes
attrs1 Attributes
attrs2) =
    forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Attributes -> RelationalError
AttributeTypesMismatchError forall a b. (a -> b) -> a -> b
$ Attributes -> Attributes -> Attributes
A.attributesDifference Attributes
attrs1 Attributes
attrs2
  | Bool
otherwise =
    forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Attributes -> RelationTupleSet -> Relation
Relation Attributes
attrs1 RelationTupleSet
newtuples
  where
    newtuples :: RelationTupleSet
newtuples = Attributes
-> RelationTupleSet -> RelationTupleSet -> RelationTupleSet
tupleSetUnion Attributes
attrs1 RelationTupleSet
tupSet1 RelationTupleSet
tupSet2

project :: S.Set AttributeName -> Relation -> Either RelationalError Relation
project :: Set AttributeName -> Relation -> Either RelationalError Relation
project Set AttributeName
attrNames rel :: Relation
rel@(Relation Attributes
_ RelationTupleSet
tupSet) = do
  Attributes
newAttrs <- Set AttributeName
-> Attributes -> Either RelationalError Attributes
A.projectionAttributesForNames Set AttributeName
attrNames (Relation -> Attributes
attributes Relation
rel)  
  [RelationTuple]
newTupleList <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Attributes -> RelationTuple -> Either RelationalError RelationTuple
tupleProject Attributes
newAttrs) (RelationTupleSet -> [RelationTuple]
asList RelationTupleSet
tupSet)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Attributes -> RelationTupleSet -> Relation
Relation Attributes
newAttrs ([RelationTuple] -> RelationTupleSet
RelationTupleSet (forall a. HashSet a -> [a]
HS.toList (forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList [RelationTuple]
newTupleList))))

renameMany :: S.Set (AttributeName, AttributeName) -> Relation -> Either RelationalError Relation
renameMany :: Set (AttributeName, AttributeName)
-> Relation -> Either RelationalError Relation
renameMany Set (AttributeName, AttributeName)
renames Relation
rel = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Relation
-> (AttributeName, AttributeName)
-> Either RelationalError Relation
folder Relation
rel (forall a. Set a -> [a]
S.toList Set (AttributeName, AttributeName)
renames)
  where
    folder :: Relation
-> (AttributeName, AttributeName)
-> Either RelationalError Relation
folder Relation
r (AttributeName
oldName, AttributeName
newName) = AttributeName
-> AttributeName -> Relation -> Either RelationalError Relation
rename AttributeName
oldName AttributeName
newName Relation
r
  
rename :: AttributeName -> AttributeName -> Relation -> Either RelationalError Relation
rename :: AttributeName
-> AttributeName -> Relation -> Either RelationalError Relation
rename AttributeName
oldAttrName AttributeName
newAttrName rel :: Relation
rel@(Relation Attributes
oldAttrs RelationTupleSet
oldTupSet) 
  | Bool -> Bool
not Bool
attributeValid = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Set AttributeName -> RelationalError
AttributeNamesMismatchError (forall a. a -> Set a
S.singleton AttributeName
oldAttrName)
  | Bool
newAttributeInUse = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ AttributeName -> RelationalError
AttributeNameInUseError AttributeName
newAttrName
  | Bool
otherwise = Attributes -> RelationTupleSet -> Either RelationalError Relation
mkRelation Attributes
newAttrs RelationTupleSet
newTupSet
  where
    newAttributeInUse :: Bool
newAttributeInUse = Set AttributeName -> Set AttributeName -> Bool
A.attributeNamesContained (forall a. a -> Set a
S.singleton AttributeName
newAttrName) (Relation -> Set AttributeName
attributeNames Relation
rel)
    attributeValid :: Bool
attributeValid = Set AttributeName -> Set AttributeName -> Bool
A.attributeNamesContained (forall a. a -> Set a
S.singleton AttributeName
oldAttrName) (Relation -> Set AttributeName
attributeNames Relation
rel)
    newAttrs :: Attributes
newAttrs = AttributeName -> AttributeName -> Attributes -> Attributes
A.renameAttributes AttributeName
oldAttrName AttributeName
newAttrName Attributes
oldAttrs
    newTupSet :: RelationTupleSet
newTupSet = [RelationTuple] -> RelationTupleSet
RelationTupleSet forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map RelationTuple -> RelationTuple
tupsetmapper (RelationTupleSet -> [RelationTuple]
asList RelationTupleSet
oldTupSet)
    tupsetmapper :: RelationTuple -> RelationTuple
tupsetmapper = AttributeName -> AttributeName -> RelationTuple -> RelationTuple
tupleRenameAttribute AttributeName
oldAttrName AttributeName
newAttrName

--the algebra should return a relation of one attribute and one row with the arity
arity :: Relation -> Int
arity :: Relation -> Int
arity (Relation Attributes
attrs RelationTupleSet
_) = Attributes -> Int
A.arity Attributes
attrs

degree :: Relation -> Int
degree :: Relation -> Int
degree = Relation -> Int
arity

cardinality :: Relation -> RelationCardinality --we need to detect infinite tuple sets- perhaps with a flag
cardinality :: Relation -> RelationCardinality
cardinality (Relation Attributes
_ RelationTupleSet
tupSet) = Int -> RelationCardinality
Finite (forall (t :: * -> *) a. Foldable t => t a -> Int
length (RelationTupleSet -> [RelationTuple]
asList RelationTupleSet
tupSet))

--find tuples where the atoms in the relation which are NOT in the AttributeNameSet are equal
-- create a relation for each tuple where the attributes NOT in the AttributeNameSet are equal
--the attrname set attrs end up in the nested relation

--algorithm:
-- map projection of non-grouped attributes to restriction of matching grouped attribute tuples and then project on grouped attributes to construct the sub-relation
{-
group :: S.Set AttributeName -> AttributeName -> Relation -> Either RelationalError Relation
group groupAttrNames newAttrName rel@(Relation oldAttrs tupleSet) = do
  nonGroupProjection <- project nonGroupAttrNames rel
  relFold folder (Right (Relation newAttrs emptyTupleSet)) nonGroupProjection
  where
    newAttrs = M.union (attributesForNames nonGroupAttrNames rel) groupAttr
    groupAttr = Attribute newAttrName RelationAtomType (invertedAttributeNames groupAttrNames (attributes rel))
    nonGroupAttrNames = invertAttributeNames (attributes rel) groupAttrNames
    --map the projection to add the additional new attribute
    --create the new attribute (a new relation) by filtering and projecting the tupleSet
    folder tupleFromProjection acc = case acc of
      Left err -> Left err
      Right acc -> union acc (Relation newAttrs (HS.singleton (tupleExtend tupleFromProjection (matchingRelTuple tupleFromProjection))))
-}

--algorithm: self-join with image relation
group :: S.Set AttributeName -> AttributeName -> Relation -> Either RelationalError Relation
group :: Set AttributeName
-> AttributeName -> Relation -> Either RelationalError Relation
group Set AttributeName
groupAttrNames AttributeName
newAttrName Relation
rel = do
  let nonGroupAttrNames :: Set AttributeName
nonGroupAttrNames = Set AttributeName -> Set AttributeName -> Set AttributeName
A.nonMatchingAttributeNameSet Set AttributeName
groupAttrNames (forall a. Ord a => [a] -> Set a
S.fromList (forall a. Vector a -> [a]
V.toList (Attributes -> Vector AttributeName
A.attributeNames (Relation -> Attributes
attributes Relation
rel))))
  Attributes
nonGroupProjectionAttributes <- Set AttributeName
-> Attributes -> Either RelationalError Attributes
A.projectionAttributesForNames Set AttributeName
nonGroupAttrNames (Relation -> Attributes
attributes Relation
rel)
  Attributes
groupProjectionAttributes <- Set AttributeName
-> Attributes -> Either RelationalError Attributes
A.projectionAttributesForNames Set AttributeName
groupAttrNames (Relation -> Attributes
attributes Relation
rel)
  let groupAttr :: Attribute
groupAttr = AttributeName -> AtomType -> Attribute
Attribute AttributeName
newAttrName (Attributes -> AtomType
RelationAtomType Attributes
groupProjectionAttributes)
      matchingRelTuple :: RelationTuple -> RelationTuple
matchingRelTuple RelationTuple
tupIn = case RelationTuple -> Relation -> Either RelationalError Relation
imageRelationFor RelationTuple
tupIn Relation
rel of
        Right Relation
rel2 -> Attributes -> Vector Atom -> RelationTuple
RelationTuple (Attribute -> Attributes
A.singleton Attribute
groupAttr) (forall a. a -> Vector a
V.singleton (Relation -> Atom
RelationAtom Relation
rel2))
        Left RelationalError
_ -> forall a. HasCallStack => a
undefined
      mogrifier :: RelationTuple -> Either RelationalError RelationTuple
mogrifier RelationTuple
tupIn = forall (f :: * -> *) a. Applicative f => a -> f a
pure (RelationTuple -> RelationTuple -> RelationTuple
tupleExtend RelationTuple
tupIn (RelationTuple -> RelationTuple
matchingRelTuple RelationTuple
tupIn))
      newAttrs :: Attributes
newAttrs = Attribute -> Attributes -> Attributes
A.addAttribute Attribute
groupAttr Attributes
nonGroupProjectionAttributes
  Relation
nonGroupProjection <- Set AttributeName -> Relation -> Either RelationalError Relation
project Set AttributeName
nonGroupAttrNames Relation
rel
  (RelationTuple -> Either RelationalError RelationTuple)
-> Attributes -> Relation -> Either RelationalError Relation
relMogrify RelationTuple -> Either RelationalError RelationTuple
mogrifier Attributes
newAttrs Relation
nonGroupProjection


--help restriction function
--returns a subrelation of
restrictEq :: RelationTuple -> Relation -> Either RelationalError Relation
restrictEq :: RelationTuple -> Relation -> Either RelationalError Relation
restrictEq RelationTuple
tuple = RestrictionFilter -> Relation -> Either RelationalError Relation
restrict RestrictionFilter
rfilter
  where
    rfilter :: RelationTuple -> Either RelationalError Bool
    rfilter :: RestrictionFilter
rfilter RelationTuple
tupleIn = do
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (RelationTuple -> RelationTuple -> RelationTuple
tupleIntersection RelationTuple
tuple RelationTuple
tupleIn forall a. Eq a => a -> a -> Bool
== RelationTuple
tuple)

-- unwrap relation-valued attribute
-- return error if relval attrs and nongroup attrs overlap
ungroup :: AttributeName -> Relation -> Either RelationalError Relation
ungroup :: AttributeName -> Relation -> Either RelationalError Relation
ungroup AttributeName
relvalAttrName Relation
rel = case AttributeName -> Relation -> Either RelationalError Attributes
attributesForRelval AttributeName
relvalAttrName Relation
rel of
  Left RelationalError
err -> forall a b. a -> Either a b
Left RelationalError
err
  Right Attributes
relvalAttrs -> forall a. (RelationTuple -> a -> a) -> a -> Relation -> a
relFold RelationTuple
-> Either RelationalError Relation
-> Either RelationalError Relation
relFolder (forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Attributes -> RelationTupleSet -> Relation
Relation Attributes
newAttrs RelationTupleSet
emptyTupleSet) Relation
rel
   where
    newAttrs :: Attributes
newAttrs = Attributes -> Attributes -> Attributes
A.addAttributes Attributes
relvalAttrs Attributes
nonGroupAttrs
    nonGroupAttrs :: Attributes
nonGroupAttrs = AttributeName -> Attributes -> Attributes
A.deleteAttributeName AttributeName
relvalAttrName (Relation -> Attributes
attributes Relation
rel)
    relFolder :: RelationTuple -> Either RelationalError Relation -> Either RelationalError Relation
    relFolder :: RelationTuple
-> Either RelationalError Relation
-> Either RelationalError Relation
relFolder RelationTuple
tupleIn Either RelationalError Relation
acc = case Either RelationalError Relation
acc of
        Left RelationalError
err -> forall a b. a -> Either a b
Left RelationalError
err
        Right Relation
accRel -> do
                        Relation
ungrouped <- AttributeName
-> Attributes -> RelationTuple -> Either RelationalError Relation
tupleUngroup AttributeName
relvalAttrName Attributes
newAttrs RelationTuple
tupleIn
                        Relation
accRel Relation -> Relation -> Either RelationalError Relation
`union` Relation
ungrouped

--take an relval attribute name and a tuple and ungroup the relval
tupleUngroup :: AttributeName -> Attributes -> RelationTuple -> Either RelationalError Relation
tupleUngroup :: AttributeName
-> Attributes -> RelationTuple -> Either RelationalError Relation
tupleUngroup AttributeName
relvalAttrName Attributes
newAttrs RelationTuple
tuple = do
  Relation
relvalRelation <- AttributeName -> RelationTuple -> Either RelationalError Relation
relationForAttributeName AttributeName
relvalAttrName RelationTuple
tuple
  let nonGroupAttrs :: Attributes
nonGroupAttrs = Attributes -> Attributes -> Attributes
A.intersection Attributes
newAttrs (RelationTuple -> Attributes
tupleAttributes RelationTuple
tuple)
  RelationTuple
nonGroupTupleProjection <- Attributes -> RelationTuple -> Either RelationalError RelationTuple
tupleProject Attributes
nonGroupAttrs RelationTuple
tuple
  let folder :: RelationTuple
-> Either RelationalError Relation
-> Either RelationalError Relation
folder RelationTuple
tupleIn Either RelationalError Relation
acc = case Either RelationalError Relation
acc of
        Left RelationalError
err -> forall a b. a -> Either a b
Left RelationalError
err
        Right Relation
accRel ->
          Relation -> Relation -> Either RelationalError Relation
union Relation
accRel forall a b. (a -> b) -> a -> b
$ Attributes -> RelationTupleSet -> Relation
Relation Attributes
newAttrs ([RelationTuple] -> RelationTupleSet
RelationTupleSet [RelationTuple -> RelationTuple -> RelationTuple
tupleExtend RelationTuple
nonGroupTupleProjection RelationTuple
tupleIn])
  forall a. (RelationTuple -> a -> a) -> a -> Relation -> a
relFold RelationTuple
-> Either RelationalError Relation
-> Either RelationalError Relation
folder (forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Attributes -> RelationTupleSet -> Relation
Relation Attributes
newAttrs RelationTupleSet
emptyTupleSet) Relation
relvalRelation

attributesForRelval :: AttributeName -> Relation -> Either RelationalError Attributes
attributesForRelval :: AttributeName -> Relation -> Either RelationalError Attributes
attributesForRelval AttributeName
relvalAttrName (Relation Attributes
attrs RelationTupleSet
_) = do
  AtomType
atomType <- AttributeName -> Attributes -> Either RelationalError AtomType
A.atomTypeForAttributeName AttributeName
relvalAttrName Attributes
attrs
  case AtomType
atomType of
    (RelationAtomType Attributes
relAttrs) -> forall a b. b -> Either a b
Right Attributes
relAttrs
    AtomType
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ AttributeName -> RelationalError
AttributeIsNotRelationValuedError AttributeName
relvalAttrName

type RestrictionFilter = RelationTuple -> Either RelationalError Bool
restrict :: RestrictionFilter -> Relation -> Either RelationalError Relation
restrict :: RestrictionFilter -> Relation -> Either RelationalError Relation
restrict RestrictionFilter
rfilter (Relation Attributes
attrs RelationTupleSet
tupset) = do
  [RelationTuple]
tuples <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM RestrictionFilter
rfilter (RelationTupleSet -> [RelationTuple]
asList RelationTupleSet
tupset)
  forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Attributes -> RelationTupleSet -> Relation
Relation Attributes
attrs ([RelationTuple] -> RelationTupleSet
RelationTupleSet [RelationTuple]
tuples)

--joins on columns with the same name- use rename to avoid this- base case: cartesian product
--after changing from string atoms, there needs to be a type-checking step!
--this is a "nested loop" scan as described by the postgresql documentation
join :: Relation -> Relation -> Either RelationalError Relation
join :: Relation -> Relation -> Either RelationalError Relation
join (Relation Attributes
attrs1 RelationTupleSet
tupSet1) (Relation Attributes
attrs2 RelationTupleSet
tupSet2) = do
  Attributes
newAttrs <- Attributes -> Attributes -> Either RelationalError Attributes
A.joinAttributes Attributes
attrs1 Attributes
attrs2
  let tupleSetJoiner :: [RelationTuple]
-> RelationTuple -> Either RelationalError [RelationTuple]
tupleSetJoiner [RelationTuple]
accumulator RelationTuple
tuple1 = do
        [RelationTuple]
joinedTupSet <- Attributes
-> RelationTuple
-> RelationTupleSet
-> Either RelationalError [RelationTuple]
singleTupleSetJoin Attributes
newAttrs RelationTuple
tuple1 RelationTupleSet
tupSet2
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [RelationTuple]
joinedTupSet forall a. [a] -> [a] -> [a]
++ [RelationTuple]
accumulator
  [RelationTuple]
newTupSetList <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM [RelationTuple]
-> RelationTuple -> Either RelationalError [RelationTuple]
tupleSetJoiner [] (RelationTupleSet -> [RelationTuple]
asList RelationTupleSet
tupSet1)
  Attributes -> RelationTupleSet -> Relation
Relation Attributes
newAttrs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Attributes
-> [RelationTuple] -> Either RelationalError RelationTupleSet
mkTupleSet Attributes
newAttrs [RelationTuple]
newTupSetList
  
-- | Difference takes two relations of the same type and returns a new relation which contains only tuples which appear in the first relation but not the second.
difference :: Relation -> Relation -> Either RelationalError Relation  
difference :: Relation -> Relation -> Either RelationalError Relation
difference Relation
relA Relation
relB = 
  if Bool -> Bool
not (Attributes -> Attributes -> Bool
A.attributesEqual (Relation -> Attributes
attributes Relation
relA) (Relation -> Attributes
attributes Relation
relB))
  then 
    forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Set AttributeName -> RelationalError
AttributeNamesMismatchError (Attributes -> Set AttributeName
A.attributeNameSet (Attributes -> Attributes -> Attributes
A.attributesDifference Attributes
attrsA Attributes
attrsB))
  else 
    RestrictionFilter -> Relation -> Either RelationalError Relation
restrict RestrictionFilter
rfilter Relation
relA
  where
    attrsA :: Attributes
attrsA = Relation -> Attributes
attributes Relation
relA
    attrsB :: Attributes
attrsB = Relation -> Attributes
attributes Relation
relB
    rfilter :: RestrictionFilter
rfilter RelationTuple
tupInA = forall a. (RelationTuple -> a -> a) -> a -> Relation -> a
relFold (\RelationTuple
tupInB Either RelationalError Bool
acc -> if Either RelationalError Bool
acc forall a. Eq a => a -> a -> Bool
== forall a b. b -> Either a b
Right Bool
False then forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False else forall (f :: * -> *) a. Applicative f => a -> f a
pure (RelationTuple
tupInB forall a. Eq a => a -> a -> Bool
/= RelationTuple
tupInA)) (forall a b. b -> Either a b
Right Bool
True) Relation
relB
      
--a map should NOT change the structure of a relation, so attributes should be constant
relMap :: (RelationTuple -> Either RelationalError RelationTuple) -> Relation -> Either RelationalError Relation
relMap :: (RelationTuple -> Either RelationalError RelationTuple)
-> Relation -> Either RelationalError Relation
relMap RelationTuple -> Either RelationalError RelationTuple
mapper (Relation Attributes
attrs RelationTupleSet
tupleSet) = 
  case forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (RelationTupleSet -> [RelationTuple]
asList RelationTupleSet
tupleSet) RelationTuple -> Either RelationalError RelationTuple
typeMapCheck of
    Right [RelationTuple]
remappedTupleSet -> Attributes -> RelationTupleSet -> Either RelationalError Relation
mkRelation Attributes
attrs ([RelationTuple] -> RelationTupleSet
RelationTupleSet [RelationTuple]
remappedTupleSet)
    Left RelationalError
err -> forall a b. a -> Either a b
Left RelationalError
err
  where
    typeMapCheck :: RelationTuple -> Either RelationalError RelationTuple
typeMapCheck RelationTuple
tupleIn = do
      RelationTuple
remappedTuple <- RelationTuple -> Either RelationalError RelationTuple
mapper RelationTuple
tupleIn
      if RelationTuple -> Attributes
tupleAttributes RelationTuple
remappedTuple forall a. Eq a => a -> a -> Bool
== RelationTuple -> Attributes
tupleAttributes RelationTuple
tupleIn
        then forall a b. b -> Either a b
Right RelationTuple
remappedTuple
        else forall a b. a -> Either a b
Left (Attributes -> RelationalError
TupleAttributeTypeMismatchError (Attributes -> Attributes -> Attributes
A.attributesDifference (RelationTuple -> Attributes
tupleAttributes RelationTuple
tupleIn) Attributes
attrs))

relMogrify :: (RelationTuple -> Either RelationalError RelationTuple) -> Attributes -> Relation -> Either RelationalError Relation
relMogrify :: (RelationTuple -> Either RelationalError RelationTuple)
-> Attributes -> Relation -> Either RelationalError Relation
relMogrify RelationTuple -> Either RelationalError RelationTuple
mapper Attributes
newAttributes (Relation Attributes
_ RelationTupleSet
tupSet) = do
  [RelationTuple]
newTuples <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Attributes -> RelationTuple -> RelationTuple
reorderTuple Attributes
newAttributes) forall b c a. (b -> c) -> (a -> b) -> a -> c
. RelationTuple -> Either RelationalError RelationTuple
mapper) (RelationTupleSet -> [RelationTuple]
asList RelationTupleSet
tupSet)
                    
  Attributes -> [RelationTuple] -> Either RelationalError Relation
mkRelationFromTuples Attributes
newAttributes [RelationTuple]
newTuples

relFold :: (RelationTuple -> a -> a) -> a -> Relation -> a
relFold :: forall a. (RelationTuple -> a -> a) -> a -> Relation -> a
relFold RelationTuple -> a -> a
folder a
acc (Relation Attributes
_ RelationTupleSet
tupleSet) = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr RelationTuple -> a -> a
folder a
acc (RelationTupleSet -> [RelationTuple]
asList RelationTupleSet
tupleSet)

-- | Generate a randomly-ordered list of tuples from the relation.
toList :: Relation -> IO [RelationTuple]
toList :: Relation -> IO [RelationTuple]
toList Relation
rel = do 
  StdGen
gen <- forall (m :: * -> *). MonadIO m => m StdGen
newStdGen
  let rel' :: Relation
rel' = forall g a. Rand g a -> g -> a
evalRand (forall (m :: * -> *). MonadRandom m => Relation -> m Relation
randomizeTupleOrder Relation
rel) StdGen
gen
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. (RelationTuple -> a -> a) -> a -> Relation -> a
relFold (:) [] Relation
rel')

--image relation as defined by CJ Date
--given tupleA and relationB, return restricted relation where tuple attributes are not the attribues in tupleA but are attributes in relationB and match the tuple's value

--check that matching attribute names have the same types
imageRelationFor ::  RelationTuple -> Relation -> Either RelationalError Relation
imageRelationFor :: RelationTuple -> Relation -> Either RelationalError Relation
imageRelationFor RelationTuple
matchTuple Relation
rel = do
  Relation
restricted <- RelationTuple -> Relation -> Either RelationalError Relation
restrictEq RelationTuple
matchTuple Relation
rel --restrict across matching tuples
  let projectionAttrNames :: Set AttributeName
projectionAttrNames = Set AttributeName -> Set AttributeName -> Set AttributeName
A.nonMatchingAttributeNameSet (Relation -> Set AttributeName
attributeNames Relation
rel) (RelationTuple -> Set AttributeName
tupleAttributeNameSet RelationTuple
matchTuple)
  Set AttributeName -> Relation -> Either RelationalError Relation
project Set AttributeName
projectionAttrNames Relation
restricted --project across attributes not in rel

--returns a relation-valued attribute image relation for each tuple in rel1
--algorithm:
  {-
imageRelationJoin :: Relation -> Relation -> Either RelationalError Relation
imageRelationJoin rel1@(Relation attrNameSet1 tupSet1) rel2@(Relation attrNameSet2 tupSet2) = do
  Right $ Relation undefined
  where
    matchingAttrs = matchingAttributeNameSet attrNameSet1 attrNameSet2
    newAttrs = nonMatchingAttributeNameSet matchingAttrs $ S.union attrNameSet1 attrNameSet2

    tupleSetJoiner tup1 acc = undefined
-}

-- | Return a Relation describing the types in the mapping.
typesAsRelation :: TypeConstructorMapping -> Either RelationalError Relation
typesAsRelation :: TypeConstructorMapping -> Either RelationalError Relation
typesAsRelation TypeConstructorMapping
types = Attributes -> [RelationTuple] -> Either RelationalError Relation
mkRelationFromTuples Attributes
attrs [RelationTuple]
tuples
  where
    attrs :: Attributes
attrs = [Attribute] -> Attributes
A.attributesFromList [AttributeName -> AtomType -> Attribute
Attribute AttributeName
"TypeConstructor" AtomType
TextAtomType,
                                AttributeName -> AtomType -> Attribute
Attribute AttributeName
"DataConstructors" AtomType
dConsType]
    subAttrs :: Attributes
subAttrs = [Attribute] -> Attributes
A.attributesFromList [AttributeName -> AtomType -> Attribute
Attribute AttributeName
"DataConstructor" AtomType
TextAtomType]
    dConsType :: AtomType
dConsType = Attributes -> AtomType
RelationAtomType Attributes
subAttrs
    tuples :: [RelationTuple]
tuples = forall a b. (a -> b) -> [a] -> [b]
map (TypeConstructorDef, [DataConstructorDef]) -> RelationTuple
mkTypeConsDescription TypeConstructorMapping
types
    
    mkTypeConsDescription :: (TypeConstructorDef, [DataConstructorDef]) -> RelationTuple
mkTypeConsDescription (TypeConstructorDef
tCons, [DataConstructorDef]
dConsList) =
      Attributes -> Vector Atom -> RelationTuple
RelationTuple Attributes
attrs (forall a. [a] -> Vector a
V.fromList [AttributeName -> Atom
TextAtom (TypeConstructorDef -> AttributeName
TCD.name TypeConstructorDef
tCons), [DataConstructorDef] -> Atom
mkDataConsRelation [DataConstructorDef]
dConsList])
    
    mkDataConsRelation :: [DataConstructorDef] -> Atom
mkDataConsRelation [DataConstructorDef]
dConsList = case Attributes -> [RelationTuple] -> Either RelationalError Relation
mkRelationFromTuples Attributes
subAttrs forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\DataConstructorDef
dCons -> Attributes -> Vector Atom -> RelationTuple
RelationTuple Attributes
subAttrs (forall a. a -> Vector a
V.singleton forall a b. (a -> b) -> a -> b
$ AttributeName -> Atom
TextAtom forall a b. (a -> b) -> a -> b
$ AttributeName -> [AttributeName] -> AttributeName
T.intercalate AttributeName
" " (DataConstructorDef -> AttributeName
DCD.name DataConstructorDef
dConsforall a. a -> [a] -> [a]
:forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> AttributeName
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show) (DataConstructorDef -> [DataConstructorDefArg]
DCD.fields DataConstructorDef
dCons)))) [DataConstructorDef]
dConsList of
      Left RelationalError
err -> forall a. HasCallStack => [Char] -> a
error ([Char]
"mkRelationFromTuples pooped " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show RelationalError
err)
      Right Relation
rel -> Relation -> Atom
RelationAtom Relation
rel
      
-- | Randomly resort the tuples. This is useful for emphasizing that two relations are equal even when they are printed to the console in different orders.
randomizeTupleOrder :: MonadRandom m => Relation -> m Relation
randomizeTupleOrder :: forall (m :: * -> *). MonadRandom m => Relation -> m Relation
randomizeTupleOrder (Relation Attributes
attrs RelationTupleSet
tupSet) = 
  Attributes -> RelationTupleSet -> Relation
Relation Attributes
attrs forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RelationTuple] -> RelationTupleSet
RelationTupleSet forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadRandom m => [a] -> m [a]
shuffleM (RelationTupleSet -> [RelationTuple]
asList RelationTupleSet
tupSet)

-- returns a tuple from the tupleset- this is useful for priming folds over the tuples
oneTuple :: Relation -> Maybe RelationTuple
oneTuple :: Relation -> Maybe RelationTuple
oneTuple (Relation Attributes
_ (RelationTupleSet [])) = forall a. Maybe a
Nothing
oneTuple (Relation Attributes
_ (RelationTupleSet (RelationTuple
x:[RelationTuple]
_))) = forall a. a -> Maybe a
Just RelationTuple
x

tuplesList :: Relation -> [RelationTuple]
tuplesList :: Relation -> [RelationTuple]
tuplesList (Relation Attributes
_ RelationTupleSet
tupleSet) = RelationTupleSet -> [RelationTuple]
asList RelationTupleSet
tupleSet