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

git.iko.soy/project-m36

more WIP

commit68e9b8f93836252d5a6cf1cfdeb972d120fdc485 authorAgentM <agentm@themactionfaction.com> dateTue 3 Sep 2019, 17:40 (7 years ago) parentb81f8fc

3 files changed+43−14

compare with master

unifiedsplit

src/lib/ProjectM36/Atomable.hs+4−5 src/lib/ProjectM36/RelationalExpression.hs+13−9 test/Relation/Atomable.hs+26

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

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

272272-- product types

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

274274 toAtomG = undefined

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

276− where headatom (x:_) = x

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

278− tailatoms (_:xs) = xs

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

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

276+ where splitargs1 = take splitpoint args

277+ splitargs2 = drop splitpoint args

278+ splitpoint = length args `div` 2

280279 toAtomTypeG = undefined

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

282281 toAddTypeExprG _ _ = undefined

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

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

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

519519 Left err -> Just err

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

521− typeErrors = catMaybes mValidTypes

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

521+ typeErrors = catMaybes mValidTypes

522+ eAtomArgs = unimplemented

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

523524 if length (lefts eAtomArgs) > 1 then

524525 pure (Left (someErrors (lefts eAtomArgs)))

525526 else if not (null typeErrors) then

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

644645updateTupleWithAtomExprs exprMap context graph tupIn = do

645646 --resolve all atom exprs

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

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

648+ let atom = unimplemented

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

648650 pure (attrName, atom)

649651 ) (M.toList exprMap)

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

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

734736 pure (fmap not . exprv)

735737

736738--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+{-

737740predicateRestrictionFilter _ (RelationalExprPredicate relExpr) = do

738741 rstate <- ask

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

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

783786 case runReader (evalAtomExpr tupleIn atomExpr) rstate of

784787 Left err -> Left err

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

786−

789+-}

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

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

789792 Left (AttributeNameInUseError attrName)

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

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

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

803806 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

805809 Left err -> Left err

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

807811 )

808−

812+{-

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

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

811815 Right atom -> pure (Right atom)

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

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

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

854858 pure (ConstructedAtom dConsName aType argAtoms)

855−

859+-}

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

857861typeFromAtomExpr attrs (AttributeAtomExpr attrName) = do

858862 rstate <- ask

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

863867 stateAttrs = stateAttributes rstate in

864868 case A.attributeForName attrName stateAttrs of

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

866− Left _ -> case atomForAttributeName attrName tup of

870+ Left _ -> case atomForAttributeName attrName stateTup of

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

868872 Left _ -> pure (Left err)

869873

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

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

888892typeFromAtomExpr attrs (RelationAtomExpr relExpr) = runExceptT $ do

889893 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))

891895 pure (RelationAtomType (attributes relType))

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

893897typeFromAtomExpr attrs (ConstructedAtomExpr dConsName dConsArgs _) =

test/Relation/Atomable.hs+26

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

4747

4848data Test8T = Test8C Test1T

4949 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+

5067

5168main :: IO ()

5269main = do

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

149166testNonPrimitiveValues = TestCase $ do

150167 let example = Test8C (Test1C 3)

151168 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))