2ff4067 · project-m36 · git.iko.soy

git.iko.soy/project-m36

remove user-facing undefined in preference to Proxy

resolves #144

commit2ff4067cb842dd8fd5df4eaef6e807c277abe5ac authorAgentM <agentm@themactionfaction.com> dateThu 28 Sep 2017, 22:03 (9 years ago) parent3fc7481

7 files changed+67−48

compare with master

unifiedsplit

examples/blog.hs+4−3 examples/hair.hs+2−1 examples/out_of_the_tarpit.hs+11−10 src/lib/ProjectM36/Atomable.hs+22−20 src/lib/ProjectM36/Tupleable.hs+22−10 test/Relation/Atomable.hs+3−2 test/Relation/Tupleable.hs+3−2

examples/blog.hs+4−3

@@ -12,6 +12,7 @@ import qualified Data.Text as T

1212import Data.Time.Clock

1313import Data.Time.Calendar

1414import Control.DeepSeq

15+import Data.Proxy

1516

1617--define your data types

1718data Blog = Blog {

@@ -69,9 +70,9 @@ main = do

6970createSchema :: SessionId -> Connection -> IO ()

7071createSchema sessionId conn = do

7172 _ <- handleIOErrors $ mapM (executeDatabaseContextExpr sessionId conn) [

72− toAddTypeExpr (undefined :: Category),

73− toDefineExpr (undefined :: Blog) "blog",

74− toDefineExpr (undefined :: Comment) "comment",

73+ toAddTypeExpr (Proxy :: Proxy Category),

74+ toDefineExpr (Proxy :: Proxy Blog) "blog",

75+ toDefineExpr (Proxy :: Proxy Comment) "comment",

7576 databaseContextExprForForeignKey "blog_comment" ("comment", ["blogTitle"]) ("blog", ["title"]) ]

7677 pure ()

7778

examples/hair.hs+2−1

@@ -7,6 +7,7 @@ import Data.Binary

77import Control.DeepSeq

88import qualified Data.Map as M

99import qualified Data.Text.IO as TIO

10+import Data.Proxy

1011

1112data Hair = Bald | Brown | Blond | OtherColor Text

1213 deriving (Generic, Show, Eq, Binary, NFData, Atomable)

@@ -26,7 +27,7 @@ main = do

2627 sessionId <- eCheck $ createSessionAtHead conn "master"

2728

2829 --create the data type in the database context

29− eCheck $ executeDatabaseContextExpr sessionId conn (toAddTypeExpr (undefined :: Hair))

30+ eCheck $ executeDatabaseContextExpr sessionId conn (toAddTypeExpr (Proxy :: Proxy Hair))

3031

3132 --create a relation with the new Hair AtomType

3233 let blond = NakedAtomExpr (toAtom Blond)

examples/out_of_the_tarpit.hs+11−10

@@ -11,6 +11,7 @@ import Data.Binary

1111import Control.DeepSeq

1212import qualified Data.Text as T

1313import Data.Time.Calendar

14+import Data.Proxy

1415

1516--create various database value (atom) types

1617type Price = Double

@@ -142,17 +143,17 @@ createSchema sessionId conn = do

142143 ]

143144 incDepForeignKeys = map (\(n, a, b) -> databaseContextExprForForeignKey n a b) foreignKeys

144145 --define the relvars

145− rvExprs = [toDefineExpr (undefined :: Property) "property",

146− toDefineExpr (undefined :: Offer) "offer",

147− toDefineExpr (undefined :: Decision) "decision",

148− toDefineExpr (undefined :: Room) "room",

149− toDefineExpr (undefined :: Floor) "floor",

150− toDefineExpr (undefined :: Commission) "commission"]

146+ rvExprs = [toDefineExpr (Proxy :: Proxy Property) "property",

147+ toDefineExpr (Proxy :: Proxy Offer) "offer",

148+ toDefineExpr (Proxy :: Proxy Decision) "decision",

149+ toDefineExpr (Proxy :: Proxy Room) "room",

150+ toDefineExpr (Proxy :: Proxy Floor) "floor",

151+ toDefineExpr (Proxy :: Proxy Commission) "commission"]

151152 --create the new algebraic data types

152− new_adts = [toAddTypeExpr (undefined :: RoomType),

153− toAddTypeExpr (undefined :: PriceBand),

154− toAddTypeExpr (undefined :: AreaCode),

155− toAddTypeExpr (undefined :: SpeedBand)]

153+ new_adts = [toAddTypeExpr (Proxy :: Proxy RoomType),

154+ toAddTypeExpr (Proxy :: Proxy PriceBand),

155+ toAddTypeExpr (Proxy :: Proxy AreaCode),

156+ toAddTypeExpr (Proxy :: Proxy SpeedBand)]

156157 --create the stored atom functions

157158 priceBandScript = "(\\(DoubleAtom price:_) -> do\n let band = if price < 10000.0 then \"Low\" else if price < 20000.0 then \"Medium\" else if price < 30000.0 then \"High\" else \"Premium\"\n let aType = ConstructedAtomType \"PriceBand\" empty\n pure (ConstructedAtom band aType [])) :: [Atom] -> Either AtomFunctionError Atom"

158159 areaCodeScript = "(\\(TextAtom address:_) -> let aType = ConstructedAtomType \"AreaCode\" empty in if address == \"90210\" then pure (ConstructedAtom \"City\" aType []) else pure (ConstructedAtom \"Rural\" aType [])) :: [Atom] -> Either AtomFunctionError Atom"

src/lib/ProjectM36/Atomable.hs+22−20

@@ -3,7 +3,6 @@ module ProjectM36.Atomable where

33--http://stackoverflow.com/questions/13448361/type-families-with-ghc-generics-or-data-data

44--instances to marshal Haskell ADTs to ConstructedAtoms and back

55import ProjectM36.Base

6−import ProjectM36.Relation

76import ProjectM36.DataTypes.Primitive

87import ProjectM36.DataTypes.List

98import ProjectM36.DataTypes.Maybe

@@ -18,6 +17,7 @@ import Data.Time.Calendar

1817import Data.ByteString (ByteString)

1918import Data.Time.Clock

2019import Data.Maybe

20+import Data.Proxy

2121

2222--also add haskell scripting atomable support

2323--rename this module to Atomable along with test

@@ -47,14 +47,14 @@ class (Eq a, NFData a, Binary a, Show a) => Atomable a where

4747 Nothing -> error "no fromAtomG for Atom found"

4848 Just x -> to x

4949

50− toAtomType :: a -> AtomType

51− default toAtomType :: (Generic a, AtomableG (Rep a)) => a -> AtomType

52− toAtomType v = toAtomTypeG (from v)

50+ toAtomType :: Proxy a -> AtomType

51+ default toAtomType :: (Generic a, AtomableG (Rep a)) => Proxy a -> AtomType

52+ toAtomType _ = toAtomTypeG (from (undefined :: a))

5353

5454 -- | Creates DatabaseContextExpr necessary to load the type constructor and data constructor into the database.

55− toAddTypeExpr :: a -> DatabaseContextExpr

56− default toAddTypeExpr :: (Generic a, AtomableG (Rep a)) => a -> DatabaseContextExpr

57− toAddTypeExpr v = toAddTypeExprG (from v) (toAtomType v)

55+ toAddTypeExpr :: Proxy a -> DatabaseContextExpr

56+ default toAddTypeExpr :: (Generic a, AtomableG (Rep a)) => Proxy a -> DatabaseContextExpr

57+ toAddTypeExpr p = toAddTypeExprG (from (undefined ::a)) (toAtomType p)

5858

5959instance Atomable Integer where

6060 toAtom = IntegerAtom

@@ -112,6 +112,7 @@ instance Atomable Bool where

112112 toAtomType _ = BoolAtomType

113113 toAddTypeExpr _ = NoOperation

114114

115+{-

115116instance Atomable Relation where

116117 toAtom = RelationAtom

117118 fromAtom (RelationAtom r) = r

@@ -119,23 +120,24 @@ instance Atomable Relation where

119120 --warning: cannot be used with undefined "Relation"

120121 toAtomType rel = RelationAtomType (attributes rel)

121122 toAddTypeExpr _ = NoOperation

123+-}

122124

123125instance Atomable a => Atomable (Maybe a) where

124− toAtom (Just v) = ConstructedAtom "Just" (maybeAtomType (toAtomType v)) [toAtom v]

125− toAtom Nothing = ConstructedAtom "Nothing" (maybeAtomType (toAtomType (undefined :: a))) []

126+ toAtom (Just v) = ConstructedAtom "Just" (maybeAtomType (toAtomType (Proxy :: Proxy a))) [toAtom v]

127+ toAtom Nothing = ConstructedAtom "Nothing" (maybeAtomType (toAtomType (Proxy :: Proxy a))) []

126128

127129 fromAtom (ConstructedAtom "Just" _ [val]) = Just (fromAtom val)

128130 fromAtom (ConstructedAtom "Nothing" _ []) = Nothing

129131 fromAtom _ = error "improper fromAtom (Maybe a)"

130132

131− toAtomType _ = ConstructedAtomType "Maybe" (M.singleton "a" (toAtomType (undefined :: a)))

133+ toAtomType _ = ConstructedAtomType "Maybe" (M.singleton "a" (toAtomType (Proxy :: Proxy a)))

132134 toAddTypeExpr _ = NoOperation

133135

134136instance (Atomable a, Atomable b) => Atomable (Either a b) where

135− toAtom (Left l) = ConstructedAtom "Left" (eitherAtomType (toAtomType (undefined :: a))

136− (toAtomType (undefined :: b))) [toAtom l]

137− toAtom (Right r) = ConstructedAtom "Right" (eitherAtomType (toAtomType (undefined :: a))

138− (toAtomType (undefined :: b))) [toAtom r]

137+ toAtom (Left l) = ConstructedAtom "Left" (eitherAtomType (toAtomType (Proxy :: Proxy a))

138+ (toAtomType (Proxy :: Proxy b))) [toAtom l]

139+ toAtom (Right r) = ConstructedAtom "Right" (eitherAtomType (toAtomType (Proxy :: Proxy a))

140+ (toAtomType (Proxy :: Proxy b))) [toAtom r]

139141

140142 fromAtom (ConstructedAtom "Left" _ [val]) = Left (fromAtom val)

141143 fromAtom (ConstructedAtom "Right" _ [val]) = Right (fromAtom val)

@@ -143,14 +145,14 @@ instance (Atomable a, Atomable b) => Atomable (Either a b) where

143145

144146--convert to ADT list

145147instance Atomable a => Atomable [a] where

146− toAtom [] = ConstructedAtom "Empty" (listAtomType (toAtomType (undefined :: a))) []

147− toAtom (x:xs) = ConstructedAtom "Cons" (listAtomType (toAtomType x)) (map toAtom (x:xs))

148+ toAtom [] = ConstructedAtom "Empty" (listAtomType (toAtomType (Proxy :: Proxy a))) []

149+ toAtom (x:xs) = ConstructedAtom "Cons" (listAtomType (toAtomType (Proxy :: Proxy a))) (map toAtom (x:xs))

148150

149151 fromAtom (ConstructedAtom "Empty" _ _) = []

150152 fromAtom (ConstructedAtom "Cons" _ (x:xs)) = fromAtom x:map fromAtom xs

151153 fromAtom _ = error "improper fromAtom [a]"

152154

153− toAtomType _ = ConstructedAtomType "List" (M.singleton "a" (toAtomType (undefined :: a)))

155+ toAtomType _ = ConstructedAtomType "List" (M.singleton "a" (toAtomType (Proxy :: Proxy a)))

154156 toAddTypeExpr _ = NoOperation

155157

156158-- Generics

@@ -220,13 +222,13 @@ instance (Atomable a) => AtomableG (K1 c a) where

220222 where headatom (x:_) = x

221223 headatom [] = error "no more atoms for constructor!"

222224 toAtomsG (K1 v) = [toAtom v]

223− toAtomTypeG _ = toAtomType (undefined :: a)

225+ toAtomTypeG _ = toAtomType (Proxy :: Proxy a)

224226 toAddTypeExprG _ _ = undefined

225227 getConstructorsG = undefined

226− getConstructorArgsG (K1 v) = [DataConstructorDefTypeConstructorArg tCons]

228+ getConstructorArgsG (K1 _) = [DataConstructorDefTypeConstructorArg tCons]

227229 where

228230 tCons = PrimitiveTypeConstructor primitiveATypeName primitiveAType

229− primitiveAType = toAtomType v

231+ primitiveAType = toAtomType (Proxy :: Proxy a)

230232 primitiveATypeName = fromMaybe (error ("primitive type missing: " ++ show primitiveAType)) (foldr (\(PrimitiveTypeConstructorDef name typ, _) _ -> if typ == primitiveAType then Just name else Nothing) Nothing primitiveTypeConstructorMapping)

231233

232234instance AtomableG U1 where

src/lib/ProjectM36/Tupleable.hs+22−10

@@ -2,8 +2,8 @@

22module ProjectM36.Tupleable where

33import ProjectM36.Base

44import ProjectM36.Error

5−import ProjectM36.Tuple

65import ProjectM36.TupleSet

6+import ProjectM36.Tuple

77import ProjectM36.Atomable

88import ProjectM36.DataTypes.Primitive

99import ProjectM36.Attribute hiding (null)

@@ -11,9 +11,12 @@ import GHC.Generics

1111import qualified Data.Vector as V

1212import qualified Data.Text as T

1313import Data.Monoid

14+import Data.Proxy

1415import Data.Foldable

1516

16−{-

17+{-import Data.Binary

18+import Control.DeepSeq

19+

1720data Test1T = Test1C {

1821 attrA :: Int

1922 }

@@ -32,19 +35,28 @@ instance Tupleable Test1T

3235data TestUnnamed1 = TestUnnamed1 Int Double T.Text

3336 deriving (Show,Eq, Generic)

3437

35−instance Tupleable TestUnnamed1

38+instance Tupleable TestUnnamed1

39+

40+data Test7A = Test7AC Integer

41+ deriving (Generic, Show, Eq, Atomable, NFData, Binary)

42+

43+

44+data Test7T = Test7C Test7A

45+ deriving (Generic, Show, Eq)

46+

47+instance Tupleable Test7T

3648-}

3749

3850-- | Convert a 'Traverseable' of 'Tupleable's to an 'Insert' 'DatabaseContextExpr'. This is useful for converting, for example, a list of data values to a set of Insert expressions which can be used to add the values to the database.

39−toInsertExpr :: (Tupleable a, Traversable t) => t a -> RelVarName -> Either RelationalError DatabaseContextExpr

51+toInsertExpr :: forall a. forall t. (Tupleable a, Traversable t) => t a -> RelVarName -> Either RelationalError DatabaseContextExpr

4052toInsertExpr vals rvName = do

41− let attrs = toAttributes (head (toList vals))

53+ let attrs = toAttributes (Proxy :: Proxy a)

4254 tuples <- mkTupleSet attrs $ toList (fmap toTuple vals)

4355 let rel = MakeStaticRelation attrs tuples

4456 pure (Insert rvName rel)

4557

46−-- | Convert a 'Tupleable' to a create a 'Define' expression which can be used to create an empty relation variable. Use 'toInsertExpr' to insert the actual tuple data. This function is typically used with 'undefined'.

47−toDefineExpr :: Tupleable a => a -> RelVarName -> DatabaseContextExpr

58+-- | Convert a 'Tupleable' to a create a 'Define' expression which can be used to create an empty relation variable. Use 'toInsertExpr' to insert the actual tuple data. This function is typically used with 'Data.Proxy'.

59+toDefineExpr :: Tupleable a => Proxy a -> RelVarName -> DatabaseContextExpr

4860toDefineExpr val rvName = Define rvName (map NakedAttributeExpr (V.toList attrs))

4961 where

5062 attrs = toAttributes val

@@ -56,7 +68,7 @@ class Tupleable a where

5668

5769 fromTuple :: RelationTuple -> Either RelationalError a

5870

59− toAttributes :: a -> Attributes

71+ toAttributes :: Proxy a -> Attributes

6072

6173 default toTuple :: (Generic a, TupleableG (Rep a)) => a -> RelationTuple

6274 toTuple v = toTupleG (from v)

@@ -64,8 +76,8 @@ class Tupleable a where

6476 default fromTuple :: (Generic a, TupleableG (Rep a)) => RelationTuple -> Either RelationalError a

6577 fromTuple tup = to <$> fromTupleG tup

6678

67− default toAttributes :: (Generic a, TupleableG (Rep a)) => a -> Attributes

68− toAttributes v = toAttributesG (from v)

79+ default toAttributes :: (Generic a, TupleableG (Rep a)) => Proxy a -> Attributes

80+ toAttributes _ = toAttributesG (from (undefined :: a))

6981

7082class TupleableG g where

7183 toTupleG :: g a -> RelationTuple

test/Relation/Atomable.hs+3−2

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

1212import Data.Time.Calendar (fromGregorian)

1313import Data.Text

1414import qualified Data.Map as M

15+import Data.Proxy

1516

1617{-# ANN module ("Hlint: ignore Use newtype instead of data" :: String) #-}

1718data Test1T = Test1C Integer

@@ -67,7 +68,7 @@ testHaskell2DB :: Test

6768testHaskell2DB = TestCase $ do

6869 --validate generated database context expression

6970 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

70− let test1TExpr = toAddTypeExpr (undefined :: Test1T)

71+ let test1TExpr = toAddTypeExpr (Proxy :: Proxy Test1T)

7172 expectedTest1TExpr = AddTypeConstructor (ADTypeConstructorDef "Test1T" []) [DataConstructorDef "Test1C" [DataConstructorDefTypeConstructorArg (PrimitiveTypeConstructor "Integer" IntegerAtomType)]]

7273 assertEqual "simple ADT1" expectedTest1TExpr test1TExpr

7374 checkExecuteDatabaseContextExpr sessionId dbconn test1TExpr

@@ -83,7 +84,7 @@ testHaskell2DB = TestCase $ do

8384

8485 let retrieveValExpr = Restrict (AttributeEqualityPredicate "a1" (NakedAtomExpr atomVal)) (RelationVariable "x" ())

8586 ret <- executeRelationalExpr sessionId dbconn retrieveValExpr

86− let expectedRel = mkRelationFromList (attributesFromList [Attribute "a1" (toAtomType exampleVal)]) [[atomVal]]

87+ let expectedRel = mkRelationFromList (attributesFromList [Attribute "a1" (toAtomType (Proxy :: Proxy Test1T))]) [[atomVal]]

8788 assertEqual "retrieve atomable atom" expectedRel ret

8889

8990testADT1 :: Test

test/Relation/Tupleable.hs+3−2

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

1111import qualified Data.Map as M

1212import qualified Data.Text as T

1313import System.Exit

14+import Data.Proxy

1415

1516{-# ANN module ("Hlint: ignore Use newtype instead of data" :: String) #-}

1617

@@ -85,7 +86,7 @@ testADT2 = TestCase $ do

8586 --this was a tricky case that was throwing the undefined exception because of insufficient laziness in the :*: matching- see ProjectM36.Tupleable

8687 let expectedAttributes = attributesFromList [Attribute "attrB" IntegerAtomType,

8788 Attribute "attrC" IntegerAtomType]

88− assertEqual "two record constructor toAttributes" expectedAttributes (toAttributes (undefined :: Test2T))

89+ assertEqual "two record constructor toAttributes" expectedAttributes (toAttributes (Proxy :: Proxy Test2T))

8990

9091

9192testADT3 :: Test

@@ -110,7 +111,7 @@ testADT7 = TestCase $ do

110111 let example = Test7C (Test7AC 3)

111112 assertEqual "atom type" (Right example) (fromTuple (toTuple example))

112113 let expectedAttrs = V.singleton (Attribute "" (ConstructedAtomType "Test7A" M.empty))

113− assertEqual "adt atomtype" expectedAttrs (toAttributes (undefined :: Test7T))

114+ assertEqual "adt atomtype" expectedAttrs (toAttributes (Proxy :: Proxy Test7T))

114115

115116testADT8 :: Test

116117testADT8 = TestCase $ assertEqual "single value" (Right example) (fromTuple (toTuple example))