git.iko.soy/project-m36
on master help sign in
add (Interval UTCTime) support all the way to TutorialD

-includes sample "member" function -not ideal due to monomorphism restriction- each new type must be hard-coded

commitec1003a2100784e6221aac098bc55a08d546a31a authorAgentM <agentm@themactionfaction.com> dateWed 21 Oct 2015, 11:20 (11 years ago) parent73086c5
10 files changed+139−32
compare with master
unifiedsplit
Database/Persist/ProjectM36.hs+1−2 ProjectM36/Atom.hs+10 ProjectM36/DataTypes/Interval.hs+37 ProjectM36/Relation.hs+11−1 ProjectM36/RelationalExpression.hs+3−13 TutorialD/Interpreter/DataTypes/DateTime.hs+22 TutorialD/Interpreter/DataTypes/Interval.hs+35 TutorialD/Interpreter/RelationalExpr.hs+4−12 project-m36.cabal+5−1 test/TutorialD/Interpreter.hs+11−3
Database/Persist/ProjectM36.hs+1−2
@@ -16,7 +16,7 @@ import Control.Monad.Trans.Class
1616import Control.Monad.Trans.Reader (ask, ReaderT)
1717import Control.Exception (throw, throwIO)
1818import qualified Data.Text as T
19−import ProjectM36.Atom
19+import ProjectM36.Atom
2020import Data.Aeson (FromJSON(..), ToJSON(..), withText, withObject, (.:))
2121import qualified Data.Map as M
2222import Control.Monad (when)
@@ -29,7 +29,6 @@ import Control.Monad.Trans.Either
2929import qualified Database.Persist.Types as DPT
3030import qualified Data.Set as S
3131import qualified Data.Conduit.List as CL
32−import ProjectM36.RelationalExpression (unsafeCast)
3332import Data.Typeable (typeRep, typeOf, Proxy(..))
3433import Data.Time.Calendar (Day)
3534import Data.ByteString (ByteString)
ProjectM36/Atom.hs+10
@@ -68,3 +68,13 @@ stringAtom t = Atom t
6868intAtom :: Int -> Atom
6969intAtom i = Atom i
7070
71+--not safe to use without upfront type-checking
72+castRelation :: Atom -> Relation
73+castRelation (Atom atom) = case cast atom of
74+ Just rel -> rel
75+ Nothing -> error "castRelation failure"
76+
77+unsafeCast :: (Atomable a) => Atom -> a
78+unsafeCast (Atom atom) = case cast atom of
79+ Just x -> x
80+ Nothing -> error "unsafeCast failed"
ProjectM36/DataTypes/Interval.hsnew file+37
@@ -0,0 +1,37 @@
1+{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving, OverloadedStrings #-}
2+{-# OPTIONS_GHC -fno-warn-orphans #-}
3+module ProjectM36.DataTypes.Interval where
4+import Data.Interval
5+import ProjectM36.Base
6+import Data.Binary
7+import ProjectM36.Atom
8+import Data.Typeable
9+import Data.Time.Clock
10+
11+instance (Atomable a, Ord a) => Atomable (Interval a)
12+
13+instance (Binary a) => Binary (Extended a) where
14+ put ext = case ext of
15+ NegInf -> put (1 :: Int)
16+ PosInf -> put (2 :: Int)
17+ Finite x -> put (3 :: Int) >> put x
18+ get = do
19+ flag <- get :: Get Int
20+ case flag of
21+ 1 -> pure NegInf
22+ 2 -> pure PosInf
23+ 3 -> Finite <$> get
24+ _ -> error "poop"
25+
26+instance (Ord a, Binary a) => Binary (Interval a) where
27+ put interv = put (lowerBound interv) >> put (upperBound interv)
28+ get = interval <$> get <*> get
29+
30+intervalFunctions :: [AtomFunction]
31+intervalFunctions = [AtomFunction { atomFuncName = "interval_dt_member",
32+ atomFuncType = [dateTimeAtomType,
33+ atomTypeForProxy (Proxy :: Proxy (Interval UTCTime)),
34+ boolAtomType],
35+ atomFunc = (\(dt:dtinterval:_) -> Atom $ member ((unsafeCast dt)::UTCTime) ((unsafeCast dtinterval)::(Interval UTCTime)))}
36+
37+ ]
ProjectM36/Relation.hs+11−1
@@ -14,6 +14,7 @@ import ProjectM36.TupleSet
1414import ProjectM36.Error
1515import qualified Data.Text as T
1616import qualified Control.Parallel.Strategies as P
17+import Data.Either (isRight)
1718
1819attributes :: Relation -> Attributes
1920attributes (Relation attrs _ ) = attrs
@@ -42,6 +43,15 @@ mkRelation attrs tupleSet = do
4243 case verifyTupleSet attrs tupleSet of
4344 Left err -> Left err
4445 Right verifiedTupleSet -> return $ Relation attrs verifiedTupleSet
46+
47+--less safe version of mkRelation skips verifyTupleSet
48+--useful for infinite or thunked tuple sets
49+--instead of returning a Left RelationalError, if a tuple does not match the relation's attributes, the tuple is simply removed
50+--duplicate tuples are NOT filtered by this creation method
51+mkRelationDeferVerify :: Attributes -> RelationTupleSet -> Either RelationalError Relation
52+mkRelationDeferVerify attrs tupleSet = return $ Relation attrs (RelationTupleSet (filter tupleFilter (asList tupleSet)))
53+ where
54+ tupleFilter tuple = isRight (verifyTuple attrs tuple)
4555
4656mkRelationFromTuples :: Attributes -> [RelationTuple] -> Either RelationalError Relation
4757mkRelationFromTuples attrs tupleSetList = do
@@ -257,7 +267,7 @@ matrixRelation attributeCount tupleCount = do
257267 let attrs = A.attributesFromList $ map (\c-> Attribute (T.pack $ "a" ++ show c) intAtomType) [0 .. attributeCount-1]
258268 tuple tupleX = RelationTuple attrs (V.generate attributeCount (\_ -> Atom tupleX))
259269 tuples = map (\c -> tuple c) [0 .. tupleCount]
260− mkRelationFromTuples attrs tuples
270+ mkRelationDeferVerify attrs (RelationTupleSet tuples)
261271
262272
263273castInt :: Atom -> Int
ProjectM36/RelationalExpression.hs+3−13
@@ -8,6 +8,7 @@ import ProjectM36.Error
88import ProjectM36.Atom
99import ProjectM36.Key
1010import ProjectM36.AtomFunction
11+import ProjectM36.DataTypes.Interval
1112import qualified ProjectM36.Attribute as A
1213import qualified Data.Map as M
1314import qualified Data.HashSet as HS
@@ -15,7 +16,6 @@ import qualified Data.Set as S
1516import Control.Monad.State hiding (join)
1617import Data.Maybe
1718import Data.Either
18−import Data.Typeable (cast)
1919
2020--relvar state is needed in evaluation of relational expression but only as read-only in order to extract current relvar values
2121evalRelationalExpr :: RelationalExpr -> DatabaseState (Either RelationalError Relation)
@@ -482,19 +482,9 @@ verifyAtomExprTypes _ context (RelationAtomExpr relationExpr) expectedType = do
482482 (Left err, _) -> Left err
483483 (Right relType, _) -> atomTypeVerify expectedType (RelationAtomType (attributes relType))
484484
485−--not safe to use without upfront type-checking
486−castRelation :: Atom -> Relation
487−castRelation (Atom atom) = case cast atom of
488− Just rel -> rel
489− Nothing -> error "castRelation failure"
490−
491−unsafeCast :: (Atomable a) => Atom -> a
492−unsafeCast (Atom atom) = case cast atom of
493− Just x -> x
494− Nothing -> error "unsafeCast failed"
495485
496486basicAtomFunctions :: AtomFunctions
497−basicAtomFunctions = HS.fromList [
487+basicAtomFunctions = HS.fromList $ [
498488 --match on any relation type
499489 AtomFunction { atomFuncName = "add",
500490 atomFuncType = [intAtomType, intAtomType, intAtomType],
@@ -529,7 +519,7 @@ basicAtomFunctions = HS.fromList [
529519 AtomFunction { atomFuncName = "not",
530520 atomFuncType = [boolAtomType, boolAtomType],
531521 atomFunc = boolAtomNot}
532− ]
522+ ] ++ intervalFunctions
533523
534524intAtomFuncLessThan :: Bool -> [Atom] -> Atom
535525intAtomFuncLessThan equality (iatom1:iatom2:_) = (\i1 i2 -> Atom $ ((unsafeCast i1)::Int) `op` unsafeCast i2) iatom1 iatom2
TutorialD/Interpreter/DataTypes/DateTime.hsnew file+22
@@ -0,0 +1,22 @@
1+module TutorialD.Interpreter.DataTypes.DateTime where
2+import Text.Parsec
3+import ProjectM36.Base
4+import Text.Parsec.String
5+import TutorialD.Interpreter.Base
6+import Data.Time.Clock
7+import Data.Time.Format
8+
9+dateTimeAtomP :: Parser Atom
10+dateTimeAtomP = do
11+ dateTime' <- try $ do
12+ dateTime <- dateTimeStringP
13+ reserved "::datetime"
14+ return dateTime
15+ return $ Atom dateTime'
16+
17+dateTimeStringP :: Parser UTCTime
18+dateTimeStringP = do
19+ dateTimeString <- quotedString
20+ case parseTimeM False defaultTimeLocale "%Y-%m-%d %H:%M:%S" dateTimeString of
21+ Just utctime -> return $ (utctime :: UTCTime)
22+ Nothing -> fail $ "Failed to parse datetime from " ++ dateTimeString
TutorialD/Interpreter/DataTypes/Interval.hsnew file+35
@@ -0,0 +1,35 @@
1+module TutorialD.Interpreter.DataTypes.Interval where
2+import Text.Parsec
3+import Text.Parsec.String
4+import ProjectM36.Base
5+import ProjectM36.DataTypes.Interval ()
6+import TutorialD.Interpreter.Base
7+import TutorialD.Interpreter.DataTypes.DateTime
8+import Data.Interval
9+import Data.Time.Clock
10+
11+intervalP :: (Ord a) => Parser (Extended a) -> Parser (Interval a)
12+intervalP unitP = do
13+ lBoundClosed <- string "(" *> return False <|>
14+ string "[" *> return True
15+ lBound <- unitP
16+ reservedOp ","
17+ uBound <- unitP
18+
19+ uBoundClosed <- string ")" *> return False <|>
20+ string "]" *> return True
21+
22+ return $ interval (lBound, lBoundClosed) (uBound, uBoundClosed)
23+
24+intervalDateTimeUnitP :: Parser (Extended UTCTime)
25+intervalDateTimeUnitP = Finite <$> dateTimeStringP <|>
26+ (reserved "inf" *> return PosInf) <|>
27+ (reserved "-inf" *> return NegInf)
28+
29+intervalDateTimeAtomP :: Parser Atom
30+intervalDateTimeAtomP = do
31+ reserved "interval_datetime("
32+ intv <- intervalP intervalDateTimeUnitP
33+ reserved ")"
34+ return $ Atom intv
35+
TutorialD/Interpreter/RelationalExpr.hs+4−12
@@ -17,9 +17,10 @@ import Data.Time.Format
1717import Control.Applicative (liftA)
1818import Data.ByteString.Base64 as B64
1919import Data.Text.Encoding as TE
20+import TutorialD.Interpreter.DataTypes.DateTime
21+import TutorialD.Interpreter.DataTypes.Interval
2022
2123import Data.Time.Calendar (Day)
22−import Data.Time.Clock (UTCTime)
2324
2425atomTypeP :: Parser AtomType
2526atomTypeP = (reserved "char" *> return stringAtomType) <|>
@@ -30,7 +31,7 @@ atomTypeP = (reserved "char" *> return stringAtomType) <|>
3031 (reserved "bool" *> return boolAtomType) <|>
3132 (reserved "bytestring" *> return byteStringAtomType) <|>
3233 (RelationAtomType <$> (reserved "relation" *> makeAttributesP))
33−
34+
3435--used in projection
3536attributeListP :: Parser AttributeNames
3637attributeListP = do
@@ -231,6 +232,7 @@ nakedAtomExprP = NakedAtomExpr <$> atomP
231232
232233atomP :: Parser Atom
233234atomP = dateTimeAtomP <|>
235+ intervalDateTimeAtomP <|>
234236 dateAtomP <|>
235237 maybeTextAtomP <|>
236238 maybeIntAtomP <|>
@@ -265,16 +267,6 @@ maybeIntAtomP = do
265267 maybeInt <- try $ ((Just . fromIntegral <$> (reserved "Just" *> integer)) <|>
266268 (reserved "Nothing" *> return Nothing)) <* reserved "::maybe int"
267269 return $ Atom (maybeInt :: Maybe Int)
268−
269−dateTimeAtomP :: Parser Atom
270−dateTimeAtomP = do
271− dateTimeString' <- try $ do
272− dateTimeString <- quotedString
273− reserved "::datetime"
274− return dateTimeString
275− case parseTimeM False defaultTimeLocale "%Y-%m-%d %H:%M:%S" dateTimeString' of
276− Just utctime -> return $ Atom (utctime :: UTCTime)
277− Nothing -> fail "Failed to parse datetime"
278270
279271dateAtomP :: Parser Atom
280272dateAtomP = do
project-m36.cabal+5−1
@@ -39,6 +39,8 @@ Library
3939 ,attoparsec
4040 ,either
4141 ,base64-bytestring
42+ ,data-interval
43+ ,extended-reals
4244--required for persistent db driver
4345 ,persistent
4446 ,persistent-template
@@ -81,7 +83,9 @@ Executable tutd
8183 TutorialD.Interpreter.Base,
8284 TutorialD.Interpreter.DatabaseExpr,
8385 TutorialD.Interpreter.RODatabaseContextOperator,
84− TutorialD.Interpreter.TransactionGraphOperator
86+ TutorialD.Interpreter.TransactionGraphOperator,
87+ TutorialD.Interpreter.DataTypes.Interval,
88+ TutorialD.Interpreter.DataTypes.DateTime
8589 main-is: TutorialD/tutd.hs
8690 GHC-Options: -Wall
8791
test/TutorialD/Interpreter.hs+11−3
@@ -21,6 +21,9 @@ import qualified Data.Vector as V
2121import Data.Text.Encoding as TE
2222import Data.Typeable (Proxy(..))
2323import Data.Text (Text)
24+import Data.Time.Clock (UTCTime(..))
25+import Data.Time.Calendar (fromGregorian)
26+import Data.Interval (interval, Interval, Extended(Finite))
2427
2528main :: IO ()
2629main = do
@@ -63,6 +66,7 @@ main = do
6366 simpleDAttributes = A.attributesFromList [Attribute "a" intAtomType, Attribute "b" intAtomType]
6467 simpleMaybeTextAttributes = A.attributesFromList [Attribute "a" $ atomTypeForProxy (Proxy :: Proxy (Maybe Text))]
6568 simpleMaybeIntAttributes = A.attributesFromList [Attribute "a" $ atomTypeForProxy (Proxy :: Proxy (Maybe Int))]
69+ simpleIntervalDateTimeAttributes = A.attributesFromList [Attribute "a" $ atomTypeForProxy (Proxy :: Proxy (Interval UTCTime))]
6670 simpleProjectionAttributes = A.attributesFromList [Attribute "c" intAtomType]
6771 nestedRelationAttributes = A.attributesFromList [Attribute "a" intAtomType, Attribute "b" (RelationAtomType $ A.attributesFromList [Attribute "a" intAtomType])]
6872 extendTestAttributes = A.attributesFromList [Attribute "a" intAtomType, Attribute "b" $ RelationAtomType (attributes suppliersRel)]
@@ -100,9 +104,13 @@ main = do
100104 --test Maybe Text
101105 ("x:=relation{tuple{a Just \"spam\"::maybe char}}", mkRelationFromList simpleMaybeTextAttributes [[Atom (Just "spam" :: Maybe Text)]]),
102106 --test Maybe Int
103− ("x:=relation{tuple{a Just 3::maybe int}}", mkRelationFromList simpleMaybeIntAttributes [[Atom (Just 3 :: Maybe Int)]])
104− ]
105−
107+ ("x:=relation{tuple{a Just 3::maybe int}}", mkRelationFromList simpleMaybeIntAttributes [[Atom (Just 3 :: Maybe Int)]]),
108+ --test datetime interval
109+ ("x:=relation{tuple{a interval_datetime((\"2015-01-01 00:00:00\",\"2016-01-01 00:00:00\"])}}", mkRelationFromList simpleIntervalDateTimeAttributes [
110+ [Atom $ interval (Finite (UTCTime (fromGregorian 2015 1 1) 0), False)
111+ (Finite (UTCTime (fromGregorian 2016 1 1) 0), True)]
112+ ])
113+ ]
106114
107115assertTutdEqual :: DatabaseContext -> Either RelationalError Relation -> String -> Assertion
108116assertTutdEqual databaseContext expected tutd = assertEqual tutd expected interpreted