mirror of
https://github.com/unisonweb/unison.git
synced 2024-11-11 06:05:12 +03:00
Seems to be working
This commit is contained in:
Chris Penner
parent
e94448b5d6
commit
5038744c76
@ -260,18 +260,22 @@ loop = do
|
||||
loadUnisonFile sourceName text = do
|
||||
let lexed = L.lexer (Text.unpack sourceName) (Text.unpack text)
|
||||
withFile [] sourceName (text, lexed) $ \unisonFile -> do
|
||||
sr <- toSlurpResult currentPath' unisonFile <$> slurpResultNames
|
||||
sr <- NewSlurp.results . NewSlurp.analyzeTypecheckedUnisonFile unisonFile
|
||||
Nothing
|
||||
<$> currentPathNames
|
||||
let oldSlurpResult = NewSlurp.toSlurpResult unisonFile NewSlurp.UpdateOp Nothing sr
|
||||
-- sr <- toSlurpResult currentPath' unisonFile <$> slurpResultNames
|
||||
names <- displayNames unisonFile
|
||||
pped <- prettyPrintEnvDecl names
|
||||
let ppe = PPE.suffixifiedPPE pped
|
||||
eval . Notify $ Typechecked sourceName ppe sr unisonFile
|
||||
respond $ Typechecked sourceName ppe oldSlurpResult unisonFile
|
||||
unlessError' EvaluationFailure do
|
||||
(bindings, e) <- ExceptT . eval . Evaluate ppe $ unisonFile
|
||||
lift do
|
||||
let e' = Map.map go e
|
||||
go (ann, kind, _hash, _uneval, eval, isHit) = (ann, kind, eval, isHit)
|
||||
unless (null e') $
|
||||
eval . Notify $ Evaluated text ppe bindings e'
|
||||
respond $ Evaluated text ppe bindings e'
|
||||
LoopState.latestTypecheckedFile .= Just unisonFile
|
||||
|
||||
case e of
|
||||
@ -1268,7 +1272,7 @@ loop = do
|
||||
stepAtNoSync Branch.CompressHistory (Path.unabsolute currentPath', doSlurpAdds adds uf)
|
||||
eval . AddDefsToCodebase . NewSlurp.selectDefinitions adds $ uf
|
||||
ppe <- prettyPrintEnvDecl =<< displayNames uf
|
||||
let oldSlurpResult = NewSlurp.toSlurpResult uf NewSlurp.AddOp vars sr
|
||||
let oldSlurpResult = NewSlurp.toSlurpResult uf NewSlurp.AddOp (Just vars) sr
|
||||
respond $ SlurpOutput input (PPE.suffixifiedPPE ppe) oldSlurpResult
|
||||
-- respond $ NewSlurpOutput input (PPE.suffixifiedPPE ppe) NewSlurp.AddOp sr
|
||||
addDefaultMetadata adds
|
||||
|
||||
@ -316,7 +316,7 @@ isFailure o = case o of
|
||||
ListOfDefinitions _ _ ds -> null ds
|
||||
ListOfPatches s -> Set.null s
|
||||
SlurpOutput _ _ sr -> not $ SR.isOk sr
|
||||
NewSlurpOutput _ _ slurpOp sr -> NewSlurp.anyErrors slurpOp sr
|
||||
NewSlurpOutput _ _ _ sr -> NewSlurp.anyErrors sr
|
||||
ParseErrors {} -> True
|
||||
TypeErrors {} -> True
|
||||
CompilerBugs {} -> True
|
||||
|
||||
@ -55,6 +55,7 @@ data BlockStatus v
|
||||
= Add
|
||||
| Duplicated
|
||||
| NeedsUpdate (TypeOrTermVar v)
|
||||
| Update
|
||||
| ErrFrom (TypeOrTermVar v) SlurpErr
|
||||
| SelfErr SlurpErr
|
||||
deriving (Eq, Ord)
|
||||
@ -64,6 +65,8 @@ instance Semigroup (BlockStatus v) where
|
||||
_ <> SelfErr err = SelfErr err
|
||||
ErrFrom v err <> _ = ErrFrom v err
|
||||
_ <> ErrFrom v err = ErrFrom v err
|
||||
Update <> _ = Update
|
||||
_ <> Update = Update
|
||||
NeedsUpdate v <> _ = NeedsUpdate v
|
||||
_ <> NeedsUpdate v = NeedsUpdate v
|
||||
Add <> _ = Add
|
||||
@ -141,7 +144,7 @@ results sr@(SlurpResult {termNotes, typeNotes}) =
|
||||
& Map.toList
|
||||
& fmap
|
||||
( \(v, (_, deps)) ->
|
||||
( Semigroup.foldMap1 (getBlockStatus sr) (TermVar v NEList.:| Set.toList deps),
|
||||
( Semigroup.fold1 (getBlockStatus False sr (TermVar v) NEList.:| fmap (getBlockStatus True sr) (Set.toList deps)),
|
||||
mempty {SC.terms = Set.singleton v}
|
||||
)
|
||||
)
|
||||
@ -152,19 +155,19 @@ results sr@(SlurpResult {termNotes, typeNotes}) =
|
||||
& Map.toList
|
||||
& fmap
|
||||
( \(v, (_, deps)) ->
|
||||
( Semigroup.foldMap1 (getBlockStatus sr) (TypeVar v NEList.:| Set.toList deps),
|
||||
( Semigroup.fold1 (getBlockStatus False sr (TypeVar v) NEList.:| fmap (getBlockStatus True sr) (Set.toList deps)),
|
||||
mempty {SC.types = Set.singleton v}
|
||||
)
|
||||
)
|
||||
& Map.fromListWith (<>)
|
||||
|
||||
getBlockStatus :: (Ord v, Show v) => SlurpResult v -> TypeOrTermVar v -> BlockStatus v
|
||||
getBlockStatus (SlurpResult {termNotes, typeNotes}) tv =
|
||||
getBlockStatus :: (Ord v, Show v) => Bool -> SlurpResult v -> TypeOrTermVar v -> BlockStatus v
|
||||
getBlockStatus isDep (SlurpResult {termNotes, typeNotes}) tv =
|
||||
let defNotes = case tv of
|
||||
TypeVar v -> fromMaybe (error $ "Expected " <> show v <> " in typeNotes") $ Map.lookup v typeNotes
|
||||
TermVar v -> fromMaybe (error $ "Expected " <> show v <> " in termNotes") $ Map.lookup v termNotes
|
||||
in case fst defNotes of
|
||||
DefOk Updated -> NeedsUpdate tv
|
||||
DefOk Updated -> if isDep then NeedsUpdate tv else Update
|
||||
DefErr err -> ErrFrom tv err
|
||||
DefOk New -> Add
|
||||
DefOk Duplicate -> Duplicated
|
||||
@ -474,14 +477,17 @@ toSlurpResult ::
|
||||
Ord v =>
|
||||
UF.TypecheckedUnisonFile v Ann ->
|
||||
SlurpOp ->
|
||||
Set v ->
|
||||
Maybe (Set v) ->
|
||||
Result v ->
|
||||
OldSlurp.SlurpResult v
|
||||
toSlurpResult uf op vs r =
|
||||
toSlurpResult uf op mvs r =
|
||||
-- TODO: Do a proper partition to speed this up.
|
||||
OldSlurp.SlurpResult
|
||||
{ OldSlurp.originalFile = uf,
|
||||
OldSlurp.extraDefinitions = SC.difference (fold r) (SlurpComponent vs vs),
|
||||
OldSlurp.extraDefinitions =
|
||||
case mvs of
|
||||
Nothing -> mempty
|
||||
Just vs -> SC.difference (fold r) (SlurpComponent vs vs),
|
||||
OldSlurp.adds = adds,
|
||||
OldSlurp.duplicates = duplicates,
|
||||
OldSlurp.collisions = if op == AddOp then updates else mempty,
|
||||
@ -506,8 +512,13 @@ toSlurpResult uf op vs r =
|
||||
case k of
|
||||
Add -> (sc, mempty, mempty, mempty, (mempty, mempty))
|
||||
Duplicated -> (mempty, sc, mempty, mempty, (mempty, mempty))
|
||||
Update -> (mempty, mempty, sc, mempty, (mempty, mempty))
|
||||
NeedsUpdate v ->
|
||||
(mempty, mempty, singletonSC v, mempty, (mempty, sc `SC.difference` singletonSC v))
|
||||
case op of
|
||||
AddOp ->
|
||||
(mempty, mempty, singletonSC v, mempty, (mempty, sc `SC.difference` singletonSC v))
|
||||
UpdateOp ->
|
||||
(sc, mempty, mempty, mempty, (mempty, mempty))
|
||||
ErrFrom v TermCtorCollision -> (mempty, mempty, mempty, singletonSC v, (mempty, sc `SC.difference` singletonSC v))
|
||||
ErrFrom v CtorTermCollision -> (mempty, mempty, mempty, mempty, (singletonSC v, sc `SC.difference` singletonSC v))
|
||||
SelfErr TermCtorCollision -> (mempty, mempty, mempty, sc, (mempty, mempty))
|
||||
@ -517,15 +528,16 @@ toSlurpResult uf op vs r =
|
||||
TypeVar v -> SlurpComponent {terms = mempty, types = Set.singleton v}
|
||||
TermVar v -> SlurpComponent {terms = Set.singleton v, types = mempty}
|
||||
|
||||
anyErrors :: SlurpOp -> Result v -> Bool
|
||||
anyErrors op r =
|
||||
anyErrors :: Result v -> Bool
|
||||
anyErrors r =
|
||||
any isError . Map.keys $ Map.filter (not . SC.isEmpty) r
|
||||
where
|
||||
isError :: BlockStatus v -> Bool
|
||||
isError = \case
|
||||
Add -> False
|
||||
Duplicated -> False
|
||||
Update {} -> False
|
||||
-- NeedsUpdate is an error only if we're trying to Add
|
||||
NeedsUpdate {} -> op == AddOp
|
||||
NeedsUpdate {} -> True
|
||||
ErrFrom {} -> True
|
||||
SelfErr {} -> True
|
||||
|
||||
Loading…
Reference in New Issue
Block a user