mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-11 02:25:39 +03:00
Merge remote-tracking branch 'origin/trunk' into kylegoetz-udp
# Conflicts: # unison-core/src/Unison/Type.hs
This commit is contained in:
commit
eef5dda29c
2
.github/workflows/ci.md
vendored
2
.github/workflows/ci.md
vendored
@ -9,7 +9,7 @@ At a high level, the CI process is:
|
||||
Some version numbers that are used during CI:
|
||||
- `ormolu_version: "0.5.0.1"`
|
||||
- `racket_version: "8.7"`
|
||||
- `jit_version: "@unison/internal/releases/0.0.11"`
|
||||
- `jit_version: "@unison/internal/releases/0.0.14"`
|
||||
|
||||
Some cached directories:
|
||||
- `ucm_local_bin` a temp path for caching a built `ucm`
|
||||
|
21
.github/workflows/ci.yaml
vendored
21
.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.13"
|
||||
jit_version: "@unison/internal/releases/0.0.14"
|
||||
jit_src_scheme: "unison-jit-src/scheme-libs/racket"
|
||||
jit_dist: "unison-jit-dist"
|
||||
jit_generator_os: ubuntu-20.04
|
||||
@ -142,6 +142,13 @@ jobs:
|
||||
--local-bin-path ${{env.ucm_local_bin}} \
|
||||
--copy-bins
|
||||
|
||||
# The unison-cli test requires a git user.
|
||||
- name: set git user info
|
||||
if: steps.cache-ucm-binaries.outputs.cache-hit != 'true'
|
||||
run: |
|
||||
git config --global user.name "GitHub Actions"
|
||||
git config --global user.email "actions@github.com"
|
||||
|
||||
# Run each test suite (tests and transcripts)
|
||||
- name: unison-cli test
|
||||
if: steps.cache-ucm-binaries.outputs.cache-hit != 'true'
|
||||
@ -244,12 +251,12 @@ jobs:
|
||||
path: ${{env.ucm_local_bin}}
|
||||
key: ucm-${{ matrix.os }}-${{ hashFiles('**/stack.yaml', '**/package.yaml', '**/*.hs')}}
|
||||
fail-on-cache-miss: true
|
||||
# # One of the transcripts fails if the user's git name hasn't been set.
|
||||
# ## (Which transcript? -AI)
|
||||
# - name: set git user info
|
||||
# run: |
|
||||
# git config --global user.name "GitHub Actions"
|
||||
# git config --global user.email "actions@github.com"
|
||||
# One of the transcripts fails if the user's git name hasn't been set.
|
||||
## (Which transcript? -AI)
|
||||
- name: set git user info
|
||||
run: |
|
||||
git config --global user.name "GitHub Actions"
|
||||
git config --global user.email "actions@github.com"
|
||||
- name: round-trip-tests
|
||||
if: steps.cache-transcript-test-results.outputs.cache-hit != 'true'
|
||||
run: |
|
||||
|
@ -3,7 +3,7 @@
|
||||
|
||||
-- This table is used to associate a mount point with a particular name lookup index.
|
||||
CREATE TABLE name_lookup_mounts (
|
||||
-- The the parent index we're mounting inside of.
|
||||
-- The parent index we're mounting inside of.
|
||||
parent_root_branch_hash_id INTEGER NOT NULL REFERENCES name_lookups(root_branch_hash_id) ON DELETE CASCADE,
|
||||
-- The index we're mounting.
|
||||
-- Don't allow deleting a mounted name lookup while it's still mounted in some other index,
|
||||
|
15
lib/unison-prelude/src/Unison/Util/Tuple.hs
Normal file
15
lib/unison-prelude/src/Unison/Util/Tuple.hs
Normal file
@ -0,0 +1,15 @@
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
-- | Tuple utils.
|
||||
module Unison.Util.Tuple
|
||||
( drop4th,
|
||||
)
|
||||
where
|
||||
|
||||
class Drop4th a b | a -> b where
|
||||
-- | Drop the 4th element of a tuple.
|
||||
drop4th :: a -> b
|
||||
|
||||
instance (x ~ (a, b, c)) => Drop4th (a, b, c, d) x where
|
||||
drop4th (a, b, c, _) = (a, b, c)
|
@ -1,6 +1,6 @@
|
||||
cabal-version: 1.12
|
||||
|
||||
-- This file has been generated from package.yaml by hpack version 0.35.2.
|
||||
-- This file has been generated from package.yaml by hpack version 0.36.0.
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
|
||||
@ -27,6 +27,7 @@ library
|
||||
Unison.Util.Monoid
|
||||
Unison.Util.Set
|
||||
Unison.Util.Timing
|
||||
Unison.Util.Tuple
|
||||
hs-source-dirs:
|
||||
src
|
||||
default-extensions:
|
||||
|
@ -13,7 +13,7 @@ import Unison.Util.Star2 qualified as Star2
|
||||
type Value = TermReference
|
||||
|
||||
-- `a` is generally the type of references or hashes
|
||||
-- `n` is generally the the type of name associated with the references
|
||||
-- `n` is generally the type of name associated with the references
|
||||
-- `Value` is the metadata value itself.
|
||||
type Star a n = Star2 a n Value
|
||||
|
||||
|
@ -6,7 +6,6 @@ module Unison.DataDeclaration.Dependencies
|
||||
DD.labeledDeclTypeDependencies,
|
||||
DD.labeledDeclDependenciesIncludingSelf,
|
||||
labeledDeclDependenciesIncludingSelfAndFieldAccessors,
|
||||
fieldAccessorRefs,
|
||||
hashFieldAccessors,
|
||||
)
|
||||
where
|
||||
@ -15,24 +14,25 @@ import Control.Lens
|
||||
import Data.Map qualified as Map
|
||||
import Data.Set qualified as Set
|
||||
import Data.Set.Lens (setOf)
|
||||
import U.Codebase.Reference qualified as V2Reference
|
||||
import Unison.DataDeclaration qualified as DD
|
||||
import Unison.DataDeclaration.Records (generateRecordAccessors)
|
||||
import Unison.Hashing.V2.Convert qualified as Hashing
|
||||
import Unison.LabeledDependency qualified as LD
|
||||
import Unison.Prelude
|
||||
import Unison.PrettyPrintEnv (PrettyPrintEnv)
|
||||
import Unison.PrettyPrintEnv qualified as PPE
|
||||
import Unison.Reference (Reference)
|
||||
import Unison.Reference qualified as Reference
|
||||
import Unison.Reference (TermReferenceId, TypeReference)
|
||||
import Unison.Referent (Referent)
|
||||
import Unison.Referent qualified as Referent
|
||||
import Unison.Result qualified as Result
|
||||
import Unison.Syntax.Var qualified as Var (namespaced)
|
||||
import Unison.Term qualified as Term
|
||||
import Unison.Term (Term)
|
||||
import Unison.Type (Type)
|
||||
import Unison.Type qualified as Type
|
||||
import Unison.Typechecker qualified as Typechecker
|
||||
import Unison.Typechecker.TypeLookup (TypeLookup (..))
|
||||
import Unison.Typechecker.TypeLookup qualified as TypeLookup
|
||||
import Unison.Util.Tuple qualified as Tuple
|
||||
import Unison.Var (Var)
|
||||
import Unison.Var qualified as Var
|
||||
|
||||
-- | Generate the LabeledDependencies for everything in a Decl, including the Decl itself, all
|
||||
@ -40,7 +40,7 @@ import Unison.Var qualified as Var
|
||||
--
|
||||
-- Note that we can't actually tell whether the Decl was originally a record or not, so we
|
||||
-- include all possible accessors, but they may or may not exist in the codebase.
|
||||
labeledDeclDependenciesIncludingSelfAndFieldAccessors :: Var.Var v => V2Reference.TypeReference -> (DD.Decl v a) -> Set LD.LabeledDependency
|
||||
labeledDeclDependenciesIncludingSelfAndFieldAccessors :: Var v => TypeReference -> (DD.Decl v a) -> Set LD.LabeledDependency
|
||||
labeledDeclDependenciesIncludingSelfAndFieldAccessors selfRef decl =
|
||||
DD.labeledDeclDependenciesIncludingSelf selfRef decl
|
||||
<> case decl of
|
||||
@ -50,67 +50,76 @@ labeledDeclDependenciesIncludingSelfAndFieldAccessors selfRef decl =
|
||||
& maybe Set.empty (Set.map LD.TermReferent)
|
||||
|
||||
-- | Generate Referents for all possible field accessors of a Decl.
|
||||
-- Returns 'Nothing' if typechecking of any accessor fails.
|
||||
fieldAccessorRefs :: forall v a. (Var.Var v) => Reference -> DD.DataDeclaration v a -> Maybe (Set Referent)
|
||||
--
|
||||
-- Returns @Nothing@ if this couldn't be a record because it doesn't contain exactly one constructor, or because the
|
||||
-- record contains a field with a higher rank type (and thus fails type inference).
|
||||
fieldAccessorRefs :: forall v a. (Var v) => TypeReference -> DD.DataDeclaration v a -> Maybe (Set Referent)
|
||||
fieldAccessorRefs declRef dd = do
|
||||
-- This ppe is only used for typechecking errors.
|
||||
let ppe = PPE.empty
|
||||
typ <- case DD.constructors dd of
|
||||
[(_, typ)] -> Just typ
|
||||
_ -> Nothing
|
||||
[(_, typ)] <- Just (DD.constructors dd)
|
||||
|
||||
-- This name isn't important, we just need a name to generate field names from.
|
||||
-- The field names are thrown away afterwards.
|
||||
let typeName = Var.named "Type"
|
||||
-- These names are arbitrary and don't show up anywhere.
|
||||
let vars :: [v]
|
||||
vars = [Var.freshenId (fromIntegral n) (Var.named "_") | n <- [0 .. Type.arity typ - 1]]
|
||||
hashFieldAccessors ppe typeName vars declRef dd
|
||||
<&> \accs ->
|
||||
Map.elems accs
|
||||
& setOf (folded . _1 . to (Reference.DerivedId >>> Referent.Ref))
|
||||
-- We add `n` to the end of the variable name as a quick fix to #4752, but we suspect there's a more
|
||||
-- fundamental fix to be made somewhere in the term printer to automatically suffix a var name with its
|
||||
-- freshened id if it would be ambiguous otherwise.
|
||||
vars = [Var.freshenId (fromIntegral n) (Var.named ("_" <> tShow n)) | n <- [0 .. Type.arity typ - 1]]
|
||||
|
||||
accessors <- hashFieldAccessors PPE.empty typeName vars declRef dd
|
||||
|
||||
Just (setOf (folded . _1 . to Referent.fromTermReferenceId) accessors)
|
||||
|
||||
-- | Generate Referents for all possible field accessors of a Decl.
|
||||
-- Returns 'Nothing' if typechecking of any accessor fails (which shouldn't happen).
|
||||
--
|
||||
-- Returns @Nothing@ if inferring/typechecking of any accessor fails, which shouldn't normally happen, but does when
|
||||
-- record fields are higher rank, because the higher rank types can't be inferred.
|
||||
--
|
||||
-- See https://github.com/unisonweb/unison/issues/498
|
||||
hashFieldAccessors ::
|
||||
forall v a.
|
||||
(Var.Var v) =>
|
||||
PrettyPrintEnv ->
|
||||
v ->
|
||||
[v] ->
|
||||
Reference ->
|
||||
TypeReference ->
|
||||
DD.DataDeclaration v a ->
|
||||
( Maybe
|
||||
(Map v (Reference.Id, Term.Term v (), Type.Type v ()))
|
||||
)
|
||||
Maybe (Map v (TermReferenceId, Term v (), Type v ()))
|
||||
hashFieldAccessors ppe declName vars declRef dd = do
|
||||
let accessors :: [(v, (), Term.Term v ())]
|
||||
accessors = DD.generateRecordAccessors Var.namespaced mempty (map (,()) vars) declName declRef
|
||||
let typeLookup :: TypeLookup v ()
|
||||
typeLookup =
|
||||
TypeLookup
|
||||
{ TypeLookup.typeOfTerms = mempty,
|
||||
TypeLookup.dataDecls = Map.singleton declRef (void dd),
|
||||
TypeLookup.effectDecls = mempty
|
||||
}
|
||||
let typecheckingEnv :: Typechecker.Env v ()
|
||||
typecheckingEnv =
|
||||
Typechecker.Env
|
||||
{ ambientAbilities = mempty,
|
||||
typeLookup,
|
||||
termsByShortname = mempty
|
||||
}
|
||||
accessorsWithTypes :: [(v, Term.Term v (), Type.Type v ())] <-
|
||||
for accessors \(v, _a, trm) ->
|
||||
case Result.result (Typechecker.synthesize ppe Typechecker.PatternMatchCoverageCheckAndKindInferenceSwitch'Disabled typecheckingEnv trm) of
|
||||
Nothing -> Nothing
|
||||
-- Note: Typechecker.synthesize doesn't normalize the output
|
||||
-- type. We do so here using `Type.cleanup`, mirroring what's
|
||||
-- done when typechecking a whole file and ensuring we get the
|
||||
-- same inferred type.
|
||||
Just typ -> Just (v, trm, Type.cleanup typ)
|
||||
pure $
|
||||
accessorsWithTypes
|
||||
& fmap (\(v, trm, typ) -> (v, (trm, typ, ())))
|
||||
& Map.fromList
|
||||
& Hashing.hashTermComponents
|
||||
& fmap (\(id, trm, typ, _a) -> (id, trm, typ))
|
||||
let accessors :: [(v, (), Term v ())]
|
||||
accessors =
|
||||
generateRecordAccessors Var.namespaced id (map (,()) vars) declName declRef
|
||||
|
||||
typecheckedAccessors <-
|
||||
for accessors \(v, _a, term) -> do
|
||||
typ <- typecheck term
|
||||
Just (v, (term, typ, ()))
|
||||
|
||||
typecheckedAccessors
|
||||
& Map.fromList
|
||||
& Hashing.hashTermComponents
|
||||
& Map.map Tuple.drop4th
|
||||
& Just
|
||||
where
|
||||
typecheck :: Term v () -> Maybe (Type v ())
|
||||
typecheck term = do
|
||||
typ <- Result.result (Typechecker.synthesize ppe Typechecker.PatternMatchCoverageCheckAndKindInferenceSwitch'Disabled typecheckingEnv term)
|
||||
-- Note: Typechecker.synthesize doesn't normalize the output
|
||||
-- type. We do so here using `Type.cleanup`, mirroring what's
|
||||
-- done when typechecking a whole file and ensuring we get the
|
||||
-- same inferred type.
|
||||
Just (Type.cleanup typ)
|
||||
|
||||
typecheckingEnv :: Typechecker.Env v ()
|
||||
typecheckingEnv =
|
||||
Typechecker.Env
|
||||
{ ambientAbilities = mempty,
|
||||
typeLookup =
|
||||
TypeLookup
|
||||
{ typeOfTerms = mempty,
|
||||
dataDecls = Map.singleton declRef (void dd),
|
||||
effectDecls = mempty
|
||||
},
|
||||
termsByShortname = mempty
|
||||
}
|
||||
|
@ -66,7 +66,7 @@ hashTermComponents ::
|
||||
forall v a extra.
|
||||
(Var v) =>
|
||||
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)
|
||||
Map v (Memory.Reference.TermReferenceId, Memory.Term.Term v a, Memory.Type.Type v a, extra)
|
||||
hashTermComponents mTerms =
|
||||
case h2mTermMap mTerms of
|
||||
(hTerms, constructorTypes) -> h2mTermResult (constructorTypes Map.!) <$> Hashing.hashTermComponents hTerms
|
||||
@ -81,7 +81,7 @@ hashTermComponents mTerms =
|
||||
Memory.ConstructorType.ConstructorType
|
||||
) ->
|
||||
(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)
|
||||
(Memory.Reference.TermReferenceId, 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.
|
||||
@ -91,12 +91,16 @@ hashTermComponentsWithoutTypes ::
|
||||
forall v a.
|
||||
(Var v) =>
|
||||
Map v (Memory.Term.Term v a) ->
|
||||
Map v (Memory.Reference.Id, Memory.Term.Term v a)
|
||||
Map v (Memory.Reference.TermReferenceId, Memory.Term.Term v a)
|
||||
hashTermComponentsWithoutTypes mTerms =
|
||||
case Writer.runWriter (traverse m2hTerm mTerms) of
|
||||
(hTerms, constructorTypes) -> h2mTermResult (constructorTypes Map.!) <$> Hashing.hashTermComponentsWithoutTypes hTerms
|
||||
where
|
||||
h2mTermResult :: (Ord v) => (Memory.Reference.Reference -> Memory.ConstructorType.ConstructorType) -> (Hashing.ReferenceId, Hashing.Term v a) -> (Memory.Reference.Id, Memory.Term.Term v a)
|
||||
h2mTermResult ::
|
||||
(Ord v) =>
|
||||
(Memory.Reference.Reference -> Memory.ConstructorType.ConstructorType) ->
|
||||
(Hashing.ReferenceId, Hashing.Term v a) ->
|
||||
(Memory.Reference.TermReferenceId, Memory.Term.Term v a)
|
||||
h2mTermResult getCtorType (id, tm) = (h2mReferenceId id, h2mTerm getCtorType tm)
|
||||
|
||||
hashClosedTerm :: (Var v) => Memory.Term.Term v a -> Memory.Reference.Id
|
||||
|
@ -486,7 +486,7 @@ splitMatrix v rf cons (PM rs) =
|
||||
mmap = fmap (\(t, fs) -> (t, splitRow v rf t fs =<< rs)) cons
|
||||
|
||||
-- Monad for pattern preparation. It is a state monad carrying a fresh
|
||||
-- variable source, the list of variables bound the the pattern being
|
||||
-- variable source, the list of variables bound the pattern being
|
||||
-- prepared, and a variable renaming mapping.
|
||||
type PPM v a = State (Word64, [v], Map v v) a
|
||||
|
||||
|
@ -68,7 +68,7 @@ declarations = do
|
||||
<> [(v, DD.annotation . DD.toDataDecl <$> es) | (v, es) <- Map.toList mesBad]
|
||||
|
||||
-- | When we first walk over the modifier, it may be a `unique`, in which case we want to use a function in the parsing
|
||||
-- environment to map the the type's name (which we haven't parsed yet) to a GUID to reuse (if any).
|
||||
-- environment to map the type's name (which we haven't parsed yet) to a GUID to reuse (if any).
|
||||
--
|
||||
-- So, we parse into this temporary "unresolved modifier" type, which is soon resolved to a real Modifier once we know
|
||||
-- the type name.
|
||||
|
@ -1,4 +1,11 @@
|
||||
module Unison.Syntax.DeclPrinter (prettyDecl, prettyDeclW, prettyDeclHeader, prettyDeclOrBuiltinHeader, AccessorName) where
|
||||
module Unison.Syntax.DeclPrinter
|
||||
( prettyDecl,
|
||||
prettyDeclW,
|
||||
prettyDeclHeader,
|
||||
prettyDeclOrBuiltinHeader,
|
||||
AccessorName,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad.Writer (Writer, runWriter, tell)
|
||||
import Data.List.NonEmpty (pattern (:|))
|
||||
@ -16,10 +23,11 @@ import Unison.PrettyPrintEnv (PrettyPrintEnv)
|
||||
import Unison.PrettyPrintEnv qualified as PPE
|
||||
import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl (..))
|
||||
import Unison.PrettyPrintEnvDecl qualified as PPED
|
||||
import Unison.Reference (Reference, Reference' (DerivedId))
|
||||
import Unison.Reference (Reference, Reference' (DerivedId), TypeReference)
|
||||
import Unison.Referent qualified as Referent
|
||||
import Unison.Syntax.HashQualified qualified as HQ (toText, toVar, unsafeParseText)
|
||||
import Unison.Syntax.NamePrinter (styleHashQualified'')
|
||||
import Unison.Syntax.HashQualified qualified as HQ (toText)
|
||||
import Unison.Syntax.Name qualified as Name
|
||||
import Unison.Syntax.NamePrinter (prettyName, styleHashQualified'')
|
||||
import Unison.Syntax.TypePrinter (runPretty)
|
||||
import Unison.Syntax.TypePrinter qualified as TypePrinter
|
||||
import Unison.Syntax.Var qualified as Var (namespaced)
|
||||
@ -37,7 +45,7 @@ type AccessorName = HQ.HashQualified Name
|
||||
prettyDeclW ::
|
||||
(Var v) =>
|
||||
PrettyPrintEnvDecl ->
|
||||
Reference ->
|
||||
TypeReference ->
|
||||
HQ.HashQualified Name ->
|
||||
DD.Decl v a ->
|
||||
Writer [AccessorName] (Pretty SyntaxText)
|
||||
@ -48,7 +56,7 @@ prettyDeclW ppe r hq d = case d of
|
||||
prettyDecl ::
|
||||
(Var v) =>
|
||||
PrettyPrintEnvDecl ->
|
||||
Reference ->
|
||||
TypeReference ->
|
||||
HQ.HashQualified Name ->
|
||||
DD.Decl v a ->
|
||||
Pretty SyntaxText
|
||||
@ -57,7 +65,7 @@ prettyDecl ppe r hq d = fst . runWriter $ prettyDeclW ppe r hq d
|
||||
prettyEffectDecl ::
|
||||
(Var v) =>
|
||||
PrettyPrintEnvDecl ->
|
||||
Reference ->
|
||||
TypeReference ->
|
||||
HQ.HashQualified Name ->
|
||||
EffectDeclaration v a ->
|
||||
Pretty SyntaxText
|
||||
@ -67,7 +75,7 @@ prettyGADT ::
|
||||
(Var v) =>
|
||||
PrettyPrintEnvDecl ->
|
||||
CT.ConstructorType ->
|
||||
Reference ->
|
||||
TypeReference ->
|
||||
HQ.HashQualified Name ->
|
||||
DataDeclaration v a ->
|
||||
Pretty SyntaxText
|
||||
@ -105,7 +113,7 @@ prettyPattern env ctorType namespace ref =
|
||||
prettyDataDecl ::
|
||||
(Var v) =>
|
||||
PrettyPrintEnvDecl ->
|
||||
Reference ->
|
||||
TypeReference ->
|
||||
HQ.HashQualified Name ->
|
||||
DataDeclaration v a ->
|
||||
Writer [AccessorName] (Pretty SyntaxText)
|
||||
@ -133,7 +141,7 @@ prettyDataDecl (PrettyPrintEnvDecl unsuffixifiedPPE suffixifiedPPE) r name dd =
|
||||
Nothing -> HQ.NameOnly $ declName `Name.joinDot` fieldName
|
||||
Just accessor -> HQ.NameOnly $ declName `Name.joinDot` fieldName `Name.joinDot` accessor
|
||||
| HQ.NameOnly declName <- [name],
|
||||
HQ.NameOnly fieldName <- fs,
|
||||
fieldName <- fs,
|
||||
accessor <- [Nothing, Just (Name.fromSegment "set"), Just (Name.fromSegment "modify")]
|
||||
]
|
||||
pure . P.group $
|
||||
@ -144,7 +152,7 @@ prettyDataDecl (PrettyPrintEnvDecl unsuffixifiedPPE suffixifiedPPE) r name dd =
|
||||
<> fmt S.DelimiterChar " }"
|
||||
field (fname, typ) =
|
||||
P.group $
|
||||
styleHashQualified'' (fmt (S.TypeReference r)) fname
|
||||
fmt (S.TypeReference r) (prettyName fname)
|
||||
<> fmt S.TypeAscriptionColon " :"
|
||||
`P.hang` runPretty suffixifiedPPE (TypePrinter.prettyRaw Map.empty (-1) typ)
|
||||
header = prettyDataHeader name dd <> fmt S.DelimiterChar (" = " `P.orElse` "\n = ")
|
||||
@ -166,31 +174,63 @@ fieldNames ::
|
||||
forall v a.
|
||||
(Var v) =>
|
||||
PrettyPrintEnv ->
|
||||
Reference ->
|
||||
TypeReference ->
|
||||
HQ.HashQualified Name ->
|
||||
DataDeclaration v a ->
|
||||
Maybe [HQ.HashQualified Name]
|
||||
fieldNames env r name dd = do
|
||||
typ <- case DD.constructors dd of
|
||||
[(_, typ)] -> Just typ
|
||||
_ -> Nothing
|
||||
Maybe [Name]
|
||||
fieldNames env r hqTypename dd = do
|
||||
-- If we only have a hash for the decl, then we can't know where in the namespace to look for the generated accessors,
|
||||
-- so we just give up trying to infer whether this was a record (even if it was one).
|
||||
typename <- HQ.toName hqTypename
|
||||
|
||||
-- Records have exactly one constructor
|
||||
[(_, typ)] <- Just (DD.constructors dd)
|
||||
|
||||
-- [ "_0", "_1"-1 ]
|
||||
let vars :: [v]
|
||||
-- We add `n` to the end of the variable name as a quick fix to #4752, but we suspect there's a more
|
||||
-- fundamental fix to be made somewhere in the term printer to automatically suffix a var name with its
|
||||
-- freshened id if it would be ambiguous otherwise.
|
||||
vars = [Var.freshenId (fromIntegral n) (Var.named ("_" <> Text.pack (show n))) | n <- [0 .. Type.arity typ - 1]]
|
||||
hashes <- DD.hashFieldAccessors env (HQ.toVar name) vars r dd
|
||||
|
||||
-- {
|
||||
-- "Pt._0" => ( #getx , pt -> match pt with Pt x _ -> x , Pt -> Int )
|
||||
-- "Pt._0.set" => ( #setx , x pt -> match pt with Pt _ y -> Pt x y , Int -> Pt -> Pt )
|
||||
-- "Pt._0.modify" => ( #modifyx , f pt -> match pt with Pt x y -> Pt (f x) y , (Int -> Int) -> Pt -> Pt )
|
||||
-- "Pt._11" => ( #gety , pt -> match pt with Pt _ y -> y , Pt -> Int )
|
||||
-- "Pt._11.set" => ( #sety , y pt -> match pt with Pt x _ -> Pt x y , Int -> Pt -> Pt )
|
||||
-- "Pt._11.modify" => ( #modifyy , f pt -> match pt with Pt x y -> Pt x (f y) , (Int -> Int) -> Pt -> Pt )
|
||||
-- }
|
||||
hashes <- DD.hashFieldAccessors env (Name.toVar typename) vars r dd
|
||||
|
||||
-- [
|
||||
-- ( #getx , "Pt.x" )
|
||||
-- ( #setx , "Pt.x.set" )
|
||||
-- ( #modifyx , "Pt.x.modify" )
|
||||
-- ( #gety , "Pt.y" )
|
||||
-- ( #sety , "Pt.y.set" )
|
||||
-- ( #modifyy , "Pt.y.modify" )
|
||||
-- ]
|
||||
let names =
|
||||
[ (r, HQ.toText . PPE.termName env . Referent.Ref $ DerivedId r)
|
||||
| r <- (\(refId, _trm, _typ) -> refId) <$> Map.elems hashes
|
||||
]
|
||||
|
||||
-- {
|
||||
-- #getx => "x"
|
||||
-- #setx => "x"
|
||||
-- #modifyx => "x"
|
||||
-- #gety => "y"
|
||||
-- #sety => "y"
|
||||
-- #modifyy => "y"
|
||||
-- }
|
||||
let fieldNames =
|
||||
Map.fromList
|
||||
[ (r, f)
|
||||
| (r, n) <- names,
|
||||
typename <- pure (HQ.toText name),
|
||||
typename `Text.isPrefixOf` n,
|
||||
rest <- pure $ Text.drop (Text.length typename + 1) n,
|
||||
let typenameText = Name.toText typename,
|
||||
typenameText `Text.isPrefixOf` n,
|
||||
let rest = Text.drop (Text.length typenameText + 1) n,
|
||||
(f, rest) <- pure $ Text.span (/= '.') rest,
|
||||
rest `elem` ["", ".set", ".modify"]
|
||||
]
|
||||
@ -198,9 +238,12 @@ fieldNames env r name dd = do
|
||||
if Map.size fieldNames == length names
|
||||
then
|
||||
Just
|
||||
[ HQ.unsafeParseText name
|
||||
| v <- vars,
|
||||
Just (ref, _, _) <- [Map.lookup (Var.namespaced (HQ.toVar name :| [v])) hashes],
|
||||
[ Name.unsafeParseText name
|
||||
| -- "_0"
|
||||
v <- vars,
|
||||
-- #getx
|
||||
Just (ref, _, _) <- [Map.lookup (Var.namespaced (Name.toVar typename :| [v])) hashes],
|
||||
-- "x"
|
||||
Just name <- [Map.lookup ref fieldNames]
|
||||
]
|
||||
else Nothing
|
||||
|
@ -13,6 +13,7 @@ import Text.Megaparsec qualified as P
|
||||
import Unison.ABT qualified as ABT
|
||||
import Unison.DataDeclaration (DataDeclaration)
|
||||
import Unison.DataDeclaration qualified as DD
|
||||
import Unison.DataDeclaration.Records (generateRecordAccessors)
|
||||
import Unison.Name qualified as Name
|
||||
import Unison.Names qualified as Names
|
||||
import Unison.Names.ResolutionResult qualified as Names
|
||||
@ -54,7 +55,7 @@ file = do
|
||||
Left es -> resolutionFailures (toList es)
|
||||
let accessors :: [[(v, Ann, Term v Ann)]]
|
||||
accessors =
|
||||
[ DD.generateRecordAccessors Var.namespaced Ann.GeneratedFrom (toPair <$> fields) (L.payload typ) r
|
||||
[ generateRecordAccessors Var.namespaced Ann.GeneratedFrom (toPair <$> fields) (L.payload typ) r
|
||||
| (typ, fields) <- parsedAccessors,
|
||||
Just (r, _) <- [Map.lookup (L.payload typ) (UF.datas env)]
|
||||
]
|
||||
@ -68,7 +69,7 @@ file = do
|
||||
--
|
||||
-- There's some more complicated logic below to have suffix-based name resolution
|
||||
-- make use of _terms_ from the local file.
|
||||
local (\e -> e {names = Names.push locals namesStart}) $ do
|
||||
local (\e -> e {names = Names.push locals namesStart}) do
|
||||
names <- asks names
|
||||
stanzas0 <- sepBy semi stanza
|
||||
let stanzas = fmap (TermParser.substImports names imports) <$> stanzas0
|
||||
|
@ -6,16 +6,16 @@ import Unison.ConstructorType qualified as CT
|
||||
import Unison.DataDeclaration (DataDeclaration, EffectDeclaration)
|
||||
import Unison.DataDeclaration qualified as DD
|
||||
import Unison.Prelude
|
||||
import Unison.Reference (Reference)
|
||||
import Unison.Reference (TermReference, TypeReference)
|
||||
import Unison.Referent (Referent)
|
||||
import Unison.Referent qualified as Referent
|
||||
import Unison.Type (Type)
|
||||
|
||||
-- Used for typechecking.
|
||||
data TypeLookup v a = TypeLookup
|
||||
{ typeOfTerms :: Map Reference (Type v a),
|
||||
dataDecls :: Map Reference (DataDeclaration v a),
|
||||
effectDecls :: Map Reference (EffectDeclaration v a)
|
||||
{ typeOfTerms :: Map TermReference (Type v a),
|
||||
dataDecls :: Map TypeReference (DataDeclaration v a),
|
||||
effectDecls :: Map TypeReference (EffectDeclaration v a)
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
@ -26,13 +26,13 @@ typeOfReferent tl r = case r of
|
||||
Referent.Con r CT.Effect -> typeOfEffectConstructor tl r
|
||||
|
||||
-- bombs if not found
|
||||
unsafeConstructorType :: TypeLookup v a -> Reference -> CT.ConstructorType
|
||||
unsafeConstructorType :: TypeLookup v a -> TypeReference -> CT.ConstructorType
|
||||
unsafeConstructorType tl r =
|
||||
fromMaybe
|
||||
(error $ "no constructor type for " <> show r)
|
||||
(constructorType tl r)
|
||||
|
||||
constructorType :: TypeLookup v a -> Reference -> Maybe CT.ConstructorType
|
||||
constructorType :: TypeLookup v a -> TypeReference -> Maybe CT.ConstructorType
|
||||
constructorType tl r =
|
||||
(const CT.Data <$> Map.lookup r (dataDecls tl))
|
||||
<|> (const CT.Effect <$> Map.lookup r (effectDecls tl))
|
||||
@ -47,10 +47,10 @@ typeOfEffectConstructor tl (ConstructorReference r cid) = go =<< Map.lookup r (e
|
||||
where
|
||||
go dd = DD.typeOfConstructor (DD.toDataDecl dd) cid
|
||||
|
||||
typeOfTerm :: TypeLookup v a -> Reference -> Maybe (Type v a)
|
||||
typeOfTerm :: TypeLookup v a -> TermReference -> Maybe (Type v a)
|
||||
typeOfTerm tl r = Map.lookup r (typeOfTerms tl)
|
||||
|
||||
typeOfTerm' :: TypeLookup v a -> Reference -> Either Reference (Type v a)
|
||||
typeOfTerm' :: TypeLookup v a -> TermReference -> Either TermReference (Type v a)
|
||||
typeOfTerm' tl r = case Map.lookup r (typeOfTerms tl) of
|
||||
Nothing -> Left r
|
||||
Just a -> Right a
|
||||
|
@ -142,7 +142,7 @@ mapTerms f (UnisonFileId datas effects terms watches) =
|
||||
-- rule2 = @rewrite term (x -> f x) ==> f
|
||||
--
|
||||
-- Here, `rule1` introduces a variable `f`, which can stand for
|
||||
-- any definition. Whereas `rule2` refers to the the top-level `f`
|
||||
-- any definition. Whereas `rule2` refers to the top-level `f`
|
||||
-- function in the file.
|
||||
--
|
||||
-- This function returns a tuple of: (prepareRule, preparedFile, finish)
|
||||
|
@ -142,7 +142,7 @@ resultTest rt uf filepath = do
|
||||
uf
|
||||
case term of
|
||||
Right tm -> do
|
||||
-- compare the the watch expression from the .u with the expr in .ur
|
||||
-- compare the watch expression from the .u with the expr in .ur
|
||||
let watchResult = head (view _5 <$> Map.elems watches)
|
||||
tm' = Term.letRec' False (bindings <&> \(sym, tm) -> (sym, (), tm)) watchResult
|
||||
-- note . show $ tm'
|
||||
|
@ -81,6 +81,7 @@
|
||||
exn:bug?
|
||||
exn:bug->exception
|
||||
exception->string
|
||||
raise-unison-exception
|
||||
|
||||
request
|
||||
request-case
|
||||
@ -565,7 +566,10 @@
|
||||
[0 (f)
|
||||
(control ref-exception:typelink k
|
||||
(let ([disp (describe-value f)])
|
||||
(raise (make-exn:bug "builtin.bug" disp))))]]))
|
||||
(raise
|
||||
(make-exn:bug
|
||||
(string->chunked-string "builtin.bug")
|
||||
disp))))]]))
|
||||
|
||||
(begin-encourage-inline
|
||||
(define mask64 #xffffffffffffffff)
|
||||
@ -594,3 +598,14 @@
|
||||
(if (and (fixnum? n) (exact-nonnegative-integer? n)) n
|
||||
(modulo n bit64))))
|
||||
|
||||
(define (raise-unison-exception ty msg val)
|
||||
(request
|
||||
ref-exception:typelink
|
||||
0
|
||||
(ref-failure-failure ty msg (unison-any-any val))))
|
||||
|
||||
(define (exn:bug->exception b)
|
||||
(raise-unison-exception
|
||||
ref-runtimefailure:typelink
|
||||
(exn:bug-msg b)
|
||||
(exn:bug-val b)))
|
||||
|
@ -5,129 +5,191 @@
|
||||
; implements all the functions we'd want. This library exports the
|
||||
; desired functionality on top of an unsafe in-place freeze
|
||||
; re-exported from the (unison core) module.
|
||||
#!r6rs
|
||||
(library (unison bytevector)
|
||||
(export
|
||||
freeze-bytevector!
|
||||
ibytevector-drop
|
||||
ibytevector-take
|
||||
ibytevector-append
|
||||
bytevector-u8-ref
|
||||
bytevector-u16-ref
|
||||
bytevector-u24-ref
|
||||
bytevector-u32-ref
|
||||
bytevector-u40-ref
|
||||
bytevector-u48-ref
|
||||
bytevector-u56-ref
|
||||
bytevector-u64-ref
|
||||
u8-list->ibytevector
|
||||
b32d
|
||||
b32hd
|
||||
base32-string->ibytevector)
|
||||
#lang racket/base
|
||||
|
||||
(import (rnrs)
|
||||
(unison core))
|
||||
(provide
|
||||
freeze-bytevector!
|
||||
ibytevector-drop
|
||||
ibytevector-take
|
||||
ibytevector-append
|
||||
bytevector-u8-ref
|
||||
bytevector-u16-ref
|
||||
bytevector-u24-ref
|
||||
bytevector-u32-ref
|
||||
bytevector-u40-ref
|
||||
bytevector-u48-ref
|
||||
bytevector-u56-ref
|
||||
bytevector-u64-ref
|
||||
u8-list->ibytevector
|
||||
bytevector->base32-string
|
||||
base32-string->ibytevector)
|
||||
|
||||
(define (ibytevector-drop n bs)
|
||||
(let* ([l (bytevector-length bs)]
|
||||
[k (max 0 (- l n))]
|
||||
[br (make-bytevector k)])
|
||||
(bytevector-copy! bs n br 0 k)
|
||||
(freeze-bytevector! br)))
|
||||
(require
|
||||
racket
|
||||
racket/fixnum
|
||||
(only-in racket/unsafe/ops
|
||||
unsafe-bytes->immutable-bytes!)
|
||||
(only-in rnrs
|
||||
div
|
||||
mod
|
||||
div-and-mod
|
||||
bytevector-u8-ref
|
||||
bytevector-u16-ref
|
||||
bytevector-u32-ref
|
||||
bytevector-u64-ref))
|
||||
|
||||
(define (ibytevector-take n bs)
|
||||
(let* ([sz (min n (bytevector-length bs))]
|
||||
[br (make-bytevector sz)])
|
||||
(bytevector-copy! bs 0 br 0 sz)
|
||||
(freeze-bytevector! br)))
|
||||
(define freeze-bytevector! unsafe-bytes->immutable-bytes!)
|
||||
|
||||
(define (ibytevector-append l r)
|
||||
(freeze-bytevector! (bytevector-append l r)))
|
||||
(define (ibytevector-drop n bs)
|
||||
(let* ([l (bytes-length bs)]
|
||||
[k (max 0 (- l n))]
|
||||
[br (make-bytes k)])
|
||||
(bytes-copy! br 0 bs n k)
|
||||
(unsafe-bytes->immutable-bytes! br)))
|
||||
|
||||
(define (u8-list->ibytevector l)
|
||||
(freeze-bytevector! (u8-list->bytevector l)))
|
||||
(define (ibytevector-take n bs)
|
||||
(let* ([sz (min n (bytes-length bs))]
|
||||
[br (make-bytes sz)])
|
||||
(bytes-copy br 0 bs 0 sz)
|
||||
(unsafe-bytes->immutable-bytes! br)))
|
||||
|
||||
(define (bytevector-u24-ref bs n end)
|
||||
(let ([v16 (bytevector-u16-ref bs n end)]
|
||||
[v8 (bytevector-u8-ref bs (+ n 2))])
|
||||
(case end
|
||||
[big (fxior v8 (fxarithmetic-shift-left v16 8))]
|
||||
[little (fxior v16 (fxarithmetic-shift-left v8 16))])))
|
||||
(define (ibytevector-append l r)
|
||||
(unsafe-bytes->immutable-bytes! (bytes-append l r)))
|
||||
|
||||
(define (bytevector-u40-ref bs n end)
|
||||
(let ([v32 (bytevector-u32-ref bs n end)]
|
||||
[v8 (bytevector-u8-ref bs (+ n 4))])
|
||||
(case end
|
||||
[big (fxior v8 (fxarithmetic-shift-left v32 8))]
|
||||
[small (fxior v32 (fxarithmetic-shift-left v8 32))])))
|
||||
(define (u8-list->ibytevector l)
|
||||
(unsafe-bytes->immutable-bytes! (list->bytes l)))
|
||||
|
||||
(define (bytevector-u48-ref bs n end)
|
||||
(let ([v32 (bytevector-u32-ref bs n end)]
|
||||
[v16 (bytevector-u16-ref bs (+ n 4) end)])
|
||||
(case end
|
||||
[big (fxior v16 (fxarithmetic-shift-left v32 8))]
|
||||
[small (fxior v32 (fxarithmetic-shift-left v16 32))])))
|
||||
(define (bytevector-u24-ref bs n end)
|
||||
(let ([v16 (bytevector-u16-ref bs n end)]
|
||||
[v8 (bytevector-u8-ref bs (+ n 2))])
|
||||
(case end
|
||||
[(big) (fxior v8 (fxlshift v16 8))]
|
||||
[(little) (fxior v16 (fxlshift v8 16))])))
|
||||
|
||||
(define (bytevector-u56-ref bs n end)
|
||||
(let ([v32 (bytevector-u32-ref bs n end)]
|
||||
[v16 (bytevector-u16-ref bs (+ n 4) end)]
|
||||
[v8 (bytevector-u8-ref bs (+ n 6))])
|
||||
(case end
|
||||
[big (fxior v8
|
||||
(fxarithmetic-shift-left v16 8)
|
||||
(fxarithmetic-shift-left v32 24))]
|
||||
[small (fxior v32
|
||||
(fxarithmetic-shift-left v16 32)
|
||||
(fxarithmetic-shift-left v8 48))])))
|
||||
(define (bytevector-u40-ref bs n end)
|
||||
(let ([v32 (bytevector-u32-ref bs n end)]
|
||||
[v8 (bytevector-u8-ref bs (+ n 4))])
|
||||
(case end
|
||||
[(big) (fxior v8 (fxlshift v32 8))]
|
||||
[(small) (fxior v32 (fxlshift v8 32))])))
|
||||
|
||||
(define (b32d c)
|
||||
(let ([n (char->integer c)])
|
||||
(define (bytevector-u48-ref bs n end)
|
||||
(let ([v32 (bytevector-u32-ref bs n end)]
|
||||
[v16 (bytevector-u16-ref bs (+ n 4) end)])
|
||||
(case end
|
||||
[(big) (fxior v16 (fxlshift v32 8))]
|
||||
[(small) (fxior v32 (fxlshift v16 32))])))
|
||||
|
||||
(define (bytevector-u56-ref bs n end)
|
||||
(let ([v32 (bytevector-u32-ref bs n end)]
|
||||
[v16 (bytevector-u16-ref bs (+ n 4) end)]
|
||||
[v8 (bytevector-u8-ref bs (+ n 6))])
|
||||
(case end
|
||||
[(big) (fxior v8
|
||||
(fxlshift v16 8)
|
||||
(fxlshift v32 24))]
|
||||
[(small) (fxior v32
|
||||
(fxlshift v16 32)
|
||||
(fxlshift v8 48))])))
|
||||
|
||||
(define (b32d c)
|
||||
(let ([n (char->integer c)])
|
||||
(cond
|
||||
[(and (<= 65 n) (<= n 90)) (- n 65)]
|
||||
[(and (<= 97 n) (<= n 122)) (- n 97)]
|
||||
[(and (<= 50 n) (<= n 55)) (- n 24)])))
|
||||
|
||||
(define (b32hd c)
|
||||
(let ([n (char->integer c)])
|
||||
(cond
|
||||
[(and (<= 48 n) (<= n 57)) (- n 48)]
|
||||
[(and (<= 65 n) (<= n 86)) (- n 65)]
|
||||
[(and (<= 97 n) (<= n 118)) (- n 97)])))
|
||||
|
||||
(define (base32-string->ibytevector str #:alphabet [alphabet 'standard])
|
||||
(define decode
|
||||
(match alphabet
|
||||
[hex b32hd]
|
||||
[standard b32d]))
|
||||
|
||||
(define (main ilen)
|
||||
(let* ([olen (div (* ilen 5) 8)]
|
||||
[out (make-bytes olen)])
|
||||
|
||||
(define (fill n k o)
|
||||
(when (>= k 0)
|
||||
(let ([m (fxand n 255)])
|
||||
(bytes-set! out (+ o k) m)
|
||||
(fill (fxrshift n 8) (- k 1) o))))
|
||||
|
||||
(define (fixup i)
|
||||
(if (= i 0) (values 0 -1)
|
||||
(let* ([chars (+ 1 (mod (- i 1) 8))])
|
||||
(div-and-mod (* 5 chars) 8))))
|
||||
|
||||
(let rec ([acc 0] [i 0] [o 0])
|
||||
(cond
|
||||
[(>= i ilen)
|
||||
(let-values ([(k n) (fixup i)])
|
||||
(fill (fxrshift acc n) (- k 1) o)
|
||||
(unsafe-bytes->immutable-bytes! out))]
|
||||
[(and (> i 0) (= 0 (mod i 8)))
|
||||
(fill acc 4 o)
|
||||
(rec (decode (string-ref str i)) (+ i 1) (+ o 5))]
|
||||
[else
|
||||
(let ([sacc (fxlshift acc 5)]
|
||||
[bits (decode (string-ref str i))])
|
||||
(rec (fxior sacc bits) (+ i 1) o))]))))
|
||||
|
||||
(let search ([i (- (string-length str) 1)])
|
||||
(if (and (>= i 0) (eq? (string-ref str i) #\=))
|
||||
(search (- i 1))
|
||||
(main (+ i 1)))))
|
||||
|
||||
; code should convert 5-bit numbers to the corresponding character
|
||||
(define (bytevector->base32-string bs #:alphabet [alphabet 'standard])
|
||||
(define code
|
||||
(match alphabet
|
||||
[hex b32h]
|
||||
[standard b32]))
|
||||
|
||||
(let* ([ilen (bytes-length bs)]
|
||||
[olen (* 8 (div (+ ilen 4) 5))]
|
||||
[out (make-string olen #\=)])
|
||||
|
||||
(define (fill n k o)
|
||||
(if (>= k 0)
|
||||
(let ([m (fxand n 31)])
|
||||
(string-set! out (+ o k) (code m))
|
||||
(fill (fxrshift n 5) (- k 1) o))
|
||||
#f))
|
||||
|
||||
(define (fixup i)
|
||||
(if (= i 0) (values 0 -1)
|
||||
(let ([bys (+ 1 (mod (- i 1) 5))])
|
||||
(let-values ([(d m) (div-and-mod (* 8 bys) 5)])
|
||||
(if (= m 0) (values m (- d 1))
|
||||
(values (- 5 m) d))))))
|
||||
|
||||
(let rec ([acc 0] [i 0] [o 0])
|
||||
(cond
|
||||
[(and (<= 65 n) (<= n 90)) (- n 65)]
|
||||
[(and (<= 97 n) (<= n 122)) (- n 97)]
|
||||
[(and (<= 50 n) (<= n 55)) (- n 24)])))
|
||||
[(>= i ilen)
|
||||
(let-values ([(n k) (fixup i)])
|
||||
(fill (fxlshift acc n) k o)
|
||||
out)]
|
||||
[(and (> i 0) (= 0 (mod i 5)))
|
||||
(fill acc 7 o)
|
||||
(rec (bytes-ref bs i) (+ i 1) (+ o 8))]
|
||||
[else
|
||||
(let ([sacc (fxlshift acc 8)]
|
||||
[by (bytes-ref bs i)])
|
||||
(rec (fxior sacc by) (+ i 1) o))]))))
|
||||
|
||||
(define (b32hd c)
|
||||
(let ([n (char->integer c)])
|
||||
(cond
|
||||
[(and (<= 48 n) (<= n 57)) (- n 48)]
|
||||
[(and (<= 65 n) (<= n 86)) (- n 65)]
|
||||
[(and (<= 97 n) (<= n 118)) (- n 97)])))
|
||||
; 65 = #\A
|
||||
; 24 = #\2 - 26
|
||||
(define (b32 n) (integer->char (+ n (if (< n 26) 65 24))))
|
||||
|
||||
(define (base32-string->ibytevector decode str)
|
||||
(define (main ilen)
|
||||
(let* ([olen (div (* ilen 5) 8)]
|
||||
[out (make-bytevector olen)])
|
||||
; 48 = #\0
|
||||
; 87 = #\a - 10
|
||||
(define (b32h n) (integer->char (+ n (if (< n 10) 48 87))))
|
||||
|
||||
(define (fill n k o)
|
||||
(if (>= k 0)
|
||||
(let ([m (fxand n 255)])
|
||||
(bytevector-u8-set! out (+ o k) m)
|
||||
(fill (fxarithmetic-shift-right n 8) (- k 1) o))))
|
||||
|
||||
(define (fixup i)
|
||||
(if (= i 0) (values 0 -1)
|
||||
(let ([chars (+ 1 (mod (- i 1) 8))])
|
||||
(div-and-mod (* 5 chars) 8))))
|
||||
|
||||
(let rec ([acc 0] [i 0] [o 0])
|
||||
(cond
|
||||
[(>= i ilen)
|
||||
(let-values ([(k n) (fixup i)])
|
||||
(fill (fxarithmetic-shift-right acc n) (- k 1) o)
|
||||
(freeze-bytevector! out))]
|
||||
[(and (> i 0) (= 0 (mod i 8)))
|
||||
(fill acc 4 o)
|
||||
(rec (decode (string-ref str i)) (+ i 1) (+ o 5))]
|
||||
[else
|
||||
(let ([sacc (fxarithmetic-shift-left acc 5)]
|
||||
[bits (decode (string-ref str i))])
|
||||
(rec (fxior sacc bits) (+ i 1) o))]))))
|
||||
|
||||
(let search ([i (- (string-length str) 1)])
|
||||
(if (and (>= i 0) (eq? (string-ref str i) #\=))
|
||||
(search (- i 1))
|
||||
(main (+ i 1)))))
|
||||
|
||||
|
||||
)
|
||||
|
@ -12,8 +12,7 @@
|
||||
promise-try-read
|
||||
fork
|
||||
kill
|
||||
sleep
|
||||
try-eval)
|
||||
sleep)
|
||||
|
||||
(import (rnrs)
|
||||
(rnrs records syntactic)
|
||||
@ -37,13 +36,7 @@
|
||||
sleep
|
||||
printf
|
||||
with-handlers
|
||||
exn:break?
|
||||
exn:fail?
|
||||
exn:fail:read?
|
||||
exn:fail:filesystem?
|
||||
exn:fail:network?
|
||||
exn:fail:contract:divide-by-zero?
|
||||
exn:fail:contract:non-fixnum-result?)
|
||||
exn:break?)
|
||||
(box ref-new)
|
||||
(unbox ref-read)
|
||||
(set-box! ref-write)
|
||||
@ -96,46 +89,4 @@
|
||||
(define (kill threadId)
|
||||
(break-thread threadId)
|
||||
(right unit))
|
||||
|
||||
(define (exn:io? e)
|
||||
(or (exn:fail:read? e)
|
||||
(exn:fail:filesystem? e)
|
||||
(exn:fail:network? e)))
|
||||
|
||||
(define (exn:arith? e)
|
||||
(or (exn:fail:contract:divide-by-zero? e)
|
||||
(exn:fail:contract:non-fixnum-result? e)))
|
||||
|
||||
(define (try-eval thunk)
|
||||
(with-handlers
|
||||
([exn:break?
|
||||
(lambda (e)
|
||||
(exception
|
||||
ref-threadkilledfailure:typelink
|
||||
(string->chunked-string "thread killed")
|
||||
ref-unit-unit))]
|
||||
[exn:io?
|
||||
(lambda (e)
|
||||
(exception
|
||||
ref-iofailure:typelink
|
||||
(exception->string e) ref-unit-unit))]
|
||||
[exn:arith?
|
||||
(lambda (e)
|
||||
(exception
|
||||
ref-arithfailure:typelink
|
||||
(exception->string e)
|
||||
ref-unit-unit))]
|
||||
[exn:bug? (lambda (e) (exn:bug->exception e))]
|
||||
[exn:fail?
|
||||
(lambda (e)
|
||||
(exception
|
||||
ref-runtimefailure:typelink
|
||||
(exception->string e)
|
||||
ref-unit-unit))]
|
||||
[(lambda (x) #t)
|
||||
(lambda (e)
|
||||
(exception
|
||||
ref-miscfailure:typelink
|
||||
(exception->string e)
|
||||
ref-unit-unit))])
|
||||
(right (thunk)))))
|
||||
)
|
||||
|
@ -20,10 +20,7 @@
|
||||
|
||||
exception->string
|
||||
|
||||
exn:bug
|
||||
make-exn:bug
|
||||
exn:bug?
|
||||
exn:bug->exception
|
||||
(struct-out exn:bug)
|
||||
|
||||
let-marks
|
||||
ref-mark
|
||||
@ -46,15 +43,10 @@
|
||||
decode-value
|
||||
describe-value
|
||||
|
||||
bytevector->base32-string
|
||||
b32
|
||||
b32h
|
||||
|
||||
bytevector->string/utf-8
|
||||
string->bytevector/utf-8)
|
||||
|
||||
(require
|
||||
racket/base
|
||||
(rename-in (only-in racket
|
||||
current-inexact-milliseconds
|
||||
directory-list
|
||||
@ -73,6 +65,7 @@
|
||||
path->string
|
||||
match
|
||||
match*
|
||||
string-append*
|
||||
for/fold)
|
||||
(string-copy! racket-string-copy!)
|
||||
(bytes-append bytevector-append)
|
||||
@ -83,6 +76,7 @@
|
||||
racket/exn
|
||||
(only-in racket/fixnum fl->fx fx- fxand fxlshift fxrshift fxior)
|
||||
racket/unsafe/ops
|
||||
unison/bytevector
|
||||
unison/data
|
||||
unison/data-info
|
||||
unison/chunked-seq)
|
||||
@ -108,48 +102,6 @@
|
||||
(string-set! out (+ o 1) (b16 c1))
|
||||
(rec (+ i 1) (+ o 2)))]))))
|
||||
|
||||
; code should convert 5-bit numbers to the corresponding character
|
||||
(define (bytevector->base32-string code bs)
|
||||
(let* ([ilen (bytes-length bs)]
|
||||
[olen (* 8 (div (+ ilen 4) 5))]
|
||||
[out (make-string olen #\=)])
|
||||
|
||||
(define (fill n k o)
|
||||
(if (>= k 0)
|
||||
(let ([m (fxand n 31)])
|
||||
(string-set! out (+ o k) (code m))
|
||||
(fill (fxrshift n 5) (- k 1) o))
|
||||
#f))
|
||||
|
||||
(define (fixup i)
|
||||
(if (= i 0) (values 0 -1)
|
||||
(let ([bys (+ 1 (mod (- i 1) 5))])
|
||||
(let-values ([(d m) (div-and-mod (* 8 bys) 5)])
|
||||
(if (= m 0) (values m (- d 1))
|
||||
(values (- 5 m) d))))))
|
||||
|
||||
(let rec ([acc 0] [i 0] [o 0])
|
||||
(cond
|
||||
[(>= i ilen)
|
||||
(let-values ([(n k) (fixup i)])
|
||||
(fill (fxlshift acc n) k o)
|
||||
out)]
|
||||
[(and (> i 0) (= 0 (mod i 5)))
|
||||
(fill acc 7 o)
|
||||
(rec (bytes-ref bs i) (+ i 1) (+ o 8))]
|
||||
[else
|
||||
(let ([sacc (fxlshift acc 8)]
|
||||
[by (bytes-ref bs i)])
|
||||
(rec (fxior sacc by) (+ i 1) o))]))))
|
||||
|
||||
; 65 = #\A
|
||||
; 24 = #\2 - 26
|
||||
(define (b32 n) (integer->char (+ n (if (< n 26) 65 24))))
|
||||
|
||||
; 48 = #\0
|
||||
; 87 = #\a - 10
|
||||
(define (b32h n) (integer->char (+ n (if (< n 10) 48 87))))
|
||||
|
||||
|
||||
(define (describe-list op cl l)
|
||||
(let rec ([pre (string op)] [post (string op cl)] [cur l])
|
||||
@ -164,7 +116,7 @@
|
||||
(define (describe-list-br l) (describe-list #\{ #\} l))
|
||||
|
||||
(define (describe-hash h)
|
||||
(substring (bytevector->base32-string b32h h) 0 8))
|
||||
(substring (bytevector->base32-string h #:alphabet 'hex) 0 8))
|
||||
|
||||
(define (describe-derived h i)
|
||||
(let ([th (describe-hash h)]
|
||||
@ -183,7 +135,7 @@
|
||||
[(unison-termlink-derived hash i) (describe-derived hash i)]))
|
||||
|
||||
(define (describe-bytes bs)
|
||||
(let* ([s (bytevector->base32-string b32h bs)]
|
||||
(let* ([s (bytevector->base32-string bs #:alphabet 'hex)]
|
||||
[l (string-length s)]
|
||||
[sfx (if (<= l 10) "" "...")])
|
||||
(string-append "32x" (substring s 0 10) sfx)))
|
||||
@ -216,6 +168,9 @@
|
||||
[else
|
||||
(format-non-tuple (cons tup acc))])))
|
||||
|
||||
(define (describe-applied f args)
|
||||
(string-append f " "))
|
||||
|
||||
(define (describe-value x)
|
||||
(match x
|
||||
[(unison-sum t fs)
|
||||
@ -229,22 +184,26 @@
|
||||
(let ([tt (number->string t)]
|
||||
[rt (describe-ref r)]
|
||||
[vs (describe-list-br fs)])
|
||||
(string-append "Data " rt " " tt " " vs))]
|
||||
(string-append "{Data " rt " " tt " " vs "}"))]
|
||||
[(unison-pure v)
|
||||
(string-append "Pure " (describe-list-br (list v)))]
|
||||
[(unison-termlink-con r t)
|
||||
(let ([rt (describe-ref r)]
|
||||
[tt (number->string t)])
|
||||
(string-append "{Con " r " " t "}"))]
|
||||
[(unison-termlink-builtin name) (string-append "##" name)]
|
||||
[(unison-termlink-derived hash i) (describe-derived hash i)]
|
||||
[(unison-typelink-builtin nm)
|
||||
(string-append "##" nm)]
|
||||
[(unison-typelink-derived hs i) (describe-derived hs i)]
|
||||
[(? unison-termlink?) (termlink->string x #t)]
|
||||
[(? unison-typelink?) (typelink->string x #t)]
|
||||
[(unison-quote v)
|
||||
(string-append "{Value " (describe-value v) "}")]
|
||||
[(unison-code v)
|
||||
(string-append "Code (" (describe-value v) ")")]
|
||||
(string-append "{Code " (describe-value v) "}")]
|
||||
[(unison-closure code env)
|
||||
(define dc
|
||||
(termlink->string (lookup-function-link code) #t))
|
||||
(define (f v)
|
||||
(string-append " " (describe-value v)))
|
||||
|
||||
(string-append* dc (map f env))]
|
||||
[(? procedure?)
|
||||
(string-append
|
||||
"ref"
|
||||
(termlink->string (lookup-function-link x) #t))]
|
||||
[(? chunked-list?)
|
||||
(describe-list-sq (vector->list (chunked-list->vector x)))]
|
||||
[(? chunked-string?)
|
||||
@ -503,8 +462,6 @@
|
||||
([c (in-chunked-string-chunks s)])
|
||||
(f acc (string->chunked-string (m c)))))
|
||||
|
||||
(define freeze-bytevector! unsafe-bytes->immutable-bytes!)
|
||||
|
||||
(define freeze-vector! unsafe-vector*->immutable-vector!)
|
||||
|
||||
(define (freeze-subvector src off len)
|
||||
@ -538,9 +495,3 @@
|
||||
#:methods gen:custom-write
|
||||
[(define write-proc write-exn:bug)])
|
||||
|
||||
|
||||
(define (exn:bug->exception b)
|
||||
(exception
|
||||
ref-runtimefailure:typelink
|
||||
(exn:bug-msg b)
|
||||
(exn:bug-val b)))
|
||||
|
@ -96,12 +96,16 @@
|
||||
builtin-tls.signedcert:typelink
|
||||
builtin-tls.version:typelink
|
||||
|
||||
unison-tuple->list)
|
||||
unison-tuple->list
|
||||
|
||||
typelink->string
|
||||
termlink->string)
|
||||
|
||||
(require
|
||||
racket
|
||||
racket/fixnum
|
||||
(only-in "vector-trie.rkt" ->fx/wraparound))
|
||||
(only-in "vector-trie.rkt" ->fx/wraparound)
|
||||
unison/bytevector)
|
||||
|
||||
(struct unison-data
|
||||
(ref tag fields)
|
||||
@ -153,6 +157,9 @@
|
||||
(struct unison-termlink ()
|
||||
#:transparent
|
||||
#:reflection-name 'termlink
|
||||
#:methods gen:custom-write
|
||||
[(define (write-proc tl port mode)
|
||||
(write-string (termlink->string tl #t) port))]
|
||||
#:property prop:equal+hash
|
||||
(let ()
|
||||
(define (equal-proc lnl lnr rec)
|
||||
@ -204,6 +211,9 @@
|
||||
(struct unison-typelink ()
|
||||
#:transparent
|
||||
#:reflection-name 'typelink
|
||||
#:methods gen:custom-write
|
||||
[(define (write-proc tl port mode)
|
||||
(write-string (typelink->string tl #t) port))]
|
||||
#:property prop:equal+hash
|
||||
(let ()
|
||||
(define (equal-proc lnl lnr rec)
|
||||
@ -244,9 +254,57 @@
|
||||
(struct unison-code (rep))
|
||||
(struct unison-quote (val))
|
||||
|
||||
(define (write-procedure f port mode)
|
||||
(cond
|
||||
[(hash-has-key? function-associations f)
|
||||
(define tl (lookup-function-link f))
|
||||
(write-string (termlink->string tl #t) port)]
|
||||
[else
|
||||
(case mode
|
||||
[(#f) (display f port)]
|
||||
[(#t) (write f port)]
|
||||
[else (print f port mode)])]))
|
||||
|
||||
(define (write-sequence s port mode)
|
||||
(define rec
|
||||
(case mode
|
||||
[(#f) display]
|
||||
[(#t) write]
|
||||
[else (lambda (e port) (print e port mode))]))
|
||||
|
||||
(write-string "'(" port)
|
||||
|
||||
(define first #t)
|
||||
|
||||
(for ([e s])
|
||||
(unless first
|
||||
(write-string " " port)
|
||||
(set! first #f))
|
||||
|
||||
(if (procedure? e)
|
||||
(write-procedure e port mode)
|
||||
(rec e port)))
|
||||
(write-string ")" port))
|
||||
|
||||
(struct unison-closure
|
||||
(code env)
|
||||
#:transparent
|
||||
#:methods gen:custom-write
|
||||
[(define (write-proc clo port mode)
|
||||
(define code-tl
|
||||
(lookup-function-link (unison-closure-code clo)))
|
||||
|
||||
(define rec
|
||||
(case mode
|
||||
[(#t) write]
|
||||
[(#f) display]
|
||||
[else (lambda (v port) (print v port mode))]))
|
||||
|
||||
(write-string "(unison-closure " port)
|
||||
(write-procedure (unison-closure-code clo) port mode)
|
||||
(write-string " " port)
|
||||
(write-sequence (unison-closure-env clo) port mode)
|
||||
(write-string ")" port))]
|
||||
#:property prop:procedure
|
||||
(case-lambda
|
||||
[(clo) clo]
|
||||
@ -416,9 +474,9 @@
|
||||
(define (failure typeLink msg any)
|
||||
(sum 0 typeLink msg any))
|
||||
|
||||
; Type -> Text -> a ->{Exception} b
|
||||
; Type -> Text -> a -> (type, text, a) + b
|
||||
(define (exception typeLink msg a)
|
||||
(failure typeLink msg (unison-any-any a)))
|
||||
(failure typeLink msg a))
|
||||
|
||||
; A counter for internally numbering declared data, so that the
|
||||
; entire reference doesn't need to be stored in every data record.
|
||||
@ -477,3 +535,35 @@
|
||||
(cons (car fs) (unison-tuple->list (cadr fs)))]
|
||||
[else
|
||||
(raise "unison-tuple->list: unexpected value")])))
|
||||
|
||||
(define (hash-string hs)
|
||||
(string-append
|
||||
"#"
|
||||
(bytevector->base32-string hs #:alphabet 'hex)))
|
||||
|
||||
(define (ix-string i)
|
||||
(if (= i 0)
|
||||
""
|
||||
(string-append "." (number->string i))))
|
||||
|
||||
(define (typelink->string ln [short #f])
|
||||
(define (clip s) (if short (substring s 0 8) s))
|
||||
|
||||
(match ln
|
||||
[(unison-typelink-builtin name)
|
||||
(string-append "##" name)]
|
||||
[(unison-typelink-derived hs i)
|
||||
(string-append (clip (hash-string hs)) (ix-string i))]))
|
||||
|
||||
(define (termlink->string ln [short #f])
|
||||
(define (clip s) (if short (substring s 0 8) s))
|
||||
|
||||
(match ln
|
||||
[(unison-termlink-builtin name)
|
||||
(string-append "##" name)]
|
||||
[(unison-termlink-derived hs i)
|
||||
(string-append (clip (hash-string hs)) (ix-string i))]
|
||||
[(unison-termlink-con rf t)
|
||||
(string-append
|
||||
(typelink->string rf short) "#" (number->string t))]))
|
||||
|
||||
|
@ -9,7 +9,7 @@
|
||||
racket/vector
|
||||
unison/boot
|
||||
unison/boot-generated
|
||||
(only-in unison/core bytevector->base32-string b32h)
|
||||
(only-in unison/bytevector bytevector->base32-string)
|
||||
unison/data
|
||||
unison/data-info
|
||||
unison/chunked-seq
|
||||
@ -220,7 +220,7 @@
|
||||
[(unison-termlink-builtin name)
|
||||
(string-append "builtin-" name)]
|
||||
[(unison-termlink-derived bs i)
|
||||
(let ([hs (bytevector->base32-string b32h bs)]
|
||||
(let ([hs (bytevector->base32-string bs #:alphabet 'hex)]
|
||||
[po (if (= i 0) "" (string-append "." (number->string i)))])
|
||||
(string->symbol
|
||||
(string-append "ref-" (substring hs 0 8) po)))]))
|
||||
|
@ -140,6 +140,8 @@
|
||||
builtin-Bytes.indexOf:termlink
|
||||
builtin-IO.randomBytes
|
||||
builtin-IO.randomBytes:termlink
|
||||
builtin-IO.tryEval
|
||||
builtin-IO.tryEval:termlink
|
||||
|
||||
builtin-Scope.bytearrayOf
|
||||
builtin-Scope.bytearrayOf:termlink
|
||||
@ -388,7 +390,6 @@
|
||||
unison-FOp-IO.delay.impl.v3
|
||||
unison-POp-FORK
|
||||
unison-FOp-IO.kill.impl.v3
|
||||
unison-POp-TFRC
|
||||
|
||||
unison-FOp-Handle.toText
|
||||
unison-FOp-Socket.toText
|
||||
@ -602,7 +603,14 @@
|
||||
vector-copy!
|
||||
bytes-copy!
|
||||
sub1
|
||||
add1)
|
||||
add1
|
||||
exn:break?
|
||||
exn:fail?
|
||||
exn:fail:read?
|
||||
exn:fail:filesystem?
|
||||
exn:fail:network?
|
||||
exn:fail:contract:divide-by-zero?
|
||||
exn:fail:contract:non-fixnum-result?)
|
||||
(car icar) (cdr icdr))
|
||||
(only (racket string)
|
||||
string-contains?
|
||||
@ -618,6 +626,8 @@
|
||||
clamp-integer
|
||||
clamp-natural
|
||||
wrap-natural
|
||||
exn:bug->exception
|
||||
raise-unison-exception
|
||||
bit64
|
||||
bit63
|
||||
nbit63)
|
||||
@ -698,6 +708,7 @@
|
||||
(define-builtin-link Text.!=)
|
||||
(define-builtin-link Bytes.indexOf)
|
||||
(define-builtin-link IO.randomBytes)
|
||||
(define-builtin-link IO.tryEval)
|
||||
(define-builtin-link List.splitLeft)
|
||||
(define-builtin-link List.splitRight)
|
||||
(define-builtin-link Value.toBuiltin)
|
||||
@ -827,34 +838,10 @@
|
||||
(define-unison (builtin-Scope.bytearrayOf i n)
|
||||
(make-bytevector n i))
|
||||
|
||||
(define (hash-string hs)
|
||||
(string-append "#" (bytevector->base32-string b32h hs)))
|
||||
|
||||
(define (ix-string i)
|
||||
(if (= i 0)
|
||||
""
|
||||
(string-append "." (number->string i))))
|
||||
|
||||
(define (typelink->string ln)
|
||||
(match ln
|
||||
[(unison-typelink-builtin name)
|
||||
(string-append "##" name)]
|
||||
[(unison-typelink-derived hs i)
|
||||
(string-append (hash-string hs) (ix-string i))]))
|
||||
|
||||
(define-builtin-link Link.Type.toText)
|
||||
(define-unison (builtin-Link.Type.toText ln)
|
||||
(string->chunked-string (typelink->string ln)))
|
||||
|
||||
(define (termlink->string ln)
|
||||
(match ln
|
||||
[(unison-termlink-builtin name)
|
||||
(string-append "##" name)]
|
||||
[(unison-termlink-derived hs i)
|
||||
(string-append (hash-string hs) (ix-string i))]
|
||||
[(unison-termlink-con rf t)
|
||||
(string-append (typelink->string rf) "#" (number->string t))]))
|
||||
|
||||
(define-builtin-link Link.Term.toText)
|
||||
(define-unison (builtin-Link.Term.toText ln)
|
||||
(string->chunked-string (termlink->string ln)))
|
||||
@ -1343,7 +1330,6 @@
|
||||
(define unison-FOp-ImmutableArray.size vector-length)
|
||||
|
||||
(define (unison-POp-FORK thunk) (fork thunk))
|
||||
(define (unison-POp-TFRC thunk) (try-eval thunk))
|
||||
(define (unison-FOp-IO.delay.impl.v3 micros) (sleep micros))
|
||||
(define (unison-FOp-IO.kill.impl.v3 threadId) (kill threadId))
|
||||
(define (unison-FOp-Scope.ref a) (ref-new a))
|
||||
@ -1358,6 +1344,50 @@
|
||||
(define (unison-FOp-Promise.tryRead promise) (promise-try-read promise))
|
||||
(define (unison-FOp-Promise.write promise a) (promise-write promise a)))
|
||||
|
||||
|
||||
(define (exn:io? e)
|
||||
(or (exn:fail:read? e)
|
||||
(exn:fail:filesystem? e)
|
||||
(exn:fail:network? e)))
|
||||
|
||||
(define (exn:arith? e)
|
||||
(or (exn:fail:contract:divide-by-zero? e)
|
||||
(exn:fail:contract:non-fixnum-result? e)))
|
||||
|
||||
(define-unison (builtin-IO.tryEval thunk)
|
||||
(with-handlers
|
||||
([exn:break?
|
||||
(lambda (e)
|
||||
(raise-unison-exception
|
||||
ref-threadkilledfailure:typelink
|
||||
(string->chunked-string "thread killed")
|
||||
ref-unit-unit))]
|
||||
[exn:io?
|
||||
(lambda (e)
|
||||
(raise-unison-exception
|
||||
ref-iofailure:typelink
|
||||
(exception->string e)
|
||||
ref-unit-unit))]
|
||||
[exn:arith?
|
||||
(lambda (e)
|
||||
(raise-unison-exception
|
||||
ref-arithfailure:typelink
|
||||
(exception->string e)
|
||||
ref-unit-unit))]
|
||||
[exn:bug? (lambda (e) (exn:bug->exception e))]
|
||||
[exn:fail?
|
||||
(lambda (e)
|
||||
(raise-unison-exception
|
||||
ref-runtimefailure:typelink
|
||||
(exception->string e)
|
||||
ref-unit-unit))]
|
||||
[(lambda (x) #t)
|
||||
(lambda (e)
|
||||
(raise-unison-exception
|
||||
ref-miscfailure:typelink
|
||||
(exception->string e)
|
||||
ref-unit-unit))])
|
||||
(thunk ref-unit-unit)))
|
||||
|
||||
(declare-builtin-link builtin-Float.*)
|
||||
(declare-builtin-link builtin-Float.fromRepresentation)
|
||||
@ -1417,6 +1447,7 @@
|
||||
(declare-builtin-link builtin-Text.!=)
|
||||
(declare-builtin-link builtin-Bytes.indexOf)
|
||||
(declare-builtin-link builtin-IO.randomBytes)
|
||||
(declare-builtin-link builtin-IO.tryEval)
|
||||
(declare-builtin-link builtin-List.splitLeft)
|
||||
(declare-builtin-link builtin-List.splitRight)
|
||||
(declare-builtin-link builtin-Value.toBuiltin)
|
||||
|
@ -122,7 +122,11 @@
|
||||
ref-miscfailure:typelink
|
||||
(string->chunked-string "Unknown exception")
|
||||
ref-unit-unit))] ]
|
||||
(let ([listener (tcp-listen (string->number port ) 4 #f (if (equal? 0 hostname) #f hostname))])
|
||||
(let ([listener (tcp-listen
|
||||
(string->number port)
|
||||
4
|
||||
#t
|
||||
(if (equal? 0 hostname) #f hostname))])
|
||||
(right listener))))))
|
||||
|
||||
; NOTE: This is a no-op because racket's public TCP stack doesn't have separate operations for
|
||||
|
@ -411,7 +411,7 @@ run verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmVersion
|
||||
liftIO (outputEcho $ show s)
|
||||
liftIO (writeIORef allowErrors errOk)
|
||||
-- Open a ucm block which will contain the output from UCM
|
||||
-- after processing the the UnisonFileChanged event.
|
||||
-- after processing the UnisonFileChanged event.
|
||||
liftIO (output "```ucm\n")
|
||||
-- Close the ucm block after processing the UnisonFileChanged event.
|
||||
atomically . Q.enqueue cmdQueue $ Nothing
|
||||
|
@ -81,7 +81,7 @@ withCancellation mayTimeoutMillis handler message respond = do
|
||||
-- No matter what it's possible for a message to be cancelled before the
|
||||
-- canceller has been added, but this means we're not blocking the request waiting for
|
||||
-- contention on the cancellation map on every request.
|
||||
-- The the majority of requests should be fast enough to complete "instantly" anyways.
|
||||
-- The majority of requests should be fast enough to complete "instantly" anyways.
|
||||
waitForCancel :: (Int32 |? Text) -> Lsp ()
|
||||
waitForCancel reqId = do
|
||||
barrier <- newEmptyMVar
|
||||
|
@ -194,7 +194,7 @@ instance Functor SourceNode where
|
||||
fmap f (TypeNode t) = TypeNode (fmap f t)
|
||||
fmap f (PatternNode t) = PatternNode (fmap f t)
|
||||
|
||||
-- | Find the the node in a term which contains the specified position, but none of its
|
||||
-- | Find the node in a term which contains the specified position, but none of its
|
||||
-- children contain that position.
|
||||
findSmallestEnclosingNode :: Pos -> Term Symbol Ann -> Maybe (SourceNode Ann)
|
||||
findSmallestEnclosingNode pos term
|
||||
@ -295,7 +295,7 @@ findSmallestEnclosingPattern pos pat
|
||||
| conRef == Builtins.pairRef && mayUnitRef == Builtins.unitRef -> Just pat1
|
||||
_ -> Nothing
|
||||
|
||||
-- | Find the the node in a type which contains the specified position, but none of its
|
||||
-- | Find the node in a type which contains the specified position, but none of its
|
||||
-- children contain that position.
|
||||
-- This is helpful for finding the specific type reference of a given argument within a type arrow
|
||||
-- that a position references.
|
||||
|
@ -602,7 +602,7 @@ completeTempEntities httpClient unisonShareUrl connect repoInfo downloadedCallba
|
||||
workers <- readTVar workerCount
|
||||
check (workers < maxSimultaneousPullDownloaders + 2)
|
||||
-- we do need to record the downloader as working outside of the worker thread, not inside.
|
||||
-- otherwise, we might erroneously fall through the the teardown logic below and conclude there's
|
||||
-- otherwise, we might erroneously fall through the teardown logic below and conclude there's
|
||||
-- nothing more for the dispatcher to do, when in fact a downloader thread just hasn't made it as
|
||||
-- far as recording its own existence
|
||||
recordWorking workerCount
|
||||
|
@ -23,7 +23,6 @@ module Unison.DataDeclaration
|
||||
declFields,
|
||||
typeDependencies,
|
||||
labeledTypeDependencies,
|
||||
generateRecordAccessors,
|
||||
unhashComponent,
|
||||
mkDataDecl',
|
||||
mkEffectDecl',
|
||||
@ -39,8 +38,6 @@ where
|
||||
|
||||
import Control.Lens (Iso', Lens', imap, iso, lens, over, _3)
|
||||
import Control.Monad.State (evalState)
|
||||
import Data.List.NonEmpty (pattern (:|))
|
||||
import Data.List.NonEmpty qualified as List (NonEmpty)
|
||||
import Data.Map qualified as Map
|
||||
import Data.Set qualified as Set
|
||||
import Unison.ABT qualified as ABT
|
||||
@ -50,14 +47,11 @@ import Unison.DataDeclaration.ConstructorId (ConstructorId)
|
||||
import Unison.LabeledDependency qualified as LD
|
||||
import Unison.Name qualified as Name
|
||||
import Unison.Names.ResolutionResult qualified as Names
|
||||
import Unison.Pattern qualified as Pattern
|
||||
import Unison.Prelude
|
||||
import Unison.Reference (Reference)
|
||||
import Unison.Reference qualified as Reference
|
||||
import Unison.Referent qualified as Referent
|
||||
import Unison.Referent' qualified as Referent'
|
||||
import Unison.Term (Term)
|
||||
import Unison.Term qualified as Term
|
||||
import Unison.Type (Type)
|
||||
import Unison.Type qualified as Type
|
||||
import Unison.Var (Var)
|
||||
@ -146,92 +140,6 @@ withEffectDeclM ::
|
||||
f (EffectDeclaration v' a')
|
||||
withEffectDeclM f = fmap EffectDeclaration . f . toDataDecl
|
||||
|
||||
-- propose to move this code to some very feature-specific module —AI
|
||||
generateRecordAccessors ::
|
||||
(Semigroup a, Var v) =>
|
||||
(List.NonEmpty v -> v) ->
|
||||
(a -> a) ->
|
||||
[(v, a)] ->
|
||||
v ->
|
||||
Reference ->
|
||||
[(v, a, Term v a)]
|
||||
generateRecordAccessors namespaced generatedAnn fields typename typ =
|
||||
join [tm t i | (t, i) <- fields `zip` [(0 :: Int) ..]]
|
||||
where
|
||||
argname = Var.uncapitalize typename
|
||||
tm (fname, fieldAnn) i =
|
||||
[ (namespaced (typename :| [fname]), ann, get),
|
||||
(namespaced (typename :| [fname, Var.named "set"]), ann, set),
|
||||
(namespaced (typename :| [fname, Var.named "modify"]), ann, modify)
|
||||
]
|
||||
where
|
||||
ann = generatedAnn fieldAnn
|
||||
-- example: `point -> case point of Point x _ -> x`
|
||||
get =
|
||||
Term.lam (generatedAnn fieldAnn) argname $
|
||||
Term.match
|
||||
ann
|
||||
(Term.var ann argname)
|
||||
[Term.MatchCase pat Nothing rhs]
|
||||
where
|
||||
pat = Pattern.Constructor ann (ConstructorReference typ 0) cargs
|
||||
cargs =
|
||||
[ if j == i then Pattern.Var ann else Pattern.Unbound ann
|
||||
| (_, j) <- fields `zip` [0 ..]
|
||||
]
|
||||
rhs = ABT.abs' ann fname (Term.var ann fname)
|
||||
-- example: `x point -> case point of Point _ y -> Point x y`
|
||||
set =
|
||||
Term.lam' (generatedAnn ann) [fname', argname] $
|
||||
Term.match
|
||||
ann
|
||||
(Term.var ann argname)
|
||||
[Term.MatchCase pat Nothing rhs]
|
||||
where
|
||||
fname' =
|
||||
Var.named . Var.name $
|
||||
Var.freshIn (Set.fromList $ [argname] <> (fst <$> fields)) fname
|
||||
pat = Pattern.Constructor ann (ConstructorReference typ 0) cargs
|
||||
cargs =
|
||||
[ if j == i then Pattern.Unbound ann else Pattern.Var ann
|
||||
| (_, j) <- fields `zip` [0 ..]
|
||||
]
|
||||
rhs =
|
||||
foldr
|
||||
(ABT.abs' ann)
|
||||
(Term.constructor ann (ConstructorReference typ 0) `Term.apps'` vargs)
|
||||
[f | ((f, _), j) <- fields `zip` [0 ..], j /= i]
|
||||
vargs =
|
||||
[ if j == i then Term.var ann fname' else Term.var ann v
|
||||
| ((v, _), j) <- fields `zip` [0 ..]
|
||||
]
|
||||
-- example: `f point -> case point of Point x y -> Point (f x) y`
|
||||
modify =
|
||||
Term.lam' (generatedAnn ann) [fname', argname] $
|
||||
Term.match
|
||||
ann
|
||||
(Term.var ann argname)
|
||||
[Term.MatchCase pat Nothing rhs]
|
||||
where
|
||||
fname' =
|
||||
Var.named . Var.name $
|
||||
Var.freshIn
|
||||
(Set.fromList $ [argname] <> (fst <$> fields))
|
||||
(Var.named "f")
|
||||
pat = Pattern.Constructor ann (ConstructorReference typ 0) cargs
|
||||
cargs = replicate (length fields) $ Pattern.Var ann
|
||||
rhs =
|
||||
foldr
|
||||
(ABT.abs' ann)
|
||||
(Term.constructor ann (ConstructorReference typ 0) `Term.apps'` vargs)
|
||||
(fst <$> fields)
|
||||
vargs =
|
||||
[ if j == i
|
||||
then Term.apps' (Term.var ann fname') [Term.var ann v]
|
||||
else Term.var ann v
|
||||
| ((v, _), j) <- fields `zip` [0 ..]
|
||||
]
|
||||
|
||||
constructorTypes :: DataDeclaration v a -> [Type v a]
|
||||
constructorTypes = (snd <$>) . constructors
|
||||
|
||||
|
111
unison-core/src/Unison/DataDeclaration/Records.hs
Normal file
111
unison-core/src/Unison/DataDeclaration/Records.hs
Normal file
@ -0,0 +1,111 @@
|
||||
-- | This module contains various utilities related to the implementation of record types.
|
||||
module Unison.DataDeclaration.Records
|
||||
( generateRecordAccessors,
|
||||
)
|
||||
where
|
||||
|
||||
import Data.List.NonEmpty (pattern (:|))
|
||||
import Data.List.NonEmpty qualified as List (NonEmpty)
|
||||
import Data.Set qualified as Set
|
||||
import Unison.ABT qualified as ABT
|
||||
import Unison.ConstructorReference (GConstructorReference (..))
|
||||
import Unison.Pattern qualified as Pattern
|
||||
import Unison.Prelude
|
||||
import Unison.Reference (TypeReference)
|
||||
import Unison.Term (Term)
|
||||
import Unison.Term qualified as Term
|
||||
import Unison.Var (Var)
|
||||
import Unison.Var qualified as Var
|
||||
|
||||
generateRecordAccessors ::
|
||||
(Semigroup a, Var v) =>
|
||||
(List.NonEmpty v -> v) ->
|
||||
(a -> a) ->
|
||||
[(v, a)] ->
|
||||
v ->
|
||||
TypeReference ->
|
||||
[(v, a, Term v a)]
|
||||
generateRecordAccessors namespaced generatedAnn fields typename typ =
|
||||
join [tm t i | (t, i) <- fields `zip` [(0 :: Int) ..]]
|
||||
where
|
||||
argname = Var.uncapitalize typename
|
||||
tm (fname, fieldAnn) i =
|
||||
[ (namespaced (typename :| [fname]), ann, get),
|
||||
(namespaced (typename :| [fname, Var.named "set"]), ann, set),
|
||||
(namespaced (typename :| [fname, Var.named "modify"]), ann, modify)
|
||||
]
|
||||
where
|
||||
ann = generatedAnn fieldAnn
|
||||
conref = ConstructorReference typ 0
|
||||
pat = Pattern.Constructor ann conref
|
||||
|
||||
-- point -> case point of Point _ y _ -> y
|
||||
get =
|
||||
Term.lam ann argname $
|
||||
Term.match
|
||||
ann
|
||||
(Term.var ann argname)
|
||||
[Term.MatchCase (pat cargs) Nothing rhs]
|
||||
where
|
||||
-- [_, y, _]
|
||||
cargs =
|
||||
[ if j == i then Pattern.Var ann else Pattern.Unbound ann
|
||||
| (_, j) <- fields `zip` [0 ..]
|
||||
]
|
||||
-- y -> y
|
||||
rhs = ABT.abs' ann fname (Term.var ann fname)
|
||||
|
||||
-- y' point -> case point of Point x _ z -> Point x y' z
|
||||
set =
|
||||
Term.lam' ann [fname', argname] $
|
||||
Term.match
|
||||
ann
|
||||
(Term.var ann argname)
|
||||
[Term.MatchCase (pat cargs) Nothing rhs]
|
||||
where
|
||||
-- y'
|
||||
fname' =
|
||||
Var.named . Var.name $
|
||||
Var.freshIn (Set.fromList $ [argname] <> (fst <$> fields)) fname
|
||||
-- [x, _, z]
|
||||
cargs =
|
||||
[ if j == i then Pattern.Unbound ann else Pattern.Var ann
|
||||
| (_, j) <- fields `zip` [0 ..]
|
||||
]
|
||||
-- x z -> Point x y' z
|
||||
rhs =
|
||||
foldr
|
||||
(ABT.abs' ann)
|
||||
(Term.constructor ann conref `Term.apps'` vargs)
|
||||
[v | ((v, _), j) <- fields `zip` [0 ..], j /= i]
|
||||
-- [x, y', z]
|
||||
vargs =
|
||||
[ if j == i then Term.var ann fname' else Term.var ann v
|
||||
| ((v, _), j) <- fields `zip` [0 ..]
|
||||
]
|
||||
|
||||
-- example: `f point -> case point of Point x y z -> Point x (f y) z`
|
||||
modify =
|
||||
Term.lam' ann [fname', argname] $
|
||||
Term.match
|
||||
ann
|
||||
(Term.var ann argname)
|
||||
[Term.MatchCase (pat cargs) Nothing rhs]
|
||||
where
|
||||
fname' =
|
||||
Var.named . Var.name $
|
||||
Var.freshIn
|
||||
(Set.fromList $ [argname] <> (fst <$> fields))
|
||||
(Var.named "f")
|
||||
cargs = [Pattern.Var ann | _ <- fields]
|
||||
rhs =
|
||||
foldr
|
||||
(ABT.abs' ann)
|
||||
(Term.constructor ann conref `Term.apps'` vargs)
|
||||
(fst <$> fields)
|
||||
vargs =
|
||||
[ if j == i
|
||||
then Term.apps' (Term.var ann fname') [Term.var ann v]
|
||||
else Term.var ann v
|
||||
| ((v, _), j) <- fields `zip` [0 ..]
|
||||
]
|
@ -28,7 +28,7 @@ import Unison.Prelude
|
||||
($>),
|
||||
(<&>),
|
||||
)
|
||||
import Unison.Reference (Reference)
|
||||
import Unison.Reference (TypeReference)
|
||||
import Unison.Reference qualified as Reference
|
||||
import Unison.Settings qualified as Settings
|
||||
import Unison.Util.List qualified as List
|
||||
@ -37,7 +37,7 @@ import Unison.Var qualified as Var
|
||||
|
||||
-- | Base functor for types in the Unison language
|
||||
data F a
|
||||
= Ref Reference
|
||||
= Ref TypeReference
|
||||
| Arrow a a
|
||||
| Ann a K.Kind
|
||||
| App a a
|
||||
@ -49,7 +49,7 @@ data F a
|
||||
-- variables
|
||||
deriving (Foldable, Functor, Generic, Generic1, Eq, Ord, Traversable)
|
||||
|
||||
_Ref :: Prism' (F a) Reference
|
||||
_Ref :: Prism' (F a) TypeReference
|
||||
_Ref = _Ctor @"Ref"
|
||||
|
||||
-- | Types are represented as ABTs over the base functor F, with variables in `v`
|
||||
@ -62,14 +62,14 @@ freeVars :: Type v a -> Set v
|
||||
freeVars = ABT.freeVars
|
||||
|
||||
bindExternal ::
|
||||
(ABT.Var v) => [(v, Reference)] -> Type v a -> Type v a
|
||||
(ABT.Var v) => [(v, TypeReference)] -> Type v a -> Type v a
|
||||
bindExternal bs = ABT.substsInheritAnnotation [(v, ref () r) | (v, r) <- bs]
|
||||
|
||||
bindReferences ::
|
||||
(Var v) =>
|
||||
(v -> Name.Name) ->
|
||||
Set v ->
|
||||
Map Name.Name Reference ->
|
||||
Map Name.Name TypeReference ->
|
||||
Type v a ->
|
||||
Names.ResolutionResult v a (Type v a)
|
||||
bindReferences unsafeVarToName keepFree ns t =
|
||||
@ -98,7 +98,7 @@ arity (Ann' a _) = arity a
|
||||
arity _ = 0
|
||||
|
||||
-- some smart patterns
|
||||
pattern Ref' :: Reference -> ABT.Term F v a
|
||||
pattern Ref' :: TypeReference -> ABT.Term F v a
|
||||
pattern Ref' r <- ABT.Tm' (Ref r)
|
||||
|
||||
pattern Arrow' :: ABT.Term F v a -> ABT.Term F v a -> ABT.Term F v a
|
||||
@ -247,7 +247,7 @@ isArrow _ = False
|
||||
|
||||
-- some smart constructors
|
||||
|
||||
ref :: (Ord v) => a -> Reference -> Type v a
|
||||
ref :: (Ord v) => a -> TypeReference -> Type v a
|
||||
ref a = ABT.tm' a . Ref
|
||||
|
||||
refId :: (Ord v) => a -> Reference.Id -> Type v a
|
||||
@ -259,10 +259,10 @@ termLink a = ABT.tm' a . Ref $ termLinkRef
|
||||
typeLink :: (Ord v) => a -> Type v a
|
||||
typeLink a = ABT.tm' a . Ref $ typeLinkRef
|
||||
|
||||
derivedBase32Hex :: (Ord v) => Reference -> a -> Type v a
|
||||
derivedBase32Hex :: (Ord v) => TypeReference -> a -> Type v a
|
||||
derivedBase32Hex r a = ref a r
|
||||
|
||||
intRef, natRef, floatRef, booleanRef, textRef, charRef, listRef, bytesRef, effectRef, termLinkRef, typeLinkRef :: Reference
|
||||
intRef, natRef, floatRef, booleanRef, textRef, charRef, listRef, bytesRef, effectRef, termLinkRef, typeLinkRef :: TypeReference
|
||||
intRef = Reference.Builtin "Int"
|
||||
natRef = Reference.Builtin "Nat"
|
||||
floatRef = Reference.Builtin "Float"
|
||||
@ -275,7 +275,7 @@ effectRef = Reference.Builtin "Effect"
|
||||
termLinkRef = Reference.Builtin "Link.Term"
|
||||
typeLinkRef = Reference.Builtin "Link.Type"
|
||||
|
||||
builtinIORef, fileHandleRef, filePathRef, threadIdRef, socketRef :: Reference
|
||||
builtinIORef, fileHandleRef, filePathRef, threadIdRef, socketRef :: TypeReference
|
||||
builtinIORef = Reference.Builtin "IO"
|
||||
fileHandleRef = Reference.Builtin "Handle"
|
||||
filePathRef = Reference.Builtin "FilePath"
|
||||
@ -287,72 +287,72 @@ udpSocketRef = Reference.Builtin "UDPSocket"
|
||||
udpListenSocketRef = Reference.Builtin "ListenSocket"
|
||||
udpClientSockAddrRef = Reference.Builtin "ClientSockAddr"
|
||||
|
||||
processHandleRef :: Reference
|
||||
processHandleRef :: TypeReference
|
||||
processHandleRef = Reference.Builtin "ProcessHandle"
|
||||
|
||||
scopeRef, refRef :: Reference
|
||||
scopeRef, refRef :: TypeReference
|
||||
scopeRef = Reference.Builtin "Scope"
|
||||
refRef = Reference.Builtin "Ref"
|
||||
|
||||
iarrayRef, marrayRef :: Reference
|
||||
iarrayRef, marrayRef :: TypeReference
|
||||
iarrayRef = Reference.Builtin "ImmutableArray"
|
||||
marrayRef = Reference.Builtin "MutableArray"
|
||||
|
||||
ibytearrayRef, mbytearrayRef :: Reference
|
||||
ibytearrayRef, mbytearrayRef :: TypeReference
|
||||
ibytearrayRef = Reference.Builtin "ImmutableByteArray"
|
||||
mbytearrayRef = Reference.Builtin "MutableByteArray"
|
||||
|
||||
mvarRef, tvarRef :: Reference
|
||||
mvarRef, tvarRef :: TypeReference
|
||||
mvarRef = Reference.Builtin "MVar"
|
||||
tvarRef = Reference.Builtin "TVar"
|
||||
|
||||
ticketRef :: Reference
|
||||
ticketRef :: TypeReference
|
||||
ticketRef = Reference.Builtin "Ref.Ticket"
|
||||
|
||||
promiseRef :: Reference
|
||||
promiseRef :: TypeReference
|
||||
promiseRef = Reference.Builtin "Promise"
|
||||
|
||||
tlsRef :: Reference
|
||||
tlsRef :: TypeReference
|
||||
tlsRef = Reference.Builtin "Tls"
|
||||
|
||||
stmRef :: Reference
|
||||
stmRef :: TypeReference
|
||||
stmRef = Reference.Builtin "STM"
|
||||
|
||||
patternRef :: Reference
|
||||
patternRef :: TypeReference
|
||||
patternRef = Reference.Builtin "Pattern"
|
||||
|
||||
charClassRef :: Reference
|
||||
charClassRef :: TypeReference
|
||||
charClassRef = Reference.Builtin "Char.Class"
|
||||
|
||||
tlsClientConfigRef :: Reference
|
||||
tlsClientConfigRef :: TypeReference
|
||||
tlsClientConfigRef = Reference.Builtin "Tls.ClientConfig"
|
||||
|
||||
tlsServerConfigRef :: Reference
|
||||
tlsServerConfigRef :: TypeReference
|
||||
tlsServerConfigRef = Reference.Builtin "Tls.ServerConfig"
|
||||
|
||||
tlsSignedCertRef :: Reference
|
||||
tlsSignedCertRef :: TypeReference
|
||||
tlsSignedCertRef = Reference.Builtin "Tls.SignedCert"
|
||||
|
||||
tlsPrivateKeyRef :: Reference
|
||||
tlsPrivateKeyRef :: TypeReference
|
||||
tlsPrivateKeyRef = Reference.Builtin "Tls.PrivateKey"
|
||||
|
||||
tlsCipherRef :: Reference
|
||||
tlsCipherRef :: TypeReference
|
||||
tlsCipherRef = Reference.Builtin "Tls.Cipher"
|
||||
|
||||
tlsVersionRef :: Reference
|
||||
tlsVersionRef :: TypeReference
|
||||
tlsVersionRef = Reference.Builtin "Tls.Version"
|
||||
|
||||
hashAlgorithmRef :: Reference
|
||||
hashAlgorithmRef :: TypeReference
|
||||
hashAlgorithmRef = Reference.Builtin "crypto.HashAlgorithm"
|
||||
|
||||
codeRef, valueRef :: Reference
|
||||
codeRef, valueRef :: TypeReference
|
||||
codeRef = Reference.Builtin "Code"
|
||||
valueRef = Reference.Builtin "Value"
|
||||
|
||||
anyRef :: Reference
|
||||
anyRef :: TypeReference
|
||||
anyRef = Reference.Builtin "Any"
|
||||
|
||||
timeSpecRef :: Reference
|
||||
timeSpecRef :: TypeReference
|
||||
timeSpecRef = Reference.Builtin "TimeSpec"
|
||||
|
||||
any :: (Ord v) => a -> Type v a
|
||||
@ -569,7 +569,7 @@ unforall' :: Type v a -> ([v], Type v a)
|
||||
unforall' (ForallsNamed' vs t) = (vs, t)
|
||||
unforall' t = ([], t)
|
||||
|
||||
dependencies :: (Ord v) => Type v a -> Set Reference
|
||||
dependencies :: (Ord v) => Type v a -> Set TypeReference
|
||||
dependencies t = Set.fromList . Writer.execWriter $ ABT.visit' f t
|
||||
where
|
||||
f t@(Ref r) = Writer.tell [r] $> t
|
||||
@ -578,7 +578,7 @@ dependencies t = Set.fromList . Writer.execWriter $ ABT.visit' f t
|
||||
labeledDependencies :: (Ord v) => Type v a -> Set LD.LabeledDependency
|
||||
labeledDependencies = Set.map LD.TypeReference . dependencies
|
||||
|
||||
updateDependencies :: (Ord v) => Map Reference Reference -> Type v a -> Type v a
|
||||
updateDependencies :: (Ord v) => Map TypeReference TypeReference -> Type v a -> Type v a
|
||||
updateDependencies typeUpdates = ABT.rebuildUp go
|
||||
where
|
||||
go (Ref r) = Ref (Map.findWithDefault r r typeUpdates)
|
||||
@ -838,7 +838,7 @@ cleanup :: (Var v) => Type v a -> Type v a
|
||||
cleanup t | not Settings.cleanupTypes = t
|
||||
cleanup t = normalizeForallOrder . removePureEffects True . cleanupVars1 . cleanupAbilityLists $ t
|
||||
|
||||
builtinAbilities :: Set Reference
|
||||
builtinAbilities :: Set TypeReference
|
||||
builtinAbilities = Set.fromList [builtinIORef, stmRef]
|
||||
|
||||
instance (Show a) => Show (F a) where
|
||||
|
@ -1,6 +1,6 @@
|
||||
cabal-version: 1.12
|
||||
|
||||
-- This file has been generated from package.yaml by hpack version 0.35.2.
|
||||
-- This file has been generated from package.yaml by hpack version 0.36.0.
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
|
||||
@ -31,6 +31,7 @@ library
|
||||
Unison.DataDeclaration
|
||||
Unison.DataDeclaration.ConstructorId
|
||||
Unison.DataDeclaration.Names
|
||||
Unison.DataDeclaration.Records
|
||||
Unison.Hashable
|
||||
Unison.HashQualified
|
||||
Unison.HashQualified'
|
||||
|
@ -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.13 lib.jit
|
||||
jit-setup/main> pull @unison/internal/releases/0.0.14 lib.jit
|
||||
```
|
||||
|
||||
```unison
|
||||
|
@ -20,7 +20,7 @@ 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.13 lib.jit
|
||||
jit-setup/main> pull @unison/internal/releases/0.0.14 lib.jit
|
||||
|
||||
Downloaded 15053 entities.
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user