Skip to content

Commit

Permalink
create typechecking block
Browse files Browse the repository at this point in the history
  • Loading branch information
Arya Irani committed Oct 10, 2023
1 parent 3747a30 commit 32faa94
Show file tree
Hide file tree
Showing 2 changed files with 92 additions and 113 deletions.
38 changes: 8 additions & 30 deletions unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -167,36 +167,17 @@ handleMerge alicePath0 bobPath0 _resultPath = do
lcaLibdeps <- step "load lca library dependencies" $ loadLibdeps lcaBranch
pure (Just lcaLibdeps, diffs)

-- (maybeLcaLibdeps, aliceDiff@(Merge.NamespaceDefns aliceDeclDiff aliceTermDiff), bobDiff@(Merge.NamespaceDefns bobDeclDiff bobTermDiff)) <-
-- case maybeLcaCausalHash of
-- Nothing -> do
-- (aliceDiff, bobDiff) <-
-- Merge.nameBasedNamespaceDiff
-- (Codebase.unsafeGetTypeDeclaration codebase)
-- (Codebase.unsafeGetTerm codebase)
-- Nothing
-- aliceDefns
-- bobDefns
-- pure (Nothing, aliceDiff, bobDiff)
-- Just lcaCausalHash -> do
-- lcaCausal <- step "load lca causal" $ Operations.expectCausalBranchByCausalHash lcaCausalHash
-- lcaBranch <- step "load lca shallow branch" $ Causal.value lcaCausal
-- T2 lcaDeclNames lcaTermNames <- step "load lca names" do
-- loadBranchDefinitionNames lcaBranch & onLeftM \err ->
-- rollback (werror (Text.unpack err))
-- let lcaDefns = Merge.NamespaceDefns {decls = lcaDeclNames, terms = lcaTermNames}
-- (aliceDiff, bobDiff) <-
-- Merge.nameBasedNamespaceDiff
-- (Codebase.unsafeGetTypeDeclaration codebase)
-- (Codebase.unsafeGetTerm codebase)
-- (Just lcaDefns)
-- aliceDefns
-- bobDefns


let conflictedTerms = conflictsish (diffs ^. #alice . #terms) (diffs ^. #bob . #terms)
let conflictedTypes = conflictsish (diffs ^. #alice . #types) (diffs ^. #bob . #types)

-- If there are no conflicts, then proceed to typechecking
if (null conflictedTerms && null conflictedTypes)
then do
wundefined
else do
-- If there are conflicts, then create a MergeOutput
wundefined

let mergedLibdeps =
Merge.mergeLibdeps
((==) `on` Causal.causalHash)
Expand All @@ -205,8 +186,6 @@ handleMerge alicePath0 bobPath0 _resultPath = do
aliceLibdeps
bobLibdeps



Sqlite.unsafeIO do
Text.putStrLn ""
Text.putStrLn "===== lca->alice diff ====="
Expand All @@ -225,7 +204,6 @@ handleMerge alicePath0 bobPath0 _resultPath = do
printTermConflicts conflictedTerms
Text.putStrLn ""


pure (Right ())

case result of
Expand Down
167 changes: 84 additions & 83 deletions unison-merge/src/Unison/Merge2.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -29,6 +29,7 @@ import Control.Lens (over, _3)
import Data.Either.Combinators (fromLeft', fromRight')
import Data.Foldable qualified as Foldable
import Data.Generics.Labels ()
import Data.List.NonEmpty (NonEmpty)
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Tuple qualified as Tuple
Expand Down Expand Up @@ -561,90 +562,90 @@ whatToTypecheck (drAlice, aliceUpdates) (drBob, bobUpdates) = do
updates' = dropBuiltins $ updatedTypesRt combinedUpdates
pure . WhatToTypecheck $ DeepRefsId' latestTermDependents latestTypeDependents

-- data MergeOutput v a = MergeProblem
-- { definitions :: Oink (Map Name (ConflictOrGood (V1.Term v a))) (Map Name (ConflictOrGood (V1.Decl v a)))
-- }

-- type Pretty = Text

-- type Defn v a = Either (V1.Term v a) (V1.Decl v a) -- could also be a builtin alias

-- pseudoOutput :: (Name -> Defn v a -> Pretty) -> MergeOutput v a -> Pretty
-- pseudoOutput printDefn merge = prettyConflicts <> newline <> prettyTransitiveDeps
-- where
-- (conflicted, transitiveDeps) = foldl' partitionConflicts mempty (terms $ definitions merge)
-- partitionConflicts (conflicted, transitiveDeps) (name, cog) = case cog of
-- Left conflict -> (Map.insert name conflict conflicted, transitiveDeps)
-- Right unconflicted -> (conflicted, Map.insert name unconflicted transitiveDeps)
-- prettyTransitiveDeps = foldMap prettyTransitiveDep (Map.toList transitiveDeps)
-- prettyTransitiveDep = uncurry printDefn
-- prettyConflicts = foldMap prettyConflict (Map.toList conflicted)
-- prettyConflict = \case
-- (name, ConflictAddAdd b1 b2 d1 d2) ->
-- mintercalate
-- "\n"
-- [ "-- added in " <> b1,
-- printDefn name d1,
-- "-- added in " <> b2,
-- printDefn name d2
-- ]
-- (name, ConflictUpdateUpdate b1 b2 d1 d2) ->
-- mintercalate
-- "\n"
-- [ "-- updated in " <> b1,
-- printDefn name d1,
-- "-- updated in " <> b2,
-- printDefn name d2
-- ]
-- (name, ConflictDeleteAddDependent b1 b2 d) ->
-- mintercalate
-- "\n"
-- [ "-- deleted in " <> b1,
-- printDeletedDefn name d,
-- "-- original definition still in use by " <> b2,
-- printDefn name d
-- ]
-- (name, ConflictDeleteUpdate b1 b2 d1 d2) ->
-- mintercalate
-- "\n"
-- [ "-- deleted in " <> b1,
-- printDefn name d1,
-- "-- updated in " <> b2,
-- printDefn name d2
-- ]
-- printDeletedDefn :: Name -> Defn v a -> Pretty
-- printDeletedDefn name = \case
-- _term@Left {} -> Name.toText name <> " = " <> "<<<deleted>>>"
-- Right (Left (V1.EffectDeclaration _effect)) -> case V1.Decl.modifier _effect of
-- V1.Decl.Structural -> "structural ability " <> Name.toText name <> " where " <> "<<<deleted>>>"
-- V1.Decl.Unique {} -> "unique ability " <> Name.toText name <> " where " <> "<<<deleted>>>"
-- (Right (Right _data)) -> case V1.Decl.modifier _data of
-- V1.Decl.Structural -> "structural type " <> Name.toText name <> " = " <> "<<<>>>"
-- V1.Decl.Unique {} -> "unique type " <> Name.toText name <> " = " <> "<<<>>>"
-- newline = "\n"

-- mintercalate :: Monoid a => a -> [a] -> a
-- mintercalate x ys = x <> go ys
-- where
-- go [] = mempty
-- go (y : ys) = y <> x <> go ys

-- sintercalate :: Semigroup a => a -> NonEmpty a -> a
-- sintercalate x ys = go $ toList ys
-- where
-- go [y] = y
-- go (y : ys) = y <> x <> go ys
-- go [] = error "impossible"

-- type BranchName = Text

-- type ConflictOrGood a = Either (Conflict BranchName a) a
data MergeOutput v a = MergeProblem
{ definitions :: Oink (Map Name (ConflictOrGood (V1.Term v a))) (Map Name (ConflictOrGood (V1.Decl v a)))
}

-- data Conflict branch a
-- = ConflictAddAdd !branch !branch !a !a
-- | ConflictUpdateUpdate !branch !branch !a !a
-- | ConflictDeleteAddDependent !branch !branch !a
-- | ConflictDeleteUpdate !branch !branch !a !a
type Pretty = Text

type Defn v a = Either (V1.Term v a) (V1.Decl v a) -- could also be a builtin alias

pseudoOutput :: (Name -> Defn v a -> Pretty) -> MergeOutput v a -> Pretty
pseudoOutput printDefn merge = prettyConflicts <> newline <> prettyTransitiveDeps
where
(conflicted, transitiveDeps) = foldl' partitionConflicts mempty (terms $ definitions merge)
partitionConflicts (conflicted, transitiveDeps) (name, cog) = case cog of
Left conflict -> (Map.insert name conflict conflicted, transitiveDeps)
Right unconflicted -> (conflicted, Map.insert name unconflicted transitiveDeps)
prettyTransitiveDeps = foldMap prettyTransitiveDep (Map.toList transitiveDeps)
prettyTransitiveDep = uncurry printDefn
prettyConflicts = foldMap prettyConflict (Map.toList conflicted)
prettyConflict = \case
(name, ConflictAddAdd b1 b2 d1 d2) ->
mintercalate
"\n"
[ "-- added in " <> b1,
printDefn name d1,
"-- added in " <> b2,
printDefn name d2
]
(name, ConflictUpdateUpdate b1 b2 d1 d2) ->
mintercalate
"\n"
[ "-- updated in " <> b1,
printDefn name d1,
"-- updated in " <> b2,
printDefn name d2
]
(name, ConflictDeleteAddDependent b1 b2 d) ->
mintercalate
"\n"
[ "-- deleted in " <> b1,
printDeletedDefn name d,
"-- original definition still in use by " <> b2,
printDefn name d
]
(name, ConflictDeleteUpdate b1 b2 d1 d2) ->
mintercalate
"\n"
[ "-- deleted in " <> b1,
printDefn name d1,
"-- updated in " <> b2,
printDefn name d2
]
printDeletedDefn :: Name -> Defn v a -> Pretty
printDeletedDefn name = \case
_term@Left {} -> Name.toText name <> " = " <> "<<<deleted>>>"
Right (Left (V1.EffectDeclaration _effect)) -> case V1.Decl.modifier _effect of
V1.Decl.Structural -> "structural ability " <> Name.toText name <> " where " <> "<<<deleted>>>"
V1.Decl.Unique {} -> "unique ability " <> Name.toText name <> " where " <> "<<<deleted>>>"
(Right (Right _data)) -> case V1.Decl.modifier _data of
V1.Decl.Structural -> "structural type " <> Name.toText name <> " = " <> "<<<>>>"
V1.Decl.Unique {} -> "unique type " <> Name.toText name <> " = " <> "<<<>>>"
newline = "\n"

mintercalate :: Monoid a => a -> [a] -> a
mintercalate x ys = x <> go ys
where
go [] = mempty
go (y : ys) = y <> x <> go ys

sintercalate :: Semigroup a => a -> NonEmpty a -> a
sintercalate x ys = go $ toList ys
where
go [y] = y
go (y : ys) = y <> x <> go ys
go [] = error "impossible"

type BranchName = Text

type ConflictOrGood a = Either (Conflict BranchName a) a

data Conflict branch a
= ConflictAddAdd !branch !branch !a !a
| ConflictUpdateUpdate !branch !branch !a !a
| ConflictDeleteAddDependent !branch !branch !a
| ConflictDeleteUpdate !branch !branch !a !a

data Oink terms types = Oink
{ _terms :: terms,
Expand Down

0 comments on commit 32faa94

Please sign in to comment.