git.iko.soy/project-m37
on master help sign in
project-m37/src/ProjectM37.hs
246 lines 8.8 kB history raw
1{-# OPTIONS_GHC -Wno-orphans #-}
3module ProjectM37
4 ( connect,
5 DbError (..),
6 DbConn,
7 run,
8 define,
9 insert,
10 query,
11 RelVar (..),
12 Rel,
13 rel,
14 difference,
15 project,
16 project',
17 join,
18 rename,
19 union,
20 group,
21 ungroup,
22 )
23where
25import Algebra.Lattice hiding (Join)
26import Control.Monad.Catch
27import Control.Monad.IO.Class
28import Data.Proxy
29import Data.Set (Set)
30import Data.Set qualified as S
31import Data.Text (Text)
32import Data.Text qualified as T
33import Data.Vector qualified as V
34import GHC.Generics
35import GHC.TypeLits
36import JRec (Tup, (:=) (..))
37import JRec qualified as Tup
38import ProjectM36.Atomable
39import ProjectM36.Base
40import ProjectM36.Client.Simple (ConnectionInfo, Db, DbConn, DbError, execute, simpleConnectProjectM36, withTransaction)
41import ProjectM36.Client.Simple qualified as M36
42import ProjectM36.Tuple (atomForAttributeName)
44deriving anyclass instance Exception DbError
46throwEither :: (MonadThrow m, Exception e) => m (Either e a) -> m a
47throwEither = (>>= either throwM pure)
49connect :: (MonadThrow m, MonadIO m) => ConnectionInfo -> m DbConn
50connect = throwEither . liftIO . simpleConnectProjectM36
52run :: (MonadThrow m, MonadIO m) => DbConn -> Db a -> m a
53run conn db = throwEither $ liftIO $ withTransaction conn db
55insert :: forall a fields. (RelVar a, Tup.FromNative (Rep a) fields, RelatableFields fields) => [a] -> Db ()
56insert aa =
57 execute $
58 Insert (relVar @a) $
59 MakeStaticRelation
60 (Attributes $ V.fromList $ attributes @fields @fields)
61 (RelationTupleSet $ fmap (relTuple . Tup.fromNative) aa)
63query :: forall fields. (RelatableFields fields) => Rel fields -> Db [Tup fields]
64query (Rel q) = do
65 Relation _ (RelationTupleSet tups) <- M36.query q
66 case traverse (extractFieldsFromTuple @fields @fields) tups of
67 Nothing -> liftIO $ throwM TupleMismatch
68 Just x -> pure x
70data TupleMismatch = TupleMismatch
71 deriving stock (Show)
72 deriving anyclass (Exception)
74newtype Rel fields = Rel (RelationalExprBase ())
76instance Lattice (Rel fields) where
77 Rel x \/ Rel y = Rel $ Union x y
79-- Rel x /\ Rel y = Rel $
81class (Generic a) => RelVar a where
82 relVar :: RelVarName
84rel :: forall a fields. (RelVar a, Tup.FromNative (Rep a) fields) => Rel fields
85rel = Rel $ RelationVariable (relVar @a) ()
87difference :: Rel fields -> Rel fields -> Rel fields
88difference (Rel x) (Rel y) = Rel $ Difference x y
90project :: forall names fields. (SymbolSet names) => Rel fields -> Rel (Projected names fields)
91project (Rel x) = Rel $ Project (AttributeNames $ symbolSet @names) x
93project' :: forall names fields. (SymbolSet names) => Rel fields -> Rel (DropFields names fields)
94project' (Rel x) = Rel $ Project (InvertedAttributeNames $ symbolSet @names) x
96join :: forall fields fields'. Rel fields -> Rel fields' -> Rel (fields ++ Difference fields' fields)
97join (Rel x) (Rel y) = Rel $ Join x y
99union :: Rel fields -> Rel fields -> Rel fields
100union (Rel x) (Rel y) = Rel $ Union x y
102rename :: forall renames fields. (RenameFields renames) => Rel fields -> Rel (Rename renames fields)
103rename (Rel x) = Rel $ Rename (renameFields @renames) x
105group ::
106 forall groupBy field fields.
107 (KnownSymbol field, SymbolSet groupBy) =>
108 Rel fields ->
109 Rel ((field := [Tup (Projected groupBy fields)]) ': DropFields groupBy fields)
110group (Rel x) = Rel $ Group (AttributeNames $ symbolSet @groupBy) (T.pack $ symbolVal @field Proxy) x
112ungroup ::
113 forall name fields.
114 (KnownSymbol name) =>
115 Rel fields ->
116 Rel (UnnestRelation name fields ++ DropField name fields)
117ungroup (Rel x) = Rel $ Ungroup (T.pack $ symbolVal @name Proxy) x
119define ::
120 forall record fields.
121 (RelatableFields fields, Tup.FromNative (Rep record) fields, RelVar record) =>
122 Db ()
123define = execute $ Define (relVar @record) (NakedAttributeExpr <$> attributes @fields @fields)
125class RenameFields fields where
126 renameFields :: Set (AttributeName, AttributeName)
128instance RenameFields '[] where
129 renameFields = S.empty
131instance (RenameFields renames, KnownSymbol old, KnownSymbol new) => RenameFields ('(old, new) ': renames) where
132 renameFields = S.insert (T.pack $ symbolVal @old Proxy, T.pack $ symbolVal @new Proxy) (renameFields @renames)
134type family Rename (renames :: [(Symbol, Symbol)]) fields where
135 Rename '[] fields = fields
136 Rename ('(old, new) ': renames) fields = Rename renames (RenameField old new fields)
138type family RenameField old new fields where
139 RenameField _ _ '[] = '[]
140 RenameField old new ((old := val) ': rest) = (new := val) ': rest
141 RenameField old new (field ': fields) = field ': RenameField old new fields
143type family Difference fields fields' where
144 Difference fields '[] = fields
145 Difference fields (name := _ ': fields') = Difference (DropField name fields) fields'
147type family (++) xs ys where
148 (x ': xs) ++ ys = x ': (xs ++ ys)
149 '[] ++ ys = ys
151class SymbolSet symbols where
152 symbolSet :: Set Text
154instance SymbolSet '[] where
155 symbolSet = S.empty
157instance (KnownSymbol sym, SymbolSet syms) => SymbolSet (sym ': syms) where
158 symbolSet = S.insert (T.pack $ symbolVal @sym Proxy) $ symbolSet @syms
160type family UnnestRelation name fields where
161 UnnestRelation name (name := [Tup fields'] ': _) = fields'
162 UnnestRelation name (_ ': fields) = UnnestRelation name fields
164type family Projected names fields where
165 Projected '[] _ = '[]
166 Projected (name ': names) fields = FindField name fields ': Projected names fields
168type family FindField name fields where
169 FindField name (name := val ': _) = name := val
170 FindField name (_ ': fields) = FindField name fields
171 FindField name '[] = TypeError ('Text "Field " :<>: 'Text name :<>: 'Text " not present.")
173type family DropField name fields where
174 DropField _ '[] = '[]
175 DropField name (name := val ': fields) = fields
176 DropField name (field ': fields) = field ': DropField name fields
178type family DropFields names fields where
179 DropFields '[] fields = fields
180 DropFields (name ': names) fields = DropFields names (DropField name fields)
182instance (RelatableFields fields) => BoundedJoinSemiLattice (Rel fields) where
183 bottom = Rel $ ExistingRelation $ Relation (tupAttributes @fields) (RelationTupleSet [])
185tupAttributes :: forall fields. (RelatableFields fields) => Attributes
186tupAttributes = Attributes $ V.fromList $ attributes @fields @fields
188relTuple :: forall fields. (RelatableFields fields) => Tup fields -> RelationTuple
189relTuple tup = RelationTuple (Attributes $ V.fromList (attributes @fields @fields)) (V.fromList (atoms @fields @fields tup))
191type RelatableFields fields = RelatableFields' fields fields
193class RelatableFields' allFields fieldsLeft where
194 attributes :: [Attribute]
195 atoms :: Tup allFields -> [Atom]
196 extractFieldsFromTuple :: RelationTuple -> Maybe (Tup fieldsLeft)
198instance RelatableFields' allFields '[] where
199 attributes = []
200 atoms _ = []
201 extractFieldsFromTuple _ = Just Tup.rnil
203instance
204 ( Relatable name value (IsSubrelation value),
205 RelatableFields' allFields fields,
206 Tup.Has name allFields value,
207 KnownSymbol name,
208 Tup.RemoveAccessTo name fields ~ fields,
209 KnownNat (1 + Tup.RecSize fields),
210 KnownNat (Tup.RecSize fields),
211 Tup.RecCopy fields fields ((name := value) ': fields)
212 ) =>
213 RelatableFields' allFields (name := value ': fields)
214 where
215 attributes = attribute @name @value : attributes @allFields @fields
216 atoms tup = atom @name @value (Tup.get @name tup) : atoms @allFields @fields tup
217 extractFieldsFromTuple tup = case atomForAttributeName (T.pack $ symbolVal @name Proxy) tup of
218 Left _ -> Nothing
219 Right val -> do
220 val' <- extractFieldFromAtom @name val
221 Tup.insert (Tup.FldProxy @name := val') <$> extractFieldsFromTuple @allFields @fields tup
223class (IsSubrelation value ~ subrelation) => Relatable name value (subrelation :: Bool) where
224 attribute :: Attribute
225 atom :: value -> Atom
226 extractFieldFromAtom :: Atom -> Maybe value
228instance (RelatableFields fields, KnownSymbol name) => Relatable name [Tup fields] 'True where
229 attribute =
230 Attribute (T.pack (symbolVal @name Proxy)) (RelationAtomType $ Attributes $ V.fromList $ attributes @fields @fields)
232 atom tup = RelationAtom (Relation (Attributes $ V.fromList $ attributes @fields @fields) (RelationTupleSet (relTuple <$> tup)))
234 extractFieldFromAtom (RelationAtom (Relation _ (RelationTupleSet tups))) =
235 traverse (extractFieldsFromTuple @fields) tups
236 extractFieldFromAtom _ = Nothing
238instance (IsSubrelation atom ~ 'False, Atomable atom, KnownSymbol name) => Relatable name atom 'False where
239 attribute = Attribute (T.pack (symbolVal @name Proxy)) (toAtomType @atom Proxy)
241 atom = toAtom
242 extractFieldFromAtom = Just . fromAtom
244type family IsSubrelation t :: Bool where
245 IsSubrelation [Tup _] = 'True
246 IsSubrelation _ = 'False