9a9f3bb · project-m36 · git.iko.soy

ProjectM36/Atom.hs+21−59

@@ -1,73 +1,35 @@

11module ProjectM36.Atom where

22import ProjectM36.Base

33import ProjectM36.Error

4−import Data.Typeable

5−import ProjectM36.ConcreteTypeRep

64import qualified Data.Text as T

7−import Data.Time.Calendar (Day)

8−import Data.Time.Clock

9−import Data.ByteString (ByteString)

5+--import Data.Time.Calendar

6+--import Data.Time.Clock

7+--import Data.ByteString (ByteString)

8+import Text.Read

109

1110relationForAtom :: Atom -> Either RelationalError Relation

12−relationForAtom (Atom atom) = case cast atom of

13− Just rel@(Relation _ _) -> Right rel

14− Nothing -> Left $ AttributeIsNotRelationValuedError ""

15−relationForAtom (ConstructedAtom _ _ _) = Left $ AttributeIsNotRelationValuedError ""

11+relationForAtom (RelationAtom rel) = Right rel

12+relationForAtom _ = Left $ AttributeIsNotRelationValuedError ""

1613

17−--another hard-coded typerep dispatch table :/

1814makeAtomFromText :: AttributeName -> AtomType -> T.Text -> Either RelationalError Atom

19−makeAtomFromText _ (AtomType cTypeRep) textIn = if

20− unCTR cTypeRep == typeRep (Proxy :: Proxy Int) then

21− either (Left . ParseError . T.pack) (Right . Atom) (fromText textIn :: Either String Int)

22− else if unCTR cTypeRep == typeRep (Proxy :: Proxy Double) then

23− either (Left . ParseError . T.pack) (Right . Atom) (fromText textIn :: Either String Double)

24− else if unCTR cTypeRep == typeRep (Proxy :: Proxy T.Text) then

25− either (Left . ParseError . T.pack) (Right . Atom) (fromText textIn :: Either String T.Text)

26− else if unCTR cTypeRep == typeRep (Proxy :: Proxy Day) then

27− either (Left . ParseError . T.pack) (Right . Atom) (fromText textIn :: Either String Day)

28− else if unCTR cTypeRep == typeRep (Proxy :: Proxy UTCTime) then

29− either (Left . ParseError . T.pack) (Right . Atom) (fromText textIn :: Either String UTCTime)

30− else if unCTR cTypeRep == typeRep (Proxy :: Proxy ByteString) then

31− either (Left . ParseError . T.pack) (Right . Atom) (fromText textIn :: Either String ByteString)

32− else if unCTR cTypeRep == typeRep (Proxy :: Proxy Bool) then

33− either (Left . ParseError . T.pack) (Right . Atom) (fromText textIn :: Either String Bool)

34− else

35− Left $ ParseError textIn

15+makeAtomFromText _ IntAtomType textIn = maybe ((Left . ParseError) textIn) (Right . IntAtom) (readMaybe (T.unpack textIn))

16+makeAtomFromText _ DoubleAtomType textIn = maybe ((Left . ParseError) textIn) (Right . DoubleAtom) (readMaybe (T.unpack textIn))

17+makeAtomFromText _ TextAtomType textIn = maybe ((Left . ParseError) textIn) (Right . TextAtom) (readMaybe (T.unpack textIn))

18+makeAtomFromText _ DayAtomType textIn = maybe ((Left . ParseError) textIn) (Right . DayAtom) (readMaybe (T.unpack textIn))

19+makeAtomFromText _ DateTimeAtomType textIn = maybe ((Left . ParseError) textIn) (Right . DateTimeAtom) (readMaybe (T.unpack textIn))

20+makeAtomFromText _ ByteStringAtomType textIn = maybe ((Left . ParseError) textIn) (Right . ByteStringAtom) (readMaybe (T.unpack textIn))

21+makeAtomFromText _ BoolAtomType textIn = maybe ((Left . ParseError) textIn) (Right . BoolAtom) (readMaybe (T.unpack textIn))

3622makeAtomFromText attrName _ _ = Left $ AtomTypeNotSupported attrName

3723

38−textAtom :: T.Text -> Atom

39−textAtom t = Atom t

40−

41−--intAtom shortcut

42−intAtom :: Int -> Atom

43−intAtom i = Atom i

44−

45−doubleAtom :: Double -> Atom

46−doubleAtom d = Atom d

47−

48−byteStringAtom :: ByteString -> Atom

49−byteStringAtom b = Atom b

50−

51−boolAtom :: Bool -> Atom

52−boolAtom b = Atom b

53−

54−--not safe to use without upfront type-checking

55−castRelation :: Atom -> Relation

56−castRelation (ConstructedAtom _ _ _) = error "castRelation attempt on ConstructedAtom"

57−castRelation (Atom atom) = case cast atom of

58− Just rel -> rel

59− Nothing -> error "castRelation attempt on non-relation-typed Atom"

60−

61−{-

62−basicAtomTypes :: AtomTypes

63−basicAtomTypes = M.union primitiveAtomTypes moreTypes

64− where

65− moreTypes = M.fromList [("Day", (dateAtomType,

66− AtomConstructor (M.singleton "Day" ["Int"])))

67− ]

68−-}

6924atomToText :: Atom -> T.Text

70−atomToText (Atom atom) = toText atom

25+atomToText (IntAtom i) = (T.pack . show) i

26+atomToText (DoubleAtom i) = (T.pack . show) i

27+atomToText (TextAtom i) = (T.pack . show) i --does this break quoting in CSV export?

28+atomToText (DayAtom i) = (T.pack . show) i

29+atomToText (DateTimeAtom i) = (T.pack . show) i

30+atomToText (ByteStringAtom i) = (T.pack . show) i

31+atomToText (BoolAtom i) = (T.pack . show) i

32+atomToText (RelationAtom i) = (T.pack . show) i

7133atomToText (ConstructedAtom dConsName _ atoms) = dConsName `T.append` T.intercalate " " (map atomToText atoms)

7234

7335

ProjectM36/AtomFunctions/Primitive.hs+31−44

@@ -1,101 +1,88 @@

11module ProjectM36.AtomFunctions.Primitive where

2−import ProjectM36.Atom

32import ProjectM36.Base

43import ProjectM36.Relation (relFold)

54import ProjectM36.Tuple

65import ProjectM36.AtomFunction

7−import ProjectM36.DataTypes.Primitive

86import qualified Data.HashSet as HS

9−import Data.Typeable (cast)

107import qualified Data.Vector as V

118import qualified Data.ByteString.Base64 as B64

129import qualified Data.Text.Encoding as TE

13−import qualified Data.Text as T

1410

1511primitiveAtomFunctions :: AtomFunctions

1612primitiveAtomFunctions = HS.fromList [

1713 --match on any relation type

1814 AtomFunction { atomFuncName = "add",

19− atomFuncType = [intAtomType, intAtomType, intAtomType],

20− atomFuncBody = body (\(i1:i2:_) -> Atom $ ((unsafeCast i1)::Int) + unsafeCast i2)},

15+ atomFuncType = [IntAtomType, IntAtomType, IntAtomType],

16+ atomFuncBody = body (\((IntAtom i1):(IntAtom i2):_) -> IntAtom $ i1 + i2)},

2117 AtomFunction { atomFuncName = "id",

2218 atomFuncType = [AnyAtomType, AnyAtomType],

2319 atomFuncBody = body (\(x:_) -> x)},

2420 AtomFunction { atomFuncName = "sum",

25− atomFuncType = foldAtomFuncType intAtomType intAtomType,

26− atomFuncBody = body (\(relAtom:_) -> relationSum $ unsafeCast relAtom)},

21+ atomFuncType = foldAtomFuncType IntAtomType IntAtomType,

22+ atomFuncBody = body (\(RelationAtom rel:_) -> relationSum rel)},

2723 AtomFunction { atomFuncName = "count",

28− atomFuncType = foldAtomFuncType AnyAtomType intAtomType,

29− atomFuncBody = body (\((relIn):_) -> relationCount (castRelation relIn))},

24+ atomFuncType = foldAtomFuncType AnyAtomType IntAtomType,

25+ atomFuncBody = body (\((RelationAtom relIn):_) -> relationCount relIn)},

3026 AtomFunction { atomFuncName = "max",

31− atomFuncType = foldAtomFuncType intAtomType intAtomType,

32− atomFuncBody = body (\((relIn):_) -> relationMax (castRelation relIn))},

27+ atomFuncType = foldAtomFuncType IntAtomType IntAtomType,

28+ atomFuncBody = body (\((RelationAtom relIn):_) -> relationMax relIn)},

3329 AtomFunction { atomFuncName = "min",

34− atomFuncType = foldAtomFuncType intAtomType intAtomType,

35− atomFuncBody = body (\((relIn):_) -> relationMin (castRelation relIn))},

30+ atomFuncType = foldAtomFuncType IntAtomType IntAtomType,

31+ atomFuncBody = body (\((RelationAtom relIn):_) -> relationMin relIn)},

3632 AtomFunction { atomFuncName = "lt",

37− atomFuncType = [intAtomType, intAtomType, boolAtomType],

33+ atomFuncType = [IntAtomType, IntAtomType, BoolAtomType],

3834 atomFuncBody = body $ intAtomFuncLessThan False},

3935 AtomFunction { atomFuncName = "lte",

40− atomFuncType = [intAtomType, intAtomType, boolAtomType],

36+ atomFuncType = [IntAtomType, IntAtomType, BoolAtomType],

4137 atomFuncBody = body $ intAtomFuncLessThan True},

4238 AtomFunction { atomFuncName = "gte",

43− atomFuncType = [intAtomType, intAtomType, boolAtomType],

39+ atomFuncType = [IntAtomType, IntAtomType, BoolAtomType],

4440 atomFuncBody = body $ boolAtomNot . (:[]) . intAtomFuncLessThan False},

4541 AtomFunction { atomFuncName = "gt",

46− atomFuncType = [intAtomType, intAtomType, boolAtomType],

42+ atomFuncType = [IntAtomType, IntAtomType, BoolAtomType],

4743 atomFuncBody = body $ boolAtomNot . (:[]) . intAtomFuncLessThan True},

4844 AtomFunction { atomFuncName = "not",

49− atomFuncType = [boolAtomType, boolAtomType],

45+ atomFuncType = [BoolAtomType, BoolAtomType],

5046 atomFuncBody = body boolAtomNot},

5147 AtomFunction { atomFuncName = "makeByteString",

52− atomFuncType = [textAtomType, byteStringAtomType],

48+ atomFuncType = [TextAtomType, ByteStringAtomType],

5349 --I need a proper error-handling scheme for AtomFunctions!

54− atomFuncBody = body $ \(textIn:_) -> Atom $ (B64.decodeLenient . TE.encodeUtf8) ((unsafeCast textIn)::T.Text) }

50+ atomFuncBody = body $ \((TextAtom textIn):_) -> ByteStringAtom $ (B64.decodeLenient . TE.encodeUtf8) textIn }

5551 ]

5652 where

5753 body = AtomFunctionBody Nothing

5854

59−unsafeCast :: (Atomable a) => Atom -> a

60−unsafeCast (ConstructedAtom _ _ _) = error "unsafeCast attempt on ConstructedAtom"

61−unsafeCast (Atom atom) = case cast atom of

62− Just x -> x

63− Nothing -> error "unsafeCast failed"

64−

6555intAtomFuncLessThan :: Bool -> [Atom] -> Atom

66−intAtomFuncLessThan equality (iatom1:iatom2:_) = (\i1 i2 -> Atom $ ((unsafeCast i1)::Int) `op` unsafeCast i2) iatom1 iatom2

56+intAtomFuncLessThan equality ((IntAtom i1):(IntAtom i2):_) = BoolAtom $ i1 `op` i2

6757 where

6858 op = if equality then (<=) else (<)

69−intAtomFuncLessThan _ _= Atom False

59+intAtomFuncLessThan _ _= BoolAtom False

7060

7161boolAtomNot :: [Atom] -> Atom

72−boolAtomNot (bool:_) = Atom $ not (unsafeCast bool)

73−boolAtomNot _ = Atom False

62+boolAtomNot ((BoolAtom b):_) = BoolAtom $ not b

63+boolAtomNot _ = BoolAtom False

7464

7565--used by sum atom function

7666relationSum :: Relation -> Atom

77−relationSum relIn = Atom $ relFold (\tupIn acc -> acc + (newVal tupIn)) 0 relIn

67+relationSum relIn = IntAtom $ relFold (\tupIn acc -> acc + (newVal tupIn)) 0 relIn

7868 where

7969 --extract Int from Atom

8070 newVal :: RelationTuple -> Int

81− newVal tupIn = castInt $ (tupleAtoms tupIn) V.! 0

71+ newVal tupIn = castInt ((tupleAtoms tupIn) V.! 0)

8272

8373relationCount :: Relation -> Atom

84−relationCount relIn = Atom $ relFold (\_ acc -> acc + 1) (0::Int) relIn

74+relationCount relIn = IntAtom $ relFold (\_ acc -> acc + 1) (0::Int) relIn

8575

8676relationMax :: Relation -> Atom

87−relationMax relIn = Atom $ relFold (\tupIn acc -> max acc (newVal tupIn)) minBound relIn

77+relationMax relIn = IntAtom $ relFold (\tupIn acc -> max acc (newVal tupIn)) minBound relIn

8878 where

89− newVal tupIn = castInt $ (tupleAtoms tupIn) V.! 0

79+ newVal tupIn = castInt ((tupleAtoms tupIn) V.! 0)

9080

9181relationMin :: Relation -> Atom

92−relationMin relIn = Atom $ relFold (\tupIn acc -> min acc (newVal tupIn)) maxBound relIn

82+relationMin relIn = IntAtom $ relFold (\tupIn acc -> min acc (newVal tupIn)) maxBound relIn

9383 where

94− newVal tupIn = castInt $ (tupleAtoms tupIn) V.! 0

95−

84+ newVal tupIn = castInt ((tupleAtoms tupIn) V.! 0)

85+

9686castInt :: Atom -> Int

97−castInt (ConstructedAtom _ _ _) = error "castInt attempt on ConstructedAtom"

98−castInt (Atom atom) = case cast atom of

99− Just i -> i

100− Nothing -> error "int cast failure" -- the type checker must ensure this can never occur

101−

87+castInt (IntAtom i) = i

88+castInt _ = error "attempted to cast non-IntAtom to Int"

ProjectM36/AtomType.hs+2−3

@@ -1,12 +1,11 @@

11module ProjectM36.AtomType where

22import ProjectM36.Base

3−import ProjectM36.ConcreteTypeRep

4−import Data.Typeable

53import qualified ProjectM36.TypeConstructorDef as TCD

64import qualified ProjectM36.TypeConstructor as TC

75import qualified ProjectM36.DataConstructorDef as DCD

86import ProjectM36.MiscUtils

97import ProjectM36.Error

8+import ProjectM36.DataTypes.Primitive

109import qualified ProjectM36.Attribute as A

1110import qualified Data.Vector as V

1211import qualified Data.Set as S

@@ -254,13 +253,13 @@ typeVarMapsVerify :: TypeVarMap -> TypeVarMap -> Bool

254253typeVarMapsVerify a b = M.keysSet a == M.keysSet b && (length . rights) (map (\((_,v1),(_,v2)) -> atomTypeVerify v1 v2) (zip (M.toAscList a) (M.toAscList b))) == M.size a

255254

256255prettyAtomType :: AtomType -> T.Text

257−prettyAtomType (AtomType primitiveType) = T.pack (tyConName (fst (splitTyConApp (unCTR primitiveType))))

258256prettyAtomType (RelationAtomType attrs) = "relation {" `T.append` T.intercalate "," (map prettyAttribute (V.toList attrs)) `T.append` "}"

259257prettyAtomType (ConstructedAtomType tConsName typeVarMap) = tConsName `T.append` T.concat (map showTypeVars (M.toList typeVarMap))

260258 where

261259 showTypeVars (tyVarName, aType) = " (" `T.append` tyVarName `T.append` "::" `T.append` prettyAtomType aType `T.append` ")"

262260-- it would be nice to have the original ordering, but we don't have access to the type constructor here- maybe the typevarmap should be also positional (ordered map?)

263261prettyAtomType AnyAtomType = "?AnyAtomType?"

262+prettyAtomType aType = (T.pack . show) aType

264263

265264prettyAttribute :: Attribute -> T.Text

266265prettyAttribute attr = A.attributeName attr `T.append` "::" `T.append` prettyAtomType (A.atomType attr)

ProjectM36/Base.hs+33−36

@@ -1,4 +1,4 @@

1−{-# LANGUAGE ExistentialQuantification,BangPatterns,DeriveGeneric,DeriveAnyClass #-}

1+{-# LANGUAGE ExistentialQuantification,BangPatterns,DeriveGeneric,DeriveAnyClass, TypeSynonymInstances, FlexibleInstances #-}

22{-# OPTIONS_GHC -fno-warn-orphans #-}

33module ProjectM36.Base where

44import qualified Data.Map as M

@@ -12,7 +12,7 @@ import Control.DeepSeq.Generics (genericRnf)

1212import GHC.Generics (Generic)

1313import qualified Data.Vector as V

1414import qualified Data.List as L

15−import Data.Text (Text,pack,unpack)

15+import Data.Text (Text,unpack)

1616import Data.Binary

1717import Data.Vector.Binary()

1818import Data.Time.Clock

@@ -20,41 +20,10 @@ import Data.Time.Clock.POSIX

2020import Data.Time.Calendar (Day,toGregorian,fromGregorian)

2121import Data.Hashable.Time ()

2222import Data.Typeable

23−import Text.Read (readMaybe)

2423import Data.ByteString (ByteString)

25−import ProjectM36.ConcreteTypeRep

26−import qualified Data.Text.Encoding as TE

27−import qualified Data.ByteString.Base64 as BS64

2824import Data.Maybe (isJust)

2925

3026type StringType = Text

31−

32−-- | Any data type represents as an 'Atom' in the database must adhere to the 'Atomable' typeclass.

33−class (Read a,

34− Hashable a,

35− Binary a,

36− Eq a,

37− Show a,

38− Typeable a,

39− NFData a) => Atomable a where

40− fromText :: (Atomable a) => Text -> Either String a

41− fromText t = case readMaybe (unpack t) of

42− Just v -> Right v

43− Nothing -> Left ("Parse error: " ++ (unpack t))

44−

45− toText :: a -> Text

46− toText a = pack $ show a

47−

48−instance Atomable Int

49−instance Atomable Double

50−instance Atomable Text where

51−instance Atomable Day

52−instance Atomable UTCTime

53−instance Atomable ByteString where

54− toText bs = TE.decodeUtf8With (\_ _ -> Just '?') (BS64.encode bs)

55−instance Atomable Bool

56−instance Atomable Relation

57−instance (Atomable a) => Atomable (Maybe a)

5827

5928-- | Database atoms are the smallest, undecomposable units of a tuple. Common examples are integers, text, or unique identity keys.

6029data Atom = IntAtom Int |

@@ -66,7 +35,19 @@ data Atom = IntAtom Int |

6635 BoolAtom Bool |

6736 RelationAtom Relation |

6837 ConstructedAtom DataConstructorName AtomType [Atom]

69− deriving (Eq, Show, Hashable, Binary, Typeable, NFData)

38+ deriving (Eq, Show, Binary, Typeable, NFData, Generic)

39+

40+instance Hashable Atom where

41+ hashWithSalt salt (ConstructedAtom dConsName _ atoms) = salt `hashWithSalt` atoms

42+ `hashWithSalt` dConsName --AtomType is not hashable

43+ hashWithSalt salt (IntAtom i) = salt `hashWithSalt` i

44+ hashWithSalt salt (DoubleAtom d) = salt `hashWithSalt` d

45+ hashWithSalt salt (TextAtom t) = salt `hashWithSalt` t

46+ hashWithSalt salt (DayAtom d) = salt `hashWithSalt` d

47+ hashWithSalt salt (DateTimeAtom dt) = salt `hashWithSalt` dt

48+ hashWithSalt salt (ByteStringAtom bs) = salt `hashWithSalt` bs

49+ hashWithSalt salt (BoolAtom b) = salt `hashWithSalt` b

50+ hashWithSalt salt (RelationAtom r) = salt `hashWithSalt` r

7051

7152instance Binary UTCTime where

7253 put utc = put $ toRational (utcTimeToPOSIXSeconds utc)

@@ -82,7 +63,7 @@ instance Binary Day where

8263

8364-- I suspect the definition of ConstructedAtomType with its name alone is insufficient to disambiguate the cases; for example, one could create a type named X, remove a type named X, and re-add it using different constructors. However, as long as requests are served from only one DatabaseContext at-a-time, the type name is unambiguous. This will become a problem for time-travel, however.

8465-- | The AtomType must uniquely identify the type of a atom.

85−data AtomType = IntAtomType |

66+data AtomType = IntAtomType |

8667 DoubleAtomType |

8768 TextAtomType |

8869 DayAtomType |

@@ -93,15 +74,31 @@ data AtomType = IntAtomType |

9374 ConstructedAtomType TypeConstructorName TypeVarMap |

9475 AnyAtomType

9576 --wildcard used in Atom Functions and tuples for data constructors which don't provide all arguments to the type constructor

96− deriving (Eq,NFData,Generic,Binary, Show, Hashable)

77+ deriving (Eq, NFData, Generic, Binary, Show)

9778

9879type TypeVarMap = M.Map TypeVarName AtomType

80+

81+instance Hashable TypeVarMap where

82+ hashWithSalt salt tvmap = hashWithSalt salt (M.keys tvmap)

9983

10084-- | Return True iff the atom type argument is relation-valued. If True, this indicates that the Atom contains a relation.

10185isRelationAtomType :: AtomType -> Bool

10286isRelationAtomType (RelationAtomType _) = True

10387isRelationAtomType _ = False

10488

89+{-

90+atomTypeForAtom :: Atom -> AtomType

91+atomTypeForAtom (IntAtom _) = IntAtomType

92+atomTypeForAtom (DoubleAtom _) = DoubleAtomType

93+atomTypeForAtom (TextAtom _) = TextAtomType

94+atomTypeForAtom (DayAtom _) = DayAtomType

95+atomTypeForAtom (DateTimeAtom _) = DateTimeAtomType

96+atomTypeForAtom (ByteStringAtom _) = ByteStringAtomType

97+atomTypeForAtom (BoolAtom _) = BoolAtomType

98+atomTypeForAtom (RelationAtom (Relation attrs _)) = RelationAtomType attrs

99+atomTypeForAtom (ConstructedAtom _ aType _) = aType

100+-}

101+

105102-- | The AttributeName is the name of an attribute in a relation.

106103type AttributeName = StringType

107104

ProjectM36/Client.hs−1

@@ -39,7 +39,6 @@ module ProjectM36.Client

3939 addClientNode,

4040 RelationCardinality(..),

4141 TransactionGraphOperator(..),

42− Atomable,

4342 NodeId(..),

4443 Atom(..),

4544 Session,

ProjectM36/DataTypes/Day.hs+6−16

@@ -1,30 +1,20 @@

11module ProjectM36.DataTypes.Day where

22import ProjectM36.Base

33import ProjectM36.AtomFunctionBody

4−import ProjectM36.DataTypes.Primitive

5−import ProjectM36.AtomFunctions.Primitive

64import qualified Data.HashSet as HS

75import Data.Time.Calendar

8−import qualified Data.Map as M

9−

10−dayAtom :: Day -> Atom

11−dayAtom d = Atom d

12−

13−dayAtomType :: AtomType

14−dayAtomType = ConstructedAtomType "Day" M.empty

156

167dayAtomFunctions :: AtomFunctions

178dayAtomFunctions = HS.fromList [

189 AtomFunction { atomFuncName = "fromGregorian",

19− atomFuncType = [intAtomType, intAtomType, intAtomType, dayAtomType],

20− atomFuncBody = compiledAtomFunctionBody $ \(year:month:day:_) -> ConstructedAtom "Day" dayAtomType [Atom (fromGregorian (fromIntegral (unsafeCast year::Int)) (unsafeCast month) (unsafeCast day))]

21− },

10+ atomFuncType = [IntAtomType, IntAtomType, IntAtomType, DayAtomType],

11+ atomFuncBody = compiledAtomFunctionBody $ \((IntAtom year):(IntAtom month):(IntAtom day):_) -> DayAtom (fromGregorian (fromIntegral year) month day)

12+ },

2213 AtomFunction { atomFuncName = "dayEarlierThan",

23− atomFuncType = [dayAtomType, dayAtomType, boolAtomType],

24− atomFuncBody = compiledAtomFunctionBody $ \((ConstructedAtom _ _ (dayA:_)):(ConstructedAtom _ _ (dayB:_)):_) -> Atom (unsafeCast dayA < (unsafeCast dayB :: Day))

14+ atomFuncType = [DayAtomType, DayAtomType, BoolAtomType],

15+ atomFuncBody = compiledAtomFunctionBody $ \((ConstructedAtom _ _ (IntAtom dayA:_)):(ConstructedAtom _ _ (IntAtom dayB:_)):_) -> BoolAtom (dayA < dayB)

2516 }

2617 ]

2718

2819dayTypeConstructorMapping :: TypeConstructorMapping

29−dayTypeConstructorMapping = [(ADTypeConstructorDef "Day" [],

30− [DataConstructorDef "Day" [DataConstructorDefTypeConstructorArg (PrimitiveTypeConstructor "Int" intAtomType)]])]

20+dayTypeConstructorMapping = [] -- use fromGregorian

ProjectM36/DataTypes/Either.hs+1−2

@@ -1,6 +1,5 @@

11module ProjectM36.DataTypes.Either where

22import ProjectM36.Base

3−import ProjectM36.DataTypes.Primitive

43import ProjectM36.AtomFunction

54import qualified Data.HashSet as HS

65import qualified Data.Map as M

@@ -15,5 +14,5 @@ eitherTypeConstructorMapping = [(ADTypeConstructorDef "Either" ["a", "b"],

1514

1615eitherAtomFunctions :: AtomFunctions

1716eitherAtomFunctions = HS.fromList [

18− compiledAtomFunction "isLeft" [eitherAtomType AnyAtomType AnyAtomType, boolAtomType] $ \((ConstructedAtom dConsName _ _):_) -> Atom (dConsName == "Left")

17+ compiledAtomFunction "isLeft" [eitherAtomType AnyAtomType AnyAtomType, BoolAtomType] $ \((ConstructedAtom dConsName _ _):_) -> BoolAtom (dConsName == "Left")

1918 ]

ProjectM36/DataTypes/Maybe.hs+2−3

@@ -1,6 +1,5 @@

11module ProjectM36.DataTypes.Maybe where

22import ProjectM36.Base

3−import ProjectM36.DataTypes.Primitive

43import qualified Data.HashSet as HS

54import qualified Data.Map as M

65

@@ -17,7 +16,7 @@ maybeAtomFunctions :: AtomFunctions

1716maybeAtomFunctions = HS.fromList [

1817 AtomFunction {

1918 atomFuncName ="isJust",

20− atomFuncType = [maybeAtomType AnyAtomType, boolAtomType],

21− atomFuncBody = AtomFunctionBody Nothing $ \((ConstructedAtom dConsName _ _):_) -> Atom (dConsName == "Nothing")

19+ atomFuncType = [maybeAtomType AnyAtomType, BoolAtomType],

20+ atomFuncBody = AtomFunctionBody Nothing $ \((ConstructedAtom dConsName _ _):_) -> BoolAtom (dConsName == "Nothing")

2221 }

2322 ]

ProjectM36/DataTypes/Primitive.hs+6−29

@@ -1,38 +1,15 @@

11module ProjectM36.DataTypes.Primitive where

22import ProjectM36.Base

3−import Data.Proxy

4−import Data.Typeable

5−import ProjectM36.ConcreteTypeRep

6−import qualified Data.Text as T

7−import qualified Data.ByteString as BS

8−

9−atomTypeForProxy :: (Atomable a) => Proxy a -> AtomType

10−atomTypeForProxy prox = AtomType $ CTR (typeRep prox)

11−

12−textAtomType :: AtomType

13−textAtomType = atomTypeForProxy (Proxy :: Proxy T.Text)

14−

15−intAtomType :: AtomType

16−intAtomType = atomTypeForProxy (Proxy :: Proxy Int)

17−

18−boolAtomType :: AtomType

19−boolAtomType = atomTypeForProxy (Proxy :: Proxy Bool)

20−

21−doubleAtomType :: AtomType

22−doubleAtomType = atomTypeForProxy (Proxy :: Proxy Double)

23−

24−byteStringAtomType :: AtomType

25−byteStringAtomType = atomTypeForProxy (Proxy :: Proxy BS.ByteString)

263

274primitiveTypeConstructorMapping :: TypeConstructorMapping

285primitiveTypeConstructorMapping = map (\(name, aType) ->

296 (PrimitiveTypeConstructorDef name aType, [])) prims

307 where

31− prims = [("Int", intAtomType),

32− ("Text", textAtomType),

33− ("Double", doubleAtomType),

34− ("Bool", boolAtomType),

35− ("ByteString", byteStringAtomType)

8+ prims = [("Int", IntAtomType),

9+ ("Text", TextAtomType),

10+ ("Double", DoubleAtomType),

11+ ("Bool", BoolAtomType),

12+ ("ByteString", ByteStringAtomType)

3613 ]

3714

3815-- | Return the type of an 'Atom'.

@@ -44,5 +21,5 @@ atomTypeForAtom (DayAtom _) = DayAtomType

4421atomTypeForAtom (DateTimeAtom _) = DateTimeAtomType

4522atomTypeForAtom (ByteStringAtom _) = ByteStringAtomType

4623atomTypeForAtom (BoolAtom _) = BoolAtomType

47−atomTypeForAtom (RelationAtom rel) = RelationAtomType (attributes rel)

24+atomTypeForAtom (RelationAtom (Relation attrs _)) = RelationAtomType attrs

4825atomTypeForAtom (ConstructedAtom _ aType _) = aType

ProjectM36/DateExamples.hs+35−37

@@ -1,12 +1,10 @@

11module ProjectM36.DateExamples where

22import ProjectM36.Base

3−import ProjectM36.Atom

43import qualified ProjectM36.Attribute as A

54import ProjectM36.Key

65import ProjectM36.AtomFunctions.Basic

76import ProjectM36.DataTypes.Basic

87import ProjectM36.DatabaseContext

9−import ProjectM36.DataTypes.Primitive

108import ProjectM36.Relation

119import qualified Data.Map as M

1210import qualified Data.Set as S

@@ -35,38 +33,38 @@ suppliersRel = case mkRelationFromList attrs atomMatrix of

3533 Left _ -> undefined

3634 Right rel -> rel

3735 where

38− attrs = A.attributesFromList [Attribute "s#" textAtomType,

39− Attribute "sname" textAtomType,

40− Attribute "status" intAtomType,

41− Attribute "city" textAtomType]

36+ attrs = A.attributesFromList [Attribute "s#" TextAtomType,

37+ Attribute "sname" TextAtomType,

38+ Attribute "status" IntAtomType,

39+ Attribute "city" TextAtomType]

4240 atomMatrix = [

43− [textAtom "S1", textAtom "Smith", intAtom 20, textAtom "London"],

44− [textAtom "S2", textAtom "Jones", intAtom 10, textAtom "Paris"],

45− [textAtom "S3", textAtom "Blake", intAtom 30, textAtom "Paris"],

46− [textAtom "S4", textAtom "Clark", intAtom 20, textAtom "London"],

47− [textAtom "S5", textAtom "Adams", intAtom 30, textAtom "Athens"]]

41+ [TextAtom "S1", TextAtom "Smith", IntAtom 20, TextAtom "London"],

42+ [TextAtom "S2", TextAtom "Jones", IntAtom 10, TextAtom "Paris"],

43+ [TextAtom "S3", TextAtom "Blake", IntAtom 30, TextAtom "Paris"],

44+ [TextAtom "S4", TextAtom "Clark", IntAtom 20, TextAtom "London"],

45+ [TextAtom "S5", TextAtom "Adams", IntAtom 30, TextAtom "Athens"]]

4846

4947supplierProductsRel :: Relation

5048supplierProductsRel = case mkRelationFromList attrs matrix of

5149 Left _ -> undefined

5250 Right rel -> rel

5351 where

54− attrs = A.attributesFromList [Attribute "s#" textAtomType,

55− Attribute "p#" textAtomType,

56− Attribute "qty" intAtomType]

52+ attrs = A.attributesFromList [Attribute "s#" TextAtomType,

53+ Attribute "p#" TextAtomType,

54+ Attribute "qty" IntAtomType]

5755 matrix = [

58− [textAtom "S1", textAtom "P1", intAtom 300],

59− [textAtom "S1", textAtom "P2", intAtom 200],

60− [textAtom "S1", textAtom "P3", intAtom 400],

61− [textAtom "S1", textAtom "P4", intAtom 200],

62− [textAtom "S1", textAtom "P5", intAtom 100],

63− [textAtom "S1", textAtom "P6", intAtom 100],

64− [textAtom "S2", textAtom "P1", intAtom 300],

65− [textAtom "S2", textAtom "P2", intAtom 400],

66− [textAtom "S3", textAtom "P2", intAtom 200],

67− [textAtom "S4", textAtom "P2", intAtom 200],

68− [textAtom "S4", textAtom "P4", intAtom 300],

69− [textAtom "S4", textAtom "P5", intAtom 400]

56+ [TextAtom "S1", TextAtom "P1", IntAtom 300],

57+ [TextAtom "S1", TextAtom "P2", IntAtom 200],

58+ [TextAtom "S1", TextAtom "P3", IntAtom 400],

59+ [TextAtom "S1", TextAtom "P4", IntAtom 200],

60+ [TextAtom "S1", TextAtom "P5", IntAtom 100],

61+ [TextAtom "S1", TextAtom "P6", IntAtom 100],

62+ [TextAtom "S2", TextAtom "P1", IntAtom 300],

63+ [TextAtom "S2", TextAtom "P2", IntAtom 400],

64+ [TextAtom "S3", TextAtom "P2", IntAtom 200],

65+ [TextAtom "S4", TextAtom "P2", IntAtom 200],

66+ [TextAtom "S4", TextAtom "P4", IntAtom 300],

67+ [TextAtom "S4", TextAtom "P5", IntAtom 400]

7068 ]

7169

7270productsRel :: Relation

@@ -74,16 +72,16 @@ productsRel = case mkRelationFromList attrs matrix of

7472 Left _ -> undefined

7573 Right rel -> rel

7674 where

77− attrs = A.attributesFromList [Attribute "p#" textAtomType,

78− Attribute "pname" textAtomType,

79− Attribute "color" textAtomType,

80− Attribute "weight" intAtomType,

81− Attribute "city" textAtomType]

75+ attrs = A.attributesFromList [Attribute "p#" TextAtomType,

76+ Attribute "pname" TextAtomType,

77+ Attribute "color" TextAtomType,

78+ Attribute "weight" IntAtomType,

79+ Attribute "city" TextAtomType]

8280 matrix = [

83− [textAtom "P1", textAtom "Nut", textAtom "Red", intAtom 12, textAtom "London"],

84− [textAtom "P2", textAtom "Bolt", textAtom "Green", intAtom 17, textAtom "Paris"],

85− [textAtom "P3", textAtom "Screw", textAtom "Blue", intAtom 17, textAtom "Oslo"],

86− [textAtom "P4", textAtom "Screw", textAtom "Red", intAtom 14, textAtom "London"],

87− [textAtom "P5", textAtom "Cam", textAtom "Blue", intAtom 12, textAtom "Paris"],

88− [textAtom "P6", textAtom "Cog", textAtom "Red", intAtom 19, textAtom "London"]

81+ [TextAtom "P1", TextAtom "Nut", TextAtom "Red", IntAtom 12, TextAtom "London"],

82+ [TextAtom "P2", TextAtom "Bolt", TextAtom "Green", IntAtom 17, TextAtom "Paris"],

83+ [TextAtom "P3", TextAtom "Screw", TextAtom "Blue", IntAtom 17, TextAtom "Oslo"],

84+ [TextAtom "P4", TextAtom "Screw", TextAtom "Red", IntAtom 14, TextAtom "London"],

85+ [TextAtom "P5", TextAtom "Cam", TextAtom "Blue", IntAtom 12, TextAtom "Paris"],

86+ [TextAtom "P6", TextAtom "Cog", TextAtom "Red", IntAtom 19, TextAtom "London"]

8987 ]

ProjectM36/Relation.hs+11−13

@@ -5,11 +5,9 @@ import qualified Data.HashSet as HS

55import Control.Monad

66import qualified Data.Vector as V

77import qualified Data.Map as M

8−import ProjectM36.Atom

98import ProjectM36.AtomType

109import ProjectM36.Base

1110import ProjectM36.Tuple

12−import ProjectM36.DataTypes.Primitive

1311import qualified ProjectM36.Attribute as A

1412import qualified ProjectM36.AttributeNames as AS

1513import ProjectM36.TupleSet

@@ -150,7 +148,7 @@ group groupAttrNames newAttrName rel = do

150148 groupProjectionAttributes <- AS.projectionAttributesForAttributeNames (attributes rel) groupAttrNames

151149 let groupAttr = Attribute newAttrName (RelationAtomType groupProjectionAttributes)

152150 matchingRelTuple tupIn = case imageRelationFor tupIn rel of

153− Right rel2 -> RelationTuple (V.singleton groupAttr) (V.singleton (Atom rel2))

151+ Right rel2 -> RelationTuple (V.singleton groupAttr) (V.singleton (RelationAtom rel2))

154152 Left _ -> undefined

155153 mogrifier tupIn = tupleExtend tupIn (matchingRelTuple tupIn)

156154 newAttrs = A.addAttribute groupAttr nonGroupProjectionAttributes

@@ -282,30 +280,30 @@ imageRelationJoin rel1@(Relation attrNameSet1 tupSet1) rel2@(Relation attrNameSe

282280typesAsRelation :: TypeConstructorMapping -> Either RelationalError Relation

283281typesAsRelation types = mkRelationFromTuples attrs tuples

284282 where

285− attrs = A.attributesFromList [Attribute "TypeConstructor" textAtomType,

283+ attrs = A.attributesFromList [Attribute "TypeConstructor" TextAtomType,

286284 Attribute "DataConstructors" dConsType]

287− subAttrs = A.attributesFromList [Attribute "DataConstructor" textAtomType]

285+ subAttrs = A.attributesFromList [Attribute "DataConstructor" TextAtomType]

288286 dConsType = RelationAtomType subAttrs

289287 tuples = map mkTypeConsDescription types

290288

291− mkTypeConsDescription (tCons, dConsList) = RelationTuple attrs (V.fromList [textAtom (TCD.name tCons), mkDataConsRelation dConsList])

289+ mkTypeConsDescription (tCons, dConsList) = RelationTuple attrs (V.fromList [TextAtom (TCD.name tCons), mkDataConsRelation dConsList])

292290

293− mkDataConsRelation dConsList = case mkRelationFromTuples subAttrs $ map (\dCons -> RelationTuple subAttrs (V.singleton $ textAtom $ T.intercalate " " ((DCD.name dCons):(map (T.pack . show) (DCD.fields dCons))))) dConsList of

291+ mkDataConsRelation dConsList = case mkRelationFromTuples subAttrs $ map (\dCons -> RelationTuple subAttrs (V.singleton $ TextAtom $ T.intercalate " " ((DCD.name dCons):(map (T.pack . show) (DCD.fields dCons))))) dConsList of

294292 Left err -> error ("mkRelationFromTuples pooped " ++ show err)

295− Right rel -> Atom rel

293+ Right rel -> RelationAtom rel

296294

297295-- | Return a Relation describing the relation variables.

298296relationVariablesAsRelation :: M.Map RelVarName Relation -> Either RelationalError Relation

299297relationVariablesAsRelation relVarMap = mkRelationFromList attrs tups

300298 where

301− subrelAttrs = A.attributesFromList [Attribute "attribute" textAtomType, Attribute "type" textAtomType]

302− attrs = A.attributesFromList [Attribute "name" textAtomType,

299+ subrelAttrs = A.attributesFromList [Attribute "attribute" TextAtomType, Attribute "type" TextAtomType]

300+ attrs = A.attributesFromList [Attribute "name" TextAtomType,

303301 Attribute "attributes" (RelationAtomType subrelAttrs)]

304302 tups = map relVarToAtomList (M.toList relVarMap)

305− relVarToAtomList (rvName, rel) = [textAtom rvName, attributesToRel (attributes rel)]

303+ relVarToAtomList (rvName, rel) = [TextAtom rvName, attributesToRel (attributes rel)]

306304 attributesToRel attrl = case mkRelationFromList subrelAttrs (map attrAtoms (V.toList attrl)) of

307305 Left err -> error ("relationVariablesAsRelation pooped " ++ show err)

308− Right rel -> Atom rel

309− attrAtoms a = [textAtom (A.attributeName a), textAtom (prettyAtomType (A.atomType a))]

306+ Right rel -> RelationAtom rel

307+ attrAtoms a = [TextAtom (A.attributeName a), TextAtom (prettyAtomType (A.atomType a))]

310308

311309

ProjectM36/Relation/Parse/CSV.hs+1−2

@@ -6,7 +6,6 @@ import Data.Char (ord)

66import qualified Data.ByteString.Lazy as BS

77import ProjectM36.Base

88import ProjectM36.Relation

9−import ProjectM36.DataTypes.Primitive

109import ProjectM36.Error

1110import Data.Text.Encoding (decodeUtf8)

1211import qualified ProjectM36.Attribute as A

@@ -27,7 +26,7 @@ csvDecodeOptions = DecodeOptions {decDelimiter = fromIntegral (ord ',')}

2726

2827--special case from Text- outer quotes are *not* required in CSV, so we have to add them to make it parseable

2928makeAtomFromCSVText :: AttributeName -> AtomType -> T.Text -> Either RelationalError Atom

30−makeAtomFromCSVText attrName aType textIn = makeAtomFromText attrName aType $ if aType == textAtomType then

29+makeAtomFromCSVText attrName aType textIn = makeAtomFromText attrName aType $ if aType == TextAtomType then

3130 ("\"" `T.append` textIn `T.append` "\"")

3231 else

3332 textIn

ProjectM36/Relation/Show/CSV.hs+5−5

@@ -1,7 +1,6 @@

11{-# OPTIONS_GHC -fno-warn-orphans #-}

22module ProjectM36.Relation.Show.CSV where

33import ProjectM36.Base

4−import Data.Typeable (cast)

54import ProjectM36.Attribute

65import Data.Csv

76import ProjectM36.Tuple

@@ -10,6 +9,7 @@ import qualified Data.Vector as V

109import ProjectM36.Error

1110import qualified Data.Text.Encoding as TE

1211import qualified Data.Text as T

12+import ProjectM36.Atom

1313

1414--spit out error for relations without attributes (since relTrue and relFalse cannot be distinguished then as CSV) and for relations with relation-valued attributes

1515relationAsCSV :: Relation -> Either RelationalError BS.ByteString

@@ -39,8 +39,8 @@ instance DefaultOrdered RecordRelationTuple where

3939newtype RecordAtom = RecordAtom {unAtom :: Atom}

4040

4141instance ToField RecordAtom where

42− toField (RecordAtom (ConstructedAtom dConsName _ atomList)) = TE.encodeUtf8 $ dConsName `T.append` T.intercalate " " (map (\(Atom x) -> toText x) atomList)

43− toField (RecordAtom (Atom atomVal)) = case cast atomVal of

44− Just texto -> TE.encodeUtf8 texto --squelch extraneous quotes for text type- the CSV library will add them if necessary

45− Nothing -> (TE.encodeUtf8 . toText) atomVal

42+ toField (RecordAtom (ConstructedAtom dConsName _ atomList)) = TE.encodeUtf8 $ dConsName `T.append` T.intercalate " " (map atomToText atomList)

43+ toField (RecordAtom (TextAtom atomVal)) = TE.encodeUtf8 atomVal --squelch extraneous quotes for text type- the CSV library will add them if necessary

44+ toField (RecordAtom atomVal) = (TE.encodeUtf8 . atomToText) atomVal

45+

4646

ProjectM36/Relation/Show/Gnuplot.hs+1−2

@@ -2,7 +2,6 @@ module ProjectM36.Relation.Show.Gnuplot where

22import ProjectM36.Base

33import ProjectM36.Relation

44import ProjectM36.Tuple

5−import ProjectM36.DataTypes.Primitive

65import ProjectM36.AtomFunctions.Primitive

76import qualified ProjectM36.Attribute as A

87import qualified Data.Vector as V

@@ -70,7 +69,7 @@ sample3DRelation = case mkRelationFromList (A.attributesFromList [Attribute "x"

7069-}

7170

7271plotRelation :: Relation -> IO (Maybe PlotError)

73−plotRelation rel = let attrTypes = V.replicate (arity rel) intAtomType in

72+plotRelation rel = let attrTypes = V.replicate (arity rel) IntAtomType in

7473 if attrTypes /= A.atomTypes (attributes rel) then

7574 return $ Just InvalidAttributeTypeError

7675 else do

ProjectM36/Relation/Show/Term.hs+3−4

@@ -1,6 +1,7 @@

11--writes Relation to a String suitable for terminal output

22module ProjectM36.Relation.Show.Term where

33import ProjectM36.Base

4+import ProjectM36.Atom

45import ProjectM36.AtomType

56import ProjectM36.Tuple

67import ProjectM36.Relation

@@ -8,7 +9,6 @@ import ProjectM36.Attribute

89import qualified Data.List as L

910import qualified Data.Text as T

1011import qualified Data.Vector as V

11−import Data.Typeable

1212

1313boxV :: StringType

1414boxV = "│"

@@ -100,10 +100,9 @@ showParens predicate f = if predicate then

100100 f

101101

102102showAtom :: Int -> Atom -> StringType

103−showAtom _ (Atom atom) = case cast atom of

104− Just rel -> renderTable $ relationAsTable rel

105− Nothing -> toText atom

103+showAtom _ (RelationAtom rel) = renderTable $ relationAsTable rel

106104showAtom level (ConstructedAtom dConsName _ atoms) = showParens (level >= 1 && length atoms >= 1) $ T.concat (L.intersperse " " (dConsName : (map (showAtom 1) atoms)))

105+showAtom _ atom = atomToText atom

107106

108107renderTable :: Table -> StringType

109108renderTable table = renderHeader table (fst cellLocs) `T.append` renderBody (snd table) cellLocs

ProjectM36/RelationalExpression.hs+4−4

@@ -471,12 +471,12 @@ predicateRestrictionFilter context attrs (AttributeEqualityPredicate attrName at

471471-- in the future, it would be useful to do typechecking on the attribute and atom expr filters in advance

472472predicateRestrictionFilter context attrs (AtomExprPredicate atomExpr) = do

473473 aType <- typeFromAtomExpr attrs context atomExpr

474− if aType /= boolAtomType then

475− Left $ AtomTypeMismatchError aType boolAtomType

474+ if aType /= BoolAtomType then

475+ Left $ AtomTypeMismatchError aType BoolAtomType

476476 else

477477 Right (\tupleIn -> case evalAtomExpr tupleIn context atomExpr of

478478 Left _ -> False

479− Right boolAtomValue -> boolAtomValue == Atom True)

479+ Right boolAtomValue -> boolAtomValue == BoolAtom True)

480480

481481tupleExprCheckNewAttrName :: AttributeName -> Relation -> Either RelationalError Relation

482482tupleExprCheckNewAttrName attrName rel = if isRight $ attributeForName attrName rel then

@@ -508,7 +508,7 @@ evalAtomExpr tupIn context (FunctionAtomExpr funcName arguments) = do

508508 return $ (evalAtomFunction func) evaldArgs

509509evalAtomExpr _ context (RelationAtomExpr relExpr) = do

510510 relAtom <- evalState (evalRelationalExpr relExpr) context

511− return $ Atom relAtom

511+ return $ RelationAtom relAtom

512512evalAtomExpr tupIn context cons@(ConstructedAtomExpr dConsName dConsArgs) = do

513513 aType <- typeFromAtomExpr (tupleAttributes tupIn) context cons

514514 argAtoms <- mapM (evalAtomExpr tupIn context) dConsArgs

ProjectM36/Sessions.hs+3−5

@@ -4,9 +4,7 @@ import qualified STMContainers.Map as STMMap

44import ListT

55import ProjectM36.Attribute

66import ProjectM36.Base

7−import ProjectM36.DataTypes.Primitive

87import ProjectM36.Session

9−import ProjectM36.Atom

108import ProjectM36.Relation

119import ProjectM36.Error

1210import qualified Data.UUID as U

@@ -17,13 +15,13 @@ stmMapToList :: STMMap.Map k v -> STM [(k, v)]

1715stmMapToList = ListT.fold (\l -> return . (:l)) [] . STMMap.stream

1816

1917uuidAtom :: U.UUID -> Atom

20−uuidAtom = textAtom . U.toText

18+uuidAtom = TextAtom . U.toText

2119

2220sessionsAsRelation :: Sessions -> STM (Either RelationalError Relation)

2321sessionsAsRelation sessions = do

2422 sessionAssocs <- stmMapToList sessions

2523 let atomMatrix = map (\(sessionId, (Session (DisconnectedTransaction parentUUID _))) -> [uuidAtom sessionId, uuidAtom parentUUID]) sessionAssocs

26− pure $ mkRelationFromList (attributesFromList [Attribute "sessionid" textAtomType,

27− Attribute "parentCommit" textAtomType]) atomMatrix

24+ pure $ mkRelationFromList (attributesFromList [Attribute "sessionid" TextAtomType,

25+ Attribute "parentCommit" TextAtomType]) atomMatrix

2826

2927

ProjectM36/TransactionGraph.hs+10−11

@@ -6,7 +6,6 @@ import ProjectM36.Transaction

66import ProjectM36.Relation

77import ProjectM36.TupleSet

88import ProjectM36.Tuple

9−import ProjectM36.DataTypes.Primitive

109import qualified Data.Vector as V

1110import qualified ProjectM36.Attribute as A

1211import qualified Data.UUID as U

@@ -237,18 +236,18 @@ graphAsRelation (DisconnectedTransaction parentId _) graph@(TransactionGraph _ t

237236 tupleMatrix <- mapM tupleGenerator (S.toList transSet)

238237 mkRelationFromList attrs tupleMatrix

239238 where

240− attrs = A.attributesFromList [Attribute "id" textAtomType,

239+ attrs = A.attributesFromList [Attribute "id" TextAtomType,

241240 Attribute "parents" (RelationAtomType parentAttributes),

242− Attribute "current" boolAtomType,

243− Attribute "head" textAtomType

241+ Attribute "current" BoolAtomType,

242+ Attribute "head" TextAtomType

244243 ]

245− parentAttributes = A.attributesFromList [Attribute "id" textAtomType]

244+ parentAttributes = A.attributesFromList [Attribute "id" TextAtomType]

246245 tupleGenerator transaction = case transactionParentsRelation transaction graph of

247246 Left err -> Left err

248− Right parentTransRel -> Right [Atom $ T.pack $ show (transactionId transaction),

249− Atom parentTransRel,

250− Atom $ parentId == transactionId transaction,

251− Atom $ case headNameForTransaction transaction graph of

247+ Right parentTransRel -> Right [TextAtom $ T.pack $ show (transactionId transaction),

248+ RelationAtom parentTransRel,

249+ BoolAtom $ parentId == transactionId transaction,

250+ TextAtom $ case headNameForTransaction transaction graph of

252251 Just headName -> headName

253252 Nothing -> ""

254253 ]

@@ -262,8 +261,8 @@ transactionParentsRelation trans graph = do

262261 let tuples = map trans2tuple (S.toList parentTransSet)

263262 mkRelationFromTuples attrs tuples

264263 where

265− attrs = A.attributesFromList [Attribute "id" textAtomType]

266− trans2tuple trans2 = mkRelationTuple attrs $ V.singleton (Atom (T.pack (show $ transactionId trans2)))

264+ attrs = A.attributesFromList [Attribute "id" TextAtomType]

265+ trans2tuple trans2 = mkRelationTuple attrs $ V.singleton (TextAtom (T.pack (show $ transactionId trans2)))

267266

268267{-

269268--display transaction graph as relation

ProjectM36/Tuple.hs+1

@@ -3,6 +3,7 @@ import ProjectM36.Base

33import ProjectM36.Error

44import ProjectM36.Attribute

55import ProjectM36.Atom

6+import ProjectM36.DataTypes.Primitive

67

78import qualified Data.Map as M

89import qualified Data.Set as S

TutorialD/Interpreter/Base.hs+2−13

@@ -5,12 +5,12 @@ import Text.Parsec.String

55import qualified Text.Parsec.Token as Token

66import Text.Parsec.Language

77import ProjectM36.Base

8+import ProjectM36.AtomType

89import qualified Data.Text as T

910import qualified Data.List as L

1011import qualified Data.Vector as V

1112import qualified Data.Text.IO as TIO

1213import System.IO

13−import ProjectM36.DataTypes.Primitive

1414import ProjectM36.Relation.Show.Term

1515import GHC.Generics

1616

@@ -76,21 +76,10 @@ uncapitalizedIdentifier = do

7676 spaces

7777 pure (fletter:rest)

7878

79−atomTypeToTutDType :: AtomType -> Maybe T.Text

80−atomTypeToTutDType atomType = case atomType of

81− aType@(AtomType _) -> lookup aType [(textAtomType, "char"),

82− (intAtomType, "int"),

83− (boolAtomType, "bool"),

84− (doubleAtomType, "double")]

85− (RelationAtomType attrs) -> Just $ "relation" `T.append` showRelationAttributes attrs

86− _ -> Nothing

87−

8879showRelationAttributes :: Attributes -> T.Text

8980showRelationAttributes attrs = "{" `T.append` T.concat (L.intersperse ", " $ map showAttribute attrsL) `T.append` "}"

9081 where

91− showAttribute (Attribute name atomType) = name `T.append` " " `T.append` case atomTypeToTutDType atomType of

92− Just t -> t

93− Nothing -> "unknown"

82+ showAttribute (Attribute name atomType) = name `T.append` " " `T.append` prettyAtomType atomType

9483 attrsL = V.toList attrs

9584

9685data TutorialDOperatorResult = QuitResult |

TutorialD/Interpreter/RelationalExpr.hs+4−18

@@ -226,34 +226,20 @@ relationalAtomExprP :: Parser AtomExpr

226226relationalAtomExprP = RelationAtomExpr <$> relExprP

227227

228228stringAtomP :: Parser Atom

229−stringAtomP = liftA (Atom . T.pack) quotedString

230−

231−--until polymorphic type constructors and algebraic data types are properly supported, such constructs must be unfortunately hard-coded

232−maybeTextAtomP :: Parser Atom

233−maybeTextAtomP = do

234− maybeText <- try $ ((Just . T.pack <$> (reserved "Just" *> quotedString)) <|>

235− (reserved "Nothing" *> return Nothing)) <* reserved "::maybe char"

236− return $ Atom maybeText

237−

238−--refactor to use polymorphic runtime constructors

239−maybeIntAtomP :: Parser Atom

240−maybeIntAtomP = do

241− maybeInt <- try $ ((Just . fromIntegral <$> (reserved "Just" *> integer)) <|>

242− (reserved "Nothing" *> return Nothing)) <* reserved "::maybe int"

243− return $ Atom (maybeInt :: Maybe Int)

229+stringAtomP = liftA (TextAtom . T.pack) quotedString

244230

245231doubleAtomP :: Parser Atom

246−doubleAtomP = Atom <$> (try float)

232+doubleAtomP = DoubleAtom <$> (try float)

247233

248234intAtomP :: Parser Atom

249235intAtomP = do

250236 i <- integer

251− return $ Atom ((fromIntegral i) :: Int)

237+ return $ IntAtom (fromIntegral i)

252238

253239boolAtomP :: Parser Atom

254240boolAtomP = do

255241 val <- char 't' <|> char 'f'

256− return $ Atom (val == 't')

242+ return $ BoolAtom (val == 't')

257243

258244relationAtomExprP :: Parser AtomExpr

259245relationAtomExprP = RelationAtomExpr <$> makeRelationP