Add the DAG tagging operations to ca-store

src/CAStore/Command.hs

@@ -10,14 +10,6 @@ import CAStore.Program (Program, storeFile, unstoreFile, getFileLocation)
 import CAStore.Program.IO
 import CAStore.Program.IO.Text
 import CAStore.Program.Storage
-  ( registerFiles
-  , unregisterFiles
-  , generateId
-  , registerTags
-  , assignTags
-  , unassignTags
-  , showTags
-  )
 import CAStore.Type.Text
 import Control.Monad (forM_)
 import Control.Monad.IO.Class (liftIO)
@@ -47,3 +39,17 @@ runCommand (TagRemove sid ts) = do
   unassignTags sid ts
 runCommand (TagShow sid) = do
   showTags sid
+runCommand (TagSuperAdd sup subs) = do
+  registerTags $ sup : subs
+  relateTags $ flip (,) sup <$> subs
+runCommand (TagSubAdd sub sups) = do
+  registerTags $ sub : sups
+  relateTags $ (,) sub <$> sups
+runCommand (TagSuperRemove sup subs) = do
+  unrelateTags $ flip (,) sup <$> subs
+runCommand (TagSubRemove sub sups) = do
+  unrelateTags $ (,) sub <$> sups
+runCommand (TagSuperShow sup) = do
+  showRelationSuper sup
+runCommand (TagSubShow sub) = do
+  showRelationSub sub

src/CAStore/Command/Type.hs

@@ -13,6 +13,12 @@ data Command
   | TagAdd StoreId [Tag]
   | TagRemove StoreId [Tag]
   | TagShow StoreId
+  | TagSuperAdd Tag [Tag]
+  | TagSubAdd Tag [Tag]
+  | TagSuperRemove Tag [Tag]
+  | TagSubRemove Tag [Tag]
+  | TagSuperShow Tag
+  | TagSubShow Tag
   deriving (Show)
 
 parseCommand :: [String] -> Either Error Command
@@ -28,4 +34,16 @@ parseCommand ("tag":"remove":x:xs)
   = pure $ TagRemove (StoreId x) (Tag <$> xs)
 parseCommand ("tag":"show":x:[])
   = pure $ TagShow (StoreId x)
+parseCommand ("tag":"super":"add":x:xs)
+  = pure $ TagSuperAdd (Tag x) (Tag <$> xs)
+parseCommand ("tag":"sub":"add":x:xs)
+  = pure $ TagSubAdd (Tag x) (Tag <$> xs)
+parseCommand ("tag":"super":"remove":x:xs)
+  = pure $ TagSuperRemove (Tag x) (Tag <$> xs)
+parseCommand ("tag":"sub":"remove":x:xs)
+  = pure $ TagSubRemove (Tag x) (Tag <$> xs)
+parseCommand ("tag":"super":"show":x:[])
+  = pure $ TagSuperShow $ Tag x
+parseCommand ("tag":"sub":"show":x:[])
+  = pure $ TagSubShow $ Tag x
 parseCommand xs = Left $ ErrInvalidCommand xs

src/CAStore/Program/Storage.hs

@@ -10,6 +10,11 @@ module CAStore.Program.Storage
   , assignTags
   , unassignTags
   , showTags
+  , showTagsRaw
+  , relateTags
+  , unrelateTags
+  , showRelationSuper
+  , showRelationSub
   )
 where
 
@@ -32,6 +37,13 @@ initialise = do
     runSqlQ "CREATE TABLE tag (id INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT, name TEXT NOT NULL UNIQUE) STRICT"
   unless ("is_tagged_with" `elem` tables) $ do
     runSqlQ "CREATE TABLE is_tagged_with (file INTEGER NOT NULL REFERENCES file(id), tag INTEGER NOT NULL REFERENCES tag(id), PRIMARY KEY (file, tag)) STRICT"
+  unless ("dag_tag" `elem` tables) $ do
+    runSqlQ "CREATE TABLE dag_tag (prev INTEGER NOT NULL REFERENCES tag(id), next INTEGER NOT NULL REFERENCES tag(id), PRIMARY KEY(prev, next)) STRICT"
+  views <- getAllDefinedViews
+  unless ("path_tag" `elem` views) $ do
+    runSqlQ "CREATE VIEW path_tag(start, end) AS WITH current(start, end) AS (SELECT tag.id, tag.id FROM tag UNION ALL SELECT start, next FROM current INNER JOIN dag_tag ON end == prev) SELECT start, end FROM current"
+  unless ("file_tag" `elem` views) $ do
+    runSqlQ "CREATE VIEW file_tag(hash, tag) AS SELECT DISTINCT f.hash, t.name FROM file AS f INNER JOIN is_tagged_with AS r ON f.id == r.file INNER JOIN path_tag AS p ON r.tag == p.start INNER JOIN tag AS t ON t.id == p.end"
 
 generateId :: FilePath -> Program StoreId
 generateId = fmap (StoreId . show . hash @SHA256) . liftIO . readFile
@@ -85,10 +97,42 @@ unassignTags sid ts = do
 
 showTags :: StoreId -> Program ()
 showTags sid = do
+  runSql $ \h ->
+    fold h "SELECT tag FROM file_tag WHERE hash = ? ORDER BY tag ASC" (Only sid) ()
+      (\() (Only x) -> putStrLn x)
+
+showTagsRaw :: StoreId -> Program ()
+showTagsRaw sid = do
   runSql $ \h ->
     fold h "SELECT t.name FROM is_tagged_with AS r INNER JOIN file AS f ON r.file = f.id INNER JOIN tag AS t ON r.tag = t.id WHERE f.hash = ? ORDER BY t.name ASC" (Only sid) ()
       (\() (Only x) -> putStrLn x)
 
+relateTags :: [(Tag, Tag)] -> Program ()
+relateTags tts = do
+  runSqlQ "CREATE TEMP TABLE t_rel_tag (tag1 TEXT NOT NULL, tag2 TEXT NOT NULL) STRICT"
+  runSql $ \h -> executeMany h "INSERT INTO t_rel_tag (tag1, tag2) VALUES (?, ?)" tts
+  runSqlQ "INSERT OR IGNORE INTO dag_tag (prev, next) SELECT t1.id, t2.id FROM t_rel_tag AS r INNER JOIN tag AS t1 ON r.tag1 = t1.name INNER JOIN tag AS t2 ON r.tag2 = t2.name WHERE (t2.id, t1.id) NOT IN (SELECT * FROM path_tag)"
+  runSqlQ "DELETE FROM t_rel_tag"
+
+unrelateTags :: [(Tag, Tag)] -> Program ()
+unrelateTags tts = do
+  runSqlQ "CREATE TEMP TABLE t_unrel_tag (tag1 TEXT NOT NULL, tag2 TEXT NOT NULL) STRICT"
+  runSql $ \h -> executeMany h "INSERT INTO t_unrel_tag (tag1, tag2) VALUES (?, ?)" tts
+  runSqlQ "DELETE FROM dag_tag (prev, next) WHERE (prev, next) IN (SELECT t1.id, t2.id FROM t_unrel_tag AS r INNER JOIN tag AS t1 ON r.tag1 = t1.name INNER JOIN tag AS t2 ON r.tag2 = t2.name)"
+  runSqlQ "DELETE FROM t_unrel_tag"
+
+showRelationSuper :: Tag -> Program ()
+showRelationSuper t = do
+  runSql $ \h ->
+    fold h "SELECT t2.name FROM dag_tag AS r INNER JOIN tag AS t1 ON r.prev = t1.id INNER JOIN tag AS t2 ON r.next = t2.id WHERE t1.name = ? ORDER By t2.name ASC" (Only t) ()
+      (\() (Only x) -> putStrLn x)
+
+showRelationSub :: Tag -> Program ()
+showRelationSub t = do
+  runSql $ \h ->
+    fold h "SELECT t1.name FROM dag_tag AS r INNER JOIN tag AS t1 ON r.prev = t1.id INNER JOIN tag AS t2 ON r.next = t2.id WHERE t2.name = ? ORDER By t1.name ASC" (Only t) ()
+      (\() (Only x) -> putStrLn x)
+
 runSql :: (Connection -> IO a) -> Program a
 runSql f = getConnectionHandle >>= (Program . liftIO . f)
 
@@ -105,3 +149,8 @@ getAllDefinedTables :: Program [String]
 getAllDefinedTables
   = getConnectionHandle >>= \h ->
       liftIO $ fmap fromOnly <$> query_ h "SELECT name FROM SQLITE_SCHEMA where type = 'table' ORDER BY name"
+
+getAllDefinedViews :: Program [String]
+getAllDefinedViews
+  = getConnectionHandle >>= \h ->
+      liftIO $ fmap fromOnly <$> query_ h "SELECT name FROM SQLITE_SCHEMA where type = 'view' ORDER BY name"