filled in more of IO-based Codebase impl

parser-typechecker/src/Unison/Codebase.hs

@@ -1,7 +1,11 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts, OverloadedStrings #-}
+
 module Unison.Codebase where
 
-import Control.Monad (when)
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Control.Monad.Except (runExceptT)
+import Control.Monad.Error.Class (MonadError, throwError)
+import Control.Monad (when, filterM)
 import Data.Foldable (traverse_)
 import Data.List (isPrefixOf, isSuffixOf, partition)
 import Data.Text (Text)
@@ -12,13 +16,16 @@ import qualified Unison.DataDeclaration as DD
 import qualified Unison.Hash as Hash
 import qualified Unison.Codebase.Branch as Branch
 import Unison.Reference (Reference)
--- import qualified Unison.Codebase.Serialization.V0 as V0
+import qualified Unison.Codebase.Serialization.V0 as V0
 import Unison.Codebase.Code (Code)
 import Unison.Codebase.Name (Name)
 import Unison.Codebase.Branch (Branch)
-import System.FilePath (FilePath) --, (</>))
+import System.FilePath (FilePath, (</>))
 import Unison.Result (Result, Note)
 import Unison.UnisonFile (UnisonFile')
+import qualified Data.ByteString as BS
+import qualified Data.Bytes.Get as Get
+import qualified Data.Bytes.Put as Put
 
 type DataDeclaration v a = DD.DataDeclaration' v a
 type Term v a = Term.AnnotatedTerm v a
@@ -41,6 +48,27 @@ data Session m v a
             -- and the results of parsing / typechecking.
             , watch :: FilePath -> m (FilePath, Text, Result (Note v a) (UnisonFile' v a)) }
 
+data Err = InvalidBranchFile FilePath String deriving Show
+
+branchFromFile :: (MonadIO m, MonadError Err m) => FilePath -> m Branch
+branchFromFile ubf = do
+  bytes <- liftIO $ BS.readFile ubf
+  case Get.runGetS V0.getBranch bytes of
+    Left err -> throwError $ InvalidBranchFile ubf err
+    Right branch -> pure branch
+
+branchToFile :: FilePath -> Branch -> IO ()
+branchToFile ubf b =
+  BS.writeFile ubf (Put.runPutS (V0.putBranch b))
+
+branchFromFile' :: FilePath -> IO (Maybe Branch)
+branchFromFile' ubf = go =<< runExceptT (branchFromFile ubf)
+  where
+    go (Left e) = do
+      liftIO $ putStrLn (show e)
+      pure Nothing
+    go (Right b) = pure (Just b)
+
 codebase1 :: FilePath -> Codebase IO v a
 codebase1 path = let
   filesInPathMatchingSuffix path suffix =
@@ -49,16 +77,19 @@ codebase1 path = let
   putCode _code = error "todo"
   branches = error "todo"
   getBranch _name = error "todo"
-  overwriteBranch _name branch = do
+  -- given a name and a branch, serialize given branch with
+  overwriteBranch name branch = do
     let newBranchHash = Hash.base58 . Branch.toHash $ branch
     (match, nonmatch) <- partition (Text.unpack newBranchHash `isPrefixOf`) <$>
                           filesInPathMatchingSuffix path ".ubf"
+    let
+      isBefore :: Branch -> FilePath -> IO Bool
+      isBefore b ubf = maybe False (`Branch.before` b) <$> branchFromFile' ubf
     -- delete any existing .ubf files
-    traverse_ removeFile nonmatch
+    traverse_ removeFile =<< filterM (isBefore branch) nonmatch
     -- save new branch data under <base58>.ubf
     when (null match) $
-      -- V0.putBranch (path </> Text.unpack newBranchHash <> ".ubf") branch
-      error "todo"
+      branchToFile (path </> Text.unpack name </> Text.unpack newBranchHash <> ".ubf") branch
 
   mergeBranch name branch = do
     target <- getBranch name

parser-typechecker/src/Unison/Codebase/Branch.hs

@@ -96,6 +96,9 @@ instance Monoid Branch0 where
   mempty = Branch0 R.empty R.empty R.empty R.empty
   mappend = (<>)
 
+before :: Branch -> Branch -> Bool
+before b b2 = unbranch b `Causal.before` unbranch b2
+
 -- Use e.g. by `conflicts termNamespace branch`
 conflicts :: Ord a => (Branch0 -> Relation a b) -> Branch -> Map a (Set b)
 conflicts f = conflicts' . f . Causal.head . unbranch where