@@ -1,9 +1,8 @@
1−{-# LANGUAGE GADTs,DeriveGeneric,GeneralizedNewtypeDeriving #-}
2−{-# OPTIONS_GHC -fno-warn-orphans #-}
1+{-# LANGUAGE ExistentialQuantification,BangPatterns,GADTs,DeriveGeneric,GeneralizedNewtypeDeriving #-}
32module ProjectM36.Base where
43import qualified Data.Map as M
54import qualified Data.HashSet as HS
6−import qualified Data.Hashable as Hash
5+import Data.Hashable (Hashable, hashWithSalt)
76import qualified Data.Set as S
87import Control.Monad.State (State)
98import Data.UUID (UUID)
@@ -12,24 +11,64 @@ import Control.DeepSeq.Generics (genericRnf)
1211import GHC.Generics (Generic)
1312import qualified Data.Vector as V
1413import qualified Data.List as L
15−import qualified Data.Text as T
14+import Data.Text (Text,pack,unpack)
1615import Data.Binary
1716import Data.Vector.Binary()
1817import Data.Time.Clock
1918import Data.Time.Clock.POSIX
2019import Data.Time.Calendar (Day,toGregorian,fromGregorian)
2120import Data.Hashable.Time ()
21+import Data.Typeable
22+import Text.Read (readMaybe)
23+import Data.ByteString (ByteString)
24+import ProjectM36.ConcreteTypeRep
25+
26+type StringType = Text
27+
28+class (Read a,
29+ Hashable a,
30+ Binary a,
31+ Eq a,
32+ Show a,
33+ Typeable a,
34+ NFData a) => Atomable a where
35+ fromText :: Text -> Either String a
36+ fromText t = case readMaybe (unpack t) of
37+ Just v -> Right v
38+ Nothing -> Left "parse error"
39+
40+ toText :: a -> Text
41+ toText a = pack $ show a
42+
43+instance Atomable Int
44+instance Atomable Double
45+instance Atomable Text
46+instance Atomable Day
47+instance Atomable UTCTime
48+instance Atomable ByteString
49+instance Atomable Bool
50+instance Atomable Relation
51+instance (Atomable a) => Atomable (Maybe a)
52+
53+data Atom = forall a. Atomable a => Atom a
2254
23−type StringType = T.Text
55+instance Eq Atom where
56+ (Atom a) == (Atom b) = Just a == cast b
57+
58+instance Show Atom where
59+ show (Atom atom) = "Atom " ++ show atom
60+
61+instance Binary Atom where
62+ put atom = put atom
63+ get = do
64+ r <- get :: (Get Atom)
65+ return r
2466
25−data Atom = StringAtom StringType |
26− IntAtom Int |
27− BoolAtom Bool |
28− RelationAtom Relation |
29− DateTimeAtom UTCTime |
30− DateAtom Day |
31− DoubleAtom Double
32− deriving (Show, Eq, Generic)
67+instance NFData Atom where
68+ rnf !(Atom a) = rnf a
69+
70+instance Hashable Atom where
71+ hashWithSalt salt (Atom a) = hashWithSalt salt a
3372
3473--not so great orphan instance
3574instance Binary UTCTime where
@@ -44,31 +83,14 @@ instance Binary Day where
4483 (y,m,d) <- get :: Get (Integer, Int, Int)
4584 return $ fromGregorian y m d
4685
47−instance NFData Atom where rnf = genericRnf
48−
49−instance Hash.Hashable Atom
50−
51−instance Binary Atom
86+type AtomType = ConcreteTypeRep
5287
53−data AtomType = StringAtomType |
54− IntAtomType |
55− BoolAtomType |
56− RelationAtomType Attributes |
57− DateTimeAtomType |
58− DateAtomType |
59− DoubleAtomType |
60− AnyAtomType --AnyAtomType is used as a wildcard
61− deriving (Eq, Show, Generic)
62−
63−instance NFData AtomType where rnf = genericRnf
64−instance Binary AtomType
65−
66−type AttributeName = T.Text
88+type AttributeName = StringType
6789
6890data Attribute = Attribute AttributeName AtomType deriving (Eq, Show, Generic)
6991
70−instance Hash.Hashable Attribute where
71− hashWithSalt salt (Attribute attrName _) = Hash.hashWithSalt salt attrName
92+instance Hashable Attribute where
93+ hashWithSalt salt (Attribute attrName _) = hashWithSalt salt attrName
7294
7395instance NFData Attribute where rnf = genericRnf
7496
@@ -84,7 +106,10 @@ attributesEqual attrs1 attrs2 = attrsAsSet attrs1 == attrsAsSet attrs2
84106sortedAttributesIndices :: Attributes -> [(Int, Attribute)]
85107sortedAttributesIndices attrs = L.sortBy (\(_, (Attribute name1 _)) (_,(Attribute name2 _)) -> compare name1 name2) $ V.toList (V.indexed attrs)
86108
87−newtype RelationTupleSet = RelationTupleSet { asList :: [RelationTuple] } deriving (Hash.Hashable, Show, Generic, Binary)
109+newtype RelationTupleSet = RelationTupleSet { asList :: [RelationTuple] } deriving (Hashable, Show, Generic, Binary)
110+
111+instance Read Relation where
112+ readsPrec = error "relation read not supported"
88113
89114instance Eq RelationTupleSet where
90115 set1 == set2 = hset set1 == hset set2
@@ -94,9 +119,9 @@ instance Eq RelationTupleSet where
94119instance NFData RelationTupleSet where rnf = genericRnf
95120
96121--the same hash must be generated for equal tuples so that the hashset equality works
97−instance Hash.Hashable RelationTuple where
98− hashWithSalt salt (RelationTuple attrs tupVec) = salt `Hash.hashWithSalt`
99− sortedAttrs `Hash.hashWithSalt`
122+instance Hashable RelationTuple where
123+ hashWithSalt salt (RelationTuple attrs tupVec) = salt `hashWithSalt`
124+ sortedAttrs `hashWithSalt`
100125 (V.toList sortedTupVec)
101126 where
102127 sortedAttrsIndices = sortedAttributesIndices attrs
@@ -125,9 +150,9 @@ instance Eq Relation where
125150
126151instance NFData Relation where rnf = genericRnf
127152
128−instance Hash.Hashable Relation where
129− hashWithSalt salt (Relation attrs tupSet) = salt `Hash.hashWithSalt`
130− sortedAttrs `Hash.hashWithSalt`
153+instance Hashable Relation where
154+ hashWithSalt salt (Relation attrs tupSet) = salt `hashWithSalt`
155+ sortedAttrs `hashWithSalt`
131156 asList tupSet
132157 where
133158 sortedAttrs = map snd (sortedAttributesIndices attrs)
@@ -274,14 +299,14 @@ data AtomFunction = AtomFunction {
274299 atomFunc :: [Atom] -> Atom
275300 }
276301
277−instance Hash.Hashable AtomFunction where
278− hashWithSalt salt func = salt `Hash.hashWithSalt` (atomFuncName func)
302+instance Hashable AtomFunction where
303+ hashWithSalt salt func = salt `hashWithSalt` (atomFuncName func)
279304
280305instance Eq AtomFunction where
281306 f1 == f2 = (atomFuncName f1) == (atomFuncName f2)
282307
283308instance Show AtomFunction where
284− show aFunc = T.unpack (atomFuncName aFunc) ++ "::" ++ showArgTypes
309+ show aFunc = unpack (atomFuncName aFunc) ++ "::" ++ showArgTypes
285310 where
286311 showArgTypes = concat (L.intersperse "->" $ map show (atomFuncType aFunc))
287312