mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-23 16:28:02 +03:00
wip
This commit is contained in:
Runar Bjarnason
parent
26c5a98ff9
commit
cea77de24a
@ -114,7 +114,9 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour
|
||||
Input -> awaitInput
|
||||
Notify output -> notifyUser output
|
||||
NotifyNumbered output -> notifyNumbered output
|
||||
ConfigLookup name -> Config.lookup config name
|
||||
ConfigLookup name -> do
|
||||
traceM (show name)
|
||||
Config.lookup config name
|
||||
LoadSource sourcePath -> loadSource sourcePath
|
||||
|
||||
Typecheck ambient names sourceName source -> do
|
||||
|
||||
@ -468,20 +468,27 @@ loop = do
|
||||
stepManyAt = Unison.Codebase.Editor.HandleInput.stepManyAt inputDescription
|
||||
stepManyAtM = Unison.Codebase.Editor.HandleInput.stepManyAtM inputDescription
|
||||
updateAtM = Unison.Codebase.Editor.HandleInput.updateAtM inputDescription
|
||||
manageLinks :: [(Path', NameSegment.HQSegment)]
|
||||
-> [HQ.HashQualified]
|
||||
-> (forall r. Ord r
|
||||
=> (r, Reference, Reference)
|
||||
-> Branch.Star r NameSegment
|
||||
-> Branch.Star r NameSegment)
|
||||
-> MaybeT (StateT (LoopState m v) (F m (Either Event Input) v)) ()
|
||||
manageLinks srcs mdValues op = do
|
||||
manageLinks path sources =
|
||||
manageLinks' path terms types
|
||||
where
|
||||
terms = toList . getHQ'Terms =<< sources
|
||||
types = toList . getHQ'Types =<< sources
|
||||
manageLinks'
|
||||
:: [(Path', NameSegment.HQSegment)]
|
||||
-> [Referent]
|
||||
-> [Reference]
|
||||
-> ( forall r
|
||||
. Ord r
|
||||
=> (r, Reference, Reference)
|
||||
-> Branch.Star r NameSegment
|
||||
-> Branch.Star r NameSegment
|
||||
)
|
||||
-> MaybeT (StateT (LoopState m v) (F m (Either Event Input) v)) ()
|
||||
manageLinks' !srcTerms !srcTypes mdValues op = do
|
||||
mdValuels <- fmap toList <$> traverse getHQTerms mdValues
|
||||
traverse_ go mdValuels
|
||||
where
|
||||
go mdl = do
|
||||
let !srcle = toList . getHQ'Terms =<< srcs
|
||||
!srclt = toList . getHQ'Types =<< srcs
|
||||
names0 <- basicPrettyPrintNames0
|
||||
ppe <- PPE.suffixifiedPPE <$> prettyPrintEnvDecl (Names names0 mempty)
|
||||
case mdl of
|
||||
@ -497,19 +504,20 @@ loop = do
|
||||
let get = Branch.head <$> use root
|
||||
before <- get
|
||||
stepManyAt steps
|
||||
after <- get
|
||||
after <- get
|
||||
(ppe, outputDiff) <- diffHelper before after
|
||||
if OBranchDiff.isEmpty outputDiff
|
||||
then success
|
||||
else respondNumbered $ ShowDiffNamespace Path.absoluteEmpty
|
||||
Path.absoluteEmpty
|
||||
ppe
|
||||
outputDiff
|
||||
else respondNumbered $
|
||||
ShowDiffNamespace Path.absoluteEmpty
|
||||
Path.absoluteEmpty
|
||||
ppe
|
||||
outputDiff
|
||||
where
|
||||
step mdType b0 =
|
||||
let tmUpdates terms = foldl' go terms srcle
|
||||
let tmUpdates terms = foldl' go terms srcTerms
|
||||
where go terms src = op (src, mdType, mdValue) terms
|
||||
tyUpdates types = foldl' go types srclt
|
||||
tyUpdates types = foldl' go types srcTypes
|
||||
where go types src = op (src, mdType, mdValue) types
|
||||
in over Branch.terms tmUpdates . over Branch.types tyUpdates $ b0
|
||||
mdValues -> respond $ MetadataAmbiguous ppe mdValues
|
||||
@ -1322,34 +1330,30 @@ loop = do
|
||||
. toSlurpResult currentPath' uf
|
||||
<$> slurpResultNames0
|
||||
let adds = Slurp.adds sr
|
||||
filtered = filterBySlurpResult sr $ uf
|
||||
when (Slurp.isNonempty sr) $ do
|
||||
stepAt ( Path.unabsolute currentPath'
|
||||
, doSlurpAdds adds uf)
|
||||
eval . AddDefsToCodebase . filterBySlurpResult sr $ uf
|
||||
eval $ AddDefsToCodebase filtered
|
||||
ppe <- prettyPrintEnvDecl =<<
|
||||
makeShadowedPrintNamesFromLabeled
|
||||
(UF.termSignatureExternalLabeledDependencies uf)
|
||||
(UF.typecheckedToNames0 uf)
|
||||
respond $ SlurpOutput input (PPE.suffixifiedPPE ppe) sr
|
||||
let
|
||||
addedVs = Set.toList $ SC.types adds <> SC.terms adds
|
||||
parseResult = (Path.parseHQSplit' . Var.nameStr) <$> addedVs
|
||||
(errs, addedNames) = partitionEithers parseResult
|
||||
case errs of
|
||||
e : _ ->
|
||||
error $ "I couldn't parse a name I just added to the codebase! " <> e
|
||||
_ -> do
|
||||
dm <- resolveDefaultMetadata currentPath'
|
||||
case dm of
|
||||
Nothing -> pure ()
|
||||
Just dm' -> do
|
||||
let hqs = traverse InputPatterns.parseHashQualifiedName dm'
|
||||
case hqs of
|
||||
Left e -> respond $
|
||||
ConfiguredMetadataParseError
|
||||
(Path.absoluteToPath' currentPath') (show dm') e
|
||||
Right defaultMeta ->
|
||||
manageLinks addedNames defaultMeta Metadata.insert
|
||||
dm <- resolveDefaultMetadata currentPath'
|
||||
case dm of
|
||||
Nothing -> pure ()
|
||||
Just dm' -> do
|
||||
let hqs = traverse InputPatterns.parseHashQualifiedName dm'
|
||||
case hqs of
|
||||
Left e -> respond $
|
||||
ConfiguredMetadataParseError
|
||||
(Path.absoluteToPath' currentPath') (show dm') e
|
||||
Right defaultMeta ->
|
||||
let terms = view _1 . elems $ hashTermsId filtered
|
||||
types = fst (elems (dataDeclarationsId' filtered))
|
||||
<> fst (elems (effectDeclarationsId' filtered))
|
||||
in manageLinks' terms types defaultMeta Metadata.insert
|
||||
|
||||
PreviewAddI hqs -> case (latestFile', uf) of
|
||||
(Just (sourceName, _), Just uf) -> do
|
||||
@ -1614,8 +1618,9 @@ loop = do
|
||||
success = respond Success
|
||||
|
||||
resolveDefaultMetadata :: Path.Absolute -> Action' m v (Maybe [String])
|
||||
resolveDefaultMetadata path =
|
||||
(eval . ConfigLookup) $ configKey "DefaultMetadata" path
|
||||
resolveDefaultMetadata path = do
|
||||
mstr <- (eval . ConfigLookup) $ configKey "DefaultMetadata" path
|
||||
pure mstr
|
||||
|
||||
configKey k p =
|
||||
Text.intercalate "." . toList $ k :<| fmap
|
||||
|
||||
Loading…
Reference in New Issue
Block a user