68e9b8f · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

more WIP

68e9b8fAgentM7 years ago

src/lib/ProjectM36/Atomable.hs+4−5

compare with master

unifiedsplit

@@ -272,11 +272,10 @@ instance AtomableG U1 where

272-- product types

273instance (AtomableG a, AtomableG b) => AtomableG (a :*: b) where

274 toAtomG = undefined

275− fromAtomG atom args = (:*:) <$> fromAtomG atom [headatom args] <*> fromAtomG atom (tailatoms args)

275+ fromAtomG atom args = (:*:) <$> fromAtomG atom splitargs1 <*> fromAtomG atom splitargs2

276− where headatom (x:_) = x

276+ where splitargs1 = take splitpoint args

277− headatom [] = error "no more atoms in head for product!"

277+ splitargs2 = drop splitpoint args

278− tailatoms (_:xs) = xs

278+ splitpoint = length args `div` 2

279− tailatoms [] = error "no more atoms in tail for product!"

280 toAtomTypeG = undefined

279 toAtomTypeG = undefined

281 toAtomsG (x :*: y) = toAtomsG x ++ toAtomsG y

280 toAtomsG (x :*: y) = toAtomsG x ++ toAtomsG y

282 toAddTypeExprG _ _ = undefined

281 toAddTypeExprG _ _ = undefined

src/lib/ProjectM36/RelationalExpression.hs+13−9

@@ -518,8 +518,9 @@ evalDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) _

518 let mValidTypes = map (\(expType, actType) -> case atomTypeVerify expType actType of

519 Left err -> Just err

520 Right _ -> Nothing) (zip (dbcFuncType func) atomTypes)

521− typeErrors = catMaybes mValidTypes

521+ typeErrors = catMaybes mValidTypes

522+ eAtomArgs = unimplemented

522− eAtomArgs = map (\arg -> runReader (evalAtomExpr emptyTuple arg) relExprState) atomArgExprs

523+ --eAtomArgs = map (\arg -> runReader (evalAtomExpr emptyTuple arg) relExprState) atomArgExprs

523 if length (lefts eAtomArgs) > 1 then

524 if length (lefts eAtomArgs) > 1 then

524 pure (Left (someErrors (lefts eAtomArgs)))

525 pure (Left (someErrors (lefts eAtomArgs)))

525 else if not (null typeErrors) then

526 else if not (null typeErrors) then

@@ -644,7 +645,8 @@ updateTupleWithAtomExprs :: M.Map AttributeName AtomExpr -> DatabaseContext -> T

644updateTupleWithAtomExprs exprMap context graph tupIn = do

645updateTupleWithAtomExprs exprMap context graph tupIn = do

645 --resolve all atom exprs

646 --resolve all atom exprs

646 atomsAssoc <- mapM (\(attrName, atomExpr) -> do

647 atomsAssoc <- mapM (\(attrName, atomExpr) -> do

648+ let atom = unimplemented

647− atom <- runReader (evalAtomExpr tupIn atomExpr) (mkRelationalExprState context graph)

649+ --atom <- runReader (evalAtomExpr tupIn atomExpr) (mkRelationalExprState context graph)

648 pure (attrName, atom)

650 pure (attrName, atom)

649 ) (M.toList exprMap)

651 ) (M.toList exprMap)

650 pure (updateTupleWithAtoms (M.fromList atomsAssoc) tupIn)

652 pure (updateTupleWithAtoms (M.fromList atomsAssoc) tupIn)

@@ -734,6 +736,7 @@ predicateRestrictionFilter attrs (NotPredicate expr) =

734 pure (fmap not . exprv)

736 pure (fmap not . exprv)

735

737

736--optimization opportunity: if the subexpression does not reference attributes in the top-level expression, then it need only be evaluated once, statically, outside the tuple filter- see historical implementation here

738--optimization opportunity: if the subexpression does not reference attributes in the top-level expression, then it need only be evaluated once, statically, outside the tuple filter- see historical implementation here

739+{-

737predicateRestrictionFilter _ (RelationalExprPredicate relExpr) = do

740predicateRestrictionFilter _ (RelationalExprPredicate relExpr) = do

738 rstate <- ask

741 rstate <- ask

739 pure (Right (\tup -> case runReader (evalRelationalExpr relExpr) (mergeTuplesIntoRelationalExprState tup rstate) of

742 pure (Right (\tup -> case runReader (evalRelationalExpr relExpr) (mergeTuplesIntoRelationalExprState tup rstate) of

@@ -783,7 +786,7 @@ predicateRestrictionFilter attrs (AtomExprPredicate atomExpr) = do

783 case runReader (evalAtomExpr tupleIn atomExpr) rstate of

786 case runReader (evalAtomExpr tupleIn atomExpr) rstate of

784 Left err -> Left err

787 Left err -> Left err

785 Right boolAtomValue -> pure (boolAtomValue == BoolAtom True))

788 Right boolAtomValue -> pure (boolAtomValue == BoolAtom True))

786−

789+-}

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

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

788tupleExprCheckNewAttrName attrName rel = if isRight (attributeForName attrName rel) then

791tupleExprCheckNewAttrName attrName rel = if isRight (attributeForName attrName rel) then

789 Left (AttributeNameInUseError attrName)

792 Left (AttributeNameInUseError attrName)

@@ -801,11 +804,12 @@ extendTupleExpressionProcessor relIn (AttributeExtendTupleExpr newAttrName atomE

801 atomExprType' <- liftE (verifyAtomExprTypes relIn atomExpr atomExprType)

804 atomExprType' <- liftE (verifyAtomExprTypes relIn atomExpr atomExprType)

802 let newAttrs = A.attributesFromList [Attribute newAttrName atomExprType']

805 let newAttrs = A.attributesFromList [Attribute newAttrName atomExprType']

803 newAndOldAttrs = A.addAttributes (attributes relIn) newAttrs

806 newAndOldAttrs = A.addAttributes (attributes relIn) newAttrs

804− pure (newAndOldAttrs, \tup -> let substate = mergeTuplesIntoRelationalExprState tup rstate in case runReader (evalAtomExpr tup atomExpr) substate of

807+ pure (newAndOldAttrs, \tup -> let substate = mergeTuplesIntoRelationalExprState tup rstate in

808+ case unimplemented {-runReader (evalAtomExpr tup atomExpr) substate-} of

805 Left err -> Left err

809 Left err -> Left err

806 Right atom -> Right (tupleAtomExtend newAttrName atom tup)

810 Right atom -> Right (tupleAtomExtend newAttrName atom tup)

807 )

811 )

808−

812+{-

809evalAtomExpr :: RelationTuple -> AtomExpr -> RelationalExprState (Either RelationalError Atom)

813evalAtomExpr :: RelationTuple -> AtomExpr -> RelationalExprState (Either RelationalError Atom)

810evalAtomExpr tupIn (AttributeAtomExpr attrName) = case atomForAttributeName attrName tupIn of

814evalAtomExpr tupIn (AttributeAtomExpr attrName) = case atomForAttributeName attrName tupIn of

811 Right atom -> pure (Right atom)

815 Right atom -> pure (Right atom)

@@ -852,7 +856,7 @@ evalAtomExpr tupIn cons@(ConstructedAtomExpr dConsName dConsArgs ()) = runExcept

852 aType <- either throwE pure (runReader (typeFromAtomExpr (tupleAttributes tupIn) cons) newState)

856 aType <- either throwE pure (runReader (typeFromAtomExpr (tupleAttributes tupIn) cons) newState)

853 argAtoms <- mapM (\arg -> either throwE pure (runReader (evalAtomExpr tupIn arg) newState)) dConsArgs

857 argAtoms <- mapM (\arg -> either throwE pure (runReader (evalAtomExpr tupIn arg) newState)) dConsArgs

854 pure (ConstructedAtom dConsName aType argAtoms)

858 pure (ConstructedAtom dConsName aType argAtoms)

855−

859+-}

856typeFromAtomExpr :: Attributes -> AtomExpr -> RelationalExprState (Either RelationalError AtomType)

860typeFromAtomExpr :: Attributes -> AtomExpr -> RelationalExprState (Either RelationalError AtomType)

857typeFromAtomExpr attrs (AttributeAtomExpr attrName) = do

861typeFromAtomExpr attrs (AttributeAtomExpr attrName) = do

858 rstate <- ask

862 rstate <- ask

@@ -863,7 +867,7 @@ typeFromAtomExpr attrs (AttributeAtomExpr attrName) = do

863 stateAttrs = stateAttributes rstate in

867 stateAttrs = stateAttributes rstate in

864 case A.attributeForName attrName stateAttrs of

868 case A.attributeForName attrName stateAttrs of

865 Right attr -> pure (Right (A.atomType attr))

869 Right attr -> pure (Right (A.atomType attr))

866− Left _ -> case atomForAttributeName attrName tup of

870+ Left _ -> case atomForAttributeName attrName stateTup of

867 Right atom -> pure (Right (atomTypeForAtom atom))

871 Right atom -> pure (Right (atomTypeForAtom atom))

868 Left _ -> pure (Left err)

872 Left _ -> pure (Left err)

869

873

@@ -887,7 +891,7 @@ typeFromAtomExpr attrs (FunctionAtomExpr funcName atomArgs _) = do

887 Right tvMap -> pure (resolveFunctionReturnValue funcName tvMap funcRetType)

891 Right tvMap -> pure (resolveFunctionReturnValue funcName tvMap funcRetType)

888typeFromAtomExpr attrs (RelationAtomExpr relExpr) = runExceptT $ do

892typeFromAtomExpr attrs (RelationAtomExpr relExpr) = runExceptT $ do

889 rstate <- lift ask

893 rstate <- lift ask

890− relType <- either throwE pure (runReader (typeForRelationalExpr relExpr) (mergeAttributesIntoRelationalExprState attrs rstate))

894+ relType <- either throwE pure (runReader (typeForRelationalExpr relExpr () (mergeAttributesIntoRelationalExprState attrs rstate))

891 pure (RelationAtomType (attributes relType))

895 pure (RelationAtomType (attributes relType))

892-- grab the type of the data constructor, then validate that the args match the expected types

896-- grab the type of the data constructor, then validate that the args match the expected types

893typeFromAtomExpr attrs (ConstructedAtomExpr dConsName dConsArgs _) =

897typeFromAtomExpr attrs (ConstructedAtomExpr dConsName dConsArgs _) =

test/Relation/Atomable.hs+26

@@ -47,6 +47,23 @@ data Test7T = Test7C (Either Integer Integer)

48data Test8T = Test8C Test1T

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

50+

51+data Test9_4T = Test9_4C {

52+ f9_41 :: Int,

53+ f9_42 :: Int,

54+ f9_43 :: Int,

55+ f9_44 :: Int }

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

57+

58+data Test9_5T = Test9_5C {

59+ f9_51 :: Int,

60+ f9_52 :: Int,

61+ f9_53 :: Int,

62+ f9_54 :: Int,

63+ f9_55 :: Int

64+ }

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

66+

51main :: IO ()

68main :: IO ()

52main = do

69main = do

@@ -149,3 +166,12 @@ testNonPrimitiveValues :: Test

149testNonPrimitiveValues = TestCase $ do

166testNonPrimitiveValues = TestCase $ do

150 let example = Test8C (Test1C 3)

167 let example = Test8C (Test1C 3)

151 assertEqual "non-primitive values" example (fromAtom (toAtom example))

168 assertEqual "non-primitive values" example (fromAtom (toAtom example))

169+

170+--test both odd and even product types with more than 2 fields

171+testManyFields :: Test

172+testManyFields = TestCase $ do

173+ let example4 = Test9_4T 1 2 3 4

174+ assertEqual "four fields product type" example4 (fromAtom (toAtom example4))

175+

176+ let example5 = Test9_5T 1 2 3 4 5

177+ assertEqual "five fields product type" example5 (fromAtom (toAtom example5))