mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-11 10:35:57 +03:00
Merge pull request #3881 from unisonweb/lsp/binding-annotations
This commit is contained in:
commit
67e237450d
@ -22,13 +22,15 @@ import Unison.Type qualified as Type
|
||||
import Unison.Var (Var)
|
||||
import Unison.Var qualified as Var
|
||||
|
||||
builtinTermsSrc :: a -> [(Symbol, Term Symbol a, Type Symbol a)]
|
||||
builtinTermsSrc :: a -> [(Symbol, a, Term Symbol a, Type Symbol a)]
|
||||
builtinTermsSrc ann =
|
||||
[ ( v "metadata.isPropagated",
|
||||
ann,
|
||||
Term.constructor ann (ConstructorReference Decls.isPropagatedRef Decls.isPropagatedConstructorId),
|
||||
Type.ref ann Decls.isPropagatedRef
|
||||
),
|
||||
( v "metadata.isTest",
|
||||
ann,
|
||||
Term.constructor ann (ConstructorReference Decls.isTestRef Decls.isTestConstructorId),
|
||||
Type.ref ann Decls.isTestRef
|
||||
)
|
||||
@ -39,8 +41,8 @@ v = Var.named
|
||||
|
||||
builtinTermsRef :: Map Symbol Reference.Id
|
||||
builtinTermsRef =
|
||||
fmap (\(refId, _, _) -> refId)
|
||||
fmap (\(refId, _, _, _) -> refId)
|
||||
. H.hashTermComponents
|
||||
. Map.fromList
|
||||
. fmap (\(v, tm, tp) -> (v, (tm, tp)))
|
||||
. fmap (\(v, _a, tm, tp) -> (v, (tm, tp, ())))
|
||||
$ builtinTermsSrc ()
|
||||
|
@ -316,8 +316,8 @@ addDefsToCodebase c uf = do
|
||||
traverse_ goTerm (UF.hashTermsId uf)
|
||||
where
|
||||
goTerm t | debug && trace ("Codebase.addDefsToCodebase.goTerm " ++ show t) False = undefined
|
||||
goTerm (r, Nothing, tm, tp) = putTerm c r tm tp
|
||||
goTerm (r, Just WK.TestWatch, tm, tp) = putTerm c r tm tp
|
||||
goTerm (_, r, Nothing, tm, tp) = putTerm c r tm tp
|
||||
goTerm (_, r, Just WK.TestWatch, tm, tp) = putTerm c r tm tp
|
||||
goTerm _ = pure ()
|
||||
goType :: (Show t) => (t -> Decl v a) -> (Reference.Id, t) -> Sqlite.Transaction ()
|
||||
goType _f pair | debug && trace ("Codebase.addDefsToCodebase.goType " ++ show pair) False = undefined
|
||||
|
@ -32,4 +32,4 @@ fromTypecheckedUnisonFile tuf = CodeLookup tm ty
|
||||
Map.toList (UF.effectDeclarations' tuf)
|
||||
]
|
||||
termMap :: Map Reference.Id (Term.Term v a)
|
||||
termMap = Map.fromList [(id, tm) | (id, _wk, tm, _tp) <- toList $ UF.hashTermsId tuf]
|
||||
termMap = Map.fromList [(id, tm) | (_a, id, _wk, tm, _tp) <- toList $ UF.hashTermsId tuf]
|
||||
|
@ -80,12 +80,12 @@ evaluateWatches ::
|
||||
evaluateWatches code ppe evaluationCache rt tuf = do
|
||||
-- 1. compute hashes for everything in the file
|
||||
let m :: Map v (Reference.Id, Term.Term v a)
|
||||
m = fmap (\(id, _wk, tm, _tp) -> (id, tm)) (UF.hashTermsId tuf)
|
||||
m = fmap (\(_a, id, _wk, tm, _tp) -> (id, tm)) (UF.hashTermsId tuf)
|
||||
watches :: Set v = Map.keysSet watchKinds
|
||||
watchKinds :: Map v WatchKind
|
||||
watchKinds =
|
||||
Map.fromList
|
||||
[(v, k) | (k, ws) <- UF.watchComponents tuf, (v, _tm, _tp) <- ws]
|
||||
[(v, k) | (k, ws) <- UF.watchComponents tuf, (v, _a, _tm, _tp) <- ws]
|
||||
unann = Term.amap (const ())
|
||||
-- 2. use the cache to lookup things already computed
|
||||
m' <- fmap Map.fromList . for (Map.toList m) $ \(v, (r, t)) -> do
|
||||
@ -96,8 +96,8 @@ evaluateWatches code ppe evaluationCache rt tuf = do
|
||||
-- 3. create a big ol' let rec whose body is a big tuple of all watches
|
||||
let rv :: Map Reference.Id v
|
||||
rv = Map.fromList [(r, v) | (v, (r, _)) <- Map.toList m]
|
||||
bindings :: [(v, Term v)]
|
||||
bindings = [(v, unref rv b) | (v, (_, _, b, _)) <- Map.toList m']
|
||||
bindings :: [(v, (), Term v)]
|
||||
bindings = [(v, (), unref rv b) | (v, (_, _, b, _)) <- Map.toList m']
|
||||
watchVars = [Term.var () v | v <- toList watches]
|
||||
bigOl'LetRec = Term.letRec' True bindings (tupleTerm watchVars)
|
||||
cl = void (CL.fromTypecheckedUnisonFile tuf) <> void code
|
||||
@ -153,7 +153,7 @@ evaluateTerm' codeLookup cache ppe rt tm = do
|
||||
mempty
|
||||
mempty
|
||||
mempty
|
||||
[(WK.RegularWatch, [(Var.nameds "result", tm, mempty <$> mainType rt)])]
|
||||
[(WK.RegularWatch, [(Var.nameds "result", mempty, tm, mempty <$> mainType rt)])]
|
||||
r <- evaluateWatches (void codeLookup) ppe cache rt (void tuf)
|
||||
pure $
|
||||
r <&> \(_, map) ->
|
||||
|
@ -579,9 +579,10 @@ migrateTermComponent getDeclType termBuffer declBuffer oldHash = fmap (either id
|
||||
newTermComponents =
|
||||
remappedReferences
|
||||
& Map.elems
|
||||
& fmap (\(v, trm, typ) -> (v, (trm, typ)))
|
||||
& fmap (\(v, trm, typ) -> (v, (trm, typ, ())))
|
||||
& Map.fromList
|
||||
& Convert.hashTermComponents
|
||||
& fmap (\(ref, trm, typ, _) -> (ref, trm, typ))
|
||||
|
||||
ifor newTermComponents $ \v (newReferenceId, trm, typ) -> do
|
||||
let oldReferenceId = vToOldReferenceMapping ^?! ix v
|
||||
|
@ -4,7 +4,7 @@ module Unison.FileParsers
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Lens (view, _3)
|
||||
import Control.Lens
|
||||
import Control.Monad.State (evalStateT)
|
||||
import Control.Monad.Writer (tell)
|
||||
import Data.Foldable qualified as Foldable
|
||||
@ -36,12 +36,14 @@ import Unison.Typechecker qualified as Typechecker
|
||||
import Unison.Typechecker.Context qualified as Context
|
||||
import Unison.Typechecker.Extractor (RedundantTypeAnnotation)
|
||||
import Unison.Typechecker.TypeLookup qualified as TL
|
||||
import Unison.UnisonFile (definitionLocation)
|
||||
import Unison.UnisonFile qualified as UF
|
||||
import Unison.UnisonFile.Names qualified as UF
|
||||
import Unison.Util.List qualified as List
|
||||
import Unison.Util.Relation qualified as Rel
|
||||
import Unison.Var (Var)
|
||||
import Unison.Var qualified as Var
|
||||
import Unison.WatchKind (WatchKind)
|
||||
|
||||
type Term v = Term.Term v Ann
|
||||
|
||||
@ -189,14 +191,21 @@ synthesizeFile ambient tl fqnsByShortName uf term = do
|
||||
in traverse (traverse addTypesToTopLevelBindings) tlcsFromTypechecker
|
||||
let doTdnr = applyTdnrDecisions infos
|
||||
let doTdnrInComponent (v, t, tp) = (v, doTdnr t, tp)
|
||||
let tdnredTlcs = (fmap . fmap) doTdnrInComponent topLevelComponents
|
||||
let tdnredTlcs =
|
||||
topLevelComponents
|
||||
& (fmap . fmap)
|
||||
( \vtt ->
|
||||
vtt
|
||||
& doTdnrInComponent
|
||||
& \(v, t, tp) -> (v, fromMaybe (error $ "Symbol from typechecked file not present in parsed file" <> show v) (definitionLocation v uf), t, tp)
|
||||
)
|
||||
let (watches', terms') = partition isWatch tdnredTlcs
|
||||
isWatch = all (\(v, _, _) -> Set.member v watchedVars)
|
||||
watchedVars = Set.fromList [v | (v, _) <- UF.allWatches uf]
|
||||
isWatch = all (\(v, _, _, _) -> Set.member v watchedVars)
|
||||
watchedVars = Set.fromList [v | (v, _a, _) <- UF.allWatches uf]
|
||||
tlcKind [] = error "empty TLC, should never occur"
|
||||
tlcKind tlc@((v, _, _) : _) =
|
||||
let hasE k =
|
||||
elem v . fmap fst $ Map.findWithDefault [] k (UF.watches uf)
|
||||
tlcKind tlc@((v, _, _, _) : _) =
|
||||
let hasE :: WatchKind -> Bool
|
||||
hasE k = elem v . fmap (view _1) $ Map.findWithDefault [] k (UF.watches uf)
|
||||
in case Foldable.find hasE (Map.keys $ UF.watches uf) of
|
||||
Nothing -> error "wat"
|
||||
Just kind -> (kind, tlc)
|
||||
|
@ -16,13 +16,14 @@ module Unison.Hashing.V2.Convert
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Lens (over, _3)
|
||||
import Control.Lens qualified as Lens
|
||||
import Control.Monad.Trans.Writer.CPS (Writer)
|
||||
import Control.Monad.Trans.Writer.CPS qualified as Writer
|
||||
import Data.Bifunctor (bimap)
|
||||
import Data.Bitraversable (bitraverse)
|
||||
import Data.Foldable (toList)
|
||||
import Data.Function ((&))
|
||||
import Data.Functor ((<&>))
|
||||
import Data.Map (Map)
|
||||
import Data.Map qualified as Map
|
||||
@ -64,22 +65,26 @@ typeToReferenceMentions =
|
||||
-- TODO: remove non-prime version
|
||||
-- include type in hash
|
||||
hashTermComponents ::
|
||||
forall v a.
|
||||
forall v a extra.
|
||||
(Var v) =>
|
||||
Map v (Memory.Term.Term v a, Memory.Type.Type v a) ->
|
||||
Map v (Memory.Reference.Id, Memory.Term.Term v a, Memory.Type.Type v a)
|
||||
Map v (Memory.Term.Term v a, Memory.Type.Type v a, extra) ->
|
||||
Map v (Memory.Reference.Id, Memory.Term.Term v a, Memory.Type.Type v a, extra)
|
||||
hashTermComponents mTerms =
|
||||
case Writer.runWriter (traverse (bitraverse m2hTerm (pure . m2hType)) mTerms) of
|
||||
case h2mTermMap mTerms of
|
||||
(hTerms, constructorTypes) -> h2mTermResult (constructorTypes Map.!) <$> Hashing.hashTermComponents hTerms
|
||||
where
|
||||
h2mTermMap m =
|
||||
m
|
||||
& traverse (\(trm, typ, extra) -> liftA3 (,,) (m2hTerm trm) (pure $ m2hType typ) (pure extra))
|
||||
& Writer.runWriter
|
||||
h2mTermResult ::
|
||||
(Ord v) =>
|
||||
( Memory.Reference.Reference ->
|
||||
Memory.ConstructorType.ConstructorType
|
||||
) ->
|
||||
(Hashing.ReferenceId, Hashing.Term v a, Hashing.Type v a) ->
|
||||
(Memory.Reference.Id, Memory.Term.Term v a, Memory.Type.Type v a)
|
||||
h2mTermResult getCtorType (id, tm, typ) = (h2mReferenceId id, h2mTerm getCtorType tm, h2mType typ)
|
||||
(Hashing.ReferenceId, Hashing.Term v a, Hashing.Type v a, extra) ->
|
||||
(Memory.Reference.Id, Memory.Term.Term v a, Memory.Type.Type v a, extra)
|
||||
h2mTermResult getCtorType (id, tm, typ, extra) = (h2mReferenceId id, h2mTerm getCtorType tm, h2mType typ, extra)
|
||||
|
||||
-- | This shouldn't be used when storing terms in the codebase, as it doesn't incorporate the type into the hash.
|
||||
-- this should only be used in cases where you just need a way to identify some terms that you have, but won't be
|
||||
|
@ -179,7 +179,10 @@ enclose keep rec (LetRecNamedTop' top vbs bd) =
|
||||
where
|
||||
xpnd = expandRec keep' vbs
|
||||
keep' = Set.union keep . Set.fromList . map fst $ vbs
|
||||
lvbs = (map . fmap) (rec keep' . abstract keep' . ABT.substs xpnd) vbs
|
||||
lvbs =
|
||||
vbs
|
||||
<&> \(v, trm) ->
|
||||
(v, ABT.annotation trm, (rec keep' . abstract keep' . ABT.substs xpnd) trm)
|
||||
lbd = rec keep' . ABT.substs xpnd $ bd
|
||||
-- will be lifted, so keep this variable
|
||||
enclose keep rec (Let1NamedTop' top v b@(unAnn -> LamsNamed' vs bd) e) =
|
||||
@ -299,7 +302,7 @@ beta rec (LetRecNamedTop' top (fmap (fmap rec) -> vbs) (rec -> bd)) =
|
||||
|
||||
m = Map.map length $ Map.differenceWith f (Map.fromList $ map args vbs) m0
|
||||
lvbs =
|
||||
vbs <&> \(v, b0) -> (,) v $ case b0 of
|
||||
vbs <&> \(v, b0) -> (v,ABT.annotation b0,) $ case b0 of
|
||||
LamsNamed' vs b
|
||||
| Just n <- Map.lookup v m ->
|
||||
lam' (ABT.annotation b0) (drop n vs) (dropPrefixes m b)
|
||||
|
@ -3,7 +3,7 @@
|
||||
|
||||
module Unison.Runtime.IOSource where
|
||||
|
||||
import Control.Lens (view, _1)
|
||||
import Control.Lens (view, _2)
|
||||
import Control.Monad.Morph (hoist)
|
||||
import Data.List (elemIndex, genericIndex)
|
||||
import Data.Map qualified as Map
|
||||
@ -54,7 +54,7 @@ typecheckedFile' =
|
||||
Right file -> file
|
||||
|
||||
typecheckedFileTerms :: Map.Map Symbol R.Reference
|
||||
typecheckedFileTerms = view _1 <$> UF.hashTerms typecheckedFile
|
||||
typecheckedFileTerms = view _2 <$> UF.hashTerms typecheckedFile
|
||||
|
||||
termNamed :: String -> R.Reference
|
||||
termNamed s =
|
||||
|
@ -159,7 +159,7 @@ fieldNames env r name dd = do
|
||||
_ -> Nothing
|
||||
let vars :: [v]
|
||||
vars = [Var.freshenId (fromIntegral n) (Var.named "_") | n <- [0 .. Type.arity typ - 1]]
|
||||
let accessors :: [(v, Term.Term v ())]
|
||||
let accessors :: [(v, (), Term.Term v ())]
|
||||
accessors = DD.generateRecordAccessors (map (,()) vars) (HQ.toVar name) r
|
||||
let typeLookup :: TypeLookup v ()
|
||||
typeLookup =
|
||||
@ -176,14 +176,14 @@ fieldNames env r name dd = do
|
||||
Typechecker._termsByShortname = mempty
|
||||
}
|
||||
accessorsWithTypes :: [(v, Term.Term v (), Type.Type v ())] <-
|
||||
for accessors \(v, trm) ->
|
||||
for accessors \(v, _a, trm) ->
|
||||
case Result.result (Typechecker.synthesize env typecheckingEnv trm) of
|
||||
Nothing -> Nothing
|
||||
Just typ -> Just (v, trm, typ)
|
||||
let hashes = Hashing.hashTermComponents (Map.fromList . fmap (\(v, trm, typ) -> (v, (trm, typ))) $ accessorsWithTypes)
|
||||
let hashes = Hashing.hashTermComponents (Map.fromList . fmap (\(v, trm, typ) -> (v, (trm, typ, ()))) $ accessorsWithTypes)
|
||||
let names =
|
||||
[ (r, HQ.toString . PPE.termName env . Referent.Ref $ DerivedId r)
|
||||
| r <- (\(refId, _trm, _typ) -> refId) <$> Map.elems hashes
|
||||
| r <- (\(refId, _trm, _typ, _ann) -> refId) <$> Map.elems hashes
|
||||
]
|
||||
let fieldNames =
|
||||
Map.fromList
|
||||
@ -195,7 +195,7 @@ fieldNames env r name dd = do
|
||||
Just
|
||||
[ HQ.unsafeFromString 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
|
||||
|
@ -64,12 +64,12 @@ file = do
|
||||
_ <- closeBlock
|
||||
let (termsr, watchesr) = foldl' go ([], []) stanzas
|
||||
go (terms, watches) s = case s of
|
||||
WatchBinding kind _ ((_, v), at) ->
|
||||
(terms, (kind, (v, Term.generalizeTypeSignatures at)) : watches)
|
||||
WatchExpression kind guid _ at ->
|
||||
(terms, (kind, (Var.unnamedTest guid, Term.generalizeTypeSignatures at)) : watches)
|
||||
Binding ((_, v), at) -> ((v, Term.generalizeTypeSignatures at) : terms, watches)
|
||||
Bindings bs -> ([(v, Term.generalizeTypeSignatures at) | ((_, v), at) <- bs] ++ terms, watches)
|
||||
WatchBinding kind spanningAnn ((_, v), at) ->
|
||||
(terms, (kind, (v, spanningAnn, Term.generalizeTypeSignatures at)) : watches)
|
||||
WatchExpression kind guid spanningAnn at ->
|
||||
(terms, (kind, (Var.unnamedTest guid, spanningAnn, Term.generalizeTypeSignatures at)) : watches)
|
||||
Binding ((spanningAnn, v), at) -> ((v, spanningAnn, Term.generalizeTypeSignatures at) : terms, watches)
|
||||
Bindings bs -> ([(v, spanningAnn, Term.generalizeTypeSignatures at) | ((spanningAnn, v), at) <- bs] ++ terms, watches)
|
||||
let (terms, watches) = (reverse termsr, reverse watchesr)
|
||||
-- suffixified local term bindings shadow any same-named thing from the outer codebase scope
|
||||
-- example: `foo.bar` in local file scope will shadow `foo.bar` and `bar` in codebase scope
|
||||
@ -109,13 +109,14 @@ file = do
|
||||
let bindNames = Term.bindSomeNames Name.unsafeFromVar avoid curNames . resolveLocals
|
||||
where
|
||||
avoid = Set.fromList (stanzas0 >>= getVars)
|
||||
terms <- case List.validate (traverse bindNames) terms of
|
||||
terms <- case List.validate (traverseOf _3 bindNames) terms of
|
||||
Left es -> resolutionFailures (toList es)
|
||||
Right terms -> pure terms
|
||||
watches <- case List.validate (traverse . traverse $ bindNames) watches of
|
||||
watches <- case List.validate (traverseOf (traversed . _3) bindNames) watches of
|
||||
Left es -> resolutionFailures (toList es)
|
||||
Right ws -> pure ws
|
||||
let toPair (tok, _) = (L.payload tok, ann tok)
|
||||
let toPair (tok, typ) = (L.payload tok, ann tok <> ann typ)
|
||||
accessors :: [[(v, Ann, Term v Ann)]]
|
||||
accessors =
|
||||
[ DD.generateRecordAccessors (toPair <$> fields) (L.payload typ) r
|
||||
| (typ, fields) <- parsedAccessors,
|
||||
@ -164,7 +165,7 @@ checkForDuplicateTermsAndConstructors uf = do
|
||||
allTerms :: [(v, Ann)]
|
||||
allTerms =
|
||||
UF.terms uf
|
||||
<&> (\(v, t) -> (v, ABT.annotation t))
|
||||
<&> (\(v, bindingAnn, _t) -> (v, bindingAnn))
|
||||
mergedTerms :: Map v (Set Ann)
|
||||
mergedTerms =
|
||||
(allConstructors <> allTerms)
|
||||
@ -337,10 +338,13 @@ dataDeclaration mod = do
|
||||
Type.foralls ctorAnn typeArgVs ctorType
|
||||
)
|
||||
prefixVar = TermParser.verifyRelativeVarName prefixDefinitionName
|
||||
dataConstructor :: P v (Ann, v, Type v Ann)
|
||||
dataConstructor = go <$> prefixVar <*> many TypeParser.valueTypeLeaf
|
||||
record :: P v ([(Ann, v, Type v Ann)], [(L.Token v, [(L.Token v, Type v Ann)])])
|
||||
record = do
|
||||
_ <- openBlockWith "{"
|
||||
let field = do
|
||||
let field :: P v [(L.Token v, Type v Ann)]
|
||||
field = do
|
||||
f <- liftA2 (,) (prefixVar <* reserved ":") TypeParser.valueType
|
||||
optional (reserved ",")
|
||||
>>= ( \case
|
||||
|
@ -14,6 +14,7 @@ module Unison.UnisonFile
|
||||
effectDeclarations,
|
||||
typecheckingTerm,
|
||||
watchesOfKind,
|
||||
definitionLocation,
|
||||
|
||||
-- * TypecheckedUnisonFile
|
||||
TypecheckedUnisonFile (..),
|
||||
@ -65,23 +66,33 @@ dataDeclarations = fmap (first Reference.DerivedId) . dataDeclarationsId
|
||||
effectDeclarations :: UnisonFile v a -> Map v (Reference, EffectDeclaration v a)
|
||||
effectDeclarations = fmap (first Reference.DerivedId) . effectDeclarationsId
|
||||
|
||||
watchesOfKind :: WatchKind -> UnisonFile v a -> [(v, Term v a)]
|
||||
watchesOfKind :: WatchKind -> UnisonFile v a -> [(v, a, Term v a)]
|
||||
watchesOfKind kind uf = Map.findWithDefault [] kind (watches uf)
|
||||
|
||||
watchesOfOtherKinds :: WatchKind -> UnisonFile v a -> [(v, Term v a)]
|
||||
watchesOfOtherKinds :: WatchKind -> UnisonFile v a -> [(v, a, Term v a)]
|
||||
watchesOfOtherKinds kind uf =
|
||||
join [ws | (k, ws) <- Map.toList (watches uf), k /= kind]
|
||||
|
||||
allWatches :: UnisonFile v a -> [(v, Term v a)]
|
||||
allWatches :: UnisonFile v a -> [(v, a, Term v a)]
|
||||
allWatches = join . Map.elems . watches
|
||||
|
||||
-- | Get the location of a given definition in the file.
|
||||
definitionLocation :: (Var v) => v -> UnisonFile v a -> Maybe a
|
||||
definitionLocation v uf =
|
||||
terms uf ^? folded . filteredBy (_1 . only v) . _2
|
||||
<|> watches uf ^? folded . folded . filteredBy (_1 . only v) . _2
|
||||
<|> dataDeclarations uf ^? ix v . _2 . to DD.annotation
|
||||
<|> effectDeclarations uf ^? ix v . _2 . to (DD.annotation . DD.toDataDecl)
|
||||
|
||||
-- Converts a file to a single let rec with a body of `()`, for
|
||||
-- purposes of typechecking.
|
||||
typecheckingTerm :: (Var v, Monoid a) => UnisonFile v a -> Term v a
|
||||
typecheckingTerm uf =
|
||||
Term.letRec' True (terms uf <> testWatches <> watchesOfOtherKinds TestWatch uf) $
|
||||
Term.letRec' True bindings $
|
||||
DD.unitTerm mempty
|
||||
where
|
||||
bindings =
|
||||
terms uf <> testWatches <> watchesOfOtherKinds TestWatch uf
|
||||
-- we make sure each test has type Test.Result
|
||||
f w = let wa = ABT.annotation w in Term.ann wa w (DD.testResultType wa)
|
||||
testWatches = map (second f) $ watchesOfKind TestWatch uf
|
||||
@ -93,35 +104,37 @@ dataDeclarations' = fmap (first Reference.DerivedId) . dataDeclarationsId'
|
||||
effectDeclarations' :: TypecheckedUnisonFile v a -> Map v (Reference, EffectDeclaration v a)
|
||||
effectDeclarations' = fmap (first Reference.DerivedId) . effectDeclarationsId'
|
||||
|
||||
hashTerms :: TypecheckedUnisonFile v a -> Map v (Reference, Maybe WatchKind, Term v a, Type v a)
|
||||
hashTerms = fmap (over _1 Reference.DerivedId) . hashTermsId
|
||||
hashTerms :: TypecheckedUnisonFile v a -> Map v (a, Reference, Maybe WatchKind, Term v a, Type v a)
|
||||
hashTerms = fmap (over _2 Reference.DerivedId) . hashTermsId
|
||||
|
||||
typecheckedUnisonFile ::
|
||||
forall v a.
|
||||
(Var v) =>
|
||||
Map v (Reference.Id, DataDeclaration v a) ->
|
||||
Map v (Reference.Id, EffectDeclaration v a) ->
|
||||
[[(v, Term v a, Type v a)]] ->
|
||||
[(WatchKind, [(v, Term v a, Type v a)])] ->
|
||||
[[(v, a, Term v a, Type v a)]] ->
|
||||
[(WatchKind, [(v, a, Term v a, Type v a)])] ->
|
||||
TypecheckedUnisonFile v a
|
||||
typecheckedUnisonFile datas effects tlcs watches =
|
||||
TypecheckedUnisonFileId datas effects tlcs watches hashImpl
|
||||
where
|
||||
hashImpl :: (Map v (a, Reference.Id, Maybe WatchKind, Term v a, Type v a))
|
||||
hashImpl =
|
||||
let -- includes watches
|
||||
allTerms :: [(v, Term v a, Type v a)]
|
||||
allTerms :: [(v, a, Term v a, Type v a)]
|
||||
allTerms = join tlcs ++ join (snd <$> watches)
|
||||
types :: Map v (Type v a)
|
||||
types = Map.fromList [(v, t) | (v, _, t) <- allTerms]
|
||||
types = Map.fromList [(v, t) | (v, _a, _, t) <- allTerms]
|
||||
watchKinds :: Map v (Maybe WatchKind)
|
||||
watchKinds =
|
||||
Map.fromList $
|
||||
[(v, Nothing) | (v, _e, _t) <- join tlcs]
|
||||
++ [(v, Just wk) | (wk, wkTerms) <- watches, (v, _e, _t) <- wkTerms]
|
||||
hcs = Hashing.hashTermComponents $ Map.fromList $ (\(v, e, t) -> (v, (e, t))) <$> allTerms
|
||||
[(v, Nothing) | (v, _a, _e, _t) <- join tlcs]
|
||||
++ [(v, Just wk) | (wk, wkTerms) <- watches, (v, _a, _e, _t) <- wkTerms]
|
||||
hcs :: Map v (Reference.Id, Term v a, Type v a, a)
|
||||
hcs = Hashing.hashTermComponents $ Map.fromList $ (\(v, a, e, t) -> (v, (e, t, a))) <$> allTerms
|
||||
in Map.fromList
|
||||
[ (v, (r, wk, e, t))
|
||||
| (v, (r, e, _typ)) <- Map.toList hcs,
|
||||
[ (v, (a, r, wk, e, t))
|
||||
| (v, (r, e, _typ, a)) <- Map.toList hcs,
|
||||
Just t <- [Map.lookup v types],
|
||||
wk <- [Map.findWithDefault (error $ show v ++ " missing from watchKinds") v watchKinds]
|
||||
]
|
||||
@ -137,7 +150,7 @@ lookupDecl v uf =
|
||||
|
||||
indexByReference ::
|
||||
TypecheckedUnisonFile v a ->
|
||||
(Map Reference.Id (Term v a, Type v a), Map Reference.Id (DD.Decl v a))
|
||||
(Map Reference.Id (a, Term v a, Type v a), Map Reference.Id (DD.Decl v a))
|
||||
indexByReference uf = (tms, tys)
|
||||
where
|
||||
tys =
|
||||
@ -145,7 +158,7 @@ indexByReference uf = (tms, tys)
|
||||
<> Map.fromList (over _2 Left <$> toList (effectDeclarationsId' uf))
|
||||
tms =
|
||||
Map.fromList
|
||||
[ (r, (tm, ty)) | (Reference.DerivedId r, _wk, tm, ty) <- toList (hashTerms uf)
|
||||
[ (r, (a, tm, ty)) | (a, Reference.DerivedId r, _wk, tm, ty) <- Map.elems (hashTerms uf)
|
||||
]
|
||||
|
||||
-- | A mapping of all terms in the file by their var name.
|
||||
@ -154,12 +167,12 @@ indexByReference uf = (tms, tys)
|
||||
-- Includes test watches.
|
||||
allTerms :: (Ord v) => TypecheckedUnisonFile v a -> Map v (Term v a)
|
||||
allTerms uf =
|
||||
Map.fromList [(v, t) | (v, t, _) <- join $ topLevelComponents uf]
|
||||
Map.fromList [(v, t) | (v, _a, t, _) <- join $ topLevelComponents uf]
|
||||
|
||||
-- | the top level components (no watches) plus test watches.
|
||||
topLevelComponents ::
|
||||
TypecheckedUnisonFile v a ->
|
||||
[[(v, Term v a, Type v a)]]
|
||||
[[(v, a, Term v a, Type v a)]]
|
||||
topLevelComponents file =
|
||||
topLevelComponents' file ++ [comp | (TestWatch, comp) <- watchComponents file]
|
||||
|
||||
@ -171,7 +184,7 @@ termSignatureExternalLabeledDependencies
|
||||
Set.difference
|
||||
( Set.map LD.typeRef
|
||||
. foldMap Type.dependencies
|
||||
. fmap (\(_r, _wk, _e, t) -> t)
|
||||
. fmap (\(_a, _r, _wk, _e, t) -> t)
|
||||
. toList
|
||||
$ hashTerms
|
||||
)
|
||||
@ -187,14 +200,14 @@ dependencies :: (Monoid a, Var v) => UnisonFile v a -> Set Reference
|
||||
dependencies (UnisonFile ds es ts ws) =
|
||||
foldMap (DD.dependencies . snd) ds
|
||||
<> foldMap (DD.dependencies . DD.toDataDecl . snd) es
|
||||
<> foldMap (Term.dependencies . snd) ts
|
||||
<> foldMap (foldMap (Term.dependencies . snd)) ws
|
||||
<> foldMap (Term.dependencies . view _3) ts
|
||||
<> foldMap (foldMap (Term.dependencies . view _3)) ws
|
||||
|
||||
discardTypes :: TypecheckedUnisonFile v a -> UnisonFile v a
|
||||
discardTypes (TypecheckedUnisonFileId datas effects terms watches _) =
|
||||
let watches' = g . mconcat <$> List.multimap watches
|
||||
g tup3s = [(v, e) | (v, e, _t) <- tup3s]
|
||||
in UnisonFileId datas effects [(a, b) | (a, b, _) <- join terms] watches'
|
||||
g tup3s = [(v, a, e) | (v, a, e, _t) <- tup3s]
|
||||
in UnisonFileId datas effects [(v, a, trm) | (v, a, trm, _typ) <- join terms] watches'
|
||||
|
||||
declsToTypeLookup :: (Var v) => UnisonFile v a -> TL.TypeLookup v a
|
||||
declsToTypeLookup uf =
|
||||
|
@ -1,5 +1,6 @@
|
||||
module Unison.UnisonFile.Names where
|
||||
|
||||
import Control.Lens
|
||||
import Data.Map qualified as Map
|
||||
import Data.Set qualified as Set
|
||||
import Unison.ABT qualified as ABT
|
||||
@ -7,7 +8,7 @@ import Unison.DataDeclaration (DataDeclaration, EffectDeclaration (..))
|
||||
import Unison.DataDeclaration qualified as DD
|
||||
import Unison.DataDeclaration.Names qualified as DD.Names
|
||||
import Unison.Hashing.V2.Convert qualified as Hashing
|
||||
import Unison.Names (Names (Names))
|
||||
import Unison.Names (Names (..))
|
||||
import Unison.Names.ResolutionResult qualified as Names
|
||||
import Unison.Prelude
|
||||
import Unison.Reference qualified as Reference
|
||||
@ -34,7 +35,7 @@ typecheckedToNames uf = Names (terms <> ctors) types
|
||||
terms =
|
||||
Relation.fromList
|
||||
[ (Name.unsafeFromVar v, Referent.Ref r)
|
||||
| (v, (r, wk, _, _)) <- Map.toList $ UF.hashTerms uf,
|
||||
| (v, (_a, r, wk, _, _)) <- Map.toList $ UF.hashTerms uf,
|
||||
wk == Nothing || wk == Just WK.TestWatch
|
||||
]
|
||||
types =
|
||||
@ -72,11 +73,11 @@ bindNames names (UnisonFileId d e ts ws) = do
|
||||
-- todo: consider having some kind of binding structure for terms & watches
|
||||
-- so that you don't weirdly have free vars to tiptoe around.
|
||||
-- The free vars should just be the things that need to be bound externally.
|
||||
let termVars = (fst <$> ts) ++ (Map.elems ws >>= map fst)
|
||||
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, t) -> (v,) <$> Term.bindNames Name.unsafeFromVar termVarsSet names t) ts
|
||||
ws' <- traverse (traverse (\(v, t) -> (v,) <$> Term.bindNames Name.unsafeFromVar termVarsSet names t)) ws
|
||||
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
|
||||
pure $ UnisonFileId d e ts' ws'
|
||||
|
||||
-- This function computes hashes for data and effect declarations, and
|
||||
|
@ -17,16 +17,16 @@ import Unison.WatchKind (WatchKind)
|
||||
data UnisonFile v a = UnisonFileId
|
||||
{ dataDeclarationsId :: Map v (TermReferenceId, DataDeclaration v a),
|
||||
effectDeclarationsId :: Map v (TermReferenceId, EffectDeclaration v a),
|
||||
terms :: [(v, Term v a)],
|
||||
watches :: Map WatchKind [(v, Term v a)]
|
||||
terms :: [(v, a {- ann for whole binding -}, Term v a)],
|
||||
watches :: Map WatchKind [(v, a {- ann for whole watch -}, Term v a)]
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
pattern UnisonFile ::
|
||||
Map v (TypeReference, DataDeclaration v a) ->
|
||||
Map v (TypeReference, EffectDeclaration v a) ->
|
||||
[(v, Term v a)] ->
|
||||
Map WatchKind [(v, Term v a)] ->
|
||||
[(v, a, Term v a)] ->
|
||||
Map WatchKind [(v, a, Term v a)] ->
|
||||
UnisonFile v a
|
||||
pattern UnisonFile ds es tms ws <-
|
||||
UnisonFileId
|
||||
@ -42,9 +42,9 @@ pattern UnisonFile ds es tms ws <-
|
||||
data TypecheckedUnisonFile v a = TypecheckedUnisonFileId
|
||||
{ dataDeclarationsId' :: Map v (TypeReferenceId, DataDeclaration v a),
|
||||
effectDeclarationsId' :: Map v (TypeReferenceId, EffectDeclaration v a),
|
||||
topLevelComponents' :: [[(v, Term v a, Type v a)]],
|
||||
watchComponents :: [(WatchKind, [(v, Term v a, Type v a)])],
|
||||
hashTermsId :: Map v (TermReferenceId, Maybe WatchKind, Term v a, Type v a)
|
||||
topLevelComponents' :: [[(v, a {- ann for whole binding -}, Term v a, Type v a)]],
|
||||
watchComponents :: [(WatchKind, [(v, a {- ann for whole watch -}, Term v a, Type v a)])],
|
||||
hashTermsId :: Map v (a {- ann for whole binding -}, TermReferenceId, Maybe WatchKind, Term v a, Type v a)
|
||||
}
|
||||
deriving stock (Generic, Show)
|
||||
|
||||
@ -53,11 +53,12 @@ data TypecheckedUnisonFile v a = TypecheckedUnisonFileId
|
||||
pattern TypecheckedUnisonFile ::
|
||||
Map v (TypeReference, DataDeclaration v a) ->
|
||||
Map v (TypeReference, EffectDeclaration v a) ->
|
||||
[[(v, Term v a, Type v a)]] ->
|
||||
[(WatchKind, [(v, Term v a, Type v a)])] ->
|
||||
[[(v, a, Term v a, Type v a)]] ->
|
||||
[(WatchKind, [(v, a, Term v a, Type v a)])] ->
|
||||
Map
|
||||
v
|
||||
( TermReference,
|
||||
( a,
|
||||
TermReference,
|
||||
Maybe WatchKind,
|
||||
ABT.Term (Term.F v a a) v a,
|
||||
ABT.Term Type.F v a
|
||||
@ -69,14 +70,16 @@ pattern TypecheckedUnisonFile ds es tlcs wcs hts <-
|
||||
(fmap (first Reference.DerivedId) -> es)
|
||||
tlcs
|
||||
wcs
|
||||
(fmap (over _1 Reference.DerivedId) -> hts)
|
||||
(fmap (over _2 Reference.DerivedId) -> hts)
|
||||
|
||||
instance (Ord v) => Functor (TypecheckedUnisonFile v) where
|
||||
fmap f (TypecheckedUnisonFileId ds es tlcs wcs hashTerms) =
|
||||
TypecheckedUnisonFileId ds' es' tlcs' wcs' hashTerms'
|
||||
where
|
||||
ds' = fmap (\(id, dd) -> (id, fmap f dd)) ds
|
||||
es' = fmap (\(id, ed) -> (id, fmap f ed)) es
|
||||
tlcs' = (fmap . fmap) (\(v, tm, tp) -> (v, Term.amap f tm, fmap f tp)) tlcs
|
||||
wcs' = map (\(wk, tms) -> (wk, map (\(v, tm, tp) -> (v, Term.amap f tm, fmap f tp)) tms)) wcs
|
||||
hashTerms' = fmap (\(id, wk, tm, tp) -> (id, wk, Term.amap f tm, fmap f tp)) hashTerms
|
||||
ds' = ds <&> \(refId, decl) -> (refId, fmap f decl)
|
||||
es' = es <&> \(refId, effect) -> (refId, fmap f effect)
|
||||
tlcs' =
|
||||
tlcs
|
||||
& (fmap . fmap) \(v, a, tm, tp) -> (v, f a, Term.amap f tm, fmap f tp)
|
||||
wcs' = map (\(wk, tms) -> (wk, map (\(v, a, tm, tp) -> (v, f a, Term.amap f tm, fmap f tp)) tms)) wcs
|
||||
hashTerms' = fmap (\(a, id, wk, tm, tp) -> (f a, id, wk, Term.amap f tm, fmap f tp)) hashTerms
|
||||
|
@ -148,7 +148,7 @@ resultTest rt uf filepath = do
|
||||
Right tm -> do
|
||||
-- compare the the watch expression from the .u with the expr in .ur
|
||||
let watchResult = head (view _5 <$> Map.elems watches)
|
||||
tm' = Term.letRec' False bindings watchResult
|
||||
tm' = Term.letRec' False (bindings <&> \(sym, tm) -> (sym, (), tm)) watchResult
|
||||
-- note . show $ tm'
|
||||
-- note . show $ Term.amap (const ()) tm
|
||||
expectEqual tm' (Term.amap (const ()) tm)
|
||||
|
@ -86,10 +86,10 @@ typecheckTerm tm = do
|
||||
let v = Symbol 0 (Var.Inference Var.Other)
|
||||
liftIO $
|
||||
fmap extract
|
||||
<$> Codebase.runTransaction codebase (typecheckFile' codebase [] (UF.UnisonFileId mempty mempty [(v, tm)] mempty))
|
||||
<$> Codebase.runTransaction codebase (typecheckFile' codebase [] (UF.UnisonFileId mempty mempty [(v, External, tm)] mempty))
|
||||
where
|
||||
extract tuf
|
||||
| [[(_, _, ty)]] <- UF.topLevelComponents' tuf = ty
|
||||
| [[(_, _, _, ty)]] <- UF.topLevelComponents' tuf = ty
|
||||
| otherwise = error "internal error: typecheckTerm"
|
||||
|
||||
typecheckFile' ::
|
||||
|
@ -64,8 +64,8 @@ createAuthorInfo a t = createAuthorInfo' . unpack <$> liftIO (getRandomBytes 32)
|
||||
Term v a ->
|
||||
(Reference.Id, Term v a)
|
||||
hashAndWrangle v typ tm =
|
||||
case Foldable.toList $ H.hashTermComponents (Map.singleton (Var.named v) (tm, typ)) of
|
||||
[(id, tm, _tp)] -> (id, tm)
|
||||
case Foldable.toList $ H.hashTermComponents (Map.singleton (Var.named v) (tm, typ, ())) of
|
||||
[(id, tm, _tp, ())] -> (id, tm)
|
||||
_ -> error "hashAndWrangle: Expected a single definition."
|
||||
(chType, chTypeRef) = (Type.ref a chTypeRef, IOSource.copyrightHolderRef)
|
||||
(authorType, authorTypeRef) = (Type.ref a authorTypeRef, IOSource.authorRef)
|
||||
|
@ -1370,7 +1370,7 @@ loop e = do
|
||||
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]
|
||||
terms = [(Name.unsafeFromVar 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
|
||||
@ -1971,7 +1971,7 @@ handleIOTest main = do
|
||||
-- First, look at the terms in the latest typechecked file for a name-match.
|
||||
whenJustM Cli.getLatestTypecheckedFile \typecheckedFile -> do
|
||||
whenJust (HQ.toName main) \mainName ->
|
||||
whenJust (Map.lookup (Name.toVar mainName) (UF.hashTermsId typecheckedFile)) \(ref, _wk, _term, typ) ->
|
||||
whenJust (Map.lookup (Name.toVar mainName) (UF.hashTermsId typecheckedFile)) \(_, ref, _wk, _term, typ) ->
|
||||
returnMatches [(Reference.fromId ref, typ)]
|
||||
|
||||
-- Then, if we get here (because nothing in the scratch file matched), look at the terms in the codebase.
|
||||
@ -2206,14 +2206,14 @@ doDisplay outputLoc names tm = do
|
||||
evalUnisonTermE True (PPE.suffixifiedPPE ppe) useCache (Term.amap (const External) tm)
|
||||
loadTerm (Reference.DerivedId r) = case Map.lookup r tms of
|
||||
Nothing -> fmap (fmap Term.unannotate) $ Cli.runTransaction (Codebase.getTerm codebase r)
|
||||
Just (tm, _) -> pure (Just $ Term.unannotate tm)
|
||||
Just (_, tm, _) -> pure (Just $ Term.unannotate tm)
|
||||
loadTerm _ = pure Nothing
|
||||
loadDecl (Reference.DerivedId r) = case Map.lookup r typs of
|
||||
Nothing -> fmap (fmap $ DD.amap (const ())) $ Cli.runTransaction $ Codebase.getTypeDeclaration codebase r
|
||||
Just decl -> pure (Just $ DD.amap (const ()) decl)
|
||||
loadDecl _ = pure Nothing
|
||||
loadTypeOfTerm' (Referent.Ref (Reference.DerivedId r))
|
||||
| Just (_, ty) <- Map.lookup r tms = pure $ Just (void ty)
|
||||
| Just (_, _, ty) <- Map.lookup r tms = pure $ Just (void ty)
|
||||
loadTypeOfTerm' r = fmap (fmap void) . Cli.runTransaction . loadTypeOfTerm codebase $ r
|
||||
rendered <-
|
||||
DisplayValues.displayTerm
|
||||
@ -2937,7 +2937,7 @@ addWatch watchName (Just uf) = do
|
||||
let components = join $ UF.topLevelComponents uf
|
||||
let mainComponent = filter ((\v -> Var.nameStr v == watchName) . view _1) components
|
||||
case mainComponent of
|
||||
[(v, tm, ty)] ->
|
||||
[(v, ann, tm, ty)] ->
|
||||
Just $
|
||||
let v2 = Var.freshIn (Set.fromList [v]) v
|
||||
a = ABT.annotation tm
|
||||
@ -2946,7 +2946,7 @@ addWatch watchName (Just uf) = do
|
||||
(UF.dataDeclarationsId' uf)
|
||||
(UF.effectDeclarationsId' uf)
|
||||
(UF.topLevelComponents' uf)
|
||||
(UF.watchComponents uf <> [(WK.RegularWatch, [(v2, Term.var a v, ty)])])
|
||||
(UF.watchComponents uf <> [(WK.RegularWatch, [(v2, ann, Term.var a v, ty)])])
|
||||
)
|
||||
_ -> addWatch watchName Nothing
|
||||
|
||||
@ -2964,7 +2964,7 @@ addSavedTermToUnisonFile resultName = do
|
||||
UF.typecheckedUnisonFile
|
||||
(UF.dataDeclarationsId' uf)
|
||||
(UF.effectDeclarationsId' uf)
|
||||
([(resultSymbol, trm, typ)] : UF.topLevelComponents' uf)
|
||||
([(resultSymbol, External, trm, typ)] : UF.topLevelComponents' uf)
|
||||
(UF.watchComponents uf)
|
||||
|
||||
-- | Look up runnable term with the given name in the codebase or
|
||||
@ -3006,7 +3006,7 @@ getTerm' mainName =
|
||||
let components = join $ UF.topLevelComponents uf
|
||||
let mainComponent = filter ((\v -> Var.nameStr v == mainName) . view _1) components
|
||||
case mainComponent of
|
||||
[(v, tm, ty)] ->
|
||||
[(v, _, tm, ty)] ->
|
||||
checkType ty \otyp ->
|
||||
let runMain = DD.forceTerm a a (Term.var a v)
|
||||
v2 = Var.freshIn (Set.fromList [v]) v
|
||||
@ -3028,7 +3028,7 @@ getTerm' mainName =
|
||||
createWatcherFile :: Symbol -> Term Symbol Ann -> Type Symbol Ann -> Cli (TypecheckedUnisonFile Symbol Ann)
|
||||
createWatcherFile v tm typ =
|
||||
Cli.getLatestTypecheckedFile >>= \case
|
||||
Nothing -> pure (UF.typecheckedUnisonFile mempty mempty mempty [(magicMainWatcherString, [(v, tm, typ)])])
|
||||
Nothing -> pure (UF.typecheckedUnisonFile mempty mempty mempty [(magicMainWatcherString, [(v, External, tm, typ)])])
|
||||
Just uf ->
|
||||
let v2 = Var.freshIn (Set.fromList [v]) v
|
||||
in pure $
|
||||
@ -3037,7 +3037,7 @@ createWatcherFile v tm typ =
|
||||
(UF.effectDeclarationsId' uf)
|
||||
(UF.topLevelComponents' uf)
|
||||
-- what about main's component? we have dropped them if they existed.
|
||||
[(magicMainWatcherString, [(v2, tm, typ)])]
|
||||
[(magicMainWatcherString, [(v2, External, tm, typ)])]
|
||||
|
||||
executePPE ::
|
||||
(Var v) =>
|
||||
@ -3231,7 +3231,7 @@ evalUnisonTerm sandbox ppe useCache tm =
|
||||
stripUnisonFileReferences :: TypecheckedUnisonFile Symbol a -> Term Symbol () -> Term Symbol ()
|
||||
stripUnisonFileReferences unisonFile term =
|
||||
let refMap :: Map Reference.Id Symbol
|
||||
refMap = Map.fromList . map (\(sym, (refId, _, _, _)) -> (refId, sym)) . Map.toList . UF.hashTermsId $ unisonFile
|
||||
refMap = Map.fromList . map (\(sym, (_, refId, _, _, _)) -> (refId, sym)) . Map.toList . UF.hashTermsId $ unisonFile
|
||||
alg () = \case
|
||||
ABT.Var x -> ABT.var x
|
||||
ABT.Cycle x -> ABT.cycle x
|
||||
|
@ -105,7 +105,7 @@ handleUpdate input optionalPatch requestedNames = do
|
||||
hashTerms :: Map Reference (Type Symbol Ann)
|
||||
hashTerms = Map.fromList (toList hashTerms0)
|
||||
where
|
||||
hashTerms0 = (\(r, _wk, _tm, typ) -> (r, typ)) <$> UF.hashTerms (Slurp.originalFile sr)
|
||||
hashTerms0 = (\(_ann, r, _wk, _tm, typ) -> (r, typ)) <$> UF.hashTerms (Slurp.originalFile sr)
|
||||
termEdits :: [(Name, Reference, Reference)]
|
||||
termEdits = do
|
||||
v <- Set.toList (SC.terms (updates sr))
|
||||
@ -253,7 +253,7 @@ getSlurpResultForUpdate requestedNames slurpCheckNames = do
|
||||
-- Running example:
|
||||
--
|
||||
-- "ping" => (#newping, Nothing, <#wham + 4>, <Nat>)
|
||||
let nameToInterimInfo :: Map Symbol (TermReferenceId, Maybe WatchKind, Term Symbol Ann, Type Symbol Ann)
|
||||
let nameToInterimInfo :: Map Symbol (Ann, TermReferenceId, Maybe WatchKind, Term Symbol Ann, Type Symbol Ann)
|
||||
nameToInterimInfo =
|
||||
UF.hashTermsId (Slurp.originalFile slurp0)
|
||||
|
||||
@ -278,7 +278,7 @@ getSlurpResultForUpdate requestedNames slurpCheckNames = do
|
||||
( \name ->
|
||||
case Map.lookup name nameToInterimInfo of
|
||||
Nothing -> error (reportBug "E798907" "no interim ref for name")
|
||||
Just (interimRef, _, _, _) -> (nameToTermRefs name, interimRef)
|
||||
Just (_, interimRef, _, _, _) -> (nameToTermRefs name, interimRef)
|
||||
)
|
||||
namesBeingUpdated
|
||||
|
||||
@ -409,7 +409,7 @@ getSlurpResultForUpdate requestedNames slurpCheckNames = do
|
||||
interimTermComponents =
|
||||
nameToInterimInfo
|
||||
& Map.elems
|
||||
& map (\(ref, _wk, term, typ) -> (ref, (term, typ)))
|
||||
& map (\(_ann, ref, _wk, term, typ) -> (ref, (term, typ)))
|
||||
& componentize
|
||||
& uncomponentize
|
||||
|
||||
@ -479,7 +479,7 @@ getSlurpResultForUpdate requestedNames slurpCheckNames = do
|
||||
-- #newping => <#wham + 4>
|
||||
interimRefToTerm :: Map TermReferenceId (Term Symbol Ann)
|
||||
interimRefToTerm =
|
||||
Map.remap (\(_var, (ref, _wk, term, _typ)) -> (ref, term)) nameToInterimInfo
|
||||
Map.remap (\(_var, (_ann, ref, _wk, term, _typ)) -> (ref, term)) nameToInterimInfo
|
||||
-- Running example: apply the following reference mapping everwhere in a term:
|
||||
--
|
||||
-- #pingpong.ping -> #newping
|
||||
@ -504,7 +504,9 @@ getSlurpResultForUpdate requestedNames slurpCheckNames = do
|
||||
-- fresh1 = fresh3 + 4
|
||||
-- fresh2 = fresh1 + 2
|
||||
-- fresh3 = fresh2 + 3
|
||||
terms = Map.elems refToGeneratedNameAndTerm,
|
||||
terms =
|
||||
Map.elems refToGeneratedNameAndTerm <&> \(v, term) ->
|
||||
(v, External, term),
|
||||
-- In the context of this update, whatever watches were in the latest typechecked Unison file are
|
||||
-- irrelevant, so we don't need to copy them over.
|
||||
watches = Map.empty
|
||||
@ -539,15 +541,16 @@ getSlurpResultForUpdate requestedNames slurpCheckNames = do
|
||||
-- #newping => "ping"
|
||||
interimRefToName :: Map TermReferenceId Symbol
|
||||
interimRefToName =
|
||||
Map.remap (\(name, (ref, _wk, _term, _typ)) -> (ref, name)) nameToInterimInfo
|
||||
Map.remap (\(name, (_ann, ref, _wk, _term, _typ)) -> (ref, name)) nameToInterimInfo
|
||||
|
||||
let renameTerm ::
|
||||
(Symbol, Term Symbol Ann, Type Symbol Ann) ->
|
||||
(Symbol, Term Symbol Ann, Type Symbol Ann)
|
||||
renameTerm (generatedName, term, typ) =
|
||||
(Symbol, Ann, Term Symbol Ann, Type Symbol Ann) ->
|
||||
(Symbol, Ann, Term Symbol Ann, Type Symbol Ann)
|
||||
renameTerm (generatedName, ann, term, typ) =
|
||||
( case Map.lookup generatedName generatedNameToName of
|
||||
Just name -> name
|
||||
Nothing -> error (reportBug "E440546" "no name for generated name"),
|
||||
ann,
|
||||
ABT.renames generatedNameToName term,
|
||||
typ
|
||||
)
|
||||
@ -589,7 +592,7 @@ doSlurpAdds slurp uf = Branch.batchUpdates (typeActions <> termActions)
|
||||
map doTerm . toList $
|
||||
SC.terms slurp <> UF.constructorsForDecls (SC.types slurp) uf
|
||||
names = UF.typecheckedToNames uf
|
||||
tests = Set.fromList $ fst <$> UF.watchesOfKind WK.TestWatch (UF.discardTypes uf)
|
||||
tests = Set.fromList $ view _1 <$> UF.watchesOfKind WK.TestWatch (UF.discardTypes uf)
|
||||
(isTestType, isTestValue) = IOSource.isTest
|
||||
md v =
|
||||
if Set.member v tests
|
||||
|
@ -545,10 +545,19 @@ propagate patch b = case validatePatch patch of
|
||||
UnisonFileId
|
||||
mempty
|
||||
mempty
|
||||
(Map.toList $ (\(_, tm, _) -> tm) <$> componentMap)
|
||||
( componentMap
|
||||
& Map.toList
|
||||
& fmap
|
||||
( \(v, (_ref, tm, _)) ->
|
||||
(v, External, tm)
|
||||
)
|
||||
)
|
||||
mempty
|
||||
typecheckResult <- Cli.typecheckFile' codebase [] file
|
||||
pure . fmap UF.hashTerms $ Result.result typecheckResult
|
||||
runIdentity (Result.toMaybe typecheckResult)
|
||||
& fmap UF.hashTerms
|
||||
& (fmap . fmap) (\(_ann, ref, wk, tm, tp) -> (ref, wk, tm, tp))
|
||||
& pure
|
||||
|
||||
-- TypecheckFile file ambient -> liftIO $ typecheck' ambient codebase file
|
||||
unhashTypeComponent :: Reference -> Sqlite.Transaction (Map Symbol (Reference, Decl Symbol Ann))
|
||||
|
@ -280,13 +280,13 @@ buildVarReferences uf =
|
||||
-- Filter out non-test watch expressions
|
||||
& Map.filter
|
||||
( \case
|
||||
(_, w, _, _)
|
||||
(_, _, w, _, _)
|
||||
| w == Just TestWatch || w == Nothing -> True
|
||||
| otherwise -> False
|
||||
)
|
||||
& Map.bimap
|
||||
TermVar
|
||||
(\(refId, _, _, _) -> LD.derivedTerm refId)
|
||||
(\(_, refId, _, _, _) -> LD.derivedTerm refId)
|
||||
decls :: Map TaggedVar LD.LabeledDependency
|
||||
decls =
|
||||
UF.dataDeclarationsId' uf
|
||||
|
@ -193,7 +193,7 @@ pretty isPast ppe sr =
|
||||
okTerm v = case Map.lookup v tms of
|
||||
Nothing ->
|
||||
[(P.bold (prettyVar v), Just $ P.red "(Unison bug, unknown term)")]
|
||||
Just (_, _, _, ty) ->
|
||||
Just (_, _, _, _, ty) ->
|
||||
( plus <> P.bold (prettyVar v),
|
||||
Just $ ": " <> P.indentNAfterNewline 2 (TP.pretty ppe ty)
|
||||
)
|
||||
@ -243,7 +243,7 @@ pretty isPast ppe sr =
|
||||
(typeLineFor Collision <$> toList (types (collisions sr)))
|
||||
++ (typeLineFor BlockedDependency <$> toList (types (defsWithBlockedDependencies sr)))
|
||||
termLineFor status v = case Map.lookup v tms of
|
||||
Just (_ref, _wk, _tm, ty) ->
|
||||
Just (_, _ref, _wk, _tm, ty) ->
|
||||
( prettyStatus status,
|
||||
P.bold (P.text $ Var.name v),
|
||||
": " <> P.indentNAfterNewline 6 (TP.pretty ppe ty)
|
||||
@ -348,4 +348,4 @@ filterUnisonFile
|
||||
effects = Map.restrictKeys effectDeclarations' keepTypes
|
||||
tlcs = filter (not . null) $ fmap (List.filter filterTLC) topLevelComponents'
|
||||
watches = filter (not . null . snd) $ fmap (second (List.filter filterTLC)) watchComponents
|
||||
filterTLC (v, _, _) = Set.member v keepTerms
|
||||
filterTLC (v, _, _, _) = Set.member v keepTerms
|
||||
|
@ -109,7 +109,7 @@ mkFileSummary parsed typechecked = case (parsed, typechecked) of
|
||||
(Nothing, Nothing) -> Nothing
|
||||
(_, Just tf@(UF.TypecheckedUnisonFileId {dataDeclarationsId', effectDeclarationsId', hashTermsId})) ->
|
||||
let (trms, testWatches, exprWatches) =
|
||||
hashTermsId & ifoldMap \sym (ref, wk, trm, typ) ->
|
||||
hashTermsId & ifoldMap \sym (_ann, ref, wk, trm, typ) ->
|
||||
case wk of
|
||||
Nothing -> (Map.singleton sym (Just ref, trm, getUserTypeAnnotation sym <|> Just typ), mempty, mempty)
|
||||
Just TestWatch -> (mempty, [(assertUserSym sym, Just ref, trm, getUserTypeAnnotation sym <|> Just typ)], mempty)
|
||||
@ -128,11 +128,11 @@ mkFileSummary parsed typechecked = case (parsed, typechecked) of
|
||||
}
|
||||
(Just uf@(UF.UnisonFileId {dataDeclarationsId, effectDeclarationsId, terms, watches}), _) ->
|
||||
let trms =
|
||||
terms & foldMap \(sym, trm) ->
|
||||
terms & foldMap \(sym, _ann, trm) ->
|
||||
(Map.singleton sym (Nothing, trm, Nothing))
|
||||
(testWatches, exprWatches) =
|
||||
watches & ifoldMap \wk tms ->
|
||||
tms & foldMap \(v, trm) ->
|
||||
tms & foldMap \(v, _ann, trm) ->
|
||||
case wk of
|
||||
TestWatch -> ([(assertUserSym v, Nothing, trm, Nothing)], mempty)
|
||||
_ -> (mempty, [(assertUserSym v, Nothing, trm, Nothing)])
|
||||
@ -166,7 +166,7 @@ mkFileSummary parsed typechecked = case (parsed, typechecked) of
|
||||
getUserTypeAnnotation :: Symbol -> Maybe (Type Symbol Ann)
|
||||
getUserTypeAnnotation v = do
|
||||
UF.UnisonFileId {terms, watches} <- parsed
|
||||
trm <- Prelude.lookup v (terms <> fold watches)
|
||||
trm <- (terms <> fold watches) ^? folded . filteredBy (_1 . only v) . _3
|
||||
typ <- Term.getTypeAnnotation trm
|
||||
pure typ
|
||||
|
||||
|
@ -29,7 +29,7 @@ foldingRangesForFile fileUri =
|
||||
UnisonFileId {dataDeclarationsId, effectDeclarationsId, terms} <- MaybeT $ pure parsedFile
|
||||
let dataFolds = dataDeclarationsId ^.. folded . _2 . to dataDeclSpan
|
||||
let abilityFolds = effectDeclarationsId ^.. folded . _2 . to DD.toDataDecl . to dataDeclSpan
|
||||
let termFolds = terms ^.. folded . _2 . to ABT.annotation
|
||||
let termFolds = terms ^.. folded . _3 . to ABT.annotation
|
||||
let folds = dataFolds <> abilityFolds <> termFolds
|
||||
let ranges = mapMaybe annToRange folds
|
||||
pure $ ranges <&> \r -> FoldingRange {_startLine = r ^. start . line, _startCharacter = Just (r ^. start . character), _endLine = r ^. end . line, _endCharacter = Just (r ^. end . character), _kind = Just FoldingRangeRegion}
|
||||
|
@ -254,7 +254,7 @@ makeNodeSelectionTest (name, testSrc, testTypechecked, expected) = scope name $
|
||||
pf <- maybe (crash (show ("Failed to parse" :: String, notes))) pure mayParsedFile
|
||||
let pfResult =
|
||||
UF.terms pf
|
||||
& firstJust \(_v, trm) ->
|
||||
& firstJust \(_v, _fileAnn, trm) ->
|
||||
LSPQ.findSmallestEnclosingNode pos trm
|
||||
expectEqual (Just expected) (void <$> pfResult)
|
||||
|
||||
@ -264,7 +264,7 @@ makeNodeSelectionTest (name, testSrc, testTypechecked, expected) = scope name $
|
||||
let tfResult =
|
||||
UF.hashTermsId tf
|
||||
& toList
|
||||
& firstJust \(_refId, _wk, trm, _typ) ->
|
||||
& firstJust \(_fileAnn, _refId, _wk, trm, _typ) ->
|
||||
LSPQ.findSmallestEnclosingNode pos trm
|
||||
expectEqual (Just expected) (void <$> tfResult)
|
||||
|
||||
@ -302,7 +302,7 @@ annotationNestingTest (name, src) = scope name do
|
||||
tf <- maybe (crash "Failed to typecheck") pure maytf
|
||||
UF.hashTermsId tf
|
||||
& toList
|
||||
& traverse_ \(_refId, _wk, trm, _typ) ->
|
||||
& traverse_ \(_fileAnn, _refId, _wk, trm, _typ) ->
|
||||
assertAnnotationsAreNested trm
|
||||
|
||||
-- | Asserts that for all nodes in the provided ABT, the annotations of all child nodes are
|
||||
|
@ -134,15 +134,15 @@ generateRecordAccessors ::
|
||||
[(v, a)] ->
|
||||
v ->
|
||||
Reference ->
|
||||
[(v, Term v a)]
|
||||
[(v, a, Term v a)]
|
||||
generateRecordAccessors fields typename typ =
|
||||
join [tm t i | (t, i) <- fields `zip` [(0 :: Int) ..]]
|
||||
where
|
||||
argname = Var.uncapitalize typename
|
||||
tm (fname, ann) i =
|
||||
[ (Var.namespaced [typename, fname], get),
|
||||
(Var.namespaced [typename, fname, Var.named "set"], set),
|
||||
(Var.namespaced [typename, fname, Var.named "modify"], modify)
|
||||
[ (Var.namespaced [typename, fname], ann, get),
|
||||
(Var.namespaced [typename, fname, Var.named "set"], ann, set),
|
||||
(Var.namespaced [typename, fname, Var.named "modify"], ann, modify)
|
||||
]
|
||||
where
|
||||
-- example: `point -> case point of Point x _ -> x`
|
||||
|
@ -3,7 +3,7 @@
|
||||
|
||||
module Unison.Term where
|
||||
|
||||
import Control.Lens (Lens', Prism', lens)
|
||||
import Control.Lens (Lens', Prism', lens, view, _2)
|
||||
import Control.Monad.State (evalState)
|
||||
import Control.Monad.Writer.Strict qualified as Writer
|
||||
import Data.Generics.Sum (_Ctor)
|
||||
@ -893,14 +893,14 @@ unLetRecNamedAnnotated _ = Nothing
|
||||
letRec' ::
|
||||
(Ord v, Monoid a) =>
|
||||
Bool ->
|
||||
[(v, Term' vt v a)] ->
|
||||
[(v, a, Term' vt v a)] ->
|
||||
Term' vt v a ->
|
||||
Term' vt v a
|
||||
letRec' isTop bindings body =
|
||||
letRec
|
||||
isTop
|
||||
(foldMap (ABT.annotation . snd) bindings <> ABT.annotation body)
|
||||
[((ABT.annotation b, v), b) | (v, b) <- bindings]
|
||||
(foldMap (view _2) bindings <> ABT.annotation body)
|
||||
[((a, v), b) | (v, a, b) <- bindings]
|
||||
body
|
||||
|
||||
-- Prepend a binding to form a (bigger) let rec. Useful when
|
||||
|
@ -90,22 +90,22 @@ refId :: (Ord v) => a -> ReferenceId -> Term2 vt at ap v a
|
||||
refId a = ref a . ReferenceDerivedId
|
||||
|
||||
hashTermComponents ::
|
||||
forall v a.
|
||||
forall v a extra.
|
||||
(Var v) =>
|
||||
Map v (Term v a, Type v a) ->
|
||||
Map v (ReferenceId, Term v a, Type v a)
|
||||
Map v (Term v a, Type v a, extra) ->
|
||||
Map v (ReferenceId, Term v a, Type v a, extra)
|
||||
hashTermComponents terms =
|
||||
Zip.zipWith keepType terms (ReferenceUtil.hashComponents (refId ()) terms')
|
||||
Zip.zipWith keepExtra terms (ReferenceUtil.hashComponents (refId ()) terms')
|
||||
where
|
||||
terms' :: Map v (Term v a)
|
||||
terms' = uncurry incorporateType <$> terms
|
||||
terms' = incorporateType <$> terms
|
||||
|
||||
keepType :: ((Term v a, Type v a) -> (ReferenceId, Term v a) -> (ReferenceId, Term v a, Type v a))
|
||||
keepType (_oldTrm, typ) (refId, trm) = (refId, trm, typ)
|
||||
keepExtra :: ((Term v a, Type v a, extra) -> (ReferenceId, Term v a) -> (ReferenceId, Term v a, Type v a, extra))
|
||||
keepExtra (_oldTrm, typ, extra) (refId, trm) = (refId, trm, typ, extra)
|
||||
|
||||
incorporateType :: Term v a -> Type v a -> Term v a
|
||||
incorporateType a@(ABT.out -> ABT.Tm (TermAnn e _tp)) typ = ABT.tm' (ABT.annotation a) (TermAnn e typ)
|
||||
incorporateType e typ = ABT.tm' (ABT.annotation e) (TermAnn e typ)
|
||||
incorporateType :: (Term v a, Type v a, extra) -> Term v a
|
||||
incorporateType (a@(ABT.out -> ABT.Tm (TermAnn e _tp)), typ, _extra) = ABT.tm' (ABT.annotation a) (TermAnn e typ)
|
||||
incorporateType (e, typ, _extra) = ABT.tm' (ABT.annotation e) (TermAnn e typ)
|
||||
|
||||
-- keep these until we decide if we want to add the appropriate smart constructors back into this module
|
||||
-- incorporateType (Term.Ann' e _) typ = Term.ann () e typ
|
||||
|
@ -7,7 +7,8 @@ module Unison.Parser.Ann where
|
||||
import Unison.Lexer.Pos qualified as L
|
||||
|
||||
data Ann
|
||||
= Intrinsic -- { sig :: String, start :: L.Pos, end :: L.Pos }
|
||||
= -- Used for things like Builtins which don't have a source position.
|
||||
Intrinsic -- { sig :: String, start :: L.Pos, end :: L.Pos }
|
||||
| External
|
||||
| Ann {start :: L.Pos, end :: L.Pos}
|
||||
deriving (Eq, Ord, Show)
|
||||
|
Loading…
Reference in New Issue
Block a user