Skip to content
Browse files

Bi-directional relations

  • Loading branch information...
1 parent 87f11e0 commit 7cf60bcaf547376b0cfc72a000ab7274eea18aa9 Chris Eidhof committed Oct 26, 2009
Showing with 55 additions and 114 deletions.
  1. +23 −29 Basil/Core.hs
  2. +13 −13 Basil/Interface.hs
  3. +13 −5 Basil/TContainerList.hs
  4. +6 −67 CoreData2.hs
View
52 Basil/Core.hs
@@ -10,6 +10,7 @@
module Basil.Core where
+import Basil.TContainerList
import Generics.MultiRec.Base hiding (index)
import Control.Monad.Trans (lift)
import Data.Record.Label hiding (set)
@@ -27,6 +28,12 @@ type UID = Int
data One = One
data Many = Many
+class Fam phi => ERModel (phi :: * -> *) env | phi -> env, env -> phi where
+ relations :: TList phi env
+
+relationsForType :: (ERModel phi xs, TEq phi) => phi x -> TList phi (FilterIfTypeEq x xs)
+relationsForType ix = filterByType ix relations
+
data Relation multiplicity i1 i2 where
Rel :: String -- | The name
-> mult1 -- | The multiplicity
@@ -35,44 +42,31 @@ data Relation multiplicity i1 i2 where
-> Relation (mult1, mult2) i1 i2
data Nil (phi :: * -> *) a where Nil :: Nil phi a
-data To mult1 mult2 (from :: *) (phi :: * -> *) to where
- To :: Relation (mult1, mult2) to from -> To mult1 mult2 from phi to
-
-infixr 1 :&:
-data (:&:) (a :: (* -> *) -> * -> *)
- (b :: (* -> *) -> * -> *)
- (phi :: * -> *)
- (to :: *) :: * where
- (:&:) :: a phi to -> b phi to -> (:&:) a b phi to
-
-type family Relations (fam :: * -> *) entity :: (* -> *) -> * -> *
-class HasRelations phi ix | ix -> phi where -- TODO: relation should be on El.
- relations :: (Relations phi ix) phi ix
-
-type family Value (phi :: * -> *) (relation :: (* -> *) -> * -> *) :: *
-type instance Value phi Nil = ()
-type instance Value phi ((:&:) a b) = (Value phi a, Value phi b)
-type instance Value phi ((Many `To` One) ix) = RefList phi ix
-type instance Value phi ((One `To` One) ix) = Ref phi ix
-type instance Value phi ((One `To` Many) ix) = Ref phi ix
-type instance Value phi ((Many `To` Many) ix) = RefList phi ix
+data To mult1 mult2 l r where
+ Relation :: Relation (mult1, mult2) l r
+ -> Relation (mult2, mult1) r l
+ -> To mult1 mult2 l r
+mkRelation x y = let x1 = x y1
+ y1 = y x1
+ in Relation x1 y1
+
+-- type family Value (phi :: * -> *) (relation :: (* -> *) -> * -> *) :: *
+-- type instance Value phi Nil = ()
+-- type instance Value phi ((:&:) a b) = (Value phi a, Value phi b)
+-- type instance Value phi ((Many `To` One) ix) = RefList phi ix
+-- type instance Value phi ((One `To` One) ix) = Ref phi ix
+-- type instance Value phi ((One `To` Many) ix) = Ref phi ix
+-- type instance Value phi ((Many `To` Many) ix) = RefList phi ix
data Zero
data Suc a
-data RelIndex (t :: (* -> *) -> * -> *) ix where
- RZero :: RelIndex t Zero
- RSuc :: RelIndex t x -> RelIndex t (Suc x)
-
-type family Index ix (relation :: (* -> *) -> * -> *) :: ((* -> *) -> * -> *)
-type instance Index (RelIndex a Zero) ((:&:) a b) = a
-type instance Index (RelIndex t (Suc x)) ((:&:) a b) = Index (RelIndex t x) b
-
data Witnesses (phi :: * -> *) (env :: *) where
WNil :: Witnesses phi ()
WCons :: El phi ix => Witnesses phi env -> Witnesses phi (ix, env)
+
class (Monad (p phi), Fam phi) => Persist (p :: (* -> *) -> * -> *) (phi :: * -> *) where
pFetch :: phi ix -> Int -> p phi (Maybe ix)
-- pSave :: Regular a => TRef f a fam -> Int -> a -> p fam ()
View
26 Basil/Interface.hs
@@ -3,7 +3,7 @@
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
-module Basil.Interface (runBasil, find, new, rel, attr, Basil (), BasilState) where
+module Basil.Interface (runBasil, find, new, attr, Basil (), BasilState) where
import Basil.Core
import Basil.Cache
@@ -38,17 +38,17 @@ attr r@(Ref tix ix) at = do val <- findCache r
Just x -> return $ get at x
Nothing -> error "Not found in cache."
-new :: (Persist p phi, El phi ix, HasRelations phi ix)
- => ix -> Value phi (Relations phi ix) -> Basil phi env p (Ref phi ix)
-new i rels = do let tix = proof
- freshId <- getM freshVariable
- modM freshVariable (+1)
- let saveData = mod cached (M.insert (Fresh freshId) i)
- addToTainted = mod tainted (S.insert (Fresh freshId))
- modM cache (modCache (saveData . addToTainted) (index tix))
- -- TODO :save rels
- return (Ref tix (Fresh freshId))
+new :: (Persist p phi, El phi ix)
+ => ix -> {- relations -> -} Basil phi env p (Ref phi ix)
+new i {- rels-} = do let tix = proof
+ freshId <- getM freshVariable
+ modM freshVariable (+1)
+ let saveData = mod cached (M.insert (Fresh freshId) i)
+ addToTainted = mod tainted (S.insert (Fresh freshId))
+ modM cache (modCache (saveData . addToTainted) (index tix))
+ -- TODO :save rels
+ return (Ref tix (Fresh freshId))
-rel :: (Persist p phi, El phi ix, HasRelations phi ix) => Ref phi ix -> relIndex -> Basil phi env p (Value phi (Index relIndex (Relations phi ix)))
-rel = undefined
+-- rel :: (Persist p phi, El phi ix, HasRelations phi ix) => Ref phi ix -> relIndex -> Basil phi env p (Value phi (Index relIndex (Relations phi ix)))
+-- rel = undefined
View
18 Basil/TContainerList.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TypeOperators #-}
-- Unfortunately, this is needed for the nested type family application
{-# LANGUAGE UndecidableInstances #-}
@@ -11,7 +12,7 @@ module Basil.TContainerList where
data TList (phi :: * -> *) a where
TNil :: TList phi ()
- TCons :: phi x -> f x -> TList phi xs -> TList phi (f x, xs)
+ TCons :: phi x -> phi y -> f x y -> TList phi xs -> TList phi (f x y, xs)
data TBool a where
TTrue :: TBool True
@@ -25,19 +26,26 @@ type family TypeEq a b :: *
type family FilterIfTypeEq x xs :: *
type instance FilterIfTypeEq x () = ()
-type instance FilterIfTypeEq x (f y, ys) = AppendIfTrue (TypeEq x y) (f y) (FilterIfTypeEq x ys)
+type instance FilterIfTypeEq x (f y z, ys) = AppendIfTrue (TypeEq x y `Or` TypeEq x z) (f y z) (FilterIfTypeEq x ys)
type family AppendIfTrue bool x xs :: *
type instance AppendIfTrue True x xs = (x, xs)
type instance AppendIfTrue False x xs = xs
+type family Or x y :: *
+type instance Or True True = True
+type instance Or True False = True
+type instance Or False True = True
+type instance Or False False = False
+
class TEq phi where
tEq :: phi x -> phi y -> TBool (TypeEq x y)
+tOr :: TBool x -> TBool y -> TBool (Or x y)
+tOr = undefined
filterByType :: TEq phi => phi x -> TList phi xs -> TList phi (FilterIfTypeEq x xs)
filterByType x TNil = TNil
-filterByType x (TCons pr y ys) = case tEq x pr of
- TTrue -> TCons pr y (filterByType x ys)
+filterByType x (TCons pr1 pr2 y ys) = case tOr (tEq x pr1) (tEq x pr2) of
+ TTrue -> TCons pr1 pr2 y (filterByType x ys)
TFalse -> filterByType x ys -- x ys
-
View
73 CoreData2.hs
@@ -85,89 +85,28 @@ instance Persist Logger Blog where
pFetch tix ix = do log ix
return Nothing
-data To2 mult1 mult2 l r where
- Relation :: Relation (mult1, mult2) l r
- -> Relation (mult2, mult1) r l
- -> To2 mult1 mult2 l r
-mkRelation x y = let x1 = x y1
- y1 = y x1
- in Relation x1 y1
-
-
-data PointersToRelation phi ix where
- NoRelation :: PointersToRelation phi ix
- PointerL :: PointersToRelation phi ix
-
-class Fam phi => ERModel (phi :: * -> *) env | phi -> env, env -> phi where
- relations2 :: TList phi env
-
instance ERModel Blog ERRelationsBlog where
- relations2 = TCons User authorPosts $ TCons User authorComments $ TCons Post postComments TNil
+ relations = TCons Post User authorPosts $ TCons Comment User authorComments $ TCons Comment Post postComments TNil
-type ERRelationsBlog = ((One `To2` Many) Post User
- ,((One `To2` Many) Comment User
- ,((One `To2` Many) Comment Post
- ,()
- )))
+type ERRelationsBlog = ((One `To` Many) Post User
+ ,((One `To` Many) Comment User
+ ,((One `To` Many) Comment Post
+ ,()
+ )))
--relationsForIndex = undefined
-relationsForType :: (ERModel phi xs, TEq phi) => phi x -> TList phi (FilterIfTypeEq x xs)
-relationsForType ix = filterByType ix relations2
-
--- data ERRelIndexList a items env where
--- ERILNil :: ERRelIndexList a () env
--- ERILCons :: ERRelIndex phi m1 m2 from a env -> ERRelIndexList a items env -> ERRelIndexList a (To2 m1 m2 from a , items) env
---
--- data ERRelIndex (phi :: * -> *) m1 m2 from a env where
--- Left2 :: phi a -> ERRelIndex phi m1 m2 from a (To2 m1 m2 from a, b)
--- Suc2 :: ERRelIndex phi m1 m2 from a env -> ERRelIndex phi m1 m2 from a (b, env)
---
---
--- lookupRel :: ERRelIndex phi m1 m2 from a env -> env -> To2 m1 m2 from a
--- lookupRel (Left2 _) env = fst env
--- lookupRel (Suc2 x) env = lookupRel x (snd env)
---
--- lookupRel' :: (ERModel phi env) => ERRelIndex phi m1 m2 from a env -> To2 m1 m2 from a
--- lookupRel' ix = lookupRel ix (relations2)
---rel Zero2 = undefined
-
-
---lookup' :: nat -> ix -> env -> Index2 nat ix env
---lookup' Zero ix (a, _) = undefined
--newEntity :: (Relations Blog User relations) => User -> relations -> Ref User
--newEntity = undefined
---
---instance ERModel Blog where
--- relations = (authorPosts, (authorComments, (postComments, nil)))
-
---type instance Relations Blog User = ((Many `To` One) Post) :&: ((Many `To` One) Comment) :&: Nil
---type instance Relations Blog Comment = ((One `To` Many) User) :&: ((One `To` Many) Post) :&: Nil
---type instance Relations Blog Post = ((One `To` Many) User) :&: ((Many `To` One) Comment) :&: Nil
-
authorPosts = Rel "author" One User `mkRelation` Rel "posts" Many Post
authorComments = Rel "author" One User `mkRelation` Rel "comments" Many Comment
postComments = Rel "post" One Post `mkRelation` Rel "comments" Many Comment
---
- --
-
exampleUser = UserC "chris" "test" 24
examplePost = PostC "fipo" "my first post"
exampleComment = CommentC "a comment!"
---instance HasRelations Blog User where
--- relations = ((To $ snd authorPosts) :&: (To $ snd authorComments) :&: Nil)
---
---instance HasRelations Blog Comment where
--- relations = ((To $ fst authorComments) :&: (To $ fst postComments) :&: Nil)
---
---instance HasRelations Blog Post where
--- relations = ((To $ fst authorPosts) :&: (To $ snd postComments) :&: Nil)
-
---userPosts = RZero :: RelIndex ((Many `To` One) Post) (Zero)
---userComments = RSuc RZero :: RelIndex ((Many `To` One) Comment) (Suc Zero)
-- example flow
--

0 comments on commit 7cf60bc

Please sign in to comment.
Something went wrong with that request. Please try again.