{-# LANGUAGE ExistentialQuantification,DeriveGeneric,DeriveAnyClass,FlexibleInstances,OverloadedStrings, DeriveTraversable #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module ProjectM36.Base where
import ProjectM36.DatabaseContextFunctionError
import ProjectM36.AtomFunctionError
import ProjectM36.MerkleHash
import qualified Data.Map as M
import qualified Data.HashSet as HS
import Data.Hashable (Hashable, hashWithSalt)
import qualified Data.Set as S
import Data.UUID (UUID)
import Control.DeepSeq (NFData, rnf)
import Control.DeepSeq.Generics (genericRnf)
import GHC.Generics (Generic)
import GHC.Stack
import qualified Data.Vector as V
import qualified Data.List as L
import Data.Text (Text,unpack)
import Data.Binary
import Data.Vector.Binary()
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Data.Time.Calendar (Day,toGregorian,fromGregorian)
import Data.Hashable.Time ()
import Data.Typeable
import Data.ByteString (ByteString)
import qualified Data.List.NonEmpty as NE
type StringType = Text
data Atom = IntegerAtom Integer |
IntAtom Int |
DoubleAtom Double |
TextAtom Text |
DayAtom Day |
DateTimeAtom UTCTime |
ByteStringAtom ByteString |
BoolAtom Bool |
RelationAtom Relation |
ConstructedAtom DataConstructorName AtomType [Atom]
deriving (Eq, Show, Binary, Typeable, NFData, Generic)
instance Hashable Atom where
hashWithSalt salt (ConstructedAtom dConsName _ atoms) = salt `hashWithSalt` atoms
`hashWithSalt` dConsName
hashWithSalt salt (IntAtom i) = salt `hashWithSalt` i
hashWithSalt salt (IntegerAtom i) = salt `hashWithSalt` i
hashWithSalt salt (DoubleAtom d) = salt `hashWithSalt` d
hashWithSalt salt (TextAtom t) = salt `hashWithSalt` t
hashWithSalt salt (DayAtom d) = salt `hashWithSalt` d
hashWithSalt salt (DateTimeAtom dt) = salt `hashWithSalt` dt
hashWithSalt salt (ByteStringAtom bs) = salt `hashWithSalt` bs
hashWithSalt salt (BoolAtom b) = salt `hashWithSalt` b
hashWithSalt salt (RelationAtom r) = salt `hashWithSalt` r
instance Binary UTCTime where
put utc = put $ toRational (utcTimeToPOSIXSeconds utc)
get = posixSecondsToUTCTime . fromRational <$> (get :: Get Rational)
instance Binary Day where
put day = put $ toGregorian day
get = do
(y,m,d) <- get :: Get (Integer, Int, Int)
return (fromGregorian y m d)
data AtomType = IntAtomType |
IntegerAtomType |
DoubleAtomType |
TextAtomType |
DayAtomType |
DateTimeAtomType |
ByteStringAtomType |
BoolAtomType |
RelationAtomType Attributes |
ConstructedAtomType TypeConstructorName TypeVarMap |
TypeVariableType TypeVarName
deriving (Eq, NFData, Generic, Binary, Show)
instance Ord AtomType where
compare = undefined
type TypeVarMap = M.Map TypeVarName AtomType
instance Hashable TypeVarMap where
hashWithSalt salt tvmap = hashWithSalt salt (M.keys tvmap)
isRelationAtomType :: AtomType -> Bool
isRelationAtomType (RelationAtomType _) = True
isRelationAtomType _ = False
type AttributeName = StringType
data Attribute = Attribute AttributeName AtomType deriving (Eq, Show, Generic, NFData, Binary)
instance Hashable Attribute where
hashWithSalt salt (Attribute attrName _) = hashWithSalt salt attrName
type Attributes = V.Vector Attribute
attributesEqual :: Attributes -> Attributes -> Bool
attributesEqual attrs1 attrs2 = attrsAsSet attrs1 == attrsAsSet attrs2
where
attrsAsSet = HS.fromList . V.toList
sortedAttributesIndices :: Attributes -> [(Int, Attribute)]
sortedAttributesIndices attrs = L.sortBy (\(_, Attribute name1 _) (_,Attribute name2 _) -> compare name1 name2) $ V.toList (V.indexed attrs)
newtype RelationTupleSet = RelationTupleSet { asList :: [RelationTuple] } deriving (Hashable, Show, Generic, Binary)
instance Read Relation where
readsPrec = error "relation read not supported"
instance Eq RelationTupleSet where
set1 == set2 = hset set1 == hset set2
where
hset = HS.fromList . asList
instance NFData RelationTupleSet where rnf = genericRnf
instance Hashable RelationTuple where
hashWithSalt salt (RelationTuple attrs tupVec) = if V.length attrs /= V.length tupVec then
error "invalid tuple: attributes and tuple count mismatch"
else
salt `hashWithSalt`
sortedAttrs `hashWithSalt`
V.toList sortedTupVec
where
sortedAttrsIndices = sortedAttributesIndices attrs
sortedAttrs = map snd sortedAttrsIndices
sortedTupVec = V.map (\(index, _) -> tupVec V.! index) $ V.fromList sortedAttrsIndices
data RelationTuple = RelationTuple Attributes (V.Vector Atom) deriving (Show, Generic)
instance Binary RelationTuple
instance Eq RelationTuple where
(==) tuple1@(RelationTuple attrs1 _) tuple2@(RelationTuple attrs2 _) = attributesEqual attrs1 attrs2 && atomsEqual
where
atomForAttribute attr (RelationTuple attrs tupVec) = case V.findIndex (== attr) attrs of
Nothing -> Nothing
Just index -> tupVec V.!? index
atomsEqual = V.all (== True) $ V.map (\attr -> atomForAttribute attr tuple1 == atomForAttribute attr tuple2) attrs1
instance NFData RelationTuple where rnf = genericRnf
data Relation = Relation Attributes RelationTupleSet deriving (Show, Generic,Typeable)
instance Eq Relation where
Relation attrs1 tupSet1 == Relation attrs2 tupSet2 = attributesEqual attrs1 attrs2 && tupSet1 == tupSet2
instance NFData Relation where rnf = genericRnf
instance Hashable Relation where
hashWithSalt salt (Relation attrs tupSet) = salt `hashWithSalt`
sortedAttrs `hashWithSalt`
asList tupSet
where
sortedAttrs = map snd (sortedAttributesIndices attrs)
instance Binary Relation
data RelationCardinality = Countable | Finite Int deriving (Eq, Show, Generic, Ord)
type RelVarName = StringType
type RelationalExpr = RelationalExprBase ()
data RelationalExprBase a =
MakeRelationFromExprs (Maybe [AttributeExprBase a]) (TupleExprsBase a) |
MakeStaticRelation Attributes RelationTupleSet |
ExistingRelation Relation |
RelationVariable RelVarName a |
Project (AttributeNamesBase a) (RelationalExprBase a) |
Union (RelationalExprBase a) (RelationalExprBase a) |
Join (RelationalExprBase a) (RelationalExprBase a) |
Rename AttributeName AttributeName (RelationalExprBase a) |
Difference (RelationalExprBase a) (RelationalExprBase a) |
Group (AttributeNamesBase a) AttributeName (RelationalExprBase a) |
Ungroup AttributeName (RelationalExprBase a) |
Restrict (RestrictionPredicateExprBase a) (RelationalExprBase a) |
Equals (RelationalExprBase a) (RelationalExprBase a) |
NotEquals (RelationalExprBase a) (RelationalExprBase a) |
Extend (ExtendTupleExprBase a) (RelationalExprBase a) |
With [(WithNameExprBase a, RelationalExprBase a)] (RelationalExprBase a)
deriving (Show, Eq, Generic, NFData, Foldable, Functor, Traversable)
instance Binary RelationalExpr
data WithNameExprBase a = WithNameExpr RelVarName a
deriving (Show, Eq, Generic, NFData, Foldable, Functor, Traversable)
type WithNameExpr = WithNameExprBase ()
instance Binary WithNameExpr
type GraphRefWithNameExpr = WithNameExprBase GraphRefTransactionMarker
type NotificationName = StringType
type Notifications = M.Map NotificationName Notification
data Notification = Notification {
changeExpr :: RelationalExpr,
reportOldExpr :: RelationalExpr,
reportNewExpr :: RelationalExpr
}
deriving (Show, Eq, Binary, Generic, NFData)
type TypeVarName = StringType
data TypeConstructorDef = ADTypeConstructorDef TypeConstructorName [TypeVarName] |
PrimitiveTypeConstructorDef TypeConstructorName AtomType
deriving (Show, Generic, Binary, Eq, NFData)
type TypeConstructor = TypeConstructorBase ()
data TypeConstructorBase a = ADTypeConstructor TypeConstructorName [TypeConstructor] |
PrimitiveTypeConstructor TypeConstructorName AtomType |
RelationAtomTypeConstructor [AttributeExprBase a] |
TypeVariable TypeVarName
deriving (Show, Generic, Binary, Eq, NFData)
type TypeConstructorMapping = [(TypeConstructorDef, DataConstructorDefs)]
type TypeConstructorName = StringType
type TypeConstructorArgName = StringType
type DataConstructorName = StringType
type AtomTypeName = StringType
data DataConstructorDef = DataConstructorDef DataConstructorName [DataConstructorDefArg] deriving (Eq, Show, Binary, Generic, NFData)
type DataConstructorDefs = [DataConstructorDef]
data DataConstructorDefArg = DataConstructorDefTypeConstructorArg TypeConstructor |
DataConstructorDefTypeVarNameArg TypeVarName
deriving (Show, Generic, Binary, Eq, NFData)
type InclusionDependencies = M.Map IncDepName InclusionDependency
type RelationVariables = M.Map RelVarName GraphRefRelationalExpr
data GraphRefTransactionMarker = TransactionMarker TransactionId |
UncommittedContextMarker
deriving (Eq, Show, Binary, Generic, NFData, Ord)
type GraphRefRelationalExpr = RelationalExprBase GraphRefTransactionMarker
type SchemaName = StringType
type Subschemas = M.Map SchemaName Schema
data Schemas = Schemas DatabaseContext Subschemas
newtype Schema = Schema SchemaIsomorphs
deriving (Generic, Binary)
data SchemaIsomorph = IsoRestrict RelVarName RestrictionPredicateExpr (RelVarName, RelVarName) |
IsoRename RelVarName RelVarName |
IsoUnion (RelVarName, RelVarName) RestrictionPredicateExpr RelVarName
deriving (Generic, Binary, Show)
type SchemaIsomorphs = [SchemaIsomorph]
data DatabaseContext = DatabaseContext {
inclusionDependencies :: InclusionDependencies,
relationVariables :: RelationVariables,
atomFunctions :: AtomFunctions,
dbcFunctions :: DatabaseContextFunctions,
notifications :: Notifications,
typeConstructorMapping :: TypeConstructorMapping
} deriving (NFData, Generic)
type IncDepName = StringType
data InclusionDependency = InclusionDependency RelationalExpr RelationalExpr deriving (Show, Eq, Generic, NFData)
instance Binary InclusionDependency
type AttributeNameAtomExprMap = M.Map AttributeName AtomExpr
type DatabaseContextExprName = StringType
type DatabaseContextExpr = DatabaseContextExprBase ()
type GraphRefDatabaseContextExpr = DatabaseContextExprBase GraphRefTransactionMarker
instance Binary GraphRefDatabaseContextExpr
data DatabaseContextExprBase a =
NoOperation |
Define RelVarName [AttributeExprBase a] |
Undefine RelVarName |
Assign RelVarName (RelationalExprBase a) |
Insert RelVarName (RelationalExprBase a) |
Delete RelVarName (RestrictionPredicateExprBase a) |
Update RelVarName AttributeNameAtomExprMap (RestrictionPredicateExprBase a) |
AddInclusionDependency IncDepName InclusionDependency |
RemoveInclusionDependency IncDepName |
AddNotification NotificationName RelationalExpr RelationalExpr RelationalExpr |
RemoveNotification NotificationName |
AddTypeConstructor TypeConstructorDef [DataConstructorDef] |
RemoveTypeConstructor TypeConstructorName |
RemoveAtomFunction AtomFunctionName |
RemoveDatabaseContextFunction DatabaseContextFunctionName |
ExecuteDatabaseContextFunction DatabaseContextFunctionName [AtomExprBase a] |
MultipleExpr [DatabaseContextExprBase a]
deriving (Show, Eq, Generic)
instance Binary DatabaseContextExpr
type ObjModuleName = StringType
type ObjFunctionName = StringType
type Range = (Int,Int)
data DatabaseContextIOExprBase a =
AddAtomFunction AtomFunctionName [TypeConstructor] AtomFunctionBodyScript |
LoadAtomFunctions ObjModuleName ObjFunctionName FilePath |
AddDatabaseContextFunction DatabaseContextFunctionName [TypeConstructor] DatabaseContextFunctionBodyScript |
LoadDatabaseContextFunctions ObjModuleName ObjFunctionName FilePath |
CreateArbitraryRelation RelVarName [AttributeExprBase a] Range
deriving (Show, Eq, Generic, Binary)
type GraphRefDatabaseContextIOExpr = DatabaseContextIOExprBase GraphRefTransactionMarker
type DatabaseContextIOExpr = DatabaseContextIOExprBase ()
type RestrictionPredicateExpr = RestrictionPredicateExprBase ()
type GraphRefRestrictionPredicateExpr = RestrictionPredicateExprBase GraphRefTransactionMarker
data RestrictionPredicateExprBase a =
TruePredicate |
AndPredicate (RestrictionPredicateExprBase a) (RestrictionPredicateExprBase a) |
OrPredicate (RestrictionPredicateExprBase a) (RestrictionPredicateExprBase a) |
NotPredicate (RestrictionPredicateExprBase a) |
RelationalExprPredicate (RelationalExprBase a) |
AtomExprPredicate (AtomExprBase a) |
AttributeEqualityPredicate AttributeName (AtomExprBase a)
deriving (Show, Eq, Generic, NFData, Foldable, Functor, Traversable)
instance Binary RestrictionPredicateExpr
type HeadName = StringType
type TransactionHeads = M.Map HeadName Transaction
data TransactionGraph = TransactionGraph TransactionHeads (S.Set Transaction)
transactionHeadsForGraph :: TransactionGraph -> TransactionHeads
transactionHeadsForGraph (TransactionGraph hs _) = hs
transactionsForGraph :: TransactionGraph -> S.Set Transaction
transactionsForGraph (TransactionGraph _ ts) = ts
data TransactionInfo = TransactionInfo {
parents :: TransactionParents,
stamp :: UTCTime,
merkleHash :: MerkleHash
} deriving (Show, Generic)
type TransactionParents = NE.NonEmpty TransactionId
instance Binary TransactionInfo
type TransactionId = UUID
data Transaction = Transaction TransactionId TransactionInfo Schemas
data DisconnectedTransaction = DisconnectedTransaction TransactionId Schemas DirtyFlag
type DirtyFlag = Bool
type TransactionDiffExpr = DatabaseContextExpr
transactionId :: Transaction -> TransactionId
transactionId (Transaction tid _ _) = tid
transactionInfo :: Transaction -> TransactionInfo
transactionInfo (Transaction _ info _) = info
instance Eq Transaction where
(Transaction uuidA _ _) == (Transaction uuidB _ _) = uuidA == uuidB
instance Ord Transaction where
compare (Transaction uuidA _ _) (Transaction uuidB _ _) = compare uuidA uuidB
type AtomExpr = AtomExprBase ()
type GraphRefAtomExpr = AtomExprBase GraphRefTransactionMarker
data AtomExprBase a = AttributeAtomExpr AttributeName |
NakedAtomExpr Atom |
FunctionAtomExpr AtomFunctionName [AtomExprBase a] a |
RelationAtomExpr (RelationalExprBase a) |
ConstructedAtomExpr DataConstructorName [AtomExprBase a] a
deriving (Eq,Show,Generic, NFData, Foldable, Functor, Traversable)
instance Binary AtomExpr
data ExtendTupleExprBase a = AttributeExtendTupleExpr AttributeName (AtomExprBase a)
deriving (Show, Eq, Generic, NFData, Foldable, Functor, Traversable)
type ExtendTupleExpr = ExtendTupleExprBase ()
type GraphRefExtendTupleExpr = ExtendTupleExprBase GraphRefTransactionMarker
instance Binary ExtendTupleExpr
type AtomFunctions = HS.HashSet AtomFunction
type AtomFunctionName = StringType
type AtomFunctionBodyScript = StringType
type AtomFunctionBodyType = [Atom] -> Either AtomFunctionError Atom
data AtomFunctionBody = AtomFunctionBody (Maybe AtomFunctionBodyScript) AtomFunctionBodyType
instance NFData AtomFunctionBody where
rnf (AtomFunctionBody mScript _) = rnf mScript
instance Show AtomFunctionBody where
show (AtomFunctionBody mScript _) = case mScript of
Just script -> show (unpack script)
Nothing -> "<compiled>"
data AtomFunction = AtomFunction {
atomFuncName :: AtomFunctionName,
atomFuncType :: [AtomType],
atomFuncBody :: AtomFunctionBody
} deriving (Generic, NFData)
instance Hashable AtomFunction where
hashWithSalt salt func = salt `hashWithSalt` atomFuncName func
instance Eq AtomFunction where
f1 == f2 = atomFuncName f1 == atomFuncName f2
instance Show AtomFunction where
show aFunc = unpack (atomFuncName aFunc) ++ "::" ++ showArgTypes ++ "; " ++ body
where
body = show (atomFuncBody aFunc)
showArgTypes = L.intercalate "->" (map show (atomFuncType aFunc))
data AttributeNamesBase a = AttributeNames (S.Set AttributeName) |
InvertedAttributeNames (S.Set AttributeName) |
UnionAttributeNames (AttributeNamesBase a) (AttributeNamesBase a) |
IntersectAttributeNames (AttributeNamesBase a) (AttributeNamesBase a) |
RelationalExprAttributeNames (RelationalExprBase a)
deriving (Eq, Show, Generic, NFData, Foldable, Functor, Traversable)
type AttributeNames = AttributeNamesBase ()
type GraphRefAttributeNames = AttributeNamesBase GraphRefTransactionMarker
instance Binary AttributeNames
data PersistenceStrategy = NoPersistence |
MinimalPersistence FilePath |
CrashSafePersistence FilePath
deriving (Show, Read)
type AttributeExpr = AttributeExprBase ()
type GraphRefAttributeExpr = AttributeExprBase GraphRefTransactionMarker
data AttributeExprBase a = AttributeAndTypeNameExpr AttributeName TypeConstructor a |
NakedAttributeExpr Attribute
deriving (Eq, Show, Generic, Binary, NFData, Foldable, Functor, Traversable)
newtype TupleExprBase a = TupleExpr (M.Map AttributeName (AtomExprBase a))
deriving (Eq, Show, Generic, NFData, Foldable, Functor, Traversable)
instance Binary TupleExpr
type TupleExpr = TupleExprBase ()
type GraphRefTupleExpr = TupleExprBase GraphRefTransactionMarker
data TupleExprsBase a = TupleExprs a [TupleExprBase a]
deriving (Eq, Show, Generic, NFData, Foldable, Functor, Traversable)
type GraphRefTupleExprs = TupleExprsBase GraphRefTransactionMarker
type TupleExprs = TupleExprsBase ()
instance Binary TupleExprs
data MergeStrategy =
UnionMergeStrategy |
UnionPreferMergeStrategy HeadName |
SelectedBranchMergeStrategy HeadName
deriving (Eq, Show, Binary, Generic, NFData)
type DatabaseContextFunctionName = StringType
type DatabaseContextFunctionBodyScript = StringType
type DatabaseContextFunctionBodyType = [Atom] -> DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext
data DatabaseContextFunctionBody = DatabaseContextFunctionBody (Maybe DatabaseContextFunctionBodyScript) DatabaseContextFunctionBodyType
instance NFData DatabaseContextFunctionBody where
rnf (DatabaseContextFunctionBody mScript _) = rnf mScript
data DatabaseContextFunction = DatabaseContextFunction {
dbcFuncName :: DatabaseContextFunctionName,
dbcFuncType :: [AtomType],
dbcFuncBody :: DatabaseContextFunctionBody
} deriving (Generic, NFData)
type DatabaseContextFunctions = HS.HashSet DatabaseContextFunction
instance Hashable DatabaseContextFunction where
hashWithSalt salt func = salt `hashWithSalt` dbcFuncName func
instance Eq DatabaseContextFunction where
f1 == f2 = dbcFuncName f1 == dbcFuncName f2
attrTypeVars :: Attribute -> S.Set TypeVarName
attrTypeVars (Attribute _ aType) = case aType of
IntAtomType -> S.empty
IntegerAtomType -> S.empty
DoubleAtomType -> S.empty
TextAtomType -> S.empty
DayAtomType -> S.empty
DateTimeAtomType -> S.empty
ByteStringAtomType -> S.empty
BoolAtomType -> S.empty
(RelationAtomType attrs) -> S.unions (map attrTypeVars (V.toList attrs))
(ConstructedAtomType _ tvMap) -> M.keysSet tvMap
(TypeVariableType nam) -> S.singleton nam
typeVars :: TypeConstructor -> S.Set TypeVarName
typeVars (PrimitiveTypeConstructor _ _) = S.empty
typeVars (ADTypeConstructor _ args) = S.unions (map typeVars args)
typeVars (TypeVariable v) = S.singleton v
typeVars (RelationAtomTypeConstructor attrExprs) = S.unions (map attrExprTypeVars attrExprs)
attrExprTypeVars :: AttributeExprBase a -> S.Set TypeVarName
attrExprTypeVars (AttributeAndTypeNameExpr _ tCons _) = typeVars tCons
attrExprTypeVars (NakedAttributeExpr attr) = attrTypeVars attr
atomTypeVars :: AtomType -> S.Set TypeVarName
atomTypeVars IntAtomType = S.empty
atomTypeVars IntegerAtomType = S.empty
atomTypeVars DoubleAtomType = S.empty
atomTypeVars TextAtomType = S.empty
atomTypeVars DayAtomType = S.empty
atomTypeVars DateTimeAtomType = S.empty
atomTypeVars ByteStringAtomType = S.empty
atomTypeVars BoolAtomType = S.empty
atomTypeVars (RelationAtomType attrs) = S.unions (map attrTypeVars (V.toList attrs))
atomTypeVars (ConstructedAtomType _ tvMap) = M.keysSet tvMap
atomTypeVars (TypeVariableType nam) = S.singleton nam
unimplemented :: HasCallStack => a
unimplemented = undefined
instance Binary (TupleExprsBase GraphRefTransactionMarker)
instance Binary (TupleExprBase GraphRefTransactionMarker)
instance Binary GraphRefRelationalExpr
instance Binary (AtomExprBase GraphRefTransactionMarker)
instance Binary (AttributeNamesBase GraphRefTransactionMarker)
instance Binary (RestrictionPredicateExprBase GraphRefTransactionMarker)
instance Binary (ExtendTupleExprBase GraphRefTransactionMarker)
instance Binary GraphRefWithNameExpr