unisonweb/unison
1
0
Fork 0
mirror of https://github.com/unisonweb/unison.git synced 2024-09-11 10:35:57 +03:00
Code Issues Projects Releases Wiki Activity

Merge pull request #3881 from unisonweb/lsp/binding-annotations

Browse Source
This commit is contained in:
Arya Irani 2023-07-07 12:22:17 -04:00 committed by GitHub
commit 67e237450d
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
29 changed files with 207 additions and 153 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
parser-typechecker/src/Unison/Builtin/Terms.hs
View File

@ -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 ()

4
parser-typechecker/src/Unison/Codebase.hs
View File

@ -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

2
parser-typechecker/src/Unison/Codebase/CodeLookup/Util.hs
View File

@ -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]

10
parser-typechecker/src/Unison/Codebase/Runtime.hs
View File

@ -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) ->

3
parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs
View File

@ -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

23
parser-typechecker/src/Unison/FileParsers.hs
View File

@ -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)

21
parser-typechecker/src/Unison/Hashing/V2/Convert.hs
View File

@ -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

7
parser-typechecker/src/Unison/Runtime/ANF.hs
View File

@ -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)

4
parser-typechecker/src/Unison/Runtime/IOSource.hs
View File

@ -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 =

10
parser-typechecker/src/Unison/Syntax/DeclPrinter.hs
View File

@ -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

26
parser-typechecker/src/Unison/Syntax/FileParser.hs
View File

@ -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

61
parser-typechecker/src/Unison/UnisonFile.hs
View File

@ -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 =

11
parser-typechecker/src/Unison/UnisonFile/Names.hs
View File

@ -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

35
parser-typechecker/src/Unison/UnisonFile/Type.hs
View File

@ -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

2
parser-typechecker/tests/Unison/Test/UnisonSources.hs
View File

@ -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)

4
unison-cli/src/Unison/Cli/TypeCheck.hs
View File

@ -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' ::

4
unison-cli/src/Unison/Codebase/Editor/AuthorInfo.hs
View File

@ -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)

22
unison-cli/src/Unison/Codebase/Editor/HandleInput.hs
View File

@ -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

25
unison-cli/src/Unison/Codebase/Editor/HandleInput/Update.hs
View File

@ -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

13
unison-cli/src/Unison/Codebase/Editor/Propagate.hs
View File

@ -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))

4
unison-cli/src/Unison/Codebase/Editor/Slurp.hs
View File

@ -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

6
unison-cli/src/Unison/Codebase/Editor/SlurpResult.hs
View File

@ -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

8
unison-cli/src/Unison/LSP/FileAnalysis.hs
View File

@ -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

2
unison-cli/src/Unison/LSP/FoldingRange.hs
View File

@ -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}

6
unison-cli/tests/Unison/Test/LSP.hs
View File

@ -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

8
unison-core/src/Unison/DataDeclaration.hs
View File

@ -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`

8
unison-core/src/Unison/Term.hs
View File

@ -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

20
unison-hashing-v2/src/Unison/Hashing/V2/Term.hs
View File

@ -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

3
unison-syntax/src/Unison/Parser/Ann.hs
View File

@ -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)