git.iko.soy/project-m36
on bda2cfc help sign in
project-m36/ProjectM36/Base.hs
365 lines 16 kB history raw
1{-# LANGUAGE ExistentialQuantification,BangPatterns,GADTs,DeriveGeneric,DeriveAnyClass #-}
2{-# OPTIONS_GHC -fno-warn-orphans #-}
3module ProjectM36.Base where
4import qualified Data.Map as M
5import qualified Data.HashSet as HS
6import Data.Hashable (Hashable, hashWithSalt)
7import qualified Data.Set as S
8import Control.Monad.State (State)
9import Data.UUID (UUID)
10import Control.DeepSeq (NFData, rnf)
11import Control.DeepSeq.Generics (genericRnf)
12import GHC.Generics (Generic)
13import qualified Data.Vector as V
14import qualified Data.List as L
15import Data.Text (Text,pack,unpack)
16import Data.Binary
17import Data.Vector.Binary()
18import Data.Time.Clock
19import Data.Time.Clock.POSIX
20import Data.Time.Calendar (Day,toGregorian,fromGregorian)
21import Data.Hashable.Time ()
22import Data.Typeable
23import Text.Read (readMaybe)
24import Data.ByteString (ByteString)
25import ProjectM36.ConcreteTypeRep
27type StringType = Text
29class (Read a,
30 Hashable a,
31 Binary a,
32 Eq a,
33 Show a,
34 Typeable a,
35 NFData a) => Atomable a where
36 fromText :: (Atomable a) => Text -> Either String a
37 fromText t = case readMaybe (unpack t) of
38 Just v -> Right v
39 Nothing -> Left "parse error"
41 toText :: a -> Text
42 toText a = pack $ show a
44instance Atomable Int
45instance Atomable Double
46instance Atomable Text where
47 --no need to require quoted strings
48 fromText t = Right t
49 toText t = t
50instance Atomable Day
51instance Atomable UTCTime
52instance Atomable ByteString
53instance Atomable Bool
54instance Atomable Relation
55instance (Atomable a) => Atomable (Maybe a)
57data Atom = forall a. Atomable a => Atom a
59instance Eq Atom where
60 (Atom a) == (Atom b) = Just a == cast b
62instance Show Atom where
63 show (Atom atom) = "Atom " ++ show atom
65instance Binary Atom where
66 put atom@(Atom val) = put (atomTypeForAtom atom) >> put val
67 get = do
68 atomtype <- get
69 --not-so-great for this to be hardcoded here- it would be nicer to have a dispatch table linked to the instances themselves
70 --http://stackoverflow.com/questions/8101067/binary-instance-for-an-existential
71 case atomtype of
72 AnyAtomType -> error "unsupported serialization AnyAtomType"
73 (RelationAtomType _) -> Atom <$> (get :: Get Relation)
74 (AtomType cTypeRep) -> if unCTR cTypeRep == typeRep (Proxy :: Proxy Int) then
75 Atom <$> (get :: Get Int)
76 else if unCTR cTypeRep == typeRep (Proxy :: Proxy Text) then
77 Atom <$> (get :: Get Text)
78 else if unCTR cTypeRep == typeRep (Proxy :: Proxy Double) then
79 Atom <$> (get :: Get Double)
80 else if unCTR cTypeRep == typeRep (Proxy :: Proxy Day) then
81 Atom <$> (get :: Get Day)
82 else if unCTR cTypeRep == typeRep (Proxy :: Proxy UTCTime) then
83 Atom <$> (get :: Get UTCTime)
84 else if unCTR cTypeRep == typeRep (Proxy :: Proxy ByteString) then
85 Atom <$> (get :: Get ByteString)
86 else if unCTR cTypeRep == typeRep (Proxy :: Proxy Bool) then
87 Atom <$> (get :: Get Bool)
88 else
89 error "unsupported typerep serialization"
91instance NFData Atom where
92 rnf !(Atom a) = rnf a
94instance Hashable Atom where
95 hashWithSalt salt (Atom a) = hashWithSalt salt a
97atomTypeForAtom :: Atom -> AtomType
98atomTypeForAtom (Atom atom) = case cast atom of
99 Just (Relation attrs _) -> RelationAtomType attrs
100 Nothing -> AtomType $ CTR (typeOf atom)
102instance Binary UTCTime where
103 put utc = put $ toRational (utcTimeToPOSIXSeconds utc)
104 get = do
105 r <- get :: Get Rational
106 return (posixSecondsToUTCTime (fromRational r))
108instance Binary Day where
109 put day = put $ toGregorian day
110 get = do
111 (y,m,d) <- get :: Get (Integer, Int, Int)
112 return (fromGregorian y m d)
114data AtomType = AtomType ConcreteTypeRep |
115 RelationAtomType Attributes |
116 AnyAtomType --wildcard used in Atom Functions
117 deriving (Eq,NFData,Generic,Binary,Show)
119isRelationAtomType :: AtomType -> Bool
120isRelationAtomType (RelationAtomType _) = True
121isRelationAtomType _ = False
123type AttributeName = StringType
125data Attribute = Attribute AttributeName AtomType deriving (Eq, Show, Generic)
127instance Hashable Attribute where
128 hashWithSalt salt (Attribute attrName _) = hashWithSalt salt attrName
130instance NFData Attribute where rnf = genericRnf
132instance Binary Attribute
134type Attributes = V.Vector Attribute
136attributesEqual :: Attributes -> Attributes -> Bool
137attributesEqual attrs1 attrs2 = attrsAsSet attrs1 == attrsAsSet attrs2
138 where
139 attrsAsSet = HS.fromList . V.toList
141sortedAttributesIndices :: Attributes -> [(Int, Attribute)]
142sortedAttributesIndices attrs = L.sortBy (\(_, (Attribute name1 _)) (_,(Attribute name2 _)) -> compare name1 name2) $ V.toList (V.indexed attrs)
144newtype RelationTupleSet = RelationTupleSet { asList :: [RelationTuple] } deriving (Hashable, Show, Generic, Binary)
146instance Read Relation where
147 readsPrec = error "relation read not supported"
149instance Eq RelationTupleSet where
150 set1 == set2 = hset set1 == hset set2
151 where
152 hset = HS.fromList . asList
154instance NFData RelationTupleSet where rnf = genericRnf
156--the same hash must be generated for equal tuples so that the hashset equality works
157instance Hashable RelationTuple where
158 --sanity check the tuple for attribute and tuple counts
159 --this bit me when tuples were being hashed before being verified
160 hashWithSalt salt (RelationTuple attrs tupVec) = if V.length attrs /= V.length tupVec then
161 error "invalid tuple: attributes and tuple count mismatch"
162 else
163 salt `hashWithSalt`
164 sortedAttrs `hashWithSalt`
165 (V.toList sortedTupVec)
166 where
167 sortedAttrsIndices = sortedAttributesIndices attrs
168 sortedAttrs = map snd sortedAttrsIndices
169 sortedTupVec = V.map (\(index, _) -> tupVec V.! index) $ V.fromList sortedAttrsIndices
171--maybe the attribute->int mapping should be stored once in the relation and then passed down when needed
172data RelationTuple = RelationTuple Attributes (V.Vector Atom) deriving (Show, Generic)
174instance Binary RelationTuple
176instance Eq RelationTuple where
177 (==) tuple1@(RelationTuple attrs1 _) tuple2@(RelationTuple attrs2 _) = attributesEqual attrs1 attrs2 && atomsEqual
178 where
179 atomForAttribute attr (RelationTuple attrs tupVec) = case V.findIndex (== attr) attrs of
180 Nothing -> Nothing
181 Just index -> tupVec V.!? index
182 atomsEqual = V.all (== True) $ V.map (\attr -> atomForAttribute attr tuple1 == atomForAttribute attr tuple2) attrs1
184instance NFData RelationTuple where rnf = genericRnf
186data Relation = Relation Attributes RelationTupleSet deriving (Show, Generic,Typeable)
188instance Eq Relation where
189 Relation attrs1 tupSet1 == Relation attrs2 tupSet2 = attributesEqual attrs1 attrs2 && tupSet1 == tupSet2
191instance NFData Relation where rnf = genericRnf
193instance Hashable Relation where
194 hashWithSalt salt (Relation attrs tupSet) = salt `hashWithSalt`
195 sortedAttrs `hashWithSalt`
196 asList tupSet
197 where
198 sortedAttrs = map snd (sortedAttributesIndices attrs)
200instance Binary Relation
202data RelationCardinality = Uncountable | Countable Int deriving (Eq, Show, Generic, Ord)
203data RelationSizeInfinite = RelationSizeInfinite
205type RelVarName = StringType
207data RelationalExpr where
208 MakeStaticRelation :: Attributes -> RelationTupleSet -> RelationalExpr
209 ExistingRelation :: Relation -> RelationalExpr
210 --MakeFunctionalRelation (creates a relation from a tuple-generating function, potentially infinite)
211 --in Tutorial D, relational variables pick up the type of the first relation assigned to them
212 --relational variables should also be able to be explicitly-typed like in Haskell
213 RelationVariable :: RelVarName -> RelationalExpr
214 Project :: AttributeNames -> RelationalExpr -> RelationalExpr
215 Union :: RelationalExpr -> RelationalExpr -> RelationalExpr
216 Join :: RelationalExpr -> RelationalExpr -> RelationalExpr
217 Rename :: AttributeName -> AttributeName -> RelationalExpr -> RelationalExpr
218 Group :: AttributeNames -> AttributeName -> RelationalExpr -> RelationalExpr
219 Ungroup :: AttributeName -> RelationalExpr -> RelationalExpr
220 Restrict :: RestrictionPredicateExpr -> RelationalExpr -> RelationalExpr
221 Equals :: RelationalExpr -> RelationalExpr -> RelationalExpr
222 NotEquals :: RelationalExpr -> RelationalExpr -> RelationalExpr
223 Extend :: TupleExpr -> RelationalExpr -> RelationalExpr
224 --Summarize :: AtomExpr -> AttributeName -> RelationalExpr -> RelationalExpr -> RelationalExpr -- a special case of Extend
225 deriving (Show,Eq, Generic)
227instance Binary RelationalExpr
229data DatabaseContext = DatabaseContext {
230 inclusionDependencies :: M.Map IncDepName InclusionDependency,
231 relationVariables :: M.Map RelVarName Relation,
232 atomFunctions :: AtomFunctions
233 } deriving (Show, Generic)
235--instance Binary DatabaseContext
237type IncDepName = StringType
239data InclusionDependency = InclusionDependency RelationalExpr RelationalExpr deriving (Show, Eq, Generic)
241instance Binary InclusionDependency
243--Database context expressions modify the database context while relational expressions do not
244data DatabaseExpr where
245 Define :: RelVarName -> Attributes -> DatabaseExpr
246 Undefine :: RelVarName -> DatabaseExpr --forget existence of relvar X
247 Assign :: RelVarName -> RelationalExpr -> DatabaseExpr
248 Insert :: RelVarName -> RelationalExpr -> DatabaseExpr
249 Delete :: RelVarName -> RestrictionPredicateExpr -> DatabaseExpr
250 Update :: RelVarName -> M.Map AttributeName Atom -> RestrictionPredicateExpr -> DatabaseExpr -- needs restriction support
251 AddInclusionDependency :: IncDepName -> InclusionDependency -> DatabaseExpr
252 RemoveInclusionDependency :: IncDepName -> DatabaseExpr
253 MultipleExpr :: [DatabaseExpr] -> DatabaseExpr
254 deriving (Show, Eq, Binary, Generic)
256type DatabaseState a = State DatabaseContext a
258data RestrictionPredicateExpr where
259 TruePredicate :: RestrictionPredicateExpr
260 AndPredicate :: RestrictionPredicateExpr -> RestrictionPredicateExpr -> RestrictionPredicateExpr
261 OrPredicate :: RestrictionPredicateExpr -> RestrictionPredicateExpr -> RestrictionPredicateExpr
262 NotPredicate :: RestrictionPredicateExpr -> RestrictionPredicateExpr
263 RelationalExprPredicate :: RelationalExpr -> RestrictionPredicateExpr --type must be same as true and false relations (no attributes)
264 AtomExprPredicate :: AtomExpr -> RestrictionPredicateExpr --atom must evaluate to boolean
265 AttributeEqualityPredicate :: AttributeName -> AtomExpr -> RestrictionPredicateExpr -- relationalexpr must result in relation with single tuple
266 deriving (Show, Eq, Generic)
268instance Binary RestrictionPredicateExpr
270-- child + parent links
271-- the string represents the branch name and can be used to find the named HEADs
272type HeadName = StringType
274type TransactionHeads = M.Map HeadName Transaction
276data TransactionGraph = TransactionGraph TransactionHeads (S.Set Transaction)
277 deriving (Show, Eq)
279transactionsForGraph :: TransactionGraph -> S.Set Transaction
280transactionsForGraph (TransactionGraph _ t) = t
282transactionHeadsForGraph :: TransactionGraph -> TransactionHeads
283transactionHeadsForGraph (TransactionGraph heads _) = heads
285data TransactionInfo = TransactionInfo UUID (S.Set UUID) | -- 1 parent + n children
286 MergeTransactionInfo UUID UUID (S.Set UUID) -- 2 parents, n children
287 deriving(Show, Generic)
289instance Binary TransactionInfo
291data Transaction = Transaction UUID TransactionInfo DatabaseContext -- self uuid
292 deriving (Show, Generic)
294--instance Binary Transaction
296--represents an "in-progress" transaction which has not yet been added to the transaction graph
297--one the transaction is "complete", it is committed and no longer can be changed
298-- this is similar to the index in git
299data DisconnectedTransaction = DisconnectedTransaction UUID DatabaseContext --parentUUID, context
301transactionUUID :: Transaction -> UUID
302transactionUUID (Transaction uuid _ _) = uuid
304transactionContext :: Transaction -> DatabaseContext
305transactionContext (Transaction _ _ context) = context
307transactionInfo :: Transaction -> TransactionInfo
308transactionInfo (Transaction _ info _) = info
310instance Eq Transaction where
311 (Transaction uuidA _ _) == (Transaction uuidB _ _) = uuidA == uuidB
313instance Ord Transaction where
314 compare (Transaction uuidA _ _) (Transaction uuidB _ _) = compare uuidA uuidB
316--used on the right side of attribute assignments
317data AtomExpr = AttributeAtomExpr AttributeName |
318 NakedAtomExpr Atom |
319 FunctionAtomExpr AtomFunctionName [AtomExpr] |
320 RelationAtomExpr RelationalExpr
321 deriving (Eq,Show,Generic)
323instance Binary AtomExpr
325--used to extend a relation
326data TupleExpr = AttributeTupleExpr AttributeName AtomExpr
327 deriving (Show, Eq, Generic)
329instance Binary TupleExpr
331--enumerates the list of functions available to be run as part of tuple expressions
332type AtomFunctions = HS.HashSet AtomFunction
334type AtomFunctionName = StringType
336data AtomFunction = AtomFunction {
337 atomFuncName :: AtomFunctionName,
338 atomFuncType :: [AtomType],
339 atomFunc :: [Atom] -> Atom
340 }
342instance Hashable AtomFunction where
343 hashWithSalt salt func = salt `hashWithSalt` (atomFuncName func)
345instance Eq AtomFunction where
346 f1 == f2 = (atomFuncName f1) == (atomFuncName f2)
348instance Show AtomFunction where
349 show aFunc = unpack (atomFuncName aFunc) ++ "::" ++ showArgTypes
350 where
351 showArgTypes = concat (L.intersperse "->" $ map show (atomFuncType aFunc))
353data AttributeNames = AttributeNames (S.Set AttributeName) |
354 InvertedAttributeNames (S.Set AttributeName)
355 deriving (Eq, Show, Generic)
357instance Binary AttributeNames
359--used for global dbms configuration- per-transaction flag is elsewhere
360data PersistenceStrategy = NoPersistence | --no filesystem persistence/memory-only database
361 MinimalPersistence FilePath | --fsync off
362 CrashSafePersistence FilePath --full fsync- not yet implemented
363 deriving (Show, Read)