mirror of
https://github.com/unisonweb/unison.git
synced 2024-10-04 05:37:14 +03:00
Merge branch 'trunk' into arya/jit-release
This commit is contained in:
Arya Irani
commit
a32b7c4d43
2
.github/workflows/ci.yaml
vendored
2
.github/workflows/ci.yaml
vendored
@ -21,7 +21,7 @@ env:
|
||||
ormolu_version: "0.5.2.0"
|
||||
racket_version: "8.7"
|
||||
ucm_local_bin: "ucm-local-bin"
|
||||
jit_version: "@unison/internal/releases/0.0.11"
|
||||
jit_version: "@unison/internal/releases/0.0.12"
|
||||
jit_src_scheme: "unison-jit-src/scheme-libs/racket"
|
||||
jit_dist: "unison-jit-dist"
|
||||
jit_generator_os: ubuntu-20.04
|
||||
|
||||
2
.github/workflows/haddocks.yaml
vendored
2
.github/workflows/haddocks.yaml
vendored
@ -59,7 +59,7 @@ jobs:
|
||||
stack-work-2_Linux
|
||||
|
||||
- name: install stack
|
||||
uses: ./.github/workflows/actions/install-stack
|
||||
uses: ./unison/.github/workflows/actions/install-stack
|
||||
|
||||
# One of the transcripts fails if the user's git name hasn't been set.
|
||||
- name: set git user info
|
||||
|
||||
@ -23,6 +23,8 @@ packages:
|
||||
lib/unison-util-cache
|
||||
lib/unison-util-relation
|
||||
lib/unison-util-rope
|
||||
lib/unison-util-file-embed
|
||||
lib/unison-util-nametree
|
||||
|
||||
parser-typechecker
|
||||
unison-core
|
||||
@ -46,7 +48,6 @@ source-repository-package
|
||||
constraints:
|
||||
fsnotify < 0.4,
|
||||
crypton-x509-store <= 1.6.8,
|
||||
lsp < 2.0.0.0,
|
||||
servant <= 0.19.1,
|
||||
optparse-applicative <= 0.17.1.0
|
||||
|
||||
|
||||
@ -29,7 +29,11 @@ Similarly, `save-always: true` only if a key hit means there will be nothing new
|
||||
|
||||
Backup restore keys: "Is there a prior run that would be worth starting out from? With the caveat that any irrelevant garbage it includes will be saved into this run too."
|
||||
|
||||
### Composite Actions
|
||||
### Reusability
|
||||
|
||||
Github supports splitting off "reusable workflows" (`jobs` that can be imported into another workflow), and "composite actions" (multi-step `steps` that can be imported into another `job`).
|
||||
|
||||
#### Composite actions
|
||||
|
||||
Needs to have `shell:` specified on every `run:`
|
||||
|
||||
@ -40,3 +44,9 @@ https://docs.github.com/en/actions/learn-github-actions/variables#default-enviro
|
||||
|
||||
Workflow syntax:
|
||||
https://docs.github.com/en/actions/using-workflows/workflow-syntax-for-github-actions
|
||||
|
||||
Reusable workflows:
|
||||
https://docs.github.com/en/actions/using-workflows/reusing-workflows
|
||||
|
||||
Composite actions:
|
||||
https://docs.github.com/en/actions/creating-actions/creating-a-composite-action
|
||||
|
||||
@ -95,9 +95,9 @@ hashFieldAccessors ppe declName vars declRef dd = do
|
||||
let typecheckingEnv :: Typechecker.Env v ()
|
||||
typecheckingEnv =
|
||||
Typechecker.Env
|
||||
{ Typechecker._ambientAbilities = mempty,
|
||||
Typechecker._typeLookup = typeLookup,
|
||||
Typechecker._termsByShortname = mempty
|
||||
{ ambientAbilities = mempty,
|
||||
typeLookup,
|
||||
termsByShortname = mempty
|
||||
}
|
||||
accessorsWithTypes :: [(v, Term.Term v (), Type.Type v ())] <-
|
||||
for accessors \(v, _a, trm) ->
|
||||
|
||||
@ -26,7 +26,7 @@ import Unison.Reference (Reference)
|
||||
import Unison.Referent qualified as Referent
|
||||
import Unison.Result (CompilerBug (..), Note (..), ResultT, pattern Result)
|
||||
import Unison.Result qualified as Result
|
||||
import Unison.Syntax.Name qualified as Name (toText, unsafeParseVar)
|
||||
import Unison.Syntax.Name qualified as Name (unsafeParseVar)
|
||||
import Unison.Syntax.Parser qualified as Parser
|
||||
import Unison.Term qualified as Term
|
||||
import Unison.Type qualified as Type
|
||||
@ -85,18 +85,19 @@ computeTypecheckingEnvironment shouldUseTndr ambientAbilities typeLookupf uf =
|
||||
tl <- typeLookupf (UF.dependencies uf)
|
||||
pure
|
||||
Typechecker.Env
|
||||
{ _ambientAbilities = ambientAbilities,
|
||||
_typeLookup = tl,
|
||||
_termsByShortname = Map.empty
|
||||
{ ambientAbilities = ambientAbilities,
|
||||
typeLookup = tl,
|
||||
termsByShortname = Map.empty
|
||||
}
|
||||
ShouldUseTndr'Yes parsingEnv -> do
|
||||
let preexistingNames = Parser.names parsingEnv
|
||||
tm = UF.typecheckingTerm uf
|
||||
possibleDeps =
|
||||
[ (Name.toText name, Var.name v, r)
|
||||
[ (name, shortname, r)
|
||||
| (name, r) <- Rel.toList (Names.terms preexistingNames),
|
||||
v <- Set.toList (Term.freeVars tm),
|
||||
name `Name.endsWithReverseSegments` List.NonEmpty.toList (Name.reverseSegments (Name.unsafeParseVar v))
|
||||
let shortname = Name.unsafeParseVar v,
|
||||
name `Name.endsWithReverseSegments` List.NonEmpty.toList (Name.reverseSegments shortname)
|
||||
]
|
||||
possibleRefs = Referent.toReference . view _3 <$> possibleDeps
|
||||
tl <- fmap (UF.declsToTypeLookup uf <>) (typeLookupf (UF.dependencies uf <> Set.fromList possibleRefs))
|
||||
@ -115,22 +116,23 @@ computeTypecheckingEnvironment shouldUseTndr ambientAbilities typeLookupf uf =
|
||||
[ (shortname, nr)
|
||||
| (name, shortname, r) <- possibleDeps,
|
||||
typ <- toList $ TL.typeOfReferent tl r,
|
||||
let nr = Typechecker.NamedReference name typ (Right r)
|
||||
let nr = Typechecker.NamedReference name typ (Context.ReplacementRef r)
|
||||
]
|
||||
<>
|
||||
-- local file TDNR possibilities
|
||||
[ (Var.name v, nr)
|
||||
[ (shortname, nr)
|
||||
| (name, r) <- Rel.toList (Names.terms $ UF.toNames uf),
|
||||
v <- Set.toList (Term.freeVars tm),
|
||||
name `Name.endsWithReverseSegments` List.NonEmpty.toList (Name.reverseSegments (Name.unsafeParseVar v)),
|
||||
let shortname = Name.unsafeParseVar v,
|
||||
name `Name.endsWithReverseSegments` List.NonEmpty.toList (Name.reverseSegments shortname),
|
||||
typ <- toList $ TL.typeOfReferent tl r,
|
||||
let nr = Typechecker.NamedReference (Name.toText name) typ (Right r)
|
||||
let nr = Typechecker.NamedReference name typ (Context.ReplacementRef r)
|
||||
]
|
||||
pure
|
||||
Typechecker.Env
|
||||
{ _ambientAbilities = ambientAbilities,
|
||||
_typeLookup = tl,
|
||||
_termsByShortname = fqnsByShortName
|
||||
{ ambientAbilities = ambientAbilities,
|
||||
typeLookup = tl,
|
||||
termsByShortname = fqnsByShortName
|
||||
}
|
||||
|
||||
synthesizeFile ::
|
||||
|
||||
@ -48,7 +48,7 @@ import Unison.Prelude
|
||||
import Unison.PrettyPrintEnv qualified as PPE
|
||||
import Unison.PrettyPrintEnv.Names qualified as PPE
|
||||
import Unison.Reference qualified as R
|
||||
import Unison.Referent (Referent, toReference, pattern Ref)
|
||||
import Unison.Referent (Referent, pattern Ref)
|
||||
import Unison.Result (Note (..))
|
||||
import Unison.Result qualified as Result
|
||||
import Unison.Settings qualified as Settings
|
||||
@ -626,12 +626,7 @@ renderTypeError e env src = case e of
|
||||
foldr
|
||||
sep
|
||||
id
|
||||
( sortBy
|
||||
( comparing length <> compare
|
||||
`on` (Text.splitOn "." . C.suggestionName)
|
||||
)
|
||||
suggestions
|
||||
)
|
||||
(sortBy (comparing length <> compare `on` (Name.segments . C.suggestionName)) suggestions)
|
||||
([], [], [])
|
||||
sep s@(C.Suggestion _ _ _ match) r =
|
||||
case match of
|
||||
@ -1187,19 +1182,16 @@ renderType env f t = renderType0 env f (0 :: Int) (cleanup t)
|
||||
where
|
||||
go = renderType0 env f
|
||||
|
||||
renderSuggestion ::
|
||||
(IsString s, Semigroup s, Var v) => Env -> C.Suggestion v loc -> s
|
||||
renderSuggestion :: (IsString s, Semigroup s, Var v) => Env -> C.Suggestion v loc -> s
|
||||
renderSuggestion env sug =
|
||||
renderTerm
|
||||
env
|
||||
( case C.suggestionReplacement sug of
|
||||
Right ref -> Term.ref () (toReference ref)
|
||||
Left v -> Term.var () v
|
||||
)
|
||||
renderTerm env term
|
||||
<> " : "
|
||||
<> renderType'
|
||||
env
|
||||
(C.suggestionType sug)
|
||||
<> renderType' env (C.suggestionType sug)
|
||||
where
|
||||
term =
|
||||
case C.suggestionReplacement sug of
|
||||
C.ReplacementRef ref -> Term.fromReferent () ref
|
||||
C.ReplacementVar v -> Term.var () v
|
||||
|
||||
spaces :: (IsString a, Monoid a) => (b -> a) -> [b] -> a
|
||||
spaces = intercalateMap " "
|
||||
|
||||
@ -187,9 +187,8 @@ pretty0 ::
|
||||
AmbientContext ->
|
||||
Term3 v PrintAnnotation ->
|
||||
m (Pretty SyntaxText)
|
||||
pretty0 a tm | precedence a == -2 && not (isBindingSoftHangable tm) = do
|
||||
-- precedence = -2 means this is a top level binding, and we allow
|
||||
-- use clause insertion here even when it otherwise wouldn't be
|
||||
pretty0 a tm | isTopLevelPrecedence (precedence a) && not (isBindingSoftHangable tm) = do
|
||||
-- we allow use clause insertion here even when it otherwise wouldn't be
|
||||
-- (as long as the tm isn't soft hangable, if it gets soft hung then
|
||||
-- adding use clauses beforehand will mess things up)
|
||||
tmp <- pretty0 (a {imports = im, precedence = -1}) tm
|
||||
@ -301,25 +300,24 @@ pretty0
|
||||
`hangHandler` ph
|
||||
]
|
||||
Delay' x
|
||||
| isLet x || p < 0 -> do
|
||||
let (im', uses) = calcImports im x
|
||||
let hang = if isSoftHangable x && null uses then PP.softHang else PP.hang
|
||||
px <- pretty0 (ac 0 Block im' doc) x
|
||||
pure . paren (p >= 3) $
|
||||
fmt S.ControlKeyword "do" `hang` PP.lines (uses <> [px])
|
||||
| Match' _ _ <- x -> do
|
||||
px <- pretty0 (ac 0 Block im doc) x
|
||||
let hang = if isSoftHangable x then PP.softHang else PP.hang
|
||||
pure . paren (p >= 3) $
|
||||
fmt S.ControlKeyword "do" `hang` px
|
||||
| otherwise -> do
|
||||
px <- pretty0 (ac 10 Normal im doc) x
|
||||
pure . paren (p >= 11 || isBlock x && p >= 3) $
|
||||
fmt S.DelayForceChar (l "'")
|
||||
-- Add indentation below since we're opening parens with '(
|
||||
-- This is in case the contents are a long function application
|
||||
-- in which case the arguments should be indented.
|
||||
<> PP.indentAfterNewline " " px
|
||||
let (im0', uses0) = calcImports im x
|
||||
let allowUses = isLet x || p < 0
|
||||
let im' = if allowUses then im0' else im
|
||||
let uses = if allowUses then uses0 else []
|
||||
let soft = isSoftHangable x && null uses && p < 3
|
||||
let hang = if soft then PP.softHang else PP.hang
|
||||
px <- pretty0 (ac 0 Block im' doc) x
|
||||
-- this makes sure we get proper indentation if `px` spills onto
|
||||
-- multiple lines, since `do` introduces layout block
|
||||
let indent = PP.Width (if soft then 2 else 0) + (if soft && p < 3 then 1 else 0)
|
||||
pure . paren (p >= 3) $
|
||||
fmt S.ControlKeyword "do" `hang` PP.lines (uses <> [PP.indentNAfterNewline indent px])
|
||||
List' xs -> do
|
||||
let listLink p = fmt (S.TypeReference Type.listRef) p
|
||||
let comma = listLink ", " `PP.orElse` ("\n" <> listLink ", ")
|
||||
@ -2171,3 +2169,7 @@ isLeaf (Constructor' {}) = True
|
||||
isLeaf (Request' {}) = True
|
||||
isLeaf (Ref' {}) = True
|
||||
isLeaf _ = False
|
||||
|
||||
-- | Indicates this is the RHS of a top-level definition.
|
||||
isTopLevelPrecedence :: Int -> Bool
|
||||
isTopLevelPrecedence i = i == -2
|
||||
|
||||
@ -1,7 +1,5 @@
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE OverloadedRecordDot #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
-- | This module is the primary interface to the Unison typechecker
|
||||
-- module Unison.Typechecker (admissibleTypeAt, check, check', checkAdmissible', equals, locals, subtype, isSubtype, synthesize, synthesize', typeAt, wellTyped) where
|
||||
@ -34,24 +32,20 @@ import Control.Monad.State
|
||||
import Control.Monad.Writer
|
||||
import Data.Foldable
|
||||
import Data.Map qualified as Map
|
||||
import Data.Sequence qualified as Seq
|
||||
import Data.Sequence.NonEmpty qualified as NESeq (toSeq)
|
||||
import Data.Set qualified as Set
|
||||
import Data.Text qualified as Text
|
||||
import Data.Tuple qualified as Tuple
|
||||
import Unison.ABT qualified as ABT
|
||||
import Unison.Blank qualified as B
|
||||
import Unison.Codebase.BuiltinAnnotation (BuiltinAnnotation)
|
||||
import Unison.Name qualified as Name
|
||||
import Unison.Prelude
|
||||
import Unison.PrettyPrintEnv (PrettyPrintEnv)
|
||||
import Unison.Referent (Referent)
|
||||
import Unison.Result
|
||||
( Result,
|
||||
ResultT,
|
||||
runResultT,
|
||||
pattern Result,
|
||||
)
|
||||
import Unison.Result (Result, ResultT, runResultT, pattern Result)
|
||||
import Unison.Result qualified as Result
|
||||
import Unison.Syntax.Name qualified as Name (toText, unsafeParseText)
|
||||
import Unison.Syntax.Name qualified as Name (unsafeParseText, unsafeParseVar)
|
||||
import Unison.Term (Term)
|
||||
import Unison.Term qualified as Term
|
||||
import Unison.Type (Type)
|
||||
@ -81,28 +75,27 @@ convertResult :: Context.Result v loc a -> Result (Notes v loc) a
|
||||
convertResult = \case
|
||||
Context.Success is a -> Result (Notes mempty mempty is) (Just a)
|
||||
Context.TypeError es is -> Result (Notes mempty (NESeq.toSeq es) is) Nothing
|
||||
Context.CompilerBug bug es is -> Result (Notes [bug] es is) Nothing
|
||||
Context.CompilerBug bug es is -> Result (Notes (Seq.singleton bug) es is) Nothing
|
||||
|
||||
data NamedReference v loc = NamedReference
|
||||
{ fqn :: Name,
|
||||
{ fqn :: Name.Name,
|
||||
fqnType :: Type v loc,
|
||||
replacement :: Either v Referent
|
||||
replacement :: Context.Replacement v
|
||||
}
|
||||
deriving (Show)
|
||||
deriving stock (Show)
|
||||
|
||||
data Env v loc = Env
|
||||
{ _ambientAbilities :: [Type v loc],
|
||||
_typeLookup :: TL.TypeLookup v loc,
|
||||
{ ambientAbilities :: [Type v loc],
|
||||
typeLookup :: TL.TypeLookup v loc,
|
||||
-- TDNR environment - maps short names like `+` to fully-qualified
|
||||
-- lists of named references whose full name matches the short name
|
||||
-- Example: `+` maps to [Nat.+, Float.+, Int.+]
|
||||
--
|
||||
-- This mapping is populated before typechecking with as few entries
|
||||
-- as are needed to help resolve variables needing TDNR in the file.
|
||||
_termsByShortname :: Map Name [NamedReference v loc]
|
||||
termsByShortname :: Map Name.Name [NamedReference v loc]
|
||||
}
|
||||
|
||||
makeLenses ''Env
|
||||
deriving stock (Generic)
|
||||
|
||||
-- | Infer the type of a 'Unison.Term', using
|
||||
-- a function to resolve the type of @Ref@ constructors
|
||||
@ -120,8 +113,8 @@ synthesize ppe pmccSwitch env t =
|
||||
Context.synthesizeClosed
|
||||
ppe
|
||||
pmccSwitch
|
||||
(TypeVar.liftType <$> view ambientAbilities env)
|
||||
(view typeLookup env)
|
||||
(TypeVar.liftType <$> env.ambientAbilities)
|
||||
env.typeLookup
|
||||
(TypeVar.liftTerm t)
|
||||
in Result.hoist (pure . runIdentity) $ fmap TypeVar.lowerType result
|
||||
|
||||
@ -188,16 +181,16 @@ synthesizeAndResolve ppe env = do
|
||||
|
||||
compilerBug :: Context.CompilerBug v loc -> Result (Notes v loc) ()
|
||||
compilerBug bug = do
|
||||
tell $ Notes [bug] mempty mempty
|
||||
tell $ Notes (Seq.singleton bug) mempty mempty
|
||||
Control.Monad.Fail.fail ""
|
||||
|
||||
typeError :: Context.ErrorNote v loc -> Result (Notes v loc) ()
|
||||
typeError note = do
|
||||
tell $ Notes mempty [note] mempty
|
||||
tell $ Notes mempty (Seq.singleton note) mempty
|
||||
Control.Monad.Fail.fail ""
|
||||
|
||||
btw :: (Monad f) => Context.InfoNote v loc -> ResultT (Notes v loc) f ()
|
||||
btw note = tell $ Notes mempty mempty [note]
|
||||
btw note = tell $ Notes mempty mempty (Seq.singleton note)
|
||||
|
||||
liftResult :: (Monad f) => Result (Notes v loc) a -> TDNR f v loc a
|
||||
liftResult = lift . MaybeT . WriterT . pure . runIdentity . runResultT
|
||||
@ -226,39 +219,35 @@ typeDirectedNameResolution ppe oldNotes oldType env = do
|
||||
-- Resolve blanks in the notes and generate some resolutions
|
||||
resolutions <-
|
||||
liftResult . traverse (resolveNote tdnrEnv) . toList $
|
||||
infos
|
||||
oldNotes
|
||||
infos oldNotes
|
||||
case catMaybes resolutions of
|
||||
[] -> pure oldType
|
||||
rs ->
|
||||
applySuggestions rs >>= \case
|
||||
True -> do
|
||||
synthesizeAndResolve ppe tdnrEnv
|
||||
resolutions -> do
|
||||
substituted <- traverse substSuggestion resolutions
|
||||
case or substituted of
|
||||
True -> synthesizeAndResolve ppe tdnrEnv
|
||||
False -> do
|
||||
-- The type hasn't changed
|
||||
liftResult $ suggest rs
|
||||
liftResult $ suggest resolutions
|
||||
pure oldType
|
||||
where
|
||||
addTypedComponent :: Context.InfoNote v loc -> State (Env v loc) ()
|
||||
addTypedComponent (Context.TopLevelComponent vtts) =
|
||||
for_ vtts $ \(v, typ, _) ->
|
||||
for_ (Name.suffixes . Name.unsafeParseText . Var.name $ Var.reset v) $ \suffix ->
|
||||
termsByShortname
|
||||
%= Map.insertWith
|
||||
(<>)
|
||||
(Name.toText suffix)
|
||||
[NamedReference (Var.name v) typ (Left v)]
|
||||
for_ vtts \(v, typ, _) ->
|
||||
let name = Name.unsafeParseVar (Var.reset v)
|
||||
in for_ (Name.suffixes name) \suffix ->
|
||||
#termsByShortname %= Map.insertWith (<>) suffix [NamedReference name typ (Context.ReplacementVar v)]
|
||||
addTypedComponent _ = pure ()
|
||||
|
||||
suggest :: [Resolution v loc] -> Result (Notes v loc) ()
|
||||
suggest =
|
||||
traverse_
|
||||
( \(Resolution name inferredType loc v suggestions) ->
|
||||
typeError $
|
||||
Context.ErrorNote
|
||||
(Context.UnknownTerm loc (suggestedVar v name) (dedupe suggestions) inferredType)
|
||||
[]
|
||||
)
|
||||
traverse_ \(Resolution name inferredType loc v suggestions) ->
|
||||
typeError $
|
||||
Context.ErrorNote
|
||||
{ cause = Context.UnknownTerm loc (suggestedVar v name) (dedupe suggestions) inferredType,
|
||||
path = Seq.empty
|
||||
}
|
||||
|
||||
guard x a = if x then Just a else Nothing
|
||||
|
||||
suggestedVar :: Var v => v -> Text -> v
|
||||
@ -267,10 +256,10 @@ typeDirectedNameResolution ppe oldNotes oldType env = do
|
||||
Var.MissingResult -> v
|
||||
_ -> Var.named name
|
||||
|
||||
extractSubstitution :: [Context.Suggestion v loc] -> Maybe (Either v Referent)
|
||||
extractSubstitution :: [Context.Suggestion v loc] -> Maybe (Context.Replacement v)
|
||||
extractSubstitution suggestions =
|
||||
let groupedByName :: [([Name.Name], Either v Referent)] =
|
||||
map (\(a, b) -> (b, a))
|
||||
let groupedByName :: [([Name.Name], Context.Replacement v)] =
|
||||
map Tuple.swap
|
||||
. Map.toList
|
||||
. fmap Set.toList
|
||||
. foldl'
|
||||
@ -278,86 +267,84 @@ typeDirectedNameResolution ppe oldNotes oldType env = do
|
||||
Map.insertWith
|
||||
Set.union
|
||||
suggestionReplacement
|
||||
(Set.singleton (Name.unsafeParseText suggestionName))
|
||||
(Set.singleton suggestionName)
|
||||
b
|
||||
)
|
||||
Map.empty
|
||||
$ filter Context.isExact suggestions
|
||||
matches :: Set (Either v Referent) = Name.preferShallowLibDepth groupedByName
|
||||
matches :: Set (Context.Replacement v) = Name.preferShallowLibDepth groupedByName
|
||||
in case toList matches of
|
||||
[x] -> Just x
|
||||
_ -> Nothing
|
||||
|
||||
applySuggestions :: [Resolution v loc] -> TDNR f v loc Bool
|
||||
applySuggestions = foldlM phi False
|
||||
where
|
||||
phi b a = do
|
||||
didSub <- substSuggestion a
|
||||
pure $! b || didSub
|
||||
|
||||
substSuggestion :: Resolution v loc -> TDNR f v loc Bool
|
||||
substSuggestion
|
||||
( Resolution
|
||||
name
|
||||
_
|
||||
loc
|
||||
v
|
||||
(extractSubstitution -> Just replacement)
|
||||
) =
|
||||
do
|
||||
modify (substBlank (Text.unpack name) loc solved)
|
||||
lift . btw $ Context.Decision (suggestedVar v name) loc solved
|
||||
pure True
|
||||
where
|
||||
solved = either (Term.var loc) (Term.fromReferent loc) replacement
|
||||
substSuggestion (Resolution name _ loc v (extractSubstitution -> Just replacement)) = do
|
||||
modify (substBlank name loc solved)
|
||||
lift . btw $ Context.Decision (suggestedVar v name) loc solved
|
||||
pure True
|
||||
where
|
||||
solved =
|
||||
case replacement of
|
||||
Context.ReplacementRef ref -> Term.fromReferent loc ref
|
||||
Context.ReplacementVar var -> Term.var loc var
|
||||
substSuggestion _ = pure False
|
||||
|
||||
-- Resolve a `Blank` to a term
|
||||
substBlank :: String -> loc -> Term v loc -> Term v loc -> Term v loc
|
||||
substBlank :: Text -> loc -> Term v loc -> Term v loc -> Term v loc
|
||||
substBlank s a r = ABT.visitPure go
|
||||
where
|
||||
go t = guard (ABT.annotation t == a) $ ABT.visitPure resolve t
|
||||
resolve (Term.Blank' (B.Recorded (B.Resolve loc name)))
|
||||
| name == s =
|
||||
Just (loc <$ r)
|
||||
| name == Text.unpack s = Just (loc <$ r)
|
||||
resolve _ = Nothing
|
||||
|
||||
-- Returns Nothing for irrelevant notes
|
||||
-- Returns Nothing for irrelevant notes
|
||||
resolveNote ::
|
||||
Env v loc ->
|
||||
Context.InfoNote v loc ->
|
||||
Result (Notes v loc) (Maybe (Resolution v loc))
|
||||
resolveNote env (Context.SolvedBlank (B.Resolve loc n) v it) =
|
||||
fmap (Just . Resolution (Text.pack n) it loc v . join)
|
||||
. traverse (resolve it)
|
||||
. join
|
||||
. maybeToList
|
||||
. Map.lookup (Text.pack n)
|
||||
$ view termsByShortname env
|
||||
-- Solve the case where we have a placeholder for a missing result
|
||||
-- at the end of a block. This is always an error.
|
||||
resolveNote _ (Context.SolvedBlank (B.MissingResultPlaceholder loc) v it) =
|
||||
pure . Just $ Resolution "_" it loc v []
|
||||
resolveNote _ n = btw n >> pure Nothing
|
||||
resolveNote env = \case
|
||||
Context.SolvedBlank (B.Resolve loc str) v it -> do
|
||||
let shortname = Name.unsafeParseText (Text.pack str)
|
||||
matches = Map.findWithDefault [] shortname env.termsByShortname
|
||||
suggestions <- wither (resolve it) matches
|
||||
pure $
|
||||
Just
|
||||
Resolution
|
||||
{ resolvedName = Text.pack str,
|
||||
inferredType = it,
|
||||
resolvedLoc = loc,
|
||||
v,
|
||||
suggestions
|
||||
}
|
||||
-- Solve the case where we have a placeholder for a missing result
|
||||
-- at the end of a block. This is always an error.
|
||||
Context.SolvedBlank (B.MissingResultPlaceholder loc) v it ->
|
||||
pure . Just $ Resolution "_" it loc v []
|
||||
note -> do
|
||||
btw note
|
||||
pure Nothing
|
||||
|
||||
dedupe :: [Context.Suggestion v loc] -> [Context.Suggestion v loc]
|
||||
dedupe = uniqueBy Context.suggestionReplacement
|
||||
dedupe =
|
||||
uniqueBy Context.suggestionReplacement
|
||||
|
||||
resolve ::
|
||||
Context.Type v loc ->
|
||||
NamedReference v loc ->
|
||||
Result (Notes v loc) [Context.Suggestion v loc]
|
||||
Result (Notes v loc) (Maybe (Context.Suggestion v loc))
|
||||
resolve inferredType (NamedReference fqn foundType replace) =
|
||||
-- We found a name that matches. See if the type matches too.
|
||||
case Context.isSubtype (TypeVar.liftType foundType) (Context.relax inferredType) of
|
||||
Left bug -> const [] <$> compilerBug bug
|
||||
Left bug -> Nothing <$ compilerBug bug
|
||||
-- Suggest the import if the type matches.
|
||||
Right b ->
|
||||
pure
|
||||
[ Context.Suggestion
|
||||
fqn
|
||||
(TypeVar.liftType foundType)
|
||||
replace
|
||||
(if b then Context.Exact else Context.WrongType)
|
||||
]
|
||||
pure . Just $
|
||||
Context.Suggestion
|
||||
fqn
|
||||
(TypeVar.liftType foundType)
|
||||
replace
|
||||
(if b then Context.Exact else Context.WrongType)
|
||||
|
||||
-- | Check whether a term matches a type, using a
|
||||
-- function to resolve the type of @Ref@ constructors
|
||||
|
||||
@ -31,6 +31,7 @@ module Unison.Typechecker.Context
|
||||
fitsScheme,
|
||||
isRedundant,
|
||||
Suggestion (..),
|
||||
Replacement (..),
|
||||
SuggestionMatch (..),
|
||||
isExact,
|
||||
typeErrors,
|
||||
@ -103,6 +104,7 @@ import Unison.Typechecker.TypeLookup qualified as TL
|
||||
import Unison.Typechecker.TypeVar qualified as TypeVar
|
||||
import Unison.Var (Var)
|
||||
import Unison.Var qualified as Var
|
||||
import Unison.Name (Name)
|
||||
|
||||
type TypeVar v loc = TypeVar.TypeVar (B.Blank loc) v
|
||||
|
||||
@ -329,16 +331,21 @@ data SuggestionMatch = Exact | WrongType | WrongName
|
||||
deriving (Ord, Eq, Show)
|
||||
|
||||
data Suggestion v loc = Suggestion
|
||||
{ suggestionName :: Text,
|
||||
{ suggestionName :: Name,
|
||||
suggestionType :: Type v loc,
|
||||
suggestionReplacement :: Either v Referent,
|
||||
suggestionReplacement :: Replacement v,
|
||||
suggestionMatch :: SuggestionMatch
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
isExact :: Suggestion v loc -> Bool
|
||||
isExact Suggestion {..} = suggestionMatch == Exact
|
||||
|
||||
data Replacement v
|
||||
= ReplacementRef Referent
|
||||
| ReplacementVar v
|
||||
deriving stock (Eq, Ord, Show)
|
||||
|
||||
data ErrorNote v loc = ErrorNote
|
||||
{ cause :: Cause v loc,
|
||||
path :: Seq (PathElement v loc)
|
||||
|
||||
@ -157,7 +157,7 @@ compile (Many p) !_ !success = case p of
|
||||
Char cp -> walker (charPatternPred cp)
|
||||
p -> go
|
||||
where
|
||||
go = compile p success success'
|
||||
go = try "Many" (compile p) success success'
|
||||
success' acc rem
|
||||
| Text.size rem == 0 = success acc rem
|
||||
| otherwise = go acc rem
|
||||
|
||||
@ -67,7 +67,7 @@
|
||||
(define (do-evaluate)
|
||||
(let-values ([(code main-ref) (decode-input)])
|
||||
(add-runtime-code 'unison-main code)
|
||||
(handle ['ref-4n0fgs00] top-exn-handler
|
||||
(handle [unison-exception:typelink] top-exn-handler
|
||||
((termlink->proc main-ref))
|
||||
(data 'unit 0))))
|
||||
|
||||
|
||||
@ -12,7 +12,42 @@
|
||||
; that arity appropriately.
|
||||
#!racket/base
|
||||
(provide
|
||||
(all-from-out unison/data-info)
|
||||
unison-any:typelink
|
||||
unison-boolean:typelink
|
||||
unison-bytes:typelink
|
||||
unison-char:typelink
|
||||
unison-float:typelink
|
||||
unison-int:typelink
|
||||
unison-nat:typelink
|
||||
unison-text:typelink
|
||||
unison-code:typelink
|
||||
unison-mvar:typelink
|
||||
unison-pattern:typelink
|
||||
unison-promise:typelink
|
||||
unison-sequence:typelink
|
||||
unison-socket:typelink
|
||||
unison-tls:typelink
|
||||
unison-timespec:typelink
|
||||
unison-threadid:typelink
|
||||
|
||||
unison-crypto.hashalgorithm:typelink
|
||||
unison-char.class:typelink
|
||||
unison-immutablearray:typelink
|
||||
unison-immutablebytearray:typelink
|
||||
unison-mutablearray:typelink
|
||||
unison-mutablebytearray:typelink
|
||||
unison-processhandle:typelink
|
||||
unison-ref.ticket:typelink
|
||||
unison-tls.cipher:typelink
|
||||
unison-tls.clientconfig:typelink
|
||||
unison-tls.privatekey:typelink
|
||||
unison-tls.serverconfig:typelink
|
||||
unison-tls.signedcert:typelink
|
||||
unison-tls.version:typelink
|
||||
|
||||
bytevector
|
||||
bytes
|
||||
control
|
||||
define-unison
|
||||
handle
|
||||
@ -42,6 +77,10 @@
|
||||
declare-function-link
|
||||
declare-code
|
||||
|
||||
exn:bug?
|
||||
exn:bug->exception
|
||||
exception->string
|
||||
|
||||
request
|
||||
request-case
|
||||
sum
|
||||
@ -71,7 +110,7 @@
|
||||
(require
|
||||
(for-syntax
|
||||
racket/set
|
||||
(only-in racket partition))
|
||||
(only-in racket partition flatten))
|
||||
(rename-in
|
||||
(except-in racket false true unit any)
|
||||
[make-continuation-prompt-tag make-prompt])
|
||||
@ -410,13 +449,11 @@
|
||||
[(pure . xs) #t]
|
||||
[_ #f]))
|
||||
|
||||
(define (mk-pure scrut ps)
|
||||
(define (mk-pure ps)
|
||||
(if (null? ps)
|
||||
#`(pure-val #,scrut)
|
||||
#'((unison-pure v) v)
|
||||
(syntax-case (car ps) (pure)
|
||||
[(pure (v) e ...)
|
||||
#`(let ([v (unison-pure-val #,scrut)])
|
||||
e ...)]
|
||||
[(pure (v) e ...) #'((unison-pure v) e ...)]
|
||||
[(pure vs e ...)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
@ -424,24 +461,19 @@
|
||||
(car ps)
|
||||
#'vs)])))
|
||||
|
||||
(define (mk-req scrut-stx)
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(t vs e ...)
|
||||
(with-syntax ([scrut scrut-stx])
|
||||
#'((t) (let-values
|
||||
([vs (apply values (unison-request-fields scrut))])
|
||||
e ...)))])))
|
||||
(define (mk-req stx)
|
||||
(syntax-case stx ()
|
||||
[(t (v ...) e ...)
|
||||
#'((t (list v ...)) e ...)]))
|
||||
|
||||
(define (mk-abil scrut-stx)
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(t sc ...)
|
||||
(let ([sub (mk-req scrut-stx)])
|
||||
(with-syntax
|
||||
([(sc ...) (map sub (syntax->list #'(sc ...)))]
|
||||
[scrut scrut-stx])
|
||||
#'((t) (case (unison-request-tag scrut) sc ...))))])))
|
||||
[(a sc ...)
|
||||
#`((unison-request b t vs)
|
||||
#:when (equal? a b)
|
||||
(match* (t vs)
|
||||
#,@(map mk-req (syntax->list #'(sc ...)))))])))
|
||||
|
||||
(syntax-case stx ()
|
||||
[(request-case scrut c ...)
|
||||
@ -453,66 +485,11 @@
|
||||
"multiple pure cases in request-case"
|
||||
stx)
|
||||
(with-syntax
|
||||
([pc (mk-pure #'scrut ps)]
|
||||
([pc (mk-pure ps)]
|
||||
[(ac ...) (map (mk-abil #'scrut) as)])
|
||||
|
||||
#'(cond
|
||||
[(unison-pure? scrut) pc]
|
||||
[else (case (unison-request-ability scrut) ac ...)]))))])))
|
||||
#'(match scrut pc ac ...))))])))
|
||||
|
||||
; (define (describe-list n l)
|
||||
; (let rec ([pre "["] [post "[]"] [cur l])
|
||||
; (cond
|
||||
; [(null? cur) post]
|
||||
; [else
|
||||
; (let* ([sx (describe-value-depth (- n 1) (car cur))]
|
||||
; [sxs (rec ", " "]" (cdr cur))])
|
||||
; (string-append pre sx sxs))])))
|
||||
;
|
||||
; (define (describe-ref r)
|
||||
; (cond
|
||||
; [(symbol? r) (symbol->string r)]
|
||||
; [(data? r)
|
||||
; (data-case r
|
||||
; [0 (s) (string-append "##" s)]
|
||||
; [1 (i)
|
||||
; (data-case i
|
||||
; [0 (bs ix)
|
||||
; (let* ([bd (bytevector->base32-string b32h bs)]
|
||||
; [td (istring-take 5 bd)]
|
||||
; [sx (if (>= 0 ix)
|
||||
; ""
|
||||
; (string-append "." (number->string ix)))])
|
||||
; (string-append "#" td sx))])])]))
|
||||
;
|
||||
; (define (describe-bytes bs)
|
||||
; (let* ([s (bytevector->base32-string b32h bs)]
|
||||
; [l (string-length s)]
|
||||
; [sfx (if (<= l 10) "" "...")])
|
||||
; (string-append "32x" (istring-take 10 s) sfx)))
|
||||
;
|
||||
; (define (describe-value-depth n x)
|
||||
; (if (< n 0) "..."
|
||||
; (cond
|
||||
; [(sum? x)
|
||||
; (let ([tt (number->string (sum-tag x))]
|
||||
; [vs (describe-list n (sum-fields x))])
|
||||
; (string-append "Sum " tt " " vs))]
|
||||
; [(data? x)
|
||||
; (let ([tt (number->string (data-tag x))]
|
||||
; [rt (describe-ref (data-ref x))]
|
||||
; [vs (describe-list n (data-fields x))])
|
||||
; (string-append "Data " rt " " tt " " vs))]
|
||||
; [(list? x) (describe-list n x)]
|
||||
; [(number? x) (number->string x)]
|
||||
; [(string? x) (string-append "\"" x "\"")]
|
||||
; [(bytevector? x) (describe-bytes x)]
|
||||
; [(procedure? x) (format "~a" x)]
|
||||
; [else
|
||||
; (format "describe-value: unimplemented case: ~a " x)])))
|
||||
;
|
||||
; (define (describe-value x) (describe-value-depth 20 x))
|
||||
;
|
||||
(define (decode-value x) '())
|
||||
|
||||
(define (reference->termlink rf)
|
||||
@ -582,21 +559,18 @@
|
||||
; The in-unison definition was effectively just literal scheme code
|
||||
; represented as a unison data type, with some names generated from
|
||||
; codebase data.
|
||||
;
|
||||
; Note: the ref-4n0fgs00 stuff is probably not ultimately correct, but
|
||||
; is how things work for now.
|
||||
(define (top-exn-handler rq)
|
||||
(request-case rq
|
||||
[pure (x)
|
||||
(match x
|
||||
[(unison-data r 0 (list))
|
||||
(eq? r unison-unit:link)
|
||||
(eq? r unison-unit:typelink)
|
||||
(display "")]
|
||||
[else
|
||||
(display (describe-value x))])]
|
||||
[ref-4n0fgs00
|
||||
[unison-exception:typelink
|
||||
[0 (f)
|
||||
(control 'ref-4n0fgs00 k
|
||||
(control unison-exception:typelink k
|
||||
(let ([disp (describe-value f)])
|
||||
(raise (make-exn:bug "builtin.bug" disp))))]]))
|
||||
|
||||
|
||||
@ -110,13 +110,33 @@
|
||||
(define (try-eval thunk)
|
||||
(with-handlers
|
||||
([exn:break?
|
||||
(lambda (e) (exception "ThreadKilledFailure" (string->chunked-string "thread killed") ()))]
|
||||
(lambda (e)
|
||||
(exception
|
||||
unison-threadkilledfailure:typelink
|
||||
(string->chunked-string "thread killed")
|
||||
()))]
|
||||
[exn:io?
|
||||
(lambda (e)
|
||||
(exception unison-iofailure:link (exception->string e) ()))]
|
||||
[exn:arith? (lambda (e) (exception "ArithmeticFailure" (exception->string e) ()))]
|
||||
(exception
|
||||
unison-iofailure:typelink
|
||||
(exception->string e) ()))]
|
||||
[exn:arith?
|
||||
(lambda (e)
|
||||
(exception
|
||||
unison-arithfailure:typelink
|
||||
(exception->string e)
|
||||
()))]
|
||||
[exn:bug? (lambda (e) (exn:bug->exception e))]
|
||||
[exn:fail? (lambda (e) (exception "RuntimeFailure" (exception->string e) ()))]
|
||||
[exn:fail?
|
||||
(lambda (e)
|
||||
(exception
|
||||
unison-runtimefailure:typelink
|
||||
(exception->string e)
|
||||
()))]
|
||||
[(lambda (x) #t)
|
||||
(lambda (e) (exception "MiscFailure" (string->chunked-string "unknown exception") e))])
|
||||
(lambda (e)
|
||||
(exception
|
||||
unison-miscfailure:typelink
|
||||
(string->chunked-string "unknown exception")
|
||||
e))])
|
||||
(right (thunk)))))
|
||||
|
||||
@ -19,6 +19,12 @@
|
||||
(for-syntax raise-syntax-error)
|
||||
|
||||
exception->string
|
||||
|
||||
exn:bug
|
||||
make-exn:bug
|
||||
exn:bug?
|
||||
exn:bug->exception
|
||||
|
||||
let-marks
|
||||
ref-mark
|
||||
|
||||
@ -74,6 +80,7 @@
|
||||
(only-in racket/fixnum fl->fx fx- fxand fxlshift fxrshift fxior)
|
||||
racket/unsafe/ops
|
||||
unison/data
|
||||
unison/data-info
|
||||
unison/chunked-seq)
|
||||
|
||||
(define (fx1- n) (fx- n 1))
|
||||
@ -372,3 +379,12 @@
|
||||
(begin
|
||||
(vector-set! dst i (vector-ref src (+ off i)))
|
||||
(next (fx1- i)))))))
|
||||
|
||||
; TODO needs better pretty printing for when it isn't caught
|
||||
(struct exn:bug (msg a)
|
||||
#:constructor-name make-exn:bug)
|
||||
(define (exn:bug->exception b)
|
||||
(exception
|
||||
unison-runtimefailure:typelink
|
||||
(exn:bug-msg b)
|
||||
(exn:bug-a b)))
|
||||
|
||||
@ -52,10 +52,6 @@
|
||||
ord
|
||||
failure
|
||||
exception
|
||||
exn:bug
|
||||
make-exn:bug
|
||||
exn:bug?
|
||||
exn:bug->exception
|
||||
|
||||
unison-any:typelink
|
||||
unison-any-any:tag
|
||||
@ -67,6 +63,38 @@
|
||||
unison-boolean-true
|
||||
unison-boolean-false
|
||||
|
||||
unison-bytes:typelink
|
||||
unison-char:typelink
|
||||
unison-float:typelink
|
||||
unison-int:typelink
|
||||
unison-nat:typelink
|
||||
unison-text:typelink
|
||||
unison-code:typelink
|
||||
unison-mvar:typelink
|
||||
unison-pattern:typelink
|
||||
unison-promise:typelink
|
||||
unison-sequence:typelink
|
||||
unison-socket:typelink
|
||||
unison-tls:typelink
|
||||
unison-timespec:typelink
|
||||
unison-threadid:typelink
|
||||
; unison-value:typelink
|
||||
|
||||
unison-crypto.hashalgorithm:typelink
|
||||
unison-char.class:typelink
|
||||
unison-immutablearray:typelink
|
||||
unison-immutablebytearray:typelink
|
||||
unison-mutablearray:typelink
|
||||
unison-mutablebytearray:typelink
|
||||
unison-processhandle:typelink
|
||||
unison-ref.ticket:typelink
|
||||
unison-tls.cipher:typelink
|
||||
unison-tls.clientconfig:typelink
|
||||
unison-tls.privatekey:typelink
|
||||
unison-tls.serverconfig:typelink
|
||||
unison-tls.signedcert:typelink
|
||||
unison-tls.version:typelink
|
||||
|
||||
unison-tuple->list)
|
||||
|
||||
(require
|
||||
@ -110,7 +138,8 @@
|
||||
|
||||
(struct unison-request
|
||||
(ability tag fields)
|
||||
#:constructor-name make-request)
|
||||
#:constructor-name make-request
|
||||
#:transparent)
|
||||
|
||||
; Structures for other unison builtins. Originally the plan was
|
||||
; just to secretly use an in-unison data type representation.
|
||||
@ -173,15 +202,43 @@
|
||||
|
||||
(struct unison-typelink ()
|
||||
#:transparent
|
||||
#:reflection-name 'typelink)
|
||||
#:reflection-name 'typelink
|
||||
#:property prop:equal+hash
|
||||
(let ()
|
||||
(define (equal-proc lnl lnr rec)
|
||||
(match lnl
|
||||
[(unison-typelink-builtin l)
|
||||
(match lnr
|
||||
[(unison-typelink-builtin r)
|
||||
(equal? l r)]
|
||||
[else #f])]
|
||||
[(unison-typelink-derived hl i)
|
||||
(match lnr
|
||||
[(unison-typelink-derived hr j)
|
||||
(and (equal? hl hr) (= i j))]
|
||||
[else #f])]))
|
||||
|
||||
(define ((hash-proc init) ln rec)
|
||||
(match ln
|
||||
[(unison-typelink-builtin n)
|
||||
(fxxor (fx*/wraparound (rec n) 53)
|
||||
(fx*/wraparound init 17))]
|
||||
[(unison-typelink-derived hl i)
|
||||
(fxxor (fx*/wraparound (rec hl) 59)
|
||||
(fx*/wraparound (rec i) 61)
|
||||
(fx*/wraparound init 19))]))
|
||||
|
||||
(list equal-proc (hash-proc 3) (hash-proc 5))))
|
||||
|
||||
(struct unison-typelink-builtin unison-typelink
|
||||
(name)
|
||||
#:reflection-name 'typelink)
|
||||
#:reflection-name 'typelink
|
||||
#:transparent)
|
||||
|
||||
(struct unison-typelink-derived unison-typelink
|
||||
(ref ix)
|
||||
#:reflection-name 'typelink)
|
||||
#:reflection-name 'typelink
|
||||
#:transparent)
|
||||
|
||||
(struct unison-code (rep))
|
||||
(struct unison-quote (val))
|
||||
@ -288,6 +345,52 @@
|
||||
(define unison-boolean-false
|
||||
(data unison-boolean:typelink unison-boolean-false:tag))
|
||||
|
||||
(define unison-bytes:typelink (unison-typelink-builtin "Bytes"))
|
||||
(define unison-char:typelink (unison-typelink-builtin "Char"))
|
||||
(define unison-code:typelink (unison-typelink-builtin "Code"))
|
||||
(define unison-float:typelink (unison-typelink-builtin "Float"))
|
||||
(define unison-int:typelink (unison-typelink-builtin "Int"))
|
||||
(define unison-mvar:typelink (unison-typelink-builtin "MVar"))
|
||||
(define unison-nat:typelink (unison-typelink-builtin "Nat"))
|
||||
(define unison-pattern:typelink (unison-typelink-builtin "Pattern"))
|
||||
(define unison-promise:typelink (unison-typelink-builtin "Promise"))
|
||||
(define unison-sequence:typelink (unison-typelink-builtin "Sequence"))
|
||||
(define unison-socket:typelink (unison-typelink-builtin "Socket"))
|
||||
(define unison-text:typelink (unison-typelink-builtin "Text"))
|
||||
(define unison-tls:typelink (unison-typelink-builtin "Tls"))
|
||||
(define unison-timespec:typelink (unison-typelink-builtin "TimeSpec"))
|
||||
(define unison-threadid:typelink (unison-typelink-builtin "ThreadId"))
|
||||
; (define unison-value:typelink (unison-typelink-builtin "Value"))
|
||||
|
||||
(define unison-crypto.hashalgorithm:typelink
|
||||
(unison-typelink-builtin "crypto.HashAlgorithm"))
|
||||
(define unison-char.class:typelink
|
||||
(unison-typelink-builtin "Char.Class"))
|
||||
(define unison-immutablearray:typelink
|
||||
(unison-typelink-builtin "ImmutableArray"))
|
||||
(define unison-immutablebytearray:typelink
|
||||
(unison-typelink-builtin "ImmutableByteArray"))
|
||||
(define unison-mutablearray:typelink
|
||||
(unison-typelink-builtin "MutableArray"))
|
||||
(define unison-mutablebytearray:typelink
|
||||
(unison-typelink-builtin "MutableArray"))
|
||||
(define unison-processhandle:typelink
|
||||
(unison-typelink-builtin "ProcessHandle"))
|
||||
(define unison-ref.ticket:typelink
|
||||
(unison-typelink-builtin "Ref.Ticket"))
|
||||
(define unison-tls.cipher:typelink
|
||||
(unison-typelink-builtin "Tls.Cipher"))
|
||||
(define unison-tls.clientconfig:typelink
|
||||
(unison-typelink-builtin "Tls.ClientConfig"))
|
||||
(define unison-tls.privatekey:typelink
|
||||
(unison-typelink-builtin "Tls.PrivateKey"))
|
||||
(define unison-tls.serverconfig:typelink
|
||||
(unison-typelink-builtin "Tls.ServerConfig"))
|
||||
(define unison-tls.signedcert:typelink
|
||||
(unison-typelink-builtin "Tls.SignedCert"))
|
||||
(define unison-tls.version:typelink
|
||||
(unison-typelink-builtin "Tls.Version"))
|
||||
|
||||
; Type -> Text -> Any -> Failure
|
||||
(define (failure typeLink msg any)
|
||||
(sum 0 typeLink msg any))
|
||||
@ -296,12 +399,6 @@
|
||||
(define (exception typeLink msg a)
|
||||
(failure typeLink msg (unison-any-any a)))
|
||||
|
||||
; TODO needs better pretty printing for when it isn't caught
|
||||
(struct exn:bug (msg a)
|
||||
#:constructor-name make-exn:bug)
|
||||
(define (exn:bug->exception b) (exception "RuntimeFailure" (exn:bug-msg b) (exn:bug-a b)))
|
||||
|
||||
|
||||
; A counter for internally numbering declared data, so that the
|
||||
; entire reference doesn't need to be stored in every data record.
|
||||
(define next-data-number 0)
|
||||
|
||||
@ -26,5 +26,9 @@
|
||||
(bytes->chunked-bytes (gzip-bytes (chunked-bytes->bytes bytes))))
|
||||
|
||||
(define (gzip.decompress bytes)
|
||||
(with-handlers [[exn:fail? (lambda (e) (exception "Gzip data corrupted" (exception->string e) '()))] ]
|
||||
(right (bytes->chunked-bytes (gunzip-bytes (chunked-bytes->bytes bytes))))))
|
||||
(with-handlers
|
||||
[[exn:fail? (lambda (e) (left (exception->string e)))]]
|
||||
(right
|
||||
(bytes->chunked-bytes
|
||||
(gunzip-bytes
|
||||
(chunked-bytes->bytes bytes))))))
|
||||
|
||||
@ -54,7 +54,7 @@
|
||||
(if (byte-ready? port)
|
||||
(unison-either-right #t)
|
||||
(if (port-eof? port)
|
||||
(Exception 'IO "EOF" port)
|
||||
(Exception unison-iofailure:typelink "EOF" port)
|
||||
(unison-either-right #f))))
|
||||
|
||||
(define-unison (getCurrentDirectory.impl.v3 unit)
|
||||
@ -78,7 +78,7 @@
|
||||
(set-port-position! handle (+ current amount))
|
||||
(unison-either-right none)))
|
||||
(2 ()
|
||||
(Exception 'BadNews "SeekFromEnd not supported" 0))))
|
||||
(Exception unison-iofailure:typelink "SeekFromEnd not supported" 0))))
|
||||
|
||||
(define-unison (getLine.impl.v1 handle)
|
||||
(let* ([line (read-line handle)])
|
||||
@ -90,7 +90,7 @@
|
||||
(define-unison (getChar.impl.v1 handle)
|
||||
(let* ([char (read-char handle)])
|
||||
(if (eof-object? char)
|
||||
(Exception 'isEOFError "End of file reached")
|
||||
(Exception unison-iofailure:typelink "End of file reached")
|
||||
(unison-either-right char))))
|
||||
|
||||
(define-unison (getSomeBytes.impl.v1 handle bytes)
|
||||
@ -108,8 +108,8 @@
|
||||
unison-buffermode-line-buffering)]
|
||||
[(block) (unison-either-right
|
||||
unison-buffermode-block-buffering)]
|
||||
[(#f) (Exception 'IO "Unable to determine buffering mode of handle" '())]
|
||||
[else (Exception 'IO "Unexpected response from file-stream-buffer-mode" '())]))
|
||||
[(#f) (Exception unison-iofailure:typelink "Unable to determine buffering mode of handle" '())]
|
||||
[else (Exception unison-iofailure:typelink "Unexpected response from file-stream-buffer-mode" '())]))
|
||||
|
||||
(define-unison (setBuffering.impl.v3 handle mode)
|
||||
(data-case mode
|
||||
@ -123,7 +123,7 @@
|
||||
(file-stream-buffer-mode handle 'block)
|
||||
(unison-either-right none))
|
||||
(3 (size)
|
||||
(Exception 'IO "Sized block buffering not supported" '()))))
|
||||
(Exception unison-iofailure:typelink "Sized block buffering not supported" '()))))
|
||||
|
||||
(define (with-buffer-mode port mode)
|
||||
(file-stream-buffer-mode port mode)
|
||||
@ -142,7 +142,7 @@
|
||||
(define-unison (getEcho.impl.v1 handle)
|
||||
(if (eq? handle stdin)
|
||||
(unison-either-right (get-stdin-echo))
|
||||
(Exception 'IO "getEcho only supported on stdin" '())))
|
||||
(Exception unison-iofailure:typelink "getEcho only supported on stdin" '())))
|
||||
|
||||
(define-unison (setEcho.impl.v1 handle echo)
|
||||
(if (eq? handle stdin)
|
||||
@ -151,7 +151,7 @@
|
||||
(system "stty echo")
|
||||
(system "stty -echo"))
|
||||
(unison-either-right none))
|
||||
(Exception 'IO "setEcho only supported on stdin" '())))
|
||||
(Exception unison-iofailure:typelink "setEcho only supported on stdin" '())))
|
||||
|
||||
(define (get-stdin-echo)
|
||||
(let ([current (with-output-to-string (lambda () (system "stty -a")))])
|
||||
@ -165,7 +165,7 @@
|
||||
(define-unison (getEnv.impl.v1 key)
|
||||
(let ([value (environment-variables-ref (current-environment-variables) (string->bytes/utf-8 (chunked-string->string key)))])
|
||||
(if (false? value)
|
||||
(Exception 'IO "environmental variable not found" key)
|
||||
(Exception unison-iofailure:typelink "environmental variable not found" key)
|
||||
(unison-either-right
|
||||
(string->chunked-string (bytes->string/utf-8 value))))))
|
||||
|
||||
|
||||
@ -46,14 +46,14 @@
|
||||
(with-handlers
|
||||
[[exn:fail:filesystem?
|
||||
(lambda (e)
|
||||
(exception unison-iofailure:link (exception->string e) '()))]]
|
||||
(exception unison-iofailure:typelink (exception->string e) '()))]]
|
||||
(right (file-size (chunked-string->string path)))))
|
||||
|
||||
(define (getFileTimestamp.impl.v3 path)
|
||||
(with-handlers
|
||||
[[exn:fail:filesystem?
|
||||
(lambda (e)
|
||||
(exception unison-iofailure:link (exception->string e) '()))]]
|
||||
(exception unison-iofailure:typelink (exception->string e) '()))]]
|
||||
(right (file-or-directory-modify-seconds (chunked-string->string path)))))
|
||||
|
||||
; in haskell, it's not just file but also directory
|
||||
|
||||
@ -89,7 +89,7 @@
|
||||
#:when (= t unison-schemeterm-handle:tag)
|
||||
`(handle
|
||||
,(map
|
||||
(lambda (tx) `(quote ,(text->ident tx)))
|
||||
(lambda (tx) (text->linkname tx))
|
||||
(chunked-list->list as))
|
||||
,(text->ident h)
|
||||
,@(map decode-term (chunked-list->list tms)))]
|
||||
@ -149,6 +149,10 @@
|
||||
[(equal? (substring st 0 2) "#\\") (string-ref st 2)]
|
||||
[else #f]))
|
||||
|
||||
(define (text->linkname tx)
|
||||
(let* ([st (chunked-string->string tx)])
|
||||
(string->symbol (string-append st ":typelink"))))
|
||||
|
||||
(define (text->ident tx)
|
||||
(let* ([st (chunked-string->string tx)]
|
||||
[n (string->number st)]
|
||||
@ -256,8 +260,8 @@
|
||||
(define runtime-module-map (make-hash))
|
||||
|
||||
(define (reflect-derived bs i)
|
||||
(data unison-reference:link unison-reference-derived:tag
|
||||
(data unison-id:link unison-id-id:tag bs i)))
|
||||
(data unison-reference:typelink unison-reference-derived:tag
|
||||
(data unison-id:typelink unison-id-id:tag bs i)))
|
||||
|
||||
(define (function->groupref f)
|
||||
(match (lookup-function-link f)
|
||||
@ -466,12 +470,15 @@
|
||||
[0 (snd nil)
|
||||
(values fst snd)])]))
|
||||
|
||||
(define (gen-typelinks code)
|
||||
(define (typelink-deps code)
|
||||
(group-type-dependencies
|
||||
(list->chunked-list
|
||||
(map unison-code-rep code))))
|
||||
|
||||
(define (typelink-defns-code links)
|
||||
(map decode-syntax
|
||||
(chunked-list->list
|
||||
(gen-typelink-defns
|
||||
(list->chunked-list
|
||||
(map unison-code-rep code))))))
|
||||
(chunked-list->list
|
||||
(gen-typelink-defns links))))
|
||||
|
||||
(define (gen-code args)
|
||||
(let-values ([(tl co) (splat-upair args)])
|
||||
@ -572,7 +579,7 @@
|
||||
[pname (termlink->name primary)]
|
||||
[tmlinks (map ufst udefs)]
|
||||
[codes (map usnd udefs)]
|
||||
[tylinks (gen-typelinks codes)]
|
||||
[tylinks (typelink-deps codes)]
|
||||
[sdefs (flatten (map gen-code udefs))])
|
||||
`((require unison/boot
|
||||
unison/data-info
|
||||
@ -582,29 +589,37 @@
|
||||
unison/simple-wrappers
|
||||
unison/compound-wrappers)
|
||||
|
||||
,@tylinks
|
||||
,@(typelink-defns-code tylinks)
|
||||
|
||||
,@sdefs
|
||||
|
||||
(handle ['ref-4n0fgs00] top-exn-handler
|
||||
(handle [unison-exception:typelink] top-exn-handler
|
||||
(,pname #f)))))
|
||||
|
||||
(define (build-runtime-module mname tylinks tmlinks defs)
|
||||
(let ([names (map termlink->name tmlinks)])
|
||||
`(module ,mname racket/base
|
||||
(require unison/boot
|
||||
unison/data-info
|
||||
unison/primops
|
||||
unison/primops-generated
|
||||
unison/builtin-generated
|
||||
unison/simple-wrappers
|
||||
unison/compound-wrappers)
|
||||
(define (provided-tylink r)
|
||||
(string->symbol
|
||||
(chunked-string->string
|
||||
(ref-typelink-name r))))
|
||||
(define tynames (map provided-tylink (chunked-list->list tylinks)))
|
||||
(define tmnames (map termlink->name tmlinks))
|
||||
`(module ,mname racket/base
|
||||
(require unison/boot
|
||||
unison/data
|
||||
unison/data-info
|
||||
unison/primops
|
||||
unison/primops-generated
|
||||
unison/builtin-generated
|
||||
unison/simple-wrappers
|
||||
unison/compound-wrappers)
|
||||
|
||||
(provide ,@names)
|
||||
(provide
|
||||
,@tynames
|
||||
,@tmnames)
|
||||
|
||||
,@tylinks
|
||||
,@(typelink-defns-code tylinks)
|
||||
|
||||
,@defs)))
|
||||
,@defs))
|
||||
|
||||
(define (add-runtime-module mname tylinks tmlinks defs)
|
||||
(eval (build-runtime-module mname tylinks tmlinks defs)
|
||||
@ -626,7 +641,7 @@
|
||||
[codes (map usnd udefs)]
|
||||
[refs (map termlink->reference tmlinks)]
|
||||
[depss (map code-dependencies codes)]
|
||||
[tylinks (gen-typelinks codes)]
|
||||
[tylinks (typelink-deps codes)]
|
||||
[deps (flatten depss)]
|
||||
[fdeps (filter need-dependency? deps)]
|
||||
[rdeps (remove* refs fdeps)])
|
||||
|
||||
@ -24,6 +24,13 @@
|
||||
#!r6rs
|
||||
(library (unison primops)
|
||||
(export
|
||||
builtin-Any:typelink
|
||||
builtin-Char:typelink
|
||||
builtin-Float:typelink
|
||||
builtin-Int:typelink
|
||||
builtin-Nat:typelink
|
||||
builtin-Text:typelink
|
||||
|
||||
builtin-Float.*
|
||||
builtin-Float.*:termlink
|
||||
builtin-Float.>=
|
||||
@ -181,6 +188,8 @@
|
||||
builtin-TermLink.fromReferent:termlink
|
||||
builtin-TermLink.toReferent
|
||||
builtin-TermLink.toReferent:termlink
|
||||
builtin-TypeLink.toReference
|
||||
builtin-TypeLink.toReference:termlink
|
||||
|
||||
unison-FOp-internal.dataTag
|
||||
unison-FOp-Char.toText
|
||||
@ -610,6 +619,7 @@
|
||||
define-unison
|
||||
referent->termlink
|
||||
termlink->referent
|
||||
typelink->reference
|
||||
clamp-integer
|
||||
clamp-natural
|
||||
wrap-natural
|
||||
@ -635,6 +645,13 @@
|
||||
(unison concurrent)
|
||||
(racket random))
|
||||
|
||||
(define builtin-Any:typelink unison-any:typelink)
|
||||
(define builtin-Char:typelink unison-char:typelink)
|
||||
(define builtin-Float:typelink unison-float:typelink)
|
||||
(define builtin-Int:typelink unison-int:typelink)
|
||||
(define builtin-Nat:typelink unison-nat:typelink)
|
||||
(define builtin-Text:typelink unison-text:typelink)
|
||||
|
||||
(define-builtin-link Float.*)
|
||||
(define-builtin-link Float.fromRepresentation)
|
||||
(define-builtin-link Float.toRepresentation)
|
||||
@ -701,6 +718,7 @@
|
||||
(define-builtin-link Code.toGroup)
|
||||
(define-builtin-link TermLink.fromReferent)
|
||||
(define-builtin-link TermLink.toReferent)
|
||||
(define-builtin-link TypeLink.toReference)
|
||||
(define-builtin-link IO.seekHandle.impl.v3)
|
||||
(define-builtin-link IO.getLine.impl.v1)
|
||||
(define-builtin-link IO.getSomeBytes.impl.v1)
|
||||
@ -752,6 +770,8 @@
|
||||
(referent->termlink rf))
|
||||
(define-unison (builtin-TermLink.toReferent tl)
|
||||
(termlink->referent tl))
|
||||
(define-unison (builtin-TypeLink.toReference tl)
|
||||
(typelink->reference tl))
|
||||
(define-unison (builtin-murmurHashBytes bs)
|
||||
(murmurhash-bytes (chunked-bytes->bytes bs)))
|
||||
|
||||
@ -1107,10 +1127,10 @@
|
||||
;; TODO should we convert Bytes -> Text directly without the intermediate conversions?
|
||||
(define (unison-FOp-Text.fromUtf8.impl.v3 b)
|
||||
(with-handlers
|
||||
([exn:fail:contract? ; TODO proper typeLink
|
||||
([exn:fail:contract?
|
||||
(lambda (e)
|
||||
(exception
|
||||
unison-iofailure:link
|
||||
unison-iofailure:typelink
|
||||
(string->chunked-string
|
||||
(string-append
|
||||
"Invalid UTF-8 stream: "
|
||||
@ -1414,6 +1434,7 @@
|
||||
(declare-builtin-link builtin-Code.toGroup)
|
||||
(declare-builtin-link builtin-TermLink.fromReferent)
|
||||
(declare-builtin-link builtin-TermLink.toReferent)
|
||||
(declare-builtin-link builtin-TypeLink.toReference)
|
||||
(declare-builtin-link builtin-IO.seekHandle.impl.v3)
|
||||
(declare-builtin-link builtin-IO.getLine.impl.v1)
|
||||
(declare-builtin-link builtin-IO.getSomeBytes.impl.v1)
|
||||
|
||||
@ -29,9 +29,22 @@
|
||||
(with-handlers
|
||||
[[exn:fail:network?
|
||||
(lambda (e)
|
||||
(exception unison-iofailure:link (exception->string e) '()))]
|
||||
[exn:fail:contract? (lambda (e) (exception "InvalidArguments" (exception->string e) '()))]
|
||||
[(lambda _ #t) (lambda (e) (exception "MiscFailure" (chunked-string->string (format "Unknown exception ~a" (exn->string e))) e))] ]
|
||||
(exception
|
||||
unison-iofailure:typelink
|
||||
(exception->string e) '()))]
|
||||
[exn:fail:contract?
|
||||
(lambda (e)
|
||||
(exception
|
||||
unison-miscfailure:typelink
|
||||
(exception->string e)
|
||||
'()))]
|
||||
[(lambda _ #t)
|
||||
(lambda (e)
|
||||
(exception
|
||||
unison-miscfailure:typelink
|
||||
(chunked-string->string
|
||||
(format "Unknown exception ~a" (exn->string e)))
|
||||
e))]]
|
||||
(fn)))
|
||||
|
||||
(define (closeSocket.impl.v3 socket)
|
||||
@ -52,15 +65,20 @@
|
||||
|
||||
(define (socketSend.impl.v3 socket data) ; socket bytes -> ()
|
||||
(if (not (socket-pair? socket))
|
||||
(exception "InvalidArguments" "Cannot send on a server socket" '())
|
||||
(exception
|
||||
unison-iofailure:typelink
|
||||
"Cannot send on a server socket"
|
||||
'())
|
||||
(begin
|
||||
(write-bytes (chunked-bytes->bytes data) (socket-pair-output socket))
|
||||
(flush-output (socket-pair-output socket))
|
||||
(right none)))); )
|
||||
(right none))))
|
||||
|
||||
(define (socketReceive.impl.v3 socket amt) ; socket int -> bytes
|
||||
(if (not (socket-pair? socket))
|
||||
(exception "InvalidArguments" "Cannot receive on a server socket")
|
||||
(exception
|
||||
unison-iofailure:typelink
|
||||
"Cannot receive on a server socket")
|
||||
(handle-errors
|
||||
(lambda ()
|
||||
(begin
|
||||
@ -87,9 +105,21 @@
|
||||
(with-handlers
|
||||
[[exn:fail:network?
|
||||
(lambda (e)
|
||||
(exception unison-iofailure:link (exception->string e) '()))]
|
||||
[exn:fail:contract? (lambda (e) (exception "InvalidArguments" (exception->string e) '()))]
|
||||
[(lambda _ #t) (lambda (e) (exception "MiscFailure" (string->chunked-string "Unknown exception") e))] ]
|
||||
(exception
|
||||
unison-iofailure:typelink
|
||||
(exception->string e) '()))]
|
||||
[exn:fail:contract?
|
||||
(lambda (e)
|
||||
(exception
|
||||
unison-iofailure:typelink
|
||||
(exception->string e)
|
||||
'()))]
|
||||
[(lambda _ #t)
|
||||
(lambda (e)
|
||||
(exception
|
||||
unison-miscfailure:typelink
|
||||
(string->chunked-string "Unknown exception")
|
||||
e))] ]
|
||||
(let ([listener (tcp-listen (string->number port ) 4 #f (if (equal? 0 hostname) #f hostname))])
|
||||
(right listener))))))
|
||||
|
||||
@ -104,7 +134,10 @@
|
||||
|
||||
(define (socketAccept.impl.v3 listener)
|
||||
(if (socket-pair? listener)
|
||||
(exception "InvalidArguments" (string->chunked-string "Cannot accept on a non-server socket"))
|
||||
(exception
|
||||
unison-iofailure:typelink
|
||||
(string->chunked-string "Cannot accept on a non-server socket")
|
||||
'())
|
||||
(begin
|
||||
(let-values ([(input output) (tcp-accept listener)])
|
||||
(right (socket-pair input output))))))
|
||||
|
||||
@ -62,7 +62,9 @@
|
||||
(let ([certs (read-pem-certificates (open-input-bytes (chunked-bytes->bytes bytes)))])
|
||||
(if (= 1 (length certs))
|
||||
(right bytes)
|
||||
(exception "Wrong number of certs" (string->chunked-string "nope") certs)))) ; TODO passing certs is wrong, should either be converted to chunked-list or removed
|
||||
(exception
|
||||
unison-tlsfailure:typelink
|
||||
(string->chunked-string "nope") certs)))) ; TODO passing certs is wrong, should either be converted to chunked-list or removed
|
||||
|
||||
; We don't actually "decode" certificates, we just validate them
|
||||
(define (encodeCert bytes) bytes)
|
||||
@ -110,28 +112,42 @@
|
||||
(define (ClientConfig.certificates.set certs config) ; list tlsSignedCert tlsClientConfig -> tlsClientConfig
|
||||
(client-config (client-config-host config) certs))
|
||||
|
||||
; TODO: have someone familiar with TLS verify these exception
|
||||
; classifications
|
||||
(define (handle-errors fn)
|
||||
(with-handlers
|
||||
[[exn:fail:network?
|
||||
(lambda (e)
|
||||
(exception unison-iofailure:link (exception->string e) '()))]
|
||||
(exception
|
||||
unison-iofailure:typelink
|
||||
(exception->string e) '()))]
|
||||
[exn:fail:contract?
|
||||
(lambda (e) (exception "InvalidArguments" (exception->string e) '()))]
|
||||
(lambda (e)
|
||||
(exception
|
||||
unison-miscfailure:typelink
|
||||
(exception->string e)
|
||||
'()))]
|
||||
[(lambda err
|
||||
(string-contains? (exn->string err) "not valid for hostname"))
|
||||
(lambda (e)
|
||||
(exception
|
||||
unison-iofailure:link
|
||||
unison-tlsfailure:typelink
|
||||
(string->chunked-string "NameMismatch")
|
||||
'()))]
|
||||
[(lambda err
|
||||
(string-contains? (exn->string err) "certificate verify failed"))
|
||||
(lambda (e)
|
||||
(exception
|
||||
unison-iofailure:link
|
||||
unison-tlsfailure:typelink
|
||||
(string->chunked-string "certificate verify failed")
|
||||
'()))]
|
||||
[(lambda _ #t) (lambda (e) (exception "MiscFailure" (string->chunked-string (format "Unknown exception ~a" (exn->string e))) e))]]
|
||||
[(lambda _ #t)
|
||||
(lambda (e)
|
||||
(exception
|
||||
unison-miscfailure:typelink
|
||||
(string->chunked-string
|
||||
(format "Unknown exception ~a" (exn->string e)))
|
||||
e))]]
|
||||
(fn)))
|
||||
|
||||
(define (newClient.impl.v3 config socket)
|
||||
|
||||
@ -719,7 +719,7 @@
|
||||
(next-leaf!)
|
||||
(vector-copy! new-leaf leaf-split-i leaf 0 leaf-split-i))]
|
||||
[else
|
||||
(vector-copy! new-leaf leaf-i leaf first-leaf-start leaf-insert-i)])))]
|
||||
(vector-copy! new-leaf leaf-i leaf first-leaf-start last-leaf-end)])))]
|
||||
[else
|
||||
(make-node
|
||||
(λ (new-node)
|
||||
|
||||
@ -1,6 +1,7 @@
|
||||
; Zlib
|
||||
#lang racket/base
|
||||
(require unison/data
|
||||
unison/data-info
|
||||
unison/core
|
||||
(only-in unison/chunked-seq
|
||||
bytes->chunked-bytes
|
||||
@ -105,5 +106,14 @@
|
||||
(bytes->chunked-bytes (zlib-deflate-bytes (chunked-bytes->bytes bytes))))
|
||||
|
||||
(define (zlib.decompress bytes)
|
||||
(with-handlers [[exn:fail? (lambda (e) (exception "Zlib data corrupted" (exception->string e) '()))] ]
|
||||
(right (bytes->chunked-bytes (zlib-inflate-bytes (chunked-bytes->bytes bytes))))))
|
||||
(with-handlers
|
||||
[[exn:fail?
|
||||
(lambda (e)
|
||||
(exception
|
||||
unison-miscfailure:typelink
|
||||
(exception->string e)
|
||||
'()))]]
|
||||
(right
|
||||
(bytes->chunked-bytes
|
||||
(zlib-inflate-bytes
|
||||
(chunked-bytes->bytes bytes))))))
|
||||
|
||||
@ -47,9 +47,9 @@ typecheckTerm codebase tm = do
|
||||
typeLookup <- Codebase.typeLookupForDependencies codebase (UF.dependencies file)
|
||||
let typecheckingEnv =
|
||||
Typechecker.Env
|
||||
{ _ambientAbilities = [],
|
||||
_typeLookup = typeLookup,
|
||||
_termsByShortname = Map.empty
|
||||
{ ambientAbilities = [],
|
||||
typeLookup,
|
||||
termsByShortname = Map.empty
|
||||
}
|
||||
pure $ fmap extract $ FileParsers.synthesizeFile typecheckingEnv file
|
||||
where
|
||||
|
||||
@ -155,9 +155,9 @@ synthesizeForce tl typeOfFunc = do
|
||||
ref = Reference.DerivedId (Reference.Id (Hash.fromByteString "deadbeef") 0)
|
||||
env =
|
||||
Typechecker.Env
|
||||
{ Typechecker._ambientAbilities = [DD.exceptionType External, Type.builtinIO External],
|
||||
Typechecker._typeLookup = mempty {TypeLookup.typeOfTerms = Map.singleton ref typeOfFunc} <> tl,
|
||||
Typechecker._termsByShortname = Map.empty
|
||||
{ ambientAbilities = [DD.exceptionType External, Type.builtinIO External],
|
||||
typeLookup = mempty {TypeLookup.typeOfTerms = Map.singleton ref typeOfFunc} <> tl,
|
||||
termsByShortname = Map.empty
|
||||
}
|
||||
case Result.runResultT
|
||||
( Typechecker.synthesize
|
||||
|
||||
@ -341,10 +341,10 @@ analyseNotes fileUri ppe src notes = do
|
||||
Context.Suggestion {suggestionName, suggestionType, suggestionMatch} <- sortOn nameResolutionSuggestionPriority suggestions
|
||||
let prettyType = TypePrinter.prettyStr Nothing ppe suggestionType
|
||||
let ranges = (diags ^.. folded . range)
|
||||
let rca = rangedCodeAction ("Use " <> suggestionName <> " : " <> Text.pack prettyType) diags ranges
|
||||
let rca = rangedCodeAction ("Use " <> Name.toText suggestionName <> " : " <> Text.pack prettyType) diags ranges
|
||||
pure $
|
||||
rca
|
||||
& includeEdits fileUri suggestionName ranges
|
||||
& includeEdits fileUri (Name.toText suggestionName) ranges
|
||||
& codeAction . isPreferred ?~ (suggestionMatch == Context.Exact)
|
||||
|
||||
nameResolutionSuggestionPriority (Context.Suggestion {suggestionMatch, suggestionName}) = case suggestionMatch of
|
||||
|
||||
@ -1,4 +1,10 @@
|
||||
module Unison.Blank where
|
||||
module Unison.Blank
|
||||
( Blank (..),
|
||||
Recorded (..),
|
||||
loc,
|
||||
nameb,
|
||||
)
|
||||
where
|
||||
|
||||
import Unison.Prelude
|
||||
|
||||
@ -16,17 +22,12 @@ data Recorded loc
|
||||
= -- A user-provided named placeholder
|
||||
Placeholder loc String
|
||||
| -- A name to be resolved with type-directed name resolution.
|
||||
Resolve
|
||||
loc
|
||||
String
|
||||
Resolve loc String
|
||||
| -- A placeholder for a missing result at the end of a block
|
||||
MissingResultPlaceholder
|
||||
loc
|
||||
MissingResultPlaceholder loc
|
||||
deriving (Show, Eq, Ord, Functor, Generic)
|
||||
|
||||
-- - Blank is just a dummy annotation.
|
||||
-- - Recorded indicates that we want to remember the variable's solution
|
||||
-- for some kind of
|
||||
-- | Blank is just a dummy annotation.
|
||||
data Blank loc
|
||||
= -- | just a dummy annotation
|
||||
Blank
|
||||
|
||||
@ -335,13 +335,8 @@ searchBySuffix suffix rel =
|
||||
where
|
||||
orElse s1 s2 = if Set.null s1 then s2 else s1
|
||||
|
||||
-- Like `searchBySuffix`, but prefers names that have fewer
|
||||
-- segments equal to "lib". This is used to prefer "local"
|
||||
-- names rather than names coming from libraries, which
|
||||
-- are traditionally placed under a "lib" subnamespace.
|
||||
--
|
||||
-- Example: foo.bar shadows lib.foo.bar
|
||||
-- Example: lib.foo.bar shadows lib.blah.lib.foo.bar
|
||||
-- Like `searchBySuffix`, but prefers local (outside `lib`) and direct (one `lib` deep) names to indirect (two or more
|
||||
-- `lib` deep) names.
|
||||
searchByRankedSuffix :: (Ord r) => Name -> R.Relation Name r -> Set r
|
||||
searchByRankedSuffix suffix rel =
|
||||
let rs = searchBySuffix suffix rel
|
||||
@ -359,14 +354,31 @@ preferShallowLibDepth = \case
|
||||
[] -> Set.empty
|
||||
[x] -> Set.singleton (snd x)
|
||||
rs ->
|
||||
let byDepth = List.multimap (map (first minLibs) rs)
|
||||
libCount = length . filter (== NameSegment.libSegment) . toList . reverseSegments
|
||||
minLibs [] = 0
|
||||
minLibs ns = minimum (map libCount ns)
|
||||
in case Map.lookup 0 byDepth <|> Map.lookup 1 byDepth of
|
||||
let byPriority = List.multimap (map (first minLibs) rs)
|
||||
minLibs [] = NamePriorityOne
|
||||
minLibs ns = minimum (map classifyNamePriority ns)
|
||||
in case Map.lookup NamePriorityOne byPriority <|> Map.lookup NamePriorityTwo byPriority of
|
||||
Nothing -> Set.fromList (map snd rs)
|
||||
Just rs -> Set.fromList rs
|
||||
|
||||
data NamePriority
|
||||
= NamePriorityOne -- highest priority: local names and direct dep names
|
||||
| NamePriorityTwo -- lowest priority: indirect dep names
|
||||
deriving stock (Eq, Ord)
|
||||
|
||||
classifyNamePriority :: Name -> NamePriority
|
||||
classifyNamePriority name =
|
||||
case isIndirectDependency (List.NonEmpty.toList (segments name)) of
|
||||
False -> NamePriorityOne
|
||||
True -> NamePriorityTwo
|
||||
where
|
||||
-- isIndirectDependency foo = False
|
||||
-- isIndirectDependency lib.bar.honk = False
|
||||
-- isIndirectDependency lib.baz.lib.qux.flonk = True
|
||||
isIndirectDependency = \case
|
||||
((== NameSegment.libSegment) -> True) : _ : ((== NameSegment.libSegment) -> True) : _ -> True
|
||||
_ -> False
|
||||
|
||||
sortByText :: (a -> Text) -> [a] -> [a]
|
||||
sortByText by as =
|
||||
let as' = [(a, by a) | a <- as]
|
||||
|
||||
@ -5,7 +5,7 @@ Next, we'll download the jit project and generate a few Racket files from it.
|
||||
|
||||
```ucm
|
||||
.> project.create-empty jit-setup
|
||||
jit-setup/main> pull @unison/internal/releases/0.0.11 lib.jit
|
||||
jit-setup/main> pull @unison/internal/releases/0.0.12 lib.jit
|
||||
```
|
||||
|
||||
```unison
|
||||
|
||||
@ -20,9 +20,9 @@ Next, we'll download the jit project and generate a few Racket files from it.
|
||||
|
||||
🎉 🥳 Happy coding!
|
||||
|
||||
jit-setup/main> pull @unison/internal/releases/0.0.11 lib.jit
|
||||
jit-setup/main> pull @unison/internal/releases/0.0.12 lib.jit
|
||||
|
||||
Downloaded 13900 entities.
|
||||
Downloaded 15048 entities.
|
||||
|
||||
✅
|
||||
|
||||
|
||||
@ -79,17 +79,15 @@ Abort.toOptional : '{g, Abort} a -> '{g} Optional a
|
||||
Abort.toOptional thunk = do toOptional! thunk
|
||||
|
||||
Abort.toOptional! : '{g, Abort} a ->{g} Optional a
|
||||
Abort.toOptional! thunk = toDefault! None '(Some !thunk)
|
||||
Abort.toOptional! thunk = toDefault! None do Some !thunk
|
||||
|
||||
catchAll : x -> Nat
|
||||
catchAll x = 99
|
||||
|
||||
Decode.remainder : '{Ask (Optional Bytes)} Bytes
|
||||
Decode.remainder = do
|
||||
use Bytes ++
|
||||
match ask with
|
||||
None -> Bytes.empty
|
||||
Some b -> b ++ !Decode.remainder
|
||||
Decode.remainder = do match ask with
|
||||
None -> Bytes.empty
|
||||
Some b -> b Bytes.++ !Decode.remainder
|
||||
|
||||
ex1 : Nat
|
||||
ex1 =
|
||||
@ -232,9 +230,10 @@ fix_3110c : ()
|
||||
fix_3110c = fix_3110a [1, 2, 3] (x -> ignore (Nat.increment x))
|
||||
|
||||
fix_3110d : ()
|
||||
fix_3110d = fix_3110a [1, 2, 3] '(x -> do
|
||||
fix_3110d = fix_3110a [1, 2, 3] do
|
||||
x -> do
|
||||
y = Nat.increment x
|
||||
())
|
||||
()
|
||||
|
||||
fix_3627 : Nat -> Nat -> Nat
|
||||
fix_3627 = cases
|
||||
@ -293,15 +292,15 @@ fix_4352 : Doc2
|
||||
fix_4352 = {{ `` +1 `` }}
|
||||
|
||||
fix_4384 : Doc2
|
||||
fix_4384 = {{ {{ docExampleBlock 0 '2 }} }}
|
||||
fix_4384 = {{ {{ docExampleBlock 0 do 2 }} }}
|
||||
|
||||
fix_4384a : Doc2
|
||||
fix_4384a =
|
||||
use Nat +
|
||||
{{ {{ docExampleBlock 0 '(1 + 1) }} }}
|
||||
{{ {{ docExampleBlock 0 do 1 + 1 }} }}
|
||||
|
||||
fix_4384b : Doc2
|
||||
fix_4384b = {{ {{ docExampleBlock 0 '99 }} }}
|
||||
fix_4384b = {{ {{ docExampleBlock 0 do 99 }} }}
|
||||
|
||||
fix_4384c : Doc2
|
||||
fix_4384c =
|
||||
@ -317,25 +316,8 @@ fix_4384d : Doc2
|
||||
fix_4384d =
|
||||
{{
|
||||
{{
|
||||
docExampleBlock 0 '[ 1
|
||||
, 2
|
||||
, 3
|
||||
, 4
|
||||
, 5
|
||||
, 6
|
||||
, 7
|
||||
, 8
|
||||
, 9
|
||||
, 10
|
||||
, 11
|
||||
, 12
|
||||
, 13
|
||||
, 14
|
||||
, 15
|
||||
, 16
|
||||
, 17
|
||||
, 18
|
||||
] }}
|
||||
docExampleBlock 0 do
|
||||
[1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18] }}
|
||||
}}
|
||||
|
||||
fix_4384e : Doc2
|
||||
@ -407,8 +389,9 @@ longlines1 =
|
||||
longlines2 : (Text, '{g} Bytes)
|
||||
longlines2 =
|
||||
( "adsf"
|
||||
, '(toUtf8
|
||||
"adsfsfdgsfdgsdfgsdfgsfdgsfdgsdgsgsgfsfgsgsfdgsgfsfdgsgfsfdgsdgsdfgsgf")
|
||||
, do
|
||||
toUtf8
|
||||
"adsfsfdgsfdgsdfgsdfgsfdgsfdgsdgsgsgfsfgsgsfdgsgfsfdgsgfsfdgsdgsdfgsgf"
|
||||
)
|
||||
|
||||
longlines_helper : x -> 'x
|
||||
@ -640,7 +623,7 @@ stew_issue =
|
||||
toText a = a
|
||||
Debug : a -> b -> ()
|
||||
Debug a b = ()
|
||||
error (Debug None '(Debug "Failed " 42))
|
||||
error (Debug None do Debug "Failed " 42)
|
||||
|
||||
stew_issue2 : ()
|
||||
stew_issue2 =
|
||||
@ -649,7 +632,7 @@ stew_issue2 =
|
||||
toText a = a
|
||||
Debug : a -> b -> ()
|
||||
Debug a b = ()
|
||||
error (Debug None '("Failed " ++ toText 42))
|
||||
error (Debug None do "Failed " ++ toText 42)
|
||||
|
||||
stew_issue3 : ()
|
||||
stew_issue3 =
|
||||
@ -661,8 +644,8 @@ stew_issue3 =
|
||||
configPath = 0
|
||||
Debug a b = ()
|
||||
error
|
||||
(Debug None '("Failed to get timestamp of config file "
|
||||
++ toText configPath))
|
||||
(Debug None do
|
||||
"Failed to get timestamp of config file " ++ toText configPath)
|
||||
|
||||
test3 : '('('r))
|
||||
test3 = do
|
||||
@ -671,7 +654,7 @@ test3 = do
|
||||
runrun = 42
|
||||
a = "asldkfj"
|
||||
b = "asdflkjasdf"
|
||||
''(run runrun ''runrun)
|
||||
do do run runrun do do runrun
|
||||
|
||||
use_clauses_example : Int -> Text -> Nat
|
||||
use_clauses_example oo quaffle =
|
||||
@ -689,9 +672,8 @@ UUID.random = do UUID 0 (0, 0)
|
||||
|
||||
UUID.randomUUIDBytes : 'Bytes
|
||||
UUID.randomUUIDBytes = do
|
||||
use Bytes ++
|
||||
(UUID a (b, _)) = !random
|
||||
encodeNat64be a ++ encodeNat64be b
|
||||
encodeNat64be a Bytes.++ encodeNat64be b
|
||||
|
||||
(|>) : a -> (a ->{e} b) ->{e} b
|
||||
a |> f = f a
|
||||
|
||||
@ -331,14 +331,14 @@ and the rendered output using `display`:
|
||||
You can include typechecked code snippets inline, for
|
||||
instance:
|
||||
|
||||
* {{ docExample 2 '(f x -> f x + sqr 1) }} - the `2`
|
||||
* {{ docExample 2 do f x -> f x + sqr 1 }} - the `2`
|
||||
says to ignore the first two arguments when
|
||||
rendering. In richer renderers, the `sqr` link will
|
||||
be clickable.
|
||||
* If your snippet expression is just a single function
|
||||
application, you can put it in double backticks, like
|
||||
so: ``sqr x``. This is equivalent to
|
||||
{{ docExample 1 '(x -> sqr x) }}.
|
||||
{{ docExample 1 do x -> sqr x }}.
|
||||
}}
|
||||
|
||||
.> display includingSource
|
||||
|
||||
@ -1250,7 +1250,8 @@ rendered = Pretty.get (docFormatConsole doc.guide)
|
||||
(Right
|
||||
(Term.Term
|
||||
(Any
|
||||
'Some)))))
|
||||
(do
|
||||
Some))))))
|
||||
, Lit
|
||||
()
|
||||
(Right
|
||||
@ -1569,7 +1570,7 @@ rendered = Pretty.get (docFormatConsole doc.guide)
|
||||
(SpecialForm.Link
|
||||
(Right
|
||||
(Term.Term
|
||||
(Any 'lists)))))
|
||||
(Any (do lists))))))
|
||||
])))
|
||||
]))))
|
||||
, Lit () (Right (Plain "\n"))
|
||||
@ -2680,7 +2681,8 @@ rendered = Pretty.get (docFormatConsole doc.guide)
|
||||
(EvalInline
|
||||
(Term.Term
|
||||
(Any
|
||||
'(1
|
||||
(do
|
||||
1
|
||||
Nat.+ 1)))))
|
||||
, Lit
|
||||
()
|
||||
@ -2937,7 +2939,7 @@ rendered = Pretty.get (docFormatConsole doc.guide)
|
||||
)
|
||||
, ( Right
|
||||
(Term.Term
|
||||
(Any 'sqr))
|
||||
(Any (do sqr)))
|
||||
, []
|
||||
)
|
||||
])))))
|
||||
@ -2996,7 +2998,7 @@ rendered = Pretty.get (docFormatConsole doc.guide)
|
||||
)
|
||||
, ( Right
|
||||
(Term.Term
|
||||
(Any 'sqr))
|
||||
(Any (do sqr)))
|
||||
, []
|
||||
)
|
||||
])))))
|
||||
@ -3045,7 +3047,8 @@ rendered = Pretty.get (docFormatConsole doc.guide)
|
||||
(Left
|
||||
(SignatureInline
|
||||
(Term.Term
|
||||
(Any 'sqr))))
|
||||
(Any
|
||||
(do sqr)))))
|
||||
, Lit
|
||||
()
|
||||
(Right (Plain ","))
|
||||
@ -3091,9 +3094,10 @@ rendered = Pretty.get (docFormatConsole doc.guide)
|
||||
()
|
||||
(Left
|
||||
(SpecialForm.Signature
|
||||
[ Term.Term (Any 'sqr)
|
||||
[ Term.Term
|
||||
(Any (do sqr))
|
||||
, Term.Term
|
||||
(Any '(Nat.+))
|
||||
(Any (do (Nat.+)))
|
||||
])))))
|
||||
, Lit () (Right (Plain "\n"))
|
||||
, Lit () (Right (Plain "\n"))
|
||||
@ -3129,7 +3133,7 @@ rendered = Pretty.get (docFormatConsole doc.guide)
|
||||
(Left
|
||||
(SpecialForm.Signature
|
||||
[ Term.Term
|
||||
(Any 'List.map)
|
||||
(Any (do List.map))
|
||||
])))))
|
||||
, Lit () (Right (Plain "\n"))
|
||||
, Lit () (Right (Plain "\n"))
|
||||
@ -3272,7 +3276,8 @@ rendered = Pretty.get (docFormatConsole doc.guide)
|
||||
2
|
||||
(Term.Term
|
||||
(Any
|
||||
'(f
|
||||
(do
|
||||
f
|
||||
x ->
|
||||
f
|
||||
x
|
||||
@ -3547,7 +3552,8 @@ rendered = Pretty.get (docFormatConsole doc.guide)
|
||||
1
|
||||
(Term.Term
|
||||
(Any
|
||||
'(x ->
|
||||
(do
|
||||
x ->
|
||||
sqr
|
||||
x)))))
|
||||
, Lit
|
||||
@ -3589,7 +3595,8 @@ rendered = Pretty.get (docFormatConsole doc.guide)
|
||||
1
|
||||
(Term.Term
|
||||
(Any
|
||||
'(x ->
|
||||
(do
|
||||
x ->
|
||||
sqr
|
||||
x)))))
|
||||
, Lit
|
||||
@ -3953,15 +3960,16 @@ rendered = Pretty.get (docFormatConsole doc.guide)
|
||||
(Left
|
||||
(SpecialForm.Signature
|
||||
[ Term.Term
|
||||
(Any 'docAside)
|
||||
(Any (do docAside))
|
||||
, Term.Term
|
||||
(Any 'docCallout)
|
||||
(Any (do docCallout))
|
||||
, Term.Term
|
||||
(Any 'docBlockquote)
|
||||
(Any
|
||||
(do docBlockquote))
|
||||
, Term.Term
|
||||
(Any 'docTooltip)
|
||||
(Any (do docTooltip))
|
||||
, Term.Term
|
||||
(Any 'docTable)
|
||||
(Any (do docTable))
|
||||
]))))
|
||||
, Lit () (Right (Plain "\n"))
|
||||
, Lit () (Right (Plain "\n"))
|
||||
|
||||
11
unison-src/transcripts/patterns.md
Normal file
11
unison-src/transcripts/patterns.md
Normal file
@ -0,0 +1,11 @@
|
||||
```ucm:hide
|
||||
.> builtins.merge
|
||||
```
|
||||
|
||||
Some tests of pattern behavior.
|
||||
|
||||
```unison
|
||||
p1 = join [literal "blue", literal "frog"]
|
||||
|
||||
> Pattern.run (many p1) "bluefrogbluegoat"
|
||||
```
|
||||
28
unison-src/transcripts/patterns.output.md
Normal file
28
unison-src/transcripts/patterns.output.md
Normal file
@ -0,0 +1,28 @@
|
||||
Some tests of pattern behavior.
|
||||
|
||||
```unison
|
||||
p1 = join [literal "blue", literal "frog"]
|
||||
|
||||
> Pattern.run (many p1) "bluefrogbluegoat"
|
||||
```
|
||||
|
||||
```ucm
|
||||
|
||||
Loading changes detected in scratch.u.
|
||||
|
||||
I found and typechecked these definitions in scratch.u. If you
|
||||
do an `add` or `update`, here's how your codebase would
|
||||
change:
|
||||
|
||||
⍟ These new definitions are ok to `add`:
|
||||
|
||||
p1 : Pattern Text
|
||||
|
||||
Now evaluating any watch expressions (lines starting with
|
||||
`>`)... Ctrl+C cancels.
|
||||
|
||||
3 | > Pattern.run (many p1) "bluefrogbluegoat"
|
||||
⧩
|
||||
Some ([], "bluegoat")
|
||||
|
||||
```
|
||||
@ -39,10 +39,9 @@ Type-based search also benefits from this, we can just say `Nat` rather than `.b
|
||||
.> find : Nat -> [a] -> [a]
|
||||
```
|
||||
|
||||
## Preferring names not in `lib`
|
||||
## Preferring names not in `lib.*.lib.*`
|
||||
|
||||
Suffix-based resolution prefers names with fewer name segments that are equal to "lib". This
|
||||
has the effect of preferring names defined in your project to names from dependencies of your project, and names from indirect dependencies have even lower weight.
|
||||
Suffix-based resolution prefers names that are not in an indirect dependency.
|
||||
|
||||
```unison
|
||||
cool.abra.cadabra = "my project"
|
||||
@ -55,8 +54,11 @@ lib.distributed.lib.baz.qux = "indirect dependency"
|
||||
.> add
|
||||
```
|
||||
|
||||
```unison
|
||||
```unison:error
|
||||
> abra.cadabra
|
||||
```
|
||||
|
||||
```unison
|
||||
> baz.qux
|
||||
```
|
||||
|
||||
|
||||
@ -57,10 +57,9 @@ Type-based search also benefits from this, we can just say `Nat` rather than `.b
|
||||
|
||||
|
||||
```
|
||||
## Preferring names not in `lib`
|
||||
## Preferring names not in `lib.*.lib.*`
|
||||
|
||||
Suffix-based resolution prefers names with fewer name segments that are equal to "lib". This
|
||||
has the effect of preferring names defined in your project to names from dependencies of your project, and names from indirect dependencies have even lower weight.
|
||||
Suffix-based resolution prefers names that are not in an indirect dependency.
|
||||
|
||||
```unison
|
||||
cool.abra.cadabra = "my project"
|
||||
@ -98,6 +97,27 @@ lib.distributed.lib.baz.qux = "indirect dependency"
|
||||
```
|
||||
```unison
|
||||
> abra.cadabra
|
||||
```
|
||||
|
||||
```ucm
|
||||
|
||||
Loading changes detected in scratch.u.
|
||||
|
||||
I couldn't figure out what abra.cadabra refers to here:
|
||||
|
||||
1 | > abra.cadabra
|
||||
|
||||
The name abra.cadabra is ambiguous. I couldn't narrow it down
|
||||
by type, as any type would work here.
|
||||
|
||||
I found some terms in scope that have matching names and
|
||||
types. Maybe you meant one of these:
|
||||
|
||||
cool.abra.cadabra : Text
|
||||
distributed.abra.cadabra : Text
|
||||
|
||||
```
|
||||
```unison
|
||||
> baz.qux
|
||||
```
|
||||
|
||||
@ -112,11 +132,7 @@ lib.distributed.lib.baz.qux = "indirect dependency"
|
||||
Now evaluating any watch expressions (lines starting with
|
||||
`>`)... Ctrl+C cancels.
|
||||
|
||||
1 | > abra.cadabra
|
||||
⧩
|
||||
"my project"
|
||||
|
||||
2 | > baz.qux
|
||||
1 | > baz.qux
|
||||
⧩
|
||||
"direct dependency 2"
|
||||
|
||||
@ -126,6 +142,9 @@ lib.distributed.lib.baz.qux = "indirect dependency"
|
||||
|
||||
cool.abra.cadabra : Text
|
||||
cool.abra.cadabra = "my project"
|
||||
|
||||
lib.distributed.abra.cadabra : Text
|
||||
lib.distributed.abra.cadabra = "direct dependency 1"
|
||||
|
||||
.> view baz.qux
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user