git.iko.soy/project-m36
on master help sign in
WIP compilation checkpoint
c413bf0AgentM
examples/out_of_the_tarpit.hs+91−62
compare with master
unifiedsplit
@@ -2,50 +2,35 @@
2{-# LANGUAGE DeriveAnyClass, DeriveGeneric, OverloadedStrings #-}
2{-# LANGUAGE DeriveAnyClass, DeriveGeneric, OverloadedStrings #-}
3import ProjectM36.Client
3import ProjectM36.Client
4import ProjectM36.DataTypes.Primitive
4import ProjectM36.DataTypes.Primitive
5−import qualified Data.Map as M
5+import ProjectM36.Tupleable
6import Data.Either
6import Data.Either
7import Control.Monad
7import Control.Monad
8import GHC.Generics
8import GHC.Generics
9import Data.Binary
9import Data.Binary
10import Control.DeepSeq
10import Control.DeepSeq
11+import qualified Data.Text as T
12+import Data.Time.Calendar (Day)
13+import qualified Data.Vector as V
11
14
12--create various database value (atom) types
15--create various database value (atom) types
13−addressAtomType :: AtomType
16+type Price = Double
14−addressAtomType = TextAtomType
15
17
16−nameAtomType :: AtomType
18+type Name = T.Text
17−nameAtomType = TextAtomType
18
19
19−priceAtomType :: AtomType
20+type Address = T.Text
20−priceAtomType = DoubleAtomType
21
21
22−fileNameAtomType :: AtomType
23−fileNameAtomType = TextAtomType
24−
25−data Room = Kitchen | Bathroom | LivingRoom
22+data RoomType = Kitchen | Bathroom | LivingRoom
26 deriving (Generic, Atomable, Eq, Show, Binary, NFData)
23 deriving (Generic, Atomable, Eq, Show, Binary, NFData)
27
24
28−roomAtomType :: AtomType
29−roomAtomType = toAtomType (undefined :: Room)
30−
31data PriceBand = Low | Medium | High | Premium
25data PriceBand = Low | Medium | High | Premium
32 deriving (Generic, Atomable, Eq, Show, Binary, NFData)
26 deriving (Generic, Atomable, Eq, Show, Binary, NFData)
33
27
34−priceBandAtomType :: AtomType
35−priceBandAtomType = toAtomType (undefined :: PriceBand)
36−
37data AreaCode = City | Suburban | Rural
28data AreaCode = City | Suburban | Rural
38 deriving (Generic, Atomable, Eq, Show, Binary, NFData)
29 deriving (Generic, Atomable, Eq, Show, Binary, NFData)
39
30
40−areaCodeAtomType :: AtomType
41−areaCodeAtomType = ConstructedAtomType "AreaCode" M.empty
42−
43data SpeedBand = VeryFastBand | FastBand | MediumBand | SlowBand
31data SpeedBand = VeryFastBand | FastBand | MediumBand | SlowBand
44 deriving (Generic, Atomable, Eq, Show, Binary, NFData)
32 deriving (Generic, Atomable, Eq, Show, Binary, NFData)
45
33
46−speedBandAtomType :: AtomType
47−speedBandAtomType = ConstructedAtomType "SpeedBand" M.empty
48−
49main :: IO ()
34main :: IO ()
50main = do
35main = do
51 --connect to the database
36 --connect to the database
@@ -62,38 +47,82 @@ main = do
62
47
63 createSchema sessionId conn
48 createSchema sessionId conn
64
49
50+data Test = Test {
51+ dateo :: Int,
52+ date2o :: Int
53+ }
54+ deriving (Generic, Eq)
55+
56+instance Tupleable Test
57+
58+data Property = Property {
59+ address :: T.Text,
60+ price :: Price,
61+ photo :: T.Text,
62+ dateRegistered :: Day
63+ }
64+ deriving (Generic, Eq)
65+
66+instance Tupleable Property
67+
68+data Offer = Offer {
69+ offerAddress :: Address,
70+ offerPrice :: Price,
71+ offerDate :: Day,
72+ bidderName :: Name,
73+ bidderAddress :: Address,
74+ decisionDate :: Day,
75+ accepted :: Bool
76+ }
77+ deriving (Generic, Eq)
78+
79+instance Tupleable Offer
80+
81+data Decision = Decision {
82+ dec_address :: Address,
83+ dec_offerDate :: Day, --the dec_ prefix is needed until OverloadedRecordFields is available
84+ dec_bidderName :: Name,
85+ dec_bidderAddress :: Address,
86+ dec_decisionDate :: Day,
87+ dec_accepted :: Bool
88+ }
89+ deriving (Generic, Eq)
90+
91+instance Tupleable Decision
92+
93+data Room = Room {
94+ room_address :: Address,
95+ roomName :: Name,
96+ width :: Double,
97+ breadth :: Double,
98+ roomType :: RoomType
99+ }
100+ deriving (Generic, Eq)
101+
102+instance Tupleable Room
103+
104+data Floor = Floor {
105+ floor_address :: Address,
106+ floor_roomName :: Name,
107+ floor :: Int
108+ }
109+ deriving (Generic, Eq)
110+
111+instance Tupleable Floor
112+
113+data Commission = Commission {
114+ priceBand :: PriceBand,
115+ areaCode :: AreaCode,
116+ saleSpeed :: SpeedBand,
117+ commission :: Price
118+ } deriving (Generic, Eq)
119+
120+instance Tupleable Commission
121+
65createSchema :: SessionId -> Connection -> IO ()
122createSchema :: SessionId -> Connection -> IO ()
66createSchema sessionId conn = do
123createSchema sessionId conn = do
67 --create attributes for relvars
124 --create attributes for relvars
68− let propertyAttrs = [Attribute "address" addressAtomType,
125+ let
69− Attribute "price" priceAtomType,
70− Attribute "photo" fileNameAtomType,
71− Attribute "dateRegistered" DayAtomType]
72− offerAttrs = [Attribute "address" addressAtomType,
73− Attribute "offerPrice" priceAtomType,
74− Attribute "offerDate" DayAtomType,
75− Attribute "bidderName" nameAtomType,
76− Attribute "bidderAddress" addressAtomType,
77− Attribute "decisionDate" DayAtomType,
78− Attribute "accepted" BoolAtomType]
79− decisionAttrs = [Attribute "address" addressAtomType,
80− Attribute "offerDate" DayAtomType,
81− Attribute "bidderName" nameAtomType,
82− Attribute "bidderAddress" addressAtomType,
83− Attribute "decisionDate" DayAtomType,
84− Attribute "accepted" BoolAtomType]
85− roomAttrs = [Attribute "address" addressAtomType,
86− Attribute "roomName" TextAtomType,
87− Attribute "width" DoubleAtomType,
88− Attribute "breadth" DoubleAtomType,
89− Attribute "type" roomAtomType]
90− floorAttrs = [Attribute "address" addressAtomType,
91− Attribute "roomName" TextAtomType,
92− Attribute "floor" IntAtomType]
93− commissionAttrs = [Attribute "priceBand" priceBandAtomType,
94− Attribute "areaCode" areaCodeAtomType,
95− Attribute "saleSpeed" speedBandAtomType,
96− Attribute "commission" DoubleAtomType]
97 --create uniqueness constraints
126 --create uniqueness constraints
98 incDepKeys = map (uncurry databaseContextExprForUniqueKey)
127 incDepKeys = map (uncurry databaseContextExprForUniqueKey)
99 [("property", ["address"]),
128 [("property", ["address"]),
@@ -120,15 +149,15 @@ createSchema sessionId conn = do
120 ]
149 ]
121 incDepForeignKeys = map (\(n, a, b) -> databaseContextExprForForeignKey n a b) foreignKeys
150 incDepForeignKeys = map (\(n, a, b) -> databaseContextExprForForeignKey n a b) foreignKeys
122 --define the relvars
151 --define the relvars
123− relvarMap = [("property", propertyAttrs),
152+ relvarMap = [("property", toAttributes (undefined :: Property)),
124− ("offer", offerAttrs),
153+ ("offer", toAttributes (undefined :: Offer)),
125− ("decision", decisionAttrs),
154+ ("decision", toAttributes (undefined :: Decision)),
126− ("room", roomAttrs),
155+ ("room", toAttributes (undefined :: Room)),
127− ("floor", floorAttrs),
156+ ("floor", toAttributes (undefined :: Floor)),
128− ("commission", commissionAttrs)]
157+ ("commission", toAttributes (undefined :: Commission))]
129− rvDefs = map (\(name, attrs) -> Define name (map NakedAttributeExpr attrs)) relvarMap
158+ rvDefs = map (\(name, typ) -> Define name (map NakedAttributeExpr (V.toList typ))) relvarMap
130 --create the new algebraic data types
159 --create the new algebraic data types
131− new_adts = [toDatabaseContextExpr (undefined :: Room),
160+ new_adts = [toDatabaseContextExpr (undefined :: RoomType),
132 toDatabaseContextExpr (undefined :: PriceBand),
161 toDatabaseContextExpr (undefined :: PriceBand),
133 toDatabaseContextExpr (undefined :: AreaCode),
162 toDatabaseContextExpr (undefined :: AreaCode),
134 toDatabaseContextExpr (undefined :: SpeedBand)]
163 toDatabaseContextExpr (undefined :: SpeedBand)]
@@ -143,8 +172,8 @@ createSchema sessionId conn = do
143 --gather up and execute all database updates
172 --gather up and execute all database updates
144 eErrs <- mapM (executeDatabaseContextExpr sessionId conn) (new_adts ++ rvDefs ++ incDepKeys ++ incDepForeignKeys)
173 eErrs <- mapM (executeDatabaseContextExpr sessionId conn) (new_adts ++ rvDefs ++ incDepKeys ++ incDepForeignKeys)
145 let errs = lefts eErrs
174 let errs = lefts eErrs
146− unless (null errs) (error (show errs))
175+ unless (null errs) (putStrLn (show errs))
147
176
148 eErrs' <- mapM (executeDatabaseContextIOExpr sessionId conn) atomFuncs
177 eErrs' <- mapM (executeDatabaseContextIOExpr sessionId conn) atomFuncs
149 let errs' = lefts eErrs'
178 let errs' = lefts eErrs'
150− unless (null errs') (error (show errs'))
179+ unless (null errs') (putStrLn (show errs'))
src/lib/ProjectM36/Client.hs+1−1
@@ -89,7 +89,7 @@ module ProjectM36.Client
89 Atomable(..),
89 Atomable(..),
90 TupleExprBase(..),
90 TupleExprBase(..),
91 AtomExprBase(..),
91 AtomExprBase(..),
92− RestrictionPredicateExprBase(..)
92+ RestrictionPredicateExprBase(..),
93 ) where
93 ) where
94import ProjectM36.Base hiding (inclusionDependencies) --defined in this module as well
94import ProjectM36.Base hiding (inclusionDependencies) --defined in this module as well
95import qualified ProjectM36.Base as B
95import qualified ProjectM36.Base as B
src/lib/ProjectM36/Tuple.hs+3
@@ -209,3 +209,6 @@ reorderTuple attrs tupIn = if tupleAttributes tupIn == attrs then
209 Left _ -> error "logic failure in reorderTuple"
209 Left _ -> error "logic failure in reorderTuple"
210 Right atom -> atom
210 Right atom -> atom
211
211
212+--used in Generics derivation for ADTs without named attributes
213+trimTuple :: Int -> RelationTuple -> RelationTuple
214+trimTuple index (RelationTuple attrs vals) = RelationTuple (V.drop index attrs) (V.drop index vals)
src/lib/ProjectM36/Tupleable.hs+20−17
@@ -1,17 +1,13 @@
1−{-# LANGUAGE DeriveGeneric, DefaultSignatures, FlexibleInstances, FlexibleContexts, TypeOperators, UndecidableInstances #-}
1+{-# LANGUAGE DeriveGeneric, DefaultSignatures, FlexibleInstances, FlexibleContexts, TypeOperators, UndecidableInstances, ScopedTypeVariables #-}
2module ProjectM36.Tupleable where
2module ProjectM36.Tupleable where
3import ProjectM36.Base
3import ProjectM36.Base
4import ProjectM36.Tuple
4import ProjectM36.Tuple
5import ProjectM36.Atomable
5import ProjectM36.Atomable
6−import ProjectM36.Attribute
6+import ProjectM36.Attribute hiding (null)
7import GHC.Generics
7import GHC.Generics
8import qualified Data.Vector as V
8import qualified Data.Vector as V
9import qualified Data.Text as T
9import qualified Data.Text as T
10import Data.Monoid
10import Data.Monoid
11−import Data.Proxy
12−import Data.Maybe
13−import ProjectM36.DataTypes.Primitive
14−import Debug.Trace
15
11
16data Test1T = Test1C {
12data Test1T = Test1C {
17 attrA :: Int
13 attrA :: Int
@@ -28,6 +24,10 @@ instance (Atomable a, Atomable b, Show a, Show b) => Tupleable (Test2T a b)
28
24
29instance Tupleable Test1T
25instance Tupleable Test1T
30
26
27+data TestUnnamed1 = TestUnnamed1 Int Double T.Text
28+ deriving (Show,Eq, Generic)
29+
30+instance Tupleable TestUnnamed1
31
31
32class Tupleable a where
32class Tupleable a where
33 toTuple :: a -> RelationTuple
33 toTuple :: a -> RelationTuple
@@ -53,7 +53,7 @@ class TupleableG g where
53--data type metadata
53--data type metadata
54instance (Datatype c, TupleableG a) => TupleableG (M1 D c a) where
54instance (Datatype c, TupleableG a) => TupleableG (M1 D c a) where
55 toTupleG (M1 v) = toTupleG v
55 toTupleG (M1 v) = toTupleG v
56− toAttributesG = undefined
56+ toAttributesG (M1 v) = toAttributesG v
57 fromTupleG v = M1 (fromTupleG v)
57 fromTupleG v = M1 (fromTupleG v)
58
58
59--constructor metadata
59--constructor metadata
@@ -67,36 +67,39 @@ instance (Constructor c, TupleableG a, AtomableG a) => TupleableG (M1 C c a) whe
67 else
67 else
68 attr) counter attrsToCheck
68 attr) counter attrsToCheck
69 atoms = V.fromList (toAtomsG v)
69 atoms = V.fromList (toAtomsG v)
70− toAttributesG = undefined
70+ toAttributesG (M1 v) = toAttributesG v
71 fromTupleG tup = M1 (fromTupleG tup)
71 fromTupleG tup = M1 (fromTupleG tup)
72
72
73-- product types
73-- product types
74instance (TupleableG a, TupleableG b) => TupleableG (a :*: b) where
74instance (TupleableG a, TupleableG b) => TupleableG (a :*: b) where
75− toTupleG = undefined
75+ toTupleG = error "toTupleG"
76 toAttributesG (x :*: y) = toAttributesG x V.++ toAttributesG y
76 toAttributesG (x :*: y) = toAttributesG x V.++ toAttributesG y
77− fromTupleG = undefined
77+ fromTupleG tup = fromTupleG tup :*: fromTupleG (trimTuple 1 tup)
78
78
79--selector/record
79--selector/record
80instance (Selector c, AtomableG a) => TupleableG (M1 S c a) where
80instance (Selector c, AtomableG a) => TupleableG (M1 S c a) where
81− toTupleG = undefined
81+ toTupleG = error "toTupleG"
82 toAttributesG m@(M1 v) = V.singleton (Attribute name aType)
82 toAttributesG m@(M1 v) = V.singleton (Attribute name aType)
83 where
83 where
84 name = T.pack (selName m)
84 name = T.pack (selName m)
85 aType = toAtomTypeG v
85 aType = toAtomTypeG v
86+ fromTupleG tup = if null name then -- non-record type, just pull off the first tuple item
87+ M1 (atomv (V.head (tupleAtoms tup)))
88+ else
86− fromTupleG tup = case atomForAttributeName (T.pack name) tup of
89+ case atomForAttributeName (T.pack name) tup of
87− Left _ -> error "no such record name"
90+ Left _ -> error ("no such record name: " ++ name)
88 Right atom -> M1 (atomv atom)
91 Right atom -> M1 (atomv atom)
89 where
92 where
90 atomv atom = case fromAtomG atom [atom] of
93 atomv atom = case fromAtomG atom [atom] of
91 Nothing -> error "no such atom conversion"
94 Nothing -> error "no such atom conversion"
92 Just v -> v
95 Just v -> v
93 name = selName (undefined :: M1 S c a x)
96 name = selName (undefined :: M1 S c a x)
94− --name = "attrA"
95−
96
97
97--constructors with no arguments
98--constructors with no arguments
98--basically useless but orthoganal to relationTrue
99--basically useless but orthoganal to relationTrue
99instance TupleableG U1 where
100instance TupleableG U1 where
100− toTupleG = undefined
101+ toTupleG _= emptyTuple
101 toAttributesG _ = emptyAttributes
102 toAttributesG _ = emptyAttributes
102− fromTupleG = undefined
103+ fromTupleG _ = U1
104+
105+
test/Relation/Tupleable.hs+67−12
@@ -1,33 +1,49 @@
1−{-# LANGUAGE DeriveGeneric, DefaultSignatures, FlexibleInstances, FlexibleContexts, TypeOperators #-}
1+{-# LANGUAGE DeriveGeneric, DefaultSignatures, FlexibleInstances, FlexibleContexts, TypeOperators, DeriveAnyClass #-}
2import Test.HUnit
2import Test.HUnit
3import ProjectM36.Tupleable
3import ProjectM36.Tupleable
4+import ProjectM36.Atomable
5+import Data.Binary
4import ProjectM36.Base
6import ProjectM36.Base
5−import TutorialD.Interpreter.TestBase
7+import Control.DeepSeq (NFData)
6import GHC.Generics
8import GHC.Generics
9+import qualified Data.Vector as V
10+import qualified Data.Map as M
11+import qualified Data.Text as T
12+import System.Exit
7
13
8data Test1T = Test1C {
14data Test1T = Test1C {
9 attrA :: Int
15 attrA :: Int
10 }
16 }
11− deriving (Generic)
17+ deriving (Generic, Eq, Show)
12
18
13data Test2T = Test2C {
19data Test2T = Test2C {
14 attrB :: Int,
20 attrB :: Int,
15 attrC :: Int
21 attrC :: Int
16 }
22 }
17− deriving (Generic)
23+ deriving (Generic, Eq, Show)
18
24
19data Test3T = Test3C Int
25data Test3T = Test3C Int
20− deriving Generic
26+ deriving (Generic, Eq, Show)
21
27
22data Test4T = Test4C
28data Test4T = Test4C
23− deriving Generic
29+ deriving (Generic, Eq, Show)
24
30
25data Test5T = Test5C1 Int |
31data Test5T = Test5C1 Int |
26 Test5C2 Int
32 Test5C2 Int
27− deriving Generic
33+ deriving (Generic, Eq, Show)
28
34
29data Test6T = Test6C T.Text Int Double
35data Test6T = Test6C T.Text Int Double
30− deriving Generic
36+ deriving (Generic, Eq, Show)
37+
38+data Test7A = Test7AC Int
39+ deriving (Generic, Show, Eq, Binary, NFData, Atomable)
40+
41+
42+data Test7T = Test7C Test7A
43+ deriving (Generic, Show, Eq)
44+
45+data Test8T = Test8C
46+ deriving (Generic, Show, Eq)
31
47
32instance Tupleable Test1T
48instance Tupleable Test1T
33
49
@@ -41,15 +57,54 @@ instance Tupleable Test4T
41
57
42instance Tupleable Test6T
58instance Tupleable Test6T
43
59
60+instance Tupleable Test7T
61+
62+instance Tupleable Test8T
63+
44main :: IO ()
64main :: IO ()
45main = do
65main = do
46 tcounts <- runTestTT testList
66 tcounts <- runTestTT testList
47 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
67 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
48
68
49testList :: Test
69testList :: Test
50−testList = TestList [testADT1]
70+testList = TestList [testADT1, testADT2, testADT3, testADT4, testADT6, testADT7, testADT8]
51
71
52testADT1 :: Test
72testADT1 :: Test
53−testADT1 = TestCase $ do
73+testADT1 = TestCase $ assertEqual "one record constructor" example (fromTuple (toTuple example))
74+ where
75+ example = Test1C {attrA = 3}
76+
77+
78+testADT2 :: Test
79+testADT2 = TestCase $ assertEqual "two record constructor" example (fromTuple (toTuple example))
80+ where
81+ example = Test2C { attrB = 4, attrC = 6 }
82+
83+testADT3 :: Test
84+testADT3 = TestCase $ assertEqual "one arg constructor" example (fromTuple (toTuple example))
85+ where
86+ example = Test3C 4
87+
88+testADT4 :: Test
89+testADT4 = TestCase $ assertEqual "zero arg constructor" example (fromTuple (toTuple example))
90+ where
91+ example = Test4C
92+
93+--testADT5 should not compile
94+
95+testADT6 :: Test
96+testADT6 = TestCase $ assertEqual "mixed types" example (fromTuple (toTuple example))
97+ where
98+ example = Test6C "testo" 3 4.0
99+
100+testADT7 :: Test
101+testADT7 = TestCase $ do
54− let example = Test1C {attr1 = 3}
102+ let example = Test7C (Test7AC 3)
103+ assertEqual "atom type" example (fromTuple (toTuple example))
104+ let expectedAttrs = V.singleton (Attribute "" (ConstructedAtomType "Test7A" M.empty))
105+ assertEqual "adt atomtype" expectedAttrs (toAttributes (undefined :: Test7T))
106+
107+testADT8 :: Test
55− assertEqual "one arg constructor" example (fromTuple (toTuple example))
108+testADT8 = TestCase $ assertEqual "single value" example (fromTuple (toTuple example))
109+ where
110+ example = Test8C