Merge pull request #1895 from unisonweb/wip/codebase2-cleanup

v2 (sqlite) codebase format

.gitignore

@@ -7,3 +7,6 @@ scratch.u
 # Stack
 .stack-work
 stack.yaml.lock
+
+# GHC
+*.hie

codebase2/LICENSE

@@ -0,0 +1,20 @@
+Copyright (c) 2020 Unison Computing, PBC
+
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+The above copyright notice and this permission notice shall be included
+in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

codebase2/codebase-sqlite/U/Codebase/Sqlite/Branch/Diff.hs

@@ -0,0 +1,69 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module U.Codebase.Sqlite.Branch.Diff where
+
+import qualified Data.List as List
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Set (Set)
+import U.Codebase.Reference (Reference')
+import U.Codebase.Referent (Referent')
+import U.Codebase.Sqlite.DbId (BranchObjectId, CausalHashId, ObjectId, PatchObjectId, TextId)
+import U.Codebase.Sqlite.LocalIds (LocalBranchChildId, LocalDefnId, LocalPatchObjectId, LocalTextId)
+import qualified U.Util.Map as Map
+import Data.Bifunctor (Bifunctor(bimap))
+import qualified Data.Set as Set
+
+type LocalDiff = Diff' LocalTextId LocalDefnId LocalPatchObjectId LocalBranchChildId
+type Diff = Diff' TextId ObjectId PatchObjectId (BranchObjectId, CausalHashId)
+
+data DefinitionOp' r = RemoveDef | AddDefWithMetadata (Set r) | AlterDefMetadata (AddRemove r) deriving Show
+data PatchOp' p = PatchRemove | PatchAddReplace p deriving (Functor, Show)
+data ChildOp' c = ChildRemove | ChildAddReplace c deriving (Functor, Show)
+type AddRemove a = Map a Bool
+
+type LocalDefinitionOp = DefinitionOp' (Metadata LocalTextId LocalDefnId)
+type LocalPatchOp = PatchOp' LocalPatchObjectId
+type LocalChildOp = ChildOp' LocalBranchChildId
+
+type DefinitionOp = DefinitionOp' (Metadata TextId ObjectId)
+type PatchOp = PatchOp' PatchObjectId
+type ChildOp = ChildOp' (BranchObjectId, CausalHashId)
+
+addsRemoves :: AddRemove a -> ([a], [a])
+addsRemoves map = (adds, removes)
+  where
+    (fmap fst -> adds, fmap fst -> removes) = List.partition snd (Map.toList map)
+
+type Referent'' t h = Referent' (Reference' t h) (Reference' t h)
+
+data Diff' t h p c = Diff
+  { terms :: Map t (Map (Referent'' t h) (DefinitionOp' (Metadata t h))),
+    types :: Map t (Map (Reference' t h) (DefinitionOp' (Metadata t h))),
+    patches :: Map t (PatchOp' p),
+    children :: Map t (ChildOp' c)
+  }
+  deriving Show
+
+type Metadata t h = Reference' t h
+
+quadmap :: (Ord t', Ord h') => (t -> t') -> (h -> h') -> (p -> p') -> (c -> c') -> Diff' t h p c -> Diff' t' h' p' c'
+quadmap ft fh fp fc (Diff terms types patches children) =
+  Diff
+    (Map.bimap ft (Map.bimap doReferent doDefnOp) terms)
+    (Map.bimap ft (Map.bimap doReference doDefnOp) types)
+    (Map.bimap ft doPatchOp patches)
+    (Map.bimap ft doChildOp children)
+  where
+    doReferent = bimap doReference doReference
+    doReference = bimap ft fh
+    doDefnOp = \case
+      RemoveDef -> RemoveDef
+      AddDefWithMetadata rs -> AddDefWithMetadata (Set.map doReference rs)
+      AlterDefMetadata ar -> AlterDefMetadata (Map.mapKeys doReference ar)
+    doPatchOp = fmap fp
+    doChildOp = fmap fc

codebase2/codebase-sqlite/U/Codebase/Sqlite/Branch/Format.hs

@@ -0,0 +1,20 @@
+module U.Codebase.Sqlite.Branch.Format where
+
+import Data.Vector (Vector)
+import U.Codebase.Sqlite.Branch.Diff (LocalDiff)
+import U.Codebase.Sqlite.Branch.Full (LocalBranch)
+import U.Codebase.Sqlite.DbId (CausalHashId, BranchObjectId, ObjectId, PatchObjectId, TextId)
+
+-- |you can use the exact same `BranchLocalIds` when converting between `Full` and `Diff`
+data BranchFormat
+  = Full BranchLocalIds LocalBranch
+  | Diff BranchObjectId BranchLocalIds LocalDiff
+  deriving Show
+
+data BranchLocalIds = LocalIds
+  { branchTextLookup :: Vector TextId,
+    branchDefnLookup :: Vector ObjectId,
+    branchPatchLookup :: Vector PatchObjectId,
+    branchChildLookup :: Vector (BranchObjectId, CausalHashId)
+  }
+  deriving Show

codebase2/codebase-sqlite/U/Codebase/Sqlite/Branch/Full.hs

@@ -0,0 +1,47 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module U.Codebase.Sqlite.Branch.Full where
+
+import Data.Map (Map)
+import Data.Set (Set)
+import U.Codebase.Reference (Reference')
+import U.Codebase.Referent (Referent')
+import U.Codebase.Sqlite.DbId (BranchObjectId, CausalHashId, ObjectId, PatchObjectId, TextId)
+import U.Codebase.Sqlite.LocalIds (LocalBranchChildId, LocalDefnId, LocalPatchObjectId, LocalTextId)
+import qualified U.Util.Map as Map
+import Data.Bifunctor (Bifunctor(bimap))
+import qualified Data.Set as Set
+
+type LocalBranch = Branch' LocalTextId LocalDefnId LocalPatchObjectId LocalBranchChildId
+
+type DbBranch = Branch' TextId ObjectId PatchObjectId (BranchObjectId, CausalHashId)
+
+type Referent'' t h = Referent' (Reference' t h) (Reference' t h)
+
+data Branch' t h p c = Branch
+  { terms :: Map t (Map (Referent'' t h) (MetadataSetFormat' t h)),
+    types :: Map t (Map (Reference' t h) (MetadataSetFormat' t h)),
+    patches :: Map t p,
+    children :: Map t c
+  }
+  deriving Show
+
+type LocalMetadataSet = MetadataSetFormat' LocalTextId LocalDefnId
+
+type DbMetadataSet = MetadataSetFormat' TextId ObjectId
+
+data MetadataSetFormat' t h = Inline (Set (Reference' t h))
+  deriving Show
+
+quadmap :: forall t h p c t' h' p' c'. (Ord t', Ord h') => (t -> t') -> (h -> h') -> (p -> p') -> (c -> c') -> Branch' t h p c -> Branch' t' h' p' c'
+quadmap ft fh fp fc (Branch terms types patches children) =
+  Branch
+    (Map.bimap ft doTerms terms)
+    (Map.bimap ft doTypes types)
+    (Map.bimap ft fp patches)
+    (Map.bimap ft fc children)
+  where
+    doTerms = Map.bimap (bimap (bimap ft fh) (bimap ft fh)) doMetadata
+    doTypes = Map.bimap (bimap ft fh) doMetadata
+    doMetadata (Inline s) = Inline . Set.map (bimap ft fh) $ s

codebase2/codebase-sqlite/U/Codebase/Sqlite/DbId.hs

@@ -0,0 +1,50 @@
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module U.Codebase.Sqlite.DbId where
+
+import Data.Bits (Bits)
+import Data.Word (Word64)
+import Database.SQLite.Simple.FromField
+import Database.SQLite.Simple.ToField
+import U.Util.Hashable (Hashable)
+
+newtype ObjectId = ObjectId Word64 deriving (Eq, Ord, Show)
+  deriving (Num, Real, Enum, Integral, Bits, Hashable, FromField, ToField) via Word64
+
+newtype TextId = TextId Word64 deriving (Eq, Ord, Show)
+  deriving (Num, Real, Enum, Integral, Bits, Hashable, FromField, ToField) via Word64
+
+newtype HashId = HashId Word64 deriving (Eq, Ord, Show)
+  deriving (Num, Real, Enum, Integral, Bits, Hashable, FromField, ToField) via Word64
+
+newtype PatchObjectId = PatchObjectId { unPatchObjectId :: ObjectId } deriving (Eq, Ord)
+  deriving (Num, Real, Enum, Integral, Bits, Hashable, FromField, ToField) via ObjectId
+
+newtype BranchObjectId = BranchObjectId { unBranchObjectId :: ObjectId } deriving (Eq, Ord)
+  deriving (Num, Real, Enum, Integral, Bits, Hashable, FromField, ToField) via ObjectId
+
+newtype BranchHashId = BranchHashId { unBranchHashId :: HashId } deriving (Eq, Ord)
+  deriving (Num, Real, Enum, Integral, Bits, Hashable, FromField, ToField) via HashId
+
+newtype CausalHashId = CausalHashId { unCausalHashId :: HashId } deriving (Eq, Ord)
+  deriving (Num, Real, Enum, Integral, Bits, Hashable, FromField, ToField) via HashId
+
+newtype SchemaVersion = SchemaVersion Word64 deriving (Eq, Ord, Show)
+  deriving (Num, Real, Enum, Integral, Bits, Hashable, FromField, ToField) via Word64
+
+instance Show PatchObjectId where
+  show h = "PatchObjectId (" ++ show (unPatchObjectId h) ++ ")"
+
+instance Show BranchObjectId where
+  show h = "BranchObjectId (" ++ show (unBranchObjectId h) ++ ")"
+
+instance Show BranchHashId where
+  show h = "BranchHashId (" ++ show (unBranchHashId h) ++ ")"
+
+instance Show CausalHashId where
+  show h = "CausalHashId (" ++ show (unCausalHashId h) ++ ")"

codebase2/codebase-sqlite/U/Codebase/Sqlite/Decl/Format.hs

@@ -0,0 +1,29 @@
+{-# LANGUAGE DerivingVia #-}
+
+module U.Codebase.Sqlite.Decl.Format where
+
+import Data.Vector (Vector)
+import U.Codebase.Decl (DeclR)
+import U.Codebase.Reference (Reference')
+import U.Codebase.Sqlite.LocalIds (LocalDefnId, LocalIds, LocalTextId)
+import U.Codebase.Sqlite.Symbol (Symbol)
+import qualified U.Codebase.Type as Type
+import qualified U.Core.ABT as ABT
+
+-- | Add new formats here
+data DeclFormat = Decl LocallyIndexedComponent
+  deriving Show
+
+-- | V1: Decls included `Hash`es inline
+--   V2: Instead of `Hash`, we use a smaller index.
+data LocallyIndexedComponent
+  = LocallyIndexedComponent (Vector (LocalIds, Decl Symbol))
+  deriving Show
+
+type Decl v = DeclR TypeRef v
+
+type Type v = ABT.Term F v ()
+
+type F = Type.F' TypeRef
+
+type TypeRef = Reference' LocalTextId (Maybe LocalDefnId)

codebase2/codebase-sqlite/U/Codebase/Sqlite/LocalIds.hs

@@ -0,0 +1,46 @@
+{-# LANGUAGE DerivingVia #-}
+
+module U.Codebase.Sqlite.LocalIds where
+
+import Data.Bifoldable (Bifoldable (bifoldMap))
+import Data.Bifunctor (Bifunctor (bimap))
+import Data.Bitraversable (Bitraversable (bitraverse))
+import Data.Bits (Bits)
+import Data.Vector (Vector)
+import Data.Word (Word64)
+import U.Codebase.Sqlite.DbId
+
+-- | A mapping between index ids that are local to an object and the ids in the database
+data LocalIds' t h = LocalIds
+  { textLookup :: Vector t,
+    defnLookup :: Vector h
+  } deriving Show
+
+type LocalIds = LocalIds' TextId ObjectId
+
+type WatchLocalIds = LocalIds' TextId HashId
+
+-- | represents an index into a textLookup
+newtype LocalTextId = LocalTextId Word64 deriving (Eq, Ord, Show, Num, Real, Enum, Integral, Bits) via Word64
+
+-- | represents an index into a defnLookup
+newtype LocalDefnId = LocalDefnId Word64 deriving (Eq, Ord, Show, Num, Real, Enum, Integral, Bits) via Word64
+
+-- | a local index to a hash, used when the corresponding object is allowed to be absent
+newtype LocalHashId = LocalHashId Word64 deriving (Eq, Ord, Show, Num, Real, Enum, Integral, Bits) via Word64
+
+newtype LocalPatchObjectId = LocalPatchObjectId Word64 deriving (Eq, Ord, Show, Num, Real, Enum, Integral, Bits) via Word64
+
+newtype LocalBranchChildId = LocalBranchChildId Word64 deriving (Eq, Ord, Show, Num, Real, Enum, Integral, Bits) via Word64
+
+-- | causal hashes are treated differently from HashIds, which don't have dependencies
+newtype LocalCausalHashId = LocalCausalHashId Word64 deriving (Eq, Ord, Show, Num, Real, Enum, Integral, Bits) via Word64
+
+instance Bitraversable LocalIds' where
+  bitraverse f g (LocalIds t d) = LocalIds <$> traverse f t <*> traverse g d
+
+instance Bifoldable LocalIds' where
+  bifoldMap f g (LocalIds t d) = foldMap f t <> foldMap g d
+
+instance Bifunctor LocalIds' where
+  bimap f g (LocalIds t d) = LocalIds (f <$> t) (g <$> d)

codebase2/codebase-sqlite/U/Codebase/Sqlite/ObjectType.hs

@@ -0,0 +1,21 @@
+module U.Codebase.Sqlite.ObjectType where
+
+import Database.SQLite.Simple.FromField (FromField(..))
+import Database.SQLite.Simple.ToField (ToField(..))
+import Database.SQLite.Simple (SQLData(SQLInteger))
+
+-- |Don't reorder these, they are part of the database,
+-- and the ToField and FromField implementation currently
+-- depends on the derived Enum implementation.
+data ObjectType
+  = TermComponent -- 0
+  | DeclComponent -- 1
+  | Namespace -- 2
+  | Patch -- 3
+  deriving (Eq, Ord, Show, Enum)
+
+instance ToField ObjectType where
+  toField = SQLInteger . fromIntegral . fromEnum
+
+instance FromField ObjectType where
+  fromField = fmap toEnum . fromField