mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-11 02:25:39 +03:00
Merge remote-tracking branch 'origin/trunk' into topic/ed25519
# Conflicts: # unison-src/transcripts-using-base/all-base-hashes.output.md
This commit is contained in:
commit
f66bf086b8
2
LICENSE
2
LICENSE
@ -1,4 +1,4 @@
|
||||
Copyright (c) 2013-2023, Unison Computing, public benefit corp and contributors
|
||||
Copyright (c) 2013-2024, Unison Computing, public benefit corp and contributors
|
||||
|
||||
Permission is hereby granted, free of charge, to any person obtaining a copy
|
||||
of this software and associated documentation files (the "Software"), to deal
|
||||
|
@ -34,7 +34,7 @@ verifyDeclFormatHash (ComponentHash hash) (DeclFormat.Decl (DeclFormat.LocallyIn
|
||||
& Map.toList
|
||||
& fmap (\(_refId, (v, decl, ())) -> (v, either H2.toDataDecl id $ H2.v2ToH2Decl decl))
|
||||
& Map.fromList
|
||||
& H2.hashDecls Name.unsafeFromVar
|
||||
& H2.hashDecls Name.unsafeParseVar
|
||||
& \case
|
||||
Left _err -> Just HH.DeclHashResolutionFailure
|
||||
Right m ->
|
||||
|
@ -117,7 +117,6 @@ v2ToH2Branch V2.Branch {terms, types, patches, children} = do
|
||||
v2ToH2MdValues :: V2Branch.MdValues -> H2.MdValues
|
||||
v2ToH2MdValues (V2Branch.MdValues mdMap) =
|
||||
mdMap
|
||||
& Map.keysSet
|
||||
& Set.map v2ToH2Reference
|
||||
& H2.MdValues
|
||||
|
||||
|
@ -200,8 +200,7 @@ import U.Util.Base32Hex qualified as Base32Hex
|
||||
import U.Util.Serialization qualified as S
|
||||
import Unison.Hash qualified as H
|
||||
import Unison.Hash32 qualified as Hash32
|
||||
import Unison.NameSegment (NameSegment (NameSegment))
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.NameSegment (NameSegment)
|
||||
import Unison.Prelude
|
||||
import Unison.ShortHash (ShortCausalHash (..), ShortNamespaceHash (..))
|
||||
import Unison.Sqlite
|
||||
@ -215,11 +214,6 @@ import Unison.Util.Set qualified as Set
|
||||
debug :: Bool
|
||||
debug = False
|
||||
|
||||
newtype NeedTypeForBuiltinMetadata
|
||||
= NeedTypeForBuiltinMetadata Text
|
||||
deriving stock (Show)
|
||||
deriving anyclass (SqliteExceptionReason)
|
||||
|
||||
-- * Database lookups
|
||||
|
||||
objectExistsForHash :: H.Hash -> Transaction Bool
|
||||
@ -558,51 +552,37 @@ s2cBranch (S.Branch.Full.Branch tms tps patches children) =
|
||||
<*> doPatches patches
|
||||
<*> doChildren children
|
||||
where
|
||||
loadMetadataType :: S.Reference -> Transaction C.Reference
|
||||
loadMetadataType = \case
|
||||
C.ReferenceBuiltin tId ->
|
||||
Q.expectTextCheck tId (Left . NeedTypeForBuiltinMetadata)
|
||||
C.ReferenceDerived id ->
|
||||
typeReferenceForTerm id >>= h2cReference
|
||||
|
||||
loadTypesForMetadata :: Set S.Reference -> Transaction (Map C.Reference C.Reference)
|
||||
loadTypesForMetadata rs =
|
||||
Map.fromList
|
||||
<$> traverse
|
||||
(\r -> (,) <$> s2cReference r <*> loadMetadataType r)
|
||||
(Foldable.toList rs)
|
||||
|
||||
doTerms ::
|
||||
Map Db.TextId (Map S.Referent S.DbMetadataSet) ->
|
||||
Transaction (Map NameSegment (Map C.Referent (Transaction C.Branch.MdValues)))
|
||||
doTerms =
|
||||
Map.bitraverse
|
||||
(fmap NameSegment . Q.expectText)
|
||||
Q.expectNameSegment
|
||||
( Map.bitraverse s2cReferent \case
|
||||
S.MetadataSet.Inline rs ->
|
||||
pure $ C.Branch.MdValues <$> loadTypesForMetadata rs
|
||||
pure $ C.Branch.MdValues <$> Set.traverse s2cReference rs
|
||||
)
|
||||
doTypes ::
|
||||
Map Db.TextId (Map S.Reference S.DbMetadataSet) ->
|
||||
Transaction (Map NameSegment (Map C.Reference (Transaction C.Branch.MdValues)))
|
||||
doTypes =
|
||||
Map.bitraverse
|
||||
(fmap NameSegment . Q.expectText)
|
||||
Q.expectNameSegment
|
||||
( Map.bitraverse s2cReference \case
|
||||
S.MetadataSet.Inline rs ->
|
||||
pure $ C.Branch.MdValues <$> loadTypesForMetadata rs
|
||||
pure $ C.Branch.MdValues <$> Set.traverse s2cReference rs
|
||||
)
|
||||
doPatches ::
|
||||
Map Db.TextId Db.PatchObjectId ->
|
||||
Transaction (Map NameSegment (PatchHash, Transaction C.Branch.Patch))
|
||||
doPatches = Map.bitraverse (fmap NameSegment . Q.expectText) \patchId -> do
|
||||
doPatches = Map.bitraverse Q.expectNameSegment \patchId -> do
|
||||
h <- PatchHash <$> (Q.expectPrimaryHashByObjectId . Db.unPatchObjectId) patchId
|
||||
pure (h, expectPatch patchId)
|
||||
|
||||
doChildren ::
|
||||
Map Db.TextId (Db.BranchObjectId, Db.CausalHashId) ->
|
||||
Transaction (Map NameSegment (C.Branch.CausalBranch Transaction))
|
||||
doChildren = Map.bitraverse (fmap NameSegment . Q.expectText) \(boId, chId) ->
|
||||
doChildren = Map.bitraverse Q.expectNameSegment \(boId, chId) ->
|
||||
C.Causal
|
||||
<$> Q.expectCausalHash chId
|
||||
<*> expectValueHashByCausalHashId chId
|
||||
@ -718,21 +698,21 @@ saveNamespace hh bhId me = do
|
||||
c2sBranch :: BranchV Transaction -> Transaction DbBranchV
|
||||
c2sBranch = \case
|
||||
BranchV2 branch -> do
|
||||
terms <- Map.bitraverse saveNameSegment (Map.bitraverse c2sReferent c2sMetadata) (branch ^. #terms)
|
||||
types <- Map.bitraverse saveNameSegment (Map.bitraverse c2sReference c2sMetadata) (branch ^. #types)
|
||||
patches <- Map.bitraverse saveNameSegment savePatchObjectId (branch ^. #patches)
|
||||
children <- Map.bitraverse saveNameSegment (saveBranch hh) (branch ^. #children)
|
||||
terms <- Map.bitraverse Q.saveNameSegment (Map.bitraverse c2sReferent c2sMetadata) (branch ^. #terms)
|
||||
types <- Map.bitraverse Q.saveNameSegment (Map.bitraverse c2sReference c2sMetadata) (branch ^. #types)
|
||||
patches <- Map.bitraverse Q.saveNameSegment savePatchObjectId (branch ^. #patches)
|
||||
children <- Map.bitraverse Q.saveNameSegment (saveBranch hh) (branch ^. #children)
|
||||
pure (DbBranchV2 S.Branch {terms, types, patches, children})
|
||||
BranchV3 branch -> do
|
||||
children <- Map.bitraverse saveNameSegment (saveBranchV3 hh) (branch ^. #children)
|
||||
terms <- Map.bitraverse saveNameSegment c2sReferent (branch ^. #terms)
|
||||
types <- Map.bitraverse saveNameSegment c2sReference (branch ^. #types)
|
||||
children <- Map.bitraverse Q.saveNameSegment (saveBranchV3 hh) (branch ^. #children)
|
||||
terms <- Map.bitraverse Q.saveNameSegment c2sReferent (branch ^. #terms)
|
||||
types <- Map.bitraverse Q.saveNameSegment c2sReference (branch ^. #types)
|
||||
pure (DbBranchV3 S.BranchV3 {children, terms, types})
|
||||
|
||||
c2sMetadata :: Transaction C.Branch.MdValues -> Transaction S.Branch.Full.DbMetadataSet
|
||||
c2sMetadata mm = do
|
||||
C.Branch.MdValues m <- mm
|
||||
S.Branch.Full.Inline <$> Set.traverse c2sReference (Map.keysSet m)
|
||||
S.Branch.Full.Inline <$> Set.traverse c2sReference m
|
||||
|
||||
savePatchObjectId :: (PatchHash, Transaction C.Branch.Patch) -> Transaction Db.PatchObjectId
|
||||
savePatchObjectId (h, mp) = do
|
||||
@ -740,9 +720,6 @@ saveNamespace hh bhId me = do
|
||||
patch <- mp
|
||||
savePatch hh h patch
|
||||
|
||||
saveNameSegment :: NameSegment -> Transaction Db.TextId
|
||||
saveNameSegment = Q.saveText . NameSegment.toText
|
||||
|
||||
-- Save just the causal object (i.e. the `causal` row and its associated `causal_parents`). Internal helper shared by
|
||||
-- `saveBranch` and `saveBranchV3`.
|
||||
saveCausalObject ::
|
||||
@ -1068,9 +1045,6 @@ filterTermsByReferentHavingType cTypeRef cTermRefIds =
|
||||
matches <- Q.filterTermsByReferentHavingType sTypeRef sTermRefIds
|
||||
traverse s2cReferentId matches
|
||||
|
||||
typeReferenceForTerm :: S.Reference.Id -> Transaction S.ReferenceH
|
||||
typeReferenceForTerm = Q.getTypeReferenceForReferent . C.Referent.RefId
|
||||
|
||||
termsMentioningType :: C.Reference -> Transaction (Set C.Referent.Id)
|
||||
termsMentioningType cTypeRef =
|
||||
runMaybeT (c2hReference cTypeRef) >>= \case
|
||||
|
@ -16,6 +16,10 @@ module U.Codebase.Sqlite.Queries
|
||||
expectText,
|
||||
expectTextCheck,
|
||||
|
||||
-- ** name segments
|
||||
saveNameSegment,
|
||||
expectNameSegment,
|
||||
|
||||
-- * hash table
|
||||
saveHash,
|
||||
saveHashes,
|
||||
@ -389,6 +393,8 @@ import Unison.Hash qualified as Hash
|
||||
import Unison.Hash32 (Hash32)
|
||||
import Unison.Hash32 qualified as Hash32
|
||||
import Unison.Hash32.Orphans.Sqlite ()
|
||||
import Unison.NameSegment (NameSegment (NameSegment))
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Prelude
|
||||
import Unison.Sqlite
|
||||
import Unison.Util.Alternative qualified as Alternative
|
||||
@ -646,6 +652,14 @@ loadTextSql h =
|
||||
WHERE id = :h
|
||||
|]
|
||||
|
||||
saveNameSegment :: NameSegment -> Transaction TextId
|
||||
saveNameSegment =
|
||||
saveText . NameSegment.toUnescapedText
|
||||
|
||||
expectNameSegment :: TextId -> Transaction NameSegment
|
||||
expectNameSegment =
|
||||
fmap NameSegment . expectText
|
||||
|
||||
saveHashObject :: HashId -> ObjectId -> HashVersion -> Transaction ()
|
||||
saveHashObject hId oId version =
|
||||
execute
|
||||
@ -4229,7 +4243,7 @@ data JsonParseFailure = JsonParseFailure
|
||||
deriving anyclass (SqliteExceptionReason)
|
||||
|
||||
-- | Get the most recent namespace the user has visited.
|
||||
expectMostRecentNamespace :: Transaction [Text]
|
||||
expectMostRecentNamespace :: Transaction [NameSegment]
|
||||
expectMostRecentNamespace =
|
||||
queryOneColCheck
|
||||
[sql|
|
||||
@ -4238,11 +4252,11 @@ expectMostRecentNamespace =
|
||||
|]
|
||||
check
|
||||
where
|
||||
check :: Text -> Either JsonParseFailure [Text]
|
||||
check :: Text -> Either JsonParseFailure [NameSegment]
|
||||
check bytes =
|
||||
case Aeson.eitherDecodeStrict (Text.encodeUtf8 bytes) of
|
||||
Left failure -> Left JsonParseFailure {bytes, failure = Text.pack failure}
|
||||
Right namespace -> Right namespace
|
||||
Right namespace -> Right (map NameSegment namespace)
|
||||
|
||||
-- | Set the most recent namespace the user has visited.
|
||||
setMostRecentNamespace :: [Text] -> Transaction ()
|
||||
|
@ -29,7 +29,7 @@ type MetadataType = Reference
|
||||
|
||||
type MetadataValue = Reference
|
||||
|
||||
newtype MdValues = MdValues {unMdValues :: Map MetadataValue MetadataType} deriving (Eq, Ord, Show)
|
||||
newtype MdValues = MdValues {unMdValues :: Set MetadataValue} deriving (Eq, Ord, Show)
|
||||
|
||||
type CausalBranch m = Causal m CausalHash BranchHash (Branch m) (Branch m)
|
||||
|
||||
|
@ -1,63 +1,57 @@
|
||||
module Unison.NameSegment where
|
||||
module Unison.NameSegment
|
||||
( NameSegment (..),
|
||||
toUnescapedText,
|
||||
isPrefixOf,
|
||||
|
||||
-- * Sentinel name segments
|
||||
defaultPatchSegment,
|
||||
docSegment,
|
||||
libSegment,
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Text qualified as Text
|
||||
import Data.Text.Lazy.Builder qualified as Text (Builder)
|
||||
import Data.Text.Lazy.Builder qualified as Text.Builder
|
||||
import Unison.Prelude
|
||||
import Unison.Util.Alphabetical (Alphabetical, compareAlphabetical)
|
||||
import Unison.Util.Alphabetical (Alphabetical)
|
||||
|
||||
-- Represents the parts of a name between the `.`s
|
||||
newtype NameSegment = NameSegment {toText :: Text}
|
||||
newtype NameSegment
|
||||
= NameSegment Text
|
||||
deriving stock (Eq, Ord, Generic)
|
||||
|
||||
instance Alphabetical NameSegment where
|
||||
compareAlphabetical n1 n2 = compareAlphabetical (toText n1) (toText n2)
|
||||
|
||||
-- Split text into segments. A smarter version of `Text.splitOn` that handles
|
||||
-- the name `.` properly.
|
||||
segments' :: Text -> [Text]
|
||||
segments' n = go split
|
||||
where
|
||||
split = Text.splitOn "." n
|
||||
go [] = []
|
||||
go ("" : "" : z) = "." : go z
|
||||
go ("" : z) = go z
|
||||
go (x : y) = x : go y
|
||||
|
||||
-- Same as reverse . segments', but produces the output as a
|
||||
-- lazy list, suitable for suffix-based ordering purposes or
|
||||
-- building suffix tries. Examples:
|
||||
--
|
||||
-- reverseSegments' "foo.bar.baz" => ["baz","bar","foo"]
|
||||
-- reverseSegments' ".foo.bar.baz" => ["baz","bar","foo"]
|
||||
-- reverseSegments' ".." => ["."]
|
||||
-- reverseSegments' "Nat.++" => ["++","Nat"]
|
||||
-- reverseSegments' "Nat.++.zoo" => ["zoo","++","Nat"]
|
||||
reverseSegments' :: Text -> [Text]
|
||||
reverseSegments' = go
|
||||
where
|
||||
go "" = []
|
||||
go t =
|
||||
let seg0 = Text.takeWhileEnd (/= '.') t
|
||||
seg = if Text.null seg0 then Text.takeEnd 1 t else seg0
|
||||
rem = Text.dropEnd (Text.length seg + 1) t
|
||||
in seg : go rem
|
||||
|
||||
isEmpty :: NameSegment -> Bool
|
||||
isEmpty ns = toText ns == mempty
|
||||
|
||||
isPrefixOf :: NameSegment -> NameSegment -> Bool
|
||||
isPrefixOf n1 n2 = Text.isPrefixOf (toText n1) (toText n2)
|
||||
|
||||
toString :: NameSegment -> String
|
||||
toString = Text.unpack . toText
|
||||
|
||||
toTextBuilder :: NameSegment -> Text.Builder
|
||||
toTextBuilder =
|
||||
coerce Text.Builder.fromText
|
||||
deriving newtype (Alphabetical)
|
||||
|
||||
instance IsString NameSegment where
|
||||
fromString = NameSegment . Text.pack
|
||||
fromString =
|
||||
NameSegment . Text.pack
|
||||
|
||||
instance Show NameSegment where
|
||||
show = show . toText
|
||||
show =
|
||||
Text.unpack . toUnescapedText
|
||||
|
||||
-- | Convert a name segment to unescaped text.
|
||||
--
|
||||
-- You might use this when storing a name segment as text in a database, where the literal name segment bytes are all
|
||||
-- that matter. However, you wouldn't use this to display the name segment to a user - that depends on concrete syntax.
|
||||
-- See Unison.Syntax.NameSegment (or indeed, some actual yet-built interface that abstracts concrete syntax) for that
|
||||
-- kind of function.
|
||||
--
|
||||
-- > toUnescapedText (unsafeFromText ".~") = ".~"
|
||||
toUnescapedText :: NameSegment -> Text
|
||||
toUnescapedText =
|
||||
coerce
|
||||
|
||||
isPrefixOf :: NameSegment -> NameSegment -> Bool
|
||||
isPrefixOf =
|
||||
coerce Text.isPrefixOf
|
||||
|
||||
defaultPatchSegment :: NameSegment
|
||||
defaultPatchSegment =
|
||||
"patch"
|
||||
|
||||
docSegment :: NameSegment
|
||||
docSegment =
|
||||
"doc"
|
||||
|
||||
libSegment :: NameSegment
|
||||
libSegment =
|
||||
"lib"
|
||||
|
@ -1,5 +1,3 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module Unison.ShortHash
|
||||
|
@ -11,7 +11,7 @@ import U.Codebase.Causal qualified as Causal
|
||||
import U.Codebase.HashTags (BranchHash (..))
|
||||
import Unison.Codebase.Path
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Name (libSegment)
|
||||
import Unison.NameSegment (libSegment)
|
||||
import Unison.Prelude
|
||||
import Unison.Sqlite qualified as Sqlite
|
||||
import Unison.Util.Monoid (ifoldMapM)
|
||||
|
@ -38,7 +38,7 @@ import Unison.Prelude
|
||||
import Unison.Reference qualified as R
|
||||
import Unison.Referent qualified as Referent
|
||||
import Unison.Symbol (Symbol)
|
||||
import Unison.Syntax.Name qualified as Name (unsafeFromText, unsafeFromVar)
|
||||
import Unison.Syntax.Name qualified as Name (unsafeParseText, unsafeParseVar)
|
||||
import Unison.Type qualified as Type
|
||||
import Unison.Typechecker.TypeLookup qualified as TL
|
||||
import Unison.Util.Relation qualified as Rel
|
||||
@ -56,24 +56,24 @@ names = Names terms types
|
||||
terms =
|
||||
Rel.mapRan Referent.Ref (Rel.fromMap termNameRefs)
|
||||
<> Rel.fromList
|
||||
[ (Name.unsafeFromVar vc, Referent.Con (ConstructorReference (R.DerivedId r) cid) ct)
|
||||
[ (Name.unsafeParseVar vc, Referent.Con (ConstructorReference (R.DerivedId r) cid) ct)
|
||||
| (ct, (_, (r, decl))) <-
|
||||
((CT.Data,) <$> builtinDataDecls)
|
||||
<> ((CT.Effect,) . (second . second) DD.toDataDecl <$> builtinEffectDecls),
|
||||
((_, vc, _), cid) <- DD.constructors' decl `zip` [0 ..]
|
||||
]
|
||||
<> Rel.fromList
|
||||
[ (Name.unsafeFromVar v, Referent.Ref (R.DerivedId i))
|
||||
[ (Name.unsafeParseVar v, Referent.Ref (R.DerivedId i))
|
||||
| (v, i) <- Map.toList TD.builtinTermsRef
|
||||
]
|
||||
types =
|
||||
Rel.fromList builtinTypes
|
||||
<> Rel.fromList
|
||||
[ (Name.unsafeFromVar v, R.DerivedId r)
|
||||
[ (Name.unsafeParseVar v, R.DerivedId r)
|
||||
| (v, (r, _)) <- builtinDataDecls
|
||||
]
|
||||
<> Rel.fromList
|
||||
[ (Name.unsafeFromVar v, R.DerivedId r)
|
||||
[ (Name.unsafeParseVar v, R.DerivedId r)
|
||||
| (v, (r, _)) <- builtinEffectDecls
|
||||
]
|
||||
|
||||
@ -147,7 +147,7 @@ builtinTypeDependentsOfComponent h0 = Rel.searchRan ord builtinDependencies
|
||||
-- if we decide to change their names.
|
||||
builtinTypes :: [(Name, R.Reference)]
|
||||
builtinTypes =
|
||||
Map.toList . Map.mapKeys Name.unsafeFromText $
|
||||
Map.toList . Map.mapKeys Name.unsafeParseText $
|
||||
foldl' go mempty builtinTypesSrc
|
||||
where
|
||||
go m = \case
|
||||
@ -286,7 +286,7 @@ instance Show BuiltinDSL where
|
||||
show _ = ""
|
||||
|
||||
termNameRefs :: Map Name R.Reference
|
||||
termNameRefs = Map.mapKeys Name.unsafeFromText $ foldl' go mempty (stripVersion builtinsSrc)
|
||||
termNameRefs = Map.mapKeys Name.unsafeParseText $ foldl' go mempty (stripVersion builtinsSrc)
|
||||
where
|
||||
go m = \case
|
||||
B r _tp -> Map.insert r (R.Builtin r) m
|
||||
|
@ -120,6 +120,7 @@ import Unison.Hashing.V2.Convert qualified as H
|
||||
import Unison.Name (Name)
|
||||
import Unison.Name qualified as Name
|
||||
import Unison.NameSegment (NameSegment)
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Prelude hiding (empty)
|
||||
import Unison.Reference (TermReference, TypeReference)
|
||||
import Unison.Referent (Referent)
|
||||
@ -129,7 +130,7 @@ import Unison.Util.Monoid qualified as Monoid
|
||||
import Unison.Util.Relation qualified as R
|
||||
import Unison.Util.Relation qualified as Relation
|
||||
import Unison.Util.Set qualified as Set
|
||||
import Unison.Util.Star3 qualified as Star3
|
||||
import Unison.Util.Star2 qualified as Star2
|
||||
import Witherable (FilterableWithIndex (imapMaybe))
|
||||
import Prelude hiding (head, read, subtract)
|
||||
|
||||
@ -151,7 +152,7 @@ withoutLib Branch0 {..} =
|
||||
_children
|
||||
& imapMaybe
|
||||
( \nameSegment child ->
|
||||
if nameSegment == Name.libSegment
|
||||
if nameSegment == NameSegment.libSegment
|
||||
then Nothing
|
||||
else Just (child & head_ %~ withoutLib)
|
||||
)
|
||||
@ -165,7 +166,7 @@ withoutTransitiveLibs Branch0 {..} =
|
||||
_children
|
||||
& imapMaybe
|
||||
( \nameSegment child ->
|
||||
if nameSegment == Name.libSegment
|
||||
if nameSegment == NameSegment.libSegment
|
||||
then Just (child & head_ %~ withoutLib)
|
||||
else Just (child & head_ %~ withoutTransitiveLibs)
|
||||
)
|
||||
@ -229,8 +230,8 @@ branch0 terms types children edits =
|
||||
_children = children,
|
||||
_edits = edits,
|
||||
isEmpty0 =
|
||||
R.null (Star3.d1 terms)
|
||||
&& R.null (Star3.d1 types)
|
||||
R.null (Star2.d1 terms)
|
||||
&& R.null (Star2.d1 types)
|
||||
&& Map.null edits
|
||||
&& all (isEmpty0 . head) children,
|
||||
-- These are all overwritten immediately
|
||||
@ -266,7 +267,7 @@ deriveDeepTerms branch =
|
||||
terms =
|
||||
map
|
||||
(second (Name.fromReverseSegments . (NonEmpty.:| reversePrefix)))
|
||||
(R.toList (Star3.d1 (_terms b0)))
|
||||
(R.toList (Star2.d1 (_terms b0)))
|
||||
children <- deepChildrenHelper e
|
||||
go (work <> children) (terms <> acc)
|
||||
|
||||
@ -285,7 +286,7 @@ deriveDeepTypes branch =
|
||||
go Seq.Empty acc = pure acc
|
||||
go (e@(reversePrefix, _, b0) Seq.:<| work) acc = do
|
||||
let types :: [(TypeReference, Name)]
|
||||
types = map (second (Name.fromReverseSegments . (NonEmpty.:| reversePrefix))) (R.toList (Star3.d1 (_types b0)))
|
||||
types = map (second (Name.fromReverseSegments . (NonEmpty.:| reversePrefix))) (R.toList (Star2.d1 (_types b0)))
|
||||
children <- deepChildrenHelper e
|
||||
go (work <> children) (types <> acc)
|
||||
|
||||
@ -348,7 +349,7 @@ deepChildrenHelper (reversePrefix, libDepth, b0) = do
|
||||
pure
|
||||
if isShallowDependency || isUnseenNamespace
|
||||
then
|
||||
let libDepth' = if ns == "lib" then libDepth + 1 else libDepth
|
||||
let libDepth' = if ns == NameSegment.libSegment then libDepth + 1 else libDepth
|
||||
in Seq.singleton (ns : reversePrefix, libDepth', head b)
|
||||
else Seq.empty
|
||||
State.modify' (Set.insert h)
|
||||
@ -676,28 +677,28 @@ batchUpdatesM (toList -> actions) curBranch = foldM execActions curBranch (group
|
||||
-- todo: consider inlining these into Actions2
|
||||
addTermName :: Referent -> NameSegment -> Branch0 m -> Branch0 m
|
||||
addTermName r new =
|
||||
over terms (Star3.insertD1 (r, new))
|
||||
over terms (Star2.insertD1 (r, new))
|
||||
|
||||
addTypeName :: TypeReference -> NameSegment -> Branch0 m -> Branch0 m
|
||||
addTypeName r new =
|
||||
over types (Star3.insertD1 (r, new))
|
||||
over types (Star2.insertD1 (r, new))
|
||||
|
||||
deleteTermName :: Referent -> NameSegment -> Branch0 m -> Branch0 m
|
||||
deleteTermName r n b
|
||||
| Star3.memberD1 (r, n) (view terms b) =
|
||||
over terms (Star3.deletePrimaryD1 (r, n)) b
|
||||
| Star2.memberD1 (r, n) (view terms b) =
|
||||
over terms (Star2.deletePrimaryD1 (r, n)) b
|
||||
deleteTermName _ _ b = b
|
||||
|
||||
annihilateTermName :: NameSegment -> Branch0 m -> Branch0 m
|
||||
annihilateTermName = over terms . Star3.deleteD1
|
||||
annihilateTermName = over terms . Star2.deleteD1
|
||||
|
||||
annihilateTypeName :: NameSegment -> Branch0 m -> Branch0 m
|
||||
annihilateTypeName = over types . Star3.deleteD1
|
||||
annihilateTypeName = over types . Star2.deleteD1
|
||||
|
||||
deleteTypeName :: TypeReference -> NameSegment -> Branch0 m -> Branch0 m
|
||||
deleteTypeName r n b
|
||||
| Star3.memberD1 (r, n) (view types b) =
|
||||
over types (Star3.deletePrimaryD1 (r, n)) b
|
||||
| Star2.memberD1 (r, n) (view types b) =
|
||||
over types (Star2.deletePrimaryD1 (r, n)) b
|
||||
deleteTypeName _ _ b = b
|
||||
|
||||
lca :: (Monad m) => Branch m -> Branch m -> m (Maybe (Branch m))
|
||||
|
@ -9,7 +9,7 @@ import Unison.Codebase.Patch qualified as Patch
|
||||
import Unison.NameSegment (NameSegment)
|
||||
import Unison.Reference (Reference)
|
||||
import Unison.Referent (Referent)
|
||||
import Unison.Util.Star3 qualified as Star3
|
||||
import Unison.Util.Star2 qualified as Star2
|
||||
|
||||
type Star r n = Metadata.Star r n
|
||||
|
||||
@ -38,10 +38,10 @@ diff0 old new = do
|
||||
oldEdits
|
||||
pure $
|
||||
BranchDiff
|
||||
{ addedTerms = Star3.difference (_terms new) (_terms old),
|
||||
removedTerms = Star3.difference (_terms old) (_terms new),
|
||||
addedTypes = Star3.difference (_types new) (_types old),
|
||||
removedTypes = Star3.difference (_types old) (_types new),
|
||||
{ addedTerms = Star2.difference (_terms new) (_terms old),
|
||||
removedTerms = Star2.difference (_terms old) (_terms new),
|
||||
addedTypes = Star2.difference (_types new) (_types old),
|
||||
removedTypes = Star2.difference (_types old) (_types new),
|
||||
changedPatches = diffEdits
|
||||
}
|
||||
|
||||
|
@ -33,7 +33,7 @@ import Unison.Hashing.V2.Convert qualified as H
|
||||
import Unison.Prelude hiding (empty)
|
||||
import Unison.Util.Map (unionWithM)
|
||||
import Unison.Util.Relation qualified as R
|
||||
import Unison.Util.Star3 qualified as Star3
|
||||
import Unison.Util.Star2 qualified as Star2
|
||||
import Prelude hiding (head, read, subtract)
|
||||
|
||||
data MergeMode = RegularMerge | SquashMerge deriving (Eq, Ord, Show)
|
||||
@ -91,8 +91,8 @@ merge'' lca mode (Branch x) (Branch y) =
|
||||
in (PatchHash (H.hashPatch p), pure p)
|
||||
pure $
|
||||
branch0
|
||||
(Star3.difference (_terms b0) removedTerms <> addedTerms)
|
||||
(Star3.difference (_types b0) removedTypes <> addedTypes)
|
||||
(Star2.difference (_terms b0) removedTerms <> addedTerms)
|
||||
(Star2.difference (_types b0) removedTypes <> addedTypes)
|
||||
(_children b0)
|
||||
(patches <> newPatches)
|
||||
patchMerge mhp Patch.PatchDiff {..} = Just $ do
|
||||
|
@ -37,7 +37,7 @@ import Unison.Referent (Referent)
|
||||
import Unison.Referent qualified as Referent
|
||||
import Unison.ShortHash qualified as SH
|
||||
import Unison.Util.Relation qualified as R
|
||||
import Unison.Util.Star3 qualified as Star3
|
||||
import Unison.Util.Star2 qualified as Star2
|
||||
|
||||
-- | Creates a branch containing all of the given names, with a single history node.
|
||||
fromNames :: (Monad m) => Names -> Branch m
|
||||
@ -50,16 +50,16 @@ fromNames names0 = Branch.stepManyAt (typeActions <> termActions) Branch.empty
|
||||
|
||||
getTerm :: Path.HQSplit -> Branch0 m -> Set Referent
|
||||
getTerm (p, hq) b = case hq of
|
||||
NameOnly n -> Star3.lookupD1 n terms
|
||||
HashQualified n sh -> filter sh $ Star3.lookupD1 n terms
|
||||
NameOnly n -> Star2.lookupD1 n terms
|
||||
HashQualified n sh -> filter sh $ Star2.lookupD1 n terms
|
||||
where
|
||||
filter sh = Set.filter (SH.isPrefixOf sh . Referent.toShortHash)
|
||||
terms = Branch._terms (Branch.getAt0 p b)
|
||||
|
||||
getType :: Path.HQSplit -> Branch0 m -> Set Reference.TypeReference
|
||||
getType (p, hq) b = case hq of
|
||||
NameOnly n -> Star3.lookupD1 n types
|
||||
HashQualified n sh -> filter sh $ Star3.lookupD1 n types
|
||||
NameOnly n -> Star2.lookupD1 n types
|
||||
HashQualified n sh -> filter sh $ Star2.lookupD1 n types
|
||||
where
|
||||
filter sh = Set.filter (SH.isPrefixOf sh . Reference.toShortHash)
|
||||
types = Branch._types (Branch.getAt0 p b)
|
||||
|
@ -12,6 +12,7 @@ import Unison.Prelude
|
||||
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
|
||||
import Unison.Share.Types
|
||||
import Unison.Util.Monoid qualified as Monoid
|
||||
import qualified Unison.NameSegment as NameSegment
|
||||
|
||||
data ReadRepo
|
||||
= ReadRepoGit ReadGitRepo
|
||||
@ -131,7 +132,7 @@ data ReadShareLooseCode = ReadShareLooseCode
|
||||
isPublic :: ReadShareLooseCode -> Bool
|
||||
isPublic ReadShareLooseCode {path} =
|
||||
case path of
|
||||
("public" Path.:< _) -> True
|
||||
((NameSegment.toUnescapedText -> "public") Path.:< _) -> True
|
||||
_ -> False
|
||||
|
||||
data WriteRemoteNamespace a
|
||||
|
@ -1,7 +1,3 @@
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
|
||||
-- | Execute a computation of type '{IO} () that has been previously added to
|
||||
-- the codebase, without setting up an interactive environment.
|
||||
--
|
||||
@ -20,6 +16,7 @@ import Unison.Codebase.Runtime (Runtime)
|
||||
import Unison.Codebase.Runtime qualified as Runtime
|
||||
import Unison.Names qualified as Names
|
||||
import Unison.Parser.Ann (Ann)
|
||||
import Unison.Prelude
|
||||
import Unison.PrettyPrintEnv qualified as PPE
|
||||
import Unison.Symbol (Symbol)
|
||||
import Unison.Util.Pretty qualified as P
|
||||
@ -27,7 +24,7 @@ import Unison.Util.Pretty qualified as P
|
||||
execute ::
|
||||
Codebase.Codebase IO Symbol Ann ->
|
||||
Runtime Symbol ->
|
||||
String ->
|
||||
Text ->
|
||||
IO (Either Runtime.Error ())
|
||||
execute codebase runtime mainName =
|
||||
(`finally` Runtime.terminate runtime) . runExceptT $ do
|
||||
@ -37,9 +34,9 @@ execute codebase runtime mainName =
|
||||
let mainType = Runtime.mainType runtime
|
||||
mt <- liftIO $ Codebase.runTransaction codebase $ getMainTerm loadTypeOfTerm parseNames mainName mainType
|
||||
case mt of
|
||||
MainTerm.NotAFunctionName s -> throwError ("Not a function name: " <> P.string s)
|
||||
MainTerm.NotFound s -> throwError ("Not found: " <> P.string s)
|
||||
MainTerm.BadType s _ -> throwError (P.string s <> " is not of type '{IO} ()")
|
||||
MainTerm.NotAFunctionName s -> throwError ("Not a function name: " <> P.text s)
|
||||
MainTerm.NotFound s -> throwError ("Not found: " <> P.text s)
|
||||
MainTerm.BadType s _ -> throwError (P.text s <> " is not of type '{IO} ()")
|
||||
MainTerm.Success _ tm _ -> do
|
||||
let codeLookup = Codebase.toCodeLookup codebase
|
||||
ppe = PPE.empty
|
||||
|
@ -16,7 +16,7 @@ import Unison.Parser.Ann qualified as Parser.Ann
|
||||
import Unison.Prelude
|
||||
import Unison.Reference (Reference)
|
||||
import Unison.Referent qualified as Referent
|
||||
import Unison.Syntax.HashQualified qualified as HQ (fromString)
|
||||
import Unison.Syntax.HashQualified qualified as HQ (parseText)
|
||||
import Unison.Term (Term)
|
||||
import Unison.Term qualified as Term
|
||||
import Unison.Type (Type)
|
||||
@ -26,20 +26,20 @@ import Unison.Var (Var)
|
||||
import Unison.Var qualified as Var
|
||||
|
||||
data MainTerm v
|
||||
= NotAFunctionName String
|
||||
| NotFound String
|
||||
| BadType String (Maybe (Type v Ann))
|
||||
= NotAFunctionName Text
|
||||
| NotFound Text
|
||||
| BadType Text (Maybe (Type v Ann))
|
||||
| Success (HQ.HashQualified Name) (Term v Ann) (Type v Ann)
|
||||
|
||||
getMainTerm ::
|
||||
(Monad m, Var v) =>
|
||||
(Reference -> m (Maybe (Type v Ann))) ->
|
||||
Names.Names ->
|
||||
String ->
|
||||
Text ->
|
||||
Type.Type v Ann ->
|
||||
m (MainTerm v)
|
||||
getMainTerm loadTypeOfTerm parseNames mainName mainType =
|
||||
case HQ.fromString mainName of
|
||||
case HQ.parseText mainName of
|
||||
Nothing -> pure (NotAFunctionName mainName)
|
||||
Just hq -> do
|
||||
let refs = Names.lookupHQTerm Names.IncludeSuffixes hq parseNames
|
||||
|
@ -1,39 +1,24 @@
|
||||
module Unison.Codebase.Metadata
|
||||
( Star,
|
||||
Type,
|
||||
Value,
|
||||
insert,
|
||||
delete,
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Map qualified as Map
|
||||
import Unison.Prelude
|
||||
import Unison.Reference (Reference)
|
||||
import Unison.Util.List qualified as List
|
||||
import Unison.Util.Relation qualified as R
|
||||
import Unison.Util.Star3 (Star3)
|
||||
import Unison.Util.Star3 qualified as Star3
|
||||
import Unison.Reference (TermReference)
|
||||
import Unison.Util.Star2 (Star2)
|
||||
import Unison.Util.Star2 qualified as Star2
|
||||
|
||||
type Type = Reference
|
||||
|
||||
type Value = Reference
|
||||
type Value = TermReference
|
||||
|
||||
-- `a` is generally the type of references or hashes
|
||||
-- `n` is generally the the type of name associated with the references
|
||||
-- `Type` is the type of metadata. Duplicate info to speed up certain queries.
|
||||
-- `(Type, Value)` is the metadata value itself along with its type.
|
||||
type Star a n = Star3 a n Type (Type, Value)
|
||||
-- `Value` is the metadata value itself.
|
||||
type Star a n = Star2 a n Value
|
||||
|
||||
insert :: (Ord a, Ord n) => (a, Type, Value) -> Star a n -> Star a n
|
||||
insert (a, ty, v) = Star3.insertD23 (a, ty, (ty, v))
|
||||
insert :: (Ord a, Ord n) => (a, Value) -> Star a n -> Star a n
|
||||
insert (a, v) = Star2.insertD2 (a, v)
|
||||
|
||||
delete :: (Ord a, Ord n) => (a, Type, Value) -> Star a n -> Star a n
|
||||
delete (a, ty, v) s =
|
||||
let s' = Star3.deleteD3 (a, (ty, v)) s
|
||||
-- if (ty,v) is the last metadata of type ty
|
||||
-- we also delete (a, ty) from the d2 index
|
||||
metadataByType = List.multimap (toList (R.lookupDom a (Star3.d3 s)))
|
||||
in case Map.lookup ty metadataByType of
|
||||
Just vs | all (== v) vs -> Star3.deleteD2 (a, ty) s'
|
||||
_ -> s'
|
||||
delete :: (Ord a, Ord n) => (a, Value) -> Star a n -> Star a n
|
||||
delete (a, v) s = Star2.deleteD2 (a, v) s
|
||||
|
@ -45,8 +45,8 @@ module Unison.Codebase.Path
|
||||
fromName,
|
||||
fromName',
|
||||
fromPath',
|
||||
fromText,
|
||||
fromText',
|
||||
unsafeParseText,
|
||||
unsafeParseText',
|
||||
toAbsoluteSplit,
|
||||
toSplit',
|
||||
toList,
|
||||
@ -54,7 +54,6 @@ module Unison.Codebase.Path
|
||||
toName',
|
||||
unsafeToName,
|
||||
unsafeToName',
|
||||
toPath',
|
||||
toText,
|
||||
toText',
|
||||
unsplit,
|
||||
@ -65,6 +64,7 @@ module Unison.Codebase.Path
|
||||
|
||||
-- * things that could be replaced with `Parse` instances
|
||||
splitFromName,
|
||||
splitFromName',
|
||||
hqSplitFromName',
|
||||
|
||||
-- * things that could be replaced with `Cons` instances
|
||||
@ -91,12 +91,10 @@ import GHC.Exts qualified as GHC
|
||||
import Unison.HashQualified' qualified as HQ'
|
||||
import Unison.Name (Convert (..), Name, Parse)
|
||||
import Unison.Name qualified as Name
|
||||
import Unison.NameSegment (NameSegment (NameSegment))
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.NameSegment (NameSegment)
|
||||
import Unison.Prelude hiding (empty, toList)
|
||||
import Unison.Syntax.Name qualified as Name (toString, unsafeFromText)
|
||||
import Unison.Syntax.Name qualified as Name (toText, unsafeParseText)
|
||||
import Unison.Util.List qualified as List
|
||||
import Unison.Util.Monoid (intercalateMap)
|
||||
|
||||
-- `Foo.Bar.baz` becomes ["Foo", "Bar", "baz"]
|
||||
newtype Path = Path {toSeq :: Seq NameSegment}
|
||||
@ -225,12 +223,6 @@ relativeEmpty' = RelativePath' (Relative empty)
|
||||
absoluteEmpty' :: Path'
|
||||
absoluteEmpty' = AbsolutePath' (Absolute empty)
|
||||
|
||||
-- | Mitchell: this function is bogus, because an empty name segment is bogus
|
||||
toPath' :: Path -> Path'
|
||||
toPath' = \case
|
||||
Path (NameSegment "" :<| tail) -> AbsolutePath' . Absolute . Path $ tail
|
||||
p -> Path' . Right . Relative $ p
|
||||
|
||||
-- Forget whether the path is absolute or relative
|
||||
fromPath' :: Path' -> Path
|
||||
fromPath' = \case
|
||||
@ -256,9 +248,19 @@ hqSplitFromName' = fmap (fmap HQ'.fromName) . Lens.unsnoc . fromName'
|
||||
-- >>> splitFromName "foo"
|
||||
-- (,foo)
|
||||
splitFromName :: Name -> Split
|
||||
splitFromName name =
|
||||
splitFromName =
|
||||
over _1 fromPath' . splitFromName'
|
||||
|
||||
splitFromName' :: Name -> Split'
|
||||
splitFromName' name =
|
||||
case Name.reverseSegments name of
|
||||
(seg :| pathSegments) -> (fromList $ reverse pathSegments, seg)
|
||||
(seg :| pathSegments) ->
|
||||
let path = fromList (reverse pathSegments)
|
||||
in ( if Name.isAbsolute name
|
||||
then AbsolutePath' (Absolute path)
|
||||
else RelativePath' (Relative path),
|
||||
seg
|
||||
)
|
||||
|
||||
-- | Remove a path prefix from a name.
|
||||
-- Returns 'Nothing' if there are no remaining segments to construct the name from.
|
||||
@ -302,19 +304,20 @@ fromName :: Name -> Path
|
||||
fromName = fromList . List.NonEmpty.toList . Name.segments
|
||||
|
||||
fromName' :: Name -> Path'
|
||||
fromName' n = case take 1 (Name.toString n) of
|
||||
"." -> AbsolutePath' . Absolute $ Path seq
|
||||
_ -> RelativePath' $ Relative path
|
||||
fromName' n
|
||||
| Name.isAbsolute n = AbsolutePath' (Absolute path)
|
||||
| otherwise = RelativePath' (Relative path)
|
||||
where
|
||||
path = fromName n
|
||||
seq = toSeq path
|
||||
|
||||
unsafeToName :: Path -> Name
|
||||
unsafeToName = Name.unsafeFromText . toText
|
||||
unsafeToName =
|
||||
fromMaybe (error "empty path") . toName
|
||||
|
||||
-- | Convert a Path' to a Name
|
||||
unsafeToName' :: Path' -> Name
|
||||
unsafeToName' = Name.unsafeFromText . toText'
|
||||
unsafeToName' =
|
||||
fromMaybe (error "empty path") . toName'
|
||||
|
||||
toName :: Path -> Maybe Name
|
||||
toName = \case
|
||||
@ -347,12 +350,13 @@ instance Show Path where
|
||||
|
||||
-- | Note: This treats the path as relative.
|
||||
toText :: Path -> Text
|
||||
toText (Path nss) = intercalateMap "." NameSegment.toText nss
|
||||
toText =
|
||||
maybe Text.empty Name.toText . toName
|
||||
|
||||
fromText :: Text -> Path
|
||||
fromText = \case
|
||||
unsafeParseText :: Text -> Path
|
||||
unsafeParseText = \case
|
||||
"" -> empty
|
||||
t -> fromList $ NameSegment <$> NameSegment.segments' t
|
||||
text -> fromName (Name.unsafeParseText text)
|
||||
|
||||
-- | Construct a Path' from a text
|
||||
--
|
||||
@ -364,17 +368,17 @@ fromText = \case
|
||||
--
|
||||
-- >>> show $ fromText' ""
|
||||
-- ""
|
||||
fromText' :: Text -> Path'
|
||||
fromText' txt =
|
||||
case Text.uncons txt of
|
||||
Nothing -> relativeEmpty'
|
||||
Just ('.', p) -> AbsolutePath' . Absolute $ fromText p
|
||||
Just _ -> RelativePath' . Relative $ fromText txt
|
||||
unsafeParseText' :: Text -> Path'
|
||||
unsafeParseText' = \case
|
||||
"" -> RelativePath' (Relative mempty)
|
||||
"." -> AbsolutePath' (Absolute mempty)
|
||||
text -> fromName' (Name.unsafeParseText text)
|
||||
|
||||
toText' :: Path' -> Text
|
||||
toText' = \case
|
||||
AbsolutePath' (Absolute path) -> Text.cons '.' (toText path)
|
||||
RelativePath' (Relative path) -> toText path
|
||||
toText' path =
|
||||
case toName' path of
|
||||
Nothing -> if isAbsolute path then "." else ""
|
||||
Just name -> Name.toText name
|
||||
|
||||
{-# COMPLETE Empty, (:<) #-}
|
||||
|
||||
@ -523,7 +527,8 @@ instance Convert HQSplit (HQ'.HashQualified Path) where convert = unsplitHQ
|
||||
|
||||
instance Convert HQSplit' (HQ'.HashQualified Path') where convert = unsplitHQ'
|
||||
|
||||
instance Convert Name Split where convert = splitFromName
|
||||
instance Convert Name Split where
|
||||
convert = splitFromName
|
||||
|
||||
instance Convert (path, NameSegment) (path, HQ'.HQSegment) where
|
||||
convert (path, name) =
|
||||
|
@ -1,167 +1,104 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
module Unison.Codebase.Path.Parse
|
||||
( parsePath',
|
||||
parsePathImpl',
|
||||
( -- * Path parsing functions
|
||||
parsePath,
|
||||
parsePath',
|
||||
parseSplit,
|
||||
parseSplit',
|
||||
definitionNameSegment,
|
||||
parseHQSplit,
|
||||
parseHQSplit',
|
||||
parseShortHashOrHQSplit',
|
||||
wordyNameSegment,
|
||||
|
||||
-- * Path parsers
|
||||
pathP,
|
||||
pathP',
|
||||
splitP,
|
||||
splitP',
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Lens (over, _1)
|
||||
import Control.Lens qualified as Lens
|
||||
import Data.List.Extra (stripPrefix)
|
||||
import Data.Text qualified as Text
|
||||
import Text.Megaparsec (Parsec)
|
||||
import Text.Megaparsec qualified as P
|
||||
import Text.Megaparsec.Char qualified as P (char)
|
||||
import Text.Megaparsec.Internal qualified as P (withParsecT)
|
||||
import Unison.Codebase.Path
|
||||
import Unison.HashQualified' qualified as HQ'
|
||||
import Unison.NameSegment (NameSegment (NameSegment))
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Prelude hiding (empty, toList)
|
||||
import Unison.ShortHash (ShortHash)
|
||||
import Unison.ShortHash qualified as SH
|
||||
import Unison.Syntax.Lexer qualified as Lexer
|
||||
import Unison.Syntax.Name qualified as Name
|
||||
import Unison.Syntax.NameSegment qualified as NameSegment (renderParseErr)
|
||||
import Unison.Syntax.ShortHash qualified as ShortHash
|
||||
|
||||
-- .libs.blah.poo is Absolute
|
||||
-- libs.blah.poo is Relative
|
||||
-- Left is some parse error tbd
|
||||
parsePath' :: String -> Either String Path'
|
||||
parsePath' p = case parsePathImpl' p of
|
||||
Left e -> Left e
|
||||
Right (p, "") -> Right p
|
||||
Right (p, rem) -> case parseSegment rem of
|
||||
Right (seg, "") -> Right (unsplit' (p, NameSegment . Text.pack $ seg))
|
||||
Right (_, rem) ->
|
||||
Left ("extra characters after " <> show p <> ": " <> show rem)
|
||||
Left e -> Left e
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- Path parsing functions
|
||||
|
||||
-- implementation detail of parsePath' and parseSplit'
|
||||
-- foo.bar.baz.34 becomes `Right (foo.bar.baz, "34")
|
||||
-- foo.bar.baz becomes `Right (foo.bar, "baz")
|
||||
-- baz becomes `Right (, "baz")
|
||||
-- foo.bar.baz#a8fj becomes `Left`; we don't hash-qualify paths.
|
||||
-- TODO: Get rid of this thing.
|
||||
parsePathImpl' :: String -> Either String (Path', String)
|
||||
parsePathImpl' p = case p of
|
||||
"." -> Right (Path' . Left $ absoluteEmpty, "")
|
||||
'.' : p -> over _1 (Path' . Left . Absolute . fromList) <$> segs p
|
||||
p -> over _1 (Path' . Right . Relative . fromList) <$> segs p
|
||||
where
|
||||
go f p = case f p of
|
||||
Right (a, "") -> case Lens.unsnoc (NameSegment.segments' $ Text.pack a) of
|
||||
Nothing -> Left "empty path"
|
||||
Just (segs, last) -> Right (NameSegment <$> segs, Text.unpack last)
|
||||
Right (segs, '.' : rem) ->
|
||||
let segs' = NameSegment.segments' (Text.pack segs)
|
||||
in Right (NameSegment <$> segs', rem)
|
||||
Right (segs, rem) ->
|
||||
Left $ "extra characters after " <> segs <> ": " <> show rem
|
||||
Left e -> Left e
|
||||
segs p = go parseSegment p
|
||||
parsePath :: String -> Either Text Path
|
||||
parsePath =
|
||||
runParser pathP
|
||||
|
||||
parseSegment :: String -> Either String (String, String)
|
||||
parseSegment s =
|
||||
first show
|
||||
. (Lexer.wordyId <> Lexer.symbolyId)
|
||||
<> unit'
|
||||
<> const (Left ("I expected an identifier but found " <> s))
|
||||
$ s
|
||||
parsePath' :: String -> Either Text Path'
|
||||
parsePath' = \case
|
||||
"" -> Right relativeEmpty'
|
||||
"." -> Right absoluteEmpty'
|
||||
path -> unsplit' <$> parseSplit' path
|
||||
|
||||
wordyNameSegment, definitionNameSegment :: String -> Either String NameSegment
|
||||
wordyNameSegment s = case Lexer.wordyId0 s of
|
||||
Left e -> Left (show e)
|
||||
Right (a, "") -> Right (NameSegment (Text.pack a))
|
||||
Right (a, rem) ->
|
||||
Left $ "trailing characters after " <> show a <> ": " <> show rem
|
||||
parseSplit :: String -> Either Text Split
|
||||
parseSplit =
|
||||
runParser splitP
|
||||
|
||||
-- Parse a name segment like "()"
|
||||
unit' :: String -> Either String (String, String)
|
||||
unit' s = case stripPrefix "()" s of
|
||||
Nothing -> Left $ "Expected () but found: " <> s
|
||||
Just rem -> Right ("()", rem)
|
||||
parseSplit' :: String -> Either Text Split'
|
||||
parseSplit' =
|
||||
runParser splitP'
|
||||
|
||||
unit :: String -> Either String NameSegment
|
||||
unit s = case unit' s of
|
||||
Right (_, "") -> Right $ NameSegment "()"
|
||||
Right (_, rem) -> Left $ "trailing characters after (): " <> show rem
|
||||
Left _ -> Left $ "I don't know how to parse " <> s
|
||||
parseShortHashOrHQSplit' :: String -> Either Text (Either ShortHash HQSplit')
|
||||
parseShortHashOrHQSplit' =
|
||||
runParser shortHashOrHqSplitP'
|
||||
|
||||
definitionNameSegment s = wordyNameSegment s <> symbolyNameSegment s <> unit s
|
||||
where
|
||||
symbolyNameSegment s = case Lexer.symbolyId0 s of
|
||||
Left e -> Left (show e)
|
||||
Right (a, "") -> Right (NameSegment (Text.pack a))
|
||||
Right (a, rem) ->
|
||||
Left $ "trailing characters after " <> show a <> ": " <> show rem
|
||||
parseHQSplit :: String -> Either Text HQSplit
|
||||
parseHQSplit s =
|
||||
parseHQSplit' s >>= \case
|
||||
(RelativePath' (Relative p), hqseg) -> Right (p, hqseg)
|
||||
_ -> Left $ "Sorry, you can't use an absolute name like " <> Text.pack s <> " here."
|
||||
|
||||
-- parseSplit' wordyNameSegment "foo.bar.baz" returns Right (foo.bar, baz)
|
||||
-- parseSplit' wordyNameSegment "foo.bar.+" returns Left err
|
||||
-- parseSplit' definitionNameSegment "foo.bar.+" returns Right (foo.bar, +)
|
||||
parseSplit' ::
|
||||
(String -> Either String NameSegment) ->
|
||||
String ->
|
||||
Either String Split'
|
||||
parseSplit' lastSegment p = do
|
||||
(p', rem) <- parsePathImpl' p
|
||||
seg <- lastSegment rem
|
||||
pure (p', seg)
|
||||
parseHQSplit' :: String -> Either Text HQSplit'
|
||||
parseHQSplit' =
|
||||
runParser hqSplitP'
|
||||
|
||||
parseShortHashOrHQSplit' :: String -> Either String (Either ShortHash HQSplit')
|
||||
parseShortHashOrHQSplit' s =
|
||||
case Text.breakOn "#" $ Text.pack s of
|
||||
("", "") -> error $ "encountered empty string parsing '" <> s <> "'"
|
||||
(n, "") -> do
|
||||
(p, rem) <- parsePathImpl' (Text.unpack n)
|
||||
seg <- definitionNameSegment rem
|
||||
pure $ Right (p, HQ'.NameOnly seg)
|
||||
("", sh) -> do
|
||||
sh <- maybeToRight (shError s) . SH.fromText $ sh
|
||||
pure $ Left sh
|
||||
(n, sh) -> do
|
||||
(p, rem) <- parsePathImpl' (Text.unpack n)
|
||||
seg <- definitionNameSegment rem
|
||||
hq <-
|
||||
maybeToRight (shError s)
|
||||
. fmap (\sh -> (p, HQ'.HashQualified seg sh))
|
||||
. SH.fromText
|
||||
$ sh
|
||||
pure $ Right hq
|
||||
where
|
||||
shError s = "couldn't parse shorthash from " <> s
|
||||
runParser :: Parsec (Lexer.Token Text) [Char] a -> String -> Either Text a
|
||||
runParser p =
|
||||
mapLeft (Text.pack . P.errorBundlePretty) . P.runParser (p <* P.eof) ""
|
||||
|
||||
parseHQSplit :: String -> Either String HQSplit
|
||||
parseHQSplit s = case parseHQSplit' s of
|
||||
Right (Path' (Right (Relative p)), hqseg) -> Right (p, hqseg)
|
||||
Right (Path' Left {}, _) ->
|
||||
Left $ "Sorry, you can't use an absolute name like " <> s <> " here."
|
||||
Left e -> Left e
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- Path parsers
|
||||
|
||||
parseHQSplit' :: String -> Either String HQSplit'
|
||||
parseHQSplit' s = case Text.breakOn "#" $ Text.pack s of
|
||||
("", "") -> error $ "encountered empty string parsing '" <> s <> "'"
|
||||
("", _) -> Left "Sorry, you can't use a hash-only reference here."
|
||||
(n, "") -> do
|
||||
(p, rem) <- parsePath n
|
||||
seg <- definitionNameSegment rem
|
||||
pure (p, HQ'.NameOnly seg)
|
||||
(n, sh) -> do
|
||||
(p, rem) <- parsePath n
|
||||
seg <- definitionNameSegment rem
|
||||
maybeToRight (shError s)
|
||||
. fmap (\sh -> (p, HQ'.HashQualified seg sh))
|
||||
. SH.fromText
|
||||
$ sh
|
||||
where
|
||||
shError s = "couldn't parse shorthash from " <> s
|
||||
parsePath n = do
|
||||
x <- parsePathImpl' $ Text.unpack n
|
||||
pure $ case x of
|
||||
(Path' (Left e), "") | e == absoluteEmpty -> (relativeEmpty', ".")
|
||||
x -> x
|
||||
pathP :: Parsec (Lexer.Token Text) [Char] Path
|
||||
pathP =
|
||||
(unsplit <$> splitP) <|> pure empty
|
||||
|
||||
pathP' :: Parsec (Lexer.Token Text) [Char] Path'
|
||||
pathP' =
|
||||
asum
|
||||
[ unsplit' <$> splitP',
|
||||
P.char '.' $> absoluteEmpty',
|
||||
pure relativeEmpty'
|
||||
]
|
||||
|
||||
splitP :: Parsec (Lexer.Token Text) [Char] Split
|
||||
splitP =
|
||||
splitFromName <$> P.withParsecT (fmap NameSegment.renderParseErr) Name.relativeNameP
|
||||
|
||||
splitP' :: Parsec (Lexer.Token Text) [Char] Split'
|
||||
splitP' =
|
||||
splitFromName' <$> P.withParsecT (fmap NameSegment.renderParseErr) Name.nameP
|
||||
|
||||
shortHashOrHqSplitP' :: Parsec (Lexer.Token Text) [Char] (Either ShortHash HQSplit')
|
||||
shortHashOrHqSplitP' =
|
||||
Left <$> ShortHash.shortHashP <|> Right <$> hqSplitP'
|
||||
|
||||
hqSplitP' :: Parsec (Lexer.Token Text) [Char] HQSplit'
|
||||
hqSplitP' = do
|
||||
(segs, seg) <- splitP'
|
||||
P.optional (P.withParsecT (fmap ("invalid hash: " <>)) ShortHash.shortHashP) <&> \case
|
||||
Nothing -> (segs, HQ'.fromName seg)
|
||||
Just hash -> (segs, HQ'.HashQualified seg hash)
|
||||
|
@ -23,7 +23,7 @@ import Unison.Reference (Reference, pattern Derived)
|
||||
import Unison.Referent (Referent)
|
||||
import Unison.Referent qualified as Referent
|
||||
import Unison.Util.Relation qualified as R
|
||||
import Unison.Util.Star3 qualified as Star3
|
||||
import Unison.Util.Star2 qualified as Star2
|
||||
|
||||
type Branches m = [(CausalHash, m (Branch m))]
|
||||
|
||||
@ -67,9 +67,9 @@ fromBranch0 b =
|
||||
fromChildren :: (Applicative m) => Map NameSegment (Branch m) -> Branches m
|
||||
fromChildren m = [(Branch.headHash b, pure b) | b <- toList m]
|
||||
references :: Branch.Star r NameSegment -> [r]
|
||||
references = toList . R.dom . Star3.d1
|
||||
references = toList . R.dom . Star2.d1
|
||||
mdValues :: Branch.Star r NameSegment -> [Reference]
|
||||
mdValues = fmap snd . toList . R.ran . Star3.d3
|
||||
mdValues = toList . R.ran . Star2.d2
|
||||
fromTermsStar :: Branch.Star Referent NameSegment -> Dependencies
|
||||
fromTermsStar s = Dependencies mempty terms decls
|
||||
where
|
||||
|
@ -51,7 +51,7 @@ import Unison.Term qualified as V1.Term
|
||||
import Unison.Type qualified as V1.Type
|
||||
import Unison.Util.Map qualified as Map
|
||||
import Unison.Util.Relation qualified as Relation
|
||||
import Unison.Util.Star3 qualified as V1.Star3
|
||||
import Unison.Util.Star2 qualified as V1.Star2
|
||||
import Unison.Var qualified as Var
|
||||
import Unison.WatchKind qualified as V1.WK
|
||||
|
||||
@ -435,13 +435,12 @@ causalbranch1to2 (V1.Branch.Branch c) =
|
||||
doTerms s =
|
||||
Map.fromList
|
||||
[ (ns, m2)
|
||||
| ns <- toList . Relation.ran $ V1.Star3.d1 s,
|
||||
| ns <- toList . Relation.ran $ V1.Star2.d1 s,
|
||||
let m2 =
|
||||
Map.fromList
|
||||
[ (referent1to2 r, pure md)
|
||||
| r <- toList . Relation.lookupRan ns $ V1.Star3.d1 s,
|
||||
let mdrefs1to2 (typeR1, valR1) = (reference1to2 valR1, reference1to2 typeR1)
|
||||
md = V2.Branch.MdValues . Map.fromList . map mdrefs1to2 . toList . Relation.lookupDom r $ V1.Star3.d3 s
|
||||
| r <- toList . Relation.lookupRan ns $ V1.Star2.d1 s,
|
||||
let md = V2.Branch.MdValues . Set.map reference1to2 . Relation.lookupDom r $ V1.Star2.d2 s
|
||||
]
|
||||
]
|
||||
|
||||
@ -449,13 +448,12 @@ causalbranch1to2 (V1.Branch.Branch c) =
|
||||
doTypes s =
|
||||
Map.fromList
|
||||
[ (ns, m2)
|
||||
| ns <- toList . Relation.ran $ V1.Star3.d1 s,
|
||||
| ns <- toList . Relation.ran $ V1.Star2.d1 s,
|
||||
let m2 =
|
||||
Map.fromList
|
||||
[ (reference1to2 r, pure md)
|
||||
| r <- toList . Relation.lookupRan ns $ V1.Star3.d1 s,
|
||||
let mdrefs1to2 (typeR1, valR1) = (reference1to2 valR1, reference1to2 typeR1)
|
||||
md = V2.Branch.MdValues . Map.fromList . map mdrefs1to2 . toList . Relation.lookupDom r $ V1.Star3.d3 s
|
||||
| r <- toList . Relation.lookupRan ns $ V1.Star2.d1 s,
|
||||
let md = V2.Branch.MdValues . Set.map reference1to2 . Relation.lookupDom r $ V1.Star2.d2 s
|
||||
]
|
||||
]
|
||||
|
||||
@ -529,11 +527,9 @@ branch2to1 branchCache lookupCT (V2.Branch.Branch v2terms v2types v2patches v2ch
|
||||
insert' name star (ref, V2.Branch.MdValues mdvals) =
|
||||
let facts = Set.singleton ref
|
||||
names = Relation.singleton ref name
|
||||
types :: Relation.Relation ref V1.Metadata.Type =
|
||||
Relation.insertManyRan ref (fmap mdref2to1 (Map.elems mdvals)) mempty
|
||||
vals :: Relation.Relation ref (V1.Metadata.Type, V1.Metadata.Value) =
|
||||
Relation.insertManyRan ref (fmap (\(v, t) -> (mdref2to1 t, mdref2to1 v)) (Map.toList mdvals)) mempty
|
||||
in star <> V1.Star3.Star3 facts names types vals
|
||||
vals :: Relation.Relation ref V1.Metadata.Value =
|
||||
Relation.insertManyRan ref (map mdref2to1 (Set.toList mdvals)) mempty
|
||||
in star <> V1.Star2.Star2 facts names vals
|
||||
|
||||
-- | Generates a v1 short hash from a v2 referent.
|
||||
-- Also shortens the hash to the provided length. If 'Nothing', it will include the full
|
||||
|
@ -27,6 +27,7 @@ import Unison.Reference qualified as Reference
|
||||
import Unison.Referent (Referent)
|
||||
import Unison.Referent qualified as Referent
|
||||
import Unison.Result qualified as Result
|
||||
import Unison.Syntax.Var qualified as Var (namespaced)
|
||||
import Unison.Term qualified as Term
|
||||
import Unison.Type qualified as Type
|
||||
import Unison.Typechecker qualified as Typechecker
|
||||
@ -83,7 +84,7 @@ hashFieldAccessors ::
|
||||
)
|
||||
hashFieldAccessors ppe declName vars declRef dd = do
|
||||
let accessors :: [(v, (), Term.Term v ())]
|
||||
accessors = DD.generateRecordAccessors mempty (map (,()) vars) declName declRef
|
||||
accessors = DD.generateRecordAccessors Var.namespaced mempty (map (,()) vars) declName declRef
|
||||
let typeLookup :: TypeLookup v ()
|
||||
typeLookup =
|
||||
TypeLookup
|
||||
|
@ -26,7 +26,7 @@ import Unison.Reference (Reference)
|
||||
import Unison.Referent qualified as Referent
|
||||
import Unison.Result (CompilerBug (..), Note (..), ResultT, pattern Result)
|
||||
import Unison.Result qualified as Result
|
||||
import Unison.Syntax.Name qualified as Name (toText, unsafeFromVar)
|
||||
import Unison.Syntax.Name qualified as Name (toText, unsafeParseVar)
|
||||
import Unison.Syntax.Parser qualified as Parser
|
||||
import Unison.Term qualified as Term
|
||||
import Unison.Type qualified as Type
|
||||
@ -96,7 +96,7 @@ computeTypecheckingEnvironment shouldUseTndr ambientAbilities typeLookupf uf =
|
||||
[ (Name.toText name, Var.name v, r)
|
||||
| (name, r) <- Rel.toList (Names.terms preexistingNames),
|
||||
v <- Set.toList (Term.freeVars tm),
|
||||
name `Name.endsWithReverseSegments` List.NonEmpty.toList (Name.reverseSegments (Name.unsafeFromVar v))
|
||||
name `Name.endsWithReverseSegments` List.NonEmpty.toList (Name.reverseSegments (Name.unsafeParseVar v))
|
||||
]
|
||||
possibleRefs = Referent.toReference . view _3 <$> possibleDeps
|
||||
tl <- fmap (UF.declsToTypeLookup uf <>) (typeLookupf (UF.dependencies uf <> Set.fromList possibleRefs))
|
||||
@ -122,7 +122,7 @@ computeTypecheckingEnvironment shouldUseTndr ambientAbilities typeLookupf uf =
|
||||
[ (Var.name v, nr)
|
||||
| (name, r) <- Rel.toList (Names.terms $ UF.toNames uf),
|
||||
v <- Set.toList (Term.freeVars tm),
|
||||
name `Name.endsWithReverseSegments` List.NonEmpty.toList (Name.reverseSegments (Name.unsafeFromVar v)),
|
||||
name `Name.endsWithReverseSegments` List.NonEmpty.toList (Name.reverseSegments (Name.unsafeParseVar v)),
|
||||
typ <- toList $ TL.typeOfReferent tl r,
|
||||
let nr = Typechecker.NamedReference (Name.toText name) typ (Right r)
|
||||
]
|
||||
|
@ -45,12 +45,12 @@ import Unison.Names.ResolutionResult (ResolutionResult)
|
||||
import Unison.Pattern qualified as Memory.Pattern
|
||||
import Unison.Reference qualified as Memory.Reference
|
||||
import Unison.Referent qualified as Memory.Referent
|
||||
import Unison.Syntax.Name qualified as Name (unsafeFromVar)
|
||||
import Unison.Syntax.Name qualified as Name (unsafeParseVar)
|
||||
import Unison.Term qualified as Memory.Term
|
||||
import Unison.Type qualified as Memory.Type
|
||||
import Unison.Util.Map qualified as Map
|
||||
import Unison.Util.Relation qualified as Relation
|
||||
import Unison.Util.Star3 qualified as Memory.Star3
|
||||
import Unison.Util.Star2 qualified as Memory.Star2
|
||||
import Unison.Var (Var)
|
||||
|
||||
typeToReference :: (Var v) => Memory.Type.Type v a -> Memory.Reference.Reference
|
||||
@ -230,7 +230,7 @@ hashDataDecls ::
|
||||
ResolutionResult v a [(v, Memory.Reference.Id, Memory.DD.DataDeclaration v a)]
|
||||
hashDataDecls memDecls = do
|
||||
let hashingDecls = fmap m2hDecl memDecls
|
||||
hashingResult <- Hashing.hashDecls Name.unsafeFromVar hashingDecls
|
||||
hashingResult <- Hashing.hashDecls Name.unsafeParseVar hashingDecls
|
||||
pure $ map h2mDeclResult hashingResult
|
||||
where
|
||||
h2mDeclResult :: (Ord v) => (v, Hashing.ReferenceId, Hashing.DataDeclaration v a) -> (v, Memory.Reference.Id, Memory.DD.DataDeclaration v a)
|
||||
@ -374,13 +374,12 @@ m2hBranch0 b =
|
||||
doTerms s =
|
||||
Map.fromList
|
||||
[ (m2hNameSegment ns, m2)
|
||||
| ns <- toList . Relation.ran $ Memory.Star3.d1 s,
|
||||
| ns <- toList . Relation.ran $ Memory.Star2.d1 s,
|
||||
let m2 =
|
||||
Map.fromList
|
||||
[ (fst (Writer.runWriter (m2hReferent r)), md)
|
||||
| r <- toList . Relation.lookupRan ns $ Memory.Star3.d1 s,
|
||||
let mdrefs1to2 (_typeR1, valR1) = m2hReference valR1
|
||||
md = Hashing.MdValues . Set.map mdrefs1to2 . Relation.lookupDom r $ Memory.Star3.d3 s
|
||||
| r <- toList . Relation.lookupRan ns $ Memory.Star2.d1 s,
|
||||
let md = Hashing.MdValues . Set.map m2hReference . Relation.lookupDom r $ Memory.Star2.d2 s
|
||||
]
|
||||
]
|
||||
|
||||
@ -390,14 +389,13 @@ m2hBranch0 b =
|
||||
doTypes s =
|
||||
Map.fromList
|
||||
[ (m2hNameSegment ns, m2)
|
||||
| ns <- toList . Relation.ran $ Memory.Star3.d1 s,
|
||||
| ns <- toList . Relation.ran $ Memory.Star2.d1 s,
|
||||
let m2 =
|
||||
Map.fromList
|
||||
[ (m2hReference r, md)
|
||||
| r <- toList . Relation.lookupRan ns $ Memory.Star3.d1 s,
|
||||
let mdrefs1to2 (_typeR1, valR1) = m2hReference valR1
|
||||
md :: Hashing.MdValues
|
||||
md = Hashing.MdValues . Set.map mdrefs1to2 . Relation.lookupDom r $ Memory.Star3.d3 s
|
||||
| r <- toList . Relation.lookupRan ns $ Memory.Star2.d1 s,
|
||||
let md :: Hashing.MdValues
|
||||
md = Hashing.MdValues . Set.map m2hReference . Relation.lookupDom r $ Memory.Star2.d2 s
|
||||
]
|
||||
]
|
||||
|
||||
@ -412,4 +410,5 @@ m2hBranch0 b =
|
||||
doChildren = Map.bimap m2hNameSegment (unCausalHash . Memory.Branch.headHash)
|
||||
|
||||
m2hNameSegment :: Memory.NameSegment.NameSegment -> Hashing.NameSegment
|
||||
m2hNameSegment (Memory.NameSegment.NameSegment s) = Hashing.NameSegment s
|
||||
m2hNameSegment =
|
||||
Hashing.NameSegment . Memory.NameSegment.toUnescapedText
|
||||
|
@ -4,7 +4,7 @@ import Data.Map qualified as Map
|
||||
import Unison.HashQualified qualified as HQ
|
||||
import Unison.Name (Name)
|
||||
import Unison.Prelude
|
||||
import Unison.Syntax.Name qualified as Name (unsafeFromText)
|
||||
import Unison.Syntax.Name qualified as Name (unsafeParseText)
|
||||
|
||||
-- Type aliases relating to Fully-Qualified Names, e.g. 'Acme.API.foo'
|
||||
-- Used primarily by the FQN elision code - see TermPrinter.PrintAnnotation.
|
||||
@ -25,7 +25,7 @@ elideFQN imports hq =
|
||||
let hash = HQ.toHash hq
|
||||
name' = do
|
||||
name <- HQ.toName hq
|
||||
let hit = fmap Name.unsafeFromText (Map.lookup name imports)
|
||||
let hit = fmap Name.unsafeParseText (Map.lookup name imports)
|
||||
-- Cut out the "const id $" to get tracing of FQN elision attempts.
|
||||
let t = const id $ trace ("hit: " ++ show hit ++ " finding: " ++ show hq ++ " in imports: " ++ show imports)
|
||||
t (pure $ fromMaybe name hit)
|
||||
|
@ -39,7 +39,6 @@ import Unison.Kind qualified as Kind
|
||||
import Unison.KindInference.Error.Pretty (prettyKindError)
|
||||
import Unison.Name (Name)
|
||||
import Unison.Name qualified as Name
|
||||
import Unison.NameSegment (NameSegment (..))
|
||||
import Unison.Names qualified as Names
|
||||
import Unison.Names.ResolutionResult qualified as Names
|
||||
import Unison.Parser.Ann (Ann (..))
|
||||
@ -53,7 +52,7 @@ import Unison.Result (Note (..))
|
||||
import Unison.Result qualified as Result
|
||||
import Unison.Settings qualified as Settings
|
||||
import Unison.Symbol (Symbol)
|
||||
import Unison.Syntax.HashQualified qualified as HQ (toString)
|
||||
import Unison.Syntax.HashQualified qualified as HQ (toText)
|
||||
import Unison.Syntax.Lexer qualified as L
|
||||
import Unison.Syntax.Name qualified as Name (toText)
|
||||
import Unison.Syntax.NamePrinter (prettyHashQualified0)
|
||||
@ -1223,15 +1222,15 @@ renderKind Kind.Star = "*"
|
||||
renderKind (Kind.Arrow k1 k2) = renderKind k1 <> " -> " <> renderKind k2
|
||||
|
||||
showTermRef :: (IsString s) => Env -> Referent -> s
|
||||
showTermRef env r = fromString . HQ.toString $ PPE.termName env r
|
||||
showTermRef env r = fromString . Text.unpack . HQ.toText $ PPE.termName env r
|
||||
|
||||
showTypeRef :: (IsString s) => Env -> R.Reference -> s
|
||||
showTypeRef env r = fromString . HQ.toString $ PPE.typeName env r
|
||||
showTypeRef env r = fromString . Text.unpack . HQ.toText $ PPE.typeName env r
|
||||
|
||||
-- todo: do something different/better if cid not found
|
||||
showConstructor :: (IsString s) => Env -> ConstructorReference -> s
|
||||
showConstructor env r =
|
||||
fromString . HQ.toString $
|
||||
fromString . Text.unpack . HQ.toText $
|
||||
PPE.patternName env r
|
||||
|
||||
_posToEnglish :: (IsString s) => L.Pos -> s
|
||||
@ -1679,7 +1678,7 @@ renderParseErrors s = \case
|
||||
else unknownTypesMsg <> "\n\n" <> dupDataAndAbilitiesMsg
|
||||
in (msgs, allRanges)
|
||||
go (Parser.DidntExpectExpression _tok (Just t@(L.payload -> L.SymbolyId (HQ'.NameOnly name))))
|
||||
| name == Name.fromSegment (NameSegment "::") =
|
||||
| name == Name.fromSegment "::" =
|
||||
let msg =
|
||||
mconcat
|
||||
[ "This looks like the start of an expression here but I was expecting a binding.",
|
||||
@ -1783,10 +1782,10 @@ renderParseErrors s = \case
|
||||
let msg =
|
||||
Pr.lines
|
||||
[ if missing
|
||||
then "I couldn't resolve the reference " <> style ErrorSite (HQ.toString (L.payload tok)) <> "."
|
||||
else "The reference " <> style ErrorSite (HQ.toString (L.payload tok)) <> " was ambiguous.",
|
||||
then "I couldn't resolve the reference " <> style ErrorSite (Text.unpack (HQ.toText (L.payload tok))) <> "."
|
||||
else "The reference " <> style ErrorSite (Text.unpack (HQ.toText (L.payload tok))) <> " was ambiguous.",
|
||||
"",
|
||||
tokenAsErrorSite s $ HQ.toString <$> tok,
|
||||
tokenAsErrorSite s $ HQ.toText <$> tok,
|
||||
if missing
|
||||
then "Make sure it's spelled correctly."
|
||||
else "Try hash-qualifying the term you meant to reference."
|
||||
@ -1798,10 +1797,10 @@ renderParseErrors s = \case
|
||||
let msg =
|
||||
Pr.lines
|
||||
[ if Set.null referents
|
||||
then "I couldn't find a term for " <> style ErrorSite (HQ.toString (L.payload tok)) <> "."
|
||||
else "The term reference " <> style ErrorSite (HQ.toString (L.payload tok)) <> " was ambiguous.",
|
||||
then "I couldn't find a term for " <> style ErrorSite (Text.unpack (HQ.toText (L.payload tok))) <> "."
|
||||
else "The term reference " <> style ErrorSite (Text.unpack (HQ.toText (L.payload tok))) <> " was ambiguous.",
|
||||
"",
|
||||
tokenAsErrorSite s $ HQ.toString <$> tok,
|
||||
tokenAsErrorSite s $ HQ.toText <$> tok,
|
||||
if missing
|
||||
then "Make sure it's spelled correctly."
|
||||
else "Try hash-qualifying the term you meant to reference."
|
||||
@ -1813,10 +1812,10 @@ renderParseErrors s = \case
|
||||
let msg =
|
||||
Pr.lines
|
||||
[ if Set.null referents
|
||||
then "I couldn't find a type for " <> style ErrorSite (HQ.toString (L.payload tok)) <> "."
|
||||
else "The type reference " <> style ErrorSite (HQ.toString (L.payload tok)) <> " was ambiguous.",
|
||||
then "I couldn't find a type for " <> style ErrorSite (Text.unpack (HQ.toText (L.payload tok))) <> "."
|
||||
else "The type reference " <> style ErrorSite (Text.unpack (HQ.toText (L.payload tok))) <> " was ambiguous.",
|
||||
"",
|
||||
tokenAsErrorSite s $ HQ.toString <$> tok,
|
||||
tokenAsErrorSite s $ HQ.toText <$> tok,
|
||||
if missing
|
||||
then "Make sure it's spelled correctly."
|
||||
else "Try hash-qualifying the type you meant to reference."
|
||||
|
@ -8,6 +8,8 @@ module Unison.Project.Util
|
||||
projectContextFromPath,
|
||||
pattern UUIDNameSegment,
|
||||
ProjectContext (..),
|
||||
pattern ProjectsNameSegment,
|
||||
pattern BranchesNameSegment,
|
||||
)
|
||||
where
|
||||
|
||||
@ -18,6 +20,7 @@ import Data.UUID qualified as UUID
|
||||
import U.Codebase.Sqlite.DbId (ProjectBranchId (..), ProjectId (..))
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.NameSegment (NameSegment (..))
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Project (ProjectAndBranch (..))
|
||||
|
||||
-- | Get the path that a project is stored at. Users aren't supposed to go here.
|
||||
@ -34,7 +37,7 @@ projectPath projectId =
|
||||
-- .__projects._ABCD.branches
|
||||
projectBranchesPath :: ProjectId -> Path.Absolute
|
||||
projectBranchesPath projectId =
|
||||
snoc (projectPath projectId) "branches"
|
||||
snoc (projectPath projectId) BranchesNameSegment
|
||||
|
||||
-- | Get the path that a branch is stored at. Users aren't supposed to go here.
|
||||
--
|
||||
@ -54,9 +57,12 @@ projectBranchSegment (ProjectBranchId branchId) =
|
||||
|
||||
pattern UUIDNameSegment :: UUID -> NameSegment
|
||||
pattern UUIDNameSegment uuid <-
|
||||
NameSegment (Text.uncons -> Just ('_', UUID.fromText . Text.map (\c -> if c == '_' then '-' else c) -> Just uuid))
|
||||
( NameSegment.toUnescapedText ->
|
||||
(Text.uncons -> Just ('_', UUID.fromText . Text.map (\c -> if c == '_' then '-' else c) -> Just uuid))
|
||||
)
|
||||
where
|
||||
UUIDNameSegment uuid = NameSegment (Text.cons '_' (Text.map (\c -> if c == '-' then '_' else c) (UUID.toText uuid)))
|
||||
UUIDNameSegment uuid =
|
||||
NameSegment (Text.cons '_' (Text.map (\c -> if c == '-' then '_' else c) (UUID.toText uuid)))
|
||||
|
||||
-- | The prism between paths like
|
||||
--
|
||||
@ -75,16 +81,12 @@ projectPathPrism =
|
||||
where
|
||||
toPath :: ProjectId -> Path.Absolute
|
||||
toPath projectId =
|
||||
Path.Absolute $
|
||||
Path.fromList
|
||||
[ "__projects",
|
||||
UUIDNameSegment (unProjectId projectId)
|
||||
]
|
||||
Path.Absolute (Path.fromList [ProjectsNameSegment, UUIDNameSegment (unProjectId projectId)])
|
||||
|
||||
toId :: Path.Absolute -> Maybe ProjectId
|
||||
toId path =
|
||||
case Path.toList (Path.unabsolute path) of
|
||||
["__projects", UUIDNameSegment projectId] -> Just (ProjectId projectId)
|
||||
[ProjectsNameSegment, UUIDNameSegment projectId] -> Just (ProjectId projectId)
|
||||
_ -> Nothing
|
||||
|
||||
-- | The prism between paths like
|
||||
@ -106,9 +108,9 @@ projectBranchPathPrism =
|
||||
toPath (ProjectAndBranch {project = projectId, branch = branchId}, restPath) =
|
||||
Path.Absolute $
|
||||
Path.fromList
|
||||
( [ "__projects",
|
||||
( [ ProjectsNameSegment,
|
||||
UUIDNameSegment (unProjectId projectId),
|
||||
"branches",
|
||||
BranchesNameSegment,
|
||||
UUIDNameSegment (unProjectBranchId branchId)
|
||||
]
|
||||
++ Path.toList restPath
|
||||
@ -117,7 +119,7 @@ projectBranchPathPrism =
|
||||
toIds :: Path.Absolute -> Maybe (ProjectAndBranch ProjectId ProjectBranchId, Path.Path)
|
||||
toIds path =
|
||||
case Path.toList (Path.unabsolute path) of
|
||||
"__projects" : UUIDNameSegment projectId : "branches" : UUIDNameSegment branchId : restPath ->
|
||||
ProjectsNameSegment : UUIDNameSegment projectId : BranchesNameSegment : UUIDNameSegment branchId : restPath ->
|
||||
Just (ProjectAndBranch {project = ProjectId projectId, branch = ProjectBranchId branchId}, Path.fromList restPath)
|
||||
_ -> Nothing
|
||||
|
||||
@ -136,3 +138,23 @@ projectContextFromPath path =
|
||||
ProjectBranchPath projectId branchId restPath
|
||||
Nothing ->
|
||||
LooseCodePath path
|
||||
|
||||
pattern ProjectsNameSegment :: NameSegment
|
||||
pattern ProjectsNameSegment <-
|
||||
((== projectsNameSegment) -> True)
|
||||
where
|
||||
ProjectsNameSegment = projectsNameSegment
|
||||
|
||||
pattern BranchesNameSegment :: NameSegment
|
||||
pattern BranchesNameSegment <-
|
||||
((== branchesNameSegment) -> True)
|
||||
where
|
||||
BranchesNameSegment = branchesNameSegment
|
||||
|
||||
projectsNameSegment :: NameSegment
|
||||
projectsNameSegment =
|
||||
"__projects"
|
||||
|
||||
branchesNameSegment :: NameSegment
|
||||
branchesNameSegment =
|
||||
"branches"
|
||||
|
@ -101,7 +101,7 @@ import Unison.ConstructorReference (ConstructorReference, GConstructorReference
|
||||
import Unison.Hashing.V2.Convert (hashTermComponentsWithoutTypes)
|
||||
import Unison.Pattern (SeqOp (..))
|
||||
import Unison.Pattern qualified as P
|
||||
import Unison.Prelude hiding (Text)
|
||||
import Unison.Prelude
|
||||
import Unison.Reference (Id, Reference, Reference' (Builtin, DerivedId))
|
||||
import Unison.Referent (Referent, pattern Con, pattern Ref)
|
||||
import Unison.Symbol (Symbol)
|
||||
@ -621,11 +621,11 @@ saturate dat = ABT.visitPure $ \case
|
||||
fvs = foldMap freeVars args
|
||||
args' = saturate dat <$> args
|
||||
|
||||
addDefaultCases :: (Var v) => (Monoid a) => String -> Term v a -> Term v a
|
||||
addDefaultCases :: (Var v) => (Monoid a) => Text -> Term v a -> Term v a
|
||||
addDefaultCases = ABT.visitPure . defaultCaseVisitor
|
||||
|
||||
defaultCaseVisitor ::
|
||||
(Var v) => (Monoid a) => String -> Term v a -> Maybe (Term v a)
|
||||
(Var v) => (Monoid a) => Text -> Term v a -> Maybe (Term v a)
|
||||
defaultCaseVisitor func m@(Match' scrut cases)
|
||||
| scrut <- addDefaultCases func scrut,
|
||||
cases <- fmap (addDefaultCases func) <$> cases =
|
||||
@ -634,7 +634,7 @@ defaultCaseVisitor func m@(Match' scrut cases)
|
||||
a = ABT.annotation m
|
||||
v = Var.freshIn mempty $ typed Var.Blank
|
||||
txt = "pattern match failure in function `" <> func <> "`"
|
||||
msg = text a $ Data.Text.pack txt
|
||||
msg = text a txt
|
||||
bu = ref a (Builtin "bug")
|
||||
dflt =
|
||||
MatchCase (P.Var a) Nothing
|
||||
|
@ -109,7 +109,7 @@ import Unison.Runtime.Pattern
|
||||
import Unison.Runtime.Serialize as SER
|
||||
import Unison.Runtime.Stack
|
||||
import Unison.Symbol (Symbol)
|
||||
import Unison.Syntax.HashQualified qualified as HQ (toString)
|
||||
import Unison.Syntax.HashQualified qualified as HQ (toText)
|
||||
import Unison.Syntax.NamePrinter (prettyHashQualified)
|
||||
import Unison.Syntax.TermPrinter
|
||||
import Unison.Term qualified as Tm
|
||||
@ -529,7 +529,7 @@ intermediateTerms ppe ctx rtms =
|
||||
. splitPatterns (dspec ctx)
|
||||
. addDefaultCases tmName
|
||||
where
|
||||
tmName = HQ.toString . termName ppe $ RF.Ref ref
|
||||
tmName = HQ.toText . termName ppe $ RF.Ref ref
|
||||
where
|
||||
orig =
|
||||
Map.fromList
|
||||
@ -597,7 +597,7 @@ intermediateTerm ppe ctx tm =
|
||||
case normalizeTerm ctx tm of
|
||||
(ref, frem, cmbs, dcmp) -> (ref, frem, fmap f cmbs, dcmp)
|
||||
where
|
||||
tmName = HQ.toString . termName ppe $ RF.Ref ref
|
||||
tmName = HQ.toText . termName ppe $ RF.Ref ref
|
||||
f =
|
||||
superNormalize
|
||||
. splitPatterns (dspec ctx)
|
||||
|
@ -5,6 +5,7 @@ where
|
||||
|
||||
import Control.Lens
|
||||
import Control.Monad.Reader (MonadReader (..))
|
||||
import Data.List.NonEmpty (pattern (:|))
|
||||
import Data.List.NonEmpty qualified as NonEmpty
|
||||
import Data.Map qualified as Map
|
||||
import Text.Megaparsec qualified as P
|
||||
@ -15,14 +16,15 @@ import Unison.Name qualified as Name
|
||||
import Unison.Parser.Ann (Ann)
|
||||
import Unison.Prelude
|
||||
import Unison.Syntax.Lexer qualified as L
|
||||
import Unison.Syntax.Name qualified as Name (toText, unsafeFromVar)
|
||||
import Unison.Syntax.Name qualified as Name (toText, unsafeParseVar)
|
||||
import Unison.Syntax.Parser
|
||||
import Unison.Syntax.TermParser qualified as TermParser
|
||||
import Unison.Syntax.TypeParser qualified as TypeParser
|
||||
import Unison.Syntax.Var qualified as Var (namespaced)
|
||||
import Unison.Type (Type)
|
||||
import Unison.Type qualified as Type
|
||||
import Unison.Var (Var)
|
||||
import Unison.Var qualified as Var
|
||||
import Unison.Var qualified as Var (name, named)
|
||||
import Prelude hiding (readFile)
|
||||
|
||||
-- The parsed form of record accessors, as in:
|
||||
@ -99,7 +101,7 @@ resolveUnresolvedModifier unresolvedModifier var =
|
||||
resolveUniqueModifier :: (Monad m, Var v) => v -> Text -> P v m DD.Modifier
|
||||
resolveUniqueModifier var guid0 = do
|
||||
ParsingEnv {uniqueTypeGuid} <- ask
|
||||
guid <- fromMaybe guid0 <$> lift (lift (uniqueTypeGuid (Name.unsafeFromVar var)))
|
||||
guid <- fromMaybe guid0 <$> lift (lift (uniqueTypeGuid (Name.unsafeParseVar var)))
|
||||
pure $ DD.Unique guid
|
||||
|
||||
defaultUniqueModifier :: (Monad m, Var v) => v -> P v m DD.Modifier
|
||||
@ -162,7 +164,7 @@ dataDeclaration maybeUnresolvedModifier = do
|
||||
ctorAnn = ann ctorName <> maybe (ann ctorName) ann (lastMay ctorArgs)
|
||||
in ( ctorAnn,
|
||||
( ann ctorName,
|
||||
Var.namespaced [L.payload name, L.payload ctorName],
|
||||
Var.namespaced (L.payload name :| [L.payload ctorName]),
|
||||
Type.foralls ctorAnn typeArgVs ctorType
|
||||
)
|
||||
)
|
||||
@ -182,7 +184,7 @@ dataDeclaration maybeUnresolvedModifier = do
|
||||
)
|
||||
fields <- field
|
||||
closingToken <- closeBlock
|
||||
let lastSegment = name <&> (\v -> Var.named (Name.toText $ Name.unqualified (Name.unsafeFromVar v)))
|
||||
let lastSegment = name <&> (\v -> Var.named (Name.toText $ Name.unqualified (Name.unsafeParseVar v)))
|
||||
pure ([go lastSegment (snd <$> fields)], [(name, fields)], ann closingToken)
|
||||
(constructors, accessors, closingAnn) <-
|
||||
msum [Left <$> record, Right <$> sepBy (reserved "|") dataConstructor] <&> \case
|
||||
@ -263,7 +265,7 @@ effectDeclaration maybeUnresolvedModifier = do
|
||||
<$> TypeParser.computationType
|
||||
)
|
||||
where
|
||||
explodeToken v t = (ann v, Var.namespaced [L.payload name, L.payload v], t)
|
||||
explodeToken v t = (ann v, Var.namespaced (L.payload name :| [L.payload v]), t)
|
||||
-- If the effect is not syntactically present in the constructor types,
|
||||
-- add them after parsing.
|
||||
ensureEffect t = case t of
|
||||
|
@ -1,15 +1,12 @@
|
||||
module Unison.Syntax.DeclPrinter (prettyDecl, prettyDeclW, prettyDeclHeader, prettyDeclOrBuiltinHeader, AccessorName) where
|
||||
|
||||
import Control.Monad.Writer (Writer, runWriter, tell)
|
||||
import Data.List (isPrefixOf)
|
||||
import Data.List.NonEmpty (pattern (:|))
|
||||
import Data.Map qualified as Map
|
||||
import Data.Text qualified as Text
|
||||
import Unison.ConstructorReference (ConstructorReference, GConstructorReference (..))
|
||||
import Unison.ConstructorType qualified as CT
|
||||
import Unison.DataDeclaration
|
||||
( DataDeclaration,
|
||||
EffectDeclaration,
|
||||
toDataDecl,
|
||||
)
|
||||
import Unison.DataDeclaration (DataDeclaration, EffectDeclaration, toDataDecl)
|
||||
import Unison.DataDeclaration qualified as DD
|
||||
import Unison.DataDeclaration.Dependencies qualified as DD
|
||||
import Unison.HashQualified qualified as HQ
|
||||
@ -21,16 +18,17 @@ import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl (..))
|
||||
import Unison.PrettyPrintEnvDecl qualified as PPED
|
||||
import Unison.Reference (Reference, Reference' (DerivedId))
|
||||
import Unison.Referent qualified as Referent
|
||||
import Unison.Syntax.HashQualified qualified as HQ (toString, toVar, unsafeFromString)
|
||||
import Unison.Syntax.HashQualified qualified as HQ (toText, toVar, unsafeParseText)
|
||||
import Unison.Syntax.NamePrinter (styleHashQualified'')
|
||||
import Unison.Syntax.TypePrinter (runPretty)
|
||||
import Unison.Syntax.TypePrinter qualified as TypePrinter
|
||||
import Unison.Syntax.Var qualified as Var (namespaced)
|
||||
import Unison.Type qualified as Type
|
||||
import Unison.Util.Pretty (Pretty)
|
||||
import Unison.Util.Pretty qualified as P
|
||||
import Unison.Util.SyntaxText qualified as S
|
||||
import Unison.Var (Var)
|
||||
import Unison.Var qualified as Var
|
||||
import Unison.Var qualified as Var (freshenId, name, named)
|
||||
|
||||
type SyntaxText = S.SyntaxText' Reference
|
||||
|
||||
@ -83,7 +81,7 @@ prettyGADT env ctorType r name dd =
|
||||
constructor (n, (_, _, t)) =
|
||||
prettyPattern (PPED.unsuffixifiedPPE env) ctorType name (ConstructorReference r n)
|
||||
<> fmt S.TypeAscriptionColon " :"
|
||||
`P.hang` TypePrinter.prettySyntax (PPED.suffixifiedPPE env) t
|
||||
`P.hang` TypePrinter.prettySyntax (PPED.suffixifiedPPE env) t
|
||||
header = prettyEffectHeader name (DD.EffectDeclaration dd) <> fmt S.ControlKeyword " where"
|
||||
|
||||
prettyPattern ::
|
||||
@ -115,9 +113,9 @@ prettyDataDecl (PrettyPrintEnvDecl unsuffixifiedPPE suffixifiedPPE) r name dd =
|
||||
(header <>)
|
||||
. P.sep (fmt S.DelimiterChar (" | " `P.orElse` "\n | "))
|
||||
<$> constructor
|
||||
`traverse` zip
|
||||
[0 ..]
|
||||
(DD.constructors' dd)
|
||||
`traverse` zip
|
||||
[0 ..]
|
||||
(DD.constructors' dd)
|
||||
where
|
||||
constructor (n, (_, _, Type.ForallsNamed' _ t)) = constructor' n t
|
||||
constructor (n, (_, _, t)) = constructor' n t
|
||||
@ -136,7 +134,7 @@ prettyDataDecl (PrettyPrintEnvDecl unsuffixifiedPPE suffixifiedPPE) r name dd =
|
||||
Just accessor -> HQ.NameOnly $ declName `Name.joinDot` fieldName `Name.joinDot` accessor
|
||||
| HQ.NameOnly declName <- [name],
|
||||
HQ.NameOnly fieldName <- fs,
|
||||
accessor <- [Nothing, Just "set", Just "modify"]
|
||||
accessor <- [Nothing, Just (Name.fromSegment "set"), Just (Name.fromSegment "modify")]
|
||||
]
|
||||
pure . P.group $
|
||||
fmt S.DelimiterChar "{ "
|
||||
@ -148,7 +146,7 @@ prettyDataDecl (PrettyPrintEnvDecl unsuffixifiedPPE suffixifiedPPE) r name dd =
|
||||
P.group $
|
||||
styleHashQualified'' (fmt (S.TypeReference r)) fname
|
||||
<> fmt S.TypeAscriptionColon " :"
|
||||
`P.hang` runPretty suffixifiedPPE (TypePrinter.prettyRaw Map.empty (-1) typ)
|
||||
`P.hang` runPretty suffixifiedPPE (TypePrinter.prettyRaw Map.empty (-1) typ)
|
||||
header = prettyDataHeader name dd <> fmt S.DelimiterChar (" = " `P.orElse` "\n = ")
|
||||
|
||||
-- Comes up with field names for a data declaration which has the form of a
|
||||
@ -180,20 +178,26 @@ fieldNames env r name dd = do
|
||||
vars = [Var.freshenId (fromIntegral n) (Var.named "_") | n <- [0 .. Type.arity typ - 1]]
|
||||
hashes <- DD.hashFieldAccessors env (HQ.toVar name) vars r dd
|
||||
let names =
|
||||
[ (r, HQ.toString . PPE.termName env . Referent.Ref $ DerivedId r)
|
||||
[ (r, HQ.toText . PPE.termName env . Referent.Ref $ DerivedId r)
|
||||
| r <- (\(refId, _trm, _typ) -> refId) <$> Map.elems hashes
|
||||
]
|
||||
let fieldNames =
|
||||
Map.fromList
|
||||
[ (r, f) | (r, n) <- names, typename <- pure (HQ.toString name), typename `isPrefixOf` n, rest <- pure $ drop (length typename + 1) n, (f, rest) <- pure $ span (/= '.') rest, rest `elem` ["", ".set", ".modify"]
|
||||
[ (r, f)
|
||||
| (r, n) <- names,
|
||||
typename <- pure (HQ.toText name),
|
||||
typename `Text.isPrefixOf` n,
|
||||
rest <- pure $ Text.drop (Text.length typename + 1) n,
|
||||
(f, rest) <- pure $ Text.span (/= '.') rest,
|
||||
rest `elem` ["", ".set", ".modify"]
|
||||
]
|
||||
|
||||
if Map.size fieldNames == length names
|
||||
then
|
||||
Just
|
||||
[ HQ.unsafeFromString name
|
||||
[ HQ.unsafeParseText name
|
||||
| v <- vars,
|
||||
Just (ref, _, _) <- [Map.lookup (Var.namespaced [HQ.toVar name, v]) hashes],
|
||||
Just (ref, _, _) <- [Map.lookup (Var.namespaced (HQ.toVar name :| [v])) hashes],
|
||||
Just name <- [Map.lookup ref fieldNames]
|
||||
]
|
||||
else Nothing
|
||||
|
@ -4,14 +4,15 @@ module Unison.Syntax.FileParser
|
||||
|
||||
import Control.Lens
|
||||
import Control.Monad.Reader (asks, local)
|
||||
import Data.List.NonEmpty (pattern (:|))
|
||||
import Data.Map qualified as Map
|
||||
import Data.Set qualified as Set
|
||||
import Data.Text qualified as Text
|
||||
import Text.Megaparsec qualified as P
|
||||
import Unison.ABT qualified as ABT
|
||||
import Unison.DataDeclaration (DataDeclaration)
|
||||
import Unison.DataDeclaration qualified as DD
|
||||
import Unison.Name qualified as Name
|
||||
import Unison.NameSegment (NameSegment (..))
|
||||
import Unison.Names qualified as Names
|
||||
import Unison.Names.ResolutionResult qualified as Names
|
||||
import Unison.NamesWithHistory qualified as Names
|
||||
@ -20,9 +21,10 @@ import Unison.Parser.Ann qualified as Ann
|
||||
import Unison.Prelude
|
||||
import Unison.Syntax.DeclParser (declarations)
|
||||
import Unison.Syntax.Lexer qualified as L
|
||||
import Unison.Syntax.Name qualified as Name (toString, unsafeFromVar)
|
||||
import Unison.Syntax.Name qualified as Name (toText, unsafeParseVar)
|
||||
import Unison.Syntax.Parser
|
||||
import Unison.Syntax.TermParser qualified as TermParser
|
||||
import Unison.Syntax.Var qualified as Var (namespaced)
|
||||
import Unison.Term (Term)
|
||||
import Unison.Term qualified as Term
|
||||
import Unison.UnisonFile (UnisonFile (..))
|
||||
@ -51,12 +53,12 @@ file = do
|
||||
Left es -> resolutionFailures (toList es)
|
||||
let accessors :: [[(v, Ann, Term v Ann)]]
|
||||
accessors =
|
||||
[ DD.generateRecordAccessors Ann.GeneratedFrom (toPair <$> fields) (L.payload typ) r
|
||||
[ DD.generateRecordAccessors Var.namespaced Ann.GeneratedFrom (toPair <$> fields) (L.payload typ) r
|
||||
| (typ, fields) <- parsedAccessors,
|
||||
Just (r, _) <- [Map.lookup (L.payload typ) (UF.datas env)]
|
||||
]
|
||||
toPair (tok, typ) = (L.payload tok, ann tok <> ann typ)
|
||||
let importNames = [(Name.unsafeFromVar v, Name.unsafeFromVar v2) | (v, v2) <- imports]
|
||||
let importNames = [(Name.unsafeParseVar v, Name.unsafeParseVar v2) | (v, v2) <- imports]
|
||||
let locals = Names.importing importNames (UF.names env)
|
||||
-- At this stage of the file parser, we've parsed all the type and ability
|
||||
-- declarations. The `push locals` here has the effect
|
||||
@ -97,13 +99,13 @@ file = do
|
||||
-- All unique local term name suffixes - these we want to
|
||||
-- avoid resolving to a term that's in the codebase
|
||||
locals :: [Name.Name]
|
||||
locals = (Name.unsafeFromVar <$> Map.keys canonicalVars)
|
||||
locals = (Name.unsafeParseVar <$> Map.keys canonicalVars)
|
||||
|
||||
-- A function to replace unique local term suffixes with their
|
||||
-- fully qualified name
|
||||
replacements = [(v, Term.var () v2) | (v, v2) <- Map.toList canonicalVars, v /= v2]
|
||||
resolveLocals = ABT.substsInheritAnnotation replacements
|
||||
let bindNames = Term.bindSomeNames Name.unsafeFromVar (Set.fromList fqLocalTerms) curNames . resolveLocals
|
||||
let bindNames = Term.bindSomeNames Name.unsafeParseVar (Set.fromList fqLocalTerms) curNames . resolveLocals
|
||||
terms <- case List.validate (traverseOf _3 bindNames) terms of
|
||||
Left es -> resolutionFailures (toList es)
|
||||
Right terms -> pure terms
|
||||
@ -217,14 +219,14 @@ stanza = watchExpression <|> unexpectedAction <|> binding
|
||||
binding@((_, v), _) <- TermParser.binding
|
||||
pure $ case doc of
|
||||
Nothing -> Binding binding
|
||||
Just (spanAnn, doc) -> Bindings [((spanAnn, Var.joinDot v (Var.named "doc")), doc), binding]
|
||||
Just (spanAnn, doc) -> Bindings [((spanAnn, Var.namespaced (v :| [Var.named "doc"])), doc), binding]
|
||||
|
||||
watched :: (Monad m, Var v) => P v m (UF.WatchKind, Text, Ann)
|
||||
watched = P.try do
|
||||
kind <- (fmap . fmap . fmap) Name.toString (optional importWordyId)
|
||||
kind <- (fmap . fmap . fmap) (Text.unpack . Name.toText) (optional importWordyId)
|
||||
guid <- uniqueName 10
|
||||
op <- optional (L.payload <$> P.lookAhead importSymbolyId)
|
||||
guard (op == Just (Name.fromSegment (NameSegment ">")))
|
||||
guard (op == Just (Name.fromSegment ">"))
|
||||
tok <- anyToken
|
||||
guard $ maybe True (`L.touches` tok) kind
|
||||
pure (maybe UF.RegularWatch L.payload kind, guid, maybe mempty ann kind <> ann tok)
|
||||
|
@ -34,8 +34,6 @@ import Unison.HashQualified qualified as HQ
|
||||
import Unison.HashQualified' qualified as HQ'
|
||||
import Unison.Name (Name)
|
||||
import Unison.Name qualified as Name
|
||||
import Unison.NameSegment (NameSegment (..))
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Names (Names)
|
||||
import Unison.Names qualified as Names
|
||||
import Unison.NamesWithHistory qualified as Names
|
||||
@ -46,7 +44,8 @@ import Unison.Prelude
|
||||
import Unison.Reference (Reference)
|
||||
import Unison.Referent (Referent)
|
||||
import Unison.Syntax.Lexer qualified as L
|
||||
import Unison.Syntax.Name qualified as Name (toText, toVar, unsafeFromVar)
|
||||
import Unison.Syntax.Name qualified as Name (toText, toVar, unsafeParseVar)
|
||||
import Unison.Syntax.NameSegment qualified as NameSegment (toEscapedText)
|
||||
import Unison.Syntax.Parser hiding (seq)
|
||||
import Unison.Syntax.Parser qualified as Parser (seq, uniqueName)
|
||||
import Unison.Syntax.TypeParser qualified as TypeParser
|
||||
@ -106,7 +105,7 @@ rewriteBlock = do
|
||||
rewriteCase = rewriteTermlike "case" DD.rewriteCase
|
||||
rewriteType = do
|
||||
kw <- quasikeyword "signature"
|
||||
vs <- P.try (some prefixDefinitionName <* symbolyQuasikeyword ".") <|> pure []
|
||||
vs <- P.try (some prefixDefinitionName <* reserved ".") <|> pure []
|
||||
lhs <- TypeParser.computationType
|
||||
rhs <- openBlockWith "==>" *> TypeParser.computationType <* closeBlock
|
||||
pure (DD.rewriteType (ann kw <> ann rhs) (L.payload <$> vs) lhs rhs)
|
||||
@ -416,15 +415,10 @@ quasikeyword kw = queryToken \case
|
||||
L.WordyId (HQ'.NameOnly n) | nameIsKeyword n kw -> Just ()
|
||||
_ -> Nothing
|
||||
|
||||
symbolyQuasikeyword :: (Ord v) => Text -> P v m (L.Token ())
|
||||
symbolyQuasikeyword kw = queryToken \case
|
||||
L.SymbolyId (HQ'.NameOnly n) | nameIsKeyword n kw -> Just ()
|
||||
_ -> Nothing
|
||||
|
||||
nameIsKeyword :: Name -> Text -> Bool
|
||||
nameIsKeyword name keyword =
|
||||
case (Name.isRelative name, Name.reverseSegments name) of
|
||||
(True, segment NonEmpty.:| []) -> NameSegment.toText segment == keyword
|
||||
(True, segment NonEmpty.:| []) -> NameSegment.toEscapedText segment == keyword
|
||||
_ -> False
|
||||
|
||||
-- If the hash qualified is name only, it is treated as a var, if it
|
||||
@ -998,9 +992,9 @@ bang = P.label "bang" do
|
||||
|
||||
seqOp :: (Ord v) => P v m Pattern.SeqOp
|
||||
seqOp =
|
||||
Pattern.Snoc <$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment (NameSegment ":+"))))
|
||||
<|> Pattern.Cons <$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment (NameSegment "+:"))))
|
||||
<|> Pattern.Concat <$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment (NameSegment "++"))))
|
||||
Pattern.Snoc <$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment ":+")))
|
||||
<|> Pattern.Cons <$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment "+:")))
|
||||
<|> Pattern.Concat <$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment "++")))
|
||||
|
||||
term4 :: (Monad m, Var v) => TermP v m
|
||||
term4 = f <$> some termLeaf
|
||||
@ -1030,7 +1024,7 @@ typedecl =
|
||||
verifyRelativeVarName :: (Var v) => P v m (L.Token v) -> P v m (L.Token v)
|
||||
verifyRelativeVarName p = do
|
||||
v <- p
|
||||
verifyRelativeName' (Name.unsafeFromVar <$> v)
|
||||
verifyRelativeName' (Name.unsafeParseVar <$> v)
|
||||
pure v
|
||||
|
||||
verifyRelativeName' :: (Ord v) => L.Token Name -> P v m ()
|
||||
@ -1101,7 +1095,7 @@ binding = label "binding" do
|
||||
-- we haven't seen a type annotation, so lookahead to '=' before commit
|
||||
(lhsLoc, name, args) <- P.try (lhs <* P.lookAhead (openBlockWith "="))
|
||||
(_bodySpanAnn, body) <- block "="
|
||||
verifyRelativeName' (fmap Name.unsafeFromVar name)
|
||||
verifyRelativeName' (fmap Name.unsafeParseVar name)
|
||||
let binding = mkBinding lhsLoc args body
|
||||
-- We don't actually use the span annotation from the block (yet) because it
|
||||
-- may contain a bunch of white-space and comments following a top-level-definition.
|
||||
@ -1109,7 +1103,7 @@ binding = label "binding" do
|
||||
pure $ ((spanAnn, (L.payload name)), binding)
|
||||
Just (nameT, typ) -> do
|
||||
(lhsLoc, name, args) <- lhs
|
||||
verifyRelativeName' (fmap Name.unsafeFromVar name)
|
||||
verifyRelativeName' (fmap Name.unsafeParseVar name)
|
||||
when (L.payload name /= L.payload nameT) $
|
||||
customFailure $
|
||||
SignatureNeedsAccompanyingBody nameT
|
||||
@ -1148,7 +1142,7 @@ importp = do
|
||||
-- a nicer error message if the suffixes are empty
|
||||
prefix <-
|
||||
optional $
|
||||
fmap Right (importWordyId <|> importDotId) -- use . Nat
|
||||
fmap Right importWordyId
|
||||
<|> fmap Left importSymbolyId
|
||||
suffixes <- optional (some (importWordyId <|> importSymbolyId))
|
||||
case (prefix, suffixes) of
|
||||
@ -1195,7 +1189,7 @@ substImports ns imports =
|
||||
-- not in Names, but in a later term binding
|
||||
[ (suffix, Type.var () full)
|
||||
| (suffix, full) <- imports,
|
||||
Names.hasTypeNamed Names.IncludeSuffixes (Name.unsafeFromVar full) ns
|
||||
Names.hasTypeNamed Names.IncludeSuffixes (Name.unsafeParseVar full) ns
|
||||
]
|
||||
|
||||
block' ::
|
||||
|
@ -39,7 +39,6 @@ import Unison.HashQualified' qualified as HQ'
|
||||
import Unison.Name (Name)
|
||||
import Unison.Name qualified as Name
|
||||
import Unison.NameSegment (NameSegment)
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Pattern (Pattern)
|
||||
import Unison.Pattern qualified as Pattern
|
||||
import Unison.Prelude
|
||||
@ -52,9 +51,10 @@ import Unison.Reference qualified as Reference
|
||||
import Unison.Referent (Referent)
|
||||
import Unison.Referent qualified as Referent
|
||||
import Unison.Syntax.HashQualified qualified as HQ (unsafeFromVar)
|
||||
import Unison.Syntax.Lexer (showEscapeChar, symbolyId)
|
||||
import Unison.Syntax.Name qualified as Name (fromText, toString, toText, unsafeFromText)
|
||||
import Unison.Syntax.Lexer (showEscapeChar)
|
||||
import Unison.Syntax.Name qualified as Name (isSymboly, parseText, parseTextEither, toText, unsafeParseText)
|
||||
import Unison.Syntax.NamePrinter (styleHashQualified'')
|
||||
import Unison.Syntax.NameSegment qualified as NameSegment (toEscapedText)
|
||||
import Unison.Syntax.TypePrinter qualified as TypePrinter
|
||||
import Unison.Term
|
||||
import Unison.Type (Type, pattern ForallsNamed')
|
||||
@ -206,7 +206,7 @@ pretty0
|
||||
elideUnit = elideUnit
|
||||
}
|
||||
term =
|
||||
specialCases term $ \case
|
||||
specialCases term \case
|
||||
Var' v -> pure . parenIfInfix name ic $ styleHashQualified'' (fmt S.Var) name
|
||||
where
|
||||
-- OK since all term vars are user specified, any freshening was just added during typechecking
|
||||
@ -298,7 +298,7 @@ pretty0
|
||||
`PP.hang` pb
|
||||
<> PP.softbreak
|
||||
<> fmt S.ControlKeyword "with"
|
||||
`hangHandler` ph
|
||||
`hangHandler` ph
|
||||
]
|
||||
Delay' x
|
||||
| isLet x || p < 0 -> do
|
||||
@ -1078,14 +1078,8 @@ l :: (IsString s) => String -> Pretty s
|
||||
l = fromString
|
||||
|
||||
isSymbolic :: HQ.HashQualified Name -> Bool
|
||||
isSymbolic (HQ.NameOnly name) = isSymbolic' name
|
||||
isSymbolic (HQ.HashQualified name _) = isSymbolic' name
|
||||
isSymbolic (HQ.HashOnly _) = False
|
||||
|
||||
isSymbolic' :: Name -> Bool
|
||||
isSymbolic' name = case symbolyId . Name.toString $ name of
|
||||
Right _ -> True
|
||||
_ -> False
|
||||
isSymbolic =
|
||||
maybe False Name.isSymboly . HQ.toName
|
||||
|
||||
emptyAc :: AmbientContext
|
||||
emptyAc = ac (-1) Normal Map.empty MaybeDoc
|
||||
@ -1271,7 +1265,7 @@ printAnnotate n tm =
|
||||
Set.fromList [n | v <- ABT.allVars tm, n <- varToName v]
|
||||
usedTypeNames =
|
||||
Set.fromList [n | Ann' _ ty <- ABT.subterms tm, v <- ABT.allVars ty, n <- varToName v]
|
||||
varToName v = toList (Name.fromText (Var.name v))
|
||||
varToName v = toList (Name.parseText (Var.name v))
|
||||
go :: (Ord v) => Term2 v at ap v b -> Term2 v () () v b
|
||||
go = extraMap' id (const ()) (const ())
|
||||
|
||||
@ -1314,11 +1308,11 @@ countName n =
|
||||
{ usages =
|
||||
Map.fromList do
|
||||
(p, s) <- Name.splits n
|
||||
pure (Name.toText s, Map.singleton (map NameSegment.toText p) 1)
|
||||
pure (Name.toText s, Map.singleton (map NameSegment.toEscapedText p) 1)
|
||||
}
|
||||
|
||||
joinName :: Prefix -> Suffix -> Name
|
||||
joinName p s = Name.unsafeFromText $ dotConcat $ p ++ [s]
|
||||
joinName p s = Name.unsafeParseText $ dotConcat $ p ++ [s]
|
||||
|
||||
dotConcat :: [Text] -> Text
|
||||
dotConcat = Text.concat . intersperse "."
|
||||
@ -1395,8 +1389,7 @@ calcImports im tm = (im', render $ getUses result)
|
||||
|> filter
|
||||
( \s ->
|
||||
let (p, i) = lookupOrDie s m
|
||||
in (i > 1 || isRight (symbolyId (unpack s)))
|
||||
&& not (null p)
|
||||
in (i > 1 || either (const False) Name.isSymboly (Name.parseTextEither s)) && not (null p)
|
||||
)
|
||||
|> map (\s -> (s, lookupOrDie s m))
|
||||
|> Map.fromList
|
||||
@ -2169,7 +2162,8 @@ avoidShadowing tm (PrettyPrintEnv terms types) =
|
||||
& maybe fullName HQ'.NameOnly
|
||||
in (fullName, minimallySuffixed)
|
||||
tweak _ p = p
|
||||
varToName v = toList (Name.fromText (Var.name v))
|
||||
varToName :: Var v => v -> [Name]
|
||||
varToName = toList . Name.parseText . Var.name
|
||||
|
||||
isLeaf :: Term2 vt at ap v a -> Bool
|
||||
isLeaf (Var' {}) = True
|
||||
|
@ -12,9 +12,6 @@ import Text.Megaparsec qualified as P
|
||||
import Unison.ABT qualified as ABT
|
||||
import Unison.Builtin.Decls qualified as DD
|
||||
import Unison.HashQualified qualified as HQ
|
||||
import Unison.HashQualified' qualified as HQ'
|
||||
import Unison.Name qualified as Name
|
||||
import Unison.NameSegment (NameSegment (NameSegment))
|
||||
import Unison.NamesWithHistory qualified as Names
|
||||
import Unison.Parser.Ann (Ann (..))
|
||||
import Unison.Prelude
|
||||
@ -125,6 +122,6 @@ forall :: (Var v) => TypeP v m -> TypeP v m
|
||||
forall rec = do
|
||||
kw <- reserved "forall" <|> reserved "∀"
|
||||
vars <- fmap (fmap L.payload) . some $ prefixDefinitionName
|
||||
_ <- matchToken $ L.SymbolyId (HQ'.fromName (Name.fromSegment (NameSegment ".")))
|
||||
_ <- reserved "."
|
||||
t <- rec
|
||||
pure $ Type.foralls (ann kw <> ann t) vars t
|
||||
|
@ -51,7 +51,7 @@ import Unison.Result
|
||||
pattern Result,
|
||||
)
|
||||
import Unison.Result qualified as Result
|
||||
import Unison.Syntax.Name qualified as Name (toText, unsafeFromText)
|
||||
import Unison.Syntax.Name qualified as Name (toText, unsafeParseText)
|
||||
import Unison.Term (Term)
|
||||
import Unison.Term qualified as Term
|
||||
import Unison.Type (Type)
|
||||
@ -242,7 +242,7 @@ typeDirectedNameResolution ppe oldNotes oldType env = do
|
||||
addTypedComponent :: Context.InfoNote v loc -> State (Env v loc) ()
|
||||
addTypedComponent (Context.TopLevelComponent vtts) =
|
||||
for_ vtts $ \(v, typ, _) ->
|
||||
for_ (Name.suffixes . Name.unsafeFromText . Var.name $ Var.reset v) $ \suffix ->
|
||||
for_ (Name.suffixes . Name.unsafeParseText . Var.name $ Var.reset v) $ \suffix ->
|
||||
termsByShortname
|
||||
%= Map.insertWith
|
||||
(<>)
|
||||
@ -278,7 +278,7 @@ typeDirectedNameResolution ppe oldNotes oldType env = do
|
||||
Map.insertWith
|
||||
Set.union
|
||||
suggestionReplacement
|
||||
(Set.singleton (Name.unsafeFromText suggestionName))
|
||||
(Set.singleton (Name.unsafeParseText suggestionName))
|
||||
b
|
||||
)
|
||||
Map.empty
|
||||
|
@ -31,8 +31,8 @@ import Unison.WatchKind qualified as WK
|
||||
toNames :: (Var v) => UnisonFile v a -> Names
|
||||
toNames uf = datas <> effects
|
||||
where
|
||||
datas = foldMap (DD.Names.dataDeclToNames' Name.unsafeFromVar) (Map.toList (UF.dataDeclarationsId uf))
|
||||
effects = foldMap (DD.Names.effectDeclToNames' Name.unsafeFromVar) (Map.toList (UF.effectDeclarationsId uf))
|
||||
datas = foldMap (DD.Names.dataDeclToNames' Name.unsafeParseVar) (Map.toList (UF.dataDeclarationsId uf))
|
||||
effects = foldMap (DD.Names.effectDeclToNames' Name.unsafeParseVar) (Map.toList (UF.effectDeclarationsId uf))
|
||||
|
||||
addNamesFromUnisonFile :: (Var v) => UnisonFile v a -> Names -> Names
|
||||
addNamesFromUnisonFile unisonFile names = Names.shadowing (toNames unisonFile) names
|
||||
@ -42,13 +42,13 @@ typecheckedToNames uf = Names (terms <> ctors) types
|
||||
where
|
||||
terms =
|
||||
Relation.fromList
|
||||
[ (Name.unsafeFromVar v, Referent.Ref r)
|
||||
[ (Name.unsafeParseVar v, Referent.Ref r)
|
||||
| (v, (_a, r, wk, _, _)) <- Map.toList $ UF.hashTerms uf,
|
||||
wk == Nothing || wk == Just WK.TestWatch
|
||||
]
|
||||
types =
|
||||
Relation.fromList
|
||||
[ (Name.unsafeFromVar v, r)
|
||||
[ (Name.unsafeParseVar v, r)
|
||||
| (v, r) <-
|
||||
Map.toList $
|
||||
fmap fst (UF.dataDeclarations' uf)
|
||||
@ -56,7 +56,7 @@ typecheckedToNames uf = Names (terms <> ctors) types
|
||||
]
|
||||
ctors =
|
||||
Relation.fromMap
|
||||
. Map.mapKeys Name.unsafeFromVar
|
||||
. Map.mapKeys Name.unsafeParseVar
|
||||
. fmap (fmap Reference.DerivedId)
|
||||
. UF.hashConstructors
|
||||
$ uf
|
||||
@ -87,8 +87,8 @@ bindNames names (UnisonFileId d e ts ws) = do
|
||||
let termVars = (view _1 <$> ts) ++ (Map.elems ws >>= map (view _1))
|
||||
termVarsSet = Set.fromList termVars
|
||||
-- todo: can we clean up this lambda using something like `second`
|
||||
ts' <- traverse (\(v, a, t) -> (v,a,) <$> Term.bindNames Name.unsafeFromVar termVarsSet names t) ts
|
||||
ws' <- traverse (traverse (\(v, a, t) -> (v,a,) <$> Term.bindNames Name.unsafeFromVar termVarsSet names t)) ws
|
||||
ts' <- traverse (\(v, a, t) -> (v,a,) <$> Term.bindNames Name.unsafeParseVar termVarsSet names t) ts
|
||||
ws' <- traverse (traverse (\(v, a, t) -> (v,a,) <$> Term.bindNames Name.unsafeParseVar termVarsSet names t)) ws
|
||||
pure $ UnisonFileId d e ts' ws'
|
||||
|
||||
-- | Given the set of fully-qualified variable names, this computes
|
||||
@ -111,7 +111,7 @@ variableCanonicalizer :: forall v. Var v => [v] -> Map v v
|
||||
variableCanonicalizer vs =
|
||||
done $ List.multimap do
|
||||
v <- vs
|
||||
let n = Name.unsafeFromVar v
|
||||
let n = Name.unsafeParseVar v
|
||||
suffix <- Name.suffixes n
|
||||
pure (Var.named (Name.toText suffix), v)
|
||||
where
|
||||
@ -134,9 +134,9 @@ environmentFor names dataDecls0 effectDecls0 = do
|
||||
let locallyBoundTypes = variableCanonicalizer (Map.keys dataDecls0 <> Map.keys effectDecls0)
|
||||
-- data decls and hash decls may reference each other, and thus must be hashed together
|
||||
dataDecls :: Map v (DataDeclaration v a) <-
|
||||
traverse (DD.Names.bindNames Name.unsafeFromVar locallyBoundTypes names) dataDecls0
|
||||
traverse (DD.Names.bindNames Name.unsafeParseVar locallyBoundTypes names) dataDecls0
|
||||
effectDecls :: Map v (EffectDeclaration v a) <-
|
||||
traverse (DD.withEffectDeclM (DD.Names.bindNames Name.unsafeFromVar locallyBoundTypes names)) effectDecls0
|
||||
traverse (DD.withEffectDeclM (DD.Names.bindNames Name.unsafeParseVar locallyBoundTypes names)) effectDecls0
|
||||
let allDecls0 :: Map v (DataDeclaration v a)
|
||||
allDecls0 = Map.union dataDecls (toDataDecl <$> effectDecls)
|
||||
hashDecls' :: [(v, Reference.Id, DataDeclaration v a)] <- Hashing.hashDataDecls allDecls0
|
||||
@ -145,8 +145,8 @@ environmentFor names dataDecls0 effectDecls0 = do
|
||||
dataDecls' = Map.difference allDecls effectDecls
|
||||
effectDecls' = second EffectDeclaration <$> Map.difference allDecls dataDecls
|
||||
-- ctor and effect terms
|
||||
ctors = foldMap (DD.Names.dataDeclToNames' Name.unsafeFromVar) (Map.toList dataDecls')
|
||||
effects = foldMap (DD.Names.effectDeclToNames' Name.unsafeFromVar) (Map.toList effectDecls')
|
||||
ctors = foldMap (DD.Names.dataDeclToNames' Name.unsafeParseVar) (Map.toList dataDecls')
|
||||
effects = foldMap (DD.Names.effectDeclToNames' Name.unsafeParseVar) (Map.toList effectDecls')
|
||||
names' = ctors <> effects
|
||||
overlaps =
|
||||
let w v dd (toDataDecl -> ed) = DupDataAndAbility v (DD.annotation dd) (DD.annotation ed)
|
||||
|
192
parser-typechecker/src/Unison/Util/Star2.hs
Normal file
192
parser-typechecker/src/Unison/Util/Star2.hs
Normal file
@ -0,0 +1,192 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module Unison.Util.Star2
|
||||
( Star2 (Star2),
|
||||
fact,
|
||||
insertD1,
|
||||
insertD2,
|
||||
deleteD1,
|
||||
deleteD2,
|
||||
deleteFact,
|
||||
deletePrimaryD1,
|
||||
d1,
|
||||
d2,
|
||||
difference,
|
||||
lookupD1,
|
||||
mapD2,
|
||||
memberD1,
|
||||
replaceFacts,
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Map qualified as Map
|
||||
import Data.Set qualified as Set
|
||||
import Unison.Prelude
|
||||
import Unison.Util.Relation (Relation)
|
||||
import Unison.Util.Relation qualified as R
|
||||
|
||||
-- Represents a set of (fact, d1, d2, d2), but indexed using a star schema so
|
||||
-- it can be efficiently queried from any of the dimensions.
|
||||
data Star2 fact d1 d2 = Star2
|
||||
{ fact :: Set fact,
|
||||
d1 :: Relation fact d1,
|
||||
d2 :: Relation fact d2
|
||||
}
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
-- Produce the cross-product across all the dimensions
|
||||
|
||||
-- `difference a b` contains only the facts from `a` that are absent from `b`
|
||||
-- or differ along any of the dimensions `d1..d2`.
|
||||
difference ::
|
||||
(Ord fact, Ord d1, Ord d2) =>
|
||||
Star2 fact d1 d2 ->
|
||||
Star2 fact d1 d2 ->
|
||||
Star2 fact d1 d2
|
||||
difference a b = Star2 facts d1s d2s
|
||||
where
|
||||
d1s = R.difference (d1 a) (d1 b)
|
||||
d2s = R.difference (d2 a) (d2 b)
|
||||
facts = R.dom d1s <> R.dom d2s
|
||||
|
||||
mapD2 :: (Ord fact, Ord d2, Ord d2a) => (d2 -> d2a) -> Star2 fact d1 d2 -> Star2 fact d1 d2a
|
||||
mapD2 f s = s {d2 = R.mapRan f (d2 s)}
|
||||
|
||||
-- Deletes tuples of the form (fact, d1, _, _).
|
||||
-- If no other (fact, dk, _, _) tuples exist for any other dk, then
|
||||
-- `fact` is removed from the `fact` set and from the other dimensions as well,
|
||||
-- that is, (fact, d1) is treated as a primary key.
|
||||
deletePrimaryD1 ::
|
||||
(Ord fact, Ord d1, Ord d2) =>
|
||||
(fact, d1) ->
|
||||
Star2 fact d1 d2 ->
|
||||
Star2 fact d1 d2
|
||||
deletePrimaryD1 (f, x) s =
|
||||
let d1' = R.delete f x (d1 s)
|
||||
otherX = R.lookupDom f d1'
|
||||
in if Set.null otherX
|
||||
then Star2 (Set.delete f (fact s)) d1' (R.deleteDom f (d2 s))
|
||||
else s {d1 = d1'}
|
||||
|
||||
-- Deletes tuples of the form (_, d1, _, _).
|
||||
deleteD1 ::
|
||||
(Ord fact, Ord d1, Ord d2) =>
|
||||
d1 ->
|
||||
Star2 fact d1 d2 ->
|
||||
Star2 fact d1 d2
|
||||
deleteD1 x s =
|
||||
let d1' = R.deleteRan x (d1 s)
|
||||
deadFacts = R.lookupRan x (d1 s)
|
||||
newFacts = Set.difference (fact s) deadFacts
|
||||
d2' = R.subtractDom deadFacts (d2 s)
|
||||
in Star2
|
||||
newFacts
|
||||
d1'
|
||||
d2'
|
||||
|
||||
lookupD1 :: (Ord fact, Ord d1) => d1 -> Star2 fact d1 d2 -> Set fact
|
||||
lookupD1 x s = R.lookupRan x (d1 s)
|
||||
|
||||
insertD1 ::
|
||||
(Ord fact, Ord d1) =>
|
||||
(fact, d1) ->
|
||||
Star2 fact d1 d2 ->
|
||||
Star2 fact d1 d2
|
||||
insertD1 (f, x) s =
|
||||
s
|
||||
{ fact = Set.insert f (fact s),
|
||||
d1 = R.insert f x (d1 s)
|
||||
}
|
||||
|
||||
insertD2 ::
|
||||
(Ord fact, Ord d2) =>
|
||||
(fact, d2) ->
|
||||
Star2 fact d1 d2 ->
|
||||
Star2 fact d1 d2
|
||||
insertD2 (f, x) s =
|
||||
s
|
||||
{ fact = Set.insert f (fact s),
|
||||
d2 = R.insert f x (d2 s)
|
||||
}
|
||||
|
||||
memberD1 :: (Ord fact, Ord d1) => (fact, d1) -> Star2 fact d1 d2 -> Bool
|
||||
memberD1 (f, x) s = R.member f x (d1 s)
|
||||
|
||||
deleteD2 ::
|
||||
(Ord fact, Ord d1, Ord d2) =>
|
||||
(fact, d2) ->
|
||||
Star2 fact d1 d2 ->
|
||||
Star2 fact d1 d2
|
||||
deleteD2 (f, x) s = garbageCollect f (Star2 (fact s) (d1 s) d2')
|
||||
where
|
||||
d2' = R.delete f x (d2 s)
|
||||
|
||||
-- | Given a possibly-invalid Star2, which may contain the given fact in its fact set that are not related to any d1,
|
||||
-- d2, or d2, return a valid Star2, with this fact possibly removed.
|
||||
garbageCollect :: (Ord fact) => fact -> Star2 fact d1 d2 -> Star2 fact d1 d2
|
||||
garbageCollect f star =
|
||||
star
|
||||
{ fact =
|
||||
if R.memberDom f (d1 star) || R.memberDom f (d2 star)
|
||||
then fact star
|
||||
else Set.delete f (fact star)
|
||||
}
|
||||
|
||||
deleteFact ::
|
||||
(Ord fact, Ord d1, Ord d2) =>
|
||||
Set fact ->
|
||||
Star2 fact d1 d2 ->
|
||||
Star2 fact d1 d2
|
||||
deleteFact facts Star2 {..} =
|
||||
Star2
|
||||
(fact `Set.difference` facts)
|
||||
(facts R.<|| d1)
|
||||
(facts R.<|| d2)
|
||||
|
||||
-- Efficiently replace facts with those in the provided `Map`.
|
||||
-- The `apply` function can be used to add other dimensions
|
||||
-- in the same traversal. It is given `apply old new s` where
|
||||
-- s is the current `Star` being accumulated.
|
||||
--
|
||||
-- Currently used by update propagation but likely useful for
|
||||
-- other bulk rewriting of namespaces.
|
||||
replaceFacts ::
|
||||
(Ord fact, Ord d1, Ord d2) =>
|
||||
(fact -> fact -> Star2 fact d1 d2 -> Star2 fact d1 d2) ->
|
||||
Map fact fact ->
|
||||
Star2 fact d1 d2 ->
|
||||
Star2 fact d1 d2
|
||||
replaceFacts apply m s =
|
||||
let -- the intersection of `fact` and the replacement keys is often small,
|
||||
-- so we compute that first (which can happen in O(size of intersection))
|
||||
-- rather than iterating over one or the other
|
||||
replaceable = Map.keysSet m `Set.intersection` fact s
|
||||
go s old = apply old new $ replaceFact old new s
|
||||
where
|
||||
new = Map.findWithDefault old old m
|
||||
in foldl' go s replaceable
|
||||
|
||||
replaceFact ::
|
||||
(Ord fact, Ord d1, Ord d2) =>
|
||||
fact ->
|
||||
fact ->
|
||||
Star2 fact d1 d2 ->
|
||||
Star2 fact d1 d2
|
||||
replaceFact f f' s@Star2 {..} =
|
||||
if Set.notMember f fact
|
||||
then s
|
||||
else
|
||||
Star2
|
||||
(Set.insert f' . Set.delete f $ fact)
|
||||
(R.replaceDom f f' d1)
|
||||
(R.replaceDom f f' d2)
|
||||
|
||||
instance (Ord fact, Ord d1, Ord d2) => Semigroup (Star2 fact d1 d2) where
|
||||
s1 <> s2 = Star2 fact' d1' d2'
|
||||
where
|
||||
fact' = fact s1 <> fact s2
|
||||
d1' = d1 s1 <> d1 s2
|
||||
d2' = d2 s1 <> d2 s2
|
||||
|
||||
instance (Ord fact, Ord d1, Ord d2) => Monoid (Star2 fact d1 d2) where
|
||||
mempty = Star2 mempty mempty mempty
|
@ -1,291 +0,0 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module Unison.Util.Star3 where
|
||||
|
||||
import Data.Map qualified as Map
|
||||
import Data.Set qualified as Set
|
||||
import Unison.Prelude
|
||||
import Unison.Util.Relation (Relation)
|
||||
import Unison.Util.Relation qualified as R
|
||||
|
||||
-- Represents a set of (fact, d1, d2, d3), but indexed using a star schema so
|
||||
-- it can be efficiently queried from any of the dimensions.
|
||||
data Star3 fact d1 d2 d3 = Star3
|
||||
{ fact :: Set fact,
|
||||
d1 :: Relation fact d1,
|
||||
d2 :: Relation fact d2,
|
||||
d3 :: Relation fact d3
|
||||
}
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
-- Produce the cross-product across all the dimensions
|
||||
toList ::
|
||||
(Ord fact, Ord d1, Ord d2, Ord d3) =>
|
||||
Star3 fact d1 d2 d3 ->
|
||||
[(fact, d1, d2, d3)]
|
||||
toList s =
|
||||
[ (f, x, y, z) | f <- Set.toList (fact s), x <- Set.toList (R.lookupDom f (d1 s)), y <- Set.toList (R.lookupDom f (d2 s)), z <- Set.toList (R.lookupDom f (d3 s))
|
||||
]
|
||||
|
||||
-- `difference a b` contains only the facts from `a` that are absent from `b`
|
||||
-- or differ along any of the dimensions `d1..d3`.
|
||||
difference ::
|
||||
(Ord fact, Ord d1, Ord d2, Ord d3) =>
|
||||
Star3 fact d1 d2 d3 ->
|
||||
Star3 fact d1 d2 d3 ->
|
||||
Star3 fact d1 d2 d3
|
||||
difference a b = Star3 facts d1s d2s d3s
|
||||
where
|
||||
d1s = R.difference (d1 a) (d1 b)
|
||||
d2s = R.difference (d2 a) (d2 b)
|
||||
d3s = R.difference (d3 a) (d3 b)
|
||||
facts = R.dom d1s <> R.dom d2s <> R.dom d3s
|
||||
|
||||
d23s ::
|
||||
(Ord fact, Ord d2, Ord d3) =>
|
||||
Star3 fact d1 d2 d3 ->
|
||||
[(fact, d2, d3)]
|
||||
d23s s =
|
||||
[ (f, x, y) | f <- Set.toList (fact s), x <- Set.toList (R.lookupDom f (d2 s)), y <- Set.toList (R.lookupDom f (d3 s))
|
||||
]
|
||||
|
||||
d23s' ::
|
||||
(Ord fact, Ord d2, Ord d3) =>
|
||||
Star3 fact d1 d2 d3 ->
|
||||
[(d2, d3)]
|
||||
d23s' s =
|
||||
[ (x, y) | f <- Set.toList (fact s), x <- Set.toList (R.lookupDom f (d2 s)), y <- Set.toList (R.lookupDom f (d3 s))
|
||||
]
|
||||
|
||||
d12s ::
|
||||
(Ord fact, Ord d1, Ord d2) =>
|
||||
Star3 fact d1 d2 d3 ->
|
||||
[(fact, d1, d2)]
|
||||
d12s s =
|
||||
[ (f, x, y) | f <- Set.toList (fact s), x <- Set.toList (R.lookupDom f (d1 s)), y <- Set.toList (R.lookupDom f (d2 s))
|
||||
]
|
||||
|
||||
d13s ::
|
||||
(Ord fact, Ord d1, Ord d3) =>
|
||||
Star3 fact d1 d2 d3 ->
|
||||
[(fact, d1, d3)]
|
||||
d13s s =
|
||||
[ (f, x, y) | f <- Set.toList (fact s), x <- Set.toList (R.lookupDom f (d1 s)), y <- Set.toList (R.lookupDom f (d3 s))
|
||||
]
|
||||
|
||||
mapD1 :: (Ord fact, Ord d1, Ord d1a) => (d1 -> d1a) -> Star3 fact d1 d2 d3 -> Star3 fact d1a d2 d3
|
||||
mapD1 f s = s {d1 = R.mapRan f (d1 s)}
|
||||
|
||||
mapD2 :: (Ord fact, Ord d2, Ord d2a) => (d2 -> d2a) -> Star3 fact d1 d2 d3 -> Star3 fact d1 d2a d3
|
||||
mapD2 f s = s {d2 = R.mapRan f (d2 s)}
|
||||
|
||||
mapD3 :: (Ord fact, Ord d3, Ord d3a) => (d3 -> d3a) -> Star3 fact d1 d2 d3 -> Star3 fact d1 d2 d3a
|
||||
mapD3 f s = s {d3 = R.mapRan f (d3 s)}
|
||||
|
||||
fromList ::
|
||||
(Ord fact, Ord d1, Ord d2, Ord d3) =>
|
||||
[(fact, d1, d2, d3)] ->
|
||||
Star3 fact d1 d2 d3
|
||||
fromList = foldl' (flip insert) mempty
|
||||
|
||||
selectFact ::
|
||||
(Ord fact, Ord d1, Ord d2, Ord d3) =>
|
||||
Set fact ->
|
||||
Star3 fact d1 d2 d3 ->
|
||||
Star3 fact d1 d2 d3
|
||||
selectFact fs s = Star3 fact' d1' d2' d3'
|
||||
where
|
||||
fact' = Set.intersection fs (fact s)
|
||||
d1' = fs R.<| d1 s
|
||||
d2' = fs R.<| d2 s
|
||||
d3' = fs R.<| d3 s
|
||||
|
||||
select1D3 ::
|
||||
(Ord fact, Ord d1, Ord d2, Ord d3) =>
|
||||
d3 ->
|
||||
Star3 fact d1 d2 d3 ->
|
||||
Star3 fact d1 d2 d3
|
||||
select1D3 = selectD3 . Set.singleton
|
||||
|
||||
selectD3 ::
|
||||
(Ord fact, Ord d1, Ord d2, Ord d3) =>
|
||||
Set d3 ->
|
||||
Star3 fact d1 d2 d3 ->
|
||||
Star3 fact d1 d2 d3
|
||||
selectD3 d3s s = Star3 fact' d1' d2' d3'
|
||||
where
|
||||
fact' = Set.intersection (R.dom d3') (fact s)
|
||||
d1' = R.dom d3' R.<| d1 s
|
||||
d2' = R.dom d3' R.<| d2 s
|
||||
d3' = d3 s R.|> d3s
|
||||
|
||||
-- Deletes tuples of the form (fact, d1, _, _).
|
||||
-- If no other (fact, dk, _, _) tuples exist for any other dk, then
|
||||
-- `fact` is removed from the `fact` set and from the other dimensions as well,
|
||||
-- that is, (fact, d1) is treated as a primary key.
|
||||
deletePrimaryD1 ::
|
||||
(Ord fact, Ord d1, Ord d2, Ord d3) =>
|
||||
(fact, d1) ->
|
||||
Star3 fact d1 d2 d3 ->
|
||||
Star3 fact d1 d2 d3
|
||||
deletePrimaryD1 (f, x) s =
|
||||
let d1' = R.delete f x (d1 s)
|
||||
otherX = R.lookupDom f d1'
|
||||
in if Set.null otherX
|
||||
then Star3 (Set.delete f (fact s)) d1' (R.deleteDom f (d2 s)) (R.deleteDom f (d3 s))
|
||||
else s {d1 = d1'}
|
||||
|
||||
-- Deletes tuples of the form (_, d1, _, _).
|
||||
deleteD1 ::
|
||||
(Ord fact, Ord d1, Ord d2, Ord d3) =>
|
||||
d1 ->
|
||||
Star3 fact d1 d2 d3 ->
|
||||
Star3 fact d1 d2 d3
|
||||
deleteD1 x s =
|
||||
let d1' = R.deleteRan x (d1 s)
|
||||
deadFacts = R.lookupRan x (d1 s)
|
||||
newFacts = Set.difference (fact s) deadFacts
|
||||
d2' = R.subtractDom deadFacts (d2 s)
|
||||
d3' = R.subtractDom deadFacts (d3 s)
|
||||
in Star3
|
||||
newFacts
|
||||
d1'
|
||||
d2'
|
||||
d3'
|
||||
|
||||
lookupD1 :: (Ord fact, Ord d1) => d1 -> Star3 fact d1 d2 d3 -> Set fact
|
||||
lookupD1 x s = R.lookupRan x (d1 s)
|
||||
|
||||
insertD1 ::
|
||||
(Ord fact, Ord d1) =>
|
||||
(fact, d1) ->
|
||||
Star3 fact d1 d2 d3 ->
|
||||
Star3 fact d1 d2 d3
|
||||
insertD1 (f, x) s =
|
||||
s
|
||||
{ fact = Set.insert f (fact s),
|
||||
d1 = R.insert f x (d1 s)
|
||||
}
|
||||
|
||||
memberD1 :: (Ord fact, Ord d1) => (fact, d1) -> Star3 fact d1 d2 d3 -> Bool
|
||||
memberD1 (f, x) s = R.member f x (d1 s)
|
||||
|
||||
memberD2 :: (Ord fact, Ord d2) => (fact, d2) -> Star3 fact d1 d2 d3 -> Bool
|
||||
memberD2 (f, x) s = R.member f x (d2 s)
|
||||
|
||||
memberD3 :: (Ord fact, Ord d3) => (fact, d3) -> Star3 fact d1 d2 d3 -> Bool
|
||||
memberD3 (f, x) s = R.member f x (d3 s)
|
||||
|
||||
insert ::
|
||||
(Ord fact, Ord d1, Ord d2, Ord d3) =>
|
||||
(fact, d1, d2, d3) ->
|
||||
Star3 fact d1 d2 d3 ->
|
||||
Star3 fact d1 d2 d3
|
||||
insert (f, d1i, d2i, d3i) s = Star3 fact' d1' d2' d3'
|
||||
where
|
||||
fact' = Set.insert f (fact s)
|
||||
d1' = R.insert f d1i (d1 s)
|
||||
d2' = R.insert f d2i (d2 s)
|
||||
d3' = R.insert f d3i (d3 s)
|
||||
|
||||
insertD23 ::
|
||||
(Ord fact, Ord d1, Ord d2, Ord d3) =>
|
||||
(fact, d2, d3) ->
|
||||
Star3 fact d1 d2 d3 ->
|
||||
Star3 fact d1 d2 d3
|
||||
insertD23 (f, x, y) s = Star3 fact' (d1 s) d2' d3'
|
||||
where
|
||||
fact' = Set.insert f (fact s)
|
||||
d2' = R.insert f x (d2 s)
|
||||
d3' = R.insert f y (d3 s)
|
||||
|
||||
deleteD3 ::
|
||||
(Ord fact, Ord d1, Ord d2, Ord d3) =>
|
||||
(fact, d3) ->
|
||||
Star3 fact d1 d2 d3 ->
|
||||
Star3 fact d1 d2 d3
|
||||
deleteD3 (f, x) s = garbageCollect f (Star3 (fact s) (d1 s) (d2 s) d3')
|
||||
where
|
||||
d3' = R.delete f x (d3 s)
|
||||
|
||||
deleteD2 ::
|
||||
(Ord fact, Ord d1, Ord d2, Ord d3) =>
|
||||
(fact, d2) ->
|
||||
Star3 fact d1 d2 d3 ->
|
||||
Star3 fact d1 d2 d3
|
||||
deleteD2 (f, x) s = garbageCollect f (Star3 (fact s) (d1 s) d2' (d3 s))
|
||||
where
|
||||
d2' = R.delete f x (d2 s)
|
||||
|
||||
-- | Given a possibly-invalid Star3, which may contain the given fact in its fact set that are not related to any d1,
|
||||
-- d2, or d3, return a valid Star3, with this fact possibly removed.
|
||||
garbageCollect :: (Ord fact) => fact -> Star3 fact d1 d2 d3 -> Star3 fact d1 d2 d3
|
||||
garbageCollect f star =
|
||||
star
|
||||
{ fact =
|
||||
if R.memberDom f (d1 star) || R.memberDom f (d2 star) || R.memberDom f (d3 star)
|
||||
then fact star
|
||||
else Set.delete f (fact star)
|
||||
}
|
||||
|
||||
deleteFact ::
|
||||
(Ord fact, Ord d1, Ord d2, Ord d3) =>
|
||||
Set fact ->
|
||||
Star3 fact d1 d2 d3 ->
|
||||
Star3 fact d1 d2 d3
|
||||
deleteFact facts Star3 {..} =
|
||||
Star3
|
||||
(fact `Set.difference` facts)
|
||||
(facts R.<|| d1)
|
||||
(facts R.<|| d2)
|
||||
(facts R.<|| d3)
|
||||
|
||||
-- Efficiently replace facts with those in the provided `Map`.
|
||||
-- The `apply` function can be used to add other dimensions
|
||||
-- in the same traversal. It is given `apply old new s` where
|
||||
-- s is the current `Star` being accumulated.
|
||||
--
|
||||
-- Currently used by update propagation but likely useful for
|
||||
-- other bulk rewriting of namespaces.
|
||||
replaceFacts ::
|
||||
(Ord fact, Ord d1, Ord d2, Ord d3) =>
|
||||
(fact -> fact -> Star3 fact d1 d2 d3 -> Star3 fact d1 d2 d3) ->
|
||||
Map fact fact ->
|
||||
Star3 fact d1 d2 d3 ->
|
||||
Star3 fact d1 d2 d3
|
||||
replaceFacts apply m s =
|
||||
let -- the intersection of `fact` and the replacement keys is often small,
|
||||
-- so we compute that first (which can happen in O(size of intersection))
|
||||
-- rather than iterating over one or the other
|
||||
replaceable = Map.keysSet m `Set.intersection` fact s
|
||||
go s old = apply old new $ replaceFact old new s
|
||||
where
|
||||
new = Map.findWithDefault old old m
|
||||
in foldl' go s replaceable
|
||||
|
||||
replaceFact ::
|
||||
(Ord fact, Ord d1, Ord d2, Ord d3) =>
|
||||
fact ->
|
||||
fact ->
|
||||
Star3 fact d1 d2 d3 ->
|
||||
Star3 fact d1 d2 d3
|
||||
replaceFact f f' s@Star3 {..} =
|
||||
if Set.notMember f fact
|
||||
then s
|
||||
else
|
||||
Star3
|
||||
(Set.insert f' . Set.delete f $ fact)
|
||||
(R.replaceDom f f' d1)
|
||||
(R.replaceDom f f' d2)
|
||||
(R.replaceDom f f' d3)
|
||||
|
||||
instance (Ord fact, Ord d1, Ord d2, Ord d3) => Semigroup (Star3 fact d1 d2 d3) where
|
||||
s1 <> s2 = Star3 fact' d1' d2' d3'
|
||||
where
|
||||
fact' = fact s1 <> fact s2
|
||||
d1' = d1 s1 <> d1 s2
|
||||
d2' = d2 s1 <> d2 s2
|
||||
d3' = d3 s1 <> d3 s2
|
||||
|
||||
instance (Ord fact, Ord d1, Ord d2, Ord d3) => Monoid (Star3 fact d1 d2 d3) where
|
||||
mempty = Star3 mempty mempty mempty mempty
|
@ -5,7 +5,7 @@ import Data.List.NonEmpty qualified as List.NonEmpty
|
||||
import Data.Set qualified as Set
|
||||
import EasyTest
|
||||
import Unison.Name as Name
|
||||
import Unison.Syntax.Name qualified as Name (unsafeFromText)
|
||||
import Unison.Syntax.Name qualified as Name (unsafeParseText)
|
||||
import Unison.Util.Relation qualified as R
|
||||
|
||||
test :: Test ()
|
||||
@ -24,25 +24,33 @@ test =
|
||||
|
||||
testCompareSuffix :: [Test ()]
|
||||
testCompareSuffix =
|
||||
[ scope "[b.c a.b.c]" (expectEqual (compareSuffix "b.c" "a.b.c") EQ),
|
||||
scope "[a.b.c a.b.c]" (expectEqual (compareSuffix "a.b.c" "a.b.c") EQ),
|
||||
scope "[b.c a.b.b]" (expectEqual (compareSuffix "b.c" "a.b.b") LT),
|
||||
scope "[a.b.c b.c]" (expectEqual (compareSuffix "a.b.c" "b.c") LT),
|
||||
scope "[b.b a.b.c]" (expectEqual (compareSuffix "b.b" "a.b.c") GT)
|
||||
[ scope "[b.c a.b.c]" (expectEqual (compareSuffix (Name.unsafeParseText "b.c") (Name.unsafeParseText "a.b.c")) EQ),
|
||||
scope "[a.b.c a.b.c]" (expectEqual (compareSuffix (Name.unsafeParseText "a.b.c") (Name.unsafeParseText "a.b.c")) EQ),
|
||||
scope "[b.c a.b.b]" (expectEqual (compareSuffix (Name.unsafeParseText "b.c") (Name.unsafeParseText "a.b.b")) LT),
|
||||
scope "[a.b.c b.c]" (expectEqual (compareSuffix (Name.unsafeParseText "a.b.c") (Name.unsafeParseText "b.c")) LT),
|
||||
scope "[b.b a.b.c]" (expectEqual (compareSuffix (Name.unsafeParseText "b.b") (Name.unsafeParseText "a.b.c")) GT)
|
||||
]
|
||||
|
||||
testEndsWithReverseSegments :: [Test ()]
|
||||
testEndsWithReverseSegments =
|
||||
[ scope "a.b.c ends with []" (expectEqual True (endsWithReverseSegments "a.b.c" [])),
|
||||
scope "a.b.c ends with [c, b]" (expectEqual True (endsWithReverseSegments "a.b.c" ["c", "b"])),
|
||||
scope "a.b.c doesn't end with [d]" (expectEqual False (endsWithReverseSegments "a.b.c" ["d"]))
|
||||
[ scope "a.b.c ends with []" (expectEqual True (endsWithReverseSegments (Name.unsafeParseText "a.b.c") [])),
|
||||
scope
|
||||
"a.b.c ends with [c, b]"
|
||||
(expectEqual True (endsWithReverseSegments (Name.unsafeParseText "a.b.c") ["c", "b"])),
|
||||
scope
|
||||
"a.b.c doesn't end with [d]"
|
||||
(expectEqual False (endsWithReverseSegments (Name.unsafeParseText "a.b.c") ["d"]))
|
||||
]
|
||||
|
||||
testEndsWithSegments :: [Test ()]
|
||||
testEndsWithSegments =
|
||||
[ scope "a.b.c ends with []" (expectEqual True (endsWithSegments "a.b.c" [])),
|
||||
scope "a.b.c ends with [b, c]" (expectEqual True (endsWithSegments "a.b.c" ["b", "c"])),
|
||||
scope "a.b.c doesn't end with [d]" (expectEqual False (endsWithSegments "a.b.c" ["d"]))
|
||||
[ scope "a.b.c ends with []" (expectEqual True (endsWithSegments (Name.unsafeParseText "a.b.c") [])),
|
||||
scope
|
||||
"a.b.c ends with [b, c]"
|
||||
(expectEqual True (endsWithSegments (Name.unsafeParseText "a.b.c") ["b", "c"])),
|
||||
scope
|
||||
"a.b.c doesn't end with [d]"
|
||||
(expectEqual False (endsWithSegments (Name.unsafeParseText "a.b.c") ["d"]))
|
||||
]
|
||||
|
||||
testSegments :: [Test ()]
|
||||
@ -55,19 +63,25 @@ testSegments =
|
||||
|
||||
testSplitName :: [Test ()]
|
||||
testSplitName =
|
||||
[ scope "x" (expectEqual (splits "x") [([], "x")]),
|
||||
scope "A.x" (expectEqual (splits "A.x") [([], "A.x"), (["A"], "x")]),
|
||||
scope "A.B.x" (expectEqual (splits "A.B.x") [([], "A.B.x"), (["A"], "B.x"), (["A", "B"], "x")])
|
||||
[ scope "x" (expectEqual (splits (Name.unsafeParseText "x")) [([], Name.unsafeParseText "x")]),
|
||||
scope "A.x" (expectEqual (splits (Name.unsafeParseText "A.x")) [([], Name.unsafeParseText "A.x"), (["A"], Name.unsafeParseText "x")]),
|
||||
scope
|
||||
"A.B.x"
|
||||
( expectEqual
|
||||
(splits (Name.unsafeParseText "A.B.x"))
|
||||
[ ([], Name.unsafeParseText "A.B.x"),
|
||||
(["A"], Name.unsafeParseText "B.x"),
|
||||
(["A", "B"], Name.unsafeParseText "x")
|
||||
]
|
||||
)
|
||||
]
|
||||
|
||||
testSuffixes :: [Test ()]
|
||||
testSuffixes =
|
||||
[ scope "one namespace" $ expectEqual (suffixes "bar") ["bar"],
|
||||
scope "two namespaces" $
|
||||
expectEqual (suffixes "foo.bar") ["foo.bar", "bar"],
|
||||
scope "multiple namespaces" $
|
||||
expectEqual (suffixes "foo.bar.baz") ["foo.bar.baz", "bar.baz", "baz"],
|
||||
scope "terms named `.`" $ expectEqual (suffixes "base..") ["base..", "."]
|
||||
[ scope "one namespace" $ expectEqual (suffixes (Name.unsafeParseText "bar")) [Name.unsafeParseText "bar"],
|
||||
scope "two namespaces" $ expectEqual (suffixes (Name.unsafeParseText "foo.bar")) [Name.unsafeParseText "foo.bar", Name.unsafeParseText "bar"],
|
||||
scope "multiple namespaces" $ expectEqual (suffixes (Name.unsafeParseText "foo.bar.baz")) [Name.unsafeParseText "foo.bar.baz", Name.unsafeParseText "bar.baz", Name.unsafeParseText "baz"],
|
||||
scope "terms named `.`" $ expectEqual (suffixes (Name.unsafeParseText "base.`.`")) [Name.unsafeParseText "base.`.`", Name.unsafeParseText "`.`"]
|
||||
]
|
||||
|
||||
testSuffixSearch :: [Test ()]
|
||||
@ -81,37 +95,23 @@ testSuffixSearch =
|
||||
(n "foo.bar.baz", 3),
|
||||
(n "a.b.c", 4),
|
||||
(n "a1.b.c", 5),
|
||||
(n "..", 6)
|
||||
(n ".`.`", 6)
|
||||
]
|
||||
n = Name.unsafeFromText
|
||||
expectEqual' ("." :| []) (Name.segments (n ".."))
|
||||
expectEqual' ("." :| []) (Name.reverseSegments (n ".."))
|
||||
n = Name.unsafeParseText
|
||||
expectEqual' ("." :| []) (Name.reverseSegments (n ".`.`"))
|
||||
expectEqual' ("." :| []) (Name.reverseSegments (n ".`.`"))
|
||||
|
||||
expectEqual'
|
||||
(Set.fromList [1, 2])
|
||||
(Name.searchBySuffix (n "map") rel)
|
||||
expectEqual'
|
||||
(n "List.map")
|
||||
(Name.suffixifyByHash (n "base.List.map") rel)
|
||||
expectEqual'
|
||||
(n "Set.map")
|
||||
(Name.suffixifyByHash (n "base.Set.map") rel)
|
||||
expectEqual'
|
||||
(n "baz")
|
||||
(Name.suffixifyByHash (n "foo.bar.baz") rel)
|
||||
expectEqual'
|
||||
(n "a.b.c")
|
||||
(Name.suffixifyByHash (n "a.b.c") rel)
|
||||
expectEqual'
|
||||
(n "a1.b.c")
|
||||
(Name.suffixifyByHash (n "a1.b.c") rel)
|
||||
note . show $ Name.reverseSegments (n ".")
|
||||
note . show $ Name.reverseSegments (n "..")
|
||||
expectEqual' (Set.fromList [1, 2]) (Name.searchBySuffix (n "map") rel)
|
||||
expectEqual' (n "List.map") (Name.suffixifyByHash (n "base.List.map") rel)
|
||||
expectEqual' (n "Set.map") (Name.suffixifyByHash (n "base.Set.map") rel)
|
||||
expectEqual' (n "baz") (Name.suffixifyByHash (n "foo.bar.baz") rel)
|
||||
expectEqual' (n "a.b.c") (Name.suffixifyByHash (n "a.b.c") rel)
|
||||
expectEqual' (n "a1.b.c") (Name.suffixifyByHash (n "a1.b.c") rel)
|
||||
note . show $ Name.reverseSegments (n "`.`")
|
||||
note . show $ Name.reverseSegments (n ".`.`")
|
||||
tests
|
||||
[ scope "(.) shortest unique suffix" $
|
||||
expectEqual' (n ".") (Name.suffixifyByHash (n "..") rel),
|
||||
scope "(.) search by suffix" $
|
||||
expectEqual' (Set.fromList [6]) (Name.searchBySuffix (n ".") rel)
|
||||
[ scope "(.) shortest unique suffix" $ expectEqual' (n "`.`") (Name.suffixifyByHash (n ".`.`") rel),
|
||||
scope "(.) search by suffix" $ expectEqual' (Set.fromList [6]) (Name.searchBySuffix (n "`.`") rel)
|
||||
]
|
||||
ok
|
||||
]
|
||||
@ -119,23 +119,23 @@ testSuffixSearch =
|
||||
testUnsafeFromString :: [Test ()]
|
||||
testUnsafeFromString =
|
||||
[ scope "." do
|
||||
expectEqual' (isAbsolute ".") False
|
||||
expectEqual' (segments ".") ("." :| [])
|
||||
expectEqual' (isAbsolute (Name.unsafeParseText "`.`")) False
|
||||
expectEqual' (segments (Name.unsafeParseText "`.`")) ("." :| [])
|
||||
ok,
|
||||
scope ".." do
|
||||
expectEqual' (isAbsolute "..") True
|
||||
expectEqual' (segments "..") ("." :| [])
|
||||
scope ".`.`" do
|
||||
expectEqual' (isAbsolute (Name.unsafeParseText ".`.`")) True
|
||||
expectEqual' (segments (Name.unsafeParseText ".`.`")) ("." :| [])
|
||||
ok,
|
||||
scope "foo.bar" do
|
||||
expectEqual' (isAbsolute "foo.bar") False
|
||||
expectEqual' (segments "foo.bar") ("foo" :| ["bar"])
|
||||
expectEqual' (isAbsolute (Name.unsafeParseText "foo.bar")) False
|
||||
expectEqual' (segments (Name.unsafeParseText "foo.bar")) ("foo" :| ["bar"])
|
||||
ok,
|
||||
scope ".foo.bar" do
|
||||
expectEqual' (isAbsolute ".foo.bar") True
|
||||
expectEqual' (segments ".foo.bar") ("foo" :| ["bar"])
|
||||
expectEqual' (isAbsolute (Name.unsafeParseText ".foo.bar")) True
|
||||
expectEqual' (segments (Name.unsafeParseText ".foo.bar")) ("foo" :| ["bar"])
|
||||
ok,
|
||||
scope "foo.." do
|
||||
expectEqual' (isAbsolute "foo..") False
|
||||
expectEqual' (segments "foo..") ("foo" :| ["."])
|
||||
scope "foo.`.`" do
|
||||
expectEqual' (isAbsolute (Name.unsafeParseText "foo.`.`")) False
|
||||
expectEqual' (segments (Name.unsafeParseText "foo.`.`")) ("foo" :| ["."])
|
||||
ok
|
||||
]
|
||||
|
@ -4,6 +4,7 @@ module Unison.Test.Codebase.Branch
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Function ((&))
|
||||
import Data.Functor.Identity
|
||||
import Data.Map qualified as Map
|
||||
import Data.Set qualified as Set
|
||||
@ -11,10 +12,11 @@ import EasyTest
|
||||
import Unison.Codebase.Branch (Branch (Branch), Branch0)
|
||||
import Unison.Codebase.Branch qualified as Branch
|
||||
import Unison.Codebase.Causal qualified as Causal
|
||||
import Unison.Codebase.Metadata qualified as Metadata
|
||||
import Unison.Reference (Reference)
|
||||
import Unison.Reference qualified as Reference
|
||||
import Unison.Util.Relation qualified as Relation
|
||||
import Unison.Util.Star3 qualified as Star3
|
||||
import Unison.Util.Star2 qualified as Star2
|
||||
|
||||
test :: Test ()
|
||||
test =
|
||||
@ -31,7 +33,10 @@ branch0Tests =
|
||||
b0 :: Branch0 Identity =
|
||||
Branch.branch0
|
||||
mempty
|
||||
(Star3.fromList [(dummy, "b", dummy, (dummy, dummy))])
|
||||
( mempty
|
||||
& Star2.insertD1 (dummy, "b")
|
||||
& Metadata.insert (dummy, dummy)
|
||||
)
|
||||
Map.empty
|
||||
Map.empty
|
||||
let -- a.b
|
||||
@ -39,7 +44,10 @@ branch0Tests =
|
||||
b1 :: Branch0 Identity =
|
||||
Branch.branch0
|
||||
mempty
|
||||
(Star3.fromList [(dummy, "b", dummy, (dummy, dummy))])
|
||||
( mempty
|
||||
& Star2.insertD1 (dummy, "b")
|
||||
& Metadata.insert (dummy, dummy)
|
||||
)
|
||||
(Map.singleton "a" (Branch (Causal.one b0)))
|
||||
Map.empty
|
||||
|
||||
|
@ -1,58 +1,30 @@
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Unison.Test.Codebase.Path where
|
||||
|
||||
import Data.Either
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.Sequence
|
||||
import Data.Text
|
||||
import EasyTest
|
||||
import Unison.Codebase.Path
|
||||
import Unison.Codebase.Path.Parse
|
||||
import Unison.Codebase.Path (Path (..), Path' (..), Relative (..))
|
||||
import Unison.Codebase.Path.Parse (parseHQSplit', parseShortHashOrHQSplit')
|
||||
import Unison.HashQualified' qualified as HQ'
|
||||
import Unison.NameSegment
|
||||
import Unison.NameSegment (NameSegment)
|
||||
import Unison.Prelude
|
||||
import Unison.ShortHash qualified as SH
|
||||
|
||||
test :: Test ()
|
||||
test =
|
||||
scope "path" . tests $
|
||||
[ scope "parsePathImpl'" . tests $
|
||||
[ let s = "foo.bar.baz.34" in scope s . expect $ parsePathImpl' s == Right (relative ["foo", "bar", "baz"], "34"),
|
||||
let s = "foo.bar.baz" in scope s . expect $ parsePathImpl' s == Right (relative ["foo", "bar"], "baz"),
|
||||
let s = "baz" in scope s . expect $ parsePathImpl' s == Right (relative [], "baz"),
|
||||
let s = "-" in scope s . expect $ parsePathImpl' s == Right (relative [], "-"),
|
||||
let s = "34" in scope s . pending . expect $ parsePathImpl' s == Right (relative [], "34"),
|
||||
let s = "foo.bar.baz#a8fj" in scope s . expect $ isLeft $ parsePathImpl' s
|
||||
],
|
||||
scope "parseSplit'" . tests $
|
||||
[ scope "wordyNameSegment" . tests $
|
||||
[ let s = "foo.bar.baz"
|
||||
in scope s . expect $
|
||||
parseSplit' wordyNameSegment s == Right (relative ["foo", "bar"], NameSegment "baz"),
|
||||
let s = "foo.bar.baz#abc" in scope s . expect $ isLeft $ parseSplit' wordyNameSegment s,
|
||||
let s = "foo.bar.+"
|
||||
in scope s . expect $
|
||||
isLeft $
|
||||
parseSplit' wordyNameSegment s
|
||||
],
|
||||
scope "definitionNameSegment" . tests $
|
||||
[ let s = "foo.bar.+"
|
||||
in scope s . expect $
|
||||
parseSplit' definitionNameSegment s == Right (relative ["foo", "bar"], NameSegment "+")
|
||||
]
|
||||
],
|
||||
scope "parseShortHashOrHQSplit'" . tests $
|
||||
[ scope "parseShortHashOrHQSplit'" . tests $
|
||||
[ let s = "foo.bar#34"
|
||||
in scope s . expect $
|
||||
parseShortHashOrHQSplit' s
|
||||
== (Right . Right)
|
||||
(relative ["foo"], HQ'.HashQualified (NameSegment "bar") (fromJust (SH.fromText "#34"))),
|
||||
(relative ["foo"], HQ'.HashQualified "bar" (fromJust (SH.fromText "#34"))),
|
||||
let s = "foo.bar.+"
|
||||
in scope s . expect $
|
||||
parseShortHashOrHQSplit' s
|
||||
== (Right . Right)
|
||||
(relative ["foo", "bar"], HQ'.NameOnly (NameSegment "+")),
|
||||
(relative ["foo", "bar"], HQ'.NameOnly "+"),
|
||||
let s = "#123"
|
||||
in scope s . expect $
|
||||
parseShortHashOrHQSplit' s
|
||||
@ -61,13 +33,13 @@ test =
|
||||
scope "parseHQ'Split'" . tests $
|
||||
[ let s = "foo.bar#34"
|
||||
in scope s . expect $
|
||||
parseHQSplit' s == Right (relative ["foo"], HQ'.HashQualified (NameSegment "bar") (fromJust (SH.fromText "#34"))),
|
||||
parseHQSplit' s == Right (relative ["foo"], HQ'.HashQualified "bar" (fromJust (SH.fromText "#34"))),
|
||||
let s = "foo.bar.+"
|
||||
in scope s . expect $
|
||||
parseHQSplit' s == Right (relative ["foo", "bar"], HQ'.NameOnly (NameSegment "+")),
|
||||
parseHQSplit' s == Right (relative ["foo", "bar"], HQ'.NameOnly "+"),
|
||||
let s = "#123" in scope s . expect $ isLeft $ parseHQSplit' s
|
||||
]
|
||||
]
|
||||
|
||||
relative :: Seq Text -> Path'
|
||||
relative = Path' . Right . Relative . Path . fmap NameSegment
|
||||
relative :: Seq NameSegment -> Path'
|
||||
relative = Path' . Right . Relative . Path
|
||||
|
@ -189,7 +189,7 @@ library
|
||||
Unison.Util.PinBoard
|
||||
Unison.Util.Pretty.MegaParsec
|
||||
Unison.Util.RefPromise
|
||||
Unison.Util.Star3
|
||||
Unison.Util.Star2
|
||||
Unison.Util.Text
|
||||
Unison.Util.Text.Pattern
|
||||
Unison.Util.TQueue
|
||||
|
@ -402,7 +402,7 @@ popd = do
|
||||
|
||||
setMostRecentNamespace :: Path.Absolute -> Cli ()
|
||||
setMostRecentNamespace =
|
||||
runTransaction . Queries.setMostRecentNamespace . map NameSegment.toText . Path.toList . Path.unabsolute
|
||||
runTransaction . Queries.setMostRecentNamespace . map NameSegment.toUnescapedText . Path.toList . Path.unabsolute
|
||||
|
||||
respond :: Output -> Cli ()
|
||||
respond output = do
|
||||
|
@ -63,7 +63,6 @@ module Unison.Cli.MonadUtils
|
||||
-- * Patches
|
||||
|
||||
-- ** Default patch
|
||||
defaultPatchNameSegment,
|
||||
defaultPatchPath,
|
||||
|
||||
-- ** Getting patches
|
||||
@ -112,7 +111,7 @@ import Unison.Codebase.ShortCausalHash qualified as SCH
|
||||
import Unison.HashQualified qualified as HQ
|
||||
import Unison.HashQualified' qualified as HQ'
|
||||
import Unison.Name qualified as Name
|
||||
import Unison.NameSegment (NameSegment)
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Names (Names)
|
||||
import Unison.Parser.Ann (Ann (..))
|
||||
import Unison.Prelude
|
||||
@ -498,13 +497,10 @@ getTypesAt path = do
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- Getting patches
|
||||
|
||||
defaultPatchNameSegment :: NameSegment
|
||||
defaultPatchNameSegment = "patch"
|
||||
|
||||
-- | The default patch path.
|
||||
defaultPatchPath :: Path.Split'
|
||||
defaultPatchPath =
|
||||
(Path.RelativePath' (Path.Relative Path.empty), defaultPatchNameSegment)
|
||||
(Path.RelativePath' (Path.Relative Path.empty), NameSegment.defaultPatchSegment)
|
||||
|
||||
-- | Get the patch at a path, or the empty patch if there's no such patch.
|
||||
getPatchAt :: Path.Split' -> Cli Patch
|
||||
|
@ -17,6 +17,7 @@ module Unison.Cli.Pretty
|
||||
prettyHash32,
|
||||
prettyHumanReadableTime,
|
||||
prettyLabeledDependencies,
|
||||
prettyPath,
|
||||
prettyPath',
|
||||
prettyProjectAndBranchName,
|
||||
prettyBranchName,
|
||||
@ -159,7 +160,7 @@ prettyShareLink :: WriteShareRemoteNamespace -> Pretty
|
||||
prettyShareLink WriteShareRemoteNamespace {repo, path} =
|
||||
let encodedPath =
|
||||
Path.toList path
|
||||
& fmap (URI.encodeText . NameSegment.toText)
|
||||
& fmap (URI.encodeText . NameSegment.toUnescapedText)
|
||||
& Text.intercalate "/"
|
||||
in P.green . P.text $ shareOrigin <> "/@" <> shareUserHandleToText repo <> "/p/code/latest/namespaces/" <> encodedPath
|
||||
|
||||
@ -176,6 +177,12 @@ prettyFilePath :: FilePath -> Pretty
|
||||
prettyFilePath fp =
|
||||
P.blue (P.string fp)
|
||||
|
||||
prettyPath :: Path.Path -> Pretty
|
||||
prettyPath path =
|
||||
if path == Path.empty
|
||||
then "the current namespace"
|
||||
else P.blue (P.shown path)
|
||||
|
||||
prettyPath' :: Path.Path' -> Pretty
|
||||
prettyPath' p' =
|
||||
if Path.isCurrentPath p'
|
||||
|
@ -38,6 +38,6 @@ loadUniqueTypeGuid currentPath name0 = do
|
||||
-- an appropriate time, such as after the current unison file finishes parsing).
|
||||
let loadBranchAtPath :: [NameSegment] -> Sqlite.Transaction (Maybe (Codebase.Branch.Branch Sqlite.Transaction))
|
||||
loadBranchAtPath segments =
|
||||
Operations.loadBranchAtPath Nothing (map NameSegment.toText segments)
|
||||
Operations.loadBranchAtPath Nothing (map NameSegment.toUnescapedText segments)
|
||||
|
||||
Codebase.loadUniqueTypeGuid loadBranchAtPath (Foldable.toList @Seq branchPath) name
|
||||
|
@ -22,15 +22,15 @@ import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo
|
||||
import Unison.Codebase.Editor.UriParser qualified as UriParser
|
||||
import Unison.Codebase.Path (Path' (..))
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Prelude
|
||||
import Unison.Syntax.NameSegment qualified as NameSegment
|
||||
|
||||
configKey :: Text -> Path.Absolute -> Text
|
||||
configKey k p =
|
||||
Text.intercalate "." . toList $
|
||||
k
|
||||
:<| fmap
|
||||
NameSegment.toText
|
||||
NameSegment.toEscapedText
|
||||
(Path.toSeq $ Path.unabsolute p)
|
||||
|
||||
gitUrlKey :: Path.Absolute -> Text
|
||||
|
@ -32,6 +32,7 @@ import System.Directory (XdgDirectory (..), createDirectoryIfMissing, doesFileEx
|
||||
import System.Exit (ExitCode (..))
|
||||
import System.FilePath ((</>))
|
||||
import System.Process (callProcess, readCreateProcessWithExitCode, shell)
|
||||
import Text.Megaparsec qualified as Megaparsec
|
||||
import U.Codebase.Branch.Diff qualified as V2Branch.Diff
|
||||
import U.Codebase.Causal qualified as V2Causal
|
||||
import U.Codebase.HashTags (CausalHash (..))
|
||||
@ -178,9 +179,11 @@ import Unison.Share.Codeserver qualified as Codeserver
|
||||
import Unison.ShortHash qualified as SH
|
||||
import Unison.Sqlite qualified as Sqlite
|
||||
import Unison.Symbol (Symbol)
|
||||
import Unison.Syntax.HashQualified qualified as HQ (fromString, toString, toText, unsafeFromString)
|
||||
import Unison.Syntax.HashQualified qualified as HQ (parseText, parseTextWith, toText, unsafeParseText)
|
||||
import Unison.Syntax.Lexer qualified as L
|
||||
import Unison.Syntax.Name qualified as Name (toString, toText, toVar, unsafeFromVar)
|
||||
import Unison.Syntax.Lexer qualified as Lexer
|
||||
import Unison.Syntax.Name qualified as Name (toText, toVar, unsafeParseVar)
|
||||
import Unison.Syntax.NameSegment qualified as NameSegment (toEscapedText)
|
||||
import Unison.Syntax.Parser qualified as Parser
|
||||
import Unison.Syntax.TermPrinter qualified as TP
|
||||
import Unison.Term (Term)
|
||||
@ -200,7 +203,7 @@ import Unison.Util.Pretty qualified as Pretty
|
||||
import Unison.Util.Relation qualified as R
|
||||
import Unison.Util.Relation qualified as Relation
|
||||
import Unison.Util.Set qualified as Set
|
||||
import Unison.Util.Star3 qualified as Star3
|
||||
import Unison.Util.Star2 qualified as Star2
|
||||
import Unison.Util.TransitiveClosure (transitiveClosure)
|
||||
import Unison.Var (Var)
|
||||
import Unison.Var qualified as Var
|
||||
@ -801,7 +804,7 @@ loop e = do
|
||||
(seg, _) <- Map.toList (Branch._edits b)
|
||||
]
|
||||
Cli.respond $ ListOfPatches $ Set.fromList patches
|
||||
Cli.setNumberedArgs $ fmap Name.toString patches
|
||||
Cli.setNumberedArgs $ fmap (Text.unpack . Name.toText) patches
|
||||
FindShallowI pathArg -> do
|
||||
Cli.Env {codebase} <- ask
|
||||
|
||||
@ -820,11 +823,11 @@ loop e = do
|
||||
where
|
||||
entryToHQString :: ShallowListEntry v Ann -> String
|
||||
entryToHQString e =
|
||||
fixup case e of
|
||||
ShallowTypeEntry te -> Text.unpack $ Backend.typeEntryDisplayName te
|
||||
ShallowTermEntry te -> Text.unpack $ Backend.termEntryDisplayName te
|
||||
ShallowBranchEntry ns _ _ -> NameSegment.toString ns
|
||||
ShallowPatchEntry ns -> NameSegment.toString ns
|
||||
fixup $ Text.unpack case e of
|
||||
ShallowTypeEntry te -> Backend.typeEntryDisplayName te
|
||||
ShallowTermEntry te -> Backend.termEntryDisplayName te
|
||||
ShallowBranchEntry ns _ _ -> NameSegment.toEscapedText ns
|
||||
ShallowPatchEntry ns -> NameSegment.toEscapedText ns
|
||||
where
|
||||
fixup s = case pathArgStr of
|
||||
"" -> s
|
||||
@ -904,8 +907,8 @@ loop e = do
|
||||
ambiguous t rs =
|
||||
Cli.returnEarly case t of
|
||||
HQ.HashOnly h -> HashAmbiguous h rs'
|
||||
(Path.parseHQSplit' . HQ.toString -> Right n) -> DeleteNameAmbiguous hqLength n rs' Set.empty
|
||||
_ -> BadName (HQ.toString t)
|
||||
(Path.parseHQSplit' . Text.unpack . HQ.toText -> Right n) -> DeleteNameAmbiguous hqLength n rs' Set.empty
|
||||
_ -> BadName (HQ.toText t)
|
||||
where
|
||||
rs' = Set.map Referent.Ref $ Set.fromList rs
|
||||
|
||||
@ -1045,9 +1048,9 @@ loop e = do
|
||||
hqLength <- Cli.runTransaction Codebase.hashLength
|
||||
uf <- Cli.expectLatestTypecheckedFile
|
||||
let datas, effects, terms :: [(Name, Reference.Id)]
|
||||
datas = [(Name.unsafeFromVar v, r) | (v, (r, _d)) <- Map.toList $ UF.dataDeclarationsId' uf]
|
||||
effects = [(Name.unsafeFromVar v, r) | (v, (r, _e)) <- Map.toList $ UF.effectDeclarationsId' uf]
|
||||
terms = [(Name.unsafeFromVar v, r) | (v, (_, r, _wk, _tm, _tp)) <- Map.toList $ UF.hashTermsId uf]
|
||||
datas = [(Name.unsafeParseVar v, r) | (v, (r, _d)) <- Map.toList $ UF.dataDeclarationsId' uf]
|
||||
effects = [(Name.unsafeParseVar v, r) | (v, (r, _e)) <- Map.toList $ UF.effectDeclarationsId' uf]
|
||||
terms = [(Name.unsafeParseVar v, r) | (v, (_, r, _wk, _tm, _tp)) <- Map.toList $ UF.hashTermsId uf]
|
||||
Cli.respond $ DumpUnisonFileHashes hqLength datas effects terms
|
||||
DebugTabCompletionI inputs -> do
|
||||
Cli.Env {authHTTPClient, codebase} <- ask
|
||||
@ -1107,9 +1110,9 @@ loop e = do
|
||||
Branch0 terms0 types0 children0 patches0 _ _ _ _ _ ->
|
||||
let ignoreMetadata :: (Ord r, Ord n) => Metadata.Star r n -> r -> (r, Set n)
|
||||
ignoreMetadata s r =
|
||||
(r, R.lookupDom r $ Star3.d1 s)
|
||||
terms = Map.fromList . map (ignoreMetadata terms0) . Foldable.toList $ Star3.fact terms0
|
||||
types = Map.fromList . map (ignoreMetadata types0) . Foldable.toList $ Star3.fact types0
|
||||
(r, R.lookupDom r $ Star2.d1 s)
|
||||
terms = Map.fromList . map (ignoreMetadata terms0) . Foldable.toList $ Star2.fact terms0
|
||||
types = Map.fromList . map (ignoreMetadata types0) . Foldable.toList $ Star2.fact types0
|
||||
patches = fmap fst patches0
|
||||
children = fmap Branch.headHash children0
|
||||
in do
|
||||
@ -1127,14 +1130,14 @@ loop e = do
|
||||
[ Monoid.unlessM (null causalParents) $ P.lit "Causal Parents:" <> P.newline <> P.indentN 2 (P.lines (map P.shown $ Set.toList causalParents)),
|
||||
Monoid.unlessM (null terms) $ P.lit "Terms:" <> P.newline <> P.indentN 2 (P.lines (map (prettyDefn Referent.toText) $ Map.toList terms)),
|
||||
Monoid.unlessM (null types) $ P.lit "Types:" <> P.newline <> P.indentN 2 (P.lines (map (prettyDefn Reference.toText) $ Map.toList types)),
|
||||
Monoid.unlessM (null patches) $ P.lit "Patches:" <> P.newline <> P.indentN 2 (P.column2 (map (bimap (P.text . NameSegment.toText) P.shown) $ Map.toList patches)),
|
||||
Monoid.unlessM (null children) $ P.lit "Children:" <> P.newline <> P.indentN 2 (P.column2 (map (bimap (P.text . NameSegment.toText) P.shown) $ Map.toList children))
|
||||
Monoid.unlessM (null patches) $ P.lit "Patches:" <> P.newline <> P.indentN 2 (P.column2 (map (bimap (P.text . NameSegment.toEscapedText) P.shown) $ Map.toList patches)),
|
||||
Monoid.unlessM (null children) $ P.lit "Children:" <> P.newline <> P.indentN 2 (P.column2 (map (bimap (P.text . NameSegment.toEscapedText) P.shown) $ Map.toList children))
|
||||
]
|
||||
)
|
||||
where
|
||||
prettyRef renderR r = P.indentN 2 $ P.text (renderR r)
|
||||
prettyDefn renderR (r, Foldable.toList -> names) =
|
||||
P.lines (P.text . NameSegment.toText <$> if null names then [NameSegment "<unnamed>"] else names) <> P.newline <> prettyRef renderR r
|
||||
P.lines (P.text <$> if null names then ["<unnamed>"] else NameSegment.toEscapedText <$> names) <> P.newline <> prettyRef renderR r
|
||||
rootBranch <- Cli.getRootBranch
|
||||
void . liftIO . flip State.execStateT mempty $ goCausal [getCausal rootBranch]
|
||||
DebugDumpNamespaceSimpleI -> do
|
||||
@ -1319,7 +1322,7 @@ inputDescription input =
|
||||
scope <- p' scope0
|
||||
pure ("patch " <> p <> " " <> scope)
|
||||
UndoI {} -> pure "undo"
|
||||
ExecuteI s args -> pure ("execute " <> Text.unwords (fmap Text.pack (s : args)))
|
||||
ExecuteI s args -> pure ("execute " <> Text.unwords (s : fmap Text.pack args))
|
||||
IOTestI hq -> pure ("io.test " <> HQ.toText hq)
|
||||
IOTestAllI -> pure "io.test.all"
|
||||
UpdateBuiltinsI -> pure "builtins.update"
|
||||
@ -1327,14 +1330,14 @@ inputDescription input =
|
||||
MergeIOBuiltinsI -> pure "builtins.mergeio"
|
||||
MakeStandaloneI out nm -> pure ("compile " <> Text.pack out <> " " <> HQ.toText nm)
|
||||
ExecuteSchemeI nm args ->
|
||||
pure $ "run.native " <> Text.unwords (fmap Text.pack (nm : args))
|
||||
CompileSchemeI fi nm -> pure ("compile.native " <> HQ.toText nm <> " " <> Text.pack fi)
|
||||
pure $ "run.native " <> Text.unwords (nm : fmap Text.pack args)
|
||||
CompileSchemeI fi nm -> pure ("compile.native " <> HQ.toText nm <> " " <> fi)
|
||||
GenSchemeLibsI mdir ->
|
||||
pure $
|
||||
"compile.native.genlibs" <> Text.pack (maybe "" (" " ++) mdir)
|
||||
FetchSchemeCompilerI name branch ->
|
||||
pure ("compile.native.fetch" <> Text.pack name <> " " <> Text.pack branch)
|
||||
CreateAuthorI (NameSegment id) name -> pure ("create.author " <> id <> " " <> name)
|
||||
CreateAuthorI id name -> pure ("create.author " <> NameSegment.toEscapedText id <> " " <> name)
|
||||
RemoveTermReplacementI src p0 -> do
|
||||
p <- opatch p0
|
||||
pure ("delete.term-replacement" <> HQ.toText src <> " " <> p)
|
||||
@ -1348,7 +1351,6 @@ inputDescription input =
|
||||
pure (Text.unwords ["diff.namespace.to-patch", branchId1, branchId2, patch])
|
||||
ClearI {} -> pure "clear"
|
||||
DocToMarkdownI name -> pure ("debug.doc-to-markdown " <> Name.toText name)
|
||||
UpgradeI old new -> pure (Text.unwords ["upgrade", NameSegment.toText old, NameSegment.toText new])
|
||||
--
|
||||
ApiI -> wat
|
||||
AuthLoginI {} -> wat
|
||||
@ -1414,6 +1416,7 @@ inputDescription input =
|
||||
TodoI {} -> wat
|
||||
UiI {} -> wat
|
||||
UpI {} -> wat
|
||||
UpgradeI {} -> wat
|
||||
VersionI -> wat
|
||||
where
|
||||
hp' :: Either SCH.ShortCausalHash Path' -> Cli Text
|
||||
@ -1434,7 +1437,7 @@ inputDescription input =
|
||||
hqs' :: Path.HQSplit' -> Cli Text
|
||||
hqs' (p0, hq) = do
|
||||
p <- if Path.isRoot' p0 then pure mempty else p' p0
|
||||
pure (p <> "." <> HQ'.toTextWith NameSegment.toText hq)
|
||||
pure (p <> "." <> HQ'.toTextWith NameSegment.toEscapedText hq)
|
||||
hqs (p, hq) = hqs' (Path' . Right . Path.Relative $ p, hq)
|
||||
ps' = p' . Path.unsplit'
|
||||
looseCodeOrProjectToText :: Input.LooseCodeOrProject -> Cli Text
|
||||
@ -1494,8 +1497,14 @@ handleFindI isVerbose fscope ws input = do
|
||||
searchResultsFor names (Set.toList matches) []
|
||||
|
||||
-- name query
|
||||
(map HQ.unsafeFromString -> qs) -> do
|
||||
let srs = searchBranchScored names fuzzyNameDistance qs
|
||||
qs -> do
|
||||
let anythingBeforeHash :: Megaparsec.Parsec (Lexer.Token Text) [Char] Text
|
||||
anythingBeforeHash = Text.pack <$> Megaparsec.takeWhileP Nothing (/= '#')
|
||||
let srs =
|
||||
searchBranchScored
|
||||
names
|
||||
Find.simpleFuzzyScore
|
||||
(mapMaybe (HQ.parseTextWith anythingBeforeHash . Text.pack) qs)
|
||||
pure $ uniqueBy SR.toReferent srs
|
||||
let respondResults results = do
|
||||
Cli.setNumberedArgs $ fmap searchResultToHQString results
|
||||
@ -1507,7 +1516,7 @@ handleFindI isVerbose fscope ws input = do
|
||||
Cli.respond FindNoLocalMatches
|
||||
-- We've already searched everything else, so now we search JUST the
|
||||
-- names in lib.
|
||||
let mayOnlyLibBranch = currentBranch0 & Branch.children %%~ (\cs -> Map.singleton "lib" <$> Map.lookup "lib" cs)
|
||||
let mayOnlyLibBranch = currentBranch0 & Branch.children %%~ \cs -> Map.singleton NameSegment.libSegment <$> Map.lookup NameSegment.libSegment cs
|
||||
case mayOnlyLibBranch of
|
||||
Nothing -> respondResults []
|
||||
Just onlyLibBranch -> do
|
||||
@ -1584,7 +1593,7 @@ handleDependents hq = do
|
||||
r <- Set.toList dependents
|
||||
Just (isTerm, hq) <- [(True,) <$> PPE.terms fqppe (Referent.Ref r), (False,) <$> PPE.types fqppe r]
|
||||
fullName <- [HQ'.toName hq]
|
||||
guard (not (Name.beginsWithSegment fullName Name.libSegment))
|
||||
guard (not (Name.beginsWithSegment fullName NameSegment.libSegment))
|
||||
Just shortName <- pure $ PPE.terms ppe (Referent.Ref r) <|> PPE.types ppe r
|
||||
pure (isTerm, HQ'.toHQ shortName, r)
|
||||
pure results
|
||||
@ -1823,15 +1832,10 @@ confirmedCommand i = do
|
||||
-- | restores the full hash to these search results, for _numberedArgs purposes
|
||||
searchResultToHQString :: SearchResult -> String
|
||||
searchResultToHQString = \case
|
||||
SR.Tm' n r _ -> HQ.toString $ HQ.requalify n r
|
||||
SR.Tp' n r _ -> HQ.toString $ HQ.requalify n (Referent.Ref r)
|
||||
SR.Tm' n r _ -> Text.unpack $ HQ.toText $ HQ.requalify n r
|
||||
SR.Tp' n r _ -> Text.unpack $ HQ.toText $ HQ.requalify n (Referent.Ref r)
|
||||
_ -> error "impossible match failure"
|
||||
|
||||
-- Return a list of definitions whose names fuzzy match the given queries.
|
||||
fuzzyNameDistance :: Name -> Name -> Maybe Int
|
||||
fuzzyNameDistance (Name.toString -> q) (Name.toString -> n) =
|
||||
Find.simpleFuzzyScore q n
|
||||
|
||||
-- return `name` and `name.<everything>...`
|
||||
_searchBranchPrefix :: Branch m -> Name -> [SearchResult]
|
||||
_searchBranchPrefix b n = case Path.unsnoc (Path.fromName n) of
|
||||
@ -1866,8 +1870,8 @@ searchBranchScored ::
|
||||
forall score.
|
||||
(Ord score) =>
|
||||
Names ->
|
||||
(Name -> Name -> Maybe score) ->
|
||||
[HQ.HashQualified Name] ->
|
||||
(Text -> Text -> Maybe score) ->
|
||||
[HQ.HashQualified Text] ->
|
||||
[SearchResult]
|
||||
searchBranchScored names0 score queries =
|
||||
nubOrd
|
||||
@ -1877,9 +1881,9 @@ searchBranchScored names0 score queries =
|
||||
where
|
||||
searchTermNamespace = queries >>= do1query
|
||||
where
|
||||
do1query :: HQ.HashQualified Name -> [(Maybe score, SearchResult)]
|
||||
do1query :: HQ.HashQualified Text -> [(Maybe score, SearchResult)]
|
||||
do1query q = mapMaybe (score1hq q) (R.toList . Names.terms $ names0)
|
||||
score1hq :: HQ.HashQualified Name -> (Name, Referent) -> Maybe (Maybe score, SearchResult)
|
||||
score1hq :: HQ.HashQualified Text -> (Name, Referent) -> Maybe (Maybe score, SearchResult)
|
||||
score1hq query (name, ref) = case query of
|
||||
HQ.NameOnly qn ->
|
||||
pair qn
|
||||
@ -1893,12 +1897,12 @@ searchBranchScored names0 score queries =
|
||||
where
|
||||
result = SR.termSearchResult names0 name ref
|
||||
pair qn =
|
||||
(\score -> (Just score, result)) <$> score qn name
|
||||
(\score -> (Just score, result)) <$> score qn (Name.toText name)
|
||||
searchTypeNamespace = queries >>= do1query
|
||||
where
|
||||
do1query :: HQ.HashQualified Name -> [(Maybe score, SearchResult)]
|
||||
do1query :: HQ.HashQualified Text -> [(Maybe score, SearchResult)]
|
||||
do1query q = mapMaybe (score1hq q) (R.toList . Names.types $ names0)
|
||||
score1hq :: HQ.HashQualified Name -> (Name, Reference) -> Maybe (Maybe score, SearchResult)
|
||||
score1hq :: HQ.HashQualified Text -> (Name, Reference) -> Maybe (Maybe score, SearchResult)
|
||||
score1hq query (name, ref) = case query of
|
||||
HQ.NameOnly qn ->
|
||||
pair qn
|
||||
@ -1912,12 +1916,12 @@ searchBranchScored names0 score queries =
|
||||
where
|
||||
result = SR.typeSearchResult names0 name ref
|
||||
pair qn =
|
||||
(\score -> (Just score, result)) <$> score qn name
|
||||
(\score -> (Just score, result)) <$> score qn (Name.toText name)
|
||||
|
||||
compilerPath :: Path.Path'
|
||||
compilerPath = Path.Path' {Path.unPath' = Left abs}
|
||||
where
|
||||
segs = NameSegment <$> ["unison", "internal"]
|
||||
segs = ["unison", "internal"]
|
||||
rootPath = Path.Path {Path.toSeq = Seq.fromList segs}
|
||||
abs = Path.Absolute {Path.unabsolute = rootPath}
|
||||
|
||||
@ -1980,20 +1984,17 @@ doGenerateSchemeBoot force mppe mdir = do
|
||||
gen ppe saveWrap cwrapf dirTm compoundWrapName
|
||||
where
|
||||
a = External
|
||||
hq nm
|
||||
| Just hqn <- HQ.fromString nm = hqn
|
||||
| otherwise = error $ "internal error: cannot hash qualify: " ++ nm
|
||||
|
||||
sbName = hq ".unison.internal.compiler.scheme.saveBaseFile"
|
||||
swName = hq ".unison.internal.compiler.scheme.saveWrapperFile"
|
||||
sdName = hq ".unison.internal.compiler.scheme.saveDataInfoFile"
|
||||
dinfoName = hq ".unison.internal.compiler.scheme.dataInfos"
|
||||
bootName = hq ".unison.internal.compiler.scheme.bootSpec"
|
||||
builtinName = hq ".unison.internal.compiler.scheme.builtinSpec"
|
||||
sbName = HQ.unsafeParseText ".unison.internal.compiler.scheme.saveBaseFile"
|
||||
swName = HQ.unsafeParseText ".unison.internal.compiler.scheme.saveWrapperFile"
|
||||
sdName = HQ.unsafeParseText ".unison.internal.compiler.scheme.saveDataInfoFile"
|
||||
dinfoName = HQ.unsafeParseText ".unison.internal.compiler.scheme.dataInfos"
|
||||
bootName = HQ.unsafeParseText ".unison.internal.compiler.scheme.bootSpec"
|
||||
builtinName = HQ.unsafeParseText ".unison.internal.compiler.scheme.builtinSpec"
|
||||
simpleWrapName =
|
||||
hq ".unison.internal.compiler.scheme.simpleWrapperSpec"
|
||||
HQ.unsafeParseText ".unison.internal.compiler.scheme.simpleWrapperSpec"
|
||||
compoundWrapName =
|
||||
hq ".unison.internal.compiler.scheme.compoundWrapperSpec"
|
||||
HQ.unsafeParseText ".unison.internal.compiler.scheme.compoundWrapperSpec"
|
||||
|
||||
gen ppe save file dir nm =
|
||||
liftIO (doesFileExist file) >>= \b -> when (not b || force) do
|
||||
@ -2015,10 +2016,10 @@ typecheckAndEval ppe tm = do
|
||||
Result.Result notes Nothing -> do
|
||||
currentPath <- Cli.getCurrentPath
|
||||
let tes = [err | Result.TypeError err <- toList notes]
|
||||
Cli.returnEarly (TypeErrors currentPath (Text.pack rendered) ppe tes)
|
||||
Cli.returnEarly (TypeErrors currentPath rendered ppe tes)
|
||||
where
|
||||
a = External
|
||||
rendered = P.toPlainUnbroken $ TP.pretty ppe tm
|
||||
rendered = Text.pack (P.toPlainUnbroken $ TP.pretty ppe tm)
|
||||
|
||||
ensureSchemeExists :: Cli ()
|
||||
ensureSchemeExists =
|
||||
@ -2062,16 +2063,16 @@ runScheme file args = do
|
||||
unless success $
|
||||
Cli.returnEarly (PrintMessage "Scheme evaluation failed.")
|
||||
|
||||
buildScheme :: String -> String -> Cli ()
|
||||
buildScheme :: Text -> String -> Cli ()
|
||||
buildScheme main file = do
|
||||
ensureSchemeExists
|
||||
statDir <- getSchemeStaticLibDir
|
||||
genDir <- getSchemeGenLibDir
|
||||
buildRacket genDir statDir main file
|
||||
|
||||
buildRacket :: String -> String -> String -> String -> Cli ()
|
||||
buildRacket :: String -> String -> Text -> String -> Cli ()
|
||||
buildRacket genDir statDir main file =
|
||||
let args = ["-l", "raco", "--", "exe", "-o", main, file]
|
||||
let args = ["-l", "raco", "--", "exe", "-o", Text.unpack main, file]
|
||||
opts = racketOpts genDir statDir args
|
||||
in void . liftIO $
|
||||
catch
|
||||
@ -2095,25 +2096,25 @@ doCompile native output main = do
|
||||
)
|
||||
(Cli.returnEarly . EvaluationFailure)
|
||||
|
||||
doRunAsScheme :: String -> [String] -> Cli ()
|
||||
doRunAsScheme main0 args = case HQ.fromString main0 of
|
||||
doRunAsScheme :: Text -> [String] -> Cli ()
|
||||
doRunAsScheme main0 args = case HQ.parseText main0 of
|
||||
Just main -> do
|
||||
fullpath <- generateSchemeFile True main0 main
|
||||
runScheme fullpath args
|
||||
Nothing -> Cli.respond $ BadName main0
|
||||
|
||||
doCompileScheme :: String -> HQ.HashQualified Name -> Cli ()
|
||||
doCompileScheme :: Text -> HQ.HashQualified Name -> Cli ()
|
||||
doCompileScheme out main =
|
||||
generateSchemeFile True out main >>= buildScheme out
|
||||
|
||||
generateSchemeFile :: Bool -> String -> HQ.HashQualified Name -> Cli String
|
||||
generateSchemeFile :: Bool -> Text -> HQ.HashQualified Name -> Cli String
|
||||
generateSchemeFile exec out main = do
|
||||
(comp, ppe) <- resolveMainRef main
|
||||
ensureCompilerExists
|
||||
doGenerateSchemeBoot False (Just ppe) Nothing
|
||||
cacheDir <- getCacheDir
|
||||
liftIO $ createDirectoryIfMissing True (cacheDir </> "scheme-tmp")
|
||||
let scratch = out ++ ".scm"
|
||||
let scratch = Text.unpack out ++ ".scm"
|
||||
fullpath = cacheDir </> "scheme-tmp" </> scratch
|
||||
output = Text.pack fullpath
|
||||
sscm <- Term.ref a <$> resolveTermRef saveNm
|
||||
@ -2128,12 +2129,9 @@ generateSchemeFile exec out main = do
|
||||
pure fullpath
|
||||
where
|
||||
a = External
|
||||
hq nm
|
||||
| Just hqn <- HQ.fromString nm = hqn
|
||||
| otherwise = error $ "internal error: cannot hash qualify: " ++ nm
|
||||
|
||||
saveNm = hq ".unison.internal.compiler.saveScheme"
|
||||
filePathNm = hq "FilePath.FilePath"
|
||||
saveNm = HQ.unsafeParseText ".unison.internal.compiler.saveScheme"
|
||||
filePathNm = HQ.unsafeParseText "FilePath.FilePath"
|
||||
|
||||
delete ::
|
||||
Input ->
|
||||
@ -2286,7 +2284,7 @@ displayI outputLoc hq = do
|
||||
let suffixifiedPPE = PPE.suffixifiedPPE pped
|
||||
let bias = maybeToList $ HQ.toName hq
|
||||
latestTypecheckedFile <- Cli.getLatestTypecheckedFile
|
||||
case addWatch (HQ.toString hq) latestTypecheckedFile of
|
||||
case addWatch (Text.unpack (HQ.toText hq)) latestTypecheckedFile of
|
||||
Nothing -> do
|
||||
let results = Names.lookupHQTerm Names.IncludeSuffixes hq names
|
||||
ref <-
|
||||
@ -2304,7 +2302,7 @@ displayI outputLoc hq = do
|
||||
let suffixifiedFilePPE = PPE.biasTo bias $ PPE.suffixifiedPPE filePPED
|
||||
(_, watches) <- evalUnisonFile Sandboxed suffixifiedFilePPE unisonFile []
|
||||
(_, _, _, _, tm, _) <-
|
||||
Map.lookup toDisplay watches & onNothing (error $ "Evaluation dropped a watch expression: " <> HQ.toString hq)
|
||||
Map.lookup toDisplay watches & onNothing (error $ "Evaluation dropped a watch expression: " <> Text.unpack (HQ.toText hq))
|
||||
let ns = UF.addNamesFromTypeCheckedUnisonFile unisonFile names
|
||||
doDisplay outputLoc ns tm
|
||||
|
||||
@ -2323,7 +2321,7 @@ docsI src = do
|
||||
in Name.convert hq'
|
||||
|
||||
dotDoc :: HQ.HashQualified Name
|
||||
dotDoc = hq <&> \n -> Name.joinDot n "doc"
|
||||
dotDoc = hq <&> \n -> Name.joinDot n (Name.fromSegment "doc")
|
||||
|
||||
findInScratchfileByName :: Cli ()
|
||||
findInScratchfileByName = do
|
||||
@ -2382,7 +2380,7 @@ parseType input src = do
|
||||
Parsers.parseType (Text.unpack (fst lexed)) parsingEnv & onLeftM \err ->
|
||||
Cli.returnEarly (TypeParseError src err)
|
||||
|
||||
Type.bindNames Name.unsafeFromVar mempty names (Type.generalizeLowercase mempty typ) & onLeft \errs ->
|
||||
Type.bindNames Name.unsafeParseVar mempty names (Type.generalizeLowercase mempty typ) & onLeft \errs ->
|
||||
Cli.returnEarly (ParseResolutionFailures src (toList errs))
|
||||
|
||||
-- Adds a watch expression of the given name to the file, if
|
||||
|
@ -22,6 +22,7 @@ import Unison.HashQualified qualified as HQ
|
||||
import Unison.HashQualified' qualified as HQ'
|
||||
import Unison.Name (Name)
|
||||
import Unison.Name qualified as Name
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Names (Names)
|
||||
import Unison.Names qualified as Names
|
||||
import Unison.NamesWithHistory qualified as Names
|
||||
@ -76,7 +77,7 @@ handleStructuredFindI rule = do
|
||||
r <- Set.toList (Relation.ran $ Names.terms names)
|
||||
Just hq <- [PPE.terms fqppe r]
|
||||
fullName <- [HQ'.toName hq]
|
||||
guard (not (Name.beginsWithSegment fullName Name.libSegment))
|
||||
guard (not (Name.beginsWithSegment fullName NameSegment.libSegment))
|
||||
Referent.Ref _ <- pure r
|
||||
Just shortName <- [PPE.terms (PPED.suffixifiedPPE ppe) r]
|
||||
pure (HQ'.toHQ shortName, r)
|
||||
|
@ -65,7 +65,7 @@ formatFile makePPEDForFile formattingWidth currentPath inputParsedFile inputType
|
||||
)
|
||||
& Map.filter (\(tldAnn, _, _) -> isInFormatRange tldAnn)
|
||||
& itraverse \sym (tldAnn, ref, decl) -> do
|
||||
symName <- hoistMaybe (Name.fromVar sym)
|
||||
symName <- hoistMaybe (Name.parseVar sym)
|
||||
let declNameSegments = NEL.appendr (Path.toList (Path.unabsolute currentPath)) (Name.segments symName)
|
||||
let declName = Name.fromSegments declNameSegments
|
||||
let hqName = HQ.fromName symName
|
||||
@ -84,7 +84,7 @@ formatFile makePPEDForFile formattingWidth currentPath inputParsedFile inputType
|
||||
(FileSummary.termsBySymbol fileSummary)
|
||||
& Map.filter (\(tldAnn, _, trm, _) -> shouldFormatTerm tldAnn trm)
|
||||
& itraverse \sym (tldAnn, mayRefId, trm, _typ) -> do
|
||||
symName <- hoistMaybe (Name.fromVar sym)
|
||||
symName <- hoistMaybe (Name.parseVar sym)
|
||||
let defNameSegments = NEL.appendr (Path.toList (Path.unabsolute currentPath)) (Name.segments symName)
|
||||
let defName = Name.fromSegments defNameSegments
|
||||
let hqName = HQ.NameOnly symName
|
||||
|
@ -22,7 +22,7 @@ import Unison.DataDeclaration qualified as DD
|
||||
import Unison.LabeledDependency (LabeledDependency)
|
||||
import Unison.LabeledDependency qualified as LD
|
||||
import Unison.Name (Name)
|
||||
import Unison.Name qualified as Name
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Names qualified as Names
|
||||
import Unison.Prelude
|
||||
import Unison.PrettyPrintEnvDecl qualified as PPED
|
||||
@ -97,4 +97,4 @@ namespaceDependencies codebase branch = do
|
||||
|
||||
pure onlyExternalDeps
|
||||
where
|
||||
branchWithoutLibdeps = branch & over Branch.children (Map.delete Name.libSegment)
|
||||
branchWithoutLibdeps = branch & over Branch.children (Map.delete NameSegment.libSegment)
|
||||
|
@ -23,8 +23,7 @@ import Unison.Codebase.Branch qualified as Branch
|
||||
import Unison.Codebase.Editor.HandleInput.Pull qualified as Pull
|
||||
import Unison.Codebase.Editor.Output qualified as Output
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Name qualified as Name
|
||||
import Unison.NameSegment (NameSegment (NameSegment))
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
|
||||
import Unison.Share.API.Hash qualified as Share.API
|
||||
@ -137,12 +136,12 @@ projectCreate tryDownloadingBase maybeProjectName = do
|
||||
projectBranchLibBaseObject =
|
||||
over
|
||||
Branch.children
|
||||
(Map.insert (NameSegment "base") baseLatestReleaseBranchObject)
|
||||
(Map.insert "base" baseLatestReleaseBranchObject)
|
||||
Branch.empty0
|
||||
projectBranchLibObject = Branch.cons projectBranchLibBaseObject Branch.empty
|
||||
in over
|
||||
Branch.children
|
||||
(Map.insert Name.libSegment projectBranchLibObject)
|
||||
(Map.insert NameSegment.libSegment projectBranchLibObject)
|
||||
Branch.empty0
|
||||
|
||||
Cli.stepAt reflogDescription (Path.unabsolute path, const projectBranchObject)
|
||||
|
@ -51,6 +51,7 @@ import Unison.CommandLine.InputPattern qualified as InputPattern
|
||||
import Unison.CommandLine.InputPatterns qualified as InputPatterns
|
||||
import Unison.Core.Project (ProjectBranchName (UnsafeProjectBranchName))
|
||||
import Unison.NameSegment (NameSegment (..))
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectAndBranch (..), ProjectBranchNameOrLatestRelease (..), ProjectName)
|
||||
import Unison.Share.API.Hash (HashJWT)
|
||||
@ -329,13 +330,13 @@ loadPropagateDiffDefaultPatch inputDescription maybeDest0 dest = do
|
||||
Cli.respond Output.AboutToPropagatePatch
|
||||
Cli.time "loadPropagateDiffDefaultPatch" do
|
||||
original <- Cli.getBranch0At dest
|
||||
patch <- liftIO $ Branch.getPatch Cli.defaultPatchNameSegment original
|
||||
patch <- liftIO $ Branch.getPatch NameSegment.defaultPatchSegment original
|
||||
patchDidChange <- propagatePatch inputDescription patch dest
|
||||
when patchDidChange do
|
||||
whenJust maybeDest0 \dest0 -> do
|
||||
Cli.respond Output.CalculatingDiff
|
||||
patched <- Cli.getBranchAt dest
|
||||
let patchPath = Path.Path' (Right (Path.Relative (Path.fromList [Cli.defaultPatchNameSegment])))
|
||||
let patchPath = Path.Path' (Right (Path.Relative (Path.fromList [NameSegment.defaultPatchSegment])))
|
||||
(ppe, diff) <- diffHelper original (Branch.head patched)
|
||||
Cli.respondNumbered (ShowDiffAfterMergePropagate dest0 dest patchPath ppe diff)
|
||||
|
||||
|
@ -40,7 +40,7 @@ import Unison.UnisonFile qualified as UF
|
||||
import Unison.UnisonFile.Names qualified as UF
|
||||
import Unison.Var qualified as Var
|
||||
|
||||
handleRun :: Bool -> String -> [String] -> Cli ()
|
||||
handleRun :: Bool -> Text -> [String] -> Cli ()
|
||||
handleRun native main args = do
|
||||
(unisonFile, mainResType) <- do
|
||||
(sym, term, typ, otyp) <- getTerm main
|
||||
@ -75,7 +75,7 @@ data GetTermResult
|
||||
-- | Look up runnable term with the given name in the codebase or
|
||||
-- latest typechecked unison file. Return its symbol, term, type, and
|
||||
-- the type of the evaluated term.
|
||||
getTerm :: String -> Cli (Symbol, Term Symbol Ann, Type Symbol Ann, Type Symbol Ann)
|
||||
getTerm :: Text -> Cli (Symbol, Term Symbol Ann, Type Symbol Ann, Type Symbol Ann)
|
||||
getTerm main =
|
||||
getTerm' main >>= \case
|
||||
NoTermWithThatName -> do
|
||||
@ -90,7 +90,7 @@ getTerm main =
|
||||
Cli.returnEarly $ Output.BadMainFunction "run" main ty suffixifiedPPE [mainType]
|
||||
GetTermSuccess x -> pure x
|
||||
|
||||
getTerm' :: String -> Cli GetTermResult
|
||||
getTerm' :: Text -> Cli GetTermResult
|
||||
getTerm' mainName =
|
||||
let getFromCodebase = do
|
||||
Cli.Env {codebase, runtime} <- ask
|
||||
@ -108,7 +108,7 @@ getTerm' mainName =
|
||||
pure (GetTermSuccess (v, tm, typ, otyp))
|
||||
getFromFile uf = do
|
||||
let components = join $ UF.topLevelComponents uf
|
||||
let mainComponent = filter ((\v -> Var.nameStr v == mainName) . view _1) components
|
||||
let mainComponent = filter ((\v -> Var.name v == mainName) . view _1) components
|
||||
case mainComponent of
|
||||
[(v, _, tm, ty)] ->
|
||||
checkType ty \otyp ->
|
||||
|
@ -31,7 +31,7 @@ import Unison.PrettyPrintEnvDecl qualified as PPED
|
||||
import Unison.Reference (Reference)
|
||||
import Unison.Referent (Referent, pattern Con, pattern Ref)
|
||||
import Unison.Symbol (Symbol)
|
||||
import Unison.Syntax.HashQualified qualified as HQ (toString)
|
||||
import Unison.Syntax.HashQualified qualified as HQ (toText)
|
||||
import Unison.Type (Type)
|
||||
import Unison.Typechecker qualified as Typechecker
|
||||
|
||||
@ -118,7 +118,7 @@ resolveMainRef main = do
|
||||
pped <- Cli.prettyPrintEnvDeclFromNames names
|
||||
let suffixifiedPPE = PPED.suffixifiedPPE pped
|
||||
let mainType = Runtime.mainType runtime
|
||||
smain = HQ.toString main
|
||||
smain = HQ.toText main
|
||||
lookupTermRefWithType codebase main >>= \case
|
||||
[(rf, ty)]
|
||||
| Typechecker.fitsScheme ty mainType -> pure (rf, suffixifiedPPE)
|
||||
|
@ -134,7 +134,7 @@ handleIOTest main = do
|
||||
(fails, oks) <-
|
||||
refs & foldMapM \(ref, typ) -> do
|
||||
when (not $ isIOTest typ) do
|
||||
Cli.returnEarly (BadMainFunction "io.test" (HQ.toString main) typ suffixifiedPPE (Foldable.toList $ Runtime.ioTestTypes runtime))
|
||||
Cli.returnEarly (BadMainFunction "io.test" (HQ.toText main) typ suffixifiedPPE (Foldable.toList $ Runtime.ioTestTypes runtime))
|
||||
runIOTest suffixifiedPPE ref
|
||||
Cli.respond $ TestResults Output.NewlyComputed suffixifiedPPE True True oks fails
|
||||
|
||||
@ -180,7 +180,7 @@ resolveHQNames parseNames hqNames =
|
||||
getNameFromScratchFile :: HQ.HashQualified Name -> MaybeT Cli (Reference.Id, Type.Type Symbol Ann)
|
||||
getNameFromScratchFile main = do
|
||||
typecheckedFile <- MaybeT Cli.getLatestTypecheckedFile
|
||||
mainName <- hoistMaybe $ Name.fromText (HQ.toText main)
|
||||
mainName <- hoistMaybe $ Name.parseText (HQ.toText main)
|
||||
(_, ref, _wk, _term, typ) <- hoistMaybe $ Map.lookup (Name.toVar mainName) (UF.hashTermsId typecheckedFile)
|
||||
pure (ref, typ)
|
||||
|
||||
|
@ -53,7 +53,7 @@ import Unison.Referent qualified as Referent
|
||||
import Unison.Result qualified as Result
|
||||
import Unison.Sqlite qualified as Sqlite
|
||||
import Unison.Symbol (Symbol)
|
||||
import Unison.Syntax.Name qualified as Name (toVar, unsafeFromVar)
|
||||
import Unison.Syntax.Name qualified as Name (toVar, unsafeParseVar)
|
||||
import Unison.Term (Term)
|
||||
import Unison.Term qualified as Term
|
||||
import Unison.Type (Type)
|
||||
@ -90,7 +90,7 @@ handleUpdate input optionalPatch requestedNames = do
|
||||
typeEdits :: [(Name, Reference, Reference)]
|
||||
typeEdits = do
|
||||
v <- Set.toList (SC.types (updates sr))
|
||||
let n = Name.unsafeFromVar v
|
||||
let n = Name.unsafeParseVar v
|
||||
let oldRefs0 = Names.typesNamed currentCodebaseNames n
|
||||
let newRefs = Names.typesNamed fileNames n
|
||||
case (,) <$> NESet.nonEmptySet oldRefs0 <*> Set.asSingleton newRefs of
|
||||
@ -105,7 +105,7 @@ handleUpdate input optionalPatch requestedNames = do
|
||||
termEdits :: [(Name, Reference, Reference)]
|
||||
termEdits = do
|
||||
v <- Set.toList (SC.terms (updates sr))
|
||||
let n = Name.unsafeFromVar v
|
||||
let n = Name.unsafeParseVar v
|
||||
let oldRefs0 = Names.refTermsNamed currentCodebaseNames n
|
||||
let newRefs = Names.refTermsNamed fileNames n
|
||||
case (,) <$> NESet.nonEmptySet oldRefs0 <*> Set.asSingleton newRefs of
|
||||
@ -215,7 +215,7 @@ getSlurpResultForUpdate requestedNames slurpCheckNames = do
|
||||
Set.map Name.toVar . Names.namesForReferent slurpCheckNames . Referent.fromTermReferenceId
|
||||
|
||||
let nameToTermRefs :: Symbol -> Set TermReference
|
||||
nameToTermRefs = Names.refTermsNamed slurpCheckNames . Name.unsafeFromVar
|
||||
nameToTermRefs = Names.refTermsNamed slurpCheckNames . Name.unsafeParseVar
|
||||
|
||||
slurp1 <- do
|
||||
Cli.Env {codebase} <- ask
|
||||
@ -593,10 +593,10 @@ doSlurpAdds slurp uf = Branch.batchUpdates (typeActions <> termActions)
|
||||
SC.terms slurp <> UF.constructorsForDecls (SC.types slurp) uf
|
||||
names = UF.typecheckedToNames uf
|
||||
doTerm :: Symbol -> (Path, Branch0 m -> Branch0 m)
|
||||
doTerm v = case toList (Names.termsNamed names (Name.unsafeFromVar v)) of
|
||||
doTerm v = case toList (Names.termsNamed names (Name.unsafeParseVar v)) of
|
||||
[] -> errorMissingVar v
|
||||
[r] ->
|
||||
let split = Path.splitFromName (Name.unsafeFromVar v)
|
||||
let split = Path.splitFromName (Name.unsafeParseVar v)
|
||||
in BranchUtil.makeAddTermName split r
|
||||
wha ->
|
||||
error $
|
||||
@ -605,10 +605,10 @@ doSlurpAdds slurp uf = Branch.batchUpdates (typeActions <> termActions)
|
||||
<> ": "
|
||||
<> show wha
|
||||
doType :: Symbol -> (Path, Branch0 m -> Branch0 m)
|
||||
doType v = case toList (Names.typesNamed names (Name.unsafeFromVar v)) of
|
||||
doType v = case toList (Names.typesNamed names (Name.unsafeParseVar v)) of
|
||||
[] -> errorMissingVar v
|
||||
[r] ->
|
||||
let split = Path.splitFromName (Name.unsafeFromVar v)
|
||||
let split = Path.splitFromName (Name.unsafeParseVar v)
|
||||
in BranchUtil.makeAddTypeName split r
|
||||
wha ->
|
||||
error $
|
||||
|
@ -59,7 +59,8 @@ import Unison.Name (Name)
|
||||
import Unison.Name qualified as Name
|
||||
import Unison.Name.Forward (ForwardName (..))
|
||||
import Unison.Name.Forward qualified as ForwardName
|
||||
import Unison.NameSegment (NameSegment (NameSegment))
|
||||
import Unison.NameSegment (NameSegment (..))
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Names (Names (Names))
|
||||
import Unison.Names qualified as Names
|
||||
import Unison.Parser.Ann (Ann)
|
||||
@ -102,7 +103,7 @@ handleUpdate2 = do
|
||||
currentPath <- Cli.getCurrentPath
|
||||
currentBranch0 <- Cli.getBranch0At currentPath
|
||||
let namesIncludingLibdeps = Branch.toNames currentBranch0
|
||||
let namesExcludingLibdeps = Branch.toNames (currentBranch0 & over Branch.children (Map.delete Name.libSegment))
|
||||
let namesExcludingLibdeps = Branch.toNames (currentBranch0 & over Branch.children (Map.delete NameSegment.libSegment))
|
||||
let ctorNames = forwardCtorNames namesExcludingLibdeps
|
||||
|
||||
Cli.respond Output.UpdateLookingForDependents
|
||||
@ -228,7 +229,7 @@ typecheckedUnisonFileToBranchUpdates abort getConstructors tuf = do
|
||||
makeDeclUpdates (symbol, (typeRefId, decl)) = do
|
||||
-- some decls will be deleted, we want to delete their
|
||||
-- constructors as well
|
||||
deleteConstructorActions <- case maybe [] (map (BranchUtil.makeAnnihilateTermName . Path.splitFromName)) <$> getConstructors (Name.unsafeFromVar symbol) of
|
||||
deleteConstructorActions <- case maybe [] (map (BranchUtil.makeAnnihilateTermName . Path.splitFromName)) <$> getConstructors (Name.unsafeParseVar symbol) of
|
||||
Left err -> abort err
|
||||
Right actions -> pure actions
|
||||
let deleteTypeAction = BranchUtil.makeAnnihilateTypeName split
|
||||
@ -261,7 +262,7 @@ typecheckedUnisonFileToBranchUpdates abort getConstructors tuf = do
|
||||
else []
|
||||
|
||||
splitVar :: Symbol -> Path.Split
|
||||
splitVar = Path.splitFromName . Name.unsafeFromVar
|
||||
splitVar = Path.splitFromName . Name.unsafeParseVar
|
||||
|
||||
-- | get references from `names` that have the same names as in `defns`
|
||||
-- For constructors, we get the type reference.
|
||||
@ -430,14 +431,14 @@ getTermAndDeclNames tuf =
|
||||
UF.hashTermsId tuf
|
||||
& Map.foldMapWithKey \var (_, _, wk, _, _) ->
|
||||
if WK.watchKindShouldBeStoredInDatabase wk
|
||||
then Set.singleton (Name.unsafeFromVar var)
|
||||
then Set.singleton (Name.unsafeParseVar var)
|
||||
else Set.empty
|
||||
effects = keysToNames $ UF.effectDeclarationsId' tuf
|
||||
datas = keysToNames $ UF.dataDeclarationsId' tuf
|
||||
effectCtors = foldMap ctorsToNames $ fmap (Decl.toDataDecl . snd) $ UF.effectDeclarationsId' tuf
|
||||
dataCtors = foldMap ctorsToNames $ fmap snd $ UF.dataDeclarationsId' tuf
|
||||
keysToNames = Set.map Name.unsafeFromVar . Map.keysSet
|
||||
ctorsToNames = Set.fromList . map Name.unsafeFromVar . Decl.constructorVars
|
||||
keysToNames = Set.map Name.unsafeParseVar . Map.keysSet
|
||||
ctorsToNames = Set.fromList . map Name.unsafeParseVar . Decl.constructorVars
|
||||
|
||||
-- | Given a namespace and a set of dependencies, return the subset of the namespace that consists of only the
|
||||
-- (transitive) dependents of the dependencies.
|
||||
|
@ -51,12 +51,14 @@ import Unison.Reference (TermReference, TypeReference)
|
||||
import Unison.Referent (Referent)
|
||||
import Unison.Referent qualified as Referent
|
||||
import Unison.Sqlite (Transaction)
|
||||
import Unison.Syntax.NameSegment qualified as NameSegment (toEscapedText)
|
||||
import Unison.UnisonFile qualified as UnisonFile
|
||||
import Unison.Util.Pretty qualified as Pretty
|
||||
import Unison.Util.Relation (Relation)
|
||||
import Unison.Util.Relation qualified as Relation
|
||||
import Unison.Util.Set qualified as Set
|
||||
import Witch (unsafeFrom)
|
||||
import qualified Data.Char as Char
|
||||
|
||||
handleUpgrade :: NameSegment -> NameSegment -> Cli ()
|
||||
handleUpgrade oldDepName newDepName = do
|
||||
@ -68,14 +70,14 @@ handleUpgrade oldDepName newDepName = do
|
||||
(projectAndBranch, _path) <- Cli.expectCurrentProjectBranch
|
||||
let projectId = projectAndBranch ^. #project . #projectId
|
||||
let projectPath = Cli.projectBranchPath (ProjectAndBranch projectId (projectAndBranch ^. #branch . #branchId))
|
||||
let oldDepPath = Path.resolve projectPath (Path.Relative (Path.fromList [Name.libSegment, oldDepName]))
|
||||
let newDepPath = Path.resolve projectPath (Path.Relative (Path.fromList [Name.libSegment, newDepName]))
|
||||
let oldDepPath = Path.resolve projectPath (Path.Relative (Path.fromList [NameSegment.libSegment, oldDepName]))
|
||||
let newDepPath = Path.resolve projectPath (Path.Relative (Path.fromList [NameSegment.libSegment, newDepName]))
|
||||
|
||||
currentV1Branch <- Cli.getBranch0At projectPath
|
||||
let currentV1BranchWithoutOldDep = deleteLibdep oldDepName currentV1Branch
|
||||
oldDep <- Cli.expectBranch0AtPath' oldDepPath
|
||||
let oldDepWithoutDeps = deleteLibdeps oldDep
|
||||
let oldTransitiveDeps = fromMaybe Branch.empty0 $ fmap Branch.head $ Map.lookup Name.libSegment (oldDep ^. Branch.children)
|
||||
let oldTransitiveDeps = fromMaybe Branch.empty0 $ fmap Branch.head $ Map.lookup NameSegment.libSegment (oldDep ^. Branch.children)
|
||||
|
||||
newDep <- Cli.expectBranch0AtPath' newDepPath
|
||||
let newDepWithoutDeps = deleteLibdeps newDep
|
||||
@ -212,7 +214,7 @@ handleUpgrade oldDepName newDepName = do
|
||||
where
|
||||
textualDescriptionOfUpgrade :: Text
|
||||
textualDescriptionOfUpgrade =
|
||||
Text.unwords ["upgrade", NameSegment.toText oldDepName, NameSegment.toText newDepName]
|
||||
Text.unwords ["upgrade", NameSegment.toEscapedText oldDepName, NameSegment.toEscapedText newDepName]
|
||||
|
||||
makeOldDepPPE ::
|
||||
NameSegment ->
|
||||
@ -257,8 +259,8 @@ makeOldDepPPE oldDepName newDepName namesExcludingOldDep oldDep oldDepWithoutDep
|
||||
}
|
||||
where
|
||||
oldNames = Branch.toNames oldDep
|
||||
prefixedOldNames = PPE.namer (Names.prefix0 (Name.fromReverseSegments (oldDepName :| [Name.libSegment])) oldNames)
|
||||
fakeNames = PPE.namer (Names.prefix0 (Name.fromReverseSegments (newDepName :| [Name.libSegment])) oldNames)
|
||||
prefixedOldNames = PPE.namer (Names.prefix0 (Name.fromReverseSegments (oldDepName :| [NameSegment.libSegment])) oldNames)
|
||||
fakeNames = PPE.namer (Names.prefix0 (Name.fromReverseSegments (newDepName :| [NameSegment.libSegment])) oldNames)
|
||||
|
||||
-- @findTemporaryBranchName projectId oldDepName newDepName@ finds some unused branch name in @projectId@ with a name
|
||||
-- like "upgrade-<oldDepName>-to-<newDepName>".
|
||||
@ -281,18 +283,19 @@ findTemporaryBranchName projectId oldDepName newDepName = do
|
||||
where
|
||||
preferred :: ProjectBranchName
|
||||
preferred =
|
||||
-- filter isAlpha just to make it more likely this is a valid project name :sweat-smile:
|
||||
unsafeFrom @Text $
|
||||
"upgrade-"
|
||||
<> NameSegment.toText oldDepName
|
||||
<> Text.filter Char.isAlpha (NameSegment.toEscapedText oldDepName)
|
||||
<> "-to-"
|
||||
<> NameSegment.toText newDepName
|
||||
<> Text.filter Char.isAlpha (NameSegment.toEscapedText newDepName)
|
||||
|
||||
pure (fromJust (List.find (\name -> not (Set.member name allBranchNames)) allCandidates))
|
||||
|
||||
deleteLibdep :: NameSegment -> Branch0 m -> Branch0 m
|
||||
deleteLibdep dep =
|
||||
over (Branch.children . ix Name.libSegment . Branch.head_ . Branch.children) (Map.delete dep)
|
||||
over (Branch.children . ix NameSegment.libSegment . Branch.head_ . Branch.children) (Map.delete dep)
|
||||
|
||||
deleteLibdeps :: Branch0 m -> Branch0 m
|
||||
deleteLibdeps =
|
||||
over Branch.children (Map.delete Name.libSegment)
|
||||
over Branch.children (Map.delete NameSegment.libSegment)
|
||||
|
@ -34,7 +34,7 @@ import Data.Text qualified as Text
|
||||
import Data.These (These)
|
||||
import U.Codebase.HashTags (CausalHash)
|
||||
import Unison.Codebase.Branch.Merge qualified as Branch
|
||||
import Unison.Codebase.Editor.RemoteRepo
|
||||
import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteGitRepo, WriteRemoteNamespace)
|
||||
import Unison.Codebase.Path (Path')
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.Path.Parse qualified as Path
|
||||
@ -42,8 +42,8 @@ import Unison.Codebase.PushBehavior (PushBehavior)
|
||||
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
|
||||
import Unison.Codebase.ShortCausalHash qualified as SCH
|
||||
import Unison.Codebase.SyncMode (SyncMode)
|
||||
import Unison.Codebase.Verbosity
|
||||
import Unison.CommandLine.BranchRelativePath
|
||||
import Unison.Codebase.Verbosity (Verbosity)
|
||||
import Unison.CommandLine.BranchRelativePath (BranchRelativePath, parseBranchRelativePath)
|
||||
import Unison.HashQualified qualified as HQ
|
||||
import Unison.Name (Name)
|
||||
import Unison.NameSegment (NameSegment)
|
||||
@ -82,7 +82,7 @@ type HashOrHQSplit' = Either ShortHash Path.HQSplit'
|
||||
data Insistence = Force | Try
|
||||
deriving (Show, Eq)
|
||||
|
||||
parseBranchId :: String -> Either String BranchId
|
||||
parseBranchId :: String -> Either Text BranchId
|
||||
parseBranchId ('#' : s) = case SCH.fromText (Text.pack s) of
|
||||
Nothing -> Left "Invalid hash, expected a base32hex string."
|
||||
Just h -> pure $ Left h
|
||||
@ -172,7 +172,7 @@ data Input
|
||||
-- Second `Maybe Int` is cap on diff elements shown, if any
|
||||
HistoryI (Maybe Int) (Maybe Int) BranchId
|
||||
| -- execute an IO thunk with args
|
||||
ExecuteI String [String]
|
||||
ExecuteI Text [String]
|
||||
| -- save the result of a previous Execute
|
||||
SaveExecuteResultI Name
|
||||
| -- execute an IO [Result]
|
||||
@ -182,9 +182,9 @@ data Input
|
||||
| -- make a standalone binary file
|
||||
MakeStandaloneI String (HQ.HashQualified Name)
|
||||
| -- execute an IO thunk using scheme
|
||||
ExecuteSchemeI String [String]
|
||||
ExecuteSchemeI Text [String]
|
||||
| -- compile to a scheme file
|
||||
CompileSchemeI String (HQ.HashQualified Name)
|
||||
CompileSchemeI Text (HQ.HashQualified Name)
|
||||
| -- generate scheme libraries, optional target directory
|
||||
GenSchemeLibsI (Maybe String)
|
||||
| -- fetch scheme compiler from a given username and branch
|
||||
|
@ -154,13 +154,13 @@ data Output
|
||||
| InvalidSourceName String
|
||||
| SourceLoadFailed String
|
||||
| -- No main function, the [Type v Ann] are the allowed types
|
||||
NoMainFunction String PPE.PrettyPrintEnv [Type Symbol Ann]
|
||||
NoMainFunction Text PPE.PrettyPrintEnv [Type Symbol Ann]
|
||||
| -- | Function found, but has improper type
|
||||
-- Note: the constructor name is misleading here; we weren't necessarily looking for a "main".
|
||||
BadMainFunction
|
||||
String
|
||||
Text
|
||||
-- ^ what we were trying to do (e.g. "run", "io.test")
|
||||
String
|
||||
Text
|
||||
-- ^ name of function
|
||||
(Type Symbol Ann)
|
||||
-- ^ bad type of function
|
||||
@ -306,7 +306,7 @@ data Output
|
||||
| DumpNumberedArgs NumberedArgs
|
||||
| DumpBitBooster CausalHash (Map CausalHash [CausalHash])
|
||||
| DumpUnisonFileHashes Int [(Name, Reference.Id)] [(Name, Reference.Id)] [(Name, Reference.Id)]
|
||||
| BadName String
|
||||
| BadName Text
|
||||
| CouldntLoadBranch CausalHash
|
||||
| HelpMessage Input.InputPattern
|
||||
| NamespaceEmpty (NonEmpty AbsBranchId)
|
||||
|
@ -39,6 +39,7 @@ import Unison.Hashing.V2.Convert qualified as Hashing
|
||||
import Unison.Name (Name)
|
||||
import Unison.Name qualified as Name
|
||||
import Unison.NameSegment (NameSegment)
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Names (Names)
|
||||
import Unison.Names qualified as Names
|
||||
import Unison.Parser.Ann (Ann (..))
|
||||
@ -60,7 +61,7 @@ import Unison.UnisonFile qualified as UF
|
||||
import Unison.Util.Monoid (foldMapM)
|
||||
import Unison.Util.Relation qualified as R
|
||||
import Unison.Util.Set qualified as Set
|
||||
import Unison.Util.Star3 qualified as Star3
|
||||
import Unison.Util.Star2 qualified as Star2
|
||||
import Unison.Util.TransitiveClosure (transitiveClosure)
|
||||
import Unison.Var (Var)
|
||||
import Unison.WatchKind (WatchKind)
|
||||
@ -596,64 +597,61 @@ applyDeprecations patch =
|
||||
deleteDeprecatedTypes ::
|
||||
Set Reference -> Branch0 m -> Branch0 m
|
||||
deleteDeprecatedTerms rs =
|
||||
over Branch.terms (Star3.deleteFact (Set.map Referent.Ref rs))
|
||||
deleteDeprecatedTypes rs = over Branch.types (Star3.deleteFact rs)
|
||||
over Branch.terms (Star2.deleteFact (Set.map Referent.Ref rs))
|
||||
deleteDeprecatedTypes rs = over Branch.types (Star2.deleteFact rs)
|
||||
|
||||
-- | Things in the patch are not marked as propagated changes, but every other
|
||||
-- definition that is created by the `Edits` which is passed in is marked as
|
||||
-- a propagated change.
|
||||
applyPropagate :: forall m. (Applicative m) => Patch -> Edits Symbol -> Branch0 m -> Branch0 m
|
||||
applyPropagate patch Edits {newTerms, termReplacements, typeReplacements, constructorReplacements} = do
|
||||
let termTypes = Map.map (Hashing.typeToReference . snd) newTerms
|
||||
applyPropagate patch Edits {termReplacements, typeReplacements, constructorReplacements} = do
|
||||
-- recursively update names and delete deprecated definitions
|
||||
stepEverywhereButLib (updateLevel termReplacements typeReplacements termTypes)
|
||||
stepEverywhereButLib (updateLevel termReplacements typeReplacements)
|
||||
where
|
||||
-- Like Branch.stepEverywhere, but don't step the child named "lib"
|
||||
stepEverywhereButLib :: (Branch0 m -> Branch0 m) -> (Branch0 m -> Branch0 m)
|
||||
stepEverywhereButLib f branch =
|
||||
let children =
|
||||
Map.mapWithKey
|
||||
(\name child -> if name == "lib" then child else Branch.step (Branch.stepEverywhere f) child)
|
||||
(\name child -> if name == NameSegment.libSegment then child else Branch.step (Branch.stepEverywhere f) child)
|
||||
(branch ^. Branch.children)
|
||||
in f (Branch.branch0 (branch ^. Branch.terms) (branch ^. Branch.types) children (branch ^. Branch.edits))
|
||||
isPropagated r = Set.notMember r allPatchTargets
|
||||
allPatchTargets = Patch.allReferenceTargets patch
|
||||
propagatedMd :: forall r. r -> (r, Metadata.Type, Metadata.Value)
|
||||
propagatedMd r = (r, IOSource.isPropagatedReference, IOSource.isPropagatedValue)
|
||||
propagatedMd :: forall r. r -> (r, Metadata.Value)
|
||||
propagatedMd r = (r, IOSource.isPropagatedValue)
|
||||
|
||||
updateLevel ::
|
||||
Map Referent Referent ->
|
||||
Map Reference Reference ->
|
||||
Map Reference Reference ->
|
||||
Branch0 m ->
|
||||
Branch0 m
|
||||
updateLevel termEdits typeEdits termTypes Branch0 {..} =
|
||||
updateLevel termEdits typeEdits Branch0 {..} =
|
||||
Branch.branch0 terms types _children _edits
|
||||
where
|
||||
isPropagatedReferent (Referent.Con _ _) = True
|
||||
isPropagatedReferent (Referent.Ref r) = isPropagated r
|
||||
|
||||
terms0 :: Metadata.Star Referent NameSegment
|
||||
terms0 = Star3.replaceFacts replaceConstructor constructorReplacements _terms
|
||||
terms0 = Star2.replaceFacts replaceConstructor constructorReplacements _terms
|
||||
terms :: Branch.Star Referent NameSegment
|
||||
terms =
|
||||
updateMetadatas $
|
||||
Star3.replaceFacts replaceTerm termEdits terms0
|
||||
Star2.replaceFacts replaceTerm termEdits terms0
|
||||
types :: Branch.Star Reference NameSegment
|
||||
types =
|
||||
updateMetadatas $
|
||||
Star3.replaceFacts replaceType typeEdits _types
|
||||
Star2.replaceFacts replaceType typeEdits _types
|
||||
|
||||
updateMetadatas ::
|
||||
(Ord r) =>
|
||||
Star3.Star3 r NameSegment Metadata.Type (Metadata.Type, Metadata.Value) ->
|
||||
Star3.Star3 r NameSegment Metadata.Type (Metadata.Type, Metadata.Value)
|
||||
updateMetadatas s = Star3.mapD3 go s
|
||||
Metadata.Star r NameSegment ->
|
||||
Metadata.Star r NameSegment
|
||||
updateMetadatas s = Star2.mapD2 go s
|
||||
where
|
||||
go (tp, v) = case Map.lookup (Referent.Ref v) termEdits of
|
||||
Just (Referent.Ref r) -> (typeOf r tp, r)
|
||||
_ -> (tp, v)
|
||||
typeOf r t = fromMaybe t $ Map.lookup r termTypes
|
||||
go v = case Map.lookup (Referent.Ref v) termEdits of
|
||||
Just (Referent.Ref r) -> r
|
||||
_ -> v
|
||||
|
||||
replaceTerm :: Referent -> Referent -> Metadata.Star Referent NameSegment -> Metadata.Star Referent NameSegment
|
||||
replaceTerm _r r' s =
|
||||
@ -710,4 +708,4 @@ computeDirty getDependents patch shouldUpdate =
|
||||
|
||||
nameNotInLibNamespace :: Name -> Bool
|
||||
nameNotInLibNamespace name =
|
||||
not (Name.beginsWithSegment name "lib")
|
||||
not (Name.beginsWithSegment name NameSegment.libSegment)
|
||||
|
@ -23,7 +23,7 @@ import Unison.Referent (Referent)
|
||||
import Unison.Referent qualified as Referent
|
||||
import Unison.Referent' qualified as Referent
|
||||
import Unison.Symbol (Symbol)
|
||||
import Unison.Syntax.Name qualified as Name (toText, unsafeFromVar)
|
||||
import Unison.Syntax.Name qualified as Name (toText, unsafeParseVar)
|
||||
import Unison.UnisonFile qualified as UF
|
||||
import Unison.UnisonFile.Names qualified as UF
|
||||
import Unison.Util.Map qualified as Map
|
||||
@ -159,7 +159,7 @@ computeNamesWithDeprecations uf unalteredCodebaseNames involvedVars = \case
|
||||
& filter (\(typeV, _) -> Set.member (TypeVar typeV) involvedVars)
|
||||
& concatMap (\(_typeV, (_refId, decl)) -> DD.constructors' decl)
|
||||
& fmap
|
||||
( \(_ann, v, _typ) -> Name.unsafeFromVar v
|
||||
( \(_ann, v, _typ) -> Name.unsafeParseVar v
|
||||
)
|
||||
& Set.fromList
|
||||
|
||||
@ -170,7 +170,7 @@ computeNamesWithDeprecations uf unalteredCodebaseNames involvedVars = \case
|
||||
let effectNames = Map.keys (UF.effectDeclarationsId' uf)
|
||||
typeName <- declNames <> effectNames
|
||||
when (not . null $ involvedVars) (guard (TypeVar typeName `Set.member` involvedVars))
|
||||
pure $ Names.typesNamed unalteredCodebaseNames (Name.unsafeFromVar typeName)
|
||||
pure $ Names.typesNamed unalteredCodebaseNames (Name.unsafeParseVar typeName)
|
||||
existingConstructorsFromEditedTypes = Set.fromList $ do
|
||||
-- List Monad
|
||||
ref <- Set.toList oldRefsForEditedTypes
|
||||
@ -194,8 +194,8 @@ computeSelfStatuses vars varReferences codebaseNames =
|
||||
Just r -> r
|
||||
Nothing -> error $ "Expected LabeledDependency in map for var: " <> show tv
|
||||
v = untagged tv
|
||||
existingTypesAtName = Names.typesNamed codebaseNames (Name.unsafeFromVar v)
|
||||
existingTermsOrCtorsAtName = Names.termsNamed codebaseNames (Name.unsafeFromVar v)
|
||||
existingTypesAtName = Names.typesNamed codebaseNames (Name.unsafeParseVar v)
|
||||
existingTermsOrCtorsAtName = Names.termsNamed codebaseNames (Name.unsafeParseVar v)
|
||||
in case ld of
|
||||
LD.TypeReference _typeRef ->
|
||||
case Set.toList existingTypesAtName of
|
||||
|
@ -35,6 +35,7 @@ import Unison.NameSegment (NameSegment (..))
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectBranchName, ProjectBranchSpecifier (..), ProjectName, projectAndBranchNamesParser)
|
||||
import Unison.Syntax.Lexer qualified
|
||||
import Unison.Syntax.NameSegment qualified as NameSegment
|
||||
import Unison.Util.Pretty qualified as P
|
||||
import Unison.Util.Pretty.MegaParsec qualified as P
|
||||
|
||||
@ -378,7 +379,7 @@ absolutePath = do
|
||||
|
||||
nameSegment :: P NameSegment
|
||||
nameSegment =
|
||||
NameSegment . Text.pack
|
||||
NameSegment.unsafeParseText . Text.pack
|
||||
<$> ( (:)
|
||||
<$> P.satisfy Unison.Syntax.Lexer.wordyIdStartChar
|
||||
<*> P.many (P.satisfy Unison.Syntax.Lexer.wordyIdChar)
|
||||
|
@ -210,8 +210,8 @@ incrementalBranchRelativePathParser =
|
||||
Left err -> failureAt offset err
|
||||
Right x -> pure x
|
||||
|
||||
failureAt :: forall a. Int -> String -> Megaparsec.Parsec Void Text a
|
||||
failureAt offset str = Megaparsec.parseError (Megaparsec.FancyError offset (Set.singleton (Megaparsec.ErrorFail str)))
|
||||
failureAt :: forall a. Int -> Text -> Megaparsec.Parsec Void Text a
|
||||
failureAt offset str = Megaparsec.parseError (Megaparsec.FancyError offset (Set.singleton (Megaparsec.ErrorFail (Text.unpack str))))
|
||||
|
||||
parseThese ::
|
||||
forall a b.
|
||||
|
@ -27,6 +27,7 @@ import Data.Aeson qualified as Aeson
|
||||
import Data.List (isPrefixOf)
|
||||
import Data.List qualified as List
|
||||
import Data.List.Extra (nubOrdOn)
|
||||
import Data.List.NonEmpty qualified as List.NonEmpty
|
||||
import Data.List.NonEmpty qualified as NE
|
||||
import Data.Map qualified as Map
|
||||
import Data.Set.NonEmpty (NESet)
|
||||
@ -37,6 +38,7 @@ import Network.URI qualified as URI
|
||||
import System.Console.Haskeline qualified as Line
|
||||
import System.Console.Haskeline.Completion (Completion)
|
||||
import System.Console.Haskeline.Completion qualified as Haskeline
|
||||
import Text.Megaparsec qualified as P
|
||||
import U.Codebase.Branch qualified as V2Branch
|
||||
import U.Codebase.Causal qualified as V2Causal
|
||||
import U.Codebase.Reference qualified as Reference
|
||||
@ -45,11 +47,12 @@ import Unison.Auth.HTTPClient (AuthenticatedHttpClient (..))
|
||||
import Unison.Codebase (Codebase)
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.Path.Parse qualified as Path
|
||||
import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv
|
||||
import Unison.CommandLine.InputPattern qualified as IP
|
||||
import Unison.HashQualified' qualified as HQ'
|
||||
import Unison.NameSegment (NameSegment (NameSegment))
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Name qualified as Name
|
||||
import Unison.NameSegment (NameSegment (..))
|
||||
import Unison.Prelude
|
||||
import Unison.Server.Local.Endpoints.NamespaceListing (NamespaceListing (NamespaceListing))
|
||||
import Unison.Server.Local.Endpoints.NamespaceListing qualified as Server
|
||||
@ -57,6 +60,8 @@ import Unison.Server.Types qualified as Server
|
||||
import Unison.Share.Codeserver qualified as Codeserver
|
||||
import Unison.Share.Types qualified as Share
|
||||
import Unison.Sqlite qualified as Sqlite
|
||||
import Unison.Syntax.Name qualified as Name
|
||||
import Unison.Syntax.NameSegment qualified as NameSegment
|
||||
import Unison.Util.Monoid qualified as Monoid
|
||||
import Unison.Util.Pretty qualified as P
|
||||
import UnliftIO qualified
|
||||
@ -144,7 +149,12 @@ completeWithinNamespace compTypes query currentPath = do
|
||||
currentBranchSuggestions <- do
|
||||
nib <- namesInBranch shortHashLen b
|
||||
nib
|
||||
& fmap (\(isFinished, match) -> (isFinished, Text.unpack . Path.toText' $ queryPathPrefix Lens.:> NameSegment.NameSegment match))
|
||||
& fmap
|
||||
( \(ty, isFinished, match) ->
|
||||
( isFinished,
|
||||
Text.unpack (dotifyNamespace ty (Path.toText' (queryPathPrefix Lens.:> NameSegment match)))
|
||||
)
|
||||
)
|
||||
& filter (\(_isFinished, match) -> List.isPrefixOf query match)
|
||||
& fmap (\(isFinished, match) -> prettyCompletionWithQueryPrefix isFinished query match)
|
||||
& pure
|
||||
@ -156,42 +166,55 @@ completeWithinNamespace compTypes query currentPath = do
|
||||
pure . nubOrdOn Haskeline.replacement . List.sortOn Haskeline.replacement $ allSuggestions
|
||||
where
|
||||
queryPathPrefix :: Path.Path'
|
||||
querySuffix :: NameSegment.NameSegment
|
||||
querySuffix :: Text
|
||||
(queryPathPrefix, querySuffix) = parseLaxPath'Query (Text.pack query)
|
||||
absQueryPath :: Path.Absolute
|
||||
absQueryPath = Path.resolve currentPath queryPathPrefix
|
||||
getChildSuggestions :: Int -> V2Branch.Branch Sqlite.Transaction -> Sqlite.Transaction [Completion]
|
||||
getChildSuggestions shortHashLen b = do
|
||||
nonEmptyChildren <- V2Branch.nonEmptyChildren b
|
||||
case querySuffix of
|
||||
"" -> pure []
|
||||
suffix -> do
|
||||
case Map.lookup suffix nonEmptyChildren of
|
||||
Nothing -> pure []
|
||||
Just childCausal -> do
|
||||
childBranch <- V2Causal.value childCausal
|
||||
nib <- namesInBranch shortHashLen childBranch
|
||||
nib
|
||||
& fmap
|
||||
( \(isFinished, match) -> (isFinished, Text.unpack . Path.toText' $ queryPathPrefix Lens.:> suffix Lens.:> NameSegment.NameSegment match)
|
||||
)
|
||||
& filter (\(_isFinished, match) -> List.isPrefixOf query match)
|
||||
& fmap (\(isFinished, match) -> prettyCompletionWithQueryPrefix isFinished query match)
|
||||
& pure
|
||||
namesInBranch :: Int -> V2Branch.Branch Sqlite.Transaction -> Sqlite.Transaction [(Bool, Text)]
|
||||
getChildSuggestions shortHashLen b
|
||||
| Text.null querySuffix = pure []
|
||||
| otherwise =
|
||||
case NameSegment.parseText querySuffix of
|
||||
Left _ -> pure []
|
||||
Right suffix -> do
|
||||
nonEmptyChildren <- V2Branch.nonEmptyChildren b
|
||||
case Map.lookup suffix nonEmptyChildren of
|
||||
Nothing -> pure []
|
||||
Just childCausal -> do
|
||||
childBranch <- V2Causal.value childCausal
|
||||
nib <- namesInBranch shortHashLen childBranch
|
||||
nib
|
||||
& fmap
|
||||
( \(ty, isFinished, match) ->
|
||||
( isFinished,
|
||||
Text.unpack (dotifyNamespace ty (Path.toText' (queryPathPrefix Lens.:> suffix Lens.:> NameSegment match)))
|
||||
)
|
||||
)
|
||||
& filter (\(_isFinished, match) -> List.isPrefixOf query match)
|
||||
& fmap (\(isFinished, match) -> prettyCompletionWithQueryPrefix isFinished query match)
|
||||
& pure
|
||||
namesInBranch :: Int -> V2Branch.Branch Sqlite.Transaction -> Sqlite.Transaction [(CompletionType, Bool, Text)]
|
||||
namesInBranch hashLen b = do
|
||||
nonEmptyChildren <- V2Branch.nonEmptyChildren b
|
||||
let textifyHQ :: (NameSegment -> r -> HQ'.HashQualified NameSegment) -> Map NameSegment (Map r metadata) -> [(Bool, Text)]
|
||||
textifyHQ f xs =
|
||||
xs
|
||||
& hashQualifyCompletions f
|
||||
& fmap (HQ'.toTextWith NameSegment.toText)
|
||||
& fmap (HQ'.toTextWith NameSegment.toEscapedText)
|
||||
& fmap (True,)
|
||||
pure $
|
||||
((False,) <$> dotifyNamespaces (fmap NameSegment.toText . Map.keys $ nonEmptyChildren))
|
||||
<> Monoid.whenM (NESet.member TermCompletion compTypes) (textifyHQ (hqFromNamedV2Referent hashLen) $ V2Branch.terms b)
|
||||
<> Monoid.whenM (NESet.member TypeCompletion compTypes) (textifyHQ (hqFromNamedV2Reference hashLen) $ V2Branch.types b)
|
||||
<> Monoid.whenM (NESet.member PatchCompletion compTypes) (fmap ((True,) . NameSegment.toText) . Map.keys $ V2Branch.patches b)
|
||||
concat
|
||||
[ (NamespaceCompletion,False,) <$> (fmap NameSegment.toEscapedText . Map.keys $ nonEmptyChildren),
|
||||
Monoid.whenM
|
||||
(NESet.member TermCompletion compTypes)
|
||||
(map (\(x, y) -> (TermCompletion, x, y)) (textifyHQ (hqFromNamedV2Referent hashLen) $ V2Branch.terms b)),
|
||||
Monoid.whenM
|
||||
(NESet.member TypeCompletion compTypes)
|
||||
(map (\(x, y) -> (TypeCompletion, x, y)) (textifyHQ (hqFromNamedV2Reference hashLen) $ V2Branch.types b)),
|
||||
Monoid.whenM
|
||||
(NESet.member PatchCompletion compTypes)
|
||||
(fmap ((PatchCompletion,True,) . NameSegment.toEscapedText) . Map.keys $ V2Branch.patches b)
|
||||
]
|
||||
|
||||
-- Regrettably there'shqFromNamedV2Referencenot a great spot to combinators for V2 references and shorthashes right now.
|
||||
hqFromNamedV2Referent :: Int -> NameSegment -> Referent.Referent -> HQ'.HashQualified NameSegment
|
||||
@ -205,16 +228,14 @@ completeWithinNamespace compTypes query currentPath = do
|
||||
-- completions.
|
||||
qualifyRefs :: NameSegment -> Map r metadata -> [HQ'.HashQualified NameSegment]
|
||||
qualifyRefs n refs
|
||||
| ((Text.isInfixOf "#" . NameSegment.toText) querySuffix) || length refs > 1 = refs & Map.keys <&> qualify n
|
||||
| Text.isInfixOf "#" querySuffix || length refs > 1 = refs & Map.keys <&> qualify n
|
||||
| otherwise = [HQ'.NameOnly n]
|
||||
|
||||
-- If we're not completing namespaces, then all namespace completions should automatically
|
||||
-- drill-down by adding a trailing '.'
|
||||
dotifyNamespaces :: [Text] -> [Text]
|
||||
dotifyNamespaces namespaces =
|
||||
if not (NESet.member NamespaceCompletion compTypes)
|
||||
then fmap (<> ".") namespaces
|
||||
else namespaces
|
||||
dotifyNamespace :: CompletionType -> Text -> Text
|
||||
dotifyNamespace NamespaceCompletion | not (NESet.member NamespaceCompletion compTypes) = (<> ".")
|
||||
dotifyNamespace _ = id
|
||||
|
||||
-- | A path parser which which is more lax with respect to well formed paths,
|
||||
-- specifically we can determine a valid path prefix with a (possibly empty) suffix query.
|
||||
@ -241,22 +262,14 @@ completeWithinNamespace compTypes query currentPath = do
|
||||
--
|
||||
-- >>> parseLaxPath'Query "base.List"
|
||||
-- (base,"List")
|
||||
parseLaxPath'Query :: Text -> (Path.Path', NameSegment)
|
||||
parseLaxPath'Query :: Text -> (Path.Path', Text)
|
||||
parseLaxPath'Query txt =
|
||||
case unsnoc (Text.splitOn "." txt) of
|
||||
-- This case is impossible due to the behaviour of 'splitOn'
|
||||
Nothing ->
|
||||
(Path.relativeEmpty', NameSegment "")
|
||||
-- ".base."
|
||||
-- ".base.List"
|
||||
Just ("" : pathPrefix, querySegment) -> (Path.AbsolutePath' . Path.Absolute . Path.fromList . fmap NameSegment $ pathPrefix, NameSegment querySegment)
|
||||
-- ""
|
||||
-- "base"
|
||||
-- "base.List"
|
||||
Just (pathPrefix, querySegment) ->
|
||||
( Path.RelativePath' . Path.Relative . Path.fromList . fmap NameSegment $ pathPrefix,
|
||||
NameSegment querySegment
|
||||
)
|
||||
case P.runParser ((,) <$> Path.splitP' <*> P.takeRest) "" (Text.unpack txt) of
|
||||
Left _err -> (Path.relativeEmpty', txt)
|
||||
Right ((path, segment), rest) ->
|
||||
if take 1 rest == "."
|
||||
then (Path.unsplit' (path, segment), Text.empty)
|
||||
else (path, NameSegment.toEscapedText segment)
|
||||
|
||||
-- | Completes a namespace argument by prefix-matching against the query.
|
||||
prefixCompleteNamespace ::
|
||||
@ -350,19 +363,21 @@ shareCompletion ::
|
||||
m [Completion]
|
||||
shareCompletion completionTypes authHTTPClient str =
|
||||
fromMaybe [] <$> runMaybeT do
|
||||
case Text.splitOn "." (Text.pack str) of
|
||||
[] -> empty
|
||||
[userPrefix] -> do
|
||||
userHandles <- searchUsers authHTTPClient userPrefix
|
||||
case Path.toList <$> Path.parsePath str of
|
||||
Left _err -> empty
|
||||
Right [] -> empty
|
||||
Right [userPrefix] -> do
|
||||
userHandles <- searchUsers authHTTPClient (NameSegment.toEscapedText userPrefix)
|
||||
pure $
|
||||
userHandles
|
||||
& filter (userPrefix `Text.isPrefixOf`)
|
||||
<&> \handle -> prettyCompletionWithQueryPrefix False (Text.unpack userPrefix) (Text.unpack handle)
|
||||
userHandle : path -> do
|
||||
(userHandle, path, pathSuffix) <- case unsnoc path of
|
||||
Just (path, pathSuffix) -> pure (userHandle, Path.fromList (NameSegment <$> path), pathSuffix)
|
||||
Nothing -> pure (userHandle, Path.empty, "")
|
||||
NamespaceListing {namespaceListingChildren} <- MaybeT $ fetchShareNamespaceInfo authHTTPClient userHandle path
|
||||
& filter (\userHandle -> NameSegment.toEscapedText userPrefix `Text.isPrefixOf` userHandle)
|
||||
<&> \handle -> prettyCompletionWithQueryPrefix False (Text.unpack (NameSegment.toEscapedText userPrefix)) (Text.unpack handle)
|
||||
Right (userHandle : path0) -> do
|
||||
let (path, pathSuffix) =
|
||||
case unsnoc path0 of
|
||||
Just (path, pathSuffix) -> (Path.fromList path, NameSegment.toEscapedText pathSuffix)
|
||||
Nothing -> (Path.empty, "")
|
||||
NamespaceListing {namespaceListingChildren} <- MaybeT $ fetchShareNamespaceInfo authHTTPClient (NameSegment.toEscapedText userHandle) path
|
||||
namespaceListingChildren
|
||||
& fmap
|
||||
( \case
|
||||
@ -370,10 +385,10 @@ shareCompletion completionTypes authHTTPClient str =
|
||||
let name = Server.namespaceName nn
|
||||
in (NamespaceCompletion, name)
|
||||
Server.TermObject nt ->
|
||||
let name = HQ'.toTextWith NameSegment.toText $ Server.termName nt
|
||||
let name = HQ'.toTextWith Name.toText $ Server.termName nt
|
||||
in (NamespaceCompletion, name)
|
||||
Server.TypeObject nt ->
|
||||
let name = HQ'.toTextWith NameSegment.toText $ Server.typeName nt
|
||||
let name = HQ'.toTextWith Name.toText $ Server.typeName nt
|
||||
in (TermCompletion, name)
|
||||
Server.PatchObject np ->
|
||||
let name = Server.patchName np
|
||||
@ -382,8 +397,13 @@ shareCompletion completionTypes authHTTPClient str =
|
||||
& filter (\(typ, name) -> typ `NESet.member` completionTypes && pathSuffix `Text.isPrefixOf` name)
|
||||
& fmap
|
||||
( \(_, name) ->
|
||||
let queryPath = userHandle : coerce (Path.toList path)
|
||||
result = Text.unpack $ Text.intercalate "." (queryPath <> [name])
|
||||
let queryPath = userHandle : Path.toList path
|
||||
result =
|
||||
(queryPath ++ [NameSegment.unsafeParseText name])
|
||||
& List.NonEmpty.fromList
|
||||
& Name.fromSegments
|
||||
& Name.toText
|
||||
& Text.unpack
|
||||
in prettyCompletionWithQueryPrefix False str result
|
||||
)
|
||||
& pure
|
||||
|
@ -45,6 +45,7 @@ import Unison.Prelude
|
||||
import Unison.Project.Util (ProjectContext (..))
|
||||
import Unison.Symbol (Symbol)
|
||||
import Unison.Syntax.HashQualified qualified as HQ (toText)
|
||||
import Unison.Syntax.NameSegment qualified as NameSegment
|
||||
import Unison.Util.Monoid (foldMapM)
|
||||
import Unison.Util.Monoid qualified as Monoid
|
||||
import Unison.Util.Relation qualified as Relation
|
||||
@ -104,10 +105,10 @@ namespaceOptions _codebase _projCtx searchBranch0 = do
|
||||
projectDependencyOptions :: OptionFetcher
|
||||
projectDependencyOptions _codebase _projCtx searchBranch0 = do
|
||||
searchBranch0
|
||||
& Branch.getAt0 (Path.singleton Name.libSegment)
|
||||
& Branch.getAt0 (Path.singleton NameSegment.libSegment)
|
||||
& Branch.nonEmptyChildren
|
||||
& Map.keys
|
||||
& fmap NameSegment.toText
|
||||
& fmap NameSegment.toEscapedText
|
||||
& pure
|
||||
|
||||
-- | Select a namespace from the given branch.
|
||||
|
@ -20,6 +20,7 @@ import System.Console.Haskeline.Completion (Completion (Completion))
|
||||
import System.Console.Haskeline.Completion qualified as Haskeline
|
||||
import System.Console.Haskeline.Completion qualified as Line
|
||||
import Text.Megaparsec qualified as Megaparsec
|
||||
import Text.Megaparsec.Internal qualified as Megaparsec (withParsecT)
|
||||
import U.Codebase.Sqlite.DbId (ProjectBranchId, ProjectId)
|
||||
import U.Codebase.Sqlite.Project qualified as Sqlite
|
||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||
@ -28,7 +29,6 @@ import Unison.Cli.Pretty (prettyProjectAndBranchName, prettyProjectName, prettyP
|
||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
||||
import Unison.Codebase (Codebase)
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Branch qualified as Branch
|
||||
import Unison.Codebase.Branch.Merge qualified as Branch
|
||||
import Unison.Codebase.Editor.Input (DeleteOutput (..), DeleteTarget (..), Input)
|
||||
import Unison.Codebase.Editor.Input qualified as Input
|
||||
@ -60,8 +60,9 @@ import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectAndBranch (..), ProjectAndBranchNames (..), ProjectBranchName, ProjectBranchNameOrLatestRelease (..), ProjectBranchSpecifier (..), ProjectName, Semver)
|
||||
import Unison.Project.Util (ProjectContext (..), projectContextFromPath)
|
||||
import Unison.Syntax.HashQualified qualified as HQ (fromString)
|
||||
import Unison.Syntax.Name qualified as Name (fromText, unsafeFromString)
|
||||
import Unison.Syntax.HashQualified qualified as HQ (parseText)
|
||||
import Unison.Syntax.Name qualified as Name (parseText, unsafeParseText)
|
||||
import Unison.Syntax.NameSegment qualified as NameSegment (renderParseErr, segmentP)
|
||||
import Unison.Util.ColorText qualified as CT
|
||||
import Unison.Util.Monoid (intercalateMap)
|
||||
import Unison.Util.Pretty qualified as P
|
||||
@ -153,8 +154,8 @@ todo =
|
||||
]
|
||||
)
|
||||
( \case
|
||||
patchStr : ws -> mapLeft (warn . fromString) $ do
|
||||
patch <- Path.parseSplit' Path.definitionNameSegment patchStr
|
||||
patchStr : ws -> mapLeft (warn . P.text) $ do
|
||||
patch <- Path.parseSplit' patchStr
|
||||
branch <- case ws of
|
||||
[] -> pure Path.relativeEmpty'
|
||||
[pathStr] -> Path.parsePath' pathStr
|
||||
@ -213,7 +214,7 @@ add =
|
||||
( "`add` adds to the codebase all the definitions from the most recently "
|
||||
<> "typechecked file."
|
||||
)
|
||||
$ \ws -> pure $ Input.AddI (Set.fromList $ map Name.unsafeFromString ws)
|
||||
\ws -> pure $ Input.AddI (Set.fromList $ map (Name.unsafeParseText . Text.pack) ws)
|
||||
|
||||
previewAdd :: InputPattern
|
||||
previewAdd =
|
||||
@ -227,7 +228,7 @@ previewAdd =
|
||||
<> "results. Use `load` to reparse & typecheck the file if the context "
|
||||
<> "has changed."
|
||||
)
|
||||
$ \ws -> pure $ Input.PreviewAddI (Set.fromList $ map Name.unsafeFromString ws)
|
||||
\ws -> pure $ Input.PreviewAddI (Set.fromList $ map (Name.unsafeParseText . Text.pack) ws)
|
||||
|
||||
update :: InputPattern
|
||||
update =
|
||||
@ -279,7 +280,7 @@ updateOldNoPatch =
|
||||
pure $
|
||||
Input.UpdateI
|
||||
Input.NoPatch
|
||||
(Set.fromList $ map Name.unsafeFromString ws)
|
||||
(Set.fromList $ map (Name.unsafeParseText . Text.pack) ws)
|
||||
)
|
||||
|
||||
updateOld :: InputPattern
|
||||
@ -316,13 +317,11 @@ updateOld =
|
||||
)
|
||||
\case
|
||||
patchStr : ws -> do
|
||||
patch <-
|
||||
first fromString $
|
||||
Path.parseSplit' Path.definitionNameSegment patchStr
|
||||
patch <- first P.text $ Path.parseSplit' patchStr
|
||||
pure $
|
||||
Input.UpdateI
|
||||
(Input.UsePatch patch)
|
||||
(Set.fromList $ map Name.unsafeFromString ws)
|
||||
(Set.fromList $ map (Name.unsafeParseText . Text.pack) ws)
|
||||
[] -> Right $ Input.UpdateI Input.DefaultPatch mempty
|
||||
|
||||
previewUpdate :: InputPattern
|
||||
@ -337,7 +336,7 @@ previewUpdate =
|
||||
<> "typechecking results. Use `load` to reparse & typecheck the file if "
|
||||
<> "the context has changed."
|
||||
)
|
||||
\ws -> pure $ Input.PreviewUpdateI (Set.fromList $ map Name.unsafeFromString ws)
|
||||
\ws -> pure $ Input.PreviewUpdateI (Set.fromList $ map (Name.unsafeParseText . Text.pack) ws)
|
||||
|
||||
patch :: InputPattern
|
||||
patch =
|
||||
@ -366,8 +365,8 @@ patch =
|
||||
]
|
||||
)
|
||||
\case
|
||||
patchStr : ws -> first fromString $ do
|
||||
patch <- Path.parseSplit' Path.definitionNameSegment patchStr
|
||||
patchStr : ws -> first P.text do
|
||||
patch <- Path.parseSplit' patchStr
|
||||
branch <- case ws of
|
||||
[pathStr] -> Path.parsePath' pathStr
|
||||
_ -> pure Path.relativeEmpty'
|
||||
@ -474,10 +473,10 @@ docs =
|
||||
]
|
||||
)
|
||||
( \case
|
||||
(x : xs) ->
|
||||
x : xs ->
|
||||
(x NE.:| xs)
|
||||
& traverse Path.parseHQSplit'
|
||||
& bimap fromString Input.DocsI
|
||||
& bimap P.text Input.DocsI
|
||||
_ -> Left (I.help docs)
|
||||
)
|
||||
|
||||
@ -501,7 +500,7 @@ ui =
|
||||
help = P.wrap "`ui` opens the Local UI in the default browser.",
|
||||
parse = \case
|
||||
[] -> pure $ Input.UiI Path.relativeEmpty'
|
||||
[path] -> first fromString $ do
|
||||
[path] -> first P.text $ do
|
||||
p <- Path.parsePath' path
|
||||
pure $ Input.UiI p
|
||||
_ -> Left (I.help ui)
|
||||
@ -642,7 +641,7 @@ findShallow =
|
||||
)
|
||||
( \case
|
||||
[] -> pure $ Input.FindShallowI Path.relativeEmpty'
|
||||
[path] -> first fromString $ do
|
||||
[path] -> first P.text $ do
|
||||
p <- Path.parsePath' path
|
||||
pure $ Input.FindShallowI p
|
||||
_ -> Left (I.help findShallow)
|
||||
@ -695,9 +694,9 @@ renameTerm =
|
||||
]
|
||||
"`move.term foo bar` renames `foo` to `bar`."
|
||||
( \case
|
||||
[oldName, newName] -> first fromString $ do
|
||||
[oldName, newName] -> first P.text do
|
||||
src <- Path.parseHQSplit' oldName
|
||||
target <- Path.parseSplit' Path.definitionNameSegment newName
|
||||
target <- Path.parseSplit' newName
|
||||
pure $ Input.MoveTermI src target
|
||||
_ ->
|
||||
Left . P.warnCallout $
|
||||
@ -716,7 +715,7 @@ moveAll =
|
||||
]
|
||||
"`move foo bar` renames the term, type, and namespace foo to bar."
|
||||
( \case
|
||||
[oldName, newName] -> first fromString $ do
|
||||
[oldName, newName] -> first P.text $ do
|
||||
src <- Path.parsePath' oldName
|
||||
target <- Path.parsePath' newName
|
||||
pure $ Input.MoveAllI src target
|
||||
@ -737,9 +736,9 @@ renameType =
|
||||
]
|
||||
"`move.type foo bar` renames `foo` to `bar`."
|
||||
( \case
|
||||
[oldName, newName] -> first fromString $ do
|
||||
[oldName, newName] -> first P.text do
|
||||
src <- Path.parseHQSplit' oldName
|
||||
target <- Path.parseSplit' Path.definitionNameSegment newName
|
||||
target <- Path.parseSplit' newName
|
||||
pure $ Input.MoveTypeI src target
|
||||
_ ->
|
||||
Left . P.warnCallout $
|
||||
@ -786,7 +785,7 @@ deleteGen suffix queryCompletionArg target mkTarget =
|
||||
info
|
||||
( \case
|
||||
[] -> Left . P.warnCallout $ P.wrap warn
|
||||
queries -> first fromString $ do
|
||||
queries -> first P.text do
|
||||
paths <- traverse Path.parseHQSplit' queries
|
||||
pure $ Input.DeleteI (mkTarget paths)
|
||||
)
|
||||
@ -834,10 +833,7 @@ deleteReplacement isTerm =
|
||||
)
|
||||
( \case
|
||||
query : patch -> do
|
||||
patch <-
|
||||
first fromString
|
||||
. traverse (Path.parseSplit' Path.definitionNameSegment)
|
||||
$ listToMaybe patch
|
||||
patch <- first P.text . traverse Path.parseSplit' $ listToMaybe patch
|
||||
q <- parseHashQualifiedName query
|
||||
pure $ input q patch
|
||||
_ ->
|
||||
@ -919,16 +915,15 @@ aliasTerm =
|
||||
I.Visible
|
||||
[("term to alias", Required, exactDefinitionTermQueryArg), ("alias name", Required, newNameArg)]
|
||||
"`alias.term foo bar` introduces `bar` with the same definition as `foo`."
|
||||
( \case
|
||||
[oldName, newName] -> first fromString $ do
|
||||
source <- Path.parseShortHashOrHQSplit' oldName
|
||||
target <- Path.parseSplit' Path.definitionNameSegment newName
|
||||
pure $ Input.AliasTermI source target
|
||||
_ ->
|
||||
Left . warn $
|
||||
P.wrap
|
||||
"`alias.term` takes two arguments, like `alias.term oldname newname`."
|
||||
)
|
||||
\case
|
||||
[oldName, newName] -> first P.text do
|
||||
source <- Path.parseShortHashOrHQSplit' oldName
|
||||
target <- Path.parseSplit' newName
|
||||
pure $ Input.AliasTermI source target
|
||||
_ ->
|
||||
Left . warn $
|
||||
P.wrap
|
||||
"`alias.term` takes two arguments, like `alias.term oldname newname`."
|
||||
|
||||
aliasType :: InputPattern
|
||||
aliasType =
|
||||
@ -938,16 +933,15 @@ aliasType =
|
||||
I.Visible
|
||||
[("type to alias", Required, exactDefinitionTypeQueryArg), ("alias name", Required, newNameArg)]
|
||||
"`alias.type Foo Bar` introduces `Bar` with the same definition as `Foo`."
|
||||
( \case
|
||||
[oldName, newName] -> first fromString $ do
|
||||
source <- Path.parseShortHashOrHQSplit' oldName
|
||||
target <- Path.parseSplit' Path.definitionNameSegment newName
|
||||
pure $ Input.AliasTypeI source target
|
||||
_ ->
|
||||
Left . warn $
|
||||
P.wrap
|
||||
"`alias.type` takes two arguments, like `alias.type oldname newname`."
|
||||
)
|
||||
\case
|
||||
[oldName, newName] -> first P.text do
|
||||
source <- Path.parseShortHashOrHQSplit' oldName
|
||||
target <- Path.parseSplit' newName
|
||||
pure $ Input.AliasTypeI source target
|
||||
_ ->
|
||||
Left . warn $
|
||||
P.wrap
|
||||
"`alias.type` takes two arguments, like `alias.type oldname newname`."
|
||||
|
||||
aliasMany :: InputPattern
|
||||
aliasMany =
|
||||
@ -965,13 +959,12 @@ aliasMany =
|
||||
<> "creates aliases `.quux.foo.foo` and `.quux.bar.bar`."
|
||||
]
|
||||
)
|
||||
( \case
|
||||
srcs@(_ : _) Cons.:> dest -> first fromString $ do
|
||||
sourceDefinitions <- traverse Path.parseHQSplit srcs
|
||||
destNamespace <- Path.parsePath' dest
|
||||
pure $ Input.AliasManyI sourceDefinitions destNamespace
|
||||
_ -> Left (I.help aliasMany)
|
||||
)
|
||||
\case
|
||||
srcs@(_ : _) Cons.:> dest -> first P.text do
|
||||
sourceDefinitions <- traverse Path.parseHQSplit srcs
|
||||
destNamespace <- Path.parsePath' dest
|
||||
pure $ Input.AliasManyI sourceDefinitions destNamespace
|
||||
_ -> Left (I.help aliasMany)
|
||||
|
||||
up :: InputPattern
|
||||
up =
|
||||
@ -1012,13 +1005,12 @@ cd =
|
||||
]
|
||||
]
|
||||
)
|
||||
( \case
|
||||
[".."] -> Right Input.UpI
|
||||
[p] -> first fromString $ do
|
||||
p <- Path.parsePath' p
|
||||
pure . Input.SwitchBranchI $ p
|
||||
_ -> Left (I.help cd)
|
||||
)
|
||||
\case
|
||||
[".."] -> Right Input.UpI
|
||||
[p] -> first P.text do
|
||||
p <- Path.parsePath' p
|
||||
pure . Input.SwitchBranchI $ p
|
||||
_ -> Left (I.help cd)
|
||||
|
||||
back :: InputPattern
|
||||
back =
|
||||
@ -1033,10 +1025,9 @@ back =
|
||||
)
|
||||
]
|
||||
)
|
||||
( \case
|
||||
[] -> pure Input.PopBranchI
|
||||
_ -> Left (I.help cd)
|
||||
)
|
||||
\case
|
||||
[] -> pure Input.PopBranchI
|
||||
_ -> Left (I.help cd)
|
||||
|
||||
deleteNamespace :: InputPattern
|
||||
deleteNamespace =
|
||||
@ -1061,17 +1052,15 @@ deleteNamespaceForce =
|
||||
(deleteNamespaceParser (I.help deleteNamespaceForce) Input.Force)
|
||||
|
||||
deleteNamespaceParser :: P.Pretty CT.ColorText -> Input.Insistence -> [String] -> Either (P.Pretty CT.ColorText) Input
|
||||
deleteNamespaceParser helpText insistence =
|
||||
( \case
|
||||
["."] ->
|
||||
first fromString
|
||||
. pure
|
||||
$ Input.DeleteI (DeleteTarget'Namespace insistence Nothing)
|
||||
[p] -> first fromString $ do
|
||||
p <- Path.parseSplit' Path.definitionNameSegment p
|
||||
pure $ Input.DeleteI (DeleteTarget'Namespace insistence (Just p))
|
||||
_ -> Left helpText
|
||||
)
|
||||
deleteNamespaceParser helpText insistence = \case
|
||||
["."] ->
|
||||
first fromString
|
||||
. pure
|
||||
$ Input.DeleteI (DeleteTarget'Namespace insistence Nothing)
|
||||
[p] -> first P.text do
|
||||
p <- Path.parseSplit' p
|
||||
pure $ Input.DeleteI (DeleteTarget'Namespace insistence (Just p))
|
||||
_ -> Left helpText
|
||||
|
||||
deletePatch :: InputPattern
|
||||
deletePatch =
|
||||
@ -1081,23 +1070,22 @@ deletePatch =
|
||||
I.Visible
|
||||
[("patch to delete", Required, patchArg)]
|
||||
"`delete.patch <foo>` deletes the patch `foo`"
|
||||
( \case
|
||||
[p] -> first fromString $ do
|
||||
p <- Path.parseSplit' Path.definitionNameSegment p
|
||||
pure . Input.DeleteI $ DeleteTarget'Patch p
|
||||
_ -> Left (I.help deletePatch)
|
||||
)
|
||||
\case
|
||||
[p] -> first P.text do
|
||||
p <- Path.parseSplit' p
|
||||
pure . Input.DeleteI $ DeleteTarget'Patch p
|
||||
_ -> Left (I.help deletePatch)
|
||||
|
||||
movePatch :: String -> String -> Either (P.Pretty CT.ColorText) Input
|
||||
movePatch src dest = first fromString $ do
|
||||
src <- Path.parseSplit' Path.definitionNameSegment src
|
||||
dest <- Path.parseSplit' Path.definitionNameSegment dest
|
||||
movePatch src dest = first P.text do
|
||||
src <- Path.parseSplit' src
|
||||
dest <- Path.parseSplit' dest
|
||||
pure $ Input.MovePatchI src dest
|
||||
|
||||
copyPatch' :: String -> String -> Either (P.Pretty CT.ColorText) Input
|
||||
copyPatch' src dest = first fromString $ do
|
||||
src <- Path.parseSplit' Path.definitionNameSegment src
|
||||
dest <- Path.parseSplit' Path.definitionNameSegment dest
|
||||
copyPatch' src dest = first P.text do
|
||||
src <- Path.parseSplit' src
|
||||
dest <- Path.parseSplit' dest
|
||||
pure $ Input.CopyPatchI src dest
|
||||
|
||||
copyPatch :: InputPattern
|
||||
@ -1108,10 +1096,9 @@ copyPatch =
|
||||
I.Visible
|
||||
[("patch to copy", Required, patchArg), ("copy destination", Required, newNameArg)]
|
||||
"`copy.patch foo bar` copies the patch `foo` to `bar`."
|
||||
( \case
|
||||
[src, dest] -> copyPatch' src dest
|
||||
_ -> Left (I.help copyPatch)
|
||||
)
|
||||
\case
|
||||
[src, dest] -> copyPatch' src dest
|
||||
_ -> Left (I.help copyPatch)
|
||||
|
||||
renamePatch :: InputPattern
|
||||
renamePatch =
|
||||
@ -1121,10 +1108,9 @@ renamePatch =
|
||||
I.Visible
|
||||
[("patch", Required, patchArg), ("new location", Required, newNameArg)]
|
||||
"`move.patch foo bar` renames the patch `foo` to `bar`."
|
||||
( \case
|
||||
[src, dest] -> movePatch src dest
|
||||
_ -> Left (I.help renamePatch)
|
||||
)
|
||||
\case
|
||||
[src, dest] -> movePatch src dest
|
||||
_ -> Left (I.help renamePatch)
|
||||
|
||||
renameBranch :: InputPattern
|
||||
renameBranch =
|
||||
@ -1134,13 +1120,12 @@ renameBranch =
|
||||
I.Visible
|
||||
[("namespace to move", Required, namespaceArg), ("new location", Required, newNameArg)]
|
||||
"`move.namespace foo bar` renames the path `foo` to `bar`."
|
||||
( \case
|
||||
[src, dest] -> first fromString $ do
|
||||
src <- Path.parsePath' src
|
||||
dest <- Path.parsePath' dest
|
||||
pure $ Input.MoveBranchI src dest
|
||||
_ -> Left (I.help renameBranch)
|
||||
)
|
||||
\case
|
||||
[src, dest] -> first P.text do
|
||||
src <- Path.parsePath' src
|
||||
dest <- Path.parsePath' dest
|
||||
pure $ Input.MoveBranchI src dest
|
||||
_ -> Left (I.help renameBranch)
|
||||
|
||||
history :: InputPattern
|
||||
history =
|
||||
@ -1158,13 +1143,12 @@ history =
|
||||
)
|
||||
]
|
||||
)
|
||||
( \case
|
||||
[src] -> first fromString $ do
|
||||
p <- Input.parseBranchId src
|
||||
pure $ Input.HistoryI (Just 10) (Just 10) p
|
||||
[] -> pure $ Input.HistoryI (Just 10) (Just 10) (Right Path.currentPath)
|
||||
_ -> Left (I.help history)
|
||||
)
|
||||
\case
|
||||
[src] -> first P.text do
|
||||
p <- Input.parseBranchId src
|
||||
pure $ Input.HistoryI (Just 10) (Just 10) p
|
||||
[] -> pure $ Input.HistoryI (Just 10) (Just 10) (Right Path.currentPath)
|
||||
_ -> Left (I.help history)
|
||||
|
||||
forkLocal :: InputPattern
|
||||
forkLocal =
|
||||
@ -1187,13 +1171,12 @@ forkLocal =
|
||||
)
|
||||
]
|
||||
)
|
||||
( \case
|
||||
[src, dest] -> do
|
||||
src <- Input.parseBranchId2 src
|
||||
dest <- parseBranchRelativePath dest
|
||||
pure $ Input.ForkLocalBranchI src dest
|
||||
_ -> Left (I.help forkLocal)
|
||||
)
|
||||
\case
|
||||
[src, dest] -> do
|
||||
src <- Input.parseBranchId2 src
|
||||
dest <- parseBranchRelativePath dest
|
||||
pure $ Input.ForkLocalBranchI src dest
|
||||
_ -> Left (I.help forkLocal)
|
||||
|
||||
reset :: InputPattern
|
||||
reset =
|
||||
@ -1262,12 +1245,11 @@ resetRoot =
|
||||
)
|
||||
]
|
||||
)
|
||||
( \case
|
||||
[src] -> first fromString $ do
|
||||
src <- Input.parseBranchId src
|
||||
pure $ Input.ResetRootI src
|
||||
_ -> Left (I.help resetRoot)
|
||||
)
|
||||
\case
|
||||
[src] -> first P.text $ do
|
||||
src <- Input.parseBranchId src
|
||||
pure $ Input.ResetRootI src
|
||||
_ -> Left (I.help resetRoot)
|
||||
|
||||
pull :: InputPattern
|
||||
pull =
|
||||
@ -1425,11 +1407,10 @@ debugFuzzyOptions =
|
||||
P.wrap $ "or `debug.fuzzy-options merge - _`"
|
||||
]
|
||||
)
|
||||
( \case
|
||||
(cmd : args) ->
|
||||
Right $ Input.DebugFuzzyOptionsI cmd args
|
||||
_ -> Left (I.help debugFuzzyOptions)
|
||||
)
|
||||
\case
|
||||
(cmd : args) ->
|
||||
Right $ Input.DebugFuzzyOptionsI cmd args
|
||||
_ -> Left (I.help debugFuzzyOptions)
|
||||
|
||||
debugFormat :: InputPattern
|
||||
debugFormat =
|
||||
@ -1750,11 +1731,11 @@ diffNamespace =
|
||||
]
|
||||
)
|
||||
( \case
|
||||
[before, after] -> first fromString $ do
|
||||
[before, after] -> first P.text do
|
||||
before <- Input.parseBranchId before
|
||||
after <- Input.parseBranchId after
|
||||
pure $ Input.DiffNamespaceI before after
|
||||
[before] -> first fromString $ do
|
||||
[before] -> first P.text do
|
||||
before <- Input.parseBranchId before
|
||||
pure $ Input.DiffNamespaceI before (Right Path.currentPath)
|
||||
_ -> Left $ I.help diffNamespace
|
||||
@ -1830,10 +1811,7 @@ replaceEdit f = self
|
||||
)
|
||||
( \case
|
||||
source : target : patch -> do
|
||||
patch <-
|
||||
first fromString
|
||||
<$> traverse (Path.parseSplit' Path.definitionNameSegment)
|
||||
$ listToMaybe patch
|
||||
patch <- first P.text <$> traverse Path.parseSplit' $ listToMaybe patch
|
||||
sourcehq <- parseHashQualifiedName source
|
||||
targethq <- parseHashQualifiedName target
|
||||
pure $ f sourcehq targethq patch
|
||||
@ -1892,7 +1870,7 @@ editNamespace =
|
||||
[ "`edit.namespace` will load all terms and types contained within the current namespace into your scratch file. This includes definitions in namespaces, but excludes libraries.",
|
||||
"`edit.namespace ns1 ns2 ...` loads the terms and types contained within the provided namespaces."
|
||||
],
|
||||
parse = Right . Input.EditNamespaceI . fmap (Path.fromText . Text.pack)
|
||||
parse = Right . Input.EditNamespaceI . fmap (Path.unsafeParseText . Text.pack)
|
||||
}
|
||||
|
||||
topicNameArg :: ArgumentType
|
||||
@ -2103,33 +2081,32 @@ help =
|
||||
I.Visible
|
||||
[("command", Optional, commandNameArg)]
|
||||
"`help` shows general help and `help <cmd>` shows help for one command."
|
||||
( \case
|
||||
[] ->
|
||||
Left $
|
||||
intercalateMap
|
||||
"\n\n"
|
||||
showPatternHelp
|
||||
visibleInputs
|
||||
[cmd] ->
|
||||
case (Map.lookup cmd commandsByName, isHelp cmd) of
|
||||
(Nothing, Just msg) -> Left msg
|
||||
(Nothing, Nothing) -> Left . warn $ "I don't know of that command. Try `help`."
|
||||
(Just pat, Nothing) -> Left $ showPatternHelp pat
|
||||
-- If we have a command and a help topic with the same name (like "projects"), then append a tip to the
|
||||
-- command's help that suggests running `help-topic command`
|
||||
(Just pat, Just _) ->
|
||||
Left $
|
||||
showPatternHelp pat
|
||||
<> P.newline
|
||||
<> P.newline
|
||||
<> ( tip $
|
||||
"To read more about"
|
||||
<> P.group (P.string cmd <> ",")
|
||||
<> "use"
|
||||
<> makeExample helpTopics [P.string cmd]
|
||||
)
|
||||
_ -> Left $ warn "Use `help <cmd>` or `help`."
|
||||
)
|
||||
\case
|
||||
[] ->
|
||||
Left $
|
||||
intercalateMap
|
||||
"\n\n"
|
||||
showPatternHelp
|
||||
visibleInputs
|
||||
[cmd] ->
|
||||
case (Map.lookup cmd commandsByName, isHelp cmd) of
|
||||
(Nothing, Just msg) -> Left msg
|
||||
(Nothing, Nothing) -> Left . warn $ "I don't know of that command. Try `help`."
|
||||
(Just pat, Nothing) -> Left $ showPatternHelp pat
|
||||
-- If we have a command and a help topic with the same name (like "projects"), then append a tip to the
|
||||
-- command's help that suggests running `help-topic command`
|
||||
(Just pat, Just _) ->
|
||||
Left $
|
||||
showPatternHelp pat
|
||||
<> P.newline
|
||||
<> P.newline
|
||||
<> ( tip $
|
||||
"To read more about"
|
||||
<> P.group (P.string cmd <> ",")
|
||||
<> "use"
|
||||
<> makeExample helpTopics [P.string cmd]
|
||||
)
|
||||
_ -> Left $ warn "Use `help <cmd>` or `help`."
|
||||
where
|
||||
commandsByName =
|
||||
Map.fromList $ do
|
||||
@ -2146,10 +2123,9 @@ quit =
|
||||
I.Visible
|
||||
[]
|
||||
"Exits the Unison command line interface."
|
||||
( \case
|
||||
[] -> pure Input.QuitI
|
||||
_ -> Left "Use `quit`, `exit`, or <Ctrl-D> to quit."
|
||||
)
|
||||
\case
|
||||
[] -> pure Input.QuitI
|
||||
_ -> Left "Use `quit`, `exit`, or <Ctrl-D> to quit."
|
||||
|
||||
viewPatch :: InputPattern
|
||||
viewPatch =
|
||||
@ -2167,13 +2143,12 @@ viewPatch =
|
||||
)
|
||||
]
|
||||
)
|
||||
( \case
|
||||
[] -> Right $ Input.ListEditsI Nothing
|
||||
[patchStr] -> mapLeft fromString $ do
|
||||
patch <- Path.parseSplit' Path.definitionNameSegment patchStr
|
||||
Right $ Input.ListEditsI (Just patch)
|
||||
_ -> Left $ warn "`view.patch` takes a patch and that's it."
|
||||
)
|
||||
\case
|
||||
[] -> Right $ Input.ListEditsI Nothing
|
||||
[patchStr] -> mapLeft P.text do
|
||||
patch <- Path.parseSplit' patchStr
|
||||
Right $ Input.ListEditsI (Just patch)
|
||||
_ -> Left $ warn "`view.patch` takes a patch and that's it."
|
||||
|
||||
names :: Input.IsGlobal -> InputPattern
|
||||
names isGlobal =
|
||||
@ -2183,15 +2158,14 @@ names isGlobal =
|
||||
I.Visible
|
||||
[("name or hash", Required, definitionQueryArg)]
|
||||
(P.wrap $ makeExample (names isGlobal) ["foo"] <> " shows the hash and all known names for `foo`.")
|
||||
( \case
|
||||
[thing] -> case HQ.fromString thing of
|
||||
Just hq -> Right $ Input.NamesI isGlobal hq
|
||||
Nothing ->
|
||||
Left $
|
||||
"I was looking for one of these forms: "
|
||||
<> P.blue "foo .foo.bar foo#abc #abcde .foo.bar#asdf"
|
||||
_ -> Left (I.help (names isGlobal))
|
||||
)
|
||||
\case
|
||||
[thing] -> case HQ.parseText (Text.pack thing) of
|
||||
Just hq -> Right $ Input.NamesI isGlobal hq
|
||||
Nothing ->
|
||||
Left $
|
||||
"I was looking for one of these forms: "
|
||||
<> P.blue "foo .foo.bar foo#abc #abcde .foo.bar#asdf"
|
||||
_ -> Left (I.help (names isGlobal))
|
||||
where
|
||||
cmdName = if isGlobal then "names.global" else "names"
|
||||
|
||||
@ -2203,10 +2177,9 @@ dependents =
|
||||
I.Visible
|
||||
[("definition", Required, definitionQueryArg)]
|
||||
"List the named dependents of the specified definition."
|
||||
( \case
|
||||
[thing] -> fmap Input.ListDependentsI $ parseHashQualifiedName thing
|
||||
_ -> Left (I.help dependents)
|
||||
)
|
||||
\case
|
||||
[thing] -> fmap Input.ListDependentsI $ parseHashQualifiedName thing
|
||||
_ -> Left (I.help dependents)
|
||||
dependencies =
|
||||
InputPattern
|
||||
"dependencies"
|
||||
@ -2214,10 +2187,9 @@ dependencies =
|
||||
I.Visible
|
||||
[("definition", Required, definitionQueryArg)]
|
||||
"List the dependencies of the specified definition."
|
||||
( \case
|
||||
[thing] -> fmap Input.ListDependenciesI $ parseHashQualifiedName thing
|
||||
_ -> Left (I.help dependencies)
|
||||
)
|
||||
\case
|
||||
[thing] -> fmap Input.ListDependenciesI $ parseHashQualifiedName thing
|
||||
_ -> Left (I.help dependencies)
|
||||
|
||||
namespaceDependencies :: InputPattern
|
||||
namespaceDependencies =
|
||||
@ -2227,13 +2199,12 @@ namespaceDependencies =
|
||||
I.Visible
|
||||
[("namespace", Optional, namespaceArg)]
|
||||
"List the external dependencies of the specified namespace."
|
||||
( \case
|
||||
[p] -> first fromString $ do
|
||||
p <- Path.parsePath' p
|
||||
pure $ Input.NamespaceDependenciesI (Just p)
|
||||
[] -> pure (Input.NamespaceDependenciesI Nothing)
|
||||
_ -> Left (I.help namespaceDependencies)
|
||||
)
|
||||
\case
|
||||
[p] -> first P.text do
|
||||
p <- Path.parsePath' p
|
||||
pure $ Input.NamespaceDependenciesI (Just p)
|
||||
[] -> pure (Input.NamespaceDependenciesI Nothing)
|
||||
_ -> Left (I.help namespaceDependencies)
|
||||
|
||||
debugNumberedArgs :: InputPattern
|
||||
debugNumberedArgs =
|
||||
@ -2416,12 +2387,11 @@ docsToHtml =
|
||||
)
|
||||
]
|
||||
)
|
||||
( \case
|
||||
[namespacePath, destinationFilePath] -> first fromString $ do
|
||||
np <- Path.parsePath' namespacePath
|
||||
pure $ Input.DocsToHtmlI np destinationFilePath
|
||||
_ -> Left $ showPatternHelp docsToHtml
|
||||
)
|
||||
\case
|
||||
[namespacePath, destinationFilePath] -> first P.text do
|
||||
np <- Path.parsePath' namespacePath
|
||||
pure $ Input.DocsToHtmlI np destinationFilePath
|
||||
_ -> Left $ showPatternHelp docsToHtml
|
||||
|
||||
docToMarkdown :: InputPattern
|
||||
docToMarkdown =
|
||||
@ -2436,12 +2406,11 @@ docToMarkdown =
|
||||
)
|
||||
]
|
||||
)
|
||||
( \case
|
||||
[docNameText] -> first fromString $ do
|
||||
docName <- maybeToEither "Invalid name" . Name.fromText . Text.pack $ docNameText
|
||||
pure $ Input.DocToMarkdownI docName
|
||||
_ -> Left $ showPatternHelp docToMarkdown
|
||||
)
|
||||
\case
|
||||
[docNameText] -> first fromString $ do
|
||||
docName <- maybeToEither "Invalid name" . Name.parseText . Text.pack $ docNameText
|
||||
pure $ Input.DocToMarkdownI docName
|
||||
_ -> Left $ showPatternHelp docToMarkdown
|
||||
|
||||
execute :: InputPattern
|
||||
execute =
|
||||
@ -2459,11 +2428,10 @@ execute =
|
||||
)
|
||||
]
|
||||
)
|
||||
( \case
|
||||
[w] -> pure $ Input.ExecuteI w []
|
||||
(w : ws) -> pure $ Input.ExecuteI w ws
|
||||
_ -> Left $ showPatternHelp execute
|
||||
)
|
||||
\case
|
||||
[w] -> pure $ Input.ExecuteI (Text.pack w) []
|
||||
w : ws -> pure $ Input.ExecuteI (Text.pack w) ws
|
||||
_ -> Left $ showPatternHelp execute
|
||||
|
||||
saveExecuteResult :: InputPattern
|
||||
saveExecuteResult =
|
||||
@ -2475,10 +2443,9 @@ saveExecuteResult =
|
||||
( "`add.run name` adds to the codebase the result of the most recent `run` command"
|
||||
<> "as `name`."
|
||||
)
|
||||
( \case
|
||||
[w] -> pure $ Input.SaveExecuteResultI (Name.unsafeFromString w)
|
||||
_ -> Left $ showPatternHelp saveExecuteResult
|
||||
)
|
||||
\case
|
||||
[w] -> pure $ Input.SaveExecuteResultI (Name.unsafeParseText (Text.pack w))
|
||||
_ -> Left $ showPatternHelp saveExecuteResult
|
||||
|
||||
ioTest :: InputPattern
|
||||
ioTest =
|
||||
@ -2531,11 +2498,10 @@ makeStandalone =
|
||||
)
|
||||
]
|
||||
)
|
||||
( \case
|
||||
[main, file] ->
|
||||
Input.MakeStandaloneI file <$> parseHashQualifiedName main
|
||||
_ -> Left $ showPatternHelp makeStandalone
|
||||
)
|
||||
\case
|
||||
[main, file] ->
|
||||
Input.MakeStandaloneI file <$> parseHashQualifiedName main
|
||||
_ -> Left $ showPatternHelp makeStandalone
|
||||
|
||||
runScheme :: InputPattern
|
||||
runScheme =
|
||||
@ -2550,10 +2516,9 @@ runScheme =
|
||||
)
|
||||
]
|
||||
)
|
||||
( \case
|
||||
(main : args) -> Right $ Input.ExecuteSchemeI main args
|
||||
_ -> Left $ showPatternHelp runScheme
|
||||
)
|
||||
\case
|
||||
main : args -> Right $ Input.ExecuteSchemeI (Text.pack main) args
|
||||
_ -> Left $ showPatternHelp runScheme
|
||||
|
||||
compileScheme :: InputPattern
|
||||
compileScheme =
|
||||
@ -2570,11 +2535,10 @@ compileScheme =
|
||||
)
|
||||
]
|
||||
)
|
||||
( \case
|
||||
[main, file] ->
|
||||
Input.CompileSchemeI file <$> parseHashQualifiedName main
|
||||
_ -> Left $ showPatternHelp compileScheme
|
||||
)
|
||||
\case
|
||||
[main, file] ->
|
||||
Input.CompileSchemeI (Text.pack file) <$> parseHashQualifiedName main
|
||||
_ -> Left $ showPatternHelp compileScheme
|
||||
|
||||
schemeLibgen :: InputPattern
|
||||
schemeLibgen =
|
||||
@ -2597,11 +2561,10 @@ schemeLibgen =
|
||||
)
|
||||
]
|
||||
)
|
||||
( \case
|
||||
[] -> pure $ Input.GenSchemeLibsI Nothing
|
||||
[dir] -> pure . Input.GenSchemeLibsI $ Just dir
|
||||
_ -> Left $ showPatternHelp schemeLibgen
|
||||
)
|
||||
\case
|
||||
[] -> pure $ Input.GenSchemeLibsI Nothing
|
||||
[dir] -> pure . Input.GenSchemeLibsI $ Just dir
|
||||
_ -> Left $ showPatternHelp schemeLibgen
|
||||
|
||||
fetchScheme :: InputPattern
|
||||
fetchScheme =
|
||||
@ -2634,16 +2597,15 @@ fetchScheme =
|
||||
)
|
||||
]
|
||||
)
|
||||
( \case
|
||||
[] -> pure (Input.FetchSchemeCompilerI "unison" JitInfo.currentRelease)
|
||||
[name] -> pure (Input.FetchSchemeCompilerI name branch)
|
||||
where
|
||||
branch
|
||||
| name == "unison" = JitInfo.currentRelease
|
||||
| otherwise = "main"
|
||||
[name, branch] -> pure (Input.FetchSchemeCompilerI name branch)
|
||||
_ -> Left $ showPatternHelp fetchScheme
|
||||
)
|
||||
\case
|
||||
[] -> pure (Input.FetchSchemeCompilerI "unison" JitInfo.currentRelease)
|
||||
[name] -> pure (Input.FetchSchemeCompilerI name branch)
|
||||
where
|
||||
branch
|
||||
| name == "unison" = JitInfo.currentRelease
|
||||
| otherwise = "main"
|
||||
[name, branch] -> pure (Input.FetchSchemeCompilerI name branch)
|
||||
_ -> Left $ showPatternHelp fetchScheme
|
||||
|
||||
createAuthor :: InputPattern
|
||||
createAuthor =
|
||||
@ -2664,8 +2626,10 @@ createAuthor =
|
||||
)
|
||||
)
|
||||
( \case
|
||||
symbolStr : authorStr@(_ : _) -> first fromString $ do
|
||||
symbol <- Path.definitionNameSegment symbolStr
|
||||
symbolStr : authorStr@(_ : _) -> first P.text do
|
||||
symbol <-
|
||||
Megaparsec.runParser (Megaparsec.withParsecT (fmap NameSegment.renderParseErr) NameSegment.segmentP <* Megaparsec.eof) "" symbolStr
|
||||
& mapLeft (Text.pack . Megaparsec.errorBundlePretty)
|
||||
-- let's have a real parser in not too long
|
||||
let author :: Text
|
||||
author = Text.pack $ case (unwords authorStr) of
|
||||
@ -2745,10 +2709,10 @@ diffNamespaceToPatch =
|
||||
help = P.wrap "Create a patch from a namespace diff.",
|
||||
parse = \case
|
||||
[branchId1, branchId2, patch] ->
|
||||
mapLeft fromString do
|
||||
mapLeft P.text do
|
||||
branchId1 <- Input.parseBranchId branchId1
|
||||
branchId2 <- Input.parseBranchId branchId2
|
||||
patch <- Path.parseSplit' Path.definitionNameSegment patch
|
||||
patch <- Path.parseSplit' patch
|
||||
pure (Input.DiffNamespaceToPatchI Input.DiffNamespaceToPatchInput {branchId1, branchId2, patch})
|
||||
_ -> Left (showPatternHelp diffNamespaceToPatch)
|
||||
}
|
||||
@ -3020,7 +2984,7 @@ upgrade =
|
||||
where
|
||||
parseRelativeNameSegment :: String -> Maybe NameSegment
|
||||
parseRelativeNameSegment string = do
|
||||
name <- Name.fromText (Text.pack string)
|
||||
name <- Name.parseText (Text.pack string)
|
||||
guard (Name.isRelative name)
|
||||
segment NE.:| [] <- Just (Name.reverseSegments name)
|
||||
Just segment
|
||||
@ -3274,14 +3238,10 @@ dependencyArg =
|
||||
ArgumentType
|
||||
{ typeName = "project dependency",
|
||||
suggestions = \q cb _http p -> Codebase.runTransaction cb do
|
||||
prefixCompleteNamespace q (p Path.:> Name.libSegment),
|
||||
prefixCompleteNamespace q (p Path.:> NameSegment.libSegment),
|
||||
fzfResolver = Just Resolvers.projectDependencyResolver
|
||||
}
|
||||
|
||||
-- | Names of child branches of the branch, only gives options for one 'layer' deeper at a time.
|
||||
childNamespaceNames :: Branch.Branch0 m -> [Text]
|
||||
childNamespaceNames b = NameSegment.toText <$> Map.keys (Branch.nonEmptyChildren b)
|
||||
|
||||
newNameArg :: ArgumentType
|
||||
newNameArg =
|
||||
ArgumentType
|
||||
@ -3338,8 +3298,7 @@ remoteNamespaceArg =
|
||||
"ghs" -> complete "git(git@github.com:"
|
||||
"gls" -> complete "git(git@gitlab.com:"
|
||||
"bbs" -> complete "git(git@bitbucket.com:"
|
||||
_ -> do
|
||||
sharePathCompletion http input,
|
||||
_ -> sharePathCompletion http input,
|
||||
fzfResolver = Nothing
|
||||
}
|
||||
|
||||
@ -3819,7 +3778,7 @@ parseHashQualifiedName s =
|
||||
<> "I expected something like `foo`, `#abc123`, or `foo#abc123`."
|
||||
)
|
||||
Right
|
||||
$ HQ.fromString s
|
||||
$ HQ.parseText (Text.pack s)
|
||||
|
||||
parseWriteGitRepo :: String -> String -> Either (P.Pretty P.ColorText) WriteGitRepo
|
||||
parseWriteGitRepo label input = do
|
||||
|
@ -130,8 +130,8 @@ import Unison.Share.Sync.Types (CodeserverTransportError (..))
|
||||
import Unison.ShortHash qualified as ShortHash
|
||||
import Unison.Sync.Types qualified as Share
|
||||
import Unison.Syntax.DeclPrinter qualified as DeclPrinter
|
||||
import Unison.Syntax.HashQualified qualified as HQ (toString, toText, unsafeFromVar)
|
||||
import Unison.Syntax.Name qualified as Name (toString, toText)
|
||||
import Unison.Syntax.HashQualified qualified as HQ (toText, unsafeFromVar)
|
||||
import Unison.Syntax.Name qualified as Name (toText)
|
||||
import Unison.Syntax.NamePrinter
|
||||
( prettyHashQualified,
|
||||
prettyHashQualified',
|
||||
@ -143,6 +143,7 @@ import Unison.Syntax.NamePrinter
|
||||
prettyShortHash,
|
||||
styleHashQualified,
|
||||
)
|
||||
import Unison.Syntax.NameSegment qualified as NameSegment (toEscapedText)
|
||||
import Unison.Syntax.TermPrinter qualified as TermPrinter
|
||||
import Unison.Syntax.TypePrinter qualified as TypePrinter
|
||||
import Unison.Term (Term)
|
||||
@ -305,7 +306,7 @@ notifyNumbered = \case
|
||||
"",
|
||||
tip $
|
||||
"Add"
|
||||
<> prettyName "License"
|
||||
<> prettyName (Name.fromSegment "License")
|
||||
<> "values for"
|
||||
<> prettyName (Name.fromSegment authorNS)
|
||||
<> "under"
|
||||
@ -492,7 +493,7 @@ notifyNumbered = \case
|
||||
E.AmbiguousReset'Hash -> \xs -> xs
|
||||
E.AmbiguousReset'Target -> \xs -> "<some hash>" : xs
|
||||
reset = IP.makeExample IP.reset
|
||||
relPath0 = prettyPath' (Path.toPath' path)
|
||||
relPath0 = prettyPath path
|
||||
absPath0 = review ProjectUtils.projectBranchPathPrism (ProjectAndBranch (pn0 ^. #projectId) (bn0 ^. #branchId), path)
|
||||
ListNamespaceDependencies _ppe _path Empty -> ("This namespace has no external dependencies.", mempty)
|
||||
ListNamespaceDependencies ppe path' externalDependencies ->
|
||||
@ -514,12 +515,13 @@ notifyNumbered = \case
|
||||
newNextNum = nextNum + length unnumberedNames
|
||||
in ( newNextNum,
|
||||
( nameToNum <> (Map.fromList (zip unnumberedNames [nextNum ..])),
|
||||
args <> fmap Name.toString unnumberedNames
|
||||
args <> fmap Name.toText unnumberedNames
|
||||
)
|
||||
)
|
||||
)
|
||||
(1, (mempty, mempty))
|
||||
& snd
|
||||
& over (_2 . mapped) Text.unpack
|
||||
externalDepsTable :: Map LabeledDependency (Set Name) -> [(P.Pretty P.ColorText, P.Pretty P.ColorText)]
|
||||
externalDepsTable = ifoldMap $ \ld dependents ->
|
||||
[(prettyLD ld, prettyDependents dependents)]
|
||||
@ -610,7 +612,7 @@ showListEdits patch ppe =
|
||||
TermEdit.Replace rhsRef _typing -> do
|
||||
n2 <- gets snd <* modify (second succ)
|
||||
let rhsTermName = PPE.termName ppe (Referent.Ref rhsRef)
|
||||
lift $ tell ([lhsHash], [HQ.toString rhsTermName])
|
||||
lift $ tell ([lhsHash], [Text.unpack (HQ.toText rhsTermName)])
|
||||
pure
|
||||
( showNum n1 <> (P.syntaxToColor . prettyHashQualified $ lhsTermName),
|
||||
"-> " <> showNum n2 <> (P.syntaxToColor . prettyHashQualified $ rhsTermName)
|
||||
@ -635,7 +637,7 @@ showListEdits patch ppe =
|
||||
TypeEdit.Replace rhsRef -> do
|
||||
n2 <- gets snd <* modify (second succ)
|
||||
let rhsTypeName = PPE.typeName ppe rhsRef
|
||||
lift $ tell ([lhsHash], [HQ.toString rhsTypeName])
|
||||
lift $ tell ([lhsHash], [Text.unpack (HQ.toText rhsTypeName)])
|
||||
pure
|
||||
( showNum n1 <> (P.syntaxToColor . prettyHashQualified $ lhsTypeName),
|
||||
"-> " <> showNum n2 <> (P.syntaxToColor . prettyHashQualified $ rhsTypeName)
|
||||
@ -648,7 +650,7 @@ notifyUser dir = \case
|
||||
. P.warnCallout
|
||||
. P.wrap
|
||||
$ "Cannot save the last run result into"
|
||||
<> P.backticked (P.string (Name.toString name))
|
||||
<> P.backticked (P.text (Name.toText name))
|
||||
<> "because that name conflicts with a name in the scratch file."
|
||||
NoLastRunResult ->
|
||||
pure
|
||||
@ -747,7 +749,7 @@ notifyUser dir = \case
|
||||
"Use"
|
||||
<> IP.makeExample
|
||||
IP.todo
|
||||
[ prettyPath' (snoc mergedPath "patch"),
|
||||
[ prettyPath' (snoc mergedPath NameSegment.defaultPatchSegment),
|
||||
prettyPath' mergedPath
|
||||
]
|
||||
<> "to see what work is remaining for the merge.",
|
||||
@ -886,21 +888,21 @@ notifyUser dir = \case
|
||||
P.lines
|
||||
[ P.wrap $
|
||||
"I looked for a function"
|
||||
<> P.backticked (P.string main)
|
||||
<> P.backticked (P.text main)
|
||||
<> "in the most recently typechecked file and codebase but couldn't find one. It has to have the type:",
|
||||
"",
|
||||
P.indentN 2 $ P.lines [P.string main <> " : " <> TypePrinter.pretty ppe t | t <- ts]
|
||||
P.indentN 2 $ P.lines [P.text main <> " : " <> TypePrinter.pretty ppe t | t <- ts]
|
||||
]
|
||||
BadMainFunction what main ty ppe ts ->
|
||||
pure . P.callout "😶" $
|
||||
P.lines
|
||||
[ P.string "I found this function:",
|
||||
"",
|
||||
P.indentN 2 $ P.string main <> " : " <> TypePrinter.pretty ppe ty,
|
||||
P.indentN 2 $ P.text main <> " : " <> TypePrinter.pretty ppe ty,
|
||||
"",
|
||||
P.wrap $ P.string "but in order for me to" <> P.backticked (P.string what) <> "it needs to be a subtype of:",
|
||||
P.wrap $ P.string "but in order for me to" <> P.backticked (P.text what) <> "it needs to be a subtype of:",
|
||||
"",
|
||||
P.indentN 2 $ P.lines [P.string main <> " : " <> TypePrinter.pretty ppe t | t <- ts]
|
||||
P.indentN 2 $ P.lines [P.text main <> " : " <> TypePrinter.pretty ppe t | t <- ts]
|
||||
]
|
||||
NoUnisonFile -> do
|
||||
dir' <- canonicalizePath dir
|
||||
@ -1073,11 +1075,11 @@ notifyUser dir = \case
|
||||
formatEntry :: (Var v) => PPE.PrettyPrintEnv -> ShallowListEntry v a -> (Pretty, Pretty)
|
||||
formatEntry ppe = \case
|
||||
ShallowTermEntry termEntry ->
|
||||
( P.syntaxToColor . prettyHashQualified' . fmap Name.fromSegment . Backend.termEntryHQName $ termEntry,
|
||||
( P.syntaxToColor . prettyHashQualified' . Backend.termEntryHQName $ termEntry,
|
||||
P.lit "(" <> maybe "type missing" (TypePrinter.pretty ppe) (Backend.termEntryType termEntry) <> P.lit ")"
|
||||
)
|
||||
ShallowTypeEntry typeEntry ->
|
||||
( P.syntaxToColor . prettyHashQualified' . fmap Name.fromSegment . Backend.typeEntryHQName $ typeEntry,
|
||||
( P.syntaxToColor . prettyHashQualified' . Backend.typeEntryHQName $ typeEntry,
|
||||
isBuiltin (typeEntryReference typeEntry)
|
||||
)
|
||||
ShallowBranchEntry ns _ (NamespaceStats {numContainedTerms, numContainedTypes}) ->
|
||||
@ -1549,8 +1551,7 @@ notifyUser dir = \case
|
||||
"",
|
||||
P.wrap "Try again with a few more hash characters to disambiguate."
|
||||
]
|
||||
BadName n ->
|
||||
pure . P.wrap $ P.string n <> " is not a kind of name I understand."
|
||||
BadName n -> pure . P.wrap $ P.text n <> " is not a kind of name I understand."
|
||||
TermNotFound' sh ->
|
||||
pure $
|
||||
"I could't find a term with hash "
|
||||
@ -1864,9 +1865,7 @@ notifyUser dir = \case
|
||||
( "Use"
|
||||
<> IP.makeExample IP.mergeLocal [prettySlashProjectBranchName (UnsafeProjectBranchName "somebranch")]
|
||||
<> "or"
|
||||
<> IP.makeExample
|
||||
IP.mergeLocal
|
||||
[prettyAbsolute (Path.Absolute (Path.fromList ["path", "to", "code"]))]
|
||||
<> IP.makeExample IP.mergeLocal [prettyAbsolute (Path.Absolute (Path.fromList ["path", "to", "code"]))]
|
||||
<> "to initialize this branch."
|
||||
)
|
||||
CreatedProjectBranchFrom'OtherBranch (ProjectAndBranch otherProject otherBranch) ->
|
||||
@ -2211,19 +2210,19 @@ notifyUser dir = \case
|
||||
UpgradeFailure path old new ->
|
||||
pure . P.wrap $
|
||||
"I couldn't automatically upgrade"
|
||||
<> P.text (NameSegment.toText old)
|
||||
<> P.text (NameSegment.toEscapedText old)
|
||||
<> "to"
|
||||
<> P.group (P.text (NameSegment.toText new) <> ".")
|
||||
<> P.group (P.text (NameSegment.toEscapedText new) <> ".")
|
||||
<> "However, I've added the definitions that need attention to the top of"
|
||||
<> P.group (prettyFilePath path <> ".")
|
||||
UpgradeSuccess old new ->
|
||||
pure . P.wrap $
|
||||
"I upgraded"
|
||||
<> P.text (NameSegment.toText old)
|
||||
<> P.text (NameSegment.toEscapedText old)
|
||||
<> "to"
|
||||
<> P.group (P.text (NameSegment.toText new) <> ",")
|
||||
<> P.group (P.text (NameSegment.toEscapedText new) <> ",")
|
||||
<> "and removed"
|
||||
<> P.group (P.text (NameSegment.toText old) <> ".")
|
||||
<> P.group (P.text (NameSegment.toEscapedText old) <> ".")
|
||||
where
|
||||
_nameChange _cmd _pastTenseCmd _oldName _newName _r = error "todo"
|
||||
|
||||
@ -2735,7 +2734,7 @@ renderNameConflicts ppe conflictedNames = do
|
||||
P.lines <$> do
|
||||
for (Map.toList conflictedNames) $ \(name, hashes) -> do
|
||||
prettyConflicts <- for hashes \hash -> do
|
||||
n <- addNumberedArg (HQ.toString hash)
|
||||
n <- addNumberedArg (Text.unpack (HQ.toText hash))
|
||||
pure $ formatNum n <> (P.blue . P.syntaxToColor . prettyHashQualified $ hash)
|
||||
pure . P.wrap $
|
||||
( "The "
|
||||
@ -2767,7 +2766,7 @@ renderEditConflicts ppe Patch {..} = do
|
||||
<> (fmap Right . Map.toList . R.toMultimap . R.filterManyDom $ _termEdits)
|
||||
numberedHQName :: HQ.HashQualified Name -> Numbered Pretty
|
||||
numberedHQName hqName = do
|
||||
n <- addNumberedArg (HQ.toString hqName)
|
||||
n <- addNumberedArg (Text.unpack (HQ.toText hqName))
|
||||
pure $ formatNum n <> styleHashQualified P.bold hqName
|
||||
formatTypeEdits ::
|
||||
(Reference, Set TypeEdit.TypeEdit) ->
|
||||
@ -2880,11 +2879,11 @@ todoOutput ppe todo = runNumbered do
|
||||
todoEdits :: Numbered Pretty
|
||||
todoEdits = do
|
||||
numberedTypes <- for (unscore <$> dirtyTypes) \(ref, displayObj) -> do
|
||||
n <- addNumberedArg (HQ.toString $ PPE.typeName ppeu ref)
|
||||
n <- addNumberedArg (Text.unpack (HQ.toText $ PPE.typeName ppeu ref))
|
||||
pure $ formatNum n <> prettyDeclPair ppeu (ref, displayObj)
|
||||
let filteredTerms = goodTerms (unscore <$> dirtyTerms)
|
||||
termNumbers <- for filteredTerms \(ref, _, _) -> do
|
||||
n <- addNumberedArg (HQ.toString $ PPE.termName ppeu ref)
|
||||
n <- addNumberedArg (Text.unpack (HQ.toText $ PPE.termName ppeu ref))
|
||||
pure $ formatNum n
|
||||
let formattedTerms = TypePrinter.prettySignaturesCT ppes filteredTerms
|
||||
numberedTerms = zipWith (<>) termNumbers formattedTerms
|
||||
@ -3300,8 +3299,8 @@ showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput {..} =
|
||||
-- prefixBranchId ".base" "List.map" -> ".base.List.map"
|
||||
prefixBranchId :: Input.AbsBranchId -> Name -> String
|
||||
prefixBranchId branchId name = case branchId of
|
||||
Left sch -> "#" <> SCH.toString sch <> ":" <> Name.toString (Name.makeAbsolute name)
|
||||
Right pathPrefix -> Name.toString (Name.makeAbsolute . Path.prefixName pathPrefix $ name)
|
||||
Left sch -> "#" <> SCH.toString sch <> ":" <> Text.unpack (Name.toText (Name.makeAbsolute name))
|
||||
Right pathPrefix -> Text.unpack (Name.toText (Name.makeAbsolute . Path.prefixName pathPrefix $ name))
|
||||
|
||||
addNumberedArg' :: String -> Numbered Pretty
|
||||
addNumberedArg' s = case sn of
|
||||
@ -3558,7 +3557,7 @@ numberedArgsForEndangerments (PPED.unsuffixifiedPPE -> ppe) m =
|
||||
m
|
||||
& Map.elems
|
||||
& concatMap toList
|
||||
& fmap (HQ.toString . PPE.labeledRefName ppe)
|
||||
& fmap (Text.unpack . HQ.toText . PPE.labeledRefName ppe)
|
||||
|
||||
-- | Format and render all dependents which are endangered by references going extinct.
|
||||
endangeredDependentsTable ::
|
||||
|
@ -10,6 +10,7 @@ import Control.Lens hiding (List, (:<))
|
||||
import Control.Monad.Reader
|
||||
import Data.Aeson qualified as Aeson
|
||||
import Data.Aeson.Types qualified as Aeson
|
||||
import Data.Foldable qualified as Foldable
|
||||
import Data.List.Extra (nubOrdOn)
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import Data.Map qualified as Map
|
||||
@ -18,6 +19,7 @@ import Data.Text qualified as Text
|
||||
import Language.LSP.Protocol.Lens
|
||||
import Language.LSP.Protocol.Message qualified as Msg
|
||||
import Language.LSP.Protocol.Types
|
||||
import Text.Megaparsec qualified as Megaparsec
|
||||
import Unison.Codebase.Path (Path)
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.HashQualified qualified as HQ
|
||||
@ -41,7 +43,7 @@ import Unison.Referent qualified as Referent
|
||||
import Unison.Runtime.IOSource qualified as IOSource
|
||||
import Unison.Syntax.DeclPrinter qualified as DeclPrinter
|
||||
import Unison.Syntax.HashQualified' qualified as HQ' (toText)
|
||||
import Unison.Syntax.Name qualified as Name (fromText, toText)
|
||||
import Unison.Syntax.Name qualified as Name (parseText, nameP, toText)
|
||||
import Unison.Syntax.TypePrinter qualified as TypePrinter
|
||||
import Unison.Util.Monoid qualified as Monoid
|
||||
import Unison.Util.Pretty qualified as Pretty
|
||||
@ -190,7 +192,7 @@ namesToCompletionTree Names {terms, types} =
|
||||
-- Special docs like "README" will still appear since they're not named 'doc'
|
||||
isDefinitionDoc name =
|
||||
case Name.reverseSegments name of
|
||||
("doc" :| _) -> True
|
||||
((NameSegment.toUnescapedText -> "doc") :| _) -> True
|
||||
_ -> False
|
||||
|
||||
nameToCompletionTree :: Name -> LabeledDependency -> CompletionTree
|
||||
@ -228,27 +230,25 @@ nameToCompletionTree name ref =
|
||||
-- @@
|
||||
matchCompletions :: CompletionTree -> Text -> [(Path, Name, LabeledDependency)]
|
||||
matchCompletions (CompletionTree tree) txt =
|
||||
matchSegments segments (Set.toList <$> tree)
|
||||
case Megaparsec.runParser (Name.nameP <* Megaparsec.eof) "" (Text.unpack txt) of
|
||||
Left _ -> []
|
||||
Right name -> matchSegments (Foldable.toList @NonEmpty (Name.segments name)) (Set.toList <$> tree)
|
||||
where
|
||||
segments :: [Text]
|
||||
segments =
|
||||
Text.splitOn "." txt
|
||||
& filter (not . Text.null)
|
||||
matchSegments :: [Text] -> Cofree (Map NameSegment) [(Name, LabeledDependency)] -> [(Path, Name, LabeledDependency)]
|
||||
matchSegments :: [NameSegment] -> Cofree (Map NameSegment) [(Name, LabeledDependency)] -> [(Path, Name, LabeledDependency)]
|
||||
matchSegments xs (currentMatches :< subtreeMap) =
|
||||
case xs of
|
||||
[] ->
|
||||
let current = currentMatches <&> (\(name, def) -> (Path.empty, name, def))
|
||||
in (current <> mkDefMatches subtreeMap)
|
||||
[prefix] ->
|
||||
Map.dropWhileAntitone ((< prefix) . NameSegment.toText) subtreeMap
|
||||
& Map.takeWhileAntitone (Text.isPrefixOf prefix . NameSegment.toText)
|
||||
Map.dropWhileAntitone (< prefix) subtreeMap
|
||||
& Map.takeWhileAntitone (NameSegment.isPrefixOf prefix)
|
||||
& \matchingSubtrees ->
|
||||
let subMatches = ifoldMap (\ns subTree -> matchSegments [] subTree & consPathPrefix ns) matchingSubtrees
|
||||
in subMatches
|
||||
(ns : rest) ->
|
||||
foldMap (matchSegments rest) (Map.lookup (NameSegment ns) subtreeMap)
|
||||
& consPathPrefix (NameSegment ns)
|
||||
foldMap (matchSegments rest) (Map.lookup ns subtreeMap)
|
||||
& consPathPrefix ns
|
||||
consPathPrefix :: NameSegment -> ([(Path, Name, LabeledDependency)]) -> [(Path, Name, LabeledDependency)]
|
||||
consPathPrefix ns = over (mapped . _1) (Path.cons ns)
|
||||
mkDefMatches :: Map NameSegment (Cofree (Map NameSegment) [(Name, LabeledDependency)]) -> [(Path, Name, LabeledDependency)]
|
||||
@ -340,8 +340,8 @@ instance Aeson.ToJSON CompletionItemDetails where
|
||||
instance Aeson.FromJSON CompletionItemDetails where
|
||||
parseJSON = Aeson.withObject "CompletionItemDetails" \obj -> do
|
||||
dep <- ((obj Aeson..: "dep") >>= ldParser)
|
||||
relativeName <- (obj Aeson..: "relativeName" >>= maybe (fail "Invalid name in CompletionItemDetails") pure . Name.fromText)
|
||||
fullyQualifiedName <- (obj Aeson..: "fullyQualifiedName" >>= maybe (fail "Invalid name in CompletionItemDetails") pure . Name.fromText)
|
||||
relativeName <- (obj Aeson..: "relativeName" >>= maybe (fail "Invalid name in CompletionItemDetails") pure . Name.parseText)
|
||||
fullyQualifiedName <- (obj Aeson..: "fullyQualifiedName" >>= maybe (fail "Invalid name in CompletionItemDetails") pure . Name.parseText)
|
||||
fileUri <- obj Aeson..: "fileUri"
|
||||
pure $ CompletionItemDetails {..}
|
||||
where
|
||||
|
@ -458,7 +458,7 @@ mkTypeSignatureHints parsedFile typecheckedFile = do
|
||||
& Zip.zip symbolsWithoutTypeSigs
|
||||
& imapMaybe
|
||||
( \v (ann, (_ann, ref, _wk, _trm, typ)) -> do
|
||||
name <- Name.fromText (Var.name v)
|
||||
name <- Name.parseText (Var.name v)
|
||||
range <- annToRange ann
|
||||
let newRangeEnd =
|
||||
range ^. LSPTypes.start
|
||||
|
@ -94,7 +94,7 @@ hoverInfo uri pos =
|
||||
LD.TypeReference (Reference.Builtin {}) -> do
|
||||
pure (symAtCursor <> " : <builtin>")
|
||||
LD.TypeReference ref@(Reference.DerivedId refId) -> do
|
||||
nameAtCursor <- MaybeT . pure $ Name.fromText symAtCursor
|
||||
nameAtCursor <- MaybeT . pure $ Name.parseText symAtCursor
|
||||
decl <- LSPQ.getTypeDeclaration uri refId
|
||||
let typ = Text.pack . Pretty.toPlain prettyWidth . Pretty.syntaxToColor $ DeclPrinter.prettyDecl pped ref (HQ.NameOnly nameAtCursor) decl
|
||||
pure typ
|
||||
|
@ -1,18 +1,13 @@
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
-- | This module handles parsing CLI arguments into 'Command's.
|
||||
-- See the excellent documentation at https://hackage.haskell.org/package/optparse-applicative
|
||||
module ArgParse where
|
||||
|
||||
import Control.Applicative (Alternative (many, (<|>)), Applicative (liftA2), optional)
|
||||
import Data.Foldable (Foldable (fold))
|
||||
import Data.Functor ((<&>))
|
||||
import Data.List qualified as List
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.List.NonEmpty qualified as NE
|
||||
import Data.Text qualified as Text
|
||||
import Options.Applicative
|
||||
( CommandFields,
|
||||
Mod,
|
||||
@ -55,18 +50,18 @@ import Options.Applicative.Help (bold, (<+>))
|
||||
import Options.Applicative.Help.Pretty qualified as P
|
||||
import Stats
|
||||
import System.Environment (lookupEnv)
|
||||
import Text.Read (readMaybe)
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.Path.Parse qualified as Path
|
||||
import Unison.CommandLine.Types (ShouldWatchFiles (..))
|
||||
import Unison.LSP (LspFormattingConfig (..))
|
||||
import Unison.Prelude
|
||||
import Unison.PrettyTerminal qualified as PT
|
||||
import Unison.Server.CodebaseServer (CodebaseServerOpts (..))
|
||||
import Unison.Server.CodebaseServer qualified as Server
|
||||
import Unison.Util.Pretty (Width (..))
|
||||
|
||||
-- The name of a symbol to execute.
|
||||
type SymbolName = String
|
||||
type SymbolName = Text
|
||||
|
||||
-- | Valid ways to provide source code to the run command
|
||||
data RunSource
|
||||
@ -455,7 +450,7 @@ readPath' :: ReadM Path.Path'
|
||||
readPath' = do
|
||||
strPath <- OptParse.str
|
||||
case Path.parsePath' strPath of
|
||||
Left err -> OptParse.readerError err
|
||||
Left err -> OptParse.readerError (Text.unpack err)
|
||||
Right path' -> pure path'
|
||||
|
||||
fileArgument :: String -> Parser FilePath
|
||||
|
@ -1,6 +1,5 @@
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
@ -70,7 +69,6 @@ import Unison.CommandLine.Types qualified as CommandLine
|
||||
import Unison.CommandLine.Welcome (CodebaseInitStatus (..))
|
||||
import Unison.CommandLine.Welcome qualified as Welcome
|
||||
import Unison.LSP qualified as LSP
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Parser.Ann (Ann)
|
||||
import Unison.Prelude
|
||||
import Unison.PrettyTerminal qualified as PT
|
||||
@ -278,7 +276,7 @@ main = do
|
||||
Just startingPath -> pure startingPath
|
||||
Nothing -> do
|
||||
segments <- Codebase.runTransaction theCodebase Queries.expectMostRecentNamespace
|
||||
pure (Path.Absolute (Path.fromList (map NameSegment.NameSegment segments)))
|
||||
pure (Path.Absolute (Path.fromList segments))
|
||||
Headless -> pure $ fromMaybe defaultInitialPath mayStartingPath
|
||||
rootCausalHash <- Codebase.runTransaction theCodebase (Queries.expectNamespaceRoot >>= Queries.expectCausalHash)
|
||||
rootCausalHashVar <- newTVarIO rootCausalHash
|
||||
|
@ -39,6 +39,8 @@ where
|
||||
|
||||
import Control.Lens (Iso', Lens', imap, iso, lens, over, _3)
|
||||
import Control.Monad.State (evalState)
|
||||
import Data.List.NonEmpty (pattern (:|))
|
||||
import Data.List.NonEmpty qualified as List (NonEmpty)
|
||||
import Data.Map qualified as Map
|
||||
import Data.Set qualified as Set
|
||||
import Unison.ABT qualified as ABT
|
||||
@ -147,19 +149,20 @@ withEffectDeclM f = fmap EffectDeclaration . f . toDataDecl
|
||||
-- propose to move this code to some very feature-specific module —AI
|
||||
generateRecordAccessors ::
|
||||
(Semigroup a, Var v) =>
|
||||
(List.NonEmpty v -> v) ->
|
||||
(a -> a) ->
|
||||
[(v, a)] ->
|
||||
v ->
|
||||
Reference ->
|
||||
[(v, a, Term v a)]
|
||||
generateRecordAccessors generatedAnn fields typename typ =
|
||||
generateRecordAccessors namespaced generatedAnn fields typename typ =
|
||||
join [tm t i | (t, i) <- fields `zip` [(0 :: Int) ..]]
|
||||
where
|
||||
argname = Var.uncapitalize typename
|
||||
tm (fname, fieldAnn) i =
|
||||
[ (Var.namespaced [typename, fname], ann, get),
|
||||
(Var.namespaced [typename, fname, Var.named "set"], ann, set),
|
||||
(Var.namespaced [typename, fname, Var.named "modify"], ann, modify)
|
||||
[ (namespaced (typename :| [fname]), ann, get),
|
||||
(namespaced (typename :| [fname, Var.named "set"]), ann, set),
|
||||
(namespaced (typename :| [fname, Var.named "modify"]), ann, modify)
|
||||
]
|
||||
where
|
||||
ann = generatedAnn fieldAnn
|
||||
|
@ -37,7 +37,6 @@ module Unison.Name
|
||||
|
||||
-- * To organize later
|
||||
commonPrefix,
|
||||
libSegment,
|
||||
preferShallowLibDepth,
|
||||
searchByRankedSuffix,
|
||||
searchBySuffix,
|
||||
@ -67,7 +66,7 @@ import Data.Monoid (Sum (..))
|
||||
import Data.RFC5051 qualified as RFC5051
|
||||
import Data.Set qualified as Set
|
||||
import Unison.Name.Internal
|
||||
import Unison.NameSegment (NameSegment (NameSegment))
|
||||
import Unison.NameSegment (NameSegment (..))
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Position (Position (..))
|
||||
import Unison.Prelude
|
||||
@ -361,16 +360,13 @@ preferShallowLibDepth = \case
|
||||
[x] -> Set.singleton (snd x)
|
||||
rs ->
|
||||
let byDepth = List.multimap (map (first minLibs) rs)
|
||||
libCount = length . filter (== libSegment) . toList . reverseSegments
|
||||
libCount = length . filter (== NameSegment.libSegment) . toList . reverseSegments
|
||||
minLibs [] = 0
|
||||
minLibs ns = minimum (map libCount ns)
|
||||
in case Map.lookup 0 byDepth <|> Map.lookup 1 byDepth of
|
||||
Nothing -> Set.fromList (map snd rs)
|
||||
Just rs -> Set.fromList rs
|
||||
|
||||
libSegment :: NameSegment
|
||||
libSegment = NameSegment "lib"
|
||||
|
||||
sortByText :: (a -> Text) -> [a] -> [a]
|
||||
sortByText by as =
|
||||
let as' = [(a, by a) | a <- as]
|
||||
@ -574,10 +570,5 @@ class Convert a b where
|
||||
class Parse a b where
|
||||
parse :: a -> Maybe b
|
||||
|
||||
instance Parse Text NameSegment where
|
||||
parse txt = case NameSegment.segments' txt of
|
||||
[n] -> Just (NameSegment.NameSegment n)
|
||||
_ -> Nothing
|
||||
|
||||
instance (Parse a a2, Parse b b2) => Parse (a, b) (a2, b2) where
|
||||
parse (a, b) = (,) <$> parse a <*> parse b
|
||||
|
@ -1,3 +1,6 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
-- | The private Unison.Name innards. Prefer importing Unison.Name instead, unless you need the data constructor of
|
||||
-- Name.
|
||||
module Unison.Name.Internal
|
||||
@ -11,6 +14,8 @@ import Control.Lens as Lens
|
||||
import Data.List.NonEmpty (pattern (:|))
|
||||
import Data.List.NonEmpty qualified as List (NonEmpty)
|
||||
import Data.List.NonEmpty qualified as List.NonEmpty
|
||||
import GHC.TypeLits (TypeError)
|
||||
import GHC.TypeLits qualified as TypeError (ErrorMessage (Text))
|
||||
import Unison.NameSegment (NameSegment)
|
||||
import Unison.Position (Position (..))
|
||||
import Unison.Prelude
|
||||
@ -42,6 +47,15 @@ instance Alphabetical Name where
|
||||
(False, True) -> GT
|
||||
_ -> compareAlphabetical (segments n1) (segments n2)
|
||||
|
||||
instance
|
||||
TypeError
|
||||
( 'TypeError.Text
|
||||
"You cannot make a Name from a string literal because there may (some day) be more than one syntax"
|
||||
) =>
|
||||
IsString Name
|
||||
where
|
||||
fromString = undefined
|
||||
|
||||
instance Ord Name where
|
||||
compare (Name p0 ss0) (Name p1 ss1) =
|
||||
compare ss0 ss1 <> compare p0 p1
|
||||
|
@ -16,13 +16,11 @@ module Unison.Var
|
||||
inferTypeConstructor,
|
||||
inferTypeConstructorArg,
|
||||
isAction,
|
||||
joinDot,
|
||||
missingResult,
|
||||
name,
|
||||
nameStr,
|
||||
named,
|
||||
nameds,
|
||||
namespaced,
|
||||
rawName,
|
||||
reset,
|
||||
uncapitalize,
|
||||
@ -32,14 +30,12 @@ module Unison.Var
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Char (isLower, toLower)
|
||||
import Data.Char (isAlphaNum, isLower, toLower)
|
||||
import Data.Text (pack)
|
||||
import Data.Text qualified as Text
|
||||
import Unison.ABT qualified as ABT
|
||||
import Unison.NameSegment qualified as Name
|
||||
import Unison.Prelude
|
||||
import Unison.Reference qualified as Reference
|
||||
import Unison.Util.Monoid (intercalateMap)
|
||||
import Unison.WatchKind (WatchKind, pattern TestWatch)
|
||||
|
||||
-- | A class for variables. Variables may have auxiliary information which
|
||||
@ -195,31 +191,14 @@ data InferenceType
|
||||
reset :: (Var v) => v -> v
|
||||
reset v = typed (typeOf v)
|
||||
|
||||
unqualifiedName :: (Var v) => v -> Text
|
||||
unqualifiedName = fromMaybe "" . lastMay . Name.segments' . name
|
||||
|
||||
unqualified :: (Var v) => v -> v
|
||||
unqualified v = case typeOf v of
|
||||
User _ -> named . unqualifiedName $ v
|
||||
_ -> v
|
||||
|
||||
namespaced :: (Var v) => [v] -> v
|
||||
namespaced vs = named $ intercalateMap "." name vs
|
||||
|
||||
nameStr :: (Var v) => v -> String
|
||||
nameStr = Text.unpack . name
|
||||
|
||||
nameds :: (Var v) => String -> v
|
||||
nameds s = named (Text.pack s)
|
||||
|
||||
joinDot :: (Var v) => v -> v -> v
|
||||
joinDot prefix v2 =
|
||||
if name prefix == "."
|
||||
then named (name prefix `mappend` name v2)
|
||||
else named (name prefix `mappend` "." `mappend` name v2)
|
||||
|
||||
universallyQuantifyIfFree :: forall v. (Var v) => v -> Bool
|
||||
universallyQuantifyIfFree v =
|
||||
ok (name $ reset v) && unqualified v == v
|
||||
Text.all isLower (Text.take 1 n) && Text.all isAlphaNum n
|
||||
where
|
||||
ok n = (all isLower . take 1 . Text.unpack) n
|
||||
n = name $ reset v
|
||||
|
@ -168,8 +168,9 @@ import Unison.Sqlite qualified as Sqlite
|
||||
import Unison.Symbol (Symbol)
|
||||
import Unison.Syntax.DeclPrinter qualified as DeclPrinter
|
||||
import Unison.Syntax.HashQualified' qualified as HQ' (toText)
|
||||
import Unison.Syntax.Name as Name (toText, unsafeFromText)
|
||||
import Unison.Syntax.Name as Name (toText, unsafeParseText)
|
||||
import Unison.Syntax.NamePrinter qualified as NP
|
||||
import Unison.Syntax.NameSegment qualified as NameSegment (toEscapedText)
|
||||
import Unison.Syntax.TermPrinter qualified as TermPrinter
|
||||
import Unison.Syntax.TypePrinter qualified as TypePrinter
|
||||
import Unison.Term (Term)
|
||||
@ -204,8 +205,8 @@ listEntryName :: ShallowListEntry v a -> Text
|
||||
listEntryName = \case
|
||||
ShallowTermEntry te -> termEntryDisplayName te
|
||||
ShallowTypeEntry te -> typeEntryDisplayName te
|
||||
ShallowBranchEntry n _ _ -> NameSegment.toText n
|
||||
ShallowPatchEntry n -> NameSegment.toText n
|
||||
ShallowBranchEntry n _ _ -> NameSegment.toEscapedText n
|
||||
ShallowPatchEntry n -> NameSegment.toEscapedText n
|
||||
|
||||
data BackendError
|
||||
= NoSuchNamespace Path.Absolute
|
||||
@ -268,7 +269,7 @@ loadReferentType codebase = \case
|
||||
data TermEntry v a = TermEntry
|
||||
{ termEntryReferent :: V2Referent.Referent,
|
||||
termEntryHash :: ShortHash,
|
||||
termEntryName :: NameSegment,
|
||||
termEntryName :: Name,
|
||||
termEntryConflicted :: Bool,
|
||||
termEntryType :: Maybe (Type v a),
|
||||
termEntryTag :: TermTag
|
||||
@ -287,9 +288,9 @@ termEntryLabeledDependencies TermEntry {termEntryType, termEntryReferent, termEn
|
||||
_ -> error "termEntryLabeledDependencies: not a constructor, but one was required"
|
||||
|
||||
termEntryDisplayName :: TermEntry v a -> Text
|
||||
termEntryDisplayName = HQ'.toTextWith NameSegment.toText . termEntryHQName
|
||||
termEntryDisplayName = HQ'.toTextWith Name.toText . termEntryHQName
|
||||
|
||||
termEntryHQName :: TermEntry v a -> HQ'.HashQualified NameSegment
|
||||
termEntryHQName :: TermEntry v a -> HQ'.HashQualified Name
|
||||
termEntryHQName TermEntry {termEntryName, termEntryConflicted, termEntryHash} =
|
||||
if termEntryConflicted
|
||||
then HQ'.HashQualified termEntryName termEntryHash
|
||||
@ -298,7 +299,7 @@ termEntryHQName TermEntry {termEntryName, termEntryConflicted, termEntryHash} =
|
||||
data TypeEntry = TypeEntry
|
||||
{ typeEntryReference :: Reference,
|
||||
typeEntryHash :: ShortHash,
|
||||
typeEntryName :: NameSegment,
|
||||
typeEntryName :: Name,
|
||||
typeEntryConflicted :: Bool,
|
||||
typeEntryTag :: TypeTag
|
||||
}
|
||||
@ -309,9 +310,9 @@ typeEntryLabeledDependencies TypeEntry {typeEntryReference} =
|
||||
Set.singleton (LD.TypeReference typeEntryReference)
|
||||
|
||||
typeEntryDisplayName :: TypeEntry -> Text
|
||||
typeEntryDisplayName = HQ'.toTextWith NameSegment.toText . typeEntryHQName
|
||||
typeEntryDisplayName = HQ'.toTextWith Name.toText . typeEntryHQName
|
||||
|
||||
typeEntryHQName :: TypeEntry -> HQ'.HashQualified NameSegment
|
||||
typeEntryHQName :: TypeEntry -> HQ'.HashQualified Name
|
||||
typeEntryHQName TypeEntry {typeEntryName, typeEntryConflicted, typeEntryReference} =
|
||||
if typeEntryConflicted
|
||||
then HQ'.HashQualified typeEntryName (Reference.toShortHash typeEntryReference)
|
||||
@ -348,7 +349,7 @@ fuzzyFind printNames query =
|
||||
|
||||
-- Prefer shorter FQNs
|
||||
rank (alignment, name, _) =
|
||||
( Name.countSegments (Name.unsafeFromText name),
|
||||
( Name.countSegments (Name.unsafeParseText name),
|
||||
negate (FZF.score alignment)
|
||||
)
|
||||
|
||||
@ -421,12 +422,9 @@ resultListType = Type.app mempty (Type.list mempty) (Type.ref mempty Decls.testR
|
||||
termListEntry ::
|
||||
(MonadIO m) =>
|
||||
Codebase m Symbol Ann ->
|
||||
-- | Optional branch to check if the term is conflicted.
|
||||
-- If omitted, all terms are just listed as not conflicted.
|
||||
Maybe (V2Branch.Branch n) ->
|
||||
ExactName NameSegment V2Referent.Referent ->
|
||||
ExactName Name V2Referent.Referent ->
|
||||
m (TermEntry Symbol Ann)
|
||||
termListEntry codebase mayBranch (ExactName nameSegment ref) = do
|
||||
termListEntry codebase (ExactName name ref) = do
|
||||
ot <- Codebase.runTransaction codebase $ do
|
||||
v1Referent <- Cv.referent2to1 (Codebase.getDeclType codebase) ref
|
||||
ot <- loadReferentType codebase v1Referent
|
||||
@ -435,21 +433,13 @@ termListEntry codebase mayBranch (ExactName nameSegment ref) = do
|
||||
pure $
|
||||
TermEntry
|
||||
{ termEntryReferent = ref,
|
||||
termEntryName = nameSegment,
|
||||
termEntryName = name,
|
||||
termEntryType = ot,
|
||||
termEntryTag = tag,
|
||||
termEntryConflicted = isConflicted,
|
||||
-- See typeEntryConflicted
|
||||
termEntryConflicted = False,
|
||||
termEntryHash = Cv.referent2toshorthash1 Nothing ref
|
||||
}
|
||||
where
|
||||
isConflicted = case mayBranch of
|
||||
Nothing -> False
|
||||
Just branch ->
|
||||
branch
|
||||
& V2Branch.terms
|
||||
& Map.lookup nameSegment
|
||||
& maybe 0 Map.size
|
||||
& (> 1)
|
||||
|
||||
getTermTag ::
|
||||
(Var v, MonadIO m) =>
|
||||
@ -493,31 +483,21 @@ getTypeTag codebase r = do
|
||||
typeListEntry ::
|
||||
(Var v) =>
|
||||
Codebase m v Ann ->
|
||||
-- | Optional branch to check if the term is conflicted.
|
||||
-- If omitted, all terms are just listed as not conflicted.
|
||||
Maybe (V2Branch.Branch n) ->
|
||||
ExactName NameSegment Reference ->
|
||||
ExactName Name Reference ->
|
||||
Sqlite.Transaction TypeEntry
|
||||
typeListEntry codebase mayBranch (ExactName nameSegment ref) = do
|
||||
typeListEntry codebase (ExactName name ref) = do
|
||||
hashLength <- Codebase.hashLength
|
||||
tag <- getTypeTag codebase ref
|
||||
pure $
|
||||
TypeEntry
|
||||
{ typeEntryReference = ref,
|
||||
typeEntryName = nameSegment,
|
||||
typeEntryConflicted = isConflicted,
|
||||
typeEntryName = name,
|
||||
-- Mitchell says: at one point this was implemented incorrectly, but fixing it seemed like more trouble than it
|
||||
-- was worth, because we don't really care about conflicted things anymore. Ditto for termEntryConflicted.
|
||||
typeEntryConflicted = False,
|
||||
typeEntryTag = tag,
|
||||
typeEntryHash = SH.shortenTo hashLength $ Reference.toShortHash ref
|
||||
}
|
||||
where
|
||||
isConflicted = case mayBranch of
|
||||
Nothing -> False
|
||||
Just branch ->
|
||||
branch
|
||||
& V2Branch.types
|
||||
& Map.lookup nameSegment
|
||||
& maybe 0 Map.size
|
||||
& (> 1)
|
||||
|
||||
typeDeclHeader ::
|
||||
forall v m.
|
||||
@ -579,13 +559,13 @@ lsBranch codebase b0 = do
|
||||
(ns, refs) <- Map.toList m
|
||||
r <- Map.keys refs
|
||||
pure (r, ns)
|
||||
termEntries <- for (flattenRefs $ V2Branch.terms b0) $ \(r, ns) -> do
|
||||
ShallowTermEntry <$> termListEntry codebase (Just b0) (ExactName ns r)
|
||||
termEntries <- for (flattenRefs $ V2Branch.terms b0) \(r, ns) -> do
|
||||
ShallowTermEntry <$> termListEntry codebase (ExactName (Name.fromSegment ns) r)
|
||||
typeEntries <-
|
||||
Codebase.runTransaction codebase do
|
||||
for (flattenRefs $ V2Branch.types b0) \(r, ns) -> do
|
||||
let v1Ref = Cv.reference2to1 r
|
||||
ShallowTypeEntry <$> typeListEntry codebase (Just b0) (ExactName ns v1Ref)
|
||||
ShallowTypeEntry <$> typeListEntry codebase (ExactName (Name.fromSegment ns) v1Ref)
|
||||
childrenWithStats <- Codebase.runTransaction codebase (V2Branch.childStats b0)
|
||||
let branchEntries :: [ShallowListEntry Symbol Ann] = do
|
||||
(ns, (h, stats)) <- Map.toList $ childrenWithStats
|
||||
@ -748,8 +728,6 @@ mkTypeDefinition ::
|
||||
MonadIO m =>
|
||||
Codebase IO Symbol Ann ->
|
||||
PPED.PrettyPrintEnvDecl ->
|
||||
Path.Path ->
|
||||
V2Branch.CausalBranch Sqlite.Transaction ->
|
||||
Width ->
|
||||
Reference ->
|
||||
[(HashQualifiedName, UnisonHash, Doc.Doc)] ->
|
||||
@ -757,13 +735,11 @@ mkTypeDefinition ::
|
||||
(AnnotatedText (UST.Element Reference))
|
||||
(AnnotatedText (UST.Element Reference)) ->
|
||||
m TypeDefinition
|
||||
mkTypeDefinition codebase pped namesRoot rootCausal width r docs tp = do
|
||||
mkTypeDefinition codebase pped width r docs tp = do
|
||||
let bn = bestNameForType @Symbol (PPED.suffixifiedPPE pped) width r
|
||||
tag <-
|
||||
liftIO $ Codebase.runTransaction codebase do
|
||||
causalAtPath <- Codebase.getShallowCausalAtPath namesRoot (Just rootCausal)
|
||||
branchAtPath <- V2Causal.value causalAtPath
|
||||
typeEntryTag <$> typeListEntry codebase (Just branchAtPath) (ExactName (NameSegment bn) r)
|
||||
typeEntryTag <$> typeListEntry codebase (ExactName (Name.unsafeParseText bn) r)
|
||||
pure $
|
||||
TypeDefinition
|
||||
(HQ'.toText <$> PPE.allTypeNames fqnPPE r)
|
||||
@ -777,8 +753,6 @@ mkTypeDefinition codebase pped namesRoot rootCausal width r docs tp = do
|
||||
mkTermDefinition ::
|
||||
Codebase IO Symbol Ann ->
|
||||
PPED.PrettyPrintEnvDecl ->
|
||||
Path.Path ->
|
||||
V2Branch.CausalBranch Sqlite.Transaction ->
|
||||
Width ->
|
||||
Reference ->
|
||||
[(HashQualifiedName, UnisonHash, Doc.Doc)] ->
|
||||
@ -786,19 +760,11 @@ mkTermDefinition ::
|
||||
(AnnotatedText (UST.Element Reference))
|
||||
(AnnotatedText (UST.Element Reference)) ->
|
||||
Backend IO TermDefinition
|
||||
mkTermDefinition codebase termPPED namesRoot rootCausal width r docs tm = do
|
||||
mkTermDefinition codebase termPPED width r docs tm = do
|
||||
let referent = Referent.Ref r
|
||||
(ts, branchAtPath) <- liftIO $ Codebase.runTransaction codebase do
|
||||
ts <- Codebase.getTypeOfTerm codebase r
|
||||
causalAtPath <- Codebase.getShallowCausalAtPath namesRoot (Just rootCausal)
|
||||
branchAtPath <- V2Causal.value causalAtPath
|
||||
pure (ts, branchAtPath)
|
||||
ts <- liftIO (Codebase.runTransaction codebase (Codebase.getTypeOfTerm codebase r))
|
||||
let bn = bestNameForTerm @Symbol (PPED.suffixifiedPPE termPPED) width (Referent.Ref r)
|
||||
tag <-
|
||||
lift
|
||||
( termEntryTag
|
||||
<$> termListEntry codebase (Just branchAtPath) (ExactName (NameSegment bn) (Cv.referent1to2 referent))
|
||||
)
|
||||
tag <- lift (termEntryTag <$> termListEntry codebase (ExactName (Name.unsafeParseText bn) (Cv.referent1to2 referent)))
|
||||
mk ts bn tag
|
||||
where
|
||||
fqnTermPPE = PPED.unsuffixifiedPPE termPPED
|
||||
@ -918,7 +884,7 @@ docsInBranchToHtmlFiles ::
|
||||
docsInBranchToHtmlFiles runtime codebase currentBranch directory = do
|
||||
let allTerms = (R.toList . Branch.deepTerms . Branch.head) currentBranch
|
||||
-- ignores docs inside lib namespace, recursively
|
||||
let notLib (_, name) = "lib" `notElem` Name.segments name
|
||||
let notLib (_, name) = NameSegment.libSegment `notElem` Name.segments name
|
||||
(docTermsWithNames, hqLength) <-
|
||||
Codebase.runTransaction codebase do
|
||||
docTermsWithNames <- filterM (isDoc codebase . fst) (filter notLib allTerms)
|
||||
@ -948,7 +914,7 @@ docsInBranchToHtmlFiles runtime codebase currentBranch directory = do
|
||||
docFilePath :: FilePath -> Name -> FilePath
|
||||
docFilePath destination docFQN =
|
||||
let (dir, fileName) =
|
||||
case unsnoc . map NameSegment.toString . toList . Name.segments $ docFQN of
|
||||
case unsnoc . map (Text.unpack . NameSegment.toUnescapedText) . toList . Name.segments $ docFQN of
|
||||
Just (path, leafName) ->
|
||||
(directoryPath path, docFileName leafName)
|
||||
Nothing ->
|
||||
|
@ -1,5 +1,4 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
@ -91,7 +90,6 @@ import Unison.Codebase.Runtime qualified as Rt
|
||||
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
|
||||
import Unison.HashQualified
|
||||
import Unison.Name as Name (Name, segments)
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Parser.Ann (Ann)
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
|
||||
@ -111,6 +109,7 @@ import Unison.Server.Local.Endpoints.UCM (UCMAPI, ucmServer)
|
||||
import Unison.Server.Types (mungeString, setCacheControl)
|
||||
import Unison.ShortHash qualified as ShortHash
|
||||
import Unison.Symbol (Symbol)
|
||||
import Unison.Syntax.NameSegment qualified as NameSegment
|
||||
|
||||
-- HTML content type
|
||||
data HTML = HTML
|
||||
@ -256,7 +255,7 @@ urlFor service baseUrl =
|
||||
namespacePath path =
|
||||
if path == Path.empty
|
||||
then []
|
||||
else [DontEscape "namespaces"] <> (EscapeMe . NameSegment.toText <$> Path.toList path)
|
||||
else [DontEscape "namespaces"] <> (EscapeMe . NameSegment.toEscapedText <$> Path.toList path)
|
||||
|
||||
definitionPath :: Maybe DefinitionReference -> Maybe [URISegment]
|
||||
definitionPath def =
|
||||
@ -274,11 +273,11 @@ urlFor service baseUrl =
|
||||
refToUrlText r =
|
||||
case r of
|
||||
NameOnly n ->
|
||||
n & Name.segments & fmap (EscapeMe . NameSegment.toText) & toList
|
||||
n & Name.segments & fmap (EscapeMe . NameSegment.toEscapedText) & toList
|
||||
HashOnly h ->
|
||||
[EscapeMe $ ShortHash.toText h]
|
||||
HashQualified n _ ->
|
||||
n & Name.segments & fmap (EscapeMe . NameSegment.toText) & toList
|
||||
n & Name.segments & fmap (EscapeMe . NameSegment.toEscapedText) & toList
|
||||
|
||||
toDefinitionPath :: DefinitionReference -> [URISegment]
|
||||
toDefinitionPath d =
|
||||
|
@ -28,7 +28,7 @@ import Unison.Server.Types
|
||||
mungeString,
|
||||
)
|
||||
import Unison.ShortHash qualified as SH
|
||||
import Unison.Syntax.HashQualified qualified as HQ (toString)
|
||||
import Unison.Syntax.HashQualified qualified as HQ (toText)
|
||||
|
||||
badHQN :: HashQualifiedName -> ServerError
|
||||
badHQN hqn =
|
||||
@ -108,7 +108,7 @@ noSuchDefinition :: HQ.HashQualified Name -> ServerError
|
||||
noSuchDefinition hqName =
|
||||
err404
|
||||
{ errBody =
|
||||
"Couldn't find a definition for " <> BSC.pack (HQ.toString hqName)
|
||||
"Couldn't find a definition for " <> LazyByteString.fromStrict (Text.encodeUtf8 (HQ.toText hqName))
|
||||
}
|
||||
|
||||
ambiguousHashForDefinition :: SH.ShortHash -> ServerError
|
||||
|
@ -13,7 +13,9 @@ import U.Codebase.Causal qualified as Causal
|
||||
import Unison.Codebase.Path
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.HashQualified qualified as HQ
|
||||
import Unison.Name (Name, libSegment)
|
||||
import Unison.Name (Name)
|
||||
import Unison.NameSegment (libSegment)
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Prelude
|
||||
import Unison.Server.Backend
|
||||
import Unison.Sqlite qualified as Sqlite
|
||||
@ -59,7 +61,13 @@ inferNamesRoot p b
|
||||
| otherwise = getLast <$> execWriterT (runReaderT (go p b) Path.empty)
|
||||
where
|
||||
findBaseProject :: Path -> Maybe Path
|
||||
findBaseProject ("public" Cons.:< "base" Cons.:< release Cons.:< _rest) = Just (Path.fromList ["public", "base", release])
|
||||
findBaseProject
|
||||
( (NameSegment.toUnescapedText -> "public")
|
||||
Cons.:< (NameSegment.toUnescapedText -> "base")
|
||||
Cons.:< release
|
||||
Cons.:< _rest
|
||||
) =
|
||||
Just (Path.fromList ["public", "base", release])
|
||||
findBaseProject _ = Nothing
|
||||
go :: Path -> Branch Sqlite.Transaction -> ReaderT Path (WriterT (Last Path) Sqlite.Transaction) ()
|
||||
go p b = do
|
||||
|
@ -80,13 +80,13 @@ prettyDefinitionsForHQName perspective shallowRoot renderWidth suffixifyBindings
|
||||
ifor (typesToSyntax suffixifyBindings width pped types) \ref tp -> do
|
||||
let hqTypeName = PPE.typeNameOrHashOnly fqnPPE ref
|
||||
docs <- liftIO $ (maybe (pure []) docResults (HQ.toName hqTypeName))
|
||||
mkTypeDefinition codebase pped namesRoot shallowRoot width ref docs tp
|
||||
mkTypeDefinition codebase pped width ref docs tp
|
||||
termDefinitions <-
|
||||
ifor (termsToSyntax suffixifyBindings width pped terms) \reference trm -> do
|
||||
let referent = Referent.Ref reference
|
||||
let hqTermName = PPE.termNameOrHashOnly fqnPPE referent
|
||||
docs <- liftIO $ (maybe (pure []) docResults (HQ.toName hqTermName))
|
||||
mkTermDefinition codebase pped namesRoot shallowRoot width reference docs trm
|
||||
mkTermDefinition codebase pped width reference docs trm
|
||||
let renderedDisplayTerms = Map.mapKeys Reference.toText termDefinitions
|
||||
renderedDisplayTypes = Map.mapKeys Reference.toText typeDefinitions
|
||||
renderedMisses = fmap HQ.toText misses
|
||||
|
@ -16,9 +16,9 @@ import Unison.Codebase (Codebase)
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Core.Project (ProjectAndBranch (..), ProjectBranchName (..), ProjectName (..))
|
||||
import Unison.NameSegment (NameSegment (..))
|
||||
import Unison.NameSegment (NameSegment)
|
||||
import Unison.Prelude
|
||||
import Unison.Project.Util (pattern UUIDNameSegment)
|
||||
import Unison.Project.Util (pattern BranchesNameSegment, pattern ProjectsNameSegment, pattern UUIDNameSegment)
|
||||
import Unison.Server.Backend
|
||||
import Unison.Server.Types (APIGet)
|
||||
|
||||
@ -40,7 +40,7 @@ instance ToSample Current where
|
||||
Current
|
||||
(Just $ UnsafeProjectName "@unison/base")
|
||||
(Just $ UnsafeProjectBranchName "main")
|
||||
(Path.Absolute $ Path.fromText ".__projects._53393e4b_1f61_467c_a488_b6068c727daa.branches._f0aec0e3_249f_4004_b836_572fea3981c1")
|
||||
(Path.Absolute $ Path.unsafeParseText ".__projects._53393e4b_1f61_467c_a488_b6068c727daa.branches._f0aec0e3_249f_4004_b836_572fea3981c1")
|
||||
)
|
||||
]
|
||||
|
||||
@ -57,8 +57,7 @@ serveCurrent = lift . getCurrentProjectBranch
|
||||
|
||||
getCurrentProjectBranch :: MonadIO m => Codebase m v a -> m Current
|
||||
getCurrentProjectBranch codebase = do
|
||||
namespace <- Codebase.runTransaction codebase Queries.expectMostRecentNamespace
|
||||
let segments = NameSegment <$> namespace
|
||||
segments <- Codebase.runTransaction codebase Queries.expectMostRecentNamespace
|
||||
let absolutePath = toPath segments
|
||||
case toIds segments of
|
||||
ProjectAndBranch (Just projectId) branchId ->
|
||||
@ -72,9 +71,9 @@ getCurrentProjectBranch codebase = do
|
||||
toIds :: [NameSegment] -> ProjectAndBranch (Maybe ProjectId) (Maybe ProjectBranchId)
|
||||
toIds segments =
|
||||
case segments of
|
||||
"__projects" : UUIDNameSegment projectId : "branches" : UUIDNameSegment branchId : _ ->
|
||||
ProjectsNameSegment : UUIDNameSegment projectId : BranchesNameSegment : UUIDNameSegment branchId : _ ->
|
||||
ProjectAndBranch {project = Just $ ProjectId projectId, branch = Just $ ProjectBranchId branchId}
|
||||
"__projects" : UUIDNameSegment projectId : _ ->
|
||||
ProjectsNameSegment : UUIDNameSegment projectId : _ ->
|
||||
ProjectAndBranch {project = Just $ ProjectId projectId, branch = Nothing}
|
||||
_ ->
|
||||
ProjectAndBranch {project = Nothing, branch = Nothing}
|
||||
|
@ -1,11 +1,5 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module Unison.Server.Local.Endpoints.FuzzyFind where
|
||||
@ -26,7 +20,6 @@ import Servant.Docs
|
||||
)
|
||||
import Servant.OpenApi ()
|
||||
import Text.FuzzyFind qualified as FZF
|
||||
import U.Codebase.Causal qualified as V2Causal
|
||||
import U.Codebase.HashTags (CausalHash)
|
||||
import Unison.Codebase (Codebase)
|
||||
import Unison.Codebase qualified as Codebase
|
||||
@ -34,7 +27,6 @@ import Unison.Codebase.Editor.DisplayObject
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.ShortCausalHash qualified as SCH
|
||||
import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv
|
||||
import Unison.NameSegment
|
||||
import Unison.Parser.Ann (Ann)
|
||||
import Unison.Prelude
|
||||
import Unison.PrettyPrintEnvDecl qualified as PPE
|
||||
@ -51,6 +43,7 @@ import Unison.Server.Types
|
||||
)
|
||||
import Unison.Symbol (Symbol)
|
||||
import Unison.Util.Pretty (Width)
|
||||
import qualified Unison.Syntax.Name as Name
|
||||
|
||||
type FuzzyFindAPI =
|
||||
"find"
|
||||
@ -161,10 +154,6 @@ serveFuzzyFind codebase mayRoot relativeTo limit typeWidth query = do
|
||||
Backend.hoistBackend (Codebase.runTransaction codebase) do
|
||||
Backend.normaliseRootCausalHash mayRoot
|
||||
(localNamesOnly, ppe) <- Backend.namesAtPathFromRootBranchHash codebase (Just rootCausal) path
|
||||
relativeToBranch <- do
|
||||
(lift . Codebase.runTransaction codebase) do
|
||||
relativeToCausal <- Codebase.getShallowCausalAtPath path (Just rootCausal)
|
||||
V2Causal.value relativeToCausal
|
||||
let alignments ::
|
||||
( [ ( FZF.Alignment,
|
||||
UnisonName,
|
||||
@ -174,26 +163,25 @@ serveFuzzyFind codebase mayRoot relativeTo limit typeWidth query = do
|
||||
)
|
||||
alignments =
|
||||
take (fromMaybe 10 limit) $ Backend.fuzzyFind localNamesOnly (fromMaybe "" query)
|
||||
lift (join <$> traverse (loadEntry (Just relativeToBranch) (PPE.suffixifiedPPE ppe)) alignments)
|
||||
lift (join <$> traverse (loadEntry (PPE.suffixifiedPPE ppe)) alignments)
|
||||
where
|
||||
loadEntry relativeToBranch ppe (a, n, refs) = do
|
||||
for refs $
|
||||
\case
|
||||
Backend.FoundTermRef r ->
|
||||
( \te ->
|
||||
( a,
|
||||
FoundTermResult
|
||||
. FoundTerm
|
||||
(Backend.bestNameForTerm @Symbol ppe (mayDefaultWidth typeWidth) r)
|
||||
$ Backend.termEntryToNamedTerm ppe typeWidth te
|
||||
)
|
||||
)
|
||||
<$> Backend.termListEntry codebase relativeToBranch (ExactName (NameSegment n) (Cv.referent1to2 r))
|
||||
Backend.FoundTypeRef r ->
|
||||
Codebase.runTransaction codebase do
|
||||
te <- Backend.typeListEntry codebase relativeToBranch (ExactName (NameSegment n) r)
|
||||
let namedType = Backend.typeEntryToNamedType te
|
||||
let typeName = Backend.bestNameForType @Symbol ppe (mayDefaultWidth typeWidth) r
|
||||
typeHeader <- Backend.typeDeclHeader codebase ppe r
|
||||
let ft = FoundType typeName typeHeader namedType
|
||||
pure (a, FoundTypeResult ft)
|
||||
loadEntry ppe (a, n, refs) = do
|
||||
for refs \case
|
||||
Backend.FoundTermRef r ->
|
||||
( \te ->
|
||||
( a,
|
||||
FoundTermResult
|
||||
. FoundTerm
|
||||
(Backend.bestNameForTerm @Symbol ppe (mayDefaultWidth typeWidth) r)
|
||||
$ Backend.termEntryToNamedTerm ppe typeWidth te
|
||||
)
|
||||
)
|
||||
<$> Backend.termListEntry codebase (ExactName (Name.unsafeParseText n) (Cv.referent1to2 r))
|
||||
Backend.FoundTypeRef r ->
|
||||
Codebase.runTransaction codebase do
|
||||
te <- Backend.typeListEntry codebase (ExactName (Name.unsafeParseText n) r)
|
||||
let namedType = Backend.typeEntryToNamedType te
|
||||
let typeName = Backend.bestNameForType @Symbol ppe (mayDefaultWidth typeWidth) r
|
||||
typeHeader <- Backend.typeDeclHeader codebase ppe r
|
||||
let ft = FoundType typeName typeHeader namedType
|
||||
pure (a, FoundTypeResult ft)
|
||||
|
@ -1,11 +1,5 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module Unison.Server.Local.Endpoints.NamespaceDetails where
|
||||
@ -78,4 +72,5 @@ namespaceDetails runtime codebase namespacePath mayRoot _mayWidth = do
|
||||
pure $ NamespaceDetails namespacePath causalHash renderedReadme
|
||||
pure $ namespaceDetails
|
||||
where
|
||||
readmeNames = Set.fromList ["README", "Readme", "ReadMe", "readme"]
|
||||
readmeNames =
|
||||
Set.fromList ["README", "Readme", "ReadMe", "readme"]
|
||||
|
@ -26,7 +26,6 @@ import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
|
||||
import Unison.Hash qualified as Hash
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Parser.Ann (Ann)
|
||||
import Unison.Prelude
|
||||
import Unison.PrettyPrintEnv qualified as PPE
|
||||
@ -42,6 +41,7 @@ import Unison.Server.Types
|
||||
v2CausalBranchToUnisonHash,
|
||||
)
|
||||
import Unison.Symbol (Symbol)
|
||||
import Unison.Syntax.NameSegment qualified as NameSegment
|
||||
import Unison.Util.Pretty (Width)
|
||||
import Unison.Var (Var)
|
||||
|
||||
@ -183,12 +183,12 @@ backendListEntryToNamespaceObject ppe typeWidth = \case
|
||||
Backend.ShallowBranchEntry name hash (NamespaceStats {numContainedTerms, numContainedTypes, numContainedPatches}) ->
|
||||
Subnamespace $
|
||||
NamedNamespace
|
||||
{ namespaceName = NameSegment.toText name,
|
||||
{ namespaceName = NameSegment.toEscapedText name,
|
||||
namespaceHash = "#" <> Hash.toBase32HexText (unCausalHash hash),
|
||||
namespaceSize = numContainedTerms + numContainedTypes + numContainedPatches
|
||||
}
|
||||
Backend.ShallowPatchEntry name ->
|
||||
PatchObject . NamedPatch $ NameSegment.toText name
|
||||
PatchObject . NamedPatch $ NameSegment.toEscapedText name
|
||||
|
||||
serve ::
|
||||
Codebase IO Symbol Ann ->
|
||||
@ -215,10 +215,9 @@ serve codebase maySCH mayRelativeTo mayNamespaceName = do
|
||||
let relativeToPath = fromMaybe Path.empty mayRelativeTo
|
||||
let namespacePath = fromMaybe Path.empty mayNamespaceName
|
||||
let path = relativeToPath <> namespacePath
|
||||
let path' = Path.toPath' path
|
||||
(listingCausal, listingBranch) <-
|
||||
(lift . Codebase.runTransaction codebase) do
|
||||
listingCausal <- Codebase.getShallowCausalAtPath (Path.fromPath' path') (Just rootCausal)
|
||||
listingCausal <- Codebase.getShallowCausalAtPath path (Just rootCausal)
|
||||
listingBranch <- V2Causal.value listingCausal
|
||||
pure (listingCausal, listingBranch)
|
||||
-- TODO: Currently the ppe is just used to render the types returned from the namespace
|
||||
@ -226,7 +225,7 @@ serve codebase maySCH mayRelativeTo mayNamespaceName = do
|
||||
-- If we ever show types on hover we need to build and use a proper PPE here, but it's not
|
||||
-- shallowPPE <- liftIO $ Backend.shallowPPE codebase listingBranch
|
||||
let shallowPPE = PPE.empty
|
||||
let listingFQN = Path.toText . Path.unabsolute . either id (Path.Absolute . Path.unrelative) $ Path.unPath' path'
|
||||
let listingFQN = Path.toText path
|
||||
let listingHash = v2CausalBranchToUnisonHash listingCausal
|
||||
listingEntries <- lift (Backend.lsBranch codebase listingBranch)
|
||||
makeNamespaceListing shallowPPE listingFQN listingHash listingEntries
|
||||
|
@ -18,9 +18,7 @@ import U.Codebase.HashTags
|
||||
import Unison.Codebase.Editor.DisplayObject
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.Path.Parse qualified as Path
|
||||
import Unison.Codebase.ShortCausalHash
|
||||
( ShortCausalHash (..),
|
||||
)
|
||||
import Unison.Codebase.ShortCausalHash (ShortCausalHash (..))
|
||||
import Unison.Codebase.ShortCausalHash qualified as SCH
|
||||
import Unison.ConstructorType (ConstructorType)
|
||||
import Unison.ConstructorType qualified as CT
|
||||
@ -32,16 +30,16 @@ import Unison.HashQualified' qualified as HQ'
|
||||
import Unison.Name (Name)
|
||||
import Unison.Name qualified as Name
|
||||
import Unison.NameSegment (NameSegment (..))
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Prelude
|
||||
import Unison.Project
|
||||
import Unison.Reference qualified as Reference
|
||||
import Unison.Referent qualified as Referent
|
||||
import Unison.ShortHash (ShortHash)
|
||||
import Unison.ShortHash qualified as SH
|
||||
import Unison.Syntax.HashQualified qualified as HQ (fromText)
|
||||
import Unison.Syntax.HashQualified' qualified as HQ' (fromText)
|
||||
import Unison.Syntax.Name qualified as Name (fromTextEither, toText)
|
||||
import Unison.Syntax.HashQualified qualified as HQ (parseText)
|
||||
import Unison.Syntax.HashQualified' qualified as HQ' (parseText)
|
||||
import Unison.Syntax.Name qualified as Name (parseTextEither, toText)
|
||||
import Unison.Syntax.NameSegment qualified as NameSegment (toEscapedText)
|
||||
import Unison.Util.Pretty (Width (..))
|
||||
|
||||
instance ToJSON Hash where
|
||||
@ -222,7 +220,7 @@ instance ToParam (QueryParam "name" Name) where
|
||||
Normal
|
||||
|
||||
instance FromHttpApiData Name where
|
||||
parseQueryParam = Name.fromTextEither
|
||||
parseQueryParam = Name.parseTextEither
|
||||
|
||||
deriving via Int instance FromHttpApiData Width
|
||||
|
||||
@ -237,7 +235,7 @@ instance ToJSON ConstructorType where
|
||||
|
||||
instance FromHttpApiData Path.Relative where
|
||||
parseUrlPiece txt = case Path.parsePath' (Text.unpack txt) of
|
||||
Left s -> Left (Text.pack s)
|
||||
Left s -> Left s
|
||||
Right (Path.RelativePath' p) -> Right p
|
||||
Right (Path.AbsolutePath' _) -> Left $ "Expected relative path, but " <> txt <> " was absolute."
|
||||
|
||||
@ -246,7 +244,7 @@ instance ToHttpApiData Path.Relative where
|
||||
|
||||
instance FromHttpApiData Path.Absolute where
|
||||
parseUrlPiece txt = case Path.parsePath' (Text.unpack txt) of
|
||||
Left s -> Left (Text.pack s)
|
||||
Left s -> Left s
|
||||
Right (Path.RelativePath' _) -> Left $ "Expected absolute path, but " <> txt <> " was relative."
|
||||
Right (Path.AbsolutePath' p) -> Right p
|
||||
|
||||
@ -254,14 +252,14 @@ instance ToHttpApiData Path.Absolute where
|
||||
toUrlPiece = tShow
|
||||
|
||||
instance FromHttpApiData Path.Path' where
|
||||
parseUrlPiece txt = mapLeft Text.pack $ Path.parsePath' (Text.unpack txt)
|
||||
parseUrlPiece txt = Path.parsePath' (Text.unpack txt)
|
||||
|
||||
instance ToHttpApiData Path.Path' where
|
||||
toUrlPiece = tShow
|
||||
|
||||
instance FromHttpApiData Path.Path where
|
||||
parseUrlPiece txt = case Path.parsePath' (Text.unpack txt) of
|
||||
Left s -> Left (Text.pack s)
|
||||
Left s -> Left s
|
||||
Right (Path.RelativePath' p) -> Right (Path.unrelative p)
|
||||
Right (Path.AbsolutePath' _) -> Left $ "Expected relative path, but " <> txt <> " was absolute."
|
||||
|
||||
@ -311,32 +309,32 @@ instance ToJSON (HQ.HashQualified Name) where
|
||||
toJSON = Aeson.String . HQ.toTextWith Name.toText
|
||||
|
||||
instance ToJSON (HQ.HashQualified NameSegment) where
|
||||
toJSON = Aeson.String . HQ.toTextWith NameSegment.toText
|
||||
toJSON = Aeson.String . HQ.toTextWith NameSegment.toEscapedText
|
||||
|
||||
instance ToJSON (HQ'.HashQualified Name) where
|
||||
toJSON = Aeson.String . HQ'.toTextWith Name.toText
|
||||
|
||||
instance ToJSON (HQ'.HashQualified NameSegment) where
|
||||
toJSON = Aeson.String . HQ'.toTextWith NameSegment.toText
|
||||
toJSON = Aeson.String . HQ'.toTextWith NameSegment.toEscapedText
|
||||
|
||||
instance FromJSON (HQ'.HashQualified Name) where
|
||||
parseJSON = Aeson.withText "HashQualified'" \txt ->
|
||||
maybe (fail "Invalid HashQualified' Name") pure $ HQ'.fromText txt
|
||||
maybe (fail "Invalid HashQualified' Name") pure $ HQ'.parseText txt
|
||||
|
||||
instance FromJSON (HQ.HashQualified Name) where
|
||||
parseJSON = Aeson.withText "HashQualified" \txt ->
|
||||
maybe (fail "Invalid HashQualified Name") pure $ HQ.fromText txt
|
||||
maybe (fail "Invalid HashQualified Name") pure $ HQ.parseText txt
|
||||
|
||||
instance FromJSON (HQ'.HashQualified NameSegment) where
|
||||
parseJSON = Aeson.withText "HashQualified'" \txt -> do
|
||||
hqName <- maybe (fail "Invalid HashQualified' NameSegment") pure $ HQ'.fromText txt
|
||||
hqName <- maybe (fail "Invalid HashQualified' NameSegment") pure $ HQ'.parseText txt
|
||||
for hqName \name -> case Name.segments name of
|
||||
(ns :| []) -> pure ns
|
||||
_ -> fail $ "Expected a single name segment but received several: " <> Text.unpack txt
|
||||
|
||||
instance FromJSON (HQ.HashQualified NameSegment) where
|
||||
parseJSON = Aeson.withText "HashQualified" \txt -> do
|
||||
hqName <- maybe (fail "Invalid HashQualified' NameSegment") pure $ HQ.fromText txt
|
||||
hqName <- maybe (fail "Invalid HashQualified' NameSegment") pure $ HQ.parseText txt
|
||||
for hqName \name -> case Name.segments name of
|
||||
(ns :| []) -> pure ns
|
||||
_ -> fail $ "Expected a single name segment but received several: " <> Text.unpack txt
|
||||
@ -344,13 +342,13 @@ instance FromJSON (HQ.HashQualified NameSegment) where
|
||||
instance FromHttpApiData (HQ.HashQualified Name) where
|
||||
parseQueryParam txt =
|
||||
Text.replace "@" "#" txt
|
||||
& HQ.fromText
|
||||
& HQ.parseText
|
||||
& maybe (Left "Invalid Hash Qualified Name. Expected one of the following forms: name@hash, name, @hash") Right
|
||||
|
||||
instance FromHttpApiData (HQ'.HashQualified Name) where
|
||||
parseQueryParam txt =
|
||||
Text.replace "@" "#" txt
|
||||
& HQ'.fromText
|
||||
& HQ'.parseText
|
||||
& maybe (Left "Invalid Hash Qualified Name. Expected one of the following forms: name@hash, name") Right
|
||||
|
||||
instance ToParamSchema (HQ.HashQualified n) where
|
||||
|
@ -1,8 +1,3 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
-- | Duplicate of the Unison.Util.SyntaxText module, but we expect these to
|
||||
@ -21,14 +16,14 @@ import Lucid
|
||||
import Lucid qualified as L
|
||||
import Unison.Name (Name)
|
||||
import Unison.Name qualified as Name
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Pattern (SeqOp (..))
|
||||
import Unison.Prelude
|
||||
import Unison.Reference (Reference)
|
||||
import Unison.Reference qualified as Reference
|
||||
import Unison.Referent qualified as Referent
|
||||
import Unison.Syntax.HashQualified qualified as HashQualified (toText)
|
||||
import Unison.Syntax.Name qualified as Name (unsafeFromText)
|
||||
import Unison.Syntax.Name qualified as Name (unsafeParseText)
|
||||
import Unison.Syntax.NameSegment qualified as NameSegment (toEscapedText)
|
||||
import Unison.Util.AnnotatedText
|
||||
( AnnotatedText (..),
|
||||
Segment (..),
|
||||
@ -269,7 +264,7 @@ nameToHtml name =
|
||||
span_ [class_ "fqn"] $ sequence_ parts
|
||||
where
|
||||
segments =
|
||||
map (segment . L.toHtml . NameSegment.toText) $ List.NonEmpty.toList $ Name.segments name
|
||||
map (segment . L.toHtml . NameSegment.toEscapedText) $ List.NonEmpty.toList $ Name.segments name
|
||||
|
||||
segment =
|
||||
span_ [class_ "segment"]
|
||||
@ -321,7 +316,7 @@ segmentToHtml (Segment segmentText element) =
|
||||
|
||||
content
|
||||
| Text.isInfixOf "->" sText = span_ [class_ "arrow"] $ L.toHtml sText
|
||||
| isFQN = nameToHtml (Name.unsafeFromText sText)
|
||||
| isFQN = nameToHtml (Name.unsafeParseText sText)
|
||||
| otherwise = L.toHtml sText
|
||||
in case ref of
|
||||
Just (r, refType) ->
|
||||
|
@ -42,15 +42,14 @@ import Unison.Hash qualified as Hash
|
||||
import Unison.HashQualified qualified as HQ
|
||||
import Unison.HashQualified' qualified as HQ'
|
||||
import Unison.Name (Name)
|
||||
import Unison.NameSegment (NameSegment)
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectAndBranch, ProjectBranchName, ProjectName)
|
||||
import Unison.Server.Doc (Doc)
|
||||
import Unison.Server.Orphans ()
|
||||
import Unison.Server.Syntax (SyntaxText)
|
||||
import Unison.ShortHash (ShortHash)
|
||||
import Unison.Syntax.HashQualified qualified as HQ (fromText)
|
||||
import Unison.Syntax.HashQualified qualified as HQ (parseText)
|
||||
import Unison.Syntax.Name qualified as Name
|
||||
import Unison.Util.Pretty (Width (..))
|
||||
|
||||
type APIHeaders x =
|
||||
@ -146,7 +145,7 @@ instance FromHttpApiData (ExactName Name ShortHash) where
|
||||
-- # is special in URLs, so we use @ for hash qualification instead;
|
||||
-- e.g. ".base.List.map@abc"
|
||||
-- e.g. ".base.Nat@@Nat"
|
||||
case HQ.fromText (Text.replace "@" "#" txt) of
|
||||
case HQ.parseText (Text.replace "@" "#" txt) of
|
||||
Nothing -> Left "Invalid absolute name with Hash"
|
||||
Just hq' -> case hq' of
|
||||
HQ.NameOnly _ -> Left "A name and hash are required, but only a name was provided"
|
||||
@ -246,7 +245,7 @@ unisonRefToText = \case
|
||||
|
||||
data NamedTerm = NamedTerm
|
||||
{ -- The name of the term, should be hash qualified if conflicted, otherwise name only.
|
||||
termName :: HQ'.HashQualified NameSegment,
|
||||
termName :: HQ'.HashQualified Name,
|
||||
termHash :: ShortHash,
|
||||
termType :: Maybe SyntaxText,
|
||||
termTag :: TermTag
|
||||
@ -256,7 +255,7 @@ data NamedTerm = NamedTerm
|
||||
instance ToJSON NamedTerm where
|
||||
toJSON (NamedTerm n h typ tag) =
|
||||
Aeson.object
|
||||
[ "termName" .= HQ'.toTextWith NameSegment.toText n,
|
||||
[ "termName" .= HQ'.toTextWith Name.toText n,
|
||||
"termHash" .= h,
|
||||
"termType" .= typ,
|
||||
"termTag" .= tag
|
||||
@ -273,7 +272,7 @@ instance FromJSON NamedTerm where
|
||||
deriving instance ToSchema NamedTerm
|
||||
|
||||
data NamedType = NamedType
|
||||
{ typeName :: HQ'.HashQualified NameSegment,
|
||||
{ typeName :: HQ'.HashQualified Name,
|
||||
typeHash :: ShortHash,
|
||||
typeTag :: TypeTag
|
||||
}
|
||||
@ -282,7 +281,7 @@ data NamedType = NamedType
|
||||
instance ToJSON NamedType where
|
||||
toJSON (NamedType n h tag) =
|
||||
Aeson.object
|
||||
[ "typeName" .= HQ'.toTextWith NameSegment.toText n,
|
||||
[ "typeName" .= HQ'.toTextWith Name.toText n,
|
||||
"typeHash" .= h,
|
||||
"typeTag" .= tag
|
||||
]
|
||||
|
@ -8,7 +8,6 @@ module Unison.Util.Find
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Char qualified as Char
|
||||
import Data.List qualified as List
|
||||
import Data.Text qualified as Text
|
||||
-- http://www.serpentine.com/blog/2007/02/27/a-haskell-regular-expression-tutorial/
|
||||
@ -27,7 +26,7 @@ import Unison.Referent qualified as Referent
|
||||
import Unison.Server.SearchResult (SearchResult)
|
||||
import Unison.Server.SearchResult qualified as SR
|
||||
import Unison.ShortHash qualified as SH
|
||||
import Unison.Syntax.Name qualified as Name (toString)
|
||||
import Unison.Syntax.Name qualified as Name (toText)
|
||||
import Unison.Syntax.NamePrinter (prettyHashQualified)
|
||||
import Unison.Util.Monoid (intercalateMap)
|
||||
import Unison.Util.Pretty qualified as P
|
||||
@ -46,46 +45,46 @@ fuzzyFinder query items render =
|
||||
|
||||
simpleFuzzyFinder ::
|
||||
forall a.
|
||||
String ->
|
||||
Text ->
|
||||
[a] ->
|
||||
(a -> String) ->
|
||||
(a -> Text) ->
|
||||
[(a, P.Pretty P.ColorText)]
|
||||
simpleFuzzyFinder query items render =
|
||||
sortAndCleanup $ do
|
||||
sortAndCleanup do
|
||||
a <- items
|
||||
let s = render a
|
||||
score <- toList (simpleFuzzyScore query s)
|
||||
pure ((a, hi s), score)
|
||||
pure ((a, hi (Text.unpack s)), score)
|
||||
where
|
||||
hi = highlightSimple query
|
||||
sortAndCleanup = List.map fst . List.sortOn snd
|
||||
|
||||
-- highlights `query` if it is a prefix of `s`, or if it
|
||||
-- appears in the final segement of s (after the final `.`)
|
||||
highlightSimple :: String -> String -> P.Pretty P.ColorText
|
||||
highlightSimple "" = P.string
|
||||
highlightSimple query = go
|
||||
highlightSimple :: Text -> String -> P.Pretty P.ColorText
|
||||
highlightSimple query
|
||||
| Text.null query = P.string
|
||||
| otherwise = go
|
||||
where
|
||||
go [] = mempty
|
||||
go s@(h : t)
|
||||
| query `List.isPrefixOf` s = hiQuery <> go (drop len s)
|
||||
| query `Text.isPrefixOf` (Text.pack s) = hiQuery <> go (drop len s)
|
||||
| otherwise = P.string [h] <> go t
|
||||
len = length query
|
||||
hiQuery = P.hiBlack (P.string query)
|
||||
len = Text.length query
|
||||
hiQuery = P.hiBlack (P.text query)
|
||||
|
||||
simpleFuzzyScore :: String -> String -> Maybe Int
|
||||
simpleFuzzyScore :: Text -> Text -> Maybe Int
|
||||
simpleFuzzyScore query s
|
||||
| query `List.isPrefixOf` s = Just (bonus s 2)
|
||||
| query `List.isSuffixOf` s = Just (bonus s 1)
|
||||
| query `List.isInfixOf` s = Just (bonus s 3)
|
||||
| lowerquery `List.isInfixOf` lowers = Just (bonus s 4)
|
||||
| query `Text.isPrefixOf` s = Just (bonus s 2)
|
||||
| query `Text.isSuffixOf` s = Just (bonus s 1)
|
||||
| query `Text.isInfixOf` s = Just (bonus s 3)
|
||||
| lowerquery `Text.isInfixOf` lowers = Just (bonus s 4)
|
||||
| otherwise = Nothing
|
||||
where
|
||||
-- prefer relative names
|
||||
bonus ('.' : _) n = n * 10
|
||||
bonus _ n = n
|
||||
lowerquery = Char.toLower <$> query
|
||||
lowers = Char.toLower <$> s
|
||||
bonus s n = if Text.take 1 s == "." then n * 10 else n
|
||||
lowerquery = Text.toLower query
|
||||
lowers = Text.toLower s
|
||||
|
||||
-- This logic was split out of fuzzyFinder because the `RE.MatchArray` has an
|
||||
-- `Ord` instance that helps us sort the fuzzy matches in a nice way. (see
|
||||
@ -155,13 +154,13 @@ fuzzyFindInBranch ::
|
||||
[(SearchResult, P.Pretty P.ColorText)]
|
||||
fuzzyFindInBranch b hq =
|
||||
simpleFuzzyFinder
|
||||
(Name.toString (HQ'.toName hq))
|
||||
(Name.toText (HQ'.toName hq))
|
||||
(candidates b hq)
|
||||
( \sr ->
|
||||
case HQ.toName (SR.name sr) of
|
||||
-- see invariant on `candidates` below.
|
||||
Nothing -> error "search result without name"
|
||||
Just name -> Name.toString name
|
||||
Just name -> Name.toText name
|
||||
)
|
||||
|
||||
getName :: SearchResult -> (SearchResult, P.Pretty P.ColorText)
|
||||
|
@ -1,5 +1,3 @@
|
||||
use . Int -- imports `.Int` from root path and gives it the local name `Int`
|
||||
|
||||
-- This brings `None` into scope unqualified
|
||||
use Optional None
|
||||
|
||||
|
@ -1,11 +1,11 @@
|
||||
|
||||
-- You can define an operator called dot
|
||||
(.) f g x = f (g x)
|
||||
(`.`) f g x = f (g x)
|
||||
|
||||
id : ∀ a. a -> a -- dot still fine in type parser
|
||||
id x = x
|
||||
|
||||
id2 = id . id
|
||||
id2 = id `.` id
|
||||
|
||||
-- You need a space or delimiter char after the dot,
|
||||
-- otherwise Unison assumes it's a rooted name - this will look for
|
||||
@ -14,15 +14,15 @@ id2 = id . id
|
||||
-- foo = id .zonk
|
||||
|
||||
-- You can define qualified functions
|
||||
(base.function..) f g x = f (g x)
|
||||
(base.function.`.`) f g x = f (g x)
|
||||
|
||||
-- looks weird, but consistent syntax with any other infix binding
|
||||
object oop.syntax.. method = method object
|
||||
object oop.syntax.`.` method = method object
|
||||
|
||||
ex =
|
||||
use base.function .
|
||||
(id . id) 42
|
||||
use base.function `.`
|
||||
(id `.` id) 42
|
||||
|
||||
ex2 = use oop.syntax .; 42 . id . id
|
||||
ex2 = use oop.syntax `.`; 42 `.` id `.` id
|
||||
|
||||
> (ex, ex2)
|
||||
|
@ -123,12 +123,11 @@ After adding to the codebase, here's the rewritten source:
|
||||
ex1 = List.map Nat.increment [1, 2, 3, 4, 5, 6, 7]
|
||||
|
||||
rule1 :
|
||||
∀ i g o g1.
|
||||
(i ->{g} o)
|
||||
-> Nat
|
||||
-> Rewrites
|
||||
( RewriteTerm Nat Nat,
|
||||
RewriteTerm (i ->{g, g1} o) (i ->{g} o))
|
||||
(i ->{g} o)
|
||||
-> Nat
|
||||
-> Rewrites
|
||||
( RewriteTerm Nat Nat,
|
||||
RewriteTerm (i ->{g, g1} o) (i ->{g} o))
|
||||
rule1 f x =
|
||||
use Nat +
|
||||
@rewrite
|
||||
|
@ -2554,25 +2554,22 @@ This transcript is intended to make visible accidental changes to the hashing al
|
||||
->{IO} [(Link.Term, Code)]
|
||||
|
||||
732. -- #srpc2uag5p1grvshbcm3urjntakgi3g3dthfse2cp38sd6uestd5neseces5ue7kum2ca0gsg9i0cilkl0gn8dn3q5dn86v4r8lbha0
|
||||
compose : ∀ i1 g1 o i g.
|
||||
(i1 ->{g1} o) -> (i ->{g} i1) -> i ->{g1, g} o
|
||||
compose : (i1 ->{g1} o) -> (i ->{g} i1) -> i ->{g1, g} o
|
||||
|
||||
733. -- #stnrk323b8mm7dknlonfl70epd9f9ede60iom7sgok31mmggnic7etgi0are2uccs9g429qo3ruaeb9tk90bh35obnce1038p5qe6co
|
||||
compose2 : ∀ i2 g2 o i1 g1 i g.
|
||||
(i2 ->{g2} o)
|
||||
-> (i1 ->{g1} i ->{g} i2)
|
||||
-> i1
|
||||
-> i
|
||||
->{g2, g1, g} o
|
||||
compose2 : (i2 ->{g2} o)
|
||||
-> (i1 ->{g1} i ->{g} i2)
|
||||
-> i1
|
||||
-> i
|
||||
->{g2, g1, g} o
|
||||
|
||||
734. -- #mrc183aovjcae3i03r1a0ia26crmmkcf2e723pda860ps6q11rancsenjoqhc3fn0eraih1mobcvt245jr77l27uoujqa452utq8p68
|
||||
compose3 : ∀ i3 g3 o i2 g2 i1 g1 i g.
|
||||
(i3 ->{g3} o)
|
||||
-> (i2 ->{g2} i1 ->{g1} i ->{g} i3)
|
||||
-> i2
|
||||
-> i1
|
||||
-> i
|
||||
->{g3, g2, g1, g} o
|
||||
compose3 : (i3 ->{g3} o)
|
||||
-> (i2 ->{g2} i1 ->{g1} i ->{g} i3)
|
||||
-> i2
|
||||
-> i1
|
||||
-> i
|
||||
->{g3, g2, g1, g} o
|
||||
|
||||
735. -- #ilkeid6l866bmq90d2v1ilqp9dsjo6ucmf8udgrokq3nr3mo9skl2vao2mo7ish136as52rsf19u9v3jkmd85bl08gnmamo4e5v2fqo
|
||||
contains : Text -> Text -> Boolean
|
||||
@ -2829,7 +2826,7 @@ This transcript is intended to make visible accidental changes to the hashing al
|
||||
setEcho : Handle -> Boolean ->{IO, Exception} ()
|
||||
|
||||
811. -- #in06o7cfgnlmm6pvdtv0jv9hniahcli0fvh27o01ork1p77ro2v51rc05ts1h6p9mtffqld4ufs8klcc4bse1tsj93cu0na0bbiuqb0
|
||||
snd : ∀ a1 a. (a1, a) -> a
|
||||
snd : (a1, a) -> a
|
||||
|
||||
812. -- #km3cpkvcnvcos0isfbnb7pb3s45ri5q42n74jmm9c4v1bcu8nlk63353u4ohfr7av4k00s4s180ddnqbam6a01thhlt2tie1hm5a9bo
|
||||
socketAccept : Socket ->{IO, Exception} Socket
|
||||
@ -2889,8 +2886,7 @@ This transcript is intended to make visible accidental changes to the hashing al
|
||||
Throw.throw : e ->{Throw e} a
|
||||
|
||||
831. -- #f6pkvs6ukf8ngh2j8lm935p1bqadso76o7e3t0j1ukupjh1rg0m1rhtp7u492sq17p3bkbintbnjehc1cqs33qlhnfkoihf5uee4ug0
|
||||
uncurry : ∀ i1 g1 i g o.
|
||||
(i1 ->{g1} i ->{g} o) -> (i1, i) ->{g1, g} o
|
||||
uncurry : (i1 ->{g1} i ->{g} o) -> (i1, i) ->{g1, g} o
|
||||
|
||||
832. -- #u1o44hd0cdlfa8racf458sahdmgea409k8baajgc5k7bqukf2ak5ggs2ped0u3h85v99pgefgb9r7ct2dv4nn9eihjghnqf30p4l57g
|
||||
Value.transitiveDeps : Value ->{IO} [(Link.Term, Code)]
|
||||
|
@ -82,12 +82,11 @@ mkTestCase = do
|
||||
-> (Tree Text -> Text)
|
||||
-> (Tree Nat, Tree Nat, Tree Nat, Tree Text)
|
||||
-> Text
|
||||
foldMap : ∀ r g2 g1 a g.
|
||||
r
|
||||
-> (r ->{g2} r ->{g1} r)
|
||||
-> (a ->{g} r)
|
||||
-> Tree a
|
||||
->{g2, g1, g} r
|
||||
foldMap : r
|
||||
-> (r ->{g2} r ->{g1} r)
|
||||
-> (a ->{g} r)
|
||||
-> Tree a
|
||||
->{g2, g1, g} r
|
||||
mkTestCase : '{IO, Exception} ()
|
||||
tree0 : Tree Nat
|
||||
tree1 : Tree Nat
|
||||
@ -105,12 +104,11 @@ mkTestCase = do
|
||||
-> (Tree Text -> Text)
|
||||
-> (Tree Nat, Tree Nat, Tree Nat, Tree Text)
|
||||
-> Text
|
||||
foldMap : ∀ r g2 g1 a g.
|
||||
r
|
||||
-> (r ->{g2} r ->{g1} r)
|
||||
-> (a ->{g} r)
|
||||
-> Tree a
|
||||
->{g2, g1, g} r
|
||||
foldMap : r
|
||||
-> (r ->{g2} r ->{g1} r)
|
||||
-> (a ->{g} r)
|
||||
-> Tree a
|
||||
->{g2, g1, g} r
|
||||
mkTestCase : '{IO, Exception} ()
|
||||
tree0 : Tree Nat
|
||||
tree1 : Tree Nat
|
||||
|
@ -67,7 +67,7 @@ unique[bb] type bar = Foo | Bar
|
||||
we get an error when attempting to delete something that is neither a type nor a term
|
||||
```ucm:error
|
||||
.> view.patch
|
||||
.> delete.type-replacement not-here
|
||||
.> delete.type-replacement notHere
|
||||
.> view.patch
|
||||
```
|
||||
|
||||
|
@ -214,12 +214,12 @@ we get an error when attempting to delete something that is neither a type nor a
|
||||
|
||||
This patch is empty.
|
||||
|
||||
.> delete.type-replacement not-here
|
||||
.> delete.type-replacement notHere
|
||||
|
||||
⚠️
|
||||
|
||||
The following names were not found in the codebase. Check your spelling.
|
||||
not-here
|
||||
notHere
|
||||
|
||||
.> view.patch
|
||||
|
||||
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user