mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-22 07:48:10 +03:00
SqliteCodebase.putTerm and helpers
This commit is contained in:
Arya Irani
parent
258acb906c
commit
7ef216a87c
@ -48,6 +48,7 @@ import qualified U.Util.Hash as H
|
||||
import qualified U.Util.Monoid as Monoid
|
||||
import U.Util.Serialization (Get, getFromBytes)
|
||||
import qualified U.Util.Serialization as S
|
||||
import Data.Maybe (isJust)
|
||||
|
||||
type Err m = MonadError Error m
|
||||
|
||||
@ -117,6 +118,9 @@ hashToObjectId h = do
|
||||
hashId <- MaybeT $ Q.loadHashId . H.toBase32Hex $ h
|
||||
liftQ $ Q.objectIdByPrimaryHashId hashId
|
||||
|
||||
objectExistsForHash :: EDB m => H.Hash -> m Bool
|
||||
objectExistsForHash h = isJust <$> runMaybeT (hashToObjectId h)
|
||||
|
||||
loadHashByObjectId :: EDB m => Db.ObjectId -> m H.Hash
|
||||
loadHashByObjectId = fmap H.fromBase32Hex . liftQ . Q.loadPrimaryHashByObjectId
|
||||
|
||||
@ -194,11 +198,11 @@ loadDeclByReference (C.Reference.Id h i) = do
|
||||
substTypeRef = bimap substText (fmap substHash)
|
||||
pure (C.Decl.DataDeclaration dt m b (C.Type.rmap substTypeRef <$> ct)) -- lens might be nice here
|
||||
|
||||
saveTerm :: DB m => C.Reference.Id -> C.Term Symbol -> C.Term.Type Symbol -> m ()
|
||||
saveTerm = error "todo"
|
||||
saveTermComponent :: H.Hash -> [(C.Term Symbol, C.Term.Type Symbol)] -> m ()
|
||||
saveTermComponent = error "todo"
|
||||
|
||||
saveDecl :: DB m => C.Reference.Id -> C.Decl Symbol -> m ()
|
||||
saveDecl = error "todo"
|
||||
saveDeclComponent :: DB m => H.Hash -> [C.Decl Symbol] -> m ()
|
||||
saveDeclComponent = error "todo"
|
||||
|
||||
listWatches :: DB m => WatchKind -> m [C.Reference.Id]
|
||||
listWatches = error "todo"
|
||||
@ -224,7 +228,7 @@ componentReferencesByPrefix ot b32prefix pos = do
|
||||
let test = maybe (const True) (==) pos
|
||||
let filterComponent l = [x | x@(C.Reference.Id _ pos) <- l, test pos]
|
||||
fmap Monoid.fromMaybe . runMaybeT $
|
||||
join <$> traverse (fmap filterComponent . componentByObjectIdS) oIds
|
||||
join <$> traverse (fmap filterComponent . componentByObjectId) oIds
|
||||
|
||||
termReferencesByPrefix :: EDB m => Text -> Maybe Word64 -> m [C.Reference.Id]
|
||||
termReferencesByPrefix t w =
|
||||
@ -270,15 +274,8 @@ declReferentsByPrefix b32prefix pos cid = do
|
||||
-- (localIds, C.Decl.DataDeclaration dt m b ct) <-
|
||||
-- hashToObjectId h >>= liftQ . Q.loadObjectById >>= decodeDeclElement i
|
||||
|
||||
-- consider getting rid of this function, or making it produce [S.Reference.Id]
|
||||
componentByObjectId :: EDB m => Db.ObjectId -> m [C.Reference.Id]
|
||||
componentByObjectId :: EDB m => Db.ObjectId -> m [S.Reference.Id]
|
||||
componentByObjectId id = do
|
||||
len <- (liftQ . Q.loadObjectById) id >>= decodeComponentLengthOnly
|
||||
hash <- loadHashByObjectId id
|
||||
pure [C.Reference.Id hash i | i <- [0 .. len - 1]]
|
||||
|
||||
componentByObjectIdS :: EDB m => Db.ObjectId -> m [S.Reference.Id]
|
||||
componentByObjectIdS id = do
|
||||
len <- (liftQ . Q.loadObjectById) id >>= decodeComponentLengthOnly
|
||||
pure [C.Reference.Id id i | i <- [0 .. len - 1]]
|
||||
|
||||
|
||||
@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
@ -6,11 +7,13 @@ module Unison.Codebase.SqliteCodebase where
|
||||
|
||||
-- initCodebase :: Branch.Cache IO -> FilePath -> IO (Codebase IO Symbol Ann)
|
||||
|
||||
import Control.Concurrent.STM
|
||||
import Control.Monad ((>=>))
|
||||
import Control.Monad (filterM, (>=>))
|
||||
import Control.Monad.Except (ExceptT, runExceptT)
|
||||
import Control.Monad.Extra (ifM, unlessM)
|
||||
import Control.Monad.Reader (ReaderT (runReaderT))
|
||||
import Control.Monad.Trans.Maybe (MaybeT)
|
||||
import Data.Bifunctor (Bifunctor (first), second)
|
||||
import Data.Foldable (traverse_)
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Set (Set)
|
||||
@ -40,7 +43,7 @@ import qualified Unison.ConstructorType as CT
|
||||
import Unison.DataDeclaration (Decl)
|
||||
import Unison.Hash (Hash)
|
||||
import Unison.Parser (Ann)
|
||||
import Unison.Prelude (MaybeT (runMaybeT), fromMaybe)
|
||||
import Unison.Prelude (MaybeT (runMaybeT), fromMaybe, traceM)
|
||||
import Unison.Reference (Reference)
|
||||
import qualified Unison.Reference as Reference
|
||||
import qualified Unison.Referent as Referent
|
||||
@ -49,9 +52,13 @@ import qualified Unison.ShortHash as SH
|
||||
import qualified Unison.ShortHash as ShortHash
|
||||
import Unison.Symbol (Symbol)
|
||||
import Unison.Term (Term)
|
||||
import qualified Unison.Term as Term
|
||||
import Unison.Type (Type)
|
||||
import qualified Unison.Type as Type
|
||||
import qualified Unison.UnisonFile as UF
|
||||
import UnliftIO (catchIO)
|
||||
import UnliftIO (MonadIO, catchIO)
|
||||
import UnliftIO.STM
|
||||
import Data.Foldable (Foldable(toList))
|
||||
|
||||
-- 1) buffer up the component
|
||||
-- 2) in the event that the component is complete, then what?
|
||||
@ -70,6 +77,7 @@ data BufferEntry a = BufferEntry
|
||||
beMissingDependencies :: Set Hash,
|
||||
beWaitingDependents :: Set Hash
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
type TermBufferEntry = BufferEntry (Term Symbol Ann, Type Symbol Ann)
|
||||
|
||||
@ -79,7 +87,7 @@ sqliteCodebase :: CodebasePath -> IO (IO (), Codebase1.Codebase IO Symbol Ann)
|
||||
sqliteCodebase root = do
|
||||
conn :: Sqlite.Connection <- Sqlite.open $ root </> "v2" </> "unison.sqlite3"
|
||||
termBuffer :: TVar (Map Hash TermBufferEntry) <- newTVarIO Map.empty
|
||||
_declBuffer :: TVar (Map Hash DeclBufferEntry) <- newTVarIO Map.empty
|
||||
declBuffer :: TVar (Map Hash DeclBufferEntry) <- newTVarIO Map.empty
|
||||
let getRootBranch :: IO (Either Codebase1.GetRootBranchError (Branch IO))
|
||||
putRootBranch :: Branch IO -> IO ()
|
||||
rootBranchUpdates :: IO (IO (), IO (Set Branch.Hash))
|
||||
@ -110,7 +118,7 @@ sqliteCodebase root = do
|
||||
error $
|
||||
"I don't know about the builtin type ##"
|
||||
++ show t
|
||||
++ ", but I need to know whether it's Data or Effect in order to construct a V1 TermLink for a constructor."
|
||||
++ ", but I've been asked for it's ConstructorType."
|
||||
in pure . fromMaybe err $
|
||||
Map.lookup (Reference.Builtin t) Builtins.builtinConstructorType
|
||||
C.Reference.ReferenceDerived i -> getDeclTypeById i
|
||||
@ -131,12 +139,32 @@ sqliteCodebase root = do
|
||||
Cv.decl2to1 h1 getCycleLen decl2
|
||||
|
||||
putTerm :: Reference.Id -> Term Symbol Ann -> Type Symbol Ann -> IO ()
|
||||
putTerm _r@(Reference.Id h _i _n) = error
|
||||
"todo"
|
||||
updateBufferEntry
|
||||
termBuffer
|
||||
h
|
||||
$ \_be -> error "todo"
|
||||
putTerm _r@(Reference.Id h@(Cv.hash1to2 -> h2) i n) tm tp =
|
||||
runDB conn $
|
||||
unlessM
|
||||
(Ops.objectExistsForHash h2)
|
||||
( withBuffer termBuffer h \(BufferEntry size comp missing waiting) -> do
|
||||
let size' = Just n
|
||||
pure $
|
||||
ifM
|
||||
((==) <$> size <*> size')
|
||||
(pure ())
|
||||
(error $ "targetSize for term " ++ show h ++ " was " ++ show size ++ ", but now " ++ show size')
|
||||
let comp' = Map.insert i (tm, tp) comp
|
||||
missingTerms' <-
|
||||
filterM
|
||||
(fmap not . Ops.objectExistsForHash . Cv.hash1to2)
|
||||
[h | Reference.Derived h _i _n <- Set.toList $ Term.termDependencies tm]
|
||||
missingTypes' <-
|
||||
filterM (fmap not . Ops.objectExistsForHash . Cv.hash1to2) $
|
||||
[h | Reference.Derived h _i _n <- Set.toList $ Term.typeDependencies tm]
|
||||
++ [h | Reference.Derived h _i _n <- Set.toList $ Type.dependencies tp]
|
||||
let missing' = missing <> Set.fromList (missingTerms' <> missingTypes')
|
||||
traverse (addBufferDependent h termBuffer) missingTerms'
|
||||
traverse (addBufferDependent h declBuffer) missingTypes'
|
||||
putBuffer termBuffer h (BufferEntry size' comp' missing' waiting)
|
||||
tryFlushTermBuffer h
|
||||
)
|
||||
|
||||
-- data BufferEntry a = BufferEntry
|
||||
-- { -- First, you are waiting for the cycle to fill up with all elements
|
||||
@ -148,17 +176,46 @@ sqliteCodebase root = do
|
||||
-- beMissingDependencies :: Set Hash,
|
||||
-- beWaitingDependents :: Set Hash
|
||||
-- }
|
||||
putBuffer :: (MonadIO m, Show a) => TVar (Map Hash (BufferEntry a)) -> Hash -> BufferEntry a -> m ()
|
||||
putBuffer tv h e = do
|
||||
traceM $ "putBuffer " ++ show h ++ " " ++ show e
|
||||
atomically $ modifyTVar tv (Map.insert h e)
|
||||
|
||||
updateBufferEntry ::
|
||||
TVar (Map Hash (BufferEntry a)) ->
|
||||
Hash ->
|
||||
-- this signature may need to change
|
||||
(BufferEntry a -> (BufferEntry a, b)) ->
|
||||
IO b
|
||||
updateBufferEntry = error "todo"
|
||||
withBuffer :: MonadIO m => TVar (Map Hash (BufferEntry a)) -> Hash -> (BufferEntry a -> m b) -> m b
|
||||
withBuffer tv h f =
|
||||
Map.lookup h <$> readTVarIO tv >>= \case
|
||||
Just e -> f e
|
||||
Nothing -> f (BufferEntry Nothing Map.empty Set.empty Set.empty)
|
||||
|
||||
removeBuffer :: MonadIO m => TVar (Map Hash (BufferEntry a)) -> Hash -> m ()
|
||||
removeBuffer tv h = atomically $ modifyTVar tv (Map.delete h)
|
||||
|
||||
addBufferDependent :: (MonadIO m, Show a) => Hash -> TVar (Map Hash (BufferEntry a)) -> Hash -> m ()
|
||||
addBufferDependent dependent tv dependency = withBuffer tv dependency \be -> do
|
||||
putBuffer tv dependency be {beWaitingDependents = Set.insert dependent $ beWaitingDependents be}
|
||||
tryFlushTermBuffer :: EDB m => Hash -> m ()
|
||||
tryFlushTermBuffer h@(Cv.hash1to2 -> h2) =
|
||||
-- skip if it has already been flushed
|
||||
unlessM (Ops.objectExistsForHash h2) $
|
||||
withBuffer
|
||||
termBuffer
|
||||
h
|
||||
\(BufferEntry size comp (Set.toList -> missing) waiting) -> do
|
||||
missing' <-
|
||||
filterM
|
||||
(fmap not . Ops.objectExistsForHash . Cv.hash1to2)
|
||||
missing
|
||||
if null missing' && size == Just (fromIntegral (length comp))
|
||||
then do
|
||||
Ops.saveTermComponent h2 $
|
||||
first (Cv.term1to2 h) . second Cv.ttype1to2 <$> toList comp
|
||||
removeBuffer termBuffer h
|
||||
traverse_ tryFlushTermBuffer waiting
|
||||
else -- update
|
||||
|
||||
putBuffer termBuffer h $
|
||||
BufferEntry size comp (Set.fromList missing') waiting
|
||||
|
||||
_tryWriteBuffer :: Hash -> TVar (Map Hash (BufferEntry a)) -> IO ()
|
||||
_tryWriteBuffer _h = error "todo" --do
|
||||
-- isMissingDependencies <- allM
|
||||
putTypeDeclaration :: Reference.Id -> Decl Symbol Ann -> IO ()
|
||||
putTypeDeclaration = error "todo"
|
||||
|
||||
@ -43,6 +43,14 @@ decltype1to2 = \case
|
||||
CT.Data -> V2.Decl.Data
|
||||
CT.Effect -> V2.Decl.Effect
|
||||
|
||||
term1to2 :: Hash -> V1.Term.Term V1.Symbol Ann -> V2.Term.Term V2.Symbol
|
||||
term1to2 h =
|
||||
V2.ABT.transform (termF1to2 h)
|
||||
. V2.ABT.vmap symbol1to2
|
||||
. V2.ABT.amap (const ())
|
||||
. abt1to2
|
||||
where termF1to2 = undefined
|
||||
|
||||
term2to1 :: forall m. Monad m => Hash -> (Hash -> m V1.Reference.Size) -> (V2.Reference -> m CT.ConstructorType) -> V2.Term.Term V2.Symbol -> m (V1.Term.Term V1.Symbol Ann)
|
||||
term2to1 h lookupSize lookupCT tm =
|
||||
V1.ABT.transformM (termF2to1 h lookupSize lookupCT)
|
||||
|
||||
@ -123,6 +123,11 @@ fromText t = either (const Nothing) Just $
|
||||
cidPart' = Text.takeWhileEnd (/= '#') t
|
||||
cidPart = Text.drop 1 cidPart'
|
||||
|
||||
fold :: (r -> a) -> (r -> Int -> ConstructorType -> a) -> Referent' r -> a
|
||||
fold fr fc = \case
|
||||
Ref' r -> fr r
|
||||
Con' r i ct -> fc r i ct
|
||||
|
||||
instance Hashable Referent where
|
||||
tokens (Ref r) = [H.Tag 0] ++ H.tokens r
|
||||
tokens (Con r i dt) = [H.Tag 2] ++ H.tokens r ++ H.tokens (fromIntegral i :: Word64) ++ H.tokens dt
|
||||
|
||||
@ -822,6 +822,21 @@ unReqOrCtor _ = Nothing
|
||||
dependencies :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set Reference
|
||||
dependencies t = Set.map (LD.fold id Referent.toReference) (labeledDependencies t)
|
||||
|
||||
termDependencies :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set Reference
|
||||
termDependencies =
|
||||
Set.fromList
|
||||
. mapMaybe
|
||||
( LD.fold
|
||||
(\_typeRef -> Nothing)
|
||||
( Referent.fold
|
||||
(\termRef -> Just termRef)
|
||||
(\_typeConRef _i _ct -> Nothing)
|
||||
)
|
||||
)
|
||||
. toList
|
||||
. labeledDependencies
|
||||
|
||||
-- gets types from annotations and constructors
|
||||
typeDependencies :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set Reference
|
||||
typeDependencies =
|
||||
Set.fromList . mapMaybe (LD.fold Just (const Nothing)) . toList . labeledDependencies
|
||||
|
||||
Loading…
Reference in New Issue
Block a user